Page MenuHomeIsabelle/Phabricator
Files F1630075

No OneTemporary
Actions

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.
diff --git a/thys/CakeML_Codegen/Compiler/Compiler.thy b/thys/CakeML_Codegen/Compiler/Compiler.thy
--- a/thys/CakeML_Codegen/Compiler/Compiler.thy
+++ b/thys/CakeML_Codegen/Compiler/Compiler.thy
@@ -1,102 +1,102 @@
section \<open>Executable compilation chain\<close>
theory Compiler
imports Composition
begin
definition term_to_exp :: "C_info \<Rightarrow> rule fset \<Rightarrow> term \<Rightarrow> exp" where
"term_to_exp C_info rs t =
cakeml.mk_con C_info (heads_of rs |\<union>| constructors.C C_info)
(pterm_to_sterm (nterm_to_pterm (fresh_frun (term_to_nterm [] t) (heads_of rs |\<union>| constructors.C C_info))))"
lemma (in rules) "Compiler.term_to_exp C_info rs = term_to_cake"
unfolding term_to_exp_def by (simp add: all_consts_def)
primrec compress_pterm :: "pterm \<Rightarrow> pterm" where
"compress_pterm (Pabs cs) = Pabs (fcompress (map_prod id compress_pterm |`| cs))" |
"compress_pterm (Pconst name) = Pconst name" |
"compress_pterm (Pvar name) = Pvar name" |
"compress_pterm (t $\<^sub>p u) = compress_pterm t $\<^sub>p compress_pterm u"
lemma compress_pterm_eq[simp]: "compress_pterm t = t"
-by (induction t) (auto simp: subst_pabs_id fset_map_snd_id map_prod_def fmember.rep_eq)
+by (induction t) (auto simp: subst_pabs_id fset_map_snd_id map_prod_def fmember_iff_member_fset)
definition compress_crule_set :: "crule_set \<Rightarrow> crule_set" where
"compress_crule_set = fcompress \<circ> fimage (map_prod id fcompress)"
definition compress_irule_set :: "irule_set \<Rightarrow> irule_set" where
"compress_irule_set = fcompress \<circ> fimage (map_prod id (fcompress \<circ> fimage (map_prod id compress_pterm)))"
definition compress_prule_set :: "prule fset \<Rightarrow> prule fset" where
"compress_prule_set = fcompress \<circ> fimage (map_prod id compress_pterm)"
lemma compress_crule_set_eq[simp]: "compress_crule_set rs = rs"
unfolding compress_crule_set_def by force
lemma compress_irule_set_eq[simp]: "compress_irule_set rs = rs"
unfolding compress_irule_set_def map_prod_def by simp
lemma compress_prule_set[simp]: "compress_prule_set rs = rs"
unfolding compress_prule_set_def by force
definition transform_irule_set_iter :: "irule_set \<Rightarrow> irule_set" where
"transform_irule_set_iter rs = ((transform_irule_set \<circ> compress_irule_set) ^^ max_arity rs) rs"
definition as_sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env \<Rightarrow> v sem_env" where
"as_sem_env C_info rs env =
\<lparr> sem_env.v =
build_rec_env (cakeml.mk_letrec_body C_info (fset_of_list (map fst rs) |\<union>| constructors.C C_info) rs) env nsEmpty,
sem_env.c =
nsEmpty \<rparr>"
definition empty_sem_env :: "C_info \<Rightarrow> v sem_env" where
"empty_sem_env C_info = \<lparr> sem_env.v = nsEmpty, sem_env.c = constructors.as_static_cenv C_info \<rparr>"
definition sem_env :: "C_info \<Rightarrow> srule list \<Rightarrow> v sem_env" where
"sem_env C_info rs = extend_dec_env (as_sem_env C_info rs (empty_sem_env C_info)) (empty_sem_env C_info)"
definition compile :: "C_info \<Rightarrow> rule fset \<Rightarrow> Ast.prog" where
"compile C_info =
CakeML_Backend.compile' C_info \<circ>
Rewriting_Sterm.compile \<circ>
compress_prule_set \<circ>
Rewriting_Pterm.compile \<circ>
transform_irule_set_iter \<circ>
compress_irule_set \<circ>
Rewriting_Pterm_Elim.compile \<circ>
compress_crule_set \<circ>
Rewriting_Nterm.consts_of \<circ>
fcompress \<circ>
Rewriting_Nterm.compile' C_info \<circ>
fcompress"
definition compile_to_env :: "C_info \<Rightarrow> rule fset \<Rightarrow> v sem_env" where
"compile_to_env C_info =
sem_env C_info \<circ>
Rewriting_Sterm.compile \<circ>
compress_prule_set \<circ>
Rewriting_Pterm.compile \<circ>
transform_irule_set_iter \<circ>
compress_irule_set \<circ>
Rewriting_Pterm_Elim.compile \<circ>
compress_crule_set \<circ>
Rewriting_Nterm.consts_of \<circ>
fcompress \<circ>
Rewriting_Nterm.compile' C_info \<circ>
fcompress"
lemma (in rules) "Compiler.compile_to_env C_info rs = rules.cake_sem_env C_info rs"
unfolding Compiler.compile_to_env_def Compiler.sem_env_def Compiler.as_sem_env_def Compiler.empty_sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.sem_env_def
unfolding rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_sem_env_def
unfolding empty_sem_env_def
by (auto simp:
Compiler.compress_irule_set_eq[abs_def]
Composition.transform_irule_set_iter_def[abs_def]
Compiler.transform_irule_set_iter_def[abs_def] comp_def pre_constants.all_consts_def)
export_code
term_to_exp compile compile_to_env
checking Scala
end
\ No newline at end of file
diff --git a/thys/CakeML_Codegen/Compiler/Composition.thy b/thys/CakeML_Codegen/Compiler/Composition.thy
--- a/thys/CakeML_Codegen/Compiler/Composition.thy
+++ b/thys/CakeML_Codegen/Compiler/Composition.thy
@@ -1,1081 +1,1081 @@
section \<open>Composition of correctness results\<close>
theory Composition
imports "../Backend/CakeML_Correctness"
begin
hide_const (open) sem_env.v
text \<open>@{typ term} \<open>\<longrightarrow>\<close> @{typ nterm} \<open>\<longrightarrow>\<close> @{typ pterm} \<open>\<longrightarrow>\<close> @{typ sterm}\<close>
subsection \<open>Reflexive-transitive closure of @{thm [source=true] irules.compile_correct}.\<close>
lemma (in prules) prewrite_closed:
assumes "rs \<turnstile>\<^sub>p t \<longrightarrow> t'" "closed t"
shows "closed t'"
using assms proof induction
case (step name rhs)
thus ?case
using all_rules by force
next
case (beta c)
obtain pat rhs where "c = (pat, rhs)" by (cases c) auto
with beta have "closed_except rhs (frees pat)"
by (auto simp: closed_except_simps)
show ?case
apply (rule rewrite_step_closed[OF _ beta(2)[unfolded \<open>c = _\<close>]])
using \<open>closed_except rhs (frees pat)\<close> beta by (auto simp: closed_except_def)
qed (auto simp: closed_except_def)
corollary (in prules) prewrite_rt_closed:
assumes "rs \<turnstile>\<^sub>p t \<longrightarrow>* t'" "closed t"
shows "closed t'"
using assms
by induction (auto intro: prewrite_closed)
corollary (in irules) compile_correct_rt:
assumes "Rewriting_Pterm.compile rs \<turnstile>\<^sub>p t \<longrightarrow>* t'" "finished rs"
shows "rs \<turnstile>\<^sub>i t \<longrightarrow>* t'"
using assms proof (induction rule: rtranclp_induct)
case step
thus ?case
by (meson compile_correct rtranclp.simps)
qed auto
subsection \<open>Reflexive-transitive closure of @{thm [source=true] prules.compile_correct}.\<close>
lemma (in prules) compile_correct_rt:
assumes "Rewriting_Sterm.compile rs \<turnstile>\<^sub>s u \<longrightarrow>* u'"
shows "rs \<turnstile>\<^sub>p sterm_to_pterm u \<longrightarrow>* sterm_to_pterm u'"
using assms proof induction
case step
thus ?case
by (meson compile_correct rtranclp.simps)
qed auto
lemma srewrite_stepD:
assumes "srewrite_step rs name t"
shows "(name, t) \<in> set rs"
using assms by induct auto
lemma (in srules) srewrite_wellformed:
assumes "rs \<turnstile>\<^sub>s t \<longrightarrow> t'" "wellformed t"
shows "wellformed t'"
using assms proof induction
case (step name rhs)
hence "(name, rhs) \<in> set rs"
by (auto dest: srewrite_stepD)
thus ?case
using all_rules by (auto simp: list_all_iff)
next
case (beta cs t t')
then obtain pat rhs env where "(pat, rhs) \<in> set cs" "match pat t = Some env" "t' = subst rhs env"
by (elim rewrite_firstE)
show ?case
unfolding \<open>t' = _\<close>
proof (rule subst_wellformed)
show "wellformed rhs"
using \<open>(pat, rhs) \<in> set cs\<close> beta by (auto simp: list_all_iff)
next
show "wellformed_env env"
using \<open>match pat t = Some env\<close> beta
by (auto intro: wellformed.match)
qed
qed auto
lemma (in srules) srewrite_wellformed_rt:
assumes "rs \<turnstile>\<^sub>s t \<longrightarrow>* t'" "wellformed t"
shows "wellformed t'"
using assms
by induction (auto intro: srewrite_wellformed)
lemma vno_abs_value_to_sterm: "no_abs (value_to_sterm v) \<longleftrightarrow> vno_abs v" for v
by (induction v) (auto simp: no_abs.list_comb list_all_iff)
subsection \<open>Reflexive-transitive closure of @{thm [source=true] rules.compile_correct}.\<close>
corollary (in rules) compile_correct_rt:
assumes "compile \<turnstile>\<^sub>n u \<longrightarrow>* u'" "closed u"
shows "rs \<turnstile> nterm_to_term' u \<longrightarrow>* nterm_to_term' u'"
using assms
proof induction
case (step u' u'')
hence "rs \<turnstile> nterm_to_term' u \<longrightarrow>* nterm_to_term' u'"
by auto
also have "rs \<turnstile> nterm_to_term' u' \<longrightarrow> nterm_to_term' u''"
using step by (auto dest: rewrite_rt_closed intro!: compile_correct simp: closed_except_def)
finally show ?case .
qed auto
subsection \<open>Reflexive-transitive closure of @{thm [source=true] irules.transform_correct}.\<close>
corollary (in irules) transform_correct_rt:
assumes "transform_irule_set rs \<turnstile>\<^sub>i u \<longrightarrow>* u''" "t \<approx>\<^sub>p u" "closed t"
obtains t'' where "rs \<turnstile>\<^sub>i t \<longrightarrow>* t''" "t'' \<approx>\<^sub>p u''"
using assms proof (induction arbitrary: thesis t)
case (step u' u'')
obtain t' where "rs \<turnstile>\<^sub>i t \<longrightarrow>* t'" "t' \<approx>\<^sub>p u'"
using step by blast
obtain t'' where "rs \<turnstile>\<^sub>i t' \<longrightarrow>* t''" "t'' \<approx>\<^sub>p u''"
apply (rule transform_correct)
apply (rule \<open>transform_irule_set rs \<turnstile>\<^sub>i u' \<longrightarrow> u''\<close>)
apply (rule \<open>t' \<approx>\<^sub>p u'\<close>)
apply (rule irewrite_rt_closed)
apply (rule \<open>rs \<turnstile>\<^sub>i t \<longrightarrow>* t'\<close>)
apply (rule \<open>closed t\<close>)
apply blast
done
show ?case
apply (rule step.prems)
apply (rule rtranclp_trans)
apply fact+
done
qed blast
corollary (in irules) transform_correct_rt_no_abs:
assumes "transform_irule_set rs \<turnstile>\<^sub>i t \<longrightarrow>* u" "closed t" "no_abs u"
shows "rs \<turnstile>\<^sub>i t \<longrightarrow>* u"
proof -
have "t \<approx>\<^sub>p t" by (rule prelated_refl)
obtain t' where "rs \<turnstile>\<^sub>i t \<longrightarrow>* t'" "t' \<approx>\<^sub>p u"
apply (rule transform_correct_rt)
apply (rule assms)
apply (rule \<open>t \<approx>\<^sub>p t\<close>)
apply (rule assms)
apply blast
done
thus ?thesis
using assms by (metis prelated_no_abs_right)
qed
corollary transform_correct_rt_n_no_abs0:
assumes "irules C rs" "(transform_irule_set ^^ n) rs \<turnstile>\<^sub>i t \<longrightarrow>* u" "closed t" "no_abs u"
shows "rs \<turnstile>\<^sub>i t \<longrightarrow>* u"
using assms(1,2) proof (induction n arbitrary: rs)
case (Suc n)
interpret irules C rs by fact
show ?case
apply (rule transform_correct_rt_no_abs)
apply (rule Suc.IH)
apply (rule rules_transform)
using Suc(3) apply (simp add: funpow_swap1)
apply fact+
done
qed auto
corollary (in irules) transform_correct_rt_n_no_abs:
assumes "(transform_irule_set ^^ n) rs \<turnstile>\<^sub>i t \<longrightarrow>* u" "closed t" "no_abs u"
shows "rs \<turnstile>\<^sub>i t \<longrightarrow>* u"
by (rule transform_correct_rt_n_no_abs0) (rule irules_axioms assms)+
hide_fact transform_correct_rt_n_no_abs0
subsection \<open>Iterated application of @{const transform_irule_set}.\<close>
definition max_arity :: "irule_set \<Rightarrow> nat" where
"max_arity rs = fMax ((arity \<circ> snd) |`| rs)"
lemma rules_transform_iter0:
assumes "irules C_info rs"
shows "irules C_info ((transform_irule_set ^^ n) rs)"
using assms
by (induction n) (auto intro: irules.rules_transform del: irulesI)
lemma (in irules) rules_transform_iter: "irules C_info ((transform_irule_set ^^ n) rs)"
by (rule rules_transform_iter0) (rule irules_axioms)
lemma transform_irule_set_n_heads: "fst |`| ((transform_irule_set ^^ n) rs) = fst |`| rs"
by (induction n) (auto simp: transform_irule_set_heads)
hide_fact rules_transform_iter0
definition transform_irule_set_iter :: "irule_set \<Rightarrow> irule_set" where
"transform_irule_set_iter rs = (transform_irule_set ^^ max_arity rs) rs"
lemma transform_irule_set_iter_heads: "fst |`| transform_irule_set_iter rs = fst |`| rs"
unfolding transform_irule_set_iter_def by (simp add: transform_irule_set_n_heads)
lemma (in irules) finished_alt_def: "finished rs \<longleftrightarrow> max_arity rs = 0"
proof
assume "max_arity rs = 0"
hence "\<not> fBex ((arity \<circ> snd) |`| rs) (\<lambda>x. 0 < x)"
using nonempty
unfolding max_arity_def
by (metis fBex_fempty fmax_ex_gr not_less0)
thus "finished rs"
unfolding finished_def
by force
next
assume "finished rs"
have "fMax ((arity \<circ> snd) |`| rs) \<le> 0"
proof (rule fMax_le)
show "fBall ((arity \<circ> snd) |`| rs) (\<lambda>x. x \<le> 0)"
using \<open>finished rs\<close> unfolding finished_def by force
next
show "(arity \<circ> snd) |`| rs \<noteq> {||}"
using nonempty by force
qed
thus "max_arity rs = 0"
unfolding max_arity_def by simp
qed
lemma (in irules) transform_finished_id: "finished rs \<Longrightarrow> transform_irule_set rs = rs"
unfolding transform_irule_set_def finished_def transform_irules_def map_prod_def id_apply
-by (rule fset_map_snd_id) (auto simp: fmember.rep_eq elim!: fBallE)
+by (rule fset_map_snd_id) (auto simp: fmember_iff_member_fset elim!: fBallE)
lemma (in irules) max_arity_decr: "max_arity (transform_irule_set rs) = max_arity rs - 1"
proof (cases "finished rs")
case True
thus ?thesis
by (auto simp: transform_finished_id finished_alt_def)
next
case False
have "(arity \<circ> snd) |`| transform_irule_set rs = (\<lambda>x. x - 1) |`| (arity \<circ> snd) |`| rs"
unfolding transform_irule_set_def fset.map_comp
proof (rule fset.map_cong0, safe, unfold o_apply map_prod_simp id_apply snd_conv)
fix name irs
assume "(name, irs) \<in> fset rs"
hence "(name, irs) |\<in>| rs"
- by (simp add: fmember.rep_eq)
+ by (simp add: fmember_iff_member_fset)
hence "arity_compatibles irs" "irs \<noteq> {||}"
using nonempty inner by (blast dest: fpairwiseD)+
thus "arity (transform_irules irs) = arity irs - 1"
by (simp add: arity_transform_irules)
qed
hence "max_arity (transform_irule_set rs) = fMax ((\<lambda>x. x - 1) |`| (arity \<circ> snd) |`| rs)"
unfolding max_arity_def by simp
also have "\<dots> = fMax ((arity \<circ> snd) |`| rs) - 1"
proof (rule fmax_decr)
show "fBex ((arity \<circ> snd) |`| rs) ((\<le>) 1)"
using False unfolding finished_def by force
qed
finally show ?thesis
unfolding max_arity_def
by simp
qed
lemma max_arity_decr'0:
assumes "irules C rs"
shows "max_arity ((transform_irule_set ^^ n) rs) = max_arity rs - n"
proof (induction n)
case (Suc n)
show ?case
apply simp
apply (subst irules.max_arity_decr)
using Suc assms by (auto intro: irules.rules_transform_iter del: irulesI)
qed auto
lemma (in irules) max_arity_decr': "max_arity ((transform_irule_set ^^ n) rs) = max_arity rs - n"
by (rule max_arity_decr'0) (rule irules_axioms)
hide_fact max_arity_decr'0
lemma (in irules) transform_finished: "finished (transform_irule_set_iter rs)"
unfolding transform_irule_set_iter_def
by (subst irules.finished_alt_def)
(auto simp: max_arity_decr' intro: rules_transform_iter del: Rewriting_Pterm_Elim.irulesI)
text \<open>Trick as described in \<open>\<section>7.1\<close> in the locale manual.\<close>
locale irules' = irules
sublocale irules' \<subseteq> irules'_as_irules: irules C_info "transform_irule_set_iter rs"
unfolding transform_irule_set_iter_def by (rule rules_transform_iter)
sublocale crules \<subseteq> crules_as_irules': irules' C_info "Rewriting_Pterm_Elim.compile rs"
unfolding irules'_def by (fact compile_rules)
sublocale irules' \<subseteq> irules'_as_prules: prules C_info "Rewriting_Pterm.compile (transform_irule_set_iter rs)"
by (rule irules'_as_irules.compile_rules) (rule transform_finished)
subsection \<open>Big-step semantics\<close>
context srules begin
definition global_css :: "(name, sclauses) fmap" where
"global_css = fmap_of_list (map (map_prod id clauses) rs)"
lemma fmdom_global_css: "fmdom global_css = fst |`| fset_of_list rs"
unfolding global_css_def by simp
definition as_vrules :: "vrule list" where
"as_vrules = map (\<lambda>(name, _). (name, Vrecabs global_css name fmempty)) rs"
lemma as_vrules_fst[simp]: "fst |`| fset_of_list as_vrules = fst |`| fset_of_list rs"
unfolding as_vrules_def
apply simp
apply (rule fset.map_cong)
apply (rule refl)
by auto
lemma as_vrules_fst'[simp]: "map fst as_vrules = map fst rs"
unfolding as_vrules_def
by auto
lemma list_all_as_vrulesI:
assumes "list_all (\<lambda>(_, t). P fmempty (clauses t)) rs"
assumes "R (fst |`| fset_of_list rs)"
shows "list_all (\<lambda>(_, t). value_pred.pred P Q R t) as_vrules"
proof (rule list_allI, safe)
fix name rhs
assume "(name, rhs) \<in> set as_vrules"
hence "rhs = Vrecabs global_css name fmempty"
unfolding as_vrules_def by auto
moreover have "fmpred (\<lambda>_. P fmempty) global_css"
unfolding global_css_def list.pred_map
using assms by (auto simp: list_all_iff intro!: fmpred_of_list)
moreover have "name |\<in>| fmdom global_css"
unfolding global_css_def
apply auto
using \<open>(name, rhs) \<in> set as_vrules\<close> unfolding as_vrules_def
including fset.lifting apply transfer'
by force
moreover have "R (fmdom global_css)"
using assms unfolding global_css_def
by auto
ultimately show "value_pred.pred P Q R rhs"
by (simp add: value_pred.pred_alt_def)
qed
lemma srules_as_vrules: "vrules C_info as_vrules"
proof (standard, unfold as_vrules_fst)
have "list_all (\<lambda>(_, t). vwellformed t) as_vrules"
unfolding vwellformed_def
apply (rule list_all_as_vrulesI)
apply (rule list.pred_mono_strong)
apply (rule all_rules)
apply (auto elim: clausesE)
done
moreover have "list_all (\<lambda>(_, t). vclosed t) as_vrules"
unfolding vclosed_def
apply (rule list_all_as_vrulesI)
apply auto
apply (rule list.pred_mono_strong)
apply (rule all_rules)
apply (auto elim: clausesE simp: Sterm.closed_except_simps)
done
moreover have "list_all (\<lambda>(_, t). \<not> is_Vconstr t) as_vrules"
unfolding as_vrules_def
by (auto simp: list_all_iff)
ultimately show "list_all vrule as_vrules"
unfolding list_all_iff by fastforce
next
show "distinct (map fst as_vrules)"
using distinct by auto
next
show "fdisjnt (fst |`| fset_of_list rs) C"
using disjnt by simp
next
show "list_all (\<lambda>(_, rhs). not_shadows_vconsts rhs) as_vrules"
unfolding not_shadows_vconsts_def
apply (rule list_all_as_vrulesI)
apply auto
apply (rule list.pred_mono_strong)
apply (rule not_shadows)
by (auto simp: list_all_iff list_ex_iff all_consts_def elim!: clausesE)
next
show "vconstructor_value_rs as_vrules"
unfolding vconstructor_value_rs_def
apply (rule conjI)
unfolding vconstructor_value_def
apply (rule list_all_as_vrulesI)
apply (simp add: list_all_iff)
apply simp
apply simp
using disjnt by simp
next
show "list_all (\<lambda>(_, rhs). vwelldefined rhs) as_vrules"
unfolding vwelldefined_def
apply (rule list_all_as_vrulesI)
apply auto
apply (rule list.pred_mono_strong)
apply (rule swelldefined_rs)
apply auto
apply (erule clausesE)
apply hypsubst_thin
apply (subst (asm) welldefined_sabs)
by simp
next
show "distinct all_constructors"
by (fact distinct_ctr)
qed
sublocale srules_as_vrules: vrules C_info as_vrules
by (fact srules_as_vrules)
lemma rs'_rs_eq: "srules_as_vrules.rs' = rs"
unfolding srules_as_vrules.rs'_def
unfolding as_vrules_def
apply (subst map_prod_def)
apply simp
unfolding comp_def
apply (subst case_prod_twice)
apply (rule list_map_snd_id)
unfolding global_css_def
using all_rules map
apply (auto simp: list_all_iff map_of_is_map map_of_map map_prod_def fmap_of_list.rep_eq)
subgoal for a b
by (erule ballE[where x = "(a, b)"], cases b, auto simp: is_abs_def term_cases_def)
done
lemma veval_correct:
fixes v
assumes "as_vrules, fmempty \<turnstile>\<^sub>v t \<down> v" "wellformed t" "closed t"
shows "rs, fmempty \<turnstile>\<^sub>s t \<down> value_to_sterm v"
using assms
by (rule srules_as_vrules.veval_correct[unfolded rs'_rs_eq])
end
subsection \<open>ML-style semantics\<close>
context srules begin
lemma as_vrules_mk_rec_env: "fmap_of_list as_vrules = mk_rec_env global_css fmempty"
apply (subst global_css_def)
apply (subst as_vrules_def)
apply (subst mk_rec_env_def)
apply (rule fmap_ext)
apply (subst fmlookup_fmmap_keys)
apply (subst fmap_of_list.rep_eq)
apply (subst fmap_of_list.rep_eq)
apply (subst map_of_map_keyed)
apply (subst (2) map_prod_def)
apply (subst id_apply)
apply (subst map_of_map)
apply simp
apply (subst option.map_comp)
apply (rule option.map_cong)
apply (rule refl)
apply simp
apply (subst global_css_def)
apply (rule refl)
done
abbreviation (input) "vrelated \<equiv> srules_as_vrules.vrelated"
notation srules_as_vrules.vrelated ("\<turnstile>\<^sub>v/ _ \<approx> _" [0, 50] 50)
lemma vrecabs_global_css_refl:
assumes "name |\<in>| fmdom global_css"
shows "\<turnstile>\<^sub>v Vrecabs global_css name fmempty \<approx> Vrecabs global_css name fmempty"
using assms
proof (coinduction arbitrary: name)
case vrelated
have "rel_option (\<lambda>v\<^sub>1 v\<^sub>2. (\<exists>name. v\<^sub>1 = Vrecabs global_css name fmempty \<and> v\<^sub>2 = Vrecabs global_css name fmempty \<and> name |\<in>| fmdom global_css) \<or> \<turnstile>\<^sub>v v\<^sub>1 \<approx> v\<^sub>2) (fmlookup (fmap_of_list as_vrules) y) (fmlookup (mk_rec_env global_css fmempty) y)" for y
apply (subst as_vrules_mk_rec_env)
apply (rule option.rel_refl_strong)
apply (rule disjI1)
apply (simp add: mk_rec_env_def)
apply (elim conjE exE)
by (auto intro: fmdomI)
with vrelated show ?case
by fastforce
qed
lemma as_vrules_refl_rs: "fmrel_on_fset (fst |`| fset_of_list as_vrules) vrelated (fmap_of_list as_vrules) (fmap_of_list as_vrules)"
apply rule
apply (subst (2) as_vrules_def)
apply (subst (2) as_vrules_def)
apply (simp add: fmap_of_list.rep_eq)
apply (rule rel_option_reflI)
apply simp
apply (drule map_of_SomeD)
apply auto
apply (rule vrecabs_global_css_refl)
unfolding global_css_def
by (auto simp: fset_of_list_elem intro: rev_fimage_eqI)
lemma as_vrules_refl_C: "fmrel_on_fset C vrelated (fmap_of_list as_vrules) (fmap_of_list as_vrules)"
proof
fix c
assume "c |\<in>| C"
hence "c |\<notin>| fset_of_list (map fst as_vrules)"
using srules_as_vrules.vconstructor_value_rs
unfolding vconstructor_value_rs_def fdisjnt_alt_def
by auto
hence "c |\<notin>| fmdom (fmap_of_list as_vrules)"
by simp
hence "fmlookup (fmap_of_list as_vrules) c = None"
by (metis fmdom_notD)
thus "rel_option vrelated (fmlookup (fmap_of_list as_vrules) c) (fmlookup (fmap_of_list as_vrules) c)"
by simp
qed
lemma veval'_correct'':
fixes t v
assumes "fmap_of_list as_vrules \<turnstile>\<^sub>v t \<down> v"
assumes "wellformed t"
assumes "\<not> shadows_consts t"
assumes "welldefined t"
assumes "closed t"
assumes "vno_abs v"
shows "as_vrules, fmempty \<turnstile>\<^sub>v t \<down> v"
proof -
obtain v\<^sub>1 where "as_vrules, fmempty \<turnstile>\<^sub>v t \<down> v\<^sub>1" "\<turnstile>\<^sub>v v\<^sub>1 \<approx> v"
using \<open>fmap_of_list as_vrules \<turnstile>\<^sub>v t \<down> v\<close>
proof (rule srules_as_vrules.veval'_correct', unfold as_vrules_fst)
show "wellformed t" "\<not> shadows_consts t" "closed t" "consts t |\<subseteq>| all_consts"
by fact+
next
show "wellformed_venv (fmap_of_list as_vrules)"
apply rule
using srules_as_vrules.all_rules
apply (auto simp: list_all_iff)
done
next
show "not_shadows_vconsts_env (fmap_of_list as_vrules) "
apply rule
using srules_as_vrules.not_shadows
apply (auto simp: list_all_iff)
done
next
have "fmrel_on_fset (fst |`| fset_of_list as_vrules |\<union>| C) vrelated (fmap_of_list as_vrules) (fmap_of_list as_vrules)"
apply (rule fmrel_on_fset_unionI)
apply (rule as_vrules_refl_rs)
apply (rule as_vrules_refl_C)
done
show "fmrel_on_fset (consts t) vrelated (fmap_of_list as_vrules) (fmap_of_list as_vrules)"
apply (rule fmrel_on_fsubset)
apply fact+
using assms by (auto simp: all_consts_def)
qed
thus ?thesis
using assms by (metis srules_as_vrules.vrelated.eq_right)
qed
end
subsection \<open>CakeML\<close>
context srules begin
definition as_sem_env :: "v sem_env \<Rightarrow> v sem_env" where
"as_sem_env env = \<lparr> sem_env.v = build_rec_env (mk_letrec_body all_consts rs) env nsEmpty, sem_env.c = nsEmpty \<rparr>"
lemma compile_sem_env:
"evaluate_dec ck mn env state (compile_group all_consts rs) (state, Rval (as_sem_env env))"
unfolding compile_group_def as_sem_env_def
apply (rule evaluate_dec.dletrec1)
unfolding mk_letrec_body_def Let_def
apply (simp add:comp_def case_prod_twice)
using name_as_string.fst_distinct[OF distinct]
by auto
lemma compile_sem_env':
"fun_evaluate_decs mn state env [(compile_group all_consts rs)] = (state, Rval (as_sem_env env))"
unfolding compile_group_def as_sem_env_def mk_letrec_body_def Let_def
apply (simp add: comp_def case_prod_twice)
using name_as_string.fst_distinct[OF distinct]
by auto
lemma compile_prog[unfolded combine_dec_result.simps, simplified]:
"evaluate_prog ck env state (compile rs) (state, combine_dec_result (as_sem_env env) (Rval \<lparr> sem_env.v = nsEmpty, sem_env.c = nsEmpty \<rparr>))"
unfolding compile_def
apply (rule evaluate_prog.cons1)
apply rule
apply (rule evaluate_top.tdec1)
apply (rule compile_sem_env)
apply (rule evaluate_prog.empty)
done
lemma compile_prog'[unfolded combine_dec_result.simps, simplified]:
"fun_evaluate_prog state env (compile rs) = (state, combine_dec_result (as_sem_env env) (Rval \<lparr> sem_env.v = nsEmpty, sem_env.c = nsEmpty \<rparr>))"
unfolding compile_def fun_evaluate_prog_def no_dup_mods_def no_dup_top_types_def prog_to_mods_def prog_to_top_types_def decs_to_types_def
using compile_sem_env' compile_group_def by simp
definition sem_env :: "v sem_env" where
"sem_env \<equiv> extend_dec_env (as_sem_env empty_sem_env) empty_sem_env"
(* FIXME introduce lemma: is_cupcake_all_env extend_dec_env *)
(* FIXME introduce lemma: is_cupcake_all_env empty_sem_env *)
lemma cupcake_sem_env: "is_cupcake_all_env sem_env"
unfolding as_sem_env_def sem_env_def
apply (rule is_cupcake_all_envI)
apply (simp add: extend_dec_env_def empty_sem_env_def nsEmpty_def)
apply (rule cupcake_nsAppend_preserve)
apply (rule cupcake_build_rec_preserve)
apply (simp add: empty_sem_env_def)
apply (simp add: nsEmpty_def)
apply (rule mk_letrec_cupcake)
apply simp
apply (simp add: empty_sem_env_def)
done
lemma sem_env_refl: "fmrel related_v (fmap_of_list as_vrules) (fmap_of_ns (sem_env.v sem_env))"
proof
fix name
show "rel_option related_v (fmlookup (fmap_of_list as_vrules) name) (fmlookup (fmap_of_ns (sem_env.v sem_env)) name)"
apply (simp add:
as_sem_env_def build_rec_env_fmap cake_mk_rec_env_def sem_env_def
fmap_of_list.rep_eq map_of_map_keyed option.rel_map
as_vrules_def mk_letrec_body_def comp_def case_prod_twice)
apply (rule option.rel_refl_strong)
apply (rule related_v.rec_closure)
apply auto[]
apply (simp add:
fmmap_of_list[symmetric, unfolded apsnd_def map_prod_def id_def] fmap.rel_map
global_css_def Let_def map_prod_def comp_def case_prod_twice)
apply (thin_tac "map_of rs name = _")
apply (rule fmap.rel_refl_strong)
apply simp
subgoal premises prems for rhs
proof -
obtain name where "(name, rhs) \<in> set rs"
using prems
including fmap.lifting
by transfer' (auto dest: map_of_SomeD)
hence "is_abs rhs" "closed rhs" "welldefined rhs"
using all_rules swelldefined_rs by (auto simp add: list_all_iff)
then obtain cs where "clauses rhs = cs" "rhs = Sabs cs" "wellformed_clauses cs"
using \<open>(name, rhs) \<in> set rs\<close> all_rules
by (cases rhs) (auto simp: list_all_iff is_abs_def term_cases_def)
show ?thesis
unfolding related_fun_alt_def \<open>clauses rhs = cs\<close>
proof (intro conjI)
show "list_all2 (rel_prod related_pat related_exp) cs (map (\<lambda>(pat, t). (mk_ml_pat (mk_pat pat), mk_con (frees pat |\<union>| all_consts) t)) cs)"
unfolding list.rel_map
apply (rule list.rel_refl_strong)
apply (rename_tac z, case_tac z, hypsubst_thin)
apply simp
subgoal premises prems for pat t
proof (rule mk_exp_correctness)
have "\<not> shadows_consts rhs"
using \<open>(name, rhs) \<in> set rs\<close> not_shadows
by (auto simp: list_all_iff all_consts_def)
thus "\<not> shadows_consts t"
unfolding \<open>rhs = Sabs cs\<close> using prems
by (auto simp: list_all_iff list_ex_iff)
next
have "frees t |\<subseteq>| frees pat"
using \<open>closed rhs\<close> prems unfolding \<open>rhs = _\<close>
apply (auto simp: list_all_iff Sterm.closed_except_simps)
apply (erule ballE[where x = "(pat, t)"])
apply (auto simp: closed_except_def)
done
moreover have "consts t |\<subseteq>| all_consts"
using \<open>welldefined rhs\<close> prems unfolding \<open>rhs = _\<close> welldefined_sabs
by (auto simp: list_all_iff all_consts_def)
ultimately show "ids t |\<subseteq>| frees pat |\<union>| all_consts"
unfolding ids_def by auto
qed (auto simp: all_consts_def)
done
next
have 1: "frees (Sabs cs) = {||}"
using \<open>closed rhs\<close> unfolding \<open>rhs = Sabs cs\<close>
by (auto simp: closed_except_def)
have 2: "welldefined rhs"
using swelldefined_rs \<open>(name, rhs) \<in> set rs\<close>
by (auto simp: list_all_iff)
show "fresh_fNext all_consts |\<notin>| ids (Sabs cs)"
apply (rule fNext_not_member_subset)
unfolding ids_def 1
using 2 \<open>rhs = _\<close> by (simp add: all_consts_def del: consts_sterm.simps)
next
show "fresh_fNext all_consts |\<notin>| all_consts"
by (rule fNext_not_member)
qed
qed
done
qed
lemma semantic_correctness':
assumes "cupcake_evaluate_single sem_env (mk_con all_consts t) (Rval ml_v)"
assumes "welldefined t" "closed t" "\<not> shadows_consts t" "wellformed t"
obtains v where "fmap_of_list as_vrules \<turnstile>\<^sub>v t \<down> v" "related_v v ml_v"
using assms(1) proof (rule semantic_correctness)
show "is_cupcake_all_env sem_env"
by (fact cupcake_sem_env)
next
show "related_exp t (mk_con all_consts t)"
apply (rule mk_exp_correctness)
using assms
unfolding ids_def closed_except_def by (auto simp: all_consts_def)
next
show "wellformed t" "\<not> shadows_consts t" by fact+
next
show "closed_except t (fmdom (fmap_of_list as_vrules))"
using \<open>closed t\<close> by (auto simp: closed_except_def)
next
show "closed_venv (fmap_of_list as_vrules)"
apply (rule fmpred_of_list)
using srules_as_vrules.all_rules
by (auto simp: list_all_iff)
show "wellformed_venv (fmap_of_list as_vrules)"
apply (rule fmpred_of_list)
using srules_as_vrules.all_rules
by (auto simp: list_all_iff)
next
have 1: "fmpred (\<lambda>_. list_all (\<lambda>(pat, t). consts t |\<subseteq>| C |\<union>| fmdom global_css)) global_css"
apply (subst (2) global_css_def)
apply (rule fmpred_of_list)
apply (auto simp: map_prod_def)
subgoal premises prems for pat t
proof -
from prems obtain cs where "t = Sabs cs"
by (elim clausesE)
have "welldefined t"
using swelldefined_rs prems
by (auto simp: list_all_iff fmdom_global_css)
show ?thesis
using \<open>welldefined t\<close>
unfolding \<open>t = _\<close> welldefined_sabs
by (auto simp: all_consts_def list_all_iff fmdom_global_css)
qed
done
show "fmpred (\<lambda>_. vwelldefined') (fmap_of_list as_vrules)"
apply (rule fmpred_of_list)
unfolding as_vrules_def
apply simp
apply (erule imageE)
apply (auto split: prod.splits)
apply (subst fdisjnt_alt_def)
apply simp
apply (rule 1)
apply (subst global_css_def)
apply simp
subgoal for x1 x2
apply (rule fimage_eqI[where x = "(x1, x2)"])
by (auto simp: fset_of_list_elem)
subgoal
using disjnt by (auto simp: fdisjnt_alt_def fmdom_global_css)
done
next
show "not_shadows_vconsts_env (fmap_of_list as_vrules)"
apply (rule fmpred_of_list)
using srules_as_vrules.not_shadows
unfolding list_all_iff
by auto
next
show "fdisjnt C (fmdom (fmap_of_list as_vrules))"
using disjnt by (auto simp: fdisjnt_alt_def)
next
show "fmrel_on_fset (ids t) related_v (fmap_of_list as_vrules) (fmap_of_ns (sem_env.v sem_env))"
unfolding fmrel_on_fset_fmrel_restrict
apply (rule fmrel_restrict_fset)
apply (rule sem_env_refl)
done
next
show "consts t |\<subseteq>| fmdom (fmap_of_list as_vrules) |\<union>| C"
apply (subst fmdom_fmap_of_list)
apply (subst as_vrules_fst')
apply simp
using assms by (auto simp: all_consts_def)
qed blast
end
fun cake_to_value :: "v \<Rightarrow> value" where
"cake_to_value (Conv (Some (name, _)) vs) = Vconstr (Name name) (map cake_to_value vs)"
context cakeml' begin
lemma cake_to_value_abs_free:
assumes "is_cupcake_value v" "cake_no_abs v"
shows "vno_abs (cake_to_value v)"
using assms by (induction v) (auto elim: is_cupcake_value.elims simp: list_all_iff)
lemma cake_to_value_related:
assumes "cake_no_abs v" "is_cupcake_value v"
shows "related_v (cake_to_value v) v"
using assms proof (induction v)
case (Conv c vs)
then obtain name tid where "c = Some ((as_string name), TypeId (Short tid))"
apply (elim is_cupcake_value.elims)
subgoal
by (metis name.sel v.simps(2))
by auto
show ?case
unfolding \<open>c = _\<close>
apply simp
apply (rule related_v.conv)
apply (simp add: list.rel_map)
apply (rule list.rel_refl_strong)
apply (rule Conv)
using Conv unfolding \<open>c = _\<close>
by (auto simp: list_all_iff)
qed auto
lemma related_v_abs_free_uniq:
assumes "related_v v\<^sub>1 ml_v" "related_v v\<^sub>2 ml_v" "cake_no_abs ml_v"
shows "v\<^sub>1 = v\<^sub>2"
using assms proof (induction arbitrary: v\<^sub>2)
case (conv vs\<^sub>1 ml_vs name)
then obtain vs\<^sub>2 where "v\<^sub>2 = Vconstr name vs\<^sub>2" "list_all2 related_v vs\<^sub>2 ml_vs"
by (auto elim: related_v.cases simp: name.expand)
moreover have "list_all cake_no_abs ml_vs"
using conv by simp
have "list_all2 (=) vs\<^sub>1 vs\<^sub>2"
using \<open>list_all2 _ vs\<^sub>1 _\<close> \<open>list_all2 _ vs\<^sub>2 _\<close> \<open>list_all cake_no_abs ml_vs\<close>
by (induction arbitrary: vs\<^sub>2 rule: list.rel_induct) (auto simp: list_all2_Cons2)
thus ?case
unfolding \<open>v\<^sub>2 = _\<close>
by (simp add: list.rel_eq)
qed auto
corollary related_v_abs_free_cake_to_value:
assumes "related_v v ml_v" "cake_no_abs ml_v" "is_cupcake_value ml_v"
shows "v = cake_to_value ml_v"
using assms by (metis cake_to_value_related related_v_abs_free_uniq)
end
context srules begin
lemma cupcake_sem_env_preserve:
assumes "cupcake_evaluate_single sem_env (mk_con S t) (Rval ml_v)" "wellformed t"
shows "is_cupcake_value ml_v"
apply (rule cupcake_single_preserve[OF assms(1)])
apply (rule cupcake_sem_env)
apply (rule mk_exp_cupcake)
apply fact
done
lemma semantic_correctness'':
assumes "cupcake_evaluate_single sem_env (mk_con all_consts t) (Rval ml_v)"
assumes "welldefined t" "closed t" "\<not> shadows_consts t" "wellformed t"
assumes "cake_no_abs ml_v"
shows "fmap_of_list as_vrules \<turnstile>\<^sub>v t \<down> cake_to_value ml_v"
using assms
by (metis cupcake_sem_env_preserve semantic_correctness' related_v_abs_free_cake_to_value)
end
subsection \<open>Composition\<close>
context rules begin
abbreviation term_to_nterm where
"term_to_nterm t \<equiv> fresh_frun (Term_to_Nterm.term_to_nterm [] t) all_consts"
abbreviation sterm_to_cake where
"sterm_to_cake \<equiv> rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.mk_con all_consts"
abbreviation "term_to_cake t \<equiv> sterm_to_cake (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
abbreviation "cake_to_term t \<equiv> (convert_term (value_to_sterm (cake_to_value t)) :: term)"
abbreviation "cake_sem_env \<equiv> rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.sem_env"
definition "compiled \<equiv> rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_vrules"
lemma fmdom_compiled: "fmdom (fmap_of_list compiled) = heads_of rs"
unfolding compiled_def
by (simp add:
rules_as_nrules.crules_as_irules'.irules'_as_prules.compile_heads
Rewriting_Pterm.compile_heads transform_irule_set_iter_heads
Rewriting_Pterm_Elim.compile_heads
compile_heads consts_of_heads)
lemma cake_semantic_correctness:
assumes "cupcake_evaluate_single cake_sem_env (sterm_to_cake t) (Rval ml_v)"
assumes "welldefined t" "closed t" "\<not> shadows_consts t" "wellformed t"
assumes "cake_no_abs ml_v"
shows "fmap_of_list compiled \<turnstile>\<^sub>v t \<down> cake_to_value ml_v"
unfolding compiled_def
apply (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.semantic_correctness'')
using assms
by (simp_all add:
rules_as_nrules.crules_as_irules'.irules'_as_prules.compile_heads
Rewriting_Pterm.compile_heads transform_irule_set_iter_heads
Rewriting_Pterm_Elim.compile_heads
compile_heads consts_of_heads all_consts_def)
text \<open>Lo and behold, this is the final correctness theorem!\<close>
theorem compiled_correct:
\<comment> \<open>If CakeML evaluation of a term succeeds ...\<close>
assumes "\<exists>k. Evaluate_Single.evaluate cake_sem_env (s \<lparr> clock := k \<rparr>) (term_to_cake t) = (s', Rval ml_v)"
\<comment> \<open>... producing a constructor term without closures ...\<close>
assumes "cake_no_abs ml_v"
\<comment> \<open>... and some syntactic properties of the involved terms hold ...\<close>
assumes "closed t" "\<not> shadows_consts t" "welldefined t" "wellformed t"
\<comment> \<open>... then this evaluation can be reproduced in the term-rewriting semantics\<close>
shows "rs \<turnstile> t \<longrightarrow>* cake_to_term ml_v"
proof -
let ?heads = "fst |`| fset_of_list rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_vrules"
have "?heads = heads_of rs"
using fmdom_compiled unfolding compiled_def by simp
have "wellformed (nterm_to_pterm (term_to_nterm t))"
by auto
hence "wellformed (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
by (auto intro: pterm_to_sterm_wellformed)
have "is_cupcake_all_env cake_sem_env"
by (rule rules_as_nrules.nrules_as_crules.crules_as_irules'.irules'_as_prules.prules_as_srules.cupcake_sem_env)
have "is_cupcake_exp (term_to_cake t)"
by (rule rules_as_nrules.nrules_as_crules.crules_as_irules'.irules'_as_prules.prules_as_srules.srules_as_cake.mk_exp_cupcake) fact
obtain k where "Evaluate_Single.evaluate cake_sem_env (s \<lparr> clock := k \<rparr>) (term_to_cake t) = (s', Rval ml_v)"
using assms by blast
then have "Big_Step_Unclocked_Single.evaluate cake_sem_env (s \<lparr> clock := (clock s') \<rparr>) (term_to_cake t) (s', Rval ml_v)"
using unclocked_single_fun_eq by fastforce
have "cupcake_evaluate_single cake_sem_env (sterm_to_cake (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))) (Rval ml_v)"
apply (rule cupcake_single_complete)
apply fact+
done
hence "is_cupcake_value ml_v"
apply (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.cupcake_sem_env_preserve)
by (auto intro: pterm_to_sterm_wellformed)
hence "vno_abs (cake_to_value ml_v)"
using \<open>cake_no_abs _\<close>
by (metis rules_as_nrules.nrules_as_crules.crules_as_irules'.irules'_as_prules.prules_as_srules.srules_as_cake.cake_to_value_abs_free)
hence "no_abs (value_to_sterm (cake_to_value ml_v))"
by (metis vno_abs_value_to_sterm)
hence "no_abs (sterm_to_pterm (value_to_sterm (cake_to_value ml_v)))"
by (metis sterm_to_pterm convert_term_no_abs)
have "welldefined (term_to_nterm t)"
unfolding term_to_nterm'_def
apply (subst fresh_frun_def)
apply (subst pred_stateD[OF term_to_nterm_consts])
apply (subst surjective_pairing)
apply (rule refl)
apply fact
done
have "welldefined (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
apply (subst pterm_to_sterm_consts)
apply fact
apply (subst consts_nterm_to_pterm)
apply fact+
done
have "\<not> shadows_consts t"
using assms unfolding shadows_consts_def fdisjnt_alt_def
by auto
hence "\<not> shadows_consts (term_to_nterm t)"
unfolding shadows_consts_def shadows_consts_def
apply auto
using term_to_nterm_all_vars[folded wellformed_term_def]
by (metis assms(6) fdisjnt_swap sup_idem)
have "\<not> shadows_consts (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
apply (subst pterm_to_sterm_shadows[symmetric])
apply fact
apply (subst shadows_nterm_to_pterm)
unfolding shadows_consts_def
apply simp
apply (rule term_to_nterm_all_vars[where T = "fempty", simplified, THEN fdisjnt_swap])
apply (fold wellformed_term_def)
apply fact
using \<open>closed t\<close> unfolding closed_except_def by (auto simp: fdisjnt_alt_def)
have "closed (term_to_nterm t)"
using assms unfolding closed_except_def
using term_to_nterm_vars unfolding wellformed_term_def by blast
hence "closed (nterm_to_pterm (term_to_nterm t))"
using closed_nterm_to_pterm unfolding closed_except_def
by auto
have "closed (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
unfolding closed_except_def
apply (subst pterm_to_sterm_frees)
apply fact
using \<open>closed (term_to_nterm t)\<close> closed_nterm_to_pterm unfolding closed_except_def
by auto
have "fmap_of_list compiled \<turnstile>\<^sub>v pterm_to_sterm (nterm_to_pterm (term_to_nterm t)) \<down> cake_to_value ml_v"
by (rule cake_semantic_correctness) fact+
hence "fmap_of_list rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_vrules \<turnstile>\<^sub>v pterm_to_sterm (nterm_to_pterm (term_to_nterm t)) \<down> cake_to_value ml_v"
using assms unfolding compiled_def by simp
hence "rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.as_vrules, fmempty \<turnstile>\<^sub>v pterm_to_sterm (nterm_to_pterm (term_to_nterm t)) \<down> cake_to_value ml_v"
proof (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.veval'_correct'')
show "\<not> rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.shadows_consts (pterm_to_sterm (nterm_to_pterm (term_to_nterm t)))"
using \<open>\<not> shadows_consts (_::sterm)\<close> \<open>?heads = heads_of rs\<close> by auto
next
show "consts (pterm_to_sterm (nterm_to_pterm (term_to_nterm t))) |\<subseteq>| rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.all_consts"
using \<open>welldefined (pterm_to_sterm _)\<close> \<open>?heads = _\<close> by auto
qed fact+
hence "Rewriting_Sterm.compile (Rewriting_Pterm.compile (transform_irule_set_iter (Rewriting_Pterm_Elim.compile (consts_of compile)))), fmempty \<turnstile>\<^sub>s pterm_to_sterm (nterm_to_pterm (term_to_nterm t)) \<down> value_to_sterm (cake_to_value ml_v)"
by (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.veval_correct) fact+
hence "Rewriting_Sterm.compile (Rewriting_Pterm.compile (transform_irule_set_iter (Rewriting_Pterm_Elim.compile (consts_of compile)))) \<turnstile>\<^sub>s pterm_to_sterm (nterm_to_pterm (term_to_nterm t)) \<longrightarrow>* value_to_sterm (cake_to_value ml_v)"
by (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.prules_as_srules.seval_correct) fact
hence "Rewriting_Pterm.compile (transform_irule_set_iter (Rewriting_Pterm_Elim.compile (consts_of compile))) \<turnstile>\<^sub>p sterm_to_pterm (pterm_to_sterm (nterm_to_pterm (term_to_nterm t))) \<longrightarrow>* sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
by (rule rules_as_nrules.crules_as_irules'.irules'_as_prules.compile_correct_rt)
hence "Rewriting_Pterm.compile (transform_irule_set_iter (Rewriting_Pterm_Elim.compile (consts_of compile))) \<turnstile>\<^sub>p nterm_to_pterm (term_to_nterm t) \<longrightarrow>* sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
by (subst (asm) pterm_to_sterm_sterm_to_pterm) fact
hence "transform_irule_set_iter (Rewriting_Pterm_Elim.compile (consts_of compile)) \<turnstile>\<^sub>i nterm_to_pterm (term_to_nterm t) \<longrightarrow>* sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
by (rule rules_as_nrules.crules_as_irules'.irules'_as_irules.compile_correct_rt)
(rule rules_as_nrules.crules_as_irules.transform_finished)
have "Rewriting_Pterm_Elim.compile (consts_of compile) \<turnstile>\<^sub>i nterm_to_pterm (term_to_nterm t) \<longrightarrow>* sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
apply (rule rules_as_nrules.crules_as_irules.transform_correct_rt_n_no_abs)
using \<open>transform_irule_set_iter _ \<turnstile>\<^sub>i _ \<longrightarrow>* _\<close> unfolding transform_irule_set_iter_def
apply simp
apply fact+
done
then obtain t' where "compile \<turnstile>\<^sub>n term_to_nterm t \<longrightarrow>* t'" "t' \<approx>\<^sub>i sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
using \<open>closed (term_to_nterm t)\<close>
by (metis rules_as_nrules.compile_correct_rt)
hence "no_abs t'"
using \<open>no_abs (sterm_to_pterm _)\<close>
by (metis irelated_no_abs)
have "rs \<turnstile> nterm_to_term' (term_to_nterm t) \<longrightarrow>* nterm_to_term' t'"
by (rule compile_correct_rt) fact+
hence "rs \<turnstile> t \<longrightarrow>* nterm_to_term' t'"
apply (subst (asm) fresh_frun_def)
apply (subst (asm) term_to_nterm_nterm_to_term[where S = "fempty" and t = t, simplified])
apply (fold wellformed_term_def)
apply fact
using assms unfolding closed_except_def by auto
have "nterm_to_pterm t' = sterm_to_pterm (value_to_sterm (cake_to_value ml_v))"
using \<open>t' \<approx>\<^sub>i _\<close>
by auto
hence "(convert_term t' :: pterm) = convert_term (value_to_sterm (cake_to_value ml_v))"
apply (subst (asm) nterm_to_pterm)
apply fact
apply (subst (asm) sterm_to_pterm)
apply fact
apply assumption
done
hence "nterm_to_term' t' = convert_term (value_to_sterm (cake_to_value ml_v))"
apply (subst nterm_to_term')
apply (rule \<open>no_abs t'\<close>)
apply (rule convert_term_inj)
subgoal premises
apply (rule convert_term_no_abs)
apply fact
done
subgoal premises
apply (rule convert_term_no_abs)
apply fact
done
apply (subst convert_term_idem)
apply (rule \<open>no_abs t'\<close>)
apply (subst convert_term_idem)
apply (rule \<open>no_abs (value_to_sterm (cake_to_value ml_v))\<close>)
apply assumption
done
thus ?thesis
using \<open>rs \<turnstile> t \<longrightarrow>* nterm_to_term' t'\<close> by simp
qed
end
end
\ No newline at end of file
diff --git a/thys/CakeML_Codegen/Rewriting/Rewriting_Pterm_Elim.thy b/thys/CakeML_Codegen/Rewriting/Rewriting_Pterm_Elim.thy
--- a/thys/CakeML_Codegen/Rewriting/Rewriting_Pterm_Elim.thy
+++ b/thys/CakeML_Codegen/Rewriting/Rewriting_Pterm_Elim.thy
@@ -1,1733 +1,1733 @@
section \<open>Higher-order term rewriting with explicit pattern matching\<close>
theory Rewriting_Pterm_Elim
imports
Rewriting_Nterm
"../Terms/Pterm"
begin
subsection \<open>Intermediate rule sets\<close>
type_synonym irules = "(term list \<times> pterm) fset"
type_synonym irule_set = "(name \<times> irules) fset"
locale pre_irules = constants C_info "fst |`| rs" for C_info and rs :: "irule_set"
locale irules = pre_irules +
assumes fmap: "is_fmap rs"
assumes nonempty: "rs \<noteq> {||}"
assumes inner:
"fBall rs (\<lambda>(_, irs).
arity_compatibles irs \<and>
is_fmap irs \<and>
patterns_compatibles irs \<and>
irs \<noteq> {||} \<and>
fBall irs (\<lambda>(pats, rhs).
linears pats \<and>
abs_ish pats rhs \<and>
closed_except rhs (freess pats) \<and>
fdisjnt (freess pats) all_consts \<and>
wellformed rhs \<and>
\<not> shadows_consts rhs \<and>
welldefined rhs))"
lemma (in pre_irules) irulesI:
assumes "\<And>name irs. (name, irs) |\<in>| rs \<Longrightarrow> arity_compatibles irs"
assumes "\<And>name irs. (name, irs) |\<in>| rs \<Longrightarrow> is_fmap irs"
assumes "\<And>name irs. (name, irs) |\<in>| rs \<Longrightarrow> patterns_compatibles irs"
assumes "\<And>name irs. (name, irs) |\<in>| rs \<Longrightarrow> irs \<noteq> {||}"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> linears pats"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> abs_ish pats rhs"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> fdisjnt (freess pats) all_consts"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> closed_except rhs (freess pats)"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> wellformed rhs"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> \<not> shadows_consts rhs"
assumes "\<And>name irs pats rhs. (name, irs) |\<in>| rs \<Longrightarrow> (pats, rhs) |\<in>| irs \<Longrightarrow> welldefined rhs"
assumes "is_fmap rs" "rs \<noteq> {||}"
shows "irules C_info rs"
using assms unfolding irules_axioms_def irules_def
by (auto simp: prod_fBallI intro: pre_irules_axioms)
lemmas irulesI[intro!] = pre_irules.irulesI[unfolded pre_irules_def]
subsubsection \<open>Translation from @{typ nterm} to @{typ pterm}\<close>
fun nterm_to_pterm :: "nterm \<Rightarrow> pterm" where
"nterm_to_pterm (Nvar s) = Pvar s" |
"nterm_to_pterm (Nconst s) = Pconst s" |
"nterm_to_pterm (t\<^sub>1 $\<^sub>n t\<^sub>2) = nterm_to_pterm t\<^sub>1 $\<^sub>p nterm_to_pterm t\<^sub>2" |
"nterm_to_pterm (\<Lambda>\<^sub>n x. t) = (\<Lambda>\<^sub>p x. nterm_to_pterm t)"
lemma nterm_to_pterm_inj: "nterm_to_pterm x = nterm_to_pterm y \<Longrightarrow> x = y"
by (induction y arbitrary: x) (auto elim: nterm_to_pterm.elims)
lemma nterm_to_pterm:
assumes "no_abs t"
shows "nterm_to_pterm t = convert_term t"
using assms
apply induction
apply auto
by (auto simp: free_nterm_def free_pterm_def const_nterm_def const_pterm_def app_nterm_def app_pterm_def)
lemma nterm_to_pterm_frees[simp]: "frees (nterm_to_pterm t) = frees t"
by (induct t) auto
lemma closed_nterm_to_pterm[intro]: "closed_except (nterm_to_pterm t) (frees t)"
unfolding closed_except_def by simp
lemma (in constants) shadows_nterm_to_pterm[simp]: "shadows_consts (nterm_to_pterm t) = shadows_consts t"
by (induct t) (auto simp: shadows_consts_def fdisjnt_alt_def)
lemma wellformed_nterm_to_pterm[intro]: "wellformed (nterm_to_pterm t)"
by (induct t) auto
lemma consts_nterm_to_pterm[simp]: "consts (nterm_to_pterm t) = consts t"
by (induct t) auto
subsubsection \<open>Translation from @{typ crule_set} to @{typ irule_set}\<close>
definition translate_crules :: "crules \<Rightarrow> irules" where
"translate_crules = fimage (map_prod id nterm_to_pterm)"
definition compile :: "crule_set \<Rightarrow> irule_set" where
"compile = fimage (map_prod id translate_crules)"
lemma compile_heads: "fst |`| compile rs = fst |`| rs"
unfolding compile_def by simp
lemma (in crules) compile_rules: "irules C_info (compile rs)"
proof
have "is_fmap rs"
using fmap by simp
thus "is_fmap (compile rs)"
unfolding compile_def map_prod_def id_apply by (rule is_fmap_image)
show "compile rs \<noteq> {||}"
using nonempty unfolding compile_def by auto
show "constants C_info (fst |`| compile rs)"
proof
show "fdisjnt (fst |`| compile rs) C"
using disjnt unfolding compile_def
by force
next
show "distinct all_constructors"
by (fact distinct_ctr)
qed
fix name irs
assume irs: "(name, irs) |\<in>| compile rs"
then obtain irs' where "(name, irs') |\<in>| rs" "irs = translate_crules irs'"
unfolding compile_def by force
hence "arity_compatibles irs'"
using inner by (blast dest: fpairwiseD)
thus "arity_compatibles irs"
unfolding \<open>irs = translate_crules irs'\<close> translate_crules_def
by (force dest: fpairwiseD)
have "patterns_compatibles irs'"
using \<open>(name, irs') |\<in>| rs\<close> inner
by (blast dest: fpairwiseD)
thus "patterns_compatibles irs"
unfolding \<open>irs = _\<close> translate_crules_def
by (auto dest: fpairwiseD)
have "is_fmap irs'"
using \<open>(name, irs') |\<in>| rs\<close> inner by auto
thus "is_fmap irs"
unfolding \<open>irs = translate_crules irs'\<close> translate_crules_def map_prod_def id_apply
by (rule is_fmap_image)
have "irs' \<noteq> {||}"
using \<open>(name, irs') |\<in>| rs\<close> inner by auto
thus "irs \<noteq> {||}"
unfolding \<open>irs = translate_crules irs'\<close> translate_crules_def by simp
fix pats rhs
assume "(pats, rhs) |\<in>| irs"
then obtain rhs' where "(pats, rhs') |\<in>| irs'" "rhs = nterm_to_pterm rhs'"
unfolding \<open>irs = translate_crules irs'\<close> translate_crules_def by force
hence "linears pats" "pats \<noteq> []" "frees rhs' |\<subseteq>| freess pats" "\<not> shadows_consts rhs'"
using fbspec[OF inner \<open>(name, irs') |\<in>| rs\<close>]
by blast+
show "linears pats" by fact
show "closed_except rhs (freess pats)"
unfolding \<open>rhs = nterm_to_pterm rhs'\<close>
using \<open>frees rhs' |\<subseteq>| freess pats\<close>
by (metis dual_order.trans closed_nterm_to_pterm closed_except_def)
show "wellformed rhs"
unfolding \<open>rhs = nterm_to_pterm rhs'\<close> by auto
have "fdisjnt (freess pats) all_consts"
using \<open>(pats, rhs') |\<in>| irs'\<close> \<open>(name, irs') |\<in>| rs\<close> inner
by blast
thus "fdisjnt (freess pats) (pre_constants.all_consts C_info (fst |`| compile rs))"
unfolding compile_def by simp
have "\<not> shadows_consts rhs"
unfolding \<open>rhs = _\<close> using \<open>\<not> shadows_consts _\<close> by simp
thus "\<not> pre_constants.shadows_consts C_info (fst |`| compile rs) rhs"
unfolding compile_heads .
show "abs_ish pats rhs"
using \<open>pats \<noteq> []\<close> unfolding abs_ish_def by simp
have "welldefined rhs'"
using fbspec[OF inner \<open>(name, irs') |\<in>| rs\<close>, simplified]
using \<open>(pats, rhs') |\<in>| irs'\<close>
by blast
thus "pre_constants.welldefined C_info (fst |`| compile rs) rhs"
unfolding compile_def \<open>rhs = _\<close>
by simp
qed
sublocale crules \<subseteq> crules_as_irules: irules C_info "compile rs"
by (fact compile_rules)
subsubsection \<open>Transformation of @{typ irule_set}\<close>
definition transform_irules :: "irules \<Rightarrow> irules" where
"transform_irules rs = (
if arity rs = 0 then rs
else map_prod id Pabs |`| fgroup_by (\<lambda>(pats, rhs). (butlast pats, (last pats, rhs))) rs)"
lemma arity_compatibles_transform_irules:
assumes "arity_compatibles rs"
shows "arity_compatibles (transform_irules rs)"
proof (cases "arity rs = 0")
case True
thus ?thesis
unfolding transform_irules_def using assms by simp
next
case False
let ?rs' = "transform_irules rs"
let ?f = "\<lambda>(pats, rhs). (butlast pats, (last pats, rhs))"
let ?grp = "fgroup_by ?f rs"
have rs': "?rs' = map_prod id Pabs |`| ?grp"
using False unfolding transform_irules_def by simp
show ?thesis
proof safe
fix pats\<^sub>1 rhs\<^sub>1 pats\<^sub>2 rhs\<^sub>2
assume "(pats\<^sub>1, rhs\<^sub>1) |\<in>| ?rs'" "(pats\<^sub>2, rhs\<^sub>2) |\<in>| ?rs'"
then obtain rhs\<^sub>1' rhs\<^sub>2' where "(pats\<^sub>1, rhs\<^sub>1') |\<in>| ?grp" "(pats\<^sub>2, rhs\<^sub>2') |\<in>| ?grp"
unfolding rs' by auto
then obtain pats\<^sub>1' pats\<^sub>2' x y \<comment> \<open>dummies\<close>
where "fst (?f (pats\<^sub>1', x)) = pats\<^sub>1" "(pats\<^sub>1', x) |\<in>| rs"
and "fst (?f (pats\<^sub>2', y)) = pats\<^sub>2" "(pats\<^sub>2', y) |\<in>| rs"
by (fastforce simp: split_beta elim: fgroup_byE2)
hence "pats\<^sub>1 = butlast pats\<^sub>1'" "pats\<^sub>2 = butlast pats\<^sub>2'" "length pats\<^sub>1' = length pats\<^sub>2'"
using assms by (force dest: fpairwiseD)+
thus "length pats\<^sub>1 = length pats\<^sub>2"
by auto
qed
qed
lemma arity_transform_irules:
assumes "arity_compatibles rs" "rs \<noteq> {||}"
shows "arity (transform_irules rs) = (if arity rs = 0 then 0 else arity rs - 1)"
proof (cases "arity rs = 0")
case True
thus ?thesis
unfolding transform_irules_def by simp
next
case False
let ?f = "\<lambda>(pats, rhs). (butlast pats, (last pats, rhs))"
let ?grp = "fgroup_by ?f rs"
let ?rs' = "map_prod id Pabs |`| ?grp"
have "arity ?rs' = arity rs - 1"
proof (rule arityI)
show "fBall ?rs' (\<lambda>(pats, _). length pats = arity rs - 1)"
proof (rule prod_fBallI)
fix pats rhs
assume "(pats, rhs) |\<in>| ?rs'"
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
by force
then obtain pats' x \<comment> \<open>dummy\<close>
where "pats = butlast pats'" "(pats', x) |\<in>| rs"
by (fastforce simp: split_beta elim: fgroup_byE2)
hence "length pats' = arity rs"
using assms by (metis arity_compatible_length)
thus "length pats = arity rs - 1"
unfolding \<open>pats = butlast pats'\<close> using False by simp
qed
next
show "?rs' \<noteq> {||}"
using assms by (simp add: fgroup_by_nonempty)
qed
with False show ?thesis
unfolding transform_irules_def by simp
qed
definition transform_irule_set :: "irule_set \<Rightarrow> irule_set" where
"transform_irule_set = fimage (map_prod id transform_irules)"
lemma transform_irule_set_heads: "fst |`| transform_irule_set rs = fst |`| rs"
unfolding transform_irule_set_def by simp
lemma (in irules) rules_transform: "irules C_info (transform_irule_set rs)"
proof
have "is_fmap rs"
using fmap by simp
thus "is_fmap (transform_irule_set rs)"
unfolding transform_irule_set_def map_prod_def id_apply by (rule is_fmap_image)
show "transform_irule_set rs \<noteq> {||}"
using nonempty unfolding transform_irule_set_def by auto
show "constants C_info (fst |`| transform_irule_set rs)"
proof
show "fdisjnt (fst |`| transform_irule_set rs) C"
using disjnt unfolding transform_irule_set_def
by force
next
show "distinct all_constructors"
by (fact distinct_ctr)
qed
fix name irs
assume irs: "(name, irs) |\<in>| transform_irule_set rs"
then obtain irs' where "(name, irs') |\<in>| rs" "irs = transform_irules irs'"
unfolding transform_irule_set_def by force
hence "arity_compatibles irs'"
using inner by (blast dest: fpairwiseD)
thus "arity_compatibles irs"
unfolding \<open>irs = transform_irules irs'\<close> by (rule arity_compatibles_transform_irules)
have "irs' \<noteq> {||}"
using \<open>(name, irs') |\<in>| rs\<close> inner by blast
thus "irs \<noteq> {||}"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (simp add: fgroup_by_nonempty)
let ?f = "\<lambda>(pats, rhs). (butlast pats, (last pats, rhs))"
let ?grp = "fgroup_by ?f irs'"
have "patterns_compatibles irs'"
using \<open>(name, irs') |\<in>| rs\<close> inner
by (blast dest: fpairwiseD)
show "patterns_compatibles irs"
proof (cases "arity irs' = 0")
case True
thus ?thesis
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
using \<open>patterns_compatibles irs'\<close> by simp
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
show ?thesis
proof safe
fix pats\<^sub>1 rhs\<^sub>1 pats\<^sub>2 rhs\<^sub>2
assume "(pats\<^sub>1, rhs\<^sub>1) |\<in>| irs" "(pats\<^sub>2, rhs\<^sub>2) |\<in>| irs"
with irs' obtain cs\<^sub>1 cs\<^sub>2 where "(pats\<^sub>1, cs\<^sub>1) |\<in>| ?grp" "(pats\<^sub>2, cs\<^sub>2) |\<in>| ?grp"
by force
then obtain pats\<^sub>1' pats\<^sub>2' and x y \<comment> \<open>dummies\<close>
where "(pats\<^sub>1', x) |\<in>| irs'" "(pats\<^sub>2', y) |\<in>| irs'"
and "pats\<^sub>1 = butlast pats\<^sub>1'" "pats\<^sub>2 = butlast pats\<^sub>2'"
unfolding irs'
by (fastforce elim: fgroup_byE2)
hence "patterns_compatible pats\<^sub>1' pats\<^sub>2'"
using \<open>patterns_compatibles irs'\<close> by (auto dest: fpairwiseD)
thus "patterns_compatible pats\<^sub>1 pats\<^sub>2"
unfolding \<open>pats\<^sub>1 = _\<close> \<open>pats\<^sub>2 = _\<close>
by auto
qed
qed
have "is_fmap irs'"
using \<open>(name, irs') |\<in>| rs\<close> inner by blast
show "is_fmap irs"
proof (cases "arity irs' = 0")
case True
thus ?thesis
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
using \<open>is_fmap irs'\<close> by simp
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
show ?thesis
proof
fix pats rhs\<^sub>1 rhs\<^sub>2
assume "(pats, rhs\<^sub>1) |\<in>| irs" "(pats, rhs\<^sub>2) |\<in>| irs"
with irs' obtain cs\<^sub>1 cs\<^sub>2
where "(pats, cs\<^sub>1) |\<in>| ?grp" "rhs\<^sub>1 = Pabs cs\<^sub>1"
and "(pats, cs\<^sub>2) |\<in>| ?grp" "rhs\<^sub>2 = Pabs cs\<^sub>2"
by force
moreover have "is_fmap ?grp"
by auto
ultimately show "rhs\<^sub>1 = rhs\<^sub>2"
by (auto dest: is_fmapD)
qed
qed
fix pats rhs
assume "(pats, rhs) |\<in>| irs"
show "linears pats"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
then obtain pats' x \<comment> \<open>dummy\<close>
where "fst (?f (pats', x)) = pats" "(pats', x) |\<in>| irs'"
by (fastforce simp: split_beta elim: fgroup_byE2)
hence "pats = butlast pats'"
by simp
moreover have "linears pats'"
using \<open>(pats', x) |\<in>| irs'\<close> \<open>(name, irs') |\<in>| rs\<close> inner
by blast
ultimately show ?thesis
by auto
qed
have "fdisjnt (freess pats) all_consts"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
then obtain pats' x \<comment> \<open>dummy\<close>
where "fst (?f (pats', x)) = pats" "(pats', x) |\<in>| irs'"
by (fastforce simp: split_beta elim: fgroup_byE2)
hence "pats = butlast pats'"
by simp
moreover have "fdisjnt (freess pats') all_consts"
using \<open>(pats', x) |\<in>| irs'\<close> \<open>(name, irs') |\<in>| rs\<close> inner by blast
ultimately show ?thesis
by (metis subsetI in_set_butlastD freess_subset fdisjnt_subset_left)
qed
thus "fdisjnt (freess pats) (pre_constants.all_consts C_info (fst |`| transform_irule_set rs))"
unfolding transform_irule_set_def by simp
show "closed_except rhs (freess pats)"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
show ?thesis
unfolding \<open>rhs = Pabs cs\<close> closed_except_simps
proof safe
fix pat t
assume "(pat, t) |\<in>| cs"
then obtain pats' where "(pats', t) |\<in>| irs'" "?f (pats', t) = (pats, (pat, t))"
using \<open>(pats, cs) |\<in>| ?grp\<close> by auto
hence "closed_except t (freess pats')"
using \<open>(name, irs') |\<in>| rs\<close> inner by blast
have "pats' \<noteq> []"
using \<open>arity_compatibles irs'\<close> \<open>(pats', t) |\<in>| irs'\<close> False
by (metis list.size(3) arity_compatible_length)
hence "pats' = pats @ [pat]"
using \<open>?f (pats', t) = (pats, (pat, t))\<close>
by (fastforce simp: split_beta snoc_eq_iff_butlast)
hence "freess pats |\<union>| frees pat = freess pats'"
unfolding freess_def by auto
thus "closed_except t (freess pats |\<union>| frees pat)"
using \<open>closed_except t (freess pats')\<close> by simp
qed
qed
show "wellformed rhs"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
show ?thesis
unfolding \<open>rhs = Pabs cs\<close>
proof (rule wellformed_PabsI)
show "cs \<noteq> {||}"
using \<open>(pats, cs) |\<in>| ?grp\<close> \<open>irs' \<noteq> {||}\<close>
by (meson femptyE fgroup_by_nonempty_inner)
next
show "is_fmap cs"
proof
fix pat t\<^sub>1 t\<^sub>2
assume "(pat, t\<^sub>1) |\<in>| cs" "(pat, t\<^sub>2) |\<in>| cs"
then obtain pats\<^sub>1' pats\<^sub>2'
where "(pats\<^sub>1', t\<^sub>1) |\<in>| irs'" "?f (pats\<^sub>1', t\<^sub>1) = (pats, (pat, t\<^sub>1))"
and "(pats\<^sub>2', t\<^sub>2) |\<in>| irs'" "?f (pats\<^sub>2', t\<^sub>2) = (pats, (pat, t\<^sub>2))"
using \<open>(pats, cs) |\<in>| ?grp\<close> by force
moreover hence "pats\<^sub>1' \<noteq> []" "pats\<^sub>2' \<noteq> []"
using \<open>arity_compatibles irs'\<close> False
unfolding prod.case
by (metis list.size(3) arity_compatible_length)+
ultimately have "pats\<^sub>1' = pats @ [pat]" "pats\<^sub>2' = pats @ [pat]"
unfolding split_beta fst_conv snd_conv
by (metis prod.inject snoc_eq_iff_butlast)+
with \<open>is_fmap irs'\<close> show "t\<^sub>1 = t\<^sub>2"
using \<open>(pats\<^sub>1', t\<^sub>1) |\<in>| irs'\<close> \<open>(pats\<^sub>2', t\<^sub>2) |\<in>| irs'\<close>
by (blast dest: is_fmapD)
qed
next
show "pattern_compatibles cs"
proof safe
fix pat\<^sub>1 rhs\<^sub>1 pat\<^sub>2 rhs\<^sub>2
assume "(pat\<^sub>1, rhs\<^sub>1) |\<in>| cs" "(pat\<^sub>2, rhs\<^sub>2) |\<in>| cs"
then obtain pats\<^sub>1' pats\<^sub>2'
where "(pats\<^sub>1', rhs\<^sub>1) |\<in>| irs'" "?f (pats\<^sub>1', rhs\<^sub>1) = (pats, (pat\<^sub>1, rhs\<^sub>1))"
and "(pats\<^sub>2', rhs\<^sub>2) |\<in>| irs'" "?f (pats\<^sub>2', rhs\<^sub>2) = (pats, (pat\<^sub>2, rhs\<^sub>2))"
using \<open>(pats, cs) |\<in>| ?grp\<close>
by force
moreover hence "pats\<^sub>1' \<noteq> []" "pats\<^sub>2' \<noteq> []"
using \<open>arity_compatibles irs'\<close> False
unfolding prod.case
by (metis list.size(3) arity_compatible_length)+
ultimately have "pats\<^sub>1' = pats @ [pat\<^sub>1]" "pats\<^sub>2' = pats @ [pat\<^sub>2]"
unfolding split_beta fst_conv snd_conv
by (metis prod.inject snoc_eq_iff_butlast)+
moreover have "patterns_compatible pats\<^sub>1' pats\<^sub>2'"
using \<open>(pats\<^sub>1', rhs\<^sub>1) |\<in>| irs'\<close> \<open>(pats\<^sub>2', rhs\<^sub>2) |\<in>| irs'\<close> \<open>patterns_compatibles irs'\<close>
by (auto dest: fpairwiseD)
ultimately show "pattern_compatible pat\<^sub>1 pat\<^sub>2"
by (auto elim: rev_accum_rel_snoc_eqE)
qed
next
fix pat t
assume "(pat, t) |\<in>| cs"
then obtain pats' where "(pats', t) |\<in>| irs'" "pat = last pats'"
using \<open>(pats, cs) |\<in>| ?grp\<close> by auto
moreover hence "pats' \<noteq> []"
using \<open>arity_compatibles irs'\<close> False
by (metis list.size(3) arity_compatible_length)
ultimately have "pat \<in> set pats'"
by auto
moreover have "linears pats'"
using \<open>(pats', t) |\<in>| irs'\<close> \<open>(name, irs') |\<in>| rs\<close> inner by blast
ultimately show "linear pat"
by (metis linears_linear)
show "wellformed t"
using \<open>(pats', t) |\<in>| irs'\<close> \<open>(name, irs') |\<in>| rs\<close> inner by blast
qed
qed
have "\<not> shadows_consts rhs"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
show ?thesis
unfolding \<open>rhs = _\<close>
proof
assume "shadows_consts (Pabs cs)"
then obtain pat t where "(pat, t) |\<in>| cs" "shadows_consts t \<or> shadows_consts pat"
by force
then obtain pats' where "(pats', t) |\<in>| irs'" "pat = last pats'"
using \<open>(pats, cs) |\<in>| ?grp\<close> by auto
moreover hence "pats' \<noteq> []"
using \<open>arity_compatibles irs'\<close> False
by (metis list.size(3) arity_compatible_length)
ultimately have "pat \<in> set pats'"
by auto
show False
using \<open>shadows_consts t \<or> shadows_consts pat\<close>
proof
assume "shadows_consts t"
thus False
using \<open>(name, irs') |\<in>| rs\<close> \<open>(pats', t) |\<in>| irs'\<close> inner by blast
next
assume "shadows_consts pat"
have "fdisjnt (freess pats') all_consts"
using \<open>(name, irs') |\<in>| rs\<close> \<open>(pats', t) |\<in>| irs'\<close> inner by blast
have "fdisjnt (frees pat) all_consts"
apply (rule fdisjnt_subset_left)
apply (subst freess_single[symmetric])
apply (rule freess_subset)
apply simp
apply fact+
done
thus False
using \<open>shadows_consts pat\<close>
unfolding shadows_consts_def fdisjnt_alt_def by auto
qed
qed
qed
thus "\<not> pre_constants.shadows_consts C_info (fst |`| transform_irule_set rs) rhs"
by (simp add: transform_irule_set_heads)
show "abs_ish pats rhs"
proof (cases "arity irs' = 0")
case True
thus ?thesis
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
thus ?thesis
unfolding abs_ish_def by (simp add: is_abs_def term_cases_def)
qed
have "welldefined rhs"
proof (cases "arity irs' = 0")
case True
hence \<open>(pats, rhs) |\<in>| irs'\<close>
using \<open>(pats, rhs) |\<in>| irs\<close> \<open>(name, irs') |\<in>| rs\<close> inner
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def
by (smt fBallE split_conv)
thus ?thesis
unfolding transform_irule_set_def
using fbspec[OF inner \<open>(name, irs') |\<in>| rs\<close>, simplified]
by force
next
case False
hence irs': "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = transform_irules irs'\<close> transform_irules_def by simp
then obtain cs where "(pats, cs) |\<in>| ?grp" "rhs = Pabs cs"
using \<open>(pats, rhs) |\<in>| irs\<close> by force
show ?thesis
unfolding \<open>rhs = _\<close>
apply simp
apply (rule ffUnion_least)
unfolding ball_simps
apply rule
apply (rename_tac x, case_tac x, hypsubst_thin)
apply simp
subgoal premises prems for pat t
proof -
from prems obtain pats' where "(pats', t) |\<in>| irs'"
using \<open>(pats, cs) |\<in>| ?grp\<close> by auto
hence "welldefined t"
using fbspec[OF inner \<open>(name, irs') |\<in>| rs\<close>, simplified]
by blast
thus ?thesis
unfolding transform_irule_set_def
by simp
qed
done
qed
thus "pre_constants.welldefined C_info (fst |`| transform_irule_set rs) rhs"
unfolding transform_irule_set_heads .
qed
subsubsection \<open>Matching and rewriting\<close>
definition irewrite_step :: "name \<Rightarrow> term list \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> pterm option" where
"irewrite_step name pats rhs t = map_option (subst rhs) (match (name $$ pats) t)"
abbreviation irewrite_step' :: "name \<Rightarrow> term list \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_, _, _ \<turnstile>\<^sub>i/ _ \<rightarrow>/ _" [50,0,50] 50) where
"name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> u \<equiv> irewrite_step name pats rhs t = Some u"
lemma irewrite_stepI:
assumes "match (name $$ pats) t = Some env" "subst rhs env = u"
shows "name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> u"
using assms unfolding irewrite_step_def by simp
inductive irewrite :: "irule_set \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>i/ _ \<longrightarrow>/ _" [50,0,50] 50) for irs where
step: "\<lbrakk> (name, rs) |\<in>| irs; (pats, rhs) |\<in>| rs; name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> t' \<rbrakk> \<Longrightarrow> irs \<turnstile>\<^sub>i t \<longrightarrow> t'" |
beta: "\<lbrakk> c |\<in>| cs; c \<turnstile> t \<rightarrow> t' \<rbrakk> \<Longrightarrow> irs \<turnstile>\<^sub>i Pabs cs $\<^sub>p t \<longrightarrow> t'" |
"fun": "irs \<turnstile>\<^sub>i t \<longrightarrow> t' \<Longrightarrow> irs \<turnstile>\<^sub>i t $\<^sub>p u \<longrightarrow> t' $\<^sub>p u" |
arg: "irs \<turnstile>\<^sub>i u \<longrightarrow> u' \<Longrightarrow> irs \<turnstile>\<^sub>i t $\<^sub>p u \<longrightarrow> t $\<^sub>p u'"
global_interpretation irewrite: rewriting "irewrite rs" for rs
by standard (auto intro: irewrite.intros simp: app_pterm_def)+
abbreviation irewrite_rt :: "irule_set \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>i/ _ \<longrightarrow>*/ _" [50,0,50] 50) where
"irewrite_rt rs \<equiv> (irewrite rs)\<^sup>*\<^sup>*"
lemma (in irules) irewrite_closed:
assumes "rs \<turnstile>\<^sub>i t \<longrightarrow> u" "closed t"
shows "closed u"
using assms proof induction
case (step name rs pats rhs t t')
then obtain env where "match (name $$ pats) t = Some env" "t' = subst rhs env"
unfolding irewrite_step_def by auto
hence "closed_env env"
using step by (auto intro: closed.match)
show ?case
unfolding \<open>t' = _\<close>
apply (subst closed_except_def)
apply (subst subst_frees)
apply fact
apply (subst match_dom)
apply fact
apply (subst frees_list_comb)
apply simp
apply (subst closed_except_def[symmetric])
using inner step by blast
next
case (beta c cs t t')
then obtain pat rhs where "c = (pat, rhs)"
by (cases c) auto
with beta obtain env where "match pat t = Some env" "t' = subst rhs env"
by auto
moreover have "closed t"
using beta unfolding closed_except_def by simp
ultimately have "closed_env env"
using beta by (auto intro: closed.match)
show ?case
unfolding \<open>t' = subst rhs env\<close>
apply (subst closed_except_def)
apply (subst subst_frees)
apply fact
apply (subst match_dom)
apply fact
apply simp
apply (subst closed_except_def[symmetric])
using inner beta \<open>c = _\<close> by (auto simp: closed_except_simps)
qed (auto simp: closed_except_def)
corollary (in irules) irewrite_rt_closed:
assumes "rs \<turnstile>\<^sub>i t \<longrightarrow>* u" "closed t"
shows "closed u"
using assms by induction (auto intro: irewrite_closed)
subsubsection \<open>Correctness of translation\<close>
abbreviation irelated :: "nterm \<Rightarrow> pterm \<Rightarrow> bool" ("_ \<approx>\<^sub>i _" [0,50] 50) where
"n \<approx>\<^sub>i p \<equiv> nterm_to_pterm n = p"
global_interpretation irelated: term_struct_rel_strong irelated
by standard
(auto simp: app_pterm_def app_nterm_def const_pterm_def const_nterm_def elim: nterm_to_pterm.elims)
lemma irelated_vars: "t \<approx>\<^sub>i u \<Longrightarrow> frees t = frees u"
by auto
lemma irelated_no_abs:
assumes "t \<approx>\<^sub>i u"
shows "no_abs t \<longleftrightarrow> no_abs u"
using assms
apply (induction arbitrary: t)
apply (auto elim!: nterm_to_pterm.elims)
apply (fold const_nterm_def const_pterm_def free_nterm_def free_pterm_def app_pterm_def app_nterm_def)
by auto
lemma irelated_subst:
assumes "t \<approx>\<^sub>i u" "irelated.P_env nenv penv"
shows "subst t nenv \<approx>\<^sub>i subst u penv"
using assms proof (induction arbitrary: nenv penv u rule: nterm_to_pterm.induct)
case (1 s)
then show ?case
by (auto elim!: fmrel_cases[where x = s])
next
case 4
from 4(2)[symmetric] show ?case
apply simp
apply (rule 4)
apply simp
using 4(3)
by (simp add: fmrel_drop)
qed auto
lemma related_irewrite_step:
assumes "name, pats, nterm_to_pterm rhs \<turnstile>\<^sub>i u \<rightarrow> u'" "t \<approx>\<^sub>i u"
obtains t' where "unsplit_rule (name, pats, rhs) \<turnstile> t \<rightarrow> t'" "t' \<approx>\<^sub>i u'"
proof -
let ?rhs' = "nterm_to_pterm rhs"
let ?x = "name $$ pats"
from assms obtain env where "match ?x u = Some env" "u' = subst ?rhs' env"
unfolding irewrite_step_def by blast
then obtain nenv where "match ?x t = Some nenv" "irelated.P_env nenv env"
using assms
by (metis Option.is_none_def not_None_eq option.rel_distinct(1) option.sel rel_option_unfold irelated.match_rel)
show thesis
proof
show "unsplit_rule (name, pats, rhs) \<turnstile> t \<rightarrow> subst rhs nenv"
using \<open>match ?x t = _\<close> by auto
next
show "subst rhs nenv \<approx>\<^sub>i u'"
unfolding \<open>u' = _\<close> using \<open>irelated.P_env nenv env\<close>
by (auto intro: irelated_subst)
qed
qed
theorem (in nrules) compile_correct:
assumes "compile (consts_of rs) \<turnstile>\<^sub>i u \<longrightarrow> u'" "t \<approx>\<^sub>i u" "closed t"
obtains t' where "rs \<turnstile>\<^sub>n t \<longrightarrow> t'" "t' \<approx>\<^sub>i u'"
using assms(1-3) proof (induction arbitrary: t thesis rule: irewrite.induct)
case (step name irs pats rhs u u')
then obtain crs where "irs = translate_crules crs" "(name, crs) |\<in>| consts_of rs"
unfolding compile_def by force
moreover with step obtain rhs' where "rhs = nterm_to_pterm rhs'" "(pats, rhs') |\<in>| crs"
unfolding translate_crules_def by force
ultimately obtain rule where "split_rule rule = (name, (pats, rhs'))" "rule |\<in>| rs"
unfolding consts_of_def by blast
hence "nrule rule"
using all_rules by blast
obtain t' where "unsplit_rule (name, pats, rhs') \<turnstile> t \<rightarrow> t'" "t' \<approx>\<^sub>i u'"
using \<open>name, pats, rhs \<turnstile>\<^sub>i u \<rightarrow> u'\<close> \<open>t \<approx>\<^sub>i u\<close> unfolding \<open>rhs = nterm_to_pterm rhs'\<close>
by (elim related_irewrite_step)
hence "rule \<turnstile> t \<rightarrow> t'"
using \<open>nrule rule\<close> \<open>split_rule rule = (name, (pats, rhs'))\<close>
by (metis unsplit_split)
show ?case
proof (rule step.prems)
show "rs \<turnstile>\<^sub>n t \<longrightarrow> t'"
apply (rule nrewrite.step)
apply fact
apply fact
done
next
show "t' \<approx>\<^sub>i u'"
by fact
qed
next
case (beta c cs u u')
then obtain pat rhs where "c = (pat, rhs)" "(pat, rhs) |\<in>| cs"
by (cases c) auto
obtain v w where "t = v $\<^sub>n w" "v \<approx>\<^sub>i Pabs cs" "w \<approx>\<^sub>i u"
using \<open>t \<approx>\<^sub>i Pabs cs $\<^sub>p u\<close> by (auto elim: nterm_to_pterm.elims)
obtain x nrhs irhs where "v = (\<Lambda>\<^sub>n x. nrhs)" "cs = {| (Free x, irhs) |}" "nrhs \<approx>\<^sub>i irhs"
using \<open>v \<approx>\<^sub>i Pabs cs\<close> by (auto elim: nterm_to_pterm.elims)
hence "t = (\<Lambda>\<^sub>n x. nrhs) $\<^sub>n w" "\<Lambda>\<^sub>n x. nrhs \<approx>\<^sub>i \<Lambda>\<^sub>p x. irhs"
unfolding \<open>t = v $\<^sub>n w\<close> using \<open>v \<approx>\<^sub>i Pabs cs\<close> by auto
have "pat = Free x" "rhs = irhs"
using \<open>cs = {| (Free x, irhs) |}\<close> \<open>(pat, rhs) |\<in>| cs\<close> by auto
hence "(Free x, irhs) \<turnstile> u \<rightarrow> u'"
using beta \<open>c = _\<close> by simp
hence "u' = subst irhs (fmap_of_list [(x, u)])"
by simp
show ?case
proof (rule beta.prems)
show "rs \<turnstile>\<^sub>n t \<longrightarrow> subst nrhs (fmap_of_list [(x, w)])"
unfolding \<open>t = (\<Lambda>\<^sub>n x. nrhs) $\<^sub>n w\<close>
by (rule nrewrite.beta)
next
show "subst nrhs (fmap_of_list [(x, w)]) \<approx>\<^sub>i u'"
unfolding \<open>u' = subst irhs _\<close>
apply (rule irelated_subst)
apply fact
apply simp
apply rule
apply rule
apply fact
done
qed
next
case ("fun" v v' u)
obtain w x where "t = w $\<^sub>n x" "w \<approx>\<^sub>i v" "x \<approx>\<^sub>i u"
using \<open>t \<approx>\<^sub>i v $\<^sub>p u\<close> by (auto elim: nterm_to_pterm.elims)
with "fun" obtain w' where "rs \<turnstile>\<^sub>n w \<longrightarrow> w'" "w' \<approx>\<^sub>i v'"
unfolding closed_except_def by auto
show ?case
proof (rule fun.prems)
show "rs \<turnstile>\<^sub>n t \<longrightarrow> w' $\<^sub>n x"
unfolding \<open>t = w $\<^sub>n x\<close>
by (rule nrewrite.fun) fact
next
show "w' $\<^sub>n x \<approx>\<^sub>i v' $\<^sub>p u"
by auto fact+
qed
next
case (arg u u' v)
obtain w x where "t = w $\<^sub>n x" "w \<approx>\<^sub>i v" "x \<approx>\<^sub>i u"
using \<open> t \<approx>\<^sub>i v $\<^sub>p u\<close> by (auto elim: nterm_to_pterm.elims)
with arg obtain x' where "rs \<turnstile>\<^sub>n x \<longrightarrow> x'" "x' \<approx>\<^sub>i u'"
unfolding closed_except_def by auto
show ?case
proof (rule arg.prems)
show "rs \<turnstile>\<^sub>n t \<longrightarrow> w $\<^sub>n x'"
unfolding \<open>t = w $\<^sub>n x\<close>
by (rule nrewrite.arg) fact
next
show "w $\<^sub>n x' \<approx>\<^sub>i v $\<^sub>p u'"
by auto fact+
qed
qed
corollary (in nrules) compile_correct_rt:
assumes "compile (consts_of rs) \<turnstile>\<^sub>i u \<longrightarrow>* u'" "t \<approx>\<^sub>i u" "closed t"
obtains t' where "rs \<turnstile>\<^sub>n t \<longrightarrow>* t'" "t' \<approx>\<^sub>i u'"
using assms proof (induction arbitrary: thesis t) (* FIXME clone of transform_correct_rt, maybe locale? *)
case (step u' u'')
obtain t' where "rs \<turnstile>\<^sub>n t \<longrightarrow>* t'" "t' \<approx>\<^sub>i u'"
using step by blast
obtain t'' where "rs \<turnstile>\<^sub>n t' \<longrightarrow>* t''" "t'' \<approx>\<^sub>i u''"
proof (rule compile_correct)
show "compile (consts_of rs) \<turnstile>\<^sub>i u' \<longrightarrow> u''" "t' \<approx>\<^sub>i u'"
by fact+
next
show "closed t'"
using \<open>rs \<turnstile>\<^sub>n t \<longrightarrow>* t'\<close> \<open>closed t\<close>
by (rule nrewrite_rt_closed)
qed blast
show ?case
proof (rule step.prems)
show "rs \<turnstile>\<^sub>n t \<longrightarrow>* t''"
using \<open>rs \<turnstile>\<^sub>n t \<longrightarrow>* t'\<close> \<open>rs \<turnstile>\<^sub>n t' \<longrightarrow>* t''\<close> by auto
qed fact
qed blast
subsubsection \<open>Completeness of translation\<close>
lemma (in nrules) compile_complete:
assumes "rs \<turnstile>\<^sub>n t \<longrightarrow> t'" "closed t"
shows "compile (consts_of rs) \<turnstile>\<^sub>i nterm_to_pterm t \<longrightarrow> nterm_to_pterm t'"
using assms proof induction
case (step r t t')
then obtain pat rhs' where "r = (pat, rhs')"
by force
then have "(pat, rhs') |\<in>| rs" "(pat, rhs') \<turnstile> t \<rightarrow> t'"
using step by blast+
then have "nrule (pat, rhs')"
using all_rules by blast
then obtain name pats where "(name, (pats, rhs')) = split_rule r" "pat = name $$ pats"
unfolding split_rule_def \<open>r = _\<close>
apply atomize_elim
by (auto simp: split_beta)
obtain crs where "(name, crs) |\<in>| consts_of rs" "(pats, rhs') |\<in>| crs"
using step \<open>_ = split_rule r\<close> \<open>r = _\<close>
by (metis consts_of_def fgroup_by_complete fst_conv snd_conv)
then obtain irs where "irs = translate_crules crs"
by blast
then have "(name, irs) |\<in>| compile (consts_of rs)"
unfolding compile_def
using \<open>(name, _) |\<in>| _\<close>
by (metis fimageI id_def map_prod_simp)
obtain rhs where "rhs = nterm_to_pterm rhs'" "(pats, rhs) |\<in>| irs"
using \<open>irs = _\<close> \<open>_ |\<in>| crs\<close>
unfolding translate_crules_def
by (metis fimageI id_def map_prod_simp)
from step obtain env' where "match pat t = Some env'" "t' = subst rhs' env'"
unfolding \<open>r = _\<close> using rewrite_step.simps
by force
then obtain env where "match pat (nterm_to_pterm t) = Some env" "irelated.P_env env' env"
by (metis irelated.match_rel option_rel_Some1)
then have "subst rhs env = nterm_to_pterm t'"
unfolding \<open>t' = _\<close>
apply -
apply (rule sym)
apply (rule irelated_subst)
unfolding \<open>rhs = _\<close>
by auto
have "name, pats, rhs \<turnstile>\<^sub>i nterm_to_pterm t \<rightarrow> nterm_to_pterm t'"
apply (rule irewrite_stepI)
using \<open>match _ _ = Some env\<close> unfolding \<open>pat = _\<close>
apply assumption
by fact
show ?case
by rule fact+
next
case (beta x t t')
obtain c where "c = (Free x, nterm_to_pterm t)"
by blast
from beta have "closed (nterm_to_pterm t')"
using closed_nterm_to_pterm[where t = t']
unfolding closed_except_def
by auto
show ?case
apply simp
apply rule
using \<open>c = _\<close>
by (fastforce intro: irelated_subst[THEN sym])+
next
case ("fun" t t' u)
show ?case
apply simp
apply rule
apply (rule "fun")
using "fun"
unfolding closed_except_def
apply simp
done
next
case (arg u u' t)
show ?case
apply simp
apply rule
apply (rule arg)
using arg
unfolding closed_except_def
by simp
qed
subsubsection \<open>Correctness of transformation\<close>
abbreviation irules_deferred_matches :: "pterm list \<Rightarrow> irules \<Rightarrow> (term \<times> pterm) fset" where
"irules_deferred_matches args \<equiv> fselect
(\<lambda>(pats, rhs). map_option (\<lambda>env. (last pats, subst rhs env)) (matchs (butlast pats) args))"
context irules begin
inductive prelated :: "pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_ \<approx>\<^sub>p _" [0,50] 50) where
const: "Pconst x \<approx>\<^sub>p Pconst x" |
var: "Pvar x \<approx>\<^sub>p Pvar x" |
app: "t\<^sub>1 \<approx>\<^sub>p u\<^sub>1 \<Longrightarrow> t\<^sub>2 \<approx>\<^sub>p u\<^sub>2 \<Longrightarrow> t\<^sub>1 $\<^sub>p t\<^sub>2 \<approx>\<^sub>p u\<^sub>1 $\<^sub>p u\<^sub>2" |
pat: "rel_fset (rel_prod (=) prelated) cs\<^sub>1 cs\<^sub>2 \<Longrightarrow> Pabs cs\<^sub>1 \<approx>\<^sub>p Pabs cs\<^sub>2" |
"defer":
"(name, rsi) |\<in>| rs \<Longrightarrow> 0 < arity rsi \<Longrightarrow>
rel_fset (rel_prod (=) prelated) (irules_deferred_matches args rsi) cs \<Longrightarrow>
list_all closed args \<Longrightarrow>
name $$ args \<approx>\<^sub>p Pabs cs"
inductive_cases prelated_absE[consumes 1, case_names pat "defer"]: "t \<approx>\<^sub>p Pabs cs"
lemma prelated_refl[intro!]: "t \<approx>\<^sub>p t"
proof (induction t)
case Pabs
thus ?case
- by (auto simp: snds.simps fmember.rep_eq intro!: prelated.pat rel_fset_refl_strong rel_prod.intros)
+ by (auto simp: snds.simps fmember_iff_member_fset intro!: prelated.pat rel_fset_refl_strong rel_prod.intros)
qed (auto intro: prelated.intros)
sublocale prelated: term_struct_rel prelated
by standard (auto simp: const_pterm_def app_pterm_def intro: prelated.intros elim: prelated.cases)
lemma prelated_pvars:
assumes "t \<approx>\<^sub>p u"
shows "frees t = frees u"
using assms proof (induction rule: prelated.induct)
case (pat cs\<^sub>1 cs\<^sub>2)
show ?case
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule rel_fset_image_eq)
apply fact
apply auto
done
next
case ("defer" name rsi args cs)
{
fix pat t
assume "(pat, t) |\<in>| cs"
with "defer" obtain t'
where "(pat, t') |\<in>| irules_deferred_matches args rsi" "frees t = frees t'"
by (auto elim: rel_fsetE2)
then obtain pats rhs env
where "pat = last pats" "(pats, rhs) |\<in>| rsi"
and "matchs (butlast pats) args = Some env" "t' = subst rhs env"
by auto
have "closed_except rhs (freess pats)" "linears pats"
using \<open>(pats, rhs) |\<in>| rsi\<close> \<open>(name, rsi) |\<in>| rs\<close> inner by blast+
have "arity_compatibles rsi"
using "defer" inner by (blast dest: fpairwiseD)
have "length pats > 0"
by (subst arity_compatible_length) fact+
hence "pats = butlast pats @ [last pats]"
by simp
note \<open>frees t = frees t'\<close>
also have "frees t' = frees rhs - fmdom env"
unfolding \<open>t' = _\<close>
apply (rule subst_frees)
apply (rule closed.matchs)
apply fact+
done
also have "\<dots> = frees rhs - freess (butlast pats)"
using \<open>matchs _ _ = _\<close> by (metis matchs_dom)
also have "\<dots> |\<subseteq>| freess pats - freess (butlast pats)"
using \<open>closed_except _ _\<close>
by (auto simp: closed_except_def)
also have "\<dots> = frees (last pats) |-| freess (butlast pats)"
by (subst \<open>pats = _\<close>) (simp add: funion_fminus)
also have "\<dots> = frees (last pats)"
proof (rule fminus_triv)
have "fdisjnt (freess (butlast pats)) (freess [last pats])"
using \<open>linears pats\<close> \<open>pats = _\<close>
by (metis linears_appendD)
thus "frees (last pats) |\<inter>| freess (butlast pats) = {||}"
by (fastforce simp: fdisjnt_alt_def)
qed
also have "\<dots> = frees pat" unfolding \<open>pat = _\<close> ..
finally have "frees t |\<subseteq>| frees pat" .
}
hence "closed (Pabs cs)"
unfolding closed_except_simps
by (auto simp: closed_except_def)
moreover have "closed (name $$ args)"
unfolding closed_list_comb by fact
ultimately show ?case
unfolding closed_except_def by simp
qed auto
corollary prelated_closed: "t \<approx>\<^sub>p u \<Longrightarrow> closed t \<longleftrightarrow> closed u"
unfolding closed_except_def
by (auto simp: prelated_pvars)
lemma prelated_no_abs_right:
assumes "t \<approx>\<^sub>p u" "no_abs u"
shows "t = u"
using assms
apply (induction rule: prelated.induct)
apply auto
apply (fold app_pterm_def)
apply auto
done
corollary env_prelated_refl[intro!]: "prelated.P_env env env"
by (auto intro: fmap.rel_refl)
text \<open>
The following, more general statement does not hold:
@{prop "t \<approx>\<^sub>p u \<Longrightarrow> rel_option prelated.P_env (match x t) (match x u)"}
If @{text t} and @{text u} are related because of the @{thm [source=true] prelated.defer} rule,
they have completely different shapes.
Establishing @{prop "is_abs t \<longleftrightarrow> is_abs u"} as a precondition would rule out this case, but at
the same time be too restrictive.
Instead, we use @{thm prelated.related_match}.
\<close>
lemma prelated_subst:
assumes "t\<^sub>1 \<approx>\<^sub>p t\<^sub>2" "prelated.P_env env\<^sub>1 env\<^sub>2"
shows "subst t\<^sub>1 env\<^sub>1 \<approx>\<^sub>p subst t\<^sub>2 env\<^sub>2"
using assms proof (induction arbitrary: env\<^sub>1 env\<^sub>2 rule: prelated.induct)
case (var x)
thus ?case
proof (cases rule: fmrel_cases[where x = x])
case none
thus ?thesis
by (auto intro: prelated.var)
next
case (some t u)
thus ?thesis
by simp
qed
next
case (pat cs\<^sub>1 cs\<^sub>2)
let ?drop = "\<lambda>env. \<lambda>(pat::term). fmdrop_fset (frees pat) env"
from pat have "prelated.P_env (?drop env\<^sub>1 pat) (?drop env\<^sub>2 pat)" for pat
by blast
with pat show ?case
by (auto intro!: prelated.pat rel_fset_image)
next
case ("defer" name rsi args cs)
have "name $$ args \<approx>\<^sub>p Pabs cs"
apply (rule prelated.defer)
apply fact+
apply (rule fset.rel_mono_strong)
apply fact
apply force
apply fact
done
moreover have "closed (name $$ args)"
unfolding closed_list_comb by fact
ultimately have "closed (Pabs cs)"
by (metis prelated_closed)
let ?drop = "\<lambda>env. \<lambda>pat. fmdrop_fset (frees pat) env"
let ?f = "\<lambda>env. (\<lambda>(pat, rhs). (pat, subst rhs (?drop env pat)))"
have "name $$ args \<approx>\<^sub>p Pabs (?f env\<^sub>2 |`| cs)"
proof (rule prelated.defer)
show "(name, rsi) |\<in>| rs" "0 < arity rsi" "list_all closed args"
using "defer" by auto
next
{
fix pat\<^sub>1 rhs\<^sub>1
fix pat\<^sub>2 rhs\<^sub>2
assume "(pat\<^sub>2, rhs\<^sub>2) |\<in>| cs"
assume "pat\<^sub>1 = pat\<^sub>2" "rhs\<^sub>1 \<approx>\<^sub>p rhs\<^sub>2"
have "rhs\<^sub>1 \<approx>\<^sub>p subst rhs\<^sub>2 (fmdrop_fset (frees pat\<^sub>2) env\<^sub>2)"
by (subst subst_closed_pabs) fact+
}
hence "rel_fset (rel_prod (=) prelated) (id |`| irules_deferred_matches args rsi) (?f env\<^sub>2 |`| cs)"
by (force intro!: rel_fset_image[OF \<open>rel_fset _ _ _\<close>])
thus "rel_fset (rel_prod (=) prelated) (irules_deferred_matches args rsi) (?f env\<^sub>2 |`| cs)"
by simp
qed
moreover have "map (\<lambda>t. subst t env\<^sub>1) args = args"
apply (rule map_idI)
apply (rule subst_closed_id)
using "defer" by (simp add: list_all_iff)
ultimately show ?case
by (simp add: subst_list_comb)
qed (auto intro: prelated.intros)
lemma prelated_step:
assumes "name, pats, rhs \<turnstile>\<^sub>i u \<rightarrow> u'" "t \<approx>\<^sub>p u"
obtains t' where "name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> t'" "t' \<approx>\<^sub>p u'"
proof -
let ?lhs = "name $$ pats"
from assms obtain env where "match ?lhs u = Some env" "u' = subst rhs env"
unfolding irewrite_step_def by blast
then obtain env' where "match ?lhs t = Some env'" "prelated.P_env env' env"
using assms by (auto elim: prelated.related_match)
hence "subst rhs env' \<approx>\<^sub>p subst rhs env"
using assms by (auto intro: prelated_subst)
show thesis
proof
show "name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> subst rhs env'"
unfolding irewrite_step_def using \<open>match ?lhs t = Some env'\<close>
by simp
next
show "subst rhs env' \<approx>\<^sub>p u'"
unfolding \<open>u' = subst rhs env\<close>
by fact
qed
qed
(* FIXME write using relators *)
lemma prelated_beta: \<comment> \<open>same problem as @{thm [source=true] prelated.related_match}\<close>
assumes "(pat, rhs\<^sub>2) \<turnstile> t\<^sub>2 \<rightarrow> u\<^sub>2" "rhs\<^sub>1 \<approx>\<^sub>p rhs\<^sub>2" "t\<^sub>1 \<approx>\<^sub>p t\<^sub>2"
obtains u\<^sub>1 where "(pat, rhs\<^sub>1) \<turnstile> t\<^sub>1 \<rightarrow> u\<^sub>1" "u\<^sub>1 \<approx>\<^sub>p u\<^sub>2"
proof -
from assms obtain env\<^sub>2 where "match pat t\<^sub>2 = Some env\<^sub>2" "u\<^sub>2 = subst rhs\<^sub>2 env\<^sub>2"
by auto
with assms obtain env\<^sub>1 where "match pat t\<^sub>1 = Some env\<^sub>1" "prelated.P_env env\<^sub>1 env\<^sub>2"
by (auto elim: prelated.related_match)
with assms have "subst rhs\<^sub>1 env\<^sub>1 \<approx>\<^sub>p subst rhs\<^sub>2 env\<^sub>2"
by (auto intro: prelated_subst)
show thesis
proof
show "(pat, rhs\<^sub>1) \<turnstile> t\<^sub>1 \<rightarrow> subst rhs\<^sub>1 env\<^sub>1"
using \<open>match pat t\<^sub>1 = _\<close> by simp
next
show "subst rhs\<^sub>1 env\<^sub>1 \<approx>\<^sub>p u\<^sub>2"
unfolding \<open>u\<^sub>2 = _\<close> by fact
qed
qed
theorem transform_correct:
assumes "transform_irule_set rs \<turnstile>\<^sub>i u \<longrightarrow> u'" "t \<approx>\<^sub>p u" "closed t"
obtains t' where "rs \<turnstile>\<^sub>i t \<longrightarrow>* t'" \<comment> \<open>zero or one step\<close> and "t' \<approx>\<^sub>p u'"
using assms(1-3) proof (induction arbitrary: t thesis rule: irewrite.induct)
case (beta c cs\<^sub>2 u\<^sub>2 x\<^sub>2')
obtain v u\<^sub>1 where "t = v $\<^sub>p u\<^sub>1" "v \<approx>\<^sub>p Pabs cs\<^sub>2" "u\<^sub>1 \<approx>\<^sub>p u\<^sub>2"
using \<open>t \<approx>\<^sub>p Pabs cs\<^sub>2 $\<^sub>p u\<^sub>2\<close> by cases
with beta have "closed u\<^sub>1"
by (simp add: closed_except_def)
obtain pat rhs\<^sub>2 where "c = (pat, rhs\<^sub>2)" by (cases c) auto
from \<open>v \<approx>\<^sub>p Pabs cs\<^sub>2\<close> show ?case
proof (cases rule: prelated_absE)
case (pat cs\<^sub>1)
with beta \<open>c = _\<close> obtain rhs\<^sub>1 where "(pat, rhs\<^sub>1) |\<in>| cs\<^sub>1" "rhs\<^sub>1 \<approx>\<^sub>p rhs\<^sub>2"
by (auto elim: rel_fsetE2)
with beta obtain x\<^sub>1' where "(pat, rhs\<^sub>1) \<turnstile> u\<^sub>1 \<rightarrow> x\<^sub>1'" "x\<^sub>1' \<approx>\<^sub>p x\<^sub>2'"
using \<open>u\<^sub>1 \<approx>\<^sub>p u\<^sub>2\<close> assms \<open>c = _\<close>
by (auto elim: prelated_beta simp del: rewrite_step.simps)
show ?thesis
proof (rule beta.prems)
show "rs \<turnstile>\<^sub>i t \<longrightarrow>* x\<^sub>1'"
unfolding \<open>t = _\<close> \<open>v = _\<close>
by (intro r_into_rtranclp irewrite.beta) fact+
next
show "x\<^sub>1' \<approx>\<^sub>p x\<^sub>2'"
by fact
qed
next
case ("defer" name rsi args)
with beta \<open>c = _\<close> obtain rhs\<^sub>1' where "(pat, rhs\<^sub>1') |\<in>| irules_deferred_matches args rsi" "rhs\<^sub>1' \<approx>\<^sub>p rhs\<^sub>2"
by (auto elim: rel_fsetE2)
then obtain env\<^sub>a rhs\<^sub>1 pats
where "matchs (butlast pats) args = Some env\<^sub>a" "pat = last pats" "rhs\<^sub>1' = subst rhs\<^sub>1 env\<^sub>a"
and "(pats, rhs\<^sub>1) |\<in>| rsi"
by auto
hence "linears pats"
using \<open>(name, rsi) |\<in>| rs\<close> inner unfolding irules_def by blast
have "arity_compatibles rsi"
using "defer" inner by (blast dest: fpairwiseD)
have "length pats > 0"
by (subst arity_compatible_length) fact+
hence "pats = butlast pats @ [pat]"
unfolding \<open>pat = _\<close> by simp
from beta \<open>c = _\<close> obtain env\<^sub>b where "match pat u\<^sub>2 = Some env\<^sub>b" "x\<^sub>2' = subst rhs\<^sub>2 env\<^sub>b"
by fastforce
with \<open>u\<^sub>1 \<approx>\<^sub>p u\<^sub>2\<close> obtain env\<^sub>b' where "match pat u\<^sub>1 = Some env\<^sub>b'" "prelated.P_env env\<^sub>b' env\<^sub>b"
by (metis prelated.related_match)
have "closed_env env\<^sub>a"
by (rule closed.matchs) fact+
have "closed_env env\<^sub>b'"
apply (rule closed.matchs[where pats = "[pat]" and ts = "[u\<^sub>1]"])
apply simp
apply fact
apply simp
apply fact
done
have "fmdom env\<^sub>a = freess (butlast pats)"
by (rule matchs_dom) fact
moreover have "fmdom env\<^sub>b' = frees pat"
by (rule match_dom) fact
moreover have "fdisjnt (freess (butlast pats)) (frees pat)"
using \<open>pats = _\<close> \<open>linears pats\<close>
by (metis freess_single linears_appendD(3))
ultimately have "fdisjnt (fmdom env\<^sub>a) (fmdom env\<^sub>b')"
by simp
show ?thesis
proof (rule beta.prems)
have "rs \<turnstile>\<^sub>i name $$ args $\<^sub>p u\<^sub>1 \<longrightarrow> subst rhs\<^sub>1' env\<^sub>b'"
proof (rule irewrite.step)
show "(name, rsi) |\<in>| rs" "(pats, rhs\<^sub>1) |\<in>| rsi"
by fact+
next
show "name, pats, rhs\<^sub>1 \<turnstile>\<^sub>i name $$ args $\<^sub>p u\<^sub>1 \<rightarrow> subst rhs\<^sub>1' env\<^sub>b'"
apply (rule irewrite_stepI)
apply (fold app_pterm_def)
apply (subst list_comb_snoc)
apply (subst matchs_match_list_comb)
apply (subst \<open>pats = _\<close>)
apply (rule matchs_appI)
apply fact
apply simp
apply fact
unfolding \<open>rhs\<^sub>1' = _\<close>
apply (rule subst_indep')
apply fact+
done
qed
thus "rs \<turnstile>\<^sub>i t \<longrightarrow>* subst rhs\<^sub>1' env\<^sub>b'"
unfolding \<open>t = _\<close> \<open>v = _\<close>
by (rule r_into_rtranclp)
next
show "subst rhs\<^sub>1' env\<^sub>b' \<approx>\<^sub>p x\<^sub>2'"
unfolding \<open>x\<^sub>2' = _\<close>
by (rule prelated_subst) fact+
qed
qed
next
case (step name rs\<^sub>2 pats rhs u u')
then obtain rs\<^sub>1 where "rs\<^sub>2 = transform_irules rs\<^sub>1" "(name, rs\<^sub>1) |\<in>| rs"
unfolding transform_irule_set_def by force
hence "arity_compatibles rs\<^sub>1"
using inner by (blast dest: fpairwiseD)
show ?case
proof (cases "arity rs\<^sub>1 = 0")
case True
hence "rs\<^sub>2 = rs\<^sub>1"
unfolding \<open>rs\<^sub>2 = _\<close> transform_irules_def by simp
with step have "(pats, rhs) |\<in>| rs\<^sub>1"
by simp
from step obtain t' where "name, pats, rhs \<turnstile>\<^sub>i t \<rightarrow> t'" "t' \<approx>\<^sub>p u'"
using assms
by (auto elim: prelated_step)
show ?thesis
proof (rule step.prems)
show "rs \<turnstile>\<^sub>i t \<longrightarrow>* t'"
by (intro conjI exI r_into_rtranclp irewrite.step) fact+
qed fact
next
let ?f = "\<lambda>(pats, rhs). (butlast pats, last pats, rhs)"
let ?grp = "fgroup_by ?f rs\<^sub>1"
case False
hence "rs\<^sub>2 = map_prod id Pabs |`| ?grp"
unfolding \<open>rs\<^sub>2 = _\<close> transform_irules_def by simp
with step obtain cs where "rhs = Pabs cs" "(pats, cs) |\<in>| ?grp"
by force
from step obtain env\<^sub>2 where "match (name $$ pats) u = Some env\<^sub>2" "u' = subst rhs env\<^sub>2"
unfolding irewrite_step_def by auto
then obtain args\<^sub>2 where "u = name $$ args\<^sub>2" "matchs pats args\<^sub>2 = Some env\<^sub>2"
by (auto elim: match_list_combE)
with step obtain args\<^sub>1 where "t = name $$ args\<^sub>1" "list_all2 prelated args\<^sub>1 args\<^sub>2"
by (auto elim: prelated.list_combE)
then obtain env\<^sub>1 where "matchs pats args\<^sub>1 = Some env\<^sub>1" "prelated.P_env env\<^sub>1 env\<^sub>2"
using \<open>matchs pats args\<^sub>2 = _\<close> by (metis prelated.related_matchs)
hence "fmdom env\<^sub>1 = freess pats"
by (auto simp: matchs_dom)
obtain cs' where "u' = Pabs cs'"
unfolding \<open>u' = _\<close> \<open>rhs = _\<close> by auto
hence "cs' = (\<lambda>(pat, rhs). (pat, subst rhs (fmdrop_fset (frees pat) env\<^sub>2 ))) |`| cs"
using \<open>u' = subst rhs env\<^sub>2\<close> unfolding \<open>rhs = _\<close>
by simp
show ?thesis
proof (rule step.prems)
show "rs \<turnstile>\<^sub>i t \<longrightarrow>* t"
by (rule rtranclp.rtrancl_refl)
next
show "t \<approx>\<^sub>p u'"
unfolding \<open>u' = Pabs cs'\<close> \<open>t = _\<close>
proof (intro prelated.defer rel_fsetI; safe?)
show "(name, rs\<^sub>1) |\<in>| rs"
by fact
next
show "0 < arity rs\<^sub>1"
using False by simp
next
show "list_all closed args\<^sub>1"
using \<open>closed t\<close> unfolding \<open>t = _\<close> closed_list_comb .
next
fix pat rhs'
assume "(pat, rhs') |\<in>| irules_deferred_matches args\<^sub>1 rs\<^sub>1"
then obtain pats' rhs env
where "(pats', rhs) |\<in>| rs\<^sub>1"
and "matchs (butlast pats') args\<^sub>1 = Some env" "pat = last pats'" "rhs' = subst rhs env"
by auto
with False have "pats' \<noteq> []"
using \<open>arity_compatibles rs\<^sub>1\<close>
by (metis list.size(3) arity_compatible_length)
hence "butlast pats' @ [last pats'] = pats'"
by simp
from \<open>(pats, cs) |\<in>| ?grp\<close> obtain pats\<^sub>e rhs\<^sub>e
where "(pats\<^sub>e, rhs\<^sub>e) |\<in>| rs\<^sub>1" "pats = butlast pats\<^sub>e"
by (auto elim: fgroup_byE2)
have "patterns_compatible (butlast pats') pats"
unfolding \<open>pats = _\<close>
apply (rule rev_accum_rel_butlast)
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>(pats\<^sub>e, rhs\<^sub>e) |\<in>| rs\<^sub>1\<close> \<open>(name, rs\<^sub>1) |\<in>| rs\<close> inner
by (blast dest: fpairwiseD)
interpret irules': irules C_info "transform_irule_set rs" by (rule rules_transform)
have "butlast pats' = pats" "env = env\<^sub>1"
apply (rule matchs_compatible_eq)
subgoal by fact
subgoal
apply (rule linears_butlastI)
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>(name, rs\<^sub>1) |\<in>| rs\<close> inner by blast
subgoal
using \<open>(pats, _) |\<in>| rs\<^sub>2\<close> \<open>(name, rs\<^sub>2) |\<in>| transform_irule_set rs\<close>
using irules'.inner by blast
apply fact+
subgoal
apply (rule matchs_compatible_eq)
apply fact
apply (rule linears_butlastI)
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>(name, rs\<^sub>1) |\<in>| rs\<close> inner
apply blast
using \<open>(pats, _) |\<in>| rs\<^sub>2\<close> \<open>(name, rs\<^sub>2) |\<in>| transform_irule_set rs\<close>
using irules'.inner apply blast
by fact+
done
let ?rhs_subst = "\<lambda>env. subst rhs (fmdrop_fset (frees pat) env)"
have "fmdom env\<^sub>2 = freess pats"
using \<open>match (_ $$ _) _ = Some env\<^sub>2\<close>
by (simp add: match_dom)
show "fBex cs' (rel_prod (=) prelated (pat, rhs'))"
unfolding \<open>rhs' = _\<close>
proof (rule fBexI, rule rel_prod.intros)
have "fdisjnt (freess (butlast pats')) (frees (last pats'))"
apply (subst freess_single[symmetric])
apply (rule linears_appendD)
apply (subst \<open>butlast pats' @ [last pats'] = pats'\<close>)
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>(name, rs\<^sub>1) |\<in>| rs\<close> inner
by blast
show "subst rhs env \<approx>\<^sub>p ?rhs_subst env\<^sub>2"
apply (rule prelated_subst)
apply (rule prelated_refl)
unfolding fmfilter_alt_defs
apply (subst fmfilter_true)
subgoal premises prems for x y
using fmdomI[OF prems]
unfolding \<open>pat = _\<close> \<open>fmdom env\<^sub>2 = _\<close>
apply (subst (asm) \<open>butlast pats' = pats\<close>[symmetric])
using \<open>fdisjnt (freess (butlast pats')) (frees (last pats'))\<close>
by (auto simp: fdisjnt_alt_def)
subgoal
unfolding \<open>env = _\<close>
by fact
done
next
have "(pat, rhs) |\<in>| cs"
unfolding \<open>pat = _\<close>
apply (rule fgroup_byD[where a = "(x, y)" for x y])
apply fact
apply simp
apply (intro conjI)
apply fact
apply (rule refl)+
apply fact
done
thus "(pat, ?rhs_subst env\<^sub>2) |\<in>| cs'"
unfolding \<open>cs' = _\<close> by force
qed simp
next
fix pat rhs'
assume "(pat, rhs') |\<in>| cs'"
then obtain rhs
where "(pat, rhs) |\<in>| cs"
and "rhs' = subst rhs (fmdrop_fset (frees pat) env\<^sub>2 )"
unfolding \<open>cs' = _\<close> by auto
with \<open>(pats, cs) |\<in>| ?grp\<close> obtain pats'
where "(pats', rhs) |\<in>| rs\<^sub>1" "pats = butlast pats'" "pat = last pats'"
by auto
with False have "length pats' \<noteq> 0"
using \<open>arity_compatibles _\<close> by (metis arity_compatible_length)
hence "pats' = pats @ [pat]"
unfolding \<open>pats = _\<close> \<open>pat = _\<close> by auto
moreover have "linears pats'"
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>(name, rs\<^sub>1) |\<in>| _\<close> inner by blast
ultimately have "fdisjnt (fmdom env\<^sub>1) (frees pat)"
unfolding \<open>fmdom env\<^sub>1 = _\<close>
by (auto dest: linears_appendD)
let ?rhs_subst = "\<lambda>env. subst rhs (fmdrop_fset (frees pat) env)"
show "fBex (irules_deferred_matches args\<^sub>1 rs\<^sub>1) (\<lambda>e. rel_prod (=) prelated e (pat, rhs'))"
unfolding \<open>rhs' = _\<close>
proof (rule fBexI, rule rel_prod.intros)
show "?rhs_subst env\<^sub>1 \<approx>\<^sub>p ?rhs_subst env\<^sub>2"
using \<open>prelated.P_env env\<^sub>1 env\<^sub>2\<close> inner
by (auto intro: prelated_subst)
next
have "matchs (butlast pats') args\<^sub>1 = Some env\<^sub>1"
using \<open>matchs pats args\<^sub>1 = _\<close> \<open>pats = _\<close> by simp
moreover have "subst rhs env\<^sub>1 = ?rhs_subst env\<^sub>1"
apply (rule arg_cong[where f = "subst rhs"])
unfolding fmfilter_alt_defs
apply (rule fmfilter_true[symmetric])
using \<open>fdisjnt (fmdom env\<^sub>1) _\<close>
by (auto simp: fdisjnt_alt_def intro: fmdomI)
ultimately show "(pat, ?rhs_subst env\<^sub>1) |\<in>| irules_deferred_matches args\<^sub>1 rs\<^sub>1"
using \<open>(pats', rhs) |\<in>| rs\<^sub>1\<close> \<open>pat = last pats'\<close>
by auto
qed simp
qed
qed
qed
next
case ("fun" v v' u)
obtain w x where "t = w $\<^sub>p x" "w \<approx>\<^sub>p v" "x \<approx>\<^sub>p u" "closed w"
using \<open>t \<approx>\<^sub>p v $\<^sub>p u\<close> \<open>closed t\<close> by cases (auto simp: closed_except_def)
with "fun" obtain w' where "rs \<turnstile>\<^sub>i w \<longrightarrow>* w'" "w' \<approx>\<^sub>p v'"
by blast
show ?case
proof (rule fun.prems)
show "rs \<turnstile>\<^sub>i t \<longrightarrow>* w' $\<^sub>p x"
unfolding \<open>t = _\<close>
by (intro irewrite.rt_comb[unfolded app_pterm_def] rtranclp.rtrancl_refl) fact
next
show "w' $\<^sub>p x \<approx>\<^sub>p v' $\<^sub>p u"
by (rule prelated.app) fact+
qed
next
case (arg u u' v)
obtain w x where "t = w $\<^sub>p x" "w \<approx>\<^sub>p v" "x \<approx>\<^sub>p u" "closed x"
using \<open>t \<approx>\<^sub>p v $\<^sub>p u\<close> \<open>closed t\<close> by cases (auto simp: closed_except_def)
with arg obtain x' where "rs \<turnstile>\<^sub>i x \<longrightarrow>* x'" "x' \<approx>\<^sub>p u'"
by blast
show ?case
proof (rule arg.prems)
show "rs \<turnstile>\<^sub>i t \<longrightarrow>* w $\<^sub>p x'"
unfolding \<open>t = w $\<^sub>p x\<close>
by (intro irewrite.rt_comb[unfolded app_pterm_def] rtranclp.rtrancl_refl) fact
next
show "w $\<^sub>p x' \<approx>\<^sub>p v $\<^sub>p u'"
by (rule prelated.app) fact+
qed
qed
end
subsubsection \<open>Completeness of transformation\<close>
lemma (in irules) transform_completeness:
assumes "rs \<turnstile>\<^sub>i t \<longrightarrow> t'" "closed t"
shows "transform_irule_set rs \<turnstile>\<^sub>i t \<longrightarrow>* t'"
using assms proof induction
case (step name irs' pats' rhs' t t')
then obtain irs where "irs = transform_irules irs'" "(name, irs) |\<in>| transform_irule_set rs"
unfolding transform_irule_set_def
by (metis fimageI id_apply map_prod_simp)
show ?case
proof (cases "arity irs' = 0")
case True
hence "irs = irs'"
unfolding \<open>irs = _\<close>
unfolding transform_irules_def
by simp
with step have "(pats', rhs') |\<in>| irs" "name, pats', rhs' \<turnstile>\<^sub>i t \<rightarrow> t'"
by blast+
have "transform_irule_set rs \<turnstile>\<^sub>i t \<longrightarrow>* t'"
apply (rule r_into_rtranclp)
apply rule
by fact+
show ?thesis by fact
next
let ?f = "\<lambda>(pats, rhs). (butlast pats, last pats, rhs)"
let ?grp = "fgroup_by ?f irs'"
note closed_except_def [simp add]
case False
then have "irs = map_prod id Pabs |`| ?grp"
unfolding \<open>irs = _\<close>
unfolding transform_irules_def
by simp
with False have "irs = transform_irules irs'"
unfolding transform_irules_def
by simp
obtain pat pats where "pat = last pats'" "pats = butlast pats'"
by blast
from step False have "length pats' \<noteq> 0"
using arity_compatible_length inner
by (smt fBallE prod.simps(2))
then have "pats' = pats @ [pat]"
unfolding \<open>pat = _\<close> \<open>pats = _\<close>
by simp
from step have "linears pats'"
using inner fBallE
by (metis (mono_tags, lifting) old.prod.case)
then have "fdisjnt (freess pats) (frees pat)"
unfolding \<open>pats' = _\<close>
using linears_appendD(3) freess_single
by force
from step obtain cs where "(pats, cs) |\<in>| ?grp"
unfolding \<open>pats = _\<close>
by (metis (no_types, lifting) fgroup_by_complete fst_conv prod.simps(2))
with step have "(pat, rhs') |\<in>| cs"
unfolding \<open>pat = _\<close> \<open>pats = _\<close>
by (meson fgroup_byD old.prod.case)
have "(pats, Pabs cs) |\<in>| irs"
using \<open>irs = map_prod id Pabs |`| ?grp\<close> \<open>(pats, cs) |\<in>| _\<close>
by (metis (no_types, lifting) eq_snd_iff fst_conv fst_map_prod id_def rev_fimage_eqI snd_map_prod)
from step obtain env' where "match (name $$ pats') t = Some env'" "subst rhs' env' = t'"
using irewrite_step_def by auto
have "name $$ pats' = (name $$ pats) $ pat"
unfolding \<open>pats' = _\<close>
by (simp add: app_term_def)
then obtain t\<^sub>0 t\<^sub>1 env\<^sub>0 env\<^sub>1 where "t = t\<^sub>0 $\<^sub>p t\<^sub>1" "match (name $$ pats) t\<^sub>0 = Some env\<^sub>0" "match pat t\<^sub>1 = Some env\<^sub>1" "env' = env\<^sub>0 ++\<^sub>f env\<^sub>1"
using match_appE_split[OF \<open>match (name $$ pats') _ = _\<close>[unfolded \<open>name $$ pats' = _\<close>], unfolded app_pterm_def]
by blast
with step have "closed t\<^sub>0" "closed t\<^sub>1"
by auto
then have "closed_env env\<^sub>0" "closed_env env\<^sub>1"
using match_vars[OF \<open>match _ t\<^sub>0 = _\<close>] match_vars[OF \<open>match _ t\<^sub>1 = _\<close>]
unfolding closed_except_def
by auto
obtain t\<^sub>0' where "subst (Pabs cs) env\<^sub>0 = t\<^sub>0'"
by blast
then obtain cs' where "t\<^sub>0' = Pabs cs'" "cs' = ((\<lambda>(pat, rhs). (pat, subst rhs (fmdrop_fset (frees pat) env\<^sub>0))) |`| cs)"
using subst_pterm.simps(3) by blast
obtain rhs where "subst rhs' (fmdrop_fset (frees pat) env\<^sub>0) = rhs"
by blast
then have "(pat, rhs) |\<in>| cs'"
unfolding \<open>cs' = _\<close>
using \<open>_ |\<in>| cs\<close>
by (metis (mono_tags, lifting) old.prod.case rev_fimage_eqI)
have "env\<^sub>0 ++\<^sub>f env\<^sub>1 = (fmdrop_fset (frees pat) env\<^sub>0) ++\<^sub>f env\<^sub>1"
apply (subst fmadd_drop_left_dom[symmetric])
using \<open>match pat _ = _\<close> match_dom
by metis
have "fdisjnt (fmdom env\<^sub>0) (fmdom env\<^sub>1)"
using match_dom
using \<open>match pat _ = _\<close> \<open>match (name $$ pats) _ = _\<close>
using \<open>fdisjnt _ _\<close>
unfolding fdisjnt_alt_def
by (metis matchs_dom match_list_combE)
have "subst rhs env\<^sub>1 = t'"
unfolding \<open>_ = rhs\<close>[symmetric]
unfolding \<open>_ = t'\<close>[symmetric]
unfolding \<open>env' = _\<close>
unfolding \<open>env\<^sub>0 ++\<^sub>f _ = _\<close>
apply (subst subst_indep')
using \<open>closed_env env\<^sub>0\<close>
apply blast
using \<open>fdisjnt (fmdom _) _\<close>
unfolding fdisjnt_alt_def
by auto
show ?thesis
unfolding \<open>t = _\<close>
apply rule
apply (rule r_into_rtranclp)
apply (rule irewrite.intros(3))
apply rule
apply fact+
apply (rule irewrite_stepI)
apply fact+
unfolding \<open>t\<^sub>0' = _\<close>
apply rule
apply fact
using \<open>match pat t\<^sub>1 = _\<close> \<open>subst rhs _ = _\<close>
by force
qed
qed (auto intro: irewrite.rt_comb[unfolded app_pterm_def] intro!: irewrite.intros simp: closed_except_def)
subsubsection \<open>Computability\<close>
export_code
compile transform_irules
checking Scala SML
end
\ No newline at end of file
diff --git a/thys/CakeML_Codegen/Rewriting/Rewriting_Sterm.thy b/thys/CakeML_Codegen/Rewriting/Rewriting_Sterm.thy
--- a/thys/CakeML_Codegen/Rewriting/Rewriting_Sterm.thy
+++ b/thys/CakeML_Codegen/Rewriting/Rewriting_Sterm.thy
@@ -1,668 +1,668 @@
section \<open>Sequential pattern matching\<close>
theory Rewriting_Sterm
imports Rewriting_Pterm
begin
type_synonym srule = "name \<times> sterm"
abbreviation closed_srules :: "srule list \<Rightarrow> bool" where
"closed_srules \<equiv> list_all (closed \<circ> snd)"
primrec srule :: "srule \<Rightarrow> bool" where
"srule (_, rhs) \<longleftrightarrow> wellformed rhs \<and> closed rhs \<and> is_abs rhs"
lemma sruleI[intro!]: "wellformed rhs \<Longrightarrow> closed rhs \<Longrightarrow> is_abs rhs \<Longrightarrow> srule (name, rhs)"
by simp
locale srules = constants C_info "fst |`| fset_of_list rs" for C_info and rs :: "srule list" +
assumes all_rules: "list_all srule rs"
assumes distinct: "distinct (map fst rs)"
assumes not_shadows: "list_all (\<lambda>(_, rhs). \<not> shadows_consts rhs) rs"
assumes swelldefined_rs: "list_all (\<lambda>(_, rhs). welldefined rhs) rs"
begin
lemma map: "is_map (set rs)"
using distinct by (rule distinct_is_map)
lemma clausesE:
assumes "(name, rhs) \<in> set rs"
obtains cs where "rhs = Sabs cs"
proof -
from assms have "is_abs rhs"
using all_rules unfolding list_all_iff by auto
then obtain cs where "rhs = Sabs cs"
by (cases rhs) (auto simp: is_abs_def term_cases_def)
with that show thesis .
qed
end
subsubsection \<open>Rewriting\<close>
inductive srewrite_step where
cons_match: "srewrite_step ((name, rhs) # rest) name rhs" |
cons_nomatch: "name \<noteq> name' \<Longrightarrow> srewrite_step rs name rhs \<Longrightarrow> srewrite_step ((name', rhs') # rs) name rhs"
lemma srewrite_stepI0:
assumes "(name, rhs) \<in> set rs" "is_map (set rs)"
shows "srewrite_step rs name rhs"
using assms proof (induction rs)
case (Cons r rs)
then obtain name' rhs' where "r = (name', rhs')" by force
show ?case
proof (cases "name = name'")
case False
show ?thesis
unfolding \<open>r = _\<close>
apply (rule srewrite_step.cons_nomatch)
subgoal by fact
apply (rule Cons)
using False Cons(2) \<open>r = _\<close> apply force
using Cons(3) unfolding is_map_def by auto
next
case True
have "rhs = rhs'"
apply (rule is_mapD)
apply fact
unfolding \<open>r = _\<close>
using Cons(2) \<open>r = _\<close> apply simp
using True apply simp
done
show ?thesis
unfolding \<open>r = _\<close> \<open>name = _\<close> \<open>rhs = _\<close>
by (rule srewrite_step.cons_match)
qed
qed auto
lemma (in srules) srewrite_stepI: "(name, rhs) \<in> set rs \<Longrightarrow> srewrite_step rs name rhs"
using map
by (metis srewrite_stepI0)
hide_fact srewrite_stepI0
inductive srewrite :: "srule list \<Rightarrow> sterm \<Rightarrow> sterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>s/ _ \<longrightarrow>/ _" [50,0,50] 50) for rs where
step: "srewrite_step rs name rhs \<Longrightarrow> rs \<turnstile>\<^sub>s Sconst name \<longrightarrow> rhs" |
beta: "rewrite_first cs t t' \<Longrightarrow> rs \<turnstile>\<^sub>s Sabs cs $\<^sub>s t \<longrightarrow> t'" |
"fun": "rs \<turnstile>\<^sub>s t \<longrightarrow> t' \<Longrightarrow> rs \<turnstile>\<^sub>s t $\<^sub>s u \<longrightarrow> t' $\<^sub>s u" |
arg: "rs \<turnstile>\<^sub>s u \<longrightarrow> u' \<Longrightarrow> rs \<turnstile>\<^sub>s t $\<^sub>s u \<longrightarrow> t $\<^sub>s u'"
code_pred srewrite .
abbreviation srewrite_rt :: "srule list \<Rightarrow> sterm \<Rightarrow> sterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>s/ _ \<longrightarrow>*/ _" [50,0,50] 50) where
"srewrite_rt rs \<equiv> (srewrite rs)\<^sup>*\<^sup>*"
global_interpretation srewrite: rewriting "srewrite rs" for rs
by standard (auto intro: srewrite.intros simp: app_sterm_def)+
code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) srewrite_step .
code_pred (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) srewrite .
subsubsection \<open>Translation from @{typ pterm} to @{typ sterm}\<close>
text \<open>
In principle, any function of type @{typ \<open>('a \<times> 'b) fset \<Rightarrow> ('a \<times> 'b) list\<close>} that orders
by keys would do here. However, For simplicity's sake, we choose a fixed one
(@{const ordered_fmap}) here.
\<close>
primrec pterm_to_sterm :: "pterm \<Rightarrow> sterm" where
"pterm_to_sterm (Pconst name) = Sconst name" |
"pterm_to_sterm (Pvar name) = Svar name" |
"pterm_to_sterm (t $\<^sub>p u) = pterm_to_sterm t $\<^sub>s pterm_to_sterm u" |
"pterm_to_sterm (Pabs cs) = Sabs (ordered_fmap (map_prod id pterm_to_sterm |`| cs))"
lemma pterm_to_sterm:
assumes "no_abs t"
shows "pterm_to_sterm t = convert_term t"
using assms proof induction
case (free name)
show ?case
apply simp
apply (simp add: free_sterm_def free_pterm_def)
done
next
case (const name)
show ?case
apply simp
apply (simp add: const_sterm_def const_pterm_def)
done
next
case (app t\<^sub>1 t\<^sub>2)
then show ?case
apply simp
apply (simp add: app_sterm_def app_pterm_def)
done
qed
text \<open>
@{const sterm_to_pterm} has to be defined, for technical reasons, in
@{theory CakeML_Codegen.Pterm}.
\<close>
lemma pterm_to_sterm_wellformed:
assumes "wellformed t"
shows "wellformed (pterm_to_sterm t)"
using assms proof (induction t rule: pterm_induct)
case (Pabs cs)
show ?case
apply simp
unfolding map_prod_def id_apply
apply (intro conjI)
subgoal
apply (subst list_all_iff_fset)
apply (subst ordered_fmap_set_eq)
apply (rule is_fmap_image)
using Pabs apply simp
apply (rule fBallI)
apply (erule fimageE)
apply auto[]
using Pabs(2) apply auto[]
apply (rule Pabs)
using Pabs(2) by auto
subgoal
apply (rule ordered_fmap_distinct)
apply (rule is_fmap_image)
using Pabs(2) by simp
subgoal
apply (subgoal_tac "cs \<noteq> {||}")
including fset.lifting apply transfer
unfolding ordered_map_def
using Pabs(2) by auto
done
qed auto
lemma pterm_to_sterm_sterm_to_pterm:
assumes "wellformed t"
shows "sterm_to_pterm (pterm_to_sterm t) = t"
using assms proof (induction t)
case (Pabs cs)
note fset_of_list_map[simp del]
show ?case
apply simp
unfolding map_prod_def id_apply
apply (subst ordered_fmap_image)
subgoal
apply (rule is_fmap_image)
using Pabs by simp
apply (subst ordered_fmap_set_eq)
subgoal
apply (rule is_fmap_image)
apply (rule is_fmap_image)
using Pabs by simp
subgoal
apply (subst fset.map_comp)
apply (subst map_prod_def[symmetric])+
unfolding o_def
apply (subst prod.map_comp)
apply (subst id_def[symmetric])+
apply simp
apply (subst map_prod_def)
unfolding id_def
apply (rule fset_map_snd_id)
apply simp
apply (rule Pabs)
- using Pabs(2) by (auto simp: fmember.rep_eq snds.simps)
+ using Pabs(2) by (auto simp: fmember_iff_member_fset snds.simps)
done
qed auto
corollary pterm_to_sterm_frees: "wellformed t \<Longrightarrow> frees (pterm_to_sterm t) = frees t"
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_frees)
corollary pterm_to_sterm_closed:
"closed_except t S \<Longrightarrow> wellformed t \<Longrightarrow> closed_except (pterm_to_sterm t) S"
unfolding closed_except_def
by (simp add: pterm_to_sterm_frees)
corollary pterm_to_sterm_consts: "wellformed t \<Longrightarrow> consts (pterm_to_sterm t) = consts t"
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_consts)
corollary (in constants) pterm_to_sterm_shadows:
"wellformed t \<Longrightarrow> shadows_consts t \<longleftrightarrow> shadows_consts (pterm_to_sterm t)"
unfolding shadows_consts_def
by (metis pterm_to_sterm_sterm_to_pterm sterm_to_pterm_all_frees)
definition compile :: "prule fset \<Rightarrow> srule list" where
"compile rs = ordered_fmap (map_prod id pterm_to_sterm |`| rs)"
subsubsection \<open>Correctness of translation\<close>
context prules begin
lemma compile_heads: "fst |`| fset_of_list (compile rs) = fst |`| rs"
unfolding compile_def
apply (subst ordered_fmap_set_eq)
apply (subst map_prod_def, subst id_apply)
apply (rule is_fmap_image)
apply (rule fmap)
apply simp
done
lemma compile_rules: "srules C_info (compile rs)"
proof
show "list_all srule (compile rs)"
using fmap all_rules
unfolding compile_def list_all_iff
including fset.lifting
apply transfer
apply (subst ordered_map_set_eq)
subgoal by simp
subgoal
unfolding map_prod_def id_def
by (erule is_map_image)
subgoal
apply (rule ballI)
apply safe
subgoal
apply (rule pterm_to_sterm_wellformed)
apply fastforce
done
subgoal
apply (rule pterm_to_sterm_closed)
apply fastforce
apply fastforce
done
subgoal for _ _ a b
apply (erule ballE[where x = "(a, b)"])
apply (cases b; auto)
apply (auto simp: is_abs_def term_cases_def)
done
done
done
next
show "distinct (map fst (compile rs))"
unfolding compile_def
apply (rule ordered_fmap_distinct)
unfolding map_prod_def id_def
apply (rule is_fmap_image)
apply (rule fmap)
done
next
have "list_all (\<lambda>(_, rhs). welldefined rhs) (compile rs)"
unfolding compile_def
apply (subst ordered_fmap_list_all)
subgoal
apply (subst map_prod_def)
apply (subst id_apply)
apply (rule is_fmap_image)
by (fact fmap)
apply simp
apply (rule fBallI)
subgoal for x
apply (cases x, simp)
apply (subst pterm_to_sterm_consts)
using all_rules apply force
using welldefined_rs by force
done
thus "list_all (\<lambda>(_, rhs). consts rhs |\<subseteq>| pre_constants.all_consts C_info (fst |`| fset_of_list (compile rs))) (compile rs)"
by (simp add: compile_heads)
next
interpret c: constants _ "fset_of_list (map fst (compile rs))"
by (simp add: constants_axioms compile_heads)
have all_consts: "c.all_consts = all_consts"
by (simp add: compile_heads)
note fset_of_list_map[simp del]
have "list_all (\<lambda>(_, rhs). \<not> shadows_consts rhs) (compile rs)"
unfolding compile_def
apply (subst list_all_iff_fset)
apply (subst ordered_fmap_set_eq)
apply (subst map_prod_def)
unfolding id_apply
apply (rule is_fmap_image)
apply (fact fmap)
apply simp
apply (rule fBall_pred_weaken[where P = "\<lambda>(_, rhs). \<not> shadows_consts rhs"])
subgoal for x
apply (cases x, simp)
apply (subst (asm) pterm_to_sterm_shadows)
using all_rules apply force
by simp
subgoal
using not_shadows by force
done
thus "list_all (\<lambda>(_, rhs). \<not> pre_constants.shadows_consts C_info (fst |`| fset_of_list (compile rs)) rhs) (compile rs)"
unfolding compile_heads all_consts .
next
show "fdisjnt (fst |`| fset_of_list (compile rs)) C"
unfolding compile_def
apply (subst fset_of_list_map[symmetric])
apply (subst ordered_fmap_keys)
apply (subst map_prod_def)
apply (subst id_apply)
apply (rule is_fmap_image)
using fmap disjnt by auto
next
show "distinct all_constructors"
by (fact distinct_ctr)
qed
sublocale prules_as_srules: srules C_info "compile rs"
by (fact compile_rules)
end
global_interpretation srelated: term_struct_rel_strong "(\<lambda>p s. p = sterm_to_pterm s)"
proof (standard, goal_cases)
case (5 name t)
then show ?case by (cases t) (auto simp: const_sterm_def const_pterm_def split: option.splits)
next
case (6 u\<^sub>1 u\<^sub>2 t)
then show ?case by (cases t) (auto simp: app_sterm_def app_pterm_def split: option.splits)
qed (auto simp: const_sterm_def const_pterm_def app_sterm_def app_pterm_def)
lemma srelated_subst:
assumes "srelated.P_env penv senv"
shows "subst (sterm_to_pterm t) penv = sterm_to_pterm (subst t senv)"
using assms
proof (induction t arbitrary: penv senv)
case (Svar name)
thus ?case
by (cases rule: fmrel_cases[where x = name]) auto
next
case (Sabs cs)
show ?case
apply simp
including fset.lifting
apply (transfer' fixing: cs penv senv)
unfolding set_map image_comp
apply (rule image_cong[OF refl])
unfolding comp_apply
apply (case_tac x)
apply hypsubst_thin
apply simp
apply (rule Sabs)
apply assumption
apply (simp add: snds.simps)
apply rule
apply (rule Sabs)
done
qed auto
context begin
private lemma srewrite_step_non_empty: "srewrite_step rs' name rhs \<Longrightarrow> rs' \<noteq> []"
by (induct rule: srewrite_step.induct) auto
private lemma compile_consE:
assumes "(name, rhs') # rest = compile rs" "is_fmap rs"
obtains rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs" "rest = compile (rs - {| (name, rhs) |})"
proof -
from assms have "ordered_fmap (map_prod id pterm_to_sterm |`| rs) = (name, rhs') # rest"
unfolding compile_def
by simp
hence "(name, rhs') \<in> set (ordered_fmap (map_prod id pterm_to_sterm |`| rs))"
by simp
have "(name, rhs') |\<in>| map_prod id pterm_to_sterm |`| rs"
apply (rule ordered_fmap_sound)
subgoal
unfolding map_prod_def id_apply
apply (rule is_fmap_image)
apply fact
done
subgoal by fact
done
then obtain rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs"
by auto
have "rest = compile (rs - {| (name, rhs) |})"
unfolding compile_def
apply (subst inj_on_fimage_set_diff[where C = rs])
subgoal
apply (rule inj_onI)
apply safe
apply auto
- apply (subst (asm) fmember.rep_eq[symmetric])+
+ apply (subst (asm) fmember_iff_member_fset[symmetric])+
using \<open>is_fmap rs\<close> by (blast dest: is_fmapD)
subgoal by simp
subgoal using \<open>(name, rhs) |\<in>| rs\<close> by simp
subgoal
apply simp
apply (subst ordered_fmap_remove)
apply (subst map_prod_def)
unfolding id_apply
apply (rule is_fmap_image)
apply fact
using \<open>(name, rhs) |\<in>| rs\<close> apply force
apply (subst \<open>rhs' = pterm_to_sterm rhs\<close>[symmetric])
apply (subst \<open>ordered_fmap _ = _\<close>[unfolded id_def])
by simp
done
show thesis
by (rule that) fact+
qed
private lemma compile_correct_step:
assumes "srewrite_step (compile rs) name rhs" "is_fmap rs" "fBall rs prule"
shows "(name, sterm_to_pterm rhs) |\<in>| rs"
using assms proof (induction "compile rs" name rhs arbitrary: rs)
case (cons_match name rhs' rest)
then obtain rhs where "rhs' = pterm_to_sterm rhs" "(name, rhs) |\<in>| rs"
by (auto elim: compile_consE)
show ?case
unfolding \<open>rhs' = _\<close>
apply (subst pterm_to_sterm_sterm_to_pterm)
using fbspec[OF \<open>fBall rs prule\<close> \<open>(name, rhs) |\<in>| rs\<close>] apply force
by fact
next
case (cons_nomatch name name\<^sub>1 rest rhs rhs\<^sub>1')
then obtain rhs\<^sub>1 where "rhs\<^sub>1' = pterm_to_sterm rhs\<^sub>1" "(name\<^sub>1, rhs\<^sub>1) |\<in>| rs" "rest = compile (rs - {| (name\<^sub>1, rhs\<^sub>1) |})"
by (auto elim: compile_consE)
let ?rs' = "rs - {| (name\<^sub>1, rhs\<^sub>1) |}"
have "(name, sterm_to_pterm rhs) |\<in>| ?rs'"
proof (intro cons_nomatch)
show "rest = compile ?rs'"
by fact
show "is_fmap (rs |-| {|(name\<^sub>1, rhs\<^sub>1)|})"
using \<open>is_fmap rs\<close>
by (rule is_fmap_subset) auto
show "fBall ?rs' prule"
using cons_nomatch by blast
qed
thus ?case
by simp
qed
lemma compile_correct0:
assumes "compile rs \<turnstile>\<^sub>s u \<longrightarrow> u'" "prules C rs"
shows "rs \<turnstile>\<^sub>p sterm_to_pterm u \<longrightarrow> sterm_to_pterm u'"
using assms proof induction
case (beta cs t t')
then obtain pat rhs env where "(pat, rhs) \<in> set cs" "match pat t = Some env" "t' = subst rhs env"
by (auto elim: rewrite_firstE)
then obtain env' where "match pat (sterm_to_pterm t) = Some env'" "srelated.P_env env' env"
by (metis option.distinct(1) option.inject option.rel_cases srelated.match_rel)
hence "subst (sterm_to_pterm rhs) env' = sterm_to_pterm (subst rhs env)"
by (simp add: srelated_subst)
let ?rhs' = "sterm_to_pterm rhs"
have "(pat, ?rhs') |\<in>| fset_of_list (map (map_prod id sterm_to_pterm) cs)"
using \<open>(pat, rhs) \<in> set cs\<close>
including fset.lifting
by transfer' force
note fset_of_list_map[simp del]
show ?case
apply simp
apply (rule prewrite.intros)
apply fact
unfolding rewrite_step.simps
apply (subst map_option_eq_Some)
apply (intro exI conjI)
apply fact
unfolding \<open>t' = _\<close>
by fact
next
case (step name rhs)
hence "(name, sterm_to_pterm rhs) |\<in>| rs"
unfolding prules_def prules_axioms_def
by (metis compile_correct_step)
thus ?case
by (auto intro: prewrite.intros)
qed (auto intro: prewrite.intros)
end
lemma (in prules) compile_correct:
assumes "compile rs \<turnstile>\<^sub>s u \<longrightarrow> u'"
shows "rs \<turnstile>\<^sub>p sterm_to_pterm u \<longrightarrow> sterm_to_pterm u'"
by (rule compile_correct0) (fact | standard)+
hide_fact compile_correct0
subsubsection \<open>Completeness of translation\<close>
global_interpretation srelated': term_struct_rel_strong "(\<lambda>p s. pterm_to_sterm p = s)"
proof (standard, goal_cases)
case (1 t name)
then show ?case by (cases t) (auto simp: const_sterm_def const_pterm_def split: option.splits)
next
case (3 t u\<^sub>1 u\<^sub>2)
then show ?case by (cases t) (auto simp: app_sterm_def app_pterm_def split: option.splits)
qed (auto simp: const_sterm_def const_pterm_def app_sterm_def app_pterm_def)
corollary srelated_env_unique:
"srelated'.P_env penv senv \<Longrightarrow> srelated'.P_env penv senv' \<Longrightarrow> senv = senv'"
apply (subst (asm) fmrel_iff)+
apply (subst (asm) option.rel_sel)+
apply (rule fmap_ext)
by (metis option.exhaust_sel)
lemma srelated_subst':
assumes "srelated'.P_env penv senv" "wellformed t"
shows "pterm_to_sterm (subst t penv) = subst (pterm_to_sterm t) senv"
using assms proof (induction t arbitrary: penv senv)
case (Pvar name)
thus ?case
by (cases rule: fmrel_cases[where x = name]) auto
next
case (Pabs cs)
hence "is_fmap cs"
by force
show ?case
apply simp
unfolding map_prod_def id_apply
apply (subst ordered_fmap_image[symmetric])
apply fact
apply (subst fset.map_comp[symmetric])
apply (subst ordered_fmap_image[symmetric])
subgoal by (rule is_fmap_image) fact
apply (subst ordered_fmap_image[symmetric])
apply fact
apply auto
apply (drule ordered_fmap_sound[OF \<open>is_fmap cs\<close>])
subgoal for pat rhs
apply (rule Pabs)
- apply (subst (asm) fmember.rep_eq)
+ apply (subst (asm) fmember_iff_member_fset)
apply assumption
apply auto
using Pabs by force+
done
qed auto
lemma srelated_find_match:
assumes "find_match cs t = Some (penv, pat, rhs)" "srelated'.P_env penv senv"
shows "find_match (map (map_prod id pterm_to_sterm) cs) (pterm_to_sterm t) = Some (senv, pat, pterm_to_sterm rhs)"
proof -
let ?cs' = "map (map_prod id pterm_to_sterm) cs"
let ?t' = "pterm_to_sterm t"
have *: "list_all2 (rel_prod (=) (\<lambda>p s. pterm_to_sterm p = s)) cs ?cs'"
unfolding list.rel_map
by (auto intro: list.rel_refl)
obtain senv0
where "find_match ?cs' ?t' = Some (senv0, pat, pterm_to_sterm rhs)" "srelated'.P_env penv senv0"
using srelated'.find_match_rel[OF * refl, where t = t, unfolded assms]
unfolding option_rel_Some1 rel_prod_conv
by auto
with assms have "senv = senv0"
by (metis srelated_env_unique)
show ?thesis
unfolding \<open>senv = _\<close> by fact
qed
lemma (in prules) compile_complete:
assumes "rs \<turnstile>\<^sub>p t \<longrightarrow> t'" "wellformed t"
shows "compile rs \<turnstile>\<^sub>s pterm_to_sterm t \<longrightarrow> pterm_to_sterm t'"
using assms proof induction
case (step name rhs)
then show ?case
apply simp
apply rule
apply (rule prules_as_srules.srewrite_stepI)
unfolding compile_def
apply (subst fset_of_list_elem[symmetric])
apply (subst ordered_fmap_set_eq)
apply (insert fmap)
apply (rule is_fmapI)
apply (force dest: is_fmapD)
by (simp add: rev_fimage_eqI)
next
case (beta c cs t t')
from beta obtain pat rhs penv where "c = (pat, rhs)" "match pat t = Some penv" "subst rhs penv = t'"
by (metis (no_types, lifting) map_option_eq_Some rewrite_step.simps surj_pair)
then obtain senv where "match pat (pterm_to_sterm t) = Some senv" "srelated'.P_env penv senv"
by (metis option_rel_Some1 srelated'.match_rel)
have "wellformed rhs"
using beta \<open>c = _\<close> prules.all_rules prule.simps
by force
then have "subst (pterm_to_sterm rhs) senv = pterm_to_sterm t'"
using srelated_subst' \<open>_ = t'\<close> \<open>srelated'.P_env _ _\<close>
by metis
have "(pat, pterm_to_sterm rhs) |\<in>| map_prod id pterm_to_sterm |`| cs"
using beta \<open>c = _\<close>
by (metis fimage_eqI id_def map_prod_simp)
have "is_fmap cs"
using beta
by auto
have "find_match (ordered_fmap cs) t = Some (penv, pat, rhs)"
apply (rule compatible_find_match)
subgoal
apply (subst ordered_fmap_set_eq[OF \<open>is_fmap cs\<close>])+
using beta by simp
subgoal
unfolding list_all_iff
apply rule
apply (rename_tac x, case_tac x)
apply simp
apply (drule ordered_fmap_sound[OF \<open>is_fmap cs\<close>])
using beta by auto
subgoal
apply (subst ordered_fmap_set_eq)
by fact
subgoal
by fact
subgoal
using beta(1) \<open>c = _\<close> \<open>is_fmap cs\<close>
using fset_of_list_elem ordered_fmap_set_eq by fast
done
show ?case
apply simp
apply rule
apply (subst \<open>_ = pterm_to_sterm t'\<close>[symmetric])
apply (rule find_match_rewrite_first)
unfolding map_prod_def id_apply
apply (subst ordered_fmap_image[symmetric])
apply fact
apply (subst map_prod_def[symmetric])
apply (subst id_def[symmetric])
apply (rule srelated_find_match)
by fact+
qed (auto intro: srewrite.intros)
subsubsection \<open>Computability\<close>
export_code compile
checking Scala
end
\ No newline at end of file
diff --git a/thys/CakeML_Codegen/Terms/Pterm.thy b/thys/CakeML_Codegen/Terms/Pterm.thy
--- a/thys/CakeML_Codegen/Terms/Pterm.thy
+++ b/thys/CakeML_Codegen/Terms/Pterm.thy
@@ -1,474 +1,474 @@
section \<open>Terms with explicit pattern matching\<close>
theory Pterm
imports
"../Utils/Compiler_Utils"
Consts
Sterm \<comment> \<open>Inclusion of this theory might seem a bit strange. Indeed, it is only for technical
reasons: to allow for a \<^theory_text>\<open>quickcheck\<close> setup.\<close>
begin
datatype pterm =
Pconst name |
Pvar name |
Pabs "(term \<times> pterm) fset" |
Papp pterm pterm (infixl "$\<^sub>p" 70)
primrec sterm_to_pterm :: "sterm \<Rightarrow> pterm" where
"sterm_to_pterm (Sconst name) = Pconst name" |
"sterm_to_pterm (Svar name) = Pvar name" |
"sterm_to_pterm (t $\<^sub>s u) = sterm_to_pterm t $\<^sub>p sterm_to_pterm u" |
"sterm_to_pterm (Sabs cs) = Pabs (fset_of_list (map (map_prod id sterm_to_pterm) cs))"
quickcheck_generator pterm
\<comment> \<open>will print some fishy ``constructor'' names, but at least it works\<close>
constructors: sterm_to_pterm
lemma sterm_to_pterm_total:
obtains t' where "t = sterm_to_pterm t'"
proof (induction t arbitrary: thesis)
case (Pconst x)
then show ?case
by (metis sterm_to_pterm.simps)
next
case (Pvar x)
then show ?case
by (metis sterm_to_pterm.simps)
next
case (Pabs cs)
from Pabs.IH obtain cs' where "cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
apply atomize_elim
proof (induction cs)
case empty
show ?case
apply (rule exI[where x = "[]"])
by simp
next
case (insert c cs)
obtain pat rhs where "c = (pat, rhs)" by (cases c) auto
have "\<exists>cs'. cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
apply (rule insert)
using insert.prems unfolding finsert.rep_eq
by blast
then obtain cs' where "cs = fset_of_list (map (map_prod id sterm_to_pterm) cs')"
by blast
obtain rhs' where "rhs = sterm_to_pterm rhs'"
apply (rule insert.prems[of "(pat, rhs)" rhs])
unfolding \<open>c = _\<close> by simp+
show ?case
apply (rule exI[where x = "(pat, rhs') # cs'"])
unfolding \<open>c = _\<close> \<open>cs = _\<close> \<open>rhs = _\<close>
by (simp add: id_def)
qed
hence "Pabs cs = sterm_to_pterm (Sabs cs')"
by simp
then show ?case
using Pabs by metis
next
case (Papp t1 t2)
then obtain t1' t2' where "t1 = sterm_to_pterm t1'" "t2 = sterm_to_pterm t2'"
by metis
then have "t1 $\<^sub>p t2 = sterm_to_pterm (t1' $\<^sub>s t2')"
by simp
with Papp show ?case
by metis
qed
lemma pterm_induct[case_names Pconst Pvar Pabs Papp]:
assumes "\<And>x. P (Pconst x)"
assumes "\<And>x. P (Pvar x)"
assumes "\<And>cs. (\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> P t) \<Longrightarrow> P (Pabs cs)"
assumes "\<And>t u. P t \<Longrightarrow> P u \<Longrightarrow> P (t $\<^sub>p u)"
shows "P t"
proof (rule pterm.induct, goal_cases)
case (3 cs)
show ?case
apply (rule assms)
using 3
- apply (subst (asm) fmember.rep_eq[symmetric])
+ apply (subst (asm) fmember_iff_member_fset[symmetric])
by auto
qed fact+
instantiation pterm :: pre_term begin
definition app_pterm where
"app_pterm t u = t $\<^sub>p u"
fun unapp_pterm where
"unapp_pterm (t $\<^sub>p u) = Some (t, u)" |
"unapp_pterm _ = None"
definition const_pterm where
"const_pterm = Pconst"
fun unconst_pterm where
"unconst_pterm (Pconst name) = Some name" |
"unconst_pterm _ = None"
definition free_pterm where
"free_pterm = Pvar"
fun unfree_pterm where
"unfree_pterm (Pvar name) = Some name" |
"unfree_pterm _ = None"
function (sequential) subst_pterm where
"subst_pterm (Pvar s) env = (case fmlookup env s of Some t \<Rightarrow> t | None \<Rightarrow> Pvar s)" |
"subst_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) env = subst_pterm t\<^sub>1 env $\<^sub>p subst_pterm t\<^sub>2 env" |
"subst_pterm (Pabs cs) env = Pabs ((\<lambda>(pat, rhs). (pat, subst_pterm rhs (fmdrop_fset (frees pat) env))) |`| cs)" |
"subst_pterm t _ = t"
by pat_completeness auto
termination
proof (relation "measure (size \<circ> fst)", goal_cases)
case 4
then show ?case
apply auto
including fset.lifting apply transfer
apply (rule le_imp_less_Suc)
apply (rule sum_nat_le_single[where y = "(a, (b, size b))" for a b])
by auto
qed auto
primrec consts_pterm :: "pterm \<Rightarrow> name fset" where
"consts_pterm (Pconst x) = {|x|}" |
"consts_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = consts_pterm t\<^sub>1 |\<union>| consts_pterm t\<^sub>2" |
"consts_pterm (Pabs cs) = ffUnion (snd |`| map_prod id consts_pterm |`| cs)" |
"consts_pterm (Pvar _) = {||}"
primrec frees_pterm :: "pterm \<Rightarrow> name fset" where
"frees_pterm (Pvar x) = {|x|}" |
"frees_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = frees_pterm t\<^sub>1 |\<union>| frees_pterm t\<^sub>2" |
"frees_pterm (Pabs cs) = ffUnion ((\<lambda>(pv, tv). tv - frees pv) |`| map_prod id frees_pterm |`| cs)" |
"frees_pterm (Pconst _) = {||}"
instance
by standard
(auto
simp: app_pterm_def const_pterm_def free_pterm_def
elim: unapp_pterm.elims unconst_pterm.elims unfree_pterm.elims
split: option.splits)
end
corollary subst_pabs_id:
assumes "\<And>pat rhs. (pat, rhs) |\<in>| cs \<Longrightarrow> subst rhs (fmdrop_fset (frees pat) env) = rhs"
shows "subst (Pabs cs) env = Pabs cs"
apply (subst subst_pterm.simps)
apply (rule arg_cong[where f = Pabs])
apply (rule fset_map_snd_id)
apply (rule assms)
-apply (subst (asm) fmember.rep_eq[symmetric])
+apply (subst (asm) fmember_iff_member_fset[symmetric])
apply assumption
done
corollary frees_pabs_alt_def:
"frees (Pabs cs) = ffUnion ((\<lambda>(pat, rhs). frees rhs - frees pat) |`| cs)"
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule fset.map_cong[OF refl])
by auto
lemma sterm_to_pterm_frees[simp]: "frees (sterm_to_pterm t) = frees t"
proof (induction t)
case (Sabs cs)
show ?case
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule fimage_cong[OF refl])
apply clarsimp
apply (subst Sabs)
by (auto simp: fset_of_list_elem snds.simps)
qed auto
lemma sterm_to_pterm_consts[simp]: "consts (sterm_to_pterm t) = consts t"
proof (induction t)
case (Sabs cs)
show ?case
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule fimage_cong[OF refl])
apply clarsimp
apply (subst Sabs)
by (auto simp: fset_of_list_elem snds.simps)
qed auto
lemma subst_sterm_to_pterm:
"subst (sterm_to_pterm t) (fmmap sterm_to_pterm env) = sterm_to_pterm (subst t env)"
proof (induction t arbitrary: env rule: sterm_induct)
case (Sabs cs)
show ?case
apply simp
apply (rule fset.map_cong0)
apply (auto split: prod.splits)
apply (rule Sabs)
by (auto simp: fset_of_list.rep_eq)
qed (auto split: option.splits)
instantiation pterm :: "term" begin
definition abs_pred_pterm :: "(pterm \<Rightarrow> bool) \<Rightarrow> pterm \<Rightarrow> bool" where
[code del]: "abs_pred P t \<longleftrightarrow> (\<forall>cs. t = Pabs cs \<longrightarrow> (\<forall>pat t. (pat, t) |\<in>| cs \<longrightarrow> P t) \<longrightarrow> P t)"
context begin
private lemma abs_pred_trivI0: "P t \<Longrightarrow> abs_pred P (t::pterm)"
unfolding abs_pred_pterm_def by auto
instance proof (standard, goal_cases)
case (1 P t)
then show ?case
by (induction t rule: pterm_induct)
(auto simp: const_pterm_def free_pterm_def app_pterm_def abs_pred_pterm_def)
next
(* FIXME proving 2, 3 and 4 via sterm probably requires lifting setup *)
(* lifting setup requires a consistent ordering without assumptions! *)
(* but: other parts (in Eq_Logic_PM_Seq) require a key-ordering that only works with assumptions *)
(* solution: don't try to abstract over the ordering *)
case (2 t)
show ?case
unfolding abs_pred_pterm_def
apply clarify
apply (rule subst_pabs_id)
by blast
next
case (3 x t)
show ?case
unfolding abs_pred_pterm_def
apply clarsimp
apply (rule fset.map_cong0)
apply (rename_tac c)
apply (case_tac c; hypsubst_thin)
apply simp
subgoal for cs env pat rhs
apply (cases "x |\<in>| frees pat")
subgoal
apply (rule arg_cong[where f = "subst rhs"])
by (auto intro: fmap_ext)
subgoal premises prems[rule_format]
apply (subst (2) prems(1)[symmetric, where pat = pat])
subgoal
- by (subst fmember.rep_eq) fact
+ by (subst fmember_iff_member_fset) fact
subgoal
using prems unfolding ffUnion_alt_def
- by (auto simp: fmember.rep_eq fset_of_list.rep_eq elim!: fBallE)
+ by (auto simp: fmember_iff_member_fset fset_of_list.rep_eq elim!: fBallE)
subgoal
apply (rule arg_cong[where f = "subst rhs"])
by (auto intro: fmap_ext)
done
done
done
next
case (4 t)
show ?case
unfolding abs_pred_pterm_def
apply clarsimp
apply (rule fset.map_cong0)
apply clarsimp
subgoal premises prems[rule_format] for cs env\<^sub>1 env\<^sub>2 a b
- apply (rule prems(2)[unfolded fmember.rep_eq, OF prems(5)])
+ apply (rule prems(2)[unfolded fmember_iff_member_fset, OF prems(5)])
using prems unfolding fdisjnt_alt_def by auto
done
next
case 5
show ?case
proof (rule abs_pred_trivI0, clarify)
fix t :: pterm
fix env :: "(name, pterm) fmap"
obtain t' where "t = sterm_to_pterm t'"
by (rule sterm_to_pterm_total)
obtain env' where "env = fmmap sterm_to_pterm env'"
by (metis fmmap_total sterm_to_pterm_total)
show "frees (subst t env) = frees t - fmdom env" if "fmpred (\<lambda>_. closed) env"
unfolding \<open>t = _\<close> \<open>env = _\<close>
apply simp
apply (subst subst_sterm_to_pterm)
apply simp
apply (rule subst_frees)
using that unfolding \<open>env = _\<close>
apply simp
apply (rule fmpred_mono_strong; assumption?)
unfolding closed_except_def by simp
qed
next
case 6
show ?case
proof (rule abs_pred_trivI0, clarify)
fix t :: pterm
fix env :: "(name, pterm) fmap"
obtain t' where "t = sterm_to_pterm t'"
by (rule sterm_to_pterm_total)
obtain env' where "env = fmmap sterm_to_pterm env'"
by (metis fmmap_total sterm_to_pterm_total)
show "consts (subst t env) = consts t |\<union>| ffUnion (consts |`| fmimage env (frees t))"
unfolding \<open>t = _\<close> \<open>env = _\<close>
apply simp
apply (subst comp_def)
apply simp
apply (subst subst_sterm_to_pterm)
apply simp
apply (rule subst_consts')
done
qed
qed (rule abs_pred_trivI0)
end
end
lemma no_abs_abs[simp]: "\<not> no_abs (Pabs cs)"
by (subst no_abs.simps) (auto simp: term_cases_def)
lemma sterm_to_pterm:
assumes "no_abs t"
shows "sterm_to_pterm t = convert_term t"
using assms proof induction
case (free name)
show ?case
apply simp
apply (simp add: free_sterm_def free_pterm_def)
done
next
case (const name)
show ?case
apply simp
apply (simp add: const_sterm_def const_pterm_def)
done
next
case (app t\<^sub>1 t\<^sub>2)
then show ?case
apply simp
apply (simp add: app_sterm_def app_pterm_def)
done
qed
abbreviation Pabs_single ("\<Lambda>\<^sub>p _. _" [0, 50] 50) where
"Pabs_single x rhs \<equiv> Pabs {| (Free x, rhs) |}"
lemma closed_except_simps:
"closed_except (Pvar x) S \<longleftrightarrow> x |\<in>| S"
"closed_except (t\<^sub>1 $\<^sub>p t\<^sub>2) S \<longleftrightarrow> closed_except t\<^sub>1 S \<and> closed_except t\<^sub>2 S"
"closed_except (Pabs cs) S \<longleftrightarrow> fBall cs (\<lambda>(pat, t). closed_except t (S |\<union>| frees pat))"
"closed_except (Pconst name) S \<longleftrightarrow> True"
proof goal_cases
case 3
show ?case
proof (standard, goal_cases)
case 1
then show ?case
apply (auto simp: ffUnion_alt_def closed_except_def)
apply (drule ffUnion_least_rev)
apply auto
by (smt case_prod_conv fBall_alt_def fminus_iff fset_rev_mp id_apply map_prod_simp)
next
case 2
then show ?case
by (fastforce simp: ffUnion_alt_def closed_except_def)
qed
qed (auto simp: ffUnion_alt_def closed_except_def)
instantiation pterm :: pre_strong_term begin
function (sequential) wellformed_pterm :: "pterm \<Rightarrow> bool" where
"wellformed_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) \<longleftrightarrow> wellformed_pterm t\<^sub>1 \<and> wellformed_pterm t\<^sub>2" |
"wellformed_pterm (Pabs cs) \<longleftrightarrow> fBall cs (\<lambda>(pat, t). linear pat \<and> wellformed_pterm t) \<and> is_fmap cs \<and> pattern_compatibles cs \<and> cs \<noteq> {||}" |
"wellformed_pterm _ \<longleftrightarrow> True"
by pat_completeness auto
termination
proof (relation "measure size", goal_cases)
case 4
then show ?case
apply auto
including fset.lifting apply transfer
apply (rule le_imp_less_Suc)
apply (rule sum_nat_le_single[where y = "(a, (b, size b))" for a b])
by auto
qed auto
primrec all_frees_pterm :: "pterm \<Rightarrow> name fset" where
"all_frees_pterm (Pvar x) = {|x|}" |
"all_frees_pterm (t\<^sub>1 $\<^sub>p t\<^sub>2) = all_frees_pterm t\<^sub>1 |\<union>| all_frees_pterm t\<^sub>2" |
"all_frees_pterm (Pabs cs) = ffUnion ((\<lambda>(P, T). P |\<union>| T) |`| map_prod frees all_frees_pterm |`| cs)" |
"all_frees_pterm (Pconst _) = {||}"
instance
by standard (auto simp: const_pterm_def free_pterm_def app_pterm_def)
end
lemma sterm_to_pterm_all_frees[simp]: "all_frees (sterm_to_pterm t) = all_frees t"
proof (induction t)
case (Sabs cs)
show ?case
apply simp
apply (rule arg_cong[where f = ffUnion])
apply (rule fimage_cong[OF refl])
apply clarsimp
apply (subst Sabs)
by (auto simp: fset_of_list_elem snds.simps)
qed auto
instance pterm :: strong_term proof (standard, goal_cases)
case (1 t)
obtain t' where "t = sterm_to_pterm t'"
by (metis sterm_to_pterm_total)
show ?case
apply (rule abs_pred_trivI)
unfolding \<open>t = _\<close> sterm_to_pterm_all_frees sterm_to_pterm_frees
by (rule frees_all_frees)
next
case (2 t)
show ?case
unfolding abs_pred_pterm_def
apply (intro allI impI)
apply (simp add: case_prod_twice, intro conjI)
subgoal by blast
subgoal by (auto intro: is_fmap_image)
subgoal
unfolding fpairwise_image fpairwise_alt_def
by (auto elim!: fBallE)
done
qed
lemma wellformed_PabsI:
assumes "is_fmap cs" "pattern_compatibles cs" "cs \<noteq> {||}"
assumes "\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> linear pat"
assumes "\<And>pat t. (pat, t) |\<in>| cs \<Longrightarrow> wellformed t"
shows "wellformed (Pabs cs)"
using assms by auto
corollary subst_closed_pabs:
assumes "(pat, rhs) |\<in>| cs" "closed (Pabs cs)"
shows "subst rhs (fmdrop_fset (frees pat) env) = rhs"
using assms by (subst subst_closed_except_id) (auto simp: fdisjnt_alt_def closed_except_simps)
lemma (in constants) shadows_consts_pterm_simps[simp]:
"shadows_consts (t\<^sub>1 $\<^sub>p t\<^sub>2) \<longleftrightarrow> shadows_consts t\<^sub>1 \<or> shadows_consts t\<^sub>2"
"shadows_consts (Pvar name) \<longleftrightarrow> name |\<in>| all_consts"
"shadows_consts (Pabs cs) \<longleftrightarrow> fBex cs (\<lambda>(pat, t). shadows_consts pat \<or> shadows_consts t)"
"shadows_consts (Pconst name) \<longleftrightarrow> False"
proof goal_cases
case 3
(* FIXME duplicated from Sterm *)
show ?case
unfolding shadows_consts_def
apply rule
subgoal
by (force simp: ffUnion_alt_def fset_of_list_elem fdisjnt_alt_def elim!: ballE)
subgoal
apply (auto simp: fset_of_list_elem fdisjnt_alt_def)
by (auto simp: fset_eq_empty_iff ffUnion_alt_def fset_of_list_elem elim!: allE fBallE)
done
qed (auto simp: shadows_consts_def fdisjnt_alt_def)
end
\ No newline at end of file
diff --git a/thys/CakeML_Codegen/Terms/Sterm.thy b/thys/CakeML_Codegen/Terms/Sterm.thy
--- a/thys/CakeML_Codegen/Terms/Sterm.thy
+++ b/thys/CakeML_Codegen/Terms/Sterm.thy
@@ -1,381 +1,381 @@
section \<open>Terms with sequential pattern matching\<close>
theory Sterm
imports Strong_Term
begin
datatype sterm =
Sconst name |
Svar name |
Sabs (clauses: "(term \<times> sterm) list") |
Sapp sterm sterm (infixl "$\<^sub>s" 70)
datatype_compat sterm
derive linorder sterm
abbreviation Sabs_single ("\<Lambda>\<^sub>s _. _" [0, 50] 50) where
"Sabs_single x rhs \<equiv> Sabs [(Free x, rhs)]"
type_synonym sclauses = "(term \<times> sterm) list"
lemma sterm_induct[case_names Sconst Svar Sabs Sapp]:
assumes "\<And>x. P (Sconst x)"
assumes "\<And>x. P (Svar x)"
assumes "\<And>cs. (\<And>pat t. (pat, t) \<in> set cs \<Longrightarrow> P t) \<Longrightarrow> P (Sabs cs)"
assumes "\<And>t u. P t \<Longrightarrow> P u \<Longrightarrow> P (t $\<^sub>s u)"
shows "P t"
using assms
apply induction_schema
apply pat_completeness
apply lexicographic_order
done
instantiation sterm :: pre_term begin
definition app_sterm where
"app_sterm t u = t $\<^sub>s u"
fun unapp_sterm where
"unapp_sterm (t $\<^sub>s u) = Some (t, u)" |
"unapp_sterm _ = None"
definition const_sterm where
"const_sterm = Sconst"
fun unconst_sterm where
"unconst_sterm (Sconst name) = Some name" |
"unconst_sterm _ = None"
fun unfree_sterm where
"unfree_sterm (Svar name) = Some name" |
"unfree_sterm _ = None"
definition free_sterm where
"free_sterm = Svar"
fun frees_sterm where
"frees_sterm (Svar name) = {|name|}" |
"frees_sterm (Sconst _) = {||}" |
"frees_sterm (Sabs cs) = ffUnion (fset_of_list (map (\<lambda>(pat, rhs). frees_sterm rhs - frees pat) cs))" |
"frees_sterm (t $\<^sub>s u) = frees_sterm t |\<union>| frees_sterm u"
fun subst_sterm where
"subst_sterm (Svar s) env = (case fmlookup env s of Some t \<Rightarrow> t | None \<Rightarrow> Svar s)" |
"subst_sterm (t\<^sub>1 $\<^sub>s t\<^sub>2) env = subst_sterm t\<^sub>1 env $\<^sub>s subst_sterm t\<^sub>2 env" |
"subst_sterm (Sabs cs) env = Sabs (map (\<lambda>(pat, rhs). (pat, subst_sterm rhs (fmdrop_fset (frees pat) env))) cs)" |
"subst_sterm t env = t"
fun consts_sterm :: "sterm \<Rightarrow> name fset" where
"consts_sterm (Svar _) = {||}" |
"consts_sterm (Sconst name) = {|name|}" |
"consts_sterm (Sabs cs) = ffUnion (fset_of_list (map (\<lambda>(_, rhs). consts_sterm rhs) cs))" |
"consts_sterm (t $\<^sub>s u) = consts_sterm t |\<union>| consts_sterm u"
instance
by standard
(auto
simp: app_sterm_def const_sterm_def free_sterm_def
elim: unapp_sterm.elims unconst_sterm.elims unfree_sterm.elims
split: option.splits)
end
instantiation sterm :: "term" begin
definition abs_pred_sterm :: "(sterm \<Rightarrow> bool) \<Rightarrow> sterm \<Rightarrow> bool" where
[code del]: "abs_pred P t \<longleftrightarrow> (\<forall>cs. t = Sabs cs \<longrightarrow> (\<forall>pat t. (pat, t) \<in> set cs \<longrightarrow> P t) \<longrightarrow> P t)"
lemma abs_pred_stermI[intro]:
assumes "\<And>cs. (\<And>pat t. (pat, t) \<in> set cs \<Longrightarrow> P t) \<Longrightarrow> P (Sabs cs)"
shows "abs_pred P t"
using assms unfolding abs_pred_sterm_def by auto
instance proof (standard, goal_cases)
case (1 P t)
then show ?case
by (induction t) (auto simp: const_sterm_def free_sterm_def app_sterm_def abs_pred_sterm_def)
next
case (2 t)
show ?case
apply rule
apply auto
apply (subst (3) list.map_id[symmetric])
apply (rule list.map_cong0)
apply auto
by blast
next
case (3 x t)
show ?case
apply rule
apply clarsimp
subgoal for cs env pat rhs
apply (cases "x |\<in>| frees pat")
subgoal
apply (rule arg_cong[where f = "subst rhs"])
by (auto intro: fmap_ext)
subgoal premises prems[rule_format]
apply (subst (2) prems(1)[symmetric, where pat = pat])
subgoal by fact
subgoal
using prems
unfolding ffUnion_alt_def
- by (auto simp add: fmember.rep_eq fset_of_list.rep_eq elim!: fBallE)
+ by (auto simp add: fmember_iff_member_fset fset_of_list.rep_eq elim!: fBallE)
subgoal
apply (rule arg_cong[where f = "subst rhs"])
by (auto intro: fmap_ext)
done
done
done
next
case (4 t)
show ?case
apply rule
apply clarsimp
subgoal premises prems[rule_format]
apply (rule prems(1)[OF prems(4)])
subgoal using prems by auto
subgoal using prems unfolding fdisjnt_alt_def by auto
done
done
next
case 5
show ?case
proof (intro abs_pred_stermI allI impI, goal_cases)
case (1 cs env)
show ?case
proof safe
fix name
assume "name |\<in>| frees (subst (Sabs cs) env)"
then obtain pat rhs
where "(pat, rhs) \<in> set cs"
and "name |\<in>| frees (subst rhs (fmdrop_fset (frees pat) env))"
and "name |\<notin>| frees pat"
by (auto simp: fset_of_list_elem case_prod_twice comp_def ffUnion_alt_def)
hence "name |\<in>| frees rhs |-| fmdom (fmdrop_fset (frees pat) env)"
using 1 by (simp add: fmpred_drop_fset)
hence "name |\<in>| frees rhs |-| frees pat"
using \<open>name |\<notin>| frees pat\<close> by blast
show "name |\<in>| frees (Sabs cs)"
apply (simp add: ffUnion_alt_def)
apply (rule fBexI[where x = "(pat, rhs)"])
unfolding prod.case
apply (fact \<open>name |\<in>| frees rhs |-| frees pat\<close>)
unfolding fset_of_list_elem
by fact
assume "name |\<in>| fmdom env"
thus False
using \<open>name |\<in>| frees rhs |-| fmdom (fmdrop_fset (frees pat) env)\<close> \<open>name |\<notin>| frees pat\<close>
by fastforce
next
fix name
assume "name |\<in>| frees (Sabs cs)" "name |\<notin>| fmdom env"
then obtain pat rhs
where "(pat, rhs) \<in> set cs" "name |\<in>| frees rhs" "name |\<notin>| frees pat"
by (auto simp: fset_of_list_elem ffUnion_alt_def)
moreover hence "name |\<in>| frees rhs |-| fmdom (fmdrop_fset (frees pat) env) |-| frees pat"
using \<open>name |\<notin>| fmdom env\<close> by fastforce
ultimately have "name |\<in>| frees (subst rhs (fmdrop_fset (frees pat) env)) |-| frees pat"
using 1 by (simp add: fmpred_drop_fset)
show "name |\<in>| frees (subst (Sabs cs) env)"
apply (simp add: case_prod_twice comp_def)
unfolding ffUnion_alt_def
apply (rule fBexI)
apply (fact \<open>name |\<in>| frees (subst rhs (fmdrop_fset (frees pat) env)) |-| frees pat\<close>)
apply (subst fimage_iff)
apply (rule fBexI[where x = "(pat, rhs)"])
apply simp
using \<open>(pat, rhs) \<in> set cs\<close>
by (auto simp: fset_of_list_elem)
qed
qed
next
case 6
show ?case
proof (intro abs_pred_stermI allI impI, goal_cases)
case (1 cs env)
\<comment> \<open>some property on various operations that is only useful in here\<close>
have *: "fbind (fmimage m (fbind A g)) f = fbind A (\<lambda>x. fbind (fmimage m (g x)) f)"
for m A f g
including fset.lifting fmap.lifting
by transfer' force
have "consts (subst (Sabs cs) env) = fbind (fset_of_list cs) (\<lambda>(pat, rhs). consts rhs |\<union>| ffUnion (consts |`| fmimage (fmdrop_fset (frees pat) env) (frees rhs)))"
apply (simp add: funion_image_bind_eq)
apply (rule fbind_cong[OF refl])
apply (clarsimp split: prod.splits)
apply (subst 1)
apply (subst (asm) fset_of_list_elem, assumption)
apply simp
by (simp add: funion_image_bind_eq)
also have "\<dots> = fbind (fset_of_list cs) (consts \<circ> snd) |\<union>| fbind (fset_of_list cs) (\<lambda>(pat, rhs). ffUnion (consts |`| fmimage (fmdrop_fset (frees pat) env) (frees rhs)))"
apply (subst fbind_fun_funion[symmetric])
apply (rule fbind_cong[OF refl])
by auto
also have "\<dots> = consts (Sabs cs) |\<union>| fbind (fset_of_list cs) (\<lambda>(pat, rhs). ffUnion (consts |`| fmimage (fmdrop_fset (frees pat) env) (frees rhs)))"
apply (rule cong[OF cong, OF refl _ refl, where f1 = "funion"])
apply (subst funion_image_bind_eq[symmetric])
unfolding consts_sterm.simps
apply (rule arg_cong[where f = ffUnion])
apply (subst fset_of_list_map)
apply (rule fset.map_cong[OF refl])
by auto
also have "\<dots> = consts (Sabs cs) |\<union>| fbind (fmimage env (fbind (fset_of_list cs) (\<lambda>(pat, rhs). frees rhs |-| frees pat))) consts"
apply (subst funion_image_bind_eq)
apply (subst fmimage_drop_fset)
apply (rule cong[OF cong, OF refl refl, where f1 = "funion"])
apply (subst *)
apply (rule fbind_cong[OF refl])
by auto
also have "\<dots> = consts (Sabs cs) |\<union>| ffUnion (consts |`| fmimage env (frees (Sabs cs)))"
by (simp only: frees_sterm.simps fset_of_list_map fmimage_Union funion_image_bind_eq)
finally show ?case .
qed
qed (auto simp: abs_pred_sterm_def)
end
lemma no_abs_abs[simp]: "\<not> no_abs (Sabs cs)"
by (subst no_abs.simps) (auto simp: term_cases_def)
lemma closed_except_simps:
"closed_except (Svar x) S \<longleftrightarrow> x |\<in>| S"
"closed_except (t\<^sub>1 $\<^sub>s t\<^sub>2) S \<longleftrightarrow> closed_except t\<^sub>1 S \<and> closed_except t\<^sub>2 S"
"closed_except (Sabs cs) S \<longleftrightarrow> list_all (\<lambda>(pat, t). closed_except t (S |\<union>| frees pat)) cs"
"closed_except (Sconst name) S \<longleftrightarrow> True"
proof goal_cases
case 3
show ?case
proof (standard, goal_cases)
case 1
then show ?case
apply (auto simp: list_all_iff ffUnion_alt_def fset_of_list_elem closed_except_def)
apply (drule ffUnion_least_rev)
apply auto
by (smt case_prod_conv fbspec fimageI fminusI fset_of_list_elem fset_rev_mp)
next
case 2
then show ?case
by (fastforce simp: list_all_iff ffUnion_alt_def fset_of_list_elem closed_except_def)
qed
qed (auto simp: ffUnion_alt_def closed_except_def)
lemma closed_except_sabs:
assumes "closed (Sabs cs)" "(pat, rhs) \<in> set cs"
shows "closed_except rhs (frees pat)"
using assms unfolding closed_except_def
apply auto
by (metis bot.extremum_uniqueI fempty_iff ffUnion_subset_elem fimageI fminusI fset_of_list_elem old.prod.case)
instantiation sterm :: strong_term begin
fun wellformed_sterm :: "sterm \<Rightarrow> bool" where
"wellformed_sterm (t\<^sub>1 $\<^sub>s t\<^sub>2) \<longleftrightarrow> wellformed_sterm t\<^sub>1 \<and> wellformed_sterm t\<^sub>2" |
"wellformed_sterm (Sabs cs) \<longleftrightarrow> list_all (\<lambda>(pat, t). linear pat \<and> wellformed_sterm t) cs \<and> distinct (map fst cs) \<and> cs \<noteq> []" |
"wellformed_sterm _ \<longleftrightarrow> True"
primrec all_frees_sterm :: "sterm \<Rightarrow> name fset" where
"all_frees_sterm (Svar x) = {|x|}" |
"all_frees_sterm (t\<^sub>1 $\<^sub>s t\<^sub>2) = all_frees_sterm t\<^sub>1 |\<union>| all_frees_sterm t\<^sub>2" |
"all_frees_sterm (Sabs cs) = ffUnion (fset_of_list (map (\<lambda>(P, T). P |\<union>| T) (map (map_prod frees all_frees_sterm) cs)))" |
"all_frees_sterm (Sconst _) = {||}"
instance proof (standard, goal_cases)
case (7 t)
show ?case
apply (intro abs_pred_stermI allI impI)
apply simp
apply (rule ffUnion_least)
apply (rule fBallI)
apply auto
apply (subst ffUnion_alt_def)
apply simp
apply (rule_tac x = "(a, b)" in fBexI)
by (auto simp: fset_of_list_elem)
next
case (8 t)
show ?case
apply (intro abs_pred_stermI allI impI)
apply (simp add: list.pred_map comp_def case_prod_twice, safe)
subgoal
apply (subst list_all_iff)
apply (rule ballI)
apply safe[1]
apply (fastforce simp: list_all_iff)
subgoal premises prems[rule_format]
apply (rule prems)
apply (fact prems)
using prems apply (fastforce simp: list_all_iff)
using prems by force
done
subgoal
apply (subst map_cong[OF refl])
by auto
done
qed (auto simp: const_sterm_def free_sterm_def app_sterm_def)
end
lemma match_sabs[simp]: "\<not> is_free t \<Longrightarrow> match t (Sabs cs) = None"
by (cases t) auto
context pre_constants begin
lemma welldefined_sabs: "welldefined (Sabs cs) \<longleftrightarrow> list_all (\<lambda>(_, t). welldefined t) cs"
apply (auto simp: list_all_iff ffUnion_alt_def dest!: ffUnion_least_rev)
apply (subst (asm) list_all_iff_fset[symmetric])
apply (auto simp: list_all_iff fset_of_list_elem)
done
lemma shadows_consts_sterm_simps[simp]:
"shadows_consts (t\<^sub>1 $\<^sub>s t\<^sub>2) \<longleftrightarrow> shadows_consts t\<^sub>1 \<or> shadows_consts t\<^sub>2"
"shadows_consts (Svar name) \<longleftrightarrow> name |\<in>| all_consts"
"shadows_consts (Sabs cs) \<longleftrightarrow> list_ex (\<lambda>(pat, t). \<not> fdisjnt all_consts (frees pat) \<or> shadows_consts t) cs"
"shadows_consts (Sconst name) \<longleftrightarrow> False"
proof (goal_cases)
case 3
show ?case
unfolding shadows_consts_def list_ex_iff
apply rule
subgoal
by (force simp: ffUnion_alt_def fset_of_list_elem fdisjnt_alt_def elim!: ballE)
subgoal
apply (auto simp: fset_of_list_elem fdisjnt_alt_def)
by (auto simp: fset_eq_empty_iff ffUnion_alt_def fset_of_list_elem elim!: allE fBallE)
done
qed (auto simp: shadows_consts_def fdisjnt_alt_def)
(* FIXME derive from axioms? *)
lemma subst_shadows:
assumes "\<not> shadows_consts (t::sterm)" "not_shadows_consts_env \<Gamma>"
shows "\<not> shadows_consts (subst t \<Gamma>)"
using assms proof (induction t arbitrary: \<Gamma> rule: sterm_induct)
case (Sabs cs)
show ?case
apply (simp add: list_ex_iff case_prod_twice)
apply (rule ballI)
subgoal for c
apply (cases c, hypsubst_thin, simp)
apply (rule conjI)
subgoal using Sabs(2) by (fastforce simp: list_ex_iff)
apply (rule Sabs(1))
apply assumption
subgoal using Sabs(2) by (fastforce simp: list_ex_iff)
subgoal using Sabs(3) by force
done
done
qed (auto split: option.splits)
end
end
\ No newline at end of file
diff --git a/thys/Coinductive_Languages/Context_Free_Grammar.thy b/thys/Coinductive_Languages/Context_Free_Grammar.thy
--- a/thys/Coinductive_Languages/Context_Free_Grammar.thy
+++ b/thys/Coinductive_Languages/Context_Free_Grammar.thy
@@ -1,177 +1,177 @@
section \<open>Word Problem for Context-Free Grammars\<close>
(*<*)
theory Context_Free_Grammar
imports Coinductive_Language "HOL-Library.FSet"
begin
(*>*)
section \<open>Context Free Languages\<close>
text \<open>
A context-free grammar consists of a list of productions for every nonterminal
and an initial nonterminal. The productions are required to be in weak Greibach
normal form, i.e. each right hand side of a production must either be empty or
start with a terminal.
\<close>
abbreviation "wgreibach \<alpha> \<equiv> (case \<alpha> of (Inr N # _) \<Rightarrow> False | _ \<Rightarrow> True)"
record ('t, 'n) cfg =
init :: "'n :: finite"
prod :: "'n \<Rightarrow> ('t + 'n) list fset"
context
fixes G :: "('t, 'n :: finite) cfg"
begin
inductive in_cfl where
"in_cfl [] []"
| "in_cfl \<alpha> w \<Longrightarrow> in_cfl (Inl a # \<alpha>) (a # w)"
| "fBex (prod G N) (\<lambda>\<beta>. in_cfl (\<beta> @ \<alpha>) w) \<Longrightarrow> in_cfl (Inr N # \<alpha>) w"
abbreviation lang_trad where
"lang_trad \<equiv> {w. in_cfl [Inr (init G)] w}"
fun \<oo>\<^sub>P where
"\<oo>\<^sub>P [] = True"
| "\<oo>\<^sub>P (Inl _ # _) = False"
| "\<oo>\<^sub>P (Inr N # \<alpha>) = ([] |\<in>| prod G N \<and> \<oo>\<^sub>P \<alpha>)"
fun \<dd>\<^sub>P where
"\<dd>\<^sub>P [] a = {||}"
| "\<dd>\<^sub>P (Inl b # \<alpha>) a = (if a = b then {|\<alpha>|} else {||})"
| "\<dd>\<^sub>P (Inr N # \<alpha>) a =
(\<lambda>\<beta>. tl \<beta> @ \<alpha>) |`| ffilter (\<lambda>\<beta>. \<beta> \<noteq> [] \<and> hd \<beta> = Inl a) (prod G N) |\<union>|
(if [] |\<in>| prod G N then \<dd>\<^sub>P \<alpha> a else {||})"
primcorec subst :: "('t + 'n) list fset \<Rightarrow> 't language" where
"subst P = Lang (fBex P \<oo>\<^sub>P) (\<lambda>a. subst (ffUnion ((\<lambda>r. \<dd>\<^sub>P r a) |`| P)))"
inductive in_cfls where
"fBex P \<oo>\<^sub>P \<Longrightarrow> in_cfls P []"
| "in_cfls (ffUnion ((\<lambda>\<alpha>. \<dd>\<^sub>P \<alpha> a) |`| P)) w \<Longrightarrow> in_cfls P (a # w)"
inductive_cases [elim!]: "in_cfls P []"
inductive_cases [elim!]: "in_cfls P (a # w)"
declare inj_eq[OF bij_is_inj[OF to_language_bij], simp]
lemma subst_in_cfls: "subst P = to_language {w. in_cfls P w}"
by (coinduction arbitrary: P) (auto intro: in_cfls.intros)
lemma \<oo>\<^sub>P_in_cfl: "\<oo>\<^sub>P \<alpha> \<Longrightarrow> in_cfl \<alpha> []"
by (induct \<alpha> rule: \<oo>\<^sub>P.induct) (auto intro!: in_cfl.intros elim: fBexI[rotated])
lemma \<dd>\<^sub>P_in_cfl: "\<beta> |\<in>| \<dd>\<^sub>P \<alpha> a \<Longrightarrow> in_cfl \<beta> w \<Longrightarrow> in_cfl \<alpha> (a # w)"
proof (induct \<alpha> a arbitrary: \<beta> w rule: \<dd>\<^sub>P.induct)
case (3 N \<alpha> a)
then show ?case
by (auto simp: rev_fBexI neq_Nil_conv split: if_splits
intro!: in_cfl.intros elim!: rev_fBexI[of "_ # _"])
qed (auto split: if_splits intro: in_cfl.intros)
lemma in_cfls_in_cfl: "in_cfls P w \<Longrightarrow> fBex P (\<lambda>\<alpha>. in_cfl \<alpha> w)"
by (induct P w rule: in_cfls.induct)
- (auto simp: \<oo>\<^sub>P_in_cfl \<dd>\<^sub>P_in_cfl ffUnion.rep_eq fmember.rep_eq fBex.rep_eq fBall.rep_eq
+ (auto simp: \<oo>\<^sub>P_in_cfl \<dd>\<^sub>P_in_cfl ffUnion.rep_eq fmember_iff_member_fset fBex.rep_eq fBall.rep_eq
intro: in_cfl.intros elim: rev_bexI)
lemma in_cfls_mono: "in_cfls P w \<Longrightarrow> P |\<subseteq>| Q \<Longrightarrow> in_cfls Q w"
proof (induct P w arbitrary: Q rule: in_cfls.induct)
case (2 a P w)
from 2(3) 2(2)[of "ffUnion ((\<lambda>\<alpha>. local.\<dd>\<^sub>P \<alpha> a) |`| Q)"] show ?case
by (auto intro!: ffunion_mono in_cfls.intros)
qed (auto intro!: in_cfls.intros)
end
locale cfg_wgreibach =
fixes G :: "('t, 'n :: finite) cfg"
assumes weakGreibach: "\<And>N \<alpha>. \<alpha> |\<in>| prod G N \<Longrightarrow> wgreibach \<alpha>"
begin
lemma in_cfl_in_cfls: "in_cfl G \<alpha> w \<Longrightarrow> in_cfls G {|\<alpha>|} w"
proof (induct \<alpha> w rule: in_cfl.induct)
case (3 N \<alpha> w)
then obtain \<beta> where
\<beta>: "\<beta> |\<in>| prod G N" and
in_cfl: "in_cfl G (\<beta> @ \<alpha>) w" and
in_cfls: "in_cfls G {|\<beta> @ \<alpha>|} w" by blast
then show ?case
proof (cases \<beta>)
case [simp]: Nil
from \<beta> in_cfls show ?thesis
by (cases w) (auto intro!: in_cfls.intros elim: in_cfls_mono)
next
case [simp]: (Cons x \<gamma>)
from weakGreibach[OF \<beta>] obtain a where [simp]: "x = Inl a" by (cases x) auto
with \<beta> in_cfls show ?thesis
apply -
apply (rule in_cfl.cases[OF in_cfl]; auto)
apply (force intro: in_cfls.intros(2) elim!: in_cfls_mono)
done
qed
qed (auto intro!: in_cfls.intros)
abbreviation lang where
"lang \<equiv> subst G {|[Inr (init G)]|}"
lemma lang_lang_trad: "lang = to_language (lang_trad G)"
proof -
have "in_cfls G {|[Inr (init G)]|} w \<longleftrightarrow> in_cfl G [Inr (init G)] w" for w
by (auto dest: in_cfls_in_cfl in_cfl_in_cfls)
then show ?thesis
by (auto simp: subst_in_cfls)
qed
end
text \<open>
The function @{term in_language} decides the word problem for a given language.
Since we can construct the language of a CFG using @{const cfg_wgreibach.lang} we obtain an
executable (but not very efficient) decision procedure for CFGs for free.
\<close>
abbreviation "\<aa> \<equiv> Inl True"
abbreviation "\<bb> \<equiv> Inl False"
abbreviation "S \<equiv> Inr ()"
interpretation palindromes: cfg_wgreibach "\<lparr>init = (), prod = \<lambda>_. {|[], [\<aa>], [\<bb>], [\<aa>, S, \<aa>], [\<bb>, S, \<bb>]|}\<rparr>"
by unfold_locales auto
lemma "in_language palindromes.lang []" by normalization
lemma "in_language palindromes.lang [True]" by normalization
lemma "in_language palindromes.lang [False]" by normalization
lemma "in_language palindromes.lang [True, True]" by normalization
lemma "in_language palindromes.lang [True, False, True]" by normalization
lemma "\<not> in_language palindromes.lang [True, False]" by normalization
lemma "\<not> in_language palindromes.lang [True, False, True, False]" by normalization
lemma "in_language palindromes.lang [True, False, True, True, False, True]" by normalization
lemma "\<not> in_language palindromes.lang [True, False, True, False, False, True]" by normalization
interpretation Dyck: cfg_wgreibach "\<lparr>init = (), prod = \<lambda>_. {|[], [\<aa>, S, \<bb>, S]|}\<rparr>"
by unfold_locales auto
lemma "in_language Dyck.lang []" by normalization
lemma "\<not> in_language Dyck.lang [True]" by normalization
lemma "\<not> in_language Dyck.lang [False]" by normalization
lemma "in_language Dyck.lang [True, False, True, False]" by normalization
lemma "in_language Dyck.lang [True, True, False, False]" by normalization
lemma "in_language Dyck.lang [True, False, True, False]" by normalization
lemma "in_language Dyck.lang [True, False, True, False, True, True, False, False]" by normalization
lemma "\<not> in_language Dyck.lang [True, False, True, True, False]" by normalization
lemma "\<not> in_language Dyck.lang [True, True, False, False, False, True]" by normalization
interpretation abSSa: cfg_wgreibach "\<lparr>init = (), prod = \<lambda>_. {|[], [\<aa>, \<bb>, S, S, \<aa>]|}\<rparr>"
by unfold_locales auto
lemma "in_language abSSa.lang []" by normalization
lemma "\<not> in_language abSSa.lang [True]" by normalization
lemma "\<not> in_language abSSa.lang [False]" by normalization
lemma "in_language abSSa.lang [True, False, True]" by normalization
lemma "in_language abSSa.lang [True, False, True, False, True, True, False, True, True]" by normalization
lemma "in_language abSSa.lang [True, False, True, False, True, True]" by normalization
lemma "\<not> in_language abSSa.lang [True, False, True, True, False]" by normalization
lemma "\<not> in_language abSSa.lang [True, True, False, False, False, True]" by normalization
(*<*)
end
(*>*)
\ No newline at end of file
diff --git a/thys/Core_DOM/common/classes/CharacterDataClass.thy b/thys/Core_DOM/common/classes/CharacterDataClass.thy
--- a/thys/Core_DOM/common/classes/CharacterDataClass.thy
+++ b/thys/Core_DOM/common/classes/CharacterDataClass.thy
@@ -1,355 +1,355 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>CharacterData\<close>
text\<open>In this theory, we introduce the types for the CharacterData class.\<close>
theory CharacterDataClass
imports
ElementClass
begin
subsubsection\<open>CharacterData\<close>
text\<open>The type @{type "DOMString"} is a type synonym for @{type "string"}, defined
\autoref{sec:Core_DOM_Basic_Datatypes}.\<close>
record RCharacterData = RNode +
nothing :: unit
val :: DOMString
register_default_tvars "'CharacterData RCharacterData_ext"
type_synonym 'CharacterData CharacterData = "'CharacterData option RCharacterData_scheme"
register_default_tvars "'CharacterData CharacterData"
type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node,
'Element, 'CharacterData) Node
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
'CharacterData option RCharacterData_ext + 'Node, 'Element) Node"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node,
'Element, 'CharacterData) Node"
type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node,
'Element, 'CharacterData) Object
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object,
'CharacterData option RCharacterData_ext + 'Node,
'Element) Object"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object,
'Node, 'Element, 'CharacterData) Object"
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap
= "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, 'shadow_root_ptr,
'Object, 'CharacterData option RCharacterData_ext + 'Node, 'Element) heap"
register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap"
definition character_data_ptr_kinds :: "(_) heap \<Rightarrow> (_) character_data_ptr fset"
where
"character_data_ptr_kinds heap = the |`| (cast |`| (ffilter is_character_data_ptr_kind
(node_ptr_kinds heap)))"
lemma character_data_ptr_kinds_simp [simp]:
"character_data_ptr_kinds (Heap (fmupd (cast character_data_ptr) character_data (the_heap h)))
= {|character_data_ptr|} |\<union>| character_data_ptr_kinds h"
apply(auto simp add: character_data_ptr_kinds_def)[1]
by force
definition character_data_ptrs :: "(_) heap \<Rightarrow> _ character_data_ptr fset"
where
"character_data_ptrs heap = ffilter is_character_data_ptr (character_data_ptr_kinds heap)"
abbreviation "character_data_ptr_exts heap \<equiv> character_data_ptr_kinds heap - character_data_ptrs heap"
definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Node \<Rightarrow> (_) CharacterData option"
where
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = (case RNode.more node of
Inr (Inl character_data) \<Rightarrow> Some (RNode.extend (RNode.truncate node) character_data)
| _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
abbreviation cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Object \<Rightarrow> (_) CharacterData option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a obj \<equiv> (case cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj of Some node \<Rightarrow> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node
| None \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
definition cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) CharacterData \<Rightarrow> (_) Node"
where
"cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = RNode.extend (RNode.truncate character_data)
(Inr (Inl (RNode.more character_data)))"
adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e
abbreviation cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) CharacterData \<Rightarrow> (_) Object"
where
"cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \<equiv> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr)"
adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
consts is_character_data_kind :: 'a
definition is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Node \<Rightarrow> bool"
where
"is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \<longleftrightarrow> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \<noteq> None"
adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e
lemmas is_character_data_kind_def = is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
abbreviation is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) Object \<Rightarrow> bool"
where
"is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \<equiv> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \<noteq> None"
adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
lemma character_data_ptr_kinds_commutes [simp]:
"cast character_data_ptr |\<in>| node_ptr_kinds h
\<longleftrightarrow> character_data_ptr |\<in>| character_data_ptr_kinds h"
apply(auto simp add: character_data_ptr_kinds_def)[1]
by (metis character_data_ptr_casts_commute2 comp_eq_dest_lhs ffmember_filter fimage_eqI
is_character_data_ptr_kind_none
option.distinct(1) option.sel)
definition get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) CharacterData option"
where
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h = Option.bind (get\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr) h) cast"
adhoc_overloading get get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
locale l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (ElementClass.type_wf h
\<and> (\<forall>character_data_ptr \<in> fset (character_data_ptr_kinds h).
get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: "type_wf h \<Longrightarrow> CharacterDataClass.type_wf h"
sublocale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a \<subseteq> l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
apply(unfold_locales)
using ElementClass.a_type_wf_def
by (meson CharacterDataClass.a_type_wf_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
locale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas = l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
sublocale l_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas by unfold_locales
lemma get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf:
assumes "type_wf h"
shows "character_data_ptr |\<in>| character_data_ptr_kinds h
\<longleftrightarrow> get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \<noteq> None"
using l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms assms
apply(simp add: type_wf_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
- by (metis assms bind.bind_lzero character_data_ptr_kinds_commutes fmember.rep_eq
+ by (metis assms bind.bind_lzero character_data_ptr_kinds_commutes fmember_iff_member_fset
local.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf option.exhaust option.simps(3))
end
global_interpretation l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas type_wf
by unfold_locales
definition put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \<Rightarrow> (_) CharacterData \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data = put\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr)
(cast character_data)"
adhoc_overloading put put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap:
assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'"
shows "character_data_ptr |\<in>| character_data_ptr_kinds h'"
using assms put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap
unfolding put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def character_data_ptr_kinds_def
by (metis character_data_ptr_kinds_commutes character_data_ptr_kinds_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap)
lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs:
assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast character_data_ptr|}"
using assms
by (simp add: put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs)
lemma cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inject [simp]: "cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e x = cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def)
by (metis (full_types) RNode.surjective old.unit.exhaust)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_none [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = None \<longleftrightarrow> \<not> (\<exists>character_data. cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node)"
apply(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def
split: sum.splits)[1]
by (metis (full_types) RNode.select_convs(2) RNode.surjective old.unit.exhaust)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_some [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = Some character_data \<longleftrightarrow> cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node"
by(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def
split: sum.splits)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_inv [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data) = Some character_data"
by simp
lemma cast_element_not_character_data [simp]:
"(cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element \<noteq> cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data)"
"(cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data \<noteq> cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element)"
by(auto simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RNode.extend_def)
lemma get_CharacterData_simp1 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h)
= Some character_data"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp2 [simp]:
"character_data_ptr \<noteq> character_data_ptr' \<Longrightarrow> get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr
(put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr' character_data h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp3 [simp]:
"get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h"
by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp4 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t character_data_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
abbreviation "create_character_data_obj val_arg
\<equiv> \<lparr> RObject.nothing = (), RNode.nothing = (), RCharacterData.nothing = (), val = val_arg, \<dots> = None \<rparr>"
definition new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) heap \<Rightarrow> ((_) character_data_ptr \<times> (_) heap)"
where
"new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h =
(let new_character_data_ptr = character_data_ptr.Ref (Suc (fMax (character_data_ptr.the_ref
|`| (character_data_ptrs h)))) in
(new_character_data_ptr, put new_character_data_ptr (create_character_data_obj '''') h))"
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "new_character_data_ptr |\<in>| character_data_ptr_kinds h'"
using assms
unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def
using put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap by blast
lemma new_character_data_ptr_new:
"character_data_ptr.Ref (Suc (fMax (finsert 0 (character_data_ptr.the_ref |`| character_data_ptrs h))))
|\<notin>| character_data_ptrs h"
by (metis Suc_n_not_le_n character_data_ptr.sel(1) fMax_ge fimage_finsert finsertI1
finsertI2 set_finsert)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "new_character_data_ptr |\<notin>| character_data_ptr_kinds h"
using assms
unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def
by (metis Pair_inject character_data_ptrs_def fMax_finsert fempty_iff ffmember_filter
fimage_is_fempty is_character_data_ptr_ref max_0L new_character_data_ptr_new)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_new_ptr:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using assms
by (metis Pair_inject new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_is_character_data_ptr:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "is_character_data_ptr new_character_data_ptr"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> cast new_character_data_ptr"
shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> cast new_character_data_ptr"
shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> new_character_data_ptr"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
locale l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = (known_ptr ptr \<or> is_character_data_ptr ptr)"
lemma known_ptr_not_character_data_ptr:
"\<not>is_character_data_ptr ptr \<Longrightarrow> a_known_ptr ptr \<Longrightarrow> known_ptr ptr"
by(simp add: a_known_ptr_def)
end
global_interpretation l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved known_ptrs_subset known_ptrs_new_ptr l_known_ptrs_def
by blast
end
diff --git a/thys/Core_DOM/common/classes/DocumentClass.thy b/thys/Core_DOM/common/classes/DocumentClass.thy
--- a/thys/Core_DOM/common/classes/DocumentClass.thy
+++ b/thys/Core_DOM/common/classes/DocumentClass.thy
@@ -1,345 +1,345 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Document\<close>
text\<open>In this theory, we introduce the types for the Document class.\<close>
theory DocumentClass
imports
CharacterDataClass
begin
text\<open>The type @{type "doctype"} is a type synonym for @{type "string"}, defined
in \autoref{sec:Core_DOM_Basic_Datatypes}.\<close>
record ('node_ptr, 'element_ptr, 'character_data_ptr) RDocument = RObject +
nothing :: unit
doctype :: doctype
document_element :: "(_) element_ptr option"
disconnected_nodes :: "('node_ptr, 'element_ptr, 'character_data_ptr) node_ptr list"
type_synonym
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_scheme"
register_default_tvars
"('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document"
type_synonym
('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node,
'Element, 'CharacterData, 'Document) Object
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option)
RDocument_ext + 'Object, 'Node, 'Element, 'CharacterData) Object"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
'Object, 'Node, 'Element, 'CharacterData, 'Document) Object"
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap
= "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr,
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_ext + 'Object, 'Node,
'Element, 'CharacterData) heap"
register_default_tvars
"('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap"
definition document_ptr_kinds :: "(_) heap \<Rightarrow> (_) document_ptr fset"
where
"document_ptr_kinds heap = the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`|
(ffilter is_document_ptr_kind (object_ptr_kinds heap)))"
definition document_ptrs :: "(_) heap \<Rightarrow> (_) document_ptr fset"
where
"document_ptrs heap = ffilter is_document_ptr (document_ptr_kinds heap)"
definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) Object \<Rightarrow> (_) Document option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = (case RObject.more obj of
Inr (Inl document) \<Rightarrow> Some (RObject.extend (RObject.truncate obj) document)
| _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
definition cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Document \<Rightarrow> (_) Object"
where
"cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = (RObject.extend (RObject.truncate document)
(Inr (Inl (RObject.more document))))"
adhoc_overloading cast cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
definition is_document_kind :: "(_) Object \<Rightarrow> bool"
where
"is_document_kind ptr \<longleftrightarrow> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr \<noteq> None"
lemma document_ptr_kinds_simp [simp]:
"document_ptr_kinds (Heap (fmupd (cast document_ptr) document (the_heap h)))
= {|document_ptr|} |\<union>| document_ptr_kinds h"
apply(auto simp add: document_ptr_kinds_def)[1]
by force
lemma document_ptr_kinds_commutes [simp]:
"cast document_ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> document_ptr |\<in>| document_ptr_kinds h"
apply(auto simp add: object_ptr_kinds_def document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_casts_commute2 document_ptr_document_ptr_cast
ffmember_filter fimage_eqI fset.map_comp option.sel)
definition get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) Document option"
where
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h = Option.bind (get (cast document_ptr) h) cast"
adhoc_overloading get get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (CharacterDataClass.type_wf h \<and>
(\<forall>document_ptr \<in> fset (document_ptr_kinds h). get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: "type_wf h \<Longrightarrow> DocumentClass.type_wf h"
sublocale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t \<subseteq> l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
apply(unfold_locales)
by (metis (full_types) type_wf_defs l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
locale l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
lemma get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf:
assumes "type_wf h"
shows "document_ptr |\<in>| document_ptr_kinds h \<longleftrightarrow> get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \<noteq> None"
using l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms assms
apply(simp add: type_wf_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
- by (metis document_ptr_kinds_commutes fmember.rep_eq is_none_bind is_none_simps(1)
+ by (metis document_ptr_kinds_commutes fmember_iff_member_fset is_none_bind is_none_simps(1)
is_none_simps(2) local.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
end
global_interpretation l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
definition put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \<Rightarrow> (_) Document \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document = put (cast document_ptr) (cast document)"
adhoc_overloading put put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap:
assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'"
shows "document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
by (metis document_ptr_kinds_commutes put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap)
lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs:
assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast document_ptr|}"
using assms
by (simp add: put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs)
lemma cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
by (metis (full_types) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = None \<longleftrightarrow> \<not> (\<exists>document. cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = obj)"
apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def
split: sum.splits)[1]
by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_some [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = Some document \<longleftrightarrow> cast document = obj"
by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def
split: sum.splits)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t (cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document) = Some document"
by simp
lemma cast_document_not_node [simp]:
"cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document \<noteq> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node"
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node \<noteq> cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document"
by(auto simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
lemma get_document_ptr_simp1 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h) = Some document"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp2 [simp]:
"document_ptr \<noteq> document_ptr'
\<Longrightarrow> get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' document h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp3 [simp]:
"get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h"
by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp4 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma get_document_ptr_simp5 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp6 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
abbreviation
create_document_obj :: "char list \<Rightarrow> (_) element_ptr option \<Rightarrow> (_) node_ptr list \<Rightarrow> (_) Document"
where
"create_document_obj doctype_arg document_element_arg disconnected_nodes_arg
\<equiv> \<lparr> RObject.nothing = (), RDocument.nothing = (), doctype = doctype_arg,
document_element = document_element_arg,
disconnected_nodes = disconnected_nodes_arg, \<dots> = None \<rparr>"
definition new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_)heap \<Rightarrow> ((_) document_ptr \<times> (_) heap)"
where
"new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h =
(let new_document_ptr = document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| (document_ptrs h)))))
in
(new_document_ptr, put new_document_ptr (create_document_obj '''' None []) h))"
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "new_document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
using put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap by blast
lemma new_document_ptr_new:
"document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| document_ptrs h))))
|\<notin>| document_ptrs h"
by (metis Suc_n_not_le_n document_ptr.sel(1) fMax_ge fimage_finsert finsertI1 finsertI2 set_finsert)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "new_document_ptr |\<notin>| document_ptr_kinds h"
using assms
unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
by (metis Pair_inject document_ptrs_def fMax_finsert fempty_iff ffmember_filter
fimage_is_fempty is_document_ptr_ref max_0L new_document_ptr_new)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using assms
by (metis Pair_inject new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "is_document_ptr new_document_ptr"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
assumes "ptr \<noteq> cast new_document_ptr"
shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'"
using assms
apply(simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
assumes "ptr \<noteq> new_document_ptr"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
locale l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = (known_ptr ptr \<or> is_document_ptr ptr)"
lemma known_ptr_not_document_ptr: "\<not>is_document_ptr ptr \<Longrightarrow> a_known_ptr ptr \<Longrightarrow> known_ptr ptr"
by(simp add: a_known_ptr_def)
end
global_interpretation l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs [instances]: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset known_ptrs_new_ptr
by blast
end
diff --git a/thys/Core_DOM/common/classes/NodeClass.thy b/thys/Core_DOM/common/classes/NodeClass.thy
--- a/thys/Core_DOM/common/classes/NodeClass.thy
+++ b/thys/Core_DOM/common/classes/NodeClass.thy
@@ -1,209 +1,209 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Node\<close>
text\<open>In this theory, we introduce the types for the Node class.\<close>
theory NodeClass
imports
ObjectClass
"../pointers/NodePointer"
begin
subsubsection\<open>Node\<close>
record RNode = RObject
+ nothing :: unit
register_default_tvars "'Node RNode_ext"
type_synonym 'Node Node = "'Node RNode_scheme"
register_default_tvars "'Node Node"
type_synonym ('Object, 'Node) Object = "('Node RNode_ext + 'Object) Object"
register_default_tvars "('Object, 'Node) Object"
type_synonym ('object_ptr, 'node_ptr, 'Object, 'Node) heap
= "('node_ptr node_ptr + 'object_ptr, 'Node RNode_ext + 'Object) heap"
register_default_tvars
"('object_ptr, 'node_ptr, 'Object, 'Node) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit) heap"
definition node_ptr_kinds :: "(_) heap \<Rightarrow> (_) node_ptr fset"
where
"node_ptr_kinds heap =
(the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`| (ffilter is_node_ptr_kind (object_ptr_kinds heap))))"
lemma node_ptr_kinds_simp [simp]:
"node_ptr_kinds (Heap (fmupd (cast node_ptr) node (the_heap h)))
= {|node_ptr|} |\<union>| node_ptr_kinds h"
apply(auto simp add: node_ptr_kinds_def)[1]
by force
definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Object \<Rightarrow> (_) Node option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = (case RObject.more obj of Inl node
\<Rightarrow> Some (RObject.extend (RObject.truncate obj) node) | _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e
definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Node \<Rightarrow> (_) Object"
where
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = (RObject.extend (RObject.truncate node) (Inl (RObject.more node)))"
adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
definition is_node_kind :: "(_) Object \<Rightarrow> bool"
where
"is_node_kind ptr \<longleftrightarrow> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \<noteq> None"
definition get\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) Node option"
where
"get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h = Option.bind (get (cast node_ptr) h) cast"
adhoc_overloading get get\<^sub>N\<^sub>o\<^sub>d\<^sub>e
locale l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (ObjectClass.type_wf h
\<and> (\<forall>node_ptr \<in> fset( node_ptr_kinds h). get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e: "type_wf h \<Longrightarrow> NodeClass.type_wf h"
sublocale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e \<subseteq> l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
apply(unfold_locales)
using ObjectClass.a_type_wf_def by auto
locale l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas = l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
sublocale l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas by unfold_locales
lemma get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf:
assumes "type_wf h"
shows "node_ptr |\<in>| node_ptr_kinds h \<longleftrightarrow> get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \<noteq> None"
using l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_axioms assms
apply(simp add: type_wf_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
- by (metis bind_eq_None_conv ffmember_filter fimage_eqI fmember.rep_eq is_node_ptr_kind_cast
+ by (metis bind_eq_None_conv ffmember_filter fimage_eqI fmember_iff_member_fset is_node_ptr_kind_cast
get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf node_ptr_casts_commute2 node_ptr_kinds_def option.sel option.simps(3))
end
global_interpretation l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas type_wf
by unfold_locales
definition put\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \<Rightarrow> (_) Node \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node = put (cast node_ptr) (cast node)"
adhoc_overloading put put\<^sub>N\<^sub>o\<^sub>d\<^sub>e
lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap:
assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'"
shows "node_ptr |\<in>| node_ptr_kinds h'"
using assms
unfolding put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def node_ptr_kinds_def
by (metis ffmember_filter fimage_eqI is_node_ptr_kind_cast node_ptr_casts_commute2
option.sel put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap)
lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs:
assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast node_ptr|}"
using assms
by (simp add: put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs)
lemma node_ptr_kinds_commutes [simp]:
"cast node_ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> node_ptr |\<in>| node_ptr_kinds h"
apply(auto simp add: node_ptr_kinds_def split: option.splits)[1]
by (metis (no_types, lifting) ffmember_filter fimage_eqI fset.map_comp
is_node_ptr_kind_none node_ptr_casts_commute2
option.distinct(1) option.sel)
lemma node_empty [simp]:
"\<lparr>RObject.nothing = (), RNode.nothing = (), \<dots> = RNode.more node\<rparr> = node"
by simp
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
by (metis (full_types) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_none [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = None \<longleftrightarrow> \<not> (\<exists>node. cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = obj)"
apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits)[1]
by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_some [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = Some node \<longleftrightarrow> cast node = obj"
by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node) = Some node"
by simp
locale l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = False"
end
global_interpretation l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset
known_ptrs_new_ptr
by blast
lemma get_node_ptr_simp1 [simp]: "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h) = Some node"
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma get_node_ptr_simp2 [simp]:
"node_ptr \<noteq> node_ptr' \<Longrightarrow> get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr' node h) = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h"
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
end
diff --git a/thys/Core_DOM/common/monads/DocumentMonad.thy b/thys/Core_DOM/common/monads/DocumentMonad.thy
--- a/thys/Core_DOM/common/monads/DocumentMonad.thy
+++ b/thys/Core_DOM/common/monads/DocumentMonad.thy
@@ -1,614 +1,614 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Document\<close>
text\<open>In this theory, we introduce the monadic method setup for the Document class.\<close>
theory DocumentMonad
imports
CharacterDataMonad
"../classes/DocumentClass"
begin
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog
= "((_) heap, exception, 'result) prog"
register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog"
global_interpretation l_ptr_kinds_M document_ptr_kinds defines document_ptr_kinds_M = a_ptr_kinds_M .
lemmas document_ptr_kinds_M_defs = a_ptr_kinds_M_def
lemma document_ptr_kinds_M_eq:
assumes "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
shows "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using assms
by(auto simp add: document_ptr_kinds_M_defs object_ptr_kinds_M_defs document_ptr_kinds_def)
lemma document_ptr_kinds_M_reads:
"reads (\<Union>object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) document_ptr_kinds_M h h'"
using object_ptr_kinds_M_reads
apply (simp add: reads_def object_ptr_kinds_M_defs document_ptr_kinds_M_defs
document_ptr_kinds_def preserved_def cong del: image_cong_simp)
apply (metis (mono_tags, opaque_lifting) object_ptr_kinds_preserved_small old.unit.exhaust preserved_def)
done
global_interpretation l_dummy defines get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = "l_get_M.a_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" .
lemma get_M_is_l_get_M: "l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds"
apply(simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf l_get_M_def)
by (metis ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf ObjectClass.type_wf_defs bind_eq_None_conv
document_ptr_kinds_commutes get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def option.simps(3))
lemmas get_M_defs = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]]
adhoc_overloading get_M get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds
apply(unfold_locales)
apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def)
lemmas get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = get_M_ok[folded get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def]
end
global_interpretation l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
global_interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
rewrites "a_get_M = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" defines put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = a_put_M
apply (simp add: get_M_is_l_get_M l_put_M_def)
by (simp add: get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemmas put_M_defs = a_put_M_def
adhoc_overloading put_M put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
apply(unfold_locales)
apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def)
lemmas put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = put_M_ok[folded put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def]
end
global_interpretation l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
lemma document_put_get [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = v)
\<Longrightarrow> h' \<turnstile> get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter \<rightarrow>\<^sub>r v"
by(auto simp add: put_M_defs get_M_defs split: option.splits)
lemma get_M_Mdocument_preserved1 [simp]:
"document_ptr \<noteq> document_ptr'
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'"
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma document_put_get_preserved [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = getter x)
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'"
apply(cases "document_ptr = document_ptr'")
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved2 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved3 [simp]:
"cast document_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved4 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast document_ptr \<noteq> object_ptr")[1]
by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
ObjectMonad.get_M_defs preserved_def
split: option.splits bind_splits dest: get_heap_E)
lemma get_M_Mdocument_preserved5 [simp]:
"cast document_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved6 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'"
by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved7 [simp]:
"h \<turnstile> put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved8 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'"
by(auto simp add: put_M_defs CharacterDataMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved9 [simp]:
"h \<turnstile> put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: CharacterDataMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved10 [simp]:
"(\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast document_ptr = object_ptr")
by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv
split: option.splits)
lemma new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_element_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_character_data_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_character_data_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
subsection \<open>Creating Documents\<close>
definition new_document :: "(_, (_) document_ptr) dom_prog"
where
"new_document = do {
h \<leftarrow> get_heap;
(new_ptr, h') \<leftarrow> return (new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h);
return_heap h';
return new_ptr
}"
lemma new_document_ok [simp]:
"h \<turnstile> ok new_document"
by(auto simp add: new_document_def split: prod.splits)
lemma new_document_ptr_in_heap:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "new_document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding new_document_def
by(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap is_OK_returns_result_I
elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_ptr_not_in_heap:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "new_document_ptr |\<notin>| document_ptr_kinds h"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap
by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_new_ptr:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr
by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_is_document_ptr:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "is_document_ptr new_document_ptr"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr
by(auto simp add: new_document_def elim!: bind_returns_result_E split: prod.splits)
lemma new_document_doctype:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr doctype \<rightarrow>\<^sub>r ''''"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_document_element:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr document_element \<rightarrow>\<^sub>r None"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_disconnected_nodes:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr disconnected_nodes \<rightarrow>\<^sub>r []"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> ptr \<noteq> cast new_document_ptr \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def ObjectMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'"
by(auto simp add: new_document_def NodeMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def ElementMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'"
by(auto simp add: new_document_def CharacterDataMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> ptr \<noteq> new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
subsection \<open>Modified Heaps\<close>
lemma get_document_ptr_simp [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)
= (if ptr = cast document_ptr then cast obj else get document_ptr h)"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def split: option.splits Option.bind_splits)
lemma document_ptr_kidns_simp [simp]:
"document_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)
= document_ptr_kinds h |\<union>| (if is_document_ptr_kind ptr then {|the (cast ptr)|} else {||})"
by(auto simp add: document_ptr_kinds_def split: option.splits)
lemma type_wf_put_I:
assumes "type_wf h"
assumes "CharacterDataClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "is_document_ptr_kind ptr \<Longrightarrow> is_document_kind obj"
shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
using assms
by(auto simp add: type_wf_defs is_document_kind_def split: option.splits)
lemma type_wf_put_ptr_not_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<notin>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_not_in_heap_E
split: option.splits if_splits)
lemma type_wf_put_ptr_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "CharacterDataClass.type_wf h"
assumes "is_document_ptr_kind ptr \<Longrightarrow> is_document_kind (the (get ptr h))"
shows "type_wf h"
using assms
apply(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_in_heap_E
split: option.splits if_splits)[1]
by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf bind.bind_lunit get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
is_document_kind_def notin_fset option.exhaust_sel)
subsection \<open>Preserving Types\<close>
lemma new_element_type_wf_preserved [simp]:
"h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def element_ptrs_def
elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: if_splits)[1]
apply fastforce
by (metis Suc_n_not_le_n element_ptr.sel(1) element_ptrs_def fMax_ge ffmember_filter
fimage_eqI is_element_ptr_ref)
lemma new_element_is_l_new_element [instances]:
"l_new_element type_wf"
using l_new_element.intro new_element_type_wf_preserved
by blast
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_name_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr tag_name_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs
ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr child_nodes_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr attrs_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr shadow_root_opt_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma new_character_data_type_wf_preserved [simp]:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
dest!: get_heap_E
elim!: bind_returns_heap_E2 bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
by (meson new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap)
lemma new_character_data_is_l_new_character_data [instances]:
"l_new_character_data type_wf"
using l_new_character_data.intro new_character_data_type_wf_preserved
by blast
lemma put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_val_type_wf_preserved [simp]:
"h \<turnstile> put_M character_data_ptr val_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: CharacterDataMonad.put_M_defs put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_kind_def
dest!: get_heap_E elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs CharacterDataMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis bind.bind_lzero finite_set_in get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def option.distinct(1) option.exhaust_sel)
by (metis finite_set_in)
lemma new_document_type_wf_preserved [simp]: "h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_ptr_kind_none
elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I ElementMonad.type_wf_put_I CharacterDataMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: if_splits)[1]
apply(auto simp add: type_wf_defs ElementClass.type_wf_defs CharacterDataClass.type_wf_defs
NodeClass.type_wf_defs ObjectClass.type_wf_defs is_document_kind_def
split: option.splits)[1]
using document_ptrs_def apply fastforce
apply (simp add: is_document_kind_def)
apply (metis Suc_n_not_le_n document_ptr.sel(1) document_ptrs_def fMax_ge ffmember_filter
fimage_eqI is_document_ptr_ref)
done
locale l_new_document = l_type_wf +
assumes new_document_types_preserved: "h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma new_document_is_l_new_document [instances]: "l_new_document type_wf"
using l_new_document.intro new_document_type_wf_preserved
by blast
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_doctype_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr doctype_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: get_M_defs)[1]
by (metis (mono_tags) error_returns_result finite_set_in option.exhaust_sel option.simps(4))
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_document_element_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr document_element_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_ptr_kind_none
cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I
ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: get_M_defs is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs
split: option.splits)[1]
by (metis finite_set_in)
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_disconnected_nodes_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr disconnected_nodes_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_ptr_kind_none
cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I
ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_document_kind_def get_M_defs type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
by (metis finite_set_in)
lemma document_ptr_kinds_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "document_ptr_kinds h = document_ptr_kinds h'"
by(simp add: document_ptr_kinds_def preserved_def object_ptr_kinds_preserved_small[OF assms])
lemma document_ptr_kinds_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h'. \<forall>w \<in> SW. h \<turnstile> w \<rightarrow>\<^sub>h h'
\<longrightarrow> (\<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')"
shows "document_ptr_kinds h = document_ptr_kinds h'"
using writes_small_big[OF assms]
apply(simp add: reflp_def transp_def preserved_def document_ptr_kinds_def)
by (metis assms object_ptr_kinds_preserved)
lemma type_wf_preserved_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>character_data_ptr. preserved
(get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
shows "DocumentClass.type_wf h = DocumentClass.type_wf h'"
using type_wf_preserved_small[OF assms(1) assms(2) assms(3) assms(4)]
allI[OF assms(5), of id, simplified] document_ptr_kinds_small[OF assms(1)]
apply(auto simp add: type_wf_defs )[1]
apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)]
split: option.splits)[1]
apply force
apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)]
split: option.splits)[1]
by force
lemma type_wf_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>character_data_ptr. preserved
(get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
shows "DocumentClass.type_wf h = DocumentClass.type_wf h'"
proof -
have "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> DocumentClass.type_wf h = DocumentClass.type_wf h'"
using assms type_wf_preserved_small by fast
with assms(1) assms(2) show ?thesis
apply(rule writes_small_big)
by(auto simp add: reflp_def transp_def)
qed
lemma type_wf_drop: "type_wf h \<Longrightarrow> type_wf (Heap (fmdrop ptr (the_heap h)))"
apply(auto simp add: type_wf_defs)[1]
using type_wf_drop
apply blast
by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf CharacterDataMonad.type_wf_drop
document_ptr_kinds_commutes finite_set_in fmlookup_drop get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def heap.sel)
end
diff --git a/thys/Core_DOM/common/monads/ObjectMonad.thy b/thys/Core_DOM/common/monads/ObjectMonad.thy
--- a/thys/Core_DOM/common/monads/ObjectMonad.thy
+++ b/thys/Core_DOM/common/monads/ObjectMonad.thy
@@ -1,258 +1,258 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Object\<close>
text\<open>In this theory, we introduce the monadic method setup for the Object class.\<close>
theory ObjectMonad
imports
BaseMonad
"../classes/ObjectClass"
begin
type_synonym ('object_ptr, 'Object, 'result) dom_prog
= "((_) heap, exception, 'result) prog"
register_default_tvars "('object_ptr, 'Object, 'result) dom_prog"
global_interpretation l_ptr_kinds_M object_ptr_kinds defines object_ptr_kinds_M = a_ptr_kinds_M .
lemmas object_ptr_kinds_M_defs = a_ptr_kinds_M_def
global_interpretation l_dummy defines get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = "l_get_M.a_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t" .
lemma get_M_is_l_get_M: "l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds"
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_get_M_def)
lemmas get_M_defs = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]]
adhoc_overloading get_M get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
locale l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
begin
interpretation l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds
apply(unfold_locales)
apply (simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf local.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t)
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = get_M_ok[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = get_M_ptr_in_heap[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
end
global_interpretation l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf
by (simp add: l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms)
lemma object_ptr_kinds_M_reads:
"reads (\<Union>object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) object_ptr_kinds_M h h'"
apply(auto simp add: object_ptr_kinds_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf type_wf_defs reads_def
preserved_def get_M_defs
split: option.splits)[1]
using a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf by blast+
global_interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
rewrites "a_get_M = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t"
defines put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = a_put_M
apply (simp add: get_M_is_l_get_M l_put_M_def)
by (simp add: get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def)
lemmas put_M_defs = a_put_M_def
adhoc_overloading put_M put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
locale l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
begin
interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
apply(unfold_locales)
using get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t local.l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms apply blast
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = put_M_ok[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = put_M_ptr_in_heap[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
end
global_interpretation l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf
by (simp add: l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms)
definition check_in_heap :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog"
where
"check_in_heap ptr = do {
h \<leftarrow> get_heap;
(if ptr |\<in>| object_ptr_kinds h then
return ()
else
error SegmentationFault
)}"
lemma check_in_heap_ptr_in_heap: "ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> h \<turnstile> ok (check_in_heap ptr)"
by(auto simp add: check_in_heap_def)
lemma check_in_heap_pure [simp]: "pure (check_in_heap ptr) h"
by(auto simp add: check_in_heap_def intro!: bind_pure_I)
lemma check_in_heap_is_OK [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (check_in_heap ptr \<bind> f) = h \<turnstile> ok (f ())"
by(simp add: check_in_heap_def)
lemma check_in_heap_returns_result [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> (check_in_heap ptr \<bind> f) \<rightarrow>\<^sub>r x = h \<turnstile> f () \<rightarrow>\<^sub>r x"
by(simp add: check_in_heap_def)
lemma check_in_heap_returns_heap [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> (check_in_heap ptr \<bind> f) \<rightarrow>\<^sub>h h' = h \<turnstile> f () \<rightarrow>\<^sub>h h'"
by(simp add: check_in_heap_def)
lemma check_in_heap_reads:
"reads {preserved (get_M object_ptr nothing)} (check_in_heap object_ptr) h h'"
apply(simp add: check_in_heap_def reads_def preserved_def)
by (metis a_type_wf_def get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap is_OK_returns_result_E
is_OK_returns_result_I unit_all_impI)
subsection\<open>Invoke\<close>
fun invoke_rec :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog)) list \<Rightarrow> (_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog"
where
"invoke_rec ((P, f)#xs) ptr args = (if P ptr then f ptr args else invoke_rec xs ptr args)"
| "invoke_rec [] ptr args = error InvokeError"
definition invoke :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog)) list
\<Rightarrow> (_) object_ptr \<Rightarrow> 'args \<Rightarrow> (_, 'result) dom_prog"
where
"invoke xs ptr args = do { check_in_heap ptr; invoke_rec xs ptr args}"
lemma invoke_split: "P (invoke ((Pred, f) # xs) ptr args) =
((\<not>(Pred ptr) \<longrightarrow> P (invoke xs ptr args))
\<and> (Pred ptr \<longrightarrow> P (do {check_in_heap ptr; f ptr args})))"
by(simp add: invoke_def)
lemma invoke_split_asm: "P (invoke ((Pred, f) # xs) ptr args) =
(\<not>((\<not>(Pred ptr) \<and> (\<not> P (invoke xs ptr args)))
\<or> (Pred ptr \<and> (\<not> P (do {check_in_heap ptr; f ptr args})))))"
by(simp add: invoke_def)
lemmas invoke_splits = invoke_split invoke_split_asm
lemma invoke_ptr_in_heap: "h \<turnstile> ok (invoke xs ptr args) \<Longrightarrow> ptr |\<in>| object_ptr_kinds h"
by (metis bind_is_OK_E check_in_heap_ptr_in_heap invoke_def is_OK_returns_heap_I)
lemma invoke_pure [simp]: "pure (invoke [] ptr args) h"
by(auto simp add: invoke_def intro!: bind_pure_I)
lemma invoke_is_OK [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> ok (invoke ((Pred, f) # xs) ptr args) = h \<turnstile> ok (f ptr args)"
by(simp add: invoke_def)
lemma invoke_returns_result [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> (invoke ((Pred, f) # xs) ptr args) \<rightarrow>\<^sub>r x = h \<turnstile> f ptr args \<rightarrow>\<^sub>r x"
by(simp add: invoke_def)
lemma invoke_returns_heap [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> (invoke ((Pred, f) # xs) ptr args) \<rightarrow>\<^sub>h h' = h \<turnstile> f ptr args \<rightarrow>\<^sub>h h'"
by(simp add: invoke_def)
lemma invoke_not [simp]: "\<not>Pred ptr \<Longrightarrow> invoke ((Pred, f) # xs) ptr args = invoke xs ptr args"
by(auto simp add: invoke_def)
lemma invoke_empty [simp]: "\<not>h \<turnstile> ok (invoke [] ptr args)"
by(auto simp add: invoke_def check_in_heap_def)
lemma invoke_empty_reads [simp]: "\<forall>P \<in> S. reflp P \<and> transp P \<Longrightarrow> reads S (invoke [] ptr args) h h'"
apply(simp add: invoke_def reads_def preserved_def)
by (meson bind_returns_result_E error_returns_result)
subsection\<open>Modified Heaps\<close>
lemma get_object_ptr_simp [simp]:
"get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = (if ptr = object_ptr then Some obj else get object_ptr h)"
by(auto simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits Option.bind_splits)
lemma object_ptr_kinds_simp [simp]: "object_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = object_ptr_kinds h |\<union>| {|ptr|}"
by(auto simp add: object_ptr_kinds_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits)
lemma type_wf_put_I:
assumes "type_wf h"
shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
using assms
by(auto simp add: type_wf_defs split: option.splits)
lemma type_wf_put_ptr_not_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<notin>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs split: option.splits if_splits)
lemma type_wf_put_ptr_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs split: option.splits if_splits)
subsection\<open>Preserving Types\<close>
lemma type_wf_preserved: "type_wf h = type_wf h'"
by(auto simp add: type_wf_defs)
lemma object_ptr_kinds_preserved_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms
apply(auto simp add: object_ptr_kinds_def preserved_def get_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def
split: option.splits)[1]
- apply (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq
+ apply (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember_iff_member_fset
old.unit.exhaust option.case_eq_if return_returns_result)
- by (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq
+ by (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember_iff_member_fset
old.unit.exhaust option.case_eq_if return_returns_result)
lemma object_ptr_kinds_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' w object_ptr. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
proof -
{
fix object_ptr w
have "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
apply(rule writes_small_big[OF assms])
by auto
}
then show ?thesis
using object_ptr_kinds_preserved_small by blast
qed
lemma reads_writes_preserved2:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' x. \<forall>w \<in> SW. h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
shows "preserved (get_M ptr getter) h h'"
apply(clarsimp simp add: preserved_def)
using reads_singleton assms(1) assms(2)
apply(rule reads_writes_preserved)
using assms(3)
by(auto simp add: preserved_def)
end
diff --git a/thys/Core_DOM/standard/Core_DOM_Heap_WF.thy b/thys/Core_DOM/standard/Core_DOM_Heap_WF.thy
--- a/thys/Core_DOM/standard/Core_DOM_Heap_WF.thy
+++ b/thys/Core_DOM/standard/Core_DOM_Heap_WF.thy
@@ -1,8044 +1,8044 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Wellformedness\<close>
text\<open>In this theory, we discuss the wellformedness of the DOM. First, we define
wellformedness and, second, we show for all functions for querying and modifying the
DOM to what extend they preserve wellformendess.\<close>
theory Core_DOM_Heap_WF
imports
"Core_DOM_Functions"
begin
locale l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_owner_document_valid :: "(_) heap \<Rightarrow> bool"
where
"a_owner_document_valid h \<longleftrightarrow> (\<forall>node_ptr \<in> fset (node_ptr_kinds h).
((\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
\<or> (\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)))"
lemma a_owner_document_valid_code [code]: "a_owner_document_valid h \<longleftrightarrow> node_ptr_kinds h |\<subseteq>|
fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)) @ map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))
"
apply(auto simp add: a_owner_document_valid_def
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_owner_document_valid_def)[1]
proof -
fix x
assume 1: " \<forall>node_ptr\<in>fset (node_ptr_kinds h).
(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
assume 2: "x |\<in>| node_ptr_kinds h"
assume 3: "x |\<notin>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
have "\<not>(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
x \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using 1 2 3
by (smt (verit) UN_I fset_of_list_elem image_eqI notin_fset set_concat set_map sorted_list_of_fset_simps(1))
then
have "(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> x \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using 1 2
by auto
then obtain parent_ptr where parent_ptr:
"parent_ptr |\<in>| object_ptr_kinds h \<and> x \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
by auto
moreover have "parent_ptr \<in> set (sorted_list_of_fset (object_ptr_kinds h))"
using parent_ptr by auto
moreover have "|h \<turnstile> get_child_nodes parent_ptr|\<^sub>r \<in> set (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))"
using calculation(2) by auto
ultimately
show "x |\<in>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h))))"
using fset_of_list_elem by fastforce
next
fix node_ptr
assume 1: "node_ptr_kinds h |\<subseteq>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))) |\<union>|
fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
assume 2: "node_ptr |\<in>| node_ptr_kinds h"
assume 3: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<longrightarrow>
node_ptr \<notin> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
have "node_ptr \<in> set (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))) \<or>
node_ptr \<in> set (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
using 1 2
by (meson fin_mono fset_of_list_elem funion_iff)
then
show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using 3
by auto
qed
definition a_parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
where
"a_parent_child_rel h = {(parent, child). parent |\<in>| object_ptr_kinds h
\<and> child \<in> cast ` set |h \<turnstile> get_child_nodes parent|\<^sub>r}"
lemma a_parent_child_rel_code [code]: "a_parent_child_rel h = set (concat (map
(\<lambda>parent. map
(\<lambda>child. (parent, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child))
|h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))
)"
by(auto simp add: a_parent_child_rel_def)
definition a_acyclic_heap :: "(_) heap \<Rightarrow> bool"
where
"a_acyclic_heap h = acyclic (a_parent_child_rel h)"
definition a_all_ptrs_in_heap :: "(_) heap \<Rightarrow> bool"
where
"a_all_ptrs_in_heap h \<longleftrightarrow>
(\<forall>ptr \<in> fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes ptr|\<^sub>r \<subseteq> fset (node_ptr_kinds h)) \<and>
(\<forall>document_ptr \<in> fset (document_ptr_kinds h).
set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r \<subseteq> fset (node_ptr_kinds h))"
definition a_distinct_lists :: "(_) heap \<Rightarrow> bool"
where
"a_distinct_lists h = distinct (concat (
(map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)
@ (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r)
))"
definition a_heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
where
"a_heap_is_wellformed h \<longleftrightarrow>
a_acyclic_heap h \<and> a_all_ptrs_in_heap h \<and> a_distinct_lists h \<and> a_owner_document_valid h"
end
locale l_heap_is_wellformed_defs =
fixes heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
fixes parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
global_interpretation l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
defines heap_is_wellformed = "l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_heap_is_wellformed get_child_nodes
get_disconnected_nodes"
and parent_child_rel = "l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_parent_child_rel get_child_nodes"
and acyclic_heap = a_acyclic_heap
and all_ptrs_in_heap = a_all_ptrs_in_heap
and distinct_lists = a_distinct_lists
and owner_document_valid = a_owner_document_valid
.
locale l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
+ l_heap_is_wellformed_defs heap_is_wellformed parent_child_rel
+ l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set" +
assumes heap_is_wellformed_impl: "heap_is_wellformed = a_heap_is_wellformed"
assumes parent_child_rel_impl: "parent_child_rel = a_parent_child_rel"
begin
lemmas heap_is_wellformed_def = heap_is_wellformed_impl[unfolded a_heap_is_wellformed_def]
lemmas parent_child_rel_def = parent_child_rel_impl[unfolded a_parent_child_rel_def]
lemmas acyclic_heap_def = a_acyclic_heap_def[folded parent_child_rel_impl]
lemma parent_child_rel_node_ptr:
"(parent, child) \<in> parent_child_rel h \<Longrightarrow> is_node_ptr_kind child"
by(auto simp add: parent_child_rel_def)
lemma parent_child_rel_child_nodes:
assumes "known_ptr parent"
and "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "child \<in> set children"
shows "(parent, cast child) \<in> parent_child_rel h"
using assms
apply(auto simp add: parent_child_rel_def is_OK_returns_result_I )[1]
using get_child_nodes_ptr_in_heap by blast
lemma parent_child_rel_child_nodes2:
assumes "known_ptr parent"
and "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "child \<in> set children"
and "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = child_obj"
shows "(parent, child_obj) \<in> parent_child_rel h"
using assms parent_child_rel_child_nodes by blast
lemma parent_child_rel_finite: "finite (parent_child_rel h)"
proof -
have "parent_child_rel h = (\<Union>ptr \<in> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r.
(\<Union>child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r. {(ptr, cast child)}))"
by(auto simp add: parent_child_rel_def)
moreover have "finite (\<Union>ptr \<in> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r.
(\<Union>child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r. {(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)}))"
by simp
ultimately show ?thesis
by simp
qed
lemma distinct_lists_no_parent:
assumes "a_distinct_lists h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
shows "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using assms
apply(auto simp add: a_distinct_lists_def)[1]
proof -
fix parent_ptr :: "(_) object_ptr"
assume a1: "parent_ptr |\<in>| object_ptr_kinds h"
assume a2: "(\<Union>x\<in>fset (object_ptr_kinds h).
set |h \<turnstile> get_child_nodes x|\<^sub>r) \<inter> (\<Union>x\<in>fset (document_ptr_kinds h).
set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
assume a3: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume a4: "node_ptr \<in> set disc_nodes"
assume a5: "node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
have f6: "parent_ptr \<in> fset (object_ptr_kinds h)"
using a1 by auto
have f7: "document_ptr \<in> fset (document_ptr_kinds h)"
- using a3 by (meson fmember.rep_eq get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I)
+ using a3 by (meson fmember_iff_member_fset get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I)
have "|h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = disc_nodes"
using a3 by simp
then show False
using f7 f6 a5 a4 a2 by blast
qed
lemma distinct_lists_disconnected_nodes:
assumes "a_distinct_lists h"
and "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
shows "distinct disc_nodes"
proof -
have h1: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using assms(1)
by(simp add: a_distinct_lists_def)
then show ?thesis
using concat_map_all_distinct[OF h1] assms(2) is_OK_returns_result_I get_disconnected_nodes_ok
by (metis (no_types, lifting) DocumentMonad.ptr_kinds_ptr_kinds_M
l_get_disconnected_nodes.get_disconnected_nodes_ptr_in_heap
l_get_disconnected_nodes_axioms select_result_I2)
qed
lemma distinct_lists_children:
assumes "a_distinct_lists h"
and "known_ptr ptr"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
shows "distinct children"
proof (cases "children = []", simp)
assume "children \<noteq> []"
have h1: "distinct (concat ((map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)))"
using assms(1)
by(simp add: a_distinct_lists_def)
show ?thesis
using concat_map_all_distinct[OF h1] assms(2) assms(3)
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M get_child_nodes_ptr_in_heap
is_OK_returns_result_I select_result_I2)
qed
lemma heap_is_wellformed_children_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "child |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: heap_is_wellformed_def a_all_ptrs_in_heap_def)[1]
by (metis (no_types, lifting) finite_set_in is_OK_returns_result_I
local.get_child_nodes_ptr_in_heap select_result_I2 subsetD)
lemma heap_is_wellformed_one_parent:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'"
assumes "set children \<inter> set children' \<noteq> {}"
shows "ptr = ptr'"
using assms
proof (auto simp add: heap_is_wellformed_def a_distinct_lists_def)[1]
fix x :: "(_) node_ptr"
assume a1: "ptr \<noteq> ptr'"
assume a2: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assume a3: "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'"
assume a4: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
have f5: "|h \<turnstile> get_child_nodes ptr|\<^sub>r = children"
using a2 by simp
have "|h \<turnstile> get_child_nodes ptr'|\<^sub>r = children'"
using a3 by (meson select_result_I2)
then have "ptr \<notin> set (sorted_list_of_set (fset (object_ptr_kinds h)))
\<or> ptr' \<notin> set (sorted_list_of_set (fset (object_ptr_kinds h)))
\<or> set children \<inter> set children' = {}"
using f5 a4 a1 by (meson distinct_concat_map_E(1))
then show False
- using a3 a2 by (metis (no_types) assms(4) finite_fset fmember.rep_eq is_OK_returns_result_I
+ using a3 a2 by (metis (no_types) assms(4) finite_fset fmember_iff_member_fset is_OK_returns_result_I
local.get_child_nodes_ptr_in_heap set_sorted_list_of_set)
qed
lemma parent_child_rel_child:
"h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<longleftrightarrow> (ptr, cast child) \<in> parent_child_rel h"
by (simp add: is_OK_returns_result_I get_child_nodes_ptr_in_heap parent_child_rel_def)
lemma parent_child_rel_acyclic: "heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
by (simp add: acyclic_heap_def local.heap_is_wellformed_def)
lemma heap_is_wellformed_disconnected_nodes_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
distinct disc_nodes"
using distinct_lists_disconnected_nodes local.heap_is_wellformed_def by blast
lemma parent_child_rel_parent_in_heap:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> parent |\<in>| object_ptr_kinds h"
using local.parent_child_rel_def by blast
lemma parent_child_rel_child_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent
\<Longrightarrow> (parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
apply(auto simp add: heap_is_wellformed_def parent_child_rel_def a_all_ptrs_in_heap_def)[1]
using get_child_nodes_ok
by (meson finite_set_in subsetD)
lemma heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
by (metis (no_types, lifting) finite_set_in is_OK_returns_result_I local.a_all_ptrs_in_heap_def
local.get_disconnected_nodes_ptr_in_heap local.heap_is_wellformed_def select_result_I2 subsetD)
lemma heap_is_wellformed_one_disc_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {} \<Longrightarrow> document_ptr = document_ptr'"
using DocumentMonad.ptr_kinds_ptr_kinds_M concat_append distinct_append distinct_concat_map_E(1)
is_OK_returns_result_I local.a_distinct_lists_def local.get_disconnected_nodes_ptr_in_heap
local.heap_is_wellformed_def select_result_I2
proof -
assume a1: "heap_is_wellformed h"
assume a2: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume a3: "h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'"
assume a4: "set disc_nodes \<inter> set disc_nodes' \<noteq> {}"
have f5: "|h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = disc_nodes"
using a2 by (meson select_result_I2)
have f6: "|h \<turnstile> get_disconnected_nodes document_ptr'|\<^sub>r = disc_nodes'"
using a3 by (meson select_result_I2)
have "\<And>nss nssa. \<not> distinct (concat (nss @ nssa)) \<or> distinct (concat nssa::(_) node_ptr list)"
by (metis (no_types) concat_append distinct_append)
then have "distinct (concat (map (\<lambda>d. |h \<turnstile> get_disconnected_nodes d|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using a1 local.a_distinct_lists_def local.heap_is_wellformed_def by blast
then show ?thesis
using f6 f5 a4 a3 a2 by (meson DocumentMonad.ptr_kinds_ptr_kinds_M distinct_concat_map_E(1)
is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap)
qed
lemma heap_is_wellformed_children_disc_nodes_different:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> set children \<inter> set disc_nodes = {}"
by (metis (no_types, opaque_lifting) disjoint_iff_not_equal distinct_lists_no_parent
is_OK_returns_result_I local.get_child_nodes_ptr_in_heap
local.heap_is_wellformed_def select_result_I2)
lemma heap_is_wellformed_children_disc_nodes:
"heap_is_wellformed h \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h
\<Longrightarrow> \<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)
\<Longrightarrow> (\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
apply(auto simp add: heap_is_wellformed_def a_distinct_lists_def a_owner_document_valid_def)[1]
- by (meson fmember.rep_eq)
+ by (meson fmember_iff_member_fset)
lemma heap_is_wellformed_children_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M concat_append distinct_append
distinct_concat_map_E(2) is_OK_returns_result_I local.a_distinct_lists_def
local.get_child_nodes_ptr_in_heap local.heap_is_wellformed_def
select_result_I2)
end
locale l_heap_is_wellformed = l_type_wf + l_known_ptr + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_get_disconnected_nodes_defs +
assumes heap_is_wellformed_children_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children
\<Longrightarrow> child |\<in>| node_ptr_kinds h"
assumes heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
assumes heap_is_wellformed_one_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr'"
assumes heap_is_wellformed_one_disc_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {} \<Longrightarrow> document_ptr = document_ptr'"
assumes heap_is_wellformed_children_disc_nodes_different:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> set children \<inter> set disc_nodes = {}"
assumes heap_is_wellformed_disconnected_nodes_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> distinct disc_nodes"
assumes heap_is_wellformed_children_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
assumes heap_is_wellformed_children_disc_nodes:
"heap_is_wellformed h \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h
\<Longrightarrow> \<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)
\<Longrightarrow> (\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
assumes parent_child_rel_child:
"h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<longleftrightarrow> (ptr, cast child) \<in> parent_child_rel h"
assumes parent_child_rel_finite:
"heap_is_wellformed h \<Longrightarrow> finite (parent_child_rel h)"
assumes parent_child_rel_acyclic:
"heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
assumes parent_child_rel_node_ptr:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> is_node_ptr_kind child_ptr"
assumes parent_child_rel_parent_in_heap:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> parent |\<in>| object_ptr_kinds h"
assumes parent_child_rel_child_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent
\<Longrightarrow> (parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
interpretation i_heap_is_wellformed?: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel
apply(unfold_locales)
by(auto simp add: heap_is_wellformed_def parent_child_rel_def)
declare l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma heap_is_wellformed_is_l_heap_is_wellformed [instances]:
"l_heap_is_wellformed type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def)[1]
using heap_is_wellformed_children_in_heap
apply blast
using heap_is_wellformed_disc_nodes_in_heap
apply blast
using heap_is_wellformed_one_parent
apply blast
using heap_is_wellformed_one_disc_parent
apply blast
using heap_is_wellformed_children_disc_nodes_different
apply blast
using heap_is_wellformed_disconnected_nodes_distinct
apply blast
using heap_is_wellformed_children_distinct
apply blast
using heap_is_wellformed_children_disc_nodes
apply blast
using parent_child_rel_child
apply (blast)
using parent_child_rel_child
apply(blast)
using parent_child_rel_finite
apply blast
using parent_child_rel_acyclic
apply blast
using parent_child_rel_node_ptr
apply blast
using parent_child_rel_parent_in_heap
apply blast
using parent_child_rel_child_in_heap
apply blast
done
subsection \<open>get\_parent\<close>
locale l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
+ l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma child_parent_dual:
assumes heap_is_wellformed: "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
assumes "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
proof -
obtain ptrs where ptrs: "h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have h1: "ptr \<in> set ptrs"
using get_child_nodes_ok assms(2) is_OK_returns_result_I
by (metis (no_types, opaque_lifting) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>\<And>thesis. (\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
get_child_nodes_ptr_in_heap returns_result_eq select_result_I2)
let ?P = "(\<lambda>ptr. get_child_nodes ptr \<bind> (\<lambda>children. return (child \<in> set children)))"
let ?filter = "filter_M ?P ptrs"
have "h \<turnstile> ok ?filter"
using ptrs type_wf
using get_child_nodes_ok
apply(auto intro!: filter_M_is_OK_I bind_is_OK_pure_I get_child_nodes_ok simp add: bind_pure_I)[1]
using assms(4) local.known_ptrs_known_ptr by blast
then obtain parent_ptrs where parent_ptrs: "h \<turnstile> ?filter \<rightarrow>\<^sub>r parent_ptrs"
by auto
have h5: "\<exists>!x. x \<in> set ptrs \<and> h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
apply(auto intro!: bind_pure_returns_result_I)[1]
using heap_is_wellformed_one_parent
proof -
have "h \<turnstile> (return (child \<in> set children)::((_) heap, exception, bool) prog) \<rightarrow>\<^sub>r True"
by (simp add: assms(3))
then show
"\<exists>z. z \<in> set ptrs \<and> h \<turnstile> Heap_Error_Monad.bind (get_child_nodes z)
(\<lambda>ns. return (child \<in> set ns)) \<rightarrow>\<^sub>r True"
by (metis (no_types) assms(2) bind_pure_returns_result_I2 h1 is_OK_returns_result_I
local.get_child_nodes_pure select_result_I2)
next
fix x y
assume 0: "x \<in> set ptrs"
and 1: "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
and 2: "y \<in> set ptrs"
and 3: "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes y)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
and 4: "(\<And>h ptr children ptr' children'. heap_is_wellformed h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr')"
then show "x = y"
by (metis (no_types, lifting) bind_returns_result_E disjoint_iff_not_equal heap_is_wellformed
return_returns_result)
qed
have "child |\<in>| node_ptr_kinds h"
using heap_is_wellformed_children_in_heap heap_is_wellformed assms(2) assms(3)
by fast
moreover have "parent_ptrs = [ptr]"
apply(rule filter_M_ex1[OF parent_ptrs h1 h5])
using ptrs assms(2) assms(3)
by(auto simp add: object_ptr_kinds_M_defs bind_pure_I intro!: bind_pure_returns_result_I)
ultimately show ?thesis
using ptrs parent_ptrs
by(auto simp add: bind_pure_I get_parent_def
elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I) (*slow, ca 1min *)
qed
lemma parent_child_rel_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
shows "(parent, cast child_node) \<in> parent_child_rel h"
using assms parent_child_rel_child get_parent_child_dual by auto
lemma heap_wellformed_induct [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
and step: "\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child)) \<Longrightarrow> P parent"
shows "P ptr"
proof -
fix ptr
have "wf ((parent_child_rel h)\<inverse>)"
by (simp add: assms(1) finite_acyclic_wf_converse parent_child_rel_acyclic parent_child_rel_finite)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
using assms parent_child_rel_child
by (meson converse_iff)
qed
qed
lemma heap_wellformed_induct2 [consumes 3, case_names not_in_heap empty_children step]:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
and not_in_heap: "\<And>parent. parent |\<notin>| object_ptr_kinds h \<Longrightarrow> P parent"
and empty_children: "\<And>parent. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r [] \<Longrightarrow> P parent"
and step: "\<And>parent children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child) \<Longrightarrow> P parent"
shows "P ptr"
proof(insert assms(1), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof(cases "parent |\<in>| object_ptr_kinds h")
case True
then obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(2) assms(3)
by (meson is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?thesis
proof (cases "children = []")
case True
then show ?thesis
using children empty_children
by simp
next
case False
then show ?thesis
using assms(6) children last_in_set step.hyps by blast
qed
next
case False
then show ?thesis
by (simp add: not_in_heap)
qed
qed
lemma heap_wellformed_induct_rev [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
and step: "\<And>child. (\<And>parent child_node. cast child_node = child
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent) \<Longrightarrow> P child"
shows "P ptr"
proof -
fix ptr
have "wf ((parent_child_rel h))"
by (simp add: assms(1) local.parent_child_rel_acyclic local.parent_child_rel_finite
wf_iff_acyclic_if_finite)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less child)
show ?case
using assms get_parent_child_dual
by (metis less.hyps parent_child_rel_parent)
qed
qed
end
interpretation i_get_parent_wf?: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed
parent_child_rel get_disconnected_nodes
using instances
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
heap_is_wellformed parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
+ l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma preserves_wellformedness_writes_needed:
assumes heap_is_wellformed: "heap_is_wellformed h"
and "h \<turnstile> f \<rightarrow>\<^sub>h h'"
and "writes SW f h h'"
and preserved_get_child_nodes:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. \<forall>r \<in> get_child_nodes_locs object_ptr. r h h'"
and preserved_get_disconnected_nodes:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>document_ptr. \<forall>r \<in> get_disconnected_nodes_locs document_ptr. r h h'"
and preserved_object_pointers:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "heap_is_wellformed h'"
proof -
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
using assms(2) assms(3) object_ptr_kinds_preserved preserved_object_pointers by blast
then have object_ptr_kinds_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
by auto
have children_eq:
"\<And>ptr children. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads assms(3) assms(2)])
using preserved_get_child_nodes by fast
then have children_eq2: "\<And>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq:
"\<And>document_ptr disconnected_nodes.
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads assms(3) assms(2)])
using preserved_get_disconnected_nodes by fast
then have disconnected_nodes_eq2:
"\<And>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r
= |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have get_parent_eq: "\<And>ptr parent. h \<turnstile> get_parent ptr \<rightarrow>\<^sub>r parent = h' \<turnstile> get_parent ptr \<rightarrow>\<^sub>r parent"
apply(rule reads_writes_preserved[OF get_parent_reads assms(3) assms(2)])
using preserved_get_child_nodes preserved_object_pointers unfolding get_parent_locs_def by fast
have "a_acyclic_heap h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h"
by(simp add: parent_child_rel_def children_eq2 object_ptr_kinds_eq3)
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
by (simp add: children_eq2 disconnected_nodes_eq2 document_ptr_kinds_eq3
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_all_ptrs_in_heap_def node_ptr_kinds_eq3 object_ptr_kinds_eq3)
moreover have h0: "a_distinct_lists h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
have h1: "map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h)))
= map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h')))"
by (simp add: children_eq2 object_ptr_kinds_eq3)
have h2: "map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))
= map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))"
using disconnected_nodes_eq document_ptr_kinds_eq2 select_result_eq by force
have "a_distinct_lists h'"
using h0
by(simp add: a_distinct_lists_def h1 h2)
moreover have "a_owner_document_valid h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
by(auto simp add: a_owner_document_valid_def children_eq2 disconnected_nodes_eq2
object_ptr_kinds_eq3 node_ptr_kinds_eq3 document_ptr_kinds_eq3)
ultimately show ?thesis
by (simp add: heap_is_wellformed_def)
qed
end
interpretation i_get_parent_wf2?: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs
heap_is_wellformed parent_child_rel get_disconnected_nodes
get_disconnected_nodes_locs
using l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by (simp add: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_get_parent_wf = l_type_wf + l_known_ptrs + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_get_parent_defs +
assumes child_parent_dual:
"heap_is_wellformed h
\<Longrightarrow> type_wf h
\<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children
\<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
assumes heap_wellformed_induct [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child)) \<Longrightarrow> P parent)
\<Longrightarrow> P ptr"
assumes heap_wellformed_induct_rev [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>child. (\<And>parent child_node. cast child_node = child
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent) \<Longrightarrow> P child)
\<Longrightarrow> P ptr"
assumes parent_child_rel_parent: "heap_is_wellformed h
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent
\<Longrightarrow> (parent, cast child_node) \<in> parent_child_rel h"
lemma get_parent_wf_is_l_get_parent_wf [instances]:
"l_get_parent_wf type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def)[1]
using child_parent_dual heap_wellformed_induct heap_wellformed_induct_rev parent_child_rel_parent
by metis+
subsection \<open>get\_disconnected\_nodes\<close>
subsection \<open>set\_disconnected\_nodes\<close>
subsubsection \<open>get\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma remove_from_disconnected_nodes_removes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "h \<turnstile> set_disconnected_nodes ptr (remove1 node_ptr disc_nodes) \<rightarrow>\<^sub>h h'"
assumes "h' \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes'"
shows "node_ptr \<notin> set disc_nodes'"
using assms
by (metis distinct_remove1_removeAll heap_is_wellformed_disconnected_nodes_distinct
set_disconnected_nodes_get_disconnected_nodes member_remove remove_code(1)
returns_result_eq)
end
locale l_set_disconnected_nodes_get_disconnected_nodes_wf = l_heap_is_wellformed
+ l_set_disconnected_nodes_get_disconnected_nodes +
assumes remove_from_disconnected_nodes_removes:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> set_disconnected_nodes ptr (remove1 node_ptr disc_nodes) \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> node_ptr \<notin> set disc_nodes'"
interpretation i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M?:
l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs heap_is_wellformed
parent_child_rel get_child_nodes
using instances
by (simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_disconnected_nodes_wf_is_l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]:
"l_set_disconnected_nodes_get_disconnected_nodes_wf type_wf known_ptr heap_is_wellformed parent_child_rel
get_child_nodes get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def
l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
using remove_from_disconnected_nodes_removes apply fast
done
subsection \<open>get\_root\_node\<close>
locale l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
+ l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
+ l_get_parent_wf
type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel get_child_nodes
get_child_nodes_locs get_parent get_parent_locs
+ l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_ancestors :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_ancestors_reads:
assumes "heap_is_wellformed h"
shows "reads get_ancestors_locs (get_ancestors node_ptr) h h'"
proof (insert assms(1), induct rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
using [[simproc del: Product_Type.unit_eq]] get_parent_reads[unfolded reads_def]
apply(simp (no_asm) add: get_ancestors_def)
by(auto simp add: get_ancestors_locs_def reads_subset[OF return_reads] get_parent_reads_pointers
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads]
reads_subset[OF get_parent_reads] reads_subset[OF get_child_nodes_reads]
split: option.splits)
qed
lemma get_ancestors_ok:
assumes "heap_is_wellformed h"
and "ptr |\<in>| object_ptr_kinds h"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "h \<turnstile> ok (get_ancestors ptr)"
proof (insert assms(1) assms(2), induct rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
using assms(3) assms(4)
apply(simp (no_asm) add: get_ancestors_def)
apply(simp add: assms(1) get_parent_parent_in_heap)
by(auto intro!: bind_is_OK_pure_I bind_pure_I get_parent_ok split: option.splits)
qed
lemma get_root_node_ptr_in_heap:
assumes "h \<turnstile> ok (get_root_node ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
unfolding get_root_node_def
using get_ancestors_ptr_in_heap
by auto
lemma get_root_node_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_root_node ptr)"
unfolding get_root_node_def
using assms get_ancestors_ok
by auto
lemma get_ancestors_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
shows "h \<turnstile> get_ancestors (cast child) \<rightarrow>\<^sub>r (cast child) # parent # ancestors
\<longleftrightarrow> h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
proof
assume a1: "h \<turnstile> get_ancestors (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r
cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
then have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child))
(\<lambda>_. Heap_Error_Monad.bind (get_parent child)
(\<lambda>x. Heap_Error_Monad.bind (case x of None \<Rightarrow> return [] | Some x \<Rightarrow> get_ancestors x)
(\<lambda>ancestors. return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # ancestors))))
\<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
by(simp add: get_ancestors_def)
then show "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
using assms(2) apply(auto elim!: bind_returns_result_E2 split: option.splits)[1]
using returns_result_eq by fastforce
next
assume "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
then show "h \<turnstile> get_ancestors (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
using assms(2)
apply(simp (no_asm) add: get_ancestors_def)
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
by (metis (full_types) assms(2) check_in_heap_ptr_in_heap is_OK_returns_result_I
local.get_parent_ptr_in_heap node_ptr_kinds_commutes old.unit.exhaust
select_result_I)
qed
lemma get_ancestors_never_empty:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors"
shows "ancestors \<noteq> []"
proof(insert assms(2), induct arbitrary: ancestors rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
next
case (Some child_node)
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
with Some show ?case
proof(induct parent_opt)
case None
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
next
case (Some option)
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
qed
qed
qed
lemma get_ancestors_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors ancestor \<rightarrow>\<^sub>r ancestor_ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "set ancestor_ancestors \<subseteq> set ancestors"
proof (insert assms(1) assms(2) assms(3), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_ptr_in_heap step(2) by auto
(* then have "h \<turnstile> check_in_heap child \<rightarrow>\<^sub>r ()"
using returns_result_select_result by force *)
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then have "ancestors = [child]"
using step(2) step(3)
by(auto simp add: get_ancestors_def elim!: bind_returns_result_E2)
show ?case
using step(2) step(3)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric]
get_parent_ok[OF type_wf known_ptrs]
by (metis (no_types, lifting) is_OK_returns_result_E known_ptrs get_parent_ok
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(2) step(3) s1
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(2) step(3)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some parent)
have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap child)
(\<lambda>_. Heap_Error_Monad.bind
(case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child of None \<Rightarrow> return []
| Some node_ptr \<Rightarrow> Heap_Error_Monad.bind (get_parent node_ptr)
(\<lambda>parent_ptr_opt. case parent_ptr_opt of None \<Rightarrow> return []
| Some x \<Rightarrow> get_ancestors x))
(\<lambda>ancestors. return (child # ancestors)))
\<rightarrow>\<^sub>r ancestors"
using step(2)
by(simp add: get_ancestors_def)
moreover obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using calculation
by(auto elim!: bind_returns_result_E2 split: option.splits)
ultimately have "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 Some
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(1)[OF s1[symmetric, simplified] Some \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors\<close>]
step(3)
apply(auto simp add: tl_ancestors)[1]
by (metis assms(4) insert_iff list.simps(15) local.step(2) returns_result_eq tl_ancestors)
qed
qed
qed
lemma get_ancestors_also_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast child \<in> set ancestors"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "parent \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors (cast child) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(4) get_ancestors_ok is_OK_returns_result_I known_ptrs
local.get_parent_ptr_in_heap node_ptr_kinds_commutes returns_result_select_result
type_wf)
then have "parent \<in> set child_ancestors"
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_subset by blast
qed
lemma get_ancestors_obtains_children:
assumes "heap_is_wellformed h"
and "ancestor \<noteq> ptr"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
obtains children ancestor_child where "h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children" and "cast ancestor_child \<in> set ancestors"
proof -
assume 0: "(\<And>children ancestor_child.
h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<Longrightarrow>
ancestor_child \<in> set children \<Longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set ancestors
\<Longrightarrow> thesis)"
have "\<exists>child. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ancestor \<and> cast child \<in> set ancestors"
proof (insert assms(1) assms(2) assms(3) assms(4), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_ptr_in_heap step(4) by auto
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then have "ancestors = [child]"
using step(3) step(4)
by(auto simp add: get_ancestors_def elim!: bind_returns_result_E2)
show ?case
using step(2) step(3) step(4)
by(auto simp add: \<open>ancestors = [child]\<close>)
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric]
using get_parent_ok known_ptrs type_wf
by (metis (no_types, lifting) is_OK_returns_result_E node_ptr_casts_commute
node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(2) step(3) step(4) s1
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(2) step(3) step(4)
by(auto simp add: \<open>ancestors = [child]\<close>)
next
case (Some parent)
have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap child)
(\<lambda>_. Heap_Error_Monad.bind
(case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child of None \<Rightarrow> return []
| Some node_ptr \<Rightarrow> Heap_Error_Monad.bind (get_parent node_ptr)
(\<lambda>parent_ptr_opt. case parent_ptr_opt of None \<Rightarrow> return []
| Some x \<Rightarrow> get_ancestors x))
(\<lambda>ancestors. return (child # ancestors)))
\<rightarrow>\<^sub>r ancestors"
using step(4)
by(simp add: get_ancestors_def)
moreover obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using calculation
by(auto elim!: bind_returns_result_E2 split: option.splits)
ultimately have "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 Some
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
(* have "ancestor \<noteq> parent" *)
have "ancestor \<in> set tl_ancestors"
using tl_ancestors step(2) step(3) by auto
show ?case
proof (cases "ancestor \<noteq> parent")
case True
show ?thesis
using step(1)[OF s1[symmetric, simplified] Some True
\<open>ancestor \<in> set tl_ancestors\<close> \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors\<close>]
using tl_ancestors by auto
next
case False
have "child \<in> set ancestors"
using step(4) get_ancestors_ptr by simp
then show ?thesis
using Some False s1[symmetric] by(auto)
qed
qed
qed
qed
then obtain child where child: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ancestor"
and in_ancestors: "cast child \<in> set ancestors"
by auto
then obtain children where
children: "h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children" and
child_in_children: "child \<in> set children"
using get_parent_child_dual by blast
show thesis
using 0[OF children child_in_children] child assms(3) in_ancestors by blast
qed
lemma get_ancestors_parent_child_rel:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "(ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
proof (safe)
assume 3: "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
show "ptr \<in> set ancestors"
proof (insert 3, induct ptr rule: heap_wellformed_induct[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by (metis (no_types, lifting) assms(2) bind_returns_result_E get_ancestors_def
in_set_member member_rec(1) return_returns_result)
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h) \<and> (ptr_child, child) \<in> (parent_child_rel h)\<^sup>*"
using converse_rtranclE[OF 1(2)] \<open>ptr \<noteq> child\<close>
by metis
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 parent_child_rel_node_ptr
by (metis )
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using local.parent_child_rel_parent_in_heap ptr_child by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis calculation known_ptrs local.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child ptr_child ptr_child_ptr_child_node
returns_result_select_result type_wf)
ultimately show ?thesis
using a1 get_child_nodes_ok type_wf known_ptrs
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h)\<^sup>*"
using ptr_child ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using known_ptrs type_wf by blast
ultimately show ?thesis
using get_ancestors_also_parent assms type_wf by blast
qed
qed
next
assume 3: "ptr \<in> set ancestors"
show "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
proof (insert 3, induct ptr rule: heap_wellformed_induct[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
then obtain children ptr_child_node where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children" and
ptr_child_node_in_ancestors: "cast ptr_child_node \<in> set ancestors"
using 1(2) assms(2) get_ancestors_obtains_children assms(1)
using known_ptrs type_wf by blast
then have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h)\<^sup>*"
using 1(1) by blast
moreover have "(ptr, cast ptr_child_node) \<in> parent_child_rel h"
using children ptr_child_node assms(1) parent_child_rel_child_nodes2
using child_parent_dual known_ptrs parent_child_rel_parent type_wf
by blast
ultimately show ?thesis
by auto
qed
qed
qed
lemma get_root_node_parent_child_rel:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r root"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "(root, child) \<in> (parent_child_rel h)\<^sup>*"
using assms get_ancestors_parent_child_rel
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
using get_ancestors_never_empty last_in_set by blast
lemma get_ancestors_eq:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "\<And>object_ptr w. object_ptr \<noteq> ptr \<Longrightarrow> w \<in> get_child_nodes_locs object_ptr \<Longrightarrow> w h h'"
and pointers_preserved: "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
and known_ptrs: "known_ptrs h"
and known_ptrs': "known_ptrs h'"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
proof -
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
using pointers_preserved object_ptr_kinds_preserved_small by blast
then have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
have "h' \<turnstile> ok (get_ancestors ptr)"
using get_ancestors_ok get_ancestors_ptr_in_heap object_ptr_kinds_eq3 assms(1) known_ptrs
known_ptrs' assms(2) assms(7) type_wf'
by blast
then obtain ancestors' where ancestors': "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'"
by auto
obtain root where root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
proof -
assume 0: "(\<And>root. h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow> thesis)"
show thesis
apply(rule 0)
using assms(7)
by(auto simp add: get_root_node_def elim!: bind_returns_result_E2 split: option.splits)
qed
have children_eq:
"\<And>p children. p \<noteq> ptr \<Longrightarrow> h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
using get_child_nodes_reads assms(3)
apply(simp add: reads_def reflp_def transp_def preserved_def)
by blast
have "acyclic (parent_child_rel h)"
using assms(1) local.parent_child_rel_acyclic by auto
have "acyclic (parent_child_rel h')"
using assms(2) local.parent_child_rel_acyclic by blast
have 2: "\<And>c parent_opt. cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c \<in> set ancestors \<inter> set ancestors'
\<Longrightarrow> h \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt = h' \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt"
proof -
fix c parent_opt
assume 1: " cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c \<in> set ancestors \<inter> set ancestors'"
obtain ptrs where ptrs: "h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by simp
let ?P = "(\<lambda>ptr. Heap_Error_Monad.bind (get_child_nodes ptr) (\<lambda>children. return (c \<in> set children)))"
have children_eq_True: "\<And>p. p \<in> set ptrs \<Longrightarrow> h \<turnstile> ?P p \<rightarrow>\<^sub>r True \<longleftrightarrow> h' \<turnstile> ?P p \<rightarrow>\<^sub>r True"
proof -
fix p
assume "p \<in> set ptrs"
then show "h \<turnstile> ?P p \<rightarrow>\<^sub>r True \<longleftrightarrow> h' \<turnstile> ?P p \<rightarrow>\<^sub>r True"
proof (cases "p = ptr")
case True
have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h)\<^sup>*"
using get_ancestors_parent_child_rel 1 assms by blast
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)"
proof (cases "cast c = ptr")
case True
then show ?thesis
using \<open>acyclic (parent_child_rel h)\<close> by(auto simp add: acyclic_def)
next
case False
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)\<^sup>*"
using \<open>acyclic (parent_child_rel h)\<close> False rtrancl_eq_or_trancl rtrancl_trancl_trancl
\<open>(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h)\<^sup>*\<close>
by (metis acyclic_def)
then show ?thesis
using r_into_rtrancl by auto
qed
obtain children where children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using type_wf
by (metis \<open>h' \<turnstile> ok get_ancestors ptr\<close> assms(1) get_ancestors_ptr_in_heap get_child_nodes_ok
heap_is_wellformed_def is_OK_returns_result_E known_ptrs local.known_ptrs_known_ptr
object_ptr_kinds_eq3)
then have "c \<notin> set children"
using \<open>(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)\<close> assms(1)
using parent_child_rel_child_nodes2
using child_parent_dual known_ptrs parent_child_rel_parent
type_wf by blast
with children have "h \<turnstile> ?P p \<rightarrow>\<^sub>r False"
by(auto simp add: True)
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h')\<^sup>*"
using get_ancestors_parent_child_rel assms(2) ancestors' 1 known_ptrs' type_wf
type_wf' by blast
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')"
proof (cases "cast c = ptr")
case True
then show ?thesis
using \<open>acyclic (parent_child_rel h')\<close> by(auto simp add: acyclic_def)
next
case False
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')\<^sup>*"
using \<open>acyclic (parent_child_rel h')\<close> False rtrancl_eq_or_trancl rtrancl_trancl_trancl
\<open>(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h')\<^sup>*\<close>
by (metis acyclic_def)
then show ?thesis
using r_into_rtrancl by auto
qed
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')"
using r_into_rtrancl by auto
obtain children' where children': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'"
using type_wf type_wf'
by (meson \<open>h' \<turnstile> ok (get_ancestors ptr)\<close> assms(2) get_ancestors_ptr_in_heap
get_child_nodes_ok is_OK_returns_result_E known_ptrs'
local.known_ptrs_known_ptr)
then have "c \<notin> set children'"
using \<open>(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')\<close> assms(2) type_wf type_wf'
using parent_child_rel_child_nodes2 child_parent_dual known_ptrs' parent_child_rel_parent
by auto
with children' have "h' \<turnstile> ?P p \<rightarrow>\<^sub>r False"
by(auto simp add: True)
ultimately show ?thesis
by (metis returns_result_eq)
next
case False
then show ?thesis
using children_eq ptrs
by (metis (no_types, lifting) bind_pure_returns_result_I bind_returns_result_E
get_child_nodes_pure return_returns_result)
qed
qed
have "\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))"
using assms(1) assms(2) object_ptr_kinds_eq ptrs type_wf type_wf'
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M bind_is_OK_pure_I
get_child_nodes_ok get_child_nodes_pure known_ptrs'
local.known_ptrs_known_ptr return_ok select_result_I2)
have children_eq_False:
"\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
proof
fix pa
assume "pa \<in> set ptrs"
and "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
have "h \<turnstile> ok (get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))
\<Longrightarrow> h' \<turnstile> ok ( get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))"
using \<open>pa \<in> set ptrs\<close> \<open>\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))\<close>
by auto
moreover have "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False
\<Longrightarrow> h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
by (metis (mono_tags, lifting) \<open>\<And>pa. pa \<in> set ptrs
\<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True\<close> \<open>pa \<in> set ptrs\<close>
calculation is_OK_returns_result_I returns_result_eq returns_result_select_result)
ultimately show "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
using \<open>h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False\<close>
by auto
next
fix pa
assume "pa \<in> set ptrs"
and "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
have "h' \<turnstile> ok (get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))
\<Longrightarrow> h \<turnstile> ok ( get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))"
using \<open>pa \<in> set ptrs\<close> \<open>\<And>pa. pa \<in> set ptrs
\<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))\<close>
by auto
moreover have "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False
\<Longrightarrow> h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
by (metis (mono_tags, lifting)
\<open>\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True\<close> \<open>pa \<in> set ptrs\<close>
calculation is_OK_returns_result_I returns_result_eq returns_result_select_result)
ultimately show "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
using \<open>h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False\<close> by blast
qed
have filter_eq: "\<And>xs. h \<turnstile> filter_M ?P ptrs \<rightarrow>\<^sub>r xs = h' \<turnstile> filter_M ?P ptrs \<rightarrow>\<^sub>r xs"
proof (rule filter_M_eq)
show
"\<And>xs x. pure (Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children))) h"
by(auto intro!: bind_pure_I)
next
show
"\<And>xs x. pure (Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children))) h'"
by(auto intro!: bind_pure_I)
next
fix xs b x
assume 0: "x \<in> set ptrs"
then show "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r b
= h' \<turnstile> Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r b"
apply(induct b)
using children_eq_True apply blast
using children_eq_False apply blast
done
qed
show "h \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt = h' \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt"
apply(simp add: get_parent_def)
apply(rule bind_cong_2)
apply(simp)
apply(simp)
apply(simp add: check_in_heap_def node_ptr_kinds_def object_ptr_kinds_eq3)
apply(rule bind_cong_2)
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(rule bind_cong_2)
apply(auto intro!: filter_M_pure_I bind_pure_I)[1]
apply(auto intro!: filter_M_pure_I bind_pure_I)[1]
apply(auto simp add: filter_eq (* dest!: returns_result_eq[OF ptrs] *))[1]
using filter_eq ptrs apply auto[1]
using filter_eq ptrs by auto
qed
have "ancestors = ancestors'"
proof(insert assms(1) assms(7) ancestors' 2, induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev)
case (step child)
show ?case
using step(2) step(3) step(4)
apply(simp add: get_ancestors_def)
apply(auto intro!: elim!: bind_returns_result_E2 split: option.splits)[1]
using returns_result_eq apply fastforce
apply (meson option.simps(3) returns_result_eq)
by (metis IntD1 IntD2 option.inject returns_result_eq step.hyps)
qed
then show ?thesis
using assms(5) ancestors'
by simp
qed
lemma get_ancestors_remains_not_in_ancestors:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'"
and "\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children' \<Longrightarrow> set children' \<subseteq> set children"
and "node \<notin> set ancestors"
and object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "node \<notin> set ancestors'"
proof -
have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
using object_ptr_kinds_eq3
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
show ?thesis
proof (insert assms(1) assms(3) assms(4) assms(6), induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev)
case (step child)
have 1: "\<And>p parent. h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent \<Longrightarrow> h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
proof -
fix p parent
assume "h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
then obtain children' where
children': "h' \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'" and
p_in_children': "p \<in> set children'"
using get_parent_child_dual by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(1) get_child_nodes_ptr_in_heap object_ptr_kinds_eq children'
known_ptrs
using type_wf type_wf'
by (metis \<open>h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent\<close> get_parent_parent_in_heap is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
have "p \<in> set children"
using assms(5) children children' p_in_children'
by blast
then show "h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
using child_parent_dual assms(1) children known_ptrs type_wf by blast
qed
have "node \<noteq> child"
using assms(1) get_ancestors_parent_child_rel step.prems(1) step.prems(3) known_ptrs
using type_wf type_wf'
by blast
then show ?case
using step(2) step(3)
apply(simp add: get_ancestors_def)
using step(4)
apply(auto elim!: bind_returns_result_E2 split: option.splits)[1]
using 1
apply (meson option.distinct(1) returns_result_eq)
by (metis "1" option.inject returns_result_eq step.hyps)
qed
qed
lemma get_ancestors_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
shows "ptr' |\<in>| object_ptr_kinds h"
proof (insert assms(4) assms(5), induct ancestors arbitrary: ptr)
case Nil
then show ?case
by(auto)
next
case (Cons a ancestors)
then obtain x where x: "h \<turnstile> get_ancestors x \<rightarrow>\<^sub>r a # ancestors"
by(auto simp add: get_ancestors_def[of a] elim!: bind_returns_result_E2 split: option.splits)
then have "x = a"
by(auto simp add: get_ancestors_def[of x] elim!: bind_returns_result_E2 split: option.splits)
then show ?case
using Cons.hyps Cons.prems(2) get_ancestors_ptr_in_heap x
by (metis assms(1) assms(2) assms(3) get_ancestors_obtains_children get_child_nodes_ptr_in_heap
is_OK_returns_result_I)
qed
lemma get_ancestors_prefix:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
assumes "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
shows "\<exists>pre. ancestors = pre @ ancestors'"
proof (insert assms(1) assms(5) assms(6), induct ptr' arbitrary: ancestors'
rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof (cases "parent \<noteq> ptr" )
case True
then obtain children ancestor_child where "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children" and "cast ancestor_child \<in> set ancestors"
using assms(1) assms(2) assms(3) assms(4) get_ancestors_obtains_children step.prems(1) by blast
then have "h \<turnstile> get_parent ancestor_child \<rightarrow>\<^sub>r Some parent"
using assms(1) assms(2) assms(3) child_parent_dual by blast
then have "h \<turnstile> get_ancestors (cast ancestor_child) \<rightarrow>\<^sub>r cast ancestor_child # ancestors'"
apply(simp add: get_ancestors_def)
using \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r ancestors'\<close> get_parent_ptr_in_heap
by(auto simp add: check_in_heap_def is_OK_returns_result_I intro!: bind_pure_returns_result_I)
then show ?thesis
using step(1) \<open>h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children\<close> \<open>ancestor_child \<in> set children\<close>
\<open>cast ancestor_child \<in> set ancestors\<close>
\<open>h \<turnstile> get_ancestors (cast ancestor_child) \<rightarrow>\<^sub>r cast ancestor_child # ancestors'\<close>
by fastforce
next
case False
then show ?thesis
by (metis append_Nil assms(4) returns_result_eq step.prems(2))
qed
qed
lemma get_ancestors_same_root_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
assumes "ptr'' \<in> set ancestors"
shows "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr \<longleftrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
proof -
have "ptr' |\<in>| object_ptr_kinds h"
by (metis assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_obtains_children
get_ancestors_ptr_in_heap get_child_nodes_ptr_in_heap is_OK_returns_result_I)
then obtain ancestors' where ancestors': "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
by (meson assms(1) assms(2) assms(3) get_ancestors_ok is_OK_returns_result_E)
then have "\<exists>pre. ancestors = pre @ ancestors'"
using get_ancestors_prefix assms by blast
moreover have "ptr'' |\<in>| object_ptr_kinds h"
by (metis assms(1) assms(2) assms(3) assms(4) assms(6) get_ancestors_obtains_children
get_ancestors_ptr_in_heap get_child_nodes_ptr_in_heap is_OK_returns_result_I)
then obtain ancestors'' where ancestors'': "h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''"
by (meson assms(1) assms(2) assms(3) get_ancestors_ok is_OK_returns_result_E)
then have "\<exists>pre. ancestors = pre @ ancestors''"
using get_ancestors_prefix assms by blast
ultimately show ?thesis
using ancestors' ancestors''
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I)[1]
apply (metis (no_types, lifting) assms(1) get_ancestors_never_empty last_appendR
returns_result_eq)
by (metis assms(1) get_ancestors_never_empty last_appendR returns_result_eq)
qed
lemma get_root_node_parent_same:
assumes "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
shows "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root \<longleftrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
proof
assume 1: " h \<turnstile> get_root_node (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r root"
show "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
using 1[unfolded get_root_node_def] assms
apply(simp add: get_ancestors_def)
apply(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)[1]
using returns_result_eq apply fastforce
using get_ancestors_ptr by fastforce
next
assume 1: " h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
show "h \<turnstile> get_root_node (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r root"
apply(simp add: get_root_node_def)
using assms 1
apply(simp add: get_ancestors_def)
apply(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)[1]
apply (simp add: check_in_heap_def is_OK_returns_result_I)
using get_ancestors_ptr get_parent_ptr_in_heap
apply (simp add: is_OK_returns_result_I)
by (meson list.distinct(1) list.set_cases local.get_ancestors_ptr)
qed
lemma get_root_node_same_no_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r cast child"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof (insert assms(1) assms(4), induct ptr rule: heap_wellformed_induct_rev)
case (step c)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r c")
case None
then have "c = cast child"
using step(2)
by(auto simp add: get_root_node_def get_ancestors_def[of c] elim!: bind_returns_result_E2)
then show ?thesis
using None by auto
next
case (Some child_node)
note s = this
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
by (metis (no_types, lifting) assms(2) assms(3) get_root_node_ptr_in_heap
is_OK_returns_result_I local.get_parent_ok node_ptr_casts_commute
node_ptr_kinds_commutes returns_result_select_result step.prems)
then show ?thesis
proof(induct parent_opt)
case None
then show ?case
using Some get_root_node_no_parent returns_result_eq step.prems by fastforce
next
case (Some parent)
then show ?case
using step s
apply(auto simp add: get_root_node_def get_ancestors_def[of c]
elim!: bind_returns_result_E2 split: option.splits list.splits)[1]
using get_root_node_parent_same step.hyps step.prems by auto
qed
qed
qed
lemma get_root_node_not_node_same:
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "\<not>is_node_ptr_kind ptr"
shows "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r ptr"
using assms
apply(simp add: get_root_node_def get_ancestors_def)
by(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)
lemma get_root_node_root_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
shows "root |\<in>| object_ptr_kinds h"
using assms
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
by (simp add: get_ancestors_never_empty get_ancestors_ptrs_in_heap)
lemma get_root_node_same_no_parent_parent_child_rel:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r ptr'"
shows "\<not>(\<exists>p. (p, ptr') \<in> (parent_child_rel h))"
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) get_root_node_same_no_parent
l_heap_is_wellformed.parent_child_rel_child local.child_parent_dual local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_heap_is_wellformed_axioms local.parent_child_rel_node_ptr
local.parent_child_rel_parent_in_heap node_ptr_casts_commute3 option.simps(3) returns_result_eq
returns_result_select_result)
end
locale l_get_ancestors_wf = l_heap_is_wellformed_defs + l_known_ptrs + l_type_wf + l_get_ancestors_defs
+ l_get_child_nodes_defs + l_get_parent_defs +
assumes get_ancestors_never_empty:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ancestors \<noteq> []"
assumes get_ancestors_ok:
"heap_is_wellformed h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (get_ancestors ptr)"
assumes get_ancestors_reads:
"heap_is_wellformed h \<Longrightarrow> reads get_ancestors_locs (get_ancestors node_ptr) h h'"
assumes get_ancestors_ptrs_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ptr' \<in> set ancestors
\<Longrightarrow> ptr' |\<in>| object_ptr_kinds h"
assumes get_ancestors_remains_not_in_ancestors:
"heap_is_wellformed h \<Longrightarrow> heap_is_wellformed h' \<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors
\<Longrightarrow> h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'
\<Longrightarrow> (\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children' \<subseteq> set children)
\<Longrightarrow> node \<notin> set ancestors
\<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> type_wf h' \<Longrightarrow> node \<notin> set ancestors'"
assumes get_ancestors_also_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors some_ptr \<rightarrow>\<^sub>r ancestors
\<Longrightarrow> cast child_node \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> type_wf h
\<Longrightarrow> known_ptrs h \<Longrightarrow> parent \<in> set ancestors"
assumes get_ancestors_obtains_children:
"heap_is_wellformed h \<Longrightarrow> ancestor \<noteq> ptr \<Longrightarrow> ancestor \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> (\<And>children ancestor_child . h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children
\<Longrightarrow> ancestor_child \<in> set children
\<Longrightarrow> cast ancestor_child \<in> set ancestors
\<Longrightarrow> thesis)
\<Longrightarrow> thesis"
assumes get_ancestors_parent_child_rel:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> (ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
locale l_get_root_node_wf = l_heap_is_wellformed_defs + l_get_root_node_defs + l_type_wf
+ l_known_ptrs + l_get_ancestors_defs + l_get_parent_defs +
assumes get_root_node_ok:
"heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h
\<Longrightarrow> h \<turnstile> ok (get_root_node ptr)"
assumes get_root_node_ptr_in_heap:
"h \<turnstile> ok (get_root_node ptr) \<Longrightarrow> ptr |\<in>| object_ptr_kinds h"
assumes get_root_node_root_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow> root |\<in>| object_ptr_kinds h"
assumes get_ancestors_same_root_node:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ptr' \<in> set ancestors
\<Longrightarrow> ptr'' \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr \<longleftrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
assumes get_root_node_same_no_parent:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r cast child \<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
assumes get_root_node_parent_same:
"h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr
\<Longrightarrow> h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root \<longleftrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
interpretation i_get_root_node_wf?:
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_parent get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
using instances
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed parent_child_rel known_ptr known_ptrs type_wf get_ancestors
get_ancestors_locs get_child_nodes get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def)[1]
using get_ancestors_never_empty apply blast
using get_ancestors_ok apply blast
using get_ancestors_reads apply blast
using get_ancestors_ptrs_in_heap apply blast
using get_ancestors_remains_not_in_ancestors apply blast
using get_ancestors_also_parent apply blast
using get_ancestors_obtains_children apply blast
using get_ancestors_parent_child_rel apply blast
using get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed get_root_node type_wf known_ptr known_ptrs
get_ancestors get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def)[1]
using get_root_node_ok apply blast
using get_root_node_ptr_in_heap apply blast
using get_root_node_root_in_heap apply blast
using get_ancestors_same_root_node apply(blast, blast)
using get_root_node_same_no_parent apply blast
using get_root_node_parent_same apply (blast, blast)
done
subsection \<open>to\_tree\_order\<close>
locale l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent +
l_get_parent_wf +
l_heap_is_wellformed
(* l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M *)
begin
lemma to_tree_order_ptr_in_heap:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> ok (to_tree_order ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
proof(insert assms(1) assms(4), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
apply(auto simp add: to_tree_order_def[of parent] map_M_pure_I elim!: bind_is_OK_E3)[1]
using get_child_nodes_ptr_in_heap by blast
qed
lemma to_tree_order_either_ptr_or_in_children:
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "node \<in> set nodes"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "node \<noteq> ptr"
obtains child child_to where "child \<in> set children"
and "h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r child_to" and "node \<in> set child_to"
proof -
obtain treeorders where treeorders: "h \<turnstile> map_M to_tree_order (map cast children) \<rightarrow>\<^sub>r treeorders"
using assms
apply(auto simp add: to_tree_order_def elim!: bind_returns_result_E)[1]
using pure_returns_heap_eq returns_result_eq by fastforce
then have "node \<in> set (concat treeorders)"
using assms[simplified to_tree_order_def]
by(auto elim!: bind_returns_result_E4 dest: pure_returns_heap_eq)
then obtain treeorder where "treeorder \<in> set treeorders"
and node_in_treeorder: "node \<in> set treeorder"
by auto
then obtain child where "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r treeorder"
and "child \<in> set children"
using assms[simplified to_tree_order_def] treeorders
by(auto elim!: map_M_pure_E2)
then show ?thesis
using node_in_treeorder returns_result_eq that by auto
qed
lemma to_tree_order_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
shows "ptr' |\<in>| object_ptr_kinds h"
proof(insert assms(1) assms(4) assms(5), induct ptr arbitrary: to rule: heap_wellformed_induct)
case (step parent)
have "parent |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) step.prems(1) to_tree_order_ptr_in_heap by blast
then obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then have "to = [parent]"
using step(2) children
apply(auto simp add: to_tree_order_def[of parent] map_M_pure_I elim!: bind_returns_result_E2)[1]
by (metis list.distinct(1) list.map_disc_iff list.set_cases map_M_pure_E2 returns_result_eq)
then show ?thesis
using \<open>parent |\<in>| object_ptr_kinds h\<close> step.prems(2) by auto
next
case False
note f = this
then show ?thesis
using children step to_tree_order_either_ptr_or_in_children
proof (cases "ptr' = parent")
case True
then show ?thesis
using \<open>parent |\<in>| object_ptr_kinds h\<close> by blast
next
case False
then show ?thesis
using children step.hyps to_tree_order_either_ptr_or_in_children
by (metis step.prems(1) step.prems(2))
qed
qed
qed
lemma to_tree_order_ok:
assumes wellformed: "heap_is_wellformed h"
and "ptr |\<in>| object_ptr_kinds h"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "h \<turnstile> ok (to_tree_order ptr)"
proof(insert assms(1) assms(2), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
using assms(3) type_wf
apply(simp add: to_tree_order_def)
apply(auto simp add: heap_is_wellformed_def intro!: map_M_ok_I bind_is_OK_pure_I map_M_pure_I)[1]
using get_child_nodes_ok known_ptrs_known_ptr apply blast
by (simp add: local.heap_is_wellformed_children_in_heap local.to_tree_order_def wellformed)
qed
lemma to_tree_order_child_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "node \<in> set children"
and "h \<turnstile> to_tree_order (cast node) \<rightarrow>\<^sub>r nodes'"
shows "set nodes' \<subseteq> set nodes"
proof
fix x
assume a1: "x \<in> set nodes'"
moreover obtain treeorders
where treeorders: "h \<turnstile> map_M to_tree_order (map cast children) \<rightarrow>\<^sub>r treeorders"
using assms(2) assms(3)
apply(auto simp add: to_tree_order_def elim!: bind_returns_result_E)[1]
using pure_returns_heap_eq returns_result_eq by fastforce
then have "nodes' \<in> set treeorders"
using assms(4) assms(5)
by(auto elim!: map_M_pure_E dest: returns_result_eq)
moreover have "set (concat treeorders) \<subseteq> set nodes"
using treeorders assms(2) assms(3)
by(auto simp add: to_tree_order_def elim!: bind_returns_result_E4 dest: pure_returns_heap_eq)
ultimately show "x \<in> set nodes"
by auto
qed
lemma to_tree_order_ptr_in_result:
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
shows "ptr \<in> set nodes"
using assms
apply(simp add: to_tree_order_def)
by(auto elim!: bind_returns_result_E2 intro!: map_M_pure_I bind_pure_I)
lemma to_tree_order_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "node \<in> set nodes"
and "h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "set nodes' \<subseteq> set nodes"
proof -
have "\<forall>nodes. h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<longrightarrow> (\<forall>node. node \<in> set nodes
\<longrightarrow> (\<forall>nodes'. h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<longrightarrow> set nodes' \<subseteq> set nodes))"
proof(insert assms(1), induct ptr rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof safe
fix nodes node nodes' x
assume 1: "(\<And>children child.
h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> \<forall>nodes. h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes
\<longrightarrow> (\<forall>node. node \<in> set nodes \<longrightarrow> (\<forall>nodes'. h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'
\<longrightarrow> set nodes' \<subseteq> set nodes)))"
and 2: "h \<turnstile> to_tree_order parent \<rightarrow>\<^sub>r nodes"
and 3: "node \<in> set nodes"
and "h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'"
and "x \<in> set nodes'"
have h1: "(\<And>children child nodes node nodes'.
h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes
\<longrightarrow> (node \<in> set nodes \<longrightarrow> (h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<longrightarrow> set nodes' \<subseteq> set nodes)))"
using 1
by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using 2
by(auto simp add: to_tree_order_def elim!: bind_returns_result_E)
then have "set nodes' \<subseteq> set nodes"
proof (cases "children = []")
case True
then show ?thesis
by (metis "2" "3" \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> children empty_iff list.set(1)
subsetI to_tree_order_either_ptr_or_in_children)
next
case False
then show ?thesis
proof (cases "node = parent")
case True
then show ?thesis
using "2" \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> returns_result_eq by fastforce
next
case False
then obtain child nodes_of_child where
"child \<in> set children" and
"h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes_of_child" and
"node \<in> set nodes_of_child"
using 2[simplified to_tree_order_def] 3
to_tree_order_either_ptr_or_in_children[where node=node and ptr=parent] children
apply(auto elim!: bind_returns_result_E2 intro: map_M_pure_I)[1]
using is_OK_returns_result_E 2 a_all_ptrs_in_heap_def assms(1) heap_is_wellformed_def
using "3" by blast
then have "set nodes' \<subseteq> set nodes_of_child"
using h1
using \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> children by blast
moreover have "set nodes_of_child \<subseteq> set nodes"
using "2" \<open>child \<in> set children\<close> \<open>h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes_of_child\<close>
assms children to_tree_order_child_subset by auto
ultimately show ?thesis
by blast
qed
qed
then show "x \<in> set nodes"
using \<open>x \<in> set nodes'\<close> by blast
qed
qed
then show ?thesis
using assms by blast
qed
lemma to_tree_order_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
assumes "parent \<in> set nodes"
shows "cast child \<in> set nodes"
proof -
obtain nodes' where nodes': "h \<turnstile> to_tree_order parent \<rightarrow>\<^sub>r nodes'"
using assms to_tree_order_ok get_parent_parent_in_heap
by (meson get_parent_parent_in_heap is_OK_returns_result_E)
then have "set nodes' \<subseteq> set nodes"
using to_tree_order_subset assms
by blast
moreover obtain children where
children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children" and
child: "child \<in> set children"
using assms get_parent_child_dual by blast
then obtain child_to where child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r child_to"
by (meson assms(1) assms(2) assms(3) assms(5) is_OK_returns_result_E is_OK_returns_result_I
get_parent_ptr_in_heap node_ptr_kinds_commutes to_tree_order_ok)
then have "cast child \<in> set child_to"
apply(simp add: to_tree_order_def)
by(auto elim!: bind_returns_result_E2 map_M_pure_E
dest!: bind_returns_result_E3[rotated, OF children, rotated] intro!: map_M_pure_I)
have "cast child \<in> set nodes'"
using nodes' child
apply(simp add: to_tree_order_def)
apply(auto elim!: bind_returns_result_E2 map_M_pure_E
dest!: bind_returns_result_E3[rotated, OF children, rotated] intro!: map_M_pure_I)[1]
using child_to \<open>cast child \<in> set child_to\<close> returns_result_eq by fastforce
ultimately show ?thesis
by auto
qed
lemma to_tree_order_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
assumes "cast child \<noteq> ptr"
assumes "child \<in> set children"
assumes "cast child \<in> set nodes"
shows "parent \<in> set nodes"
proof(insert assms(1) assms(4) assms(6) assms(8), induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"cast child \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
by (metis (full_types) assms(1) assms(2) assms(3) get_parent_ptr_in_heap
is_OK_returns_result_I l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.child_parent_dual
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_kinds_commutes
returns_result_select_result step.prems(1) step.prems(2) step.prems(3)
to_tree_order_either_ptr_or_in_children to_tree_order_ok)
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
show ?thesis
proof (cases "c = child")
case True
then have "parent = p"
using step(3) children child assms(5) assms(7)
by (meson assms(1) assms(2) assms(3) child_parent_dual option.inject returns_result_eq)
then show ?thesis
using step.prems(1) to_tree_order_ptr_in_result by blast
next
case False
then show ?thesis
using step(1)[OF children child child_to] step(3) step(4)
using \<open>set child_to \<subseteq> set nodes\<close>
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child \<in> set child_to\<close> by auto
qed
qed
qed
lemma to_tree_order_node_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "ptr' \<noteq> ptr"
assumes "ptr' \<in> set nodes"
shows "is_node_ptr_kind ptr'"
proof(insert assms(1) assms(4) assms(5) assms(6), induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"ptr' \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
using step.prems(1) step.prems(2) step.prems(3) to_tree_order_either_ptr_or_in_children by blast
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
show ?thesis
proof (cases "cast c = ptr")
case True
then show ?thesis
using step \<open>ptr' \<in> set child_to\<close> assms(5) child child_to children by blast
next
case False
then show ?thesis
using \<open>ptr' \<in> set child_to\<close> child child_to children is_node_ptr_kind_cast step.hyps by blast
qed
qed
qed
lemma to_tree_order_child2:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "cast child \<noteq> ptr"
assumes "cast child \<in> set nodes"
obtains parent where "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent" and "parent \<in> set nodes"
proof -
assume 1: "(\<And>parent. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent \<Longrightarrow> parent \<in> set nodes \<Longrightarrow> thesis)"
show thesis
proof(insert assms(1) assms(4) assms(5) assms(6) 1, induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"cast child \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
using step.prems(1) step.prems(2) step.prems(3) to_tree_order_either_ptr_or_in_children
by blast
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
have "cast child |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) assms(4) assms(6) to_tree_order_ptrs_in_heap by blast
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
by (meson assms(2) assms(3) is_OK_returns_result_E get_parent_ok node_ptr_kinds_commutes)
then show ?thesis
proof (induct parent_opt)
case None
then show ?case
by (metis \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child \<in> set child_to\<close> assms(1) assms(2) assms(3)
cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject child child_parent_dual child_to children
option.distinct(1) returns_result_eq step.hyps)
next
case (Some option)
then show ?case
by (meson assms(1) assms(2) assms(3) get_parent_child_dual step.prems(1) step.prems(2)
step.prems(3) step.prems(4) to_tree_order_child)
qed
qed
qed
qed
lemma to_tree_order_parent_child_rel:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
shows "(ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> child \<in> set to"
proof
assume 3: "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
show "child \<in> set to"
proof (insert 3, induct child rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4)
apply(simp add: to_tree_order_def)
by(auto simp add: map_M_pure_I elim!: bind_returns_result_E2)
next
case False
obtain child_parent where
"(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*" and
"(child_parent, child) \<in> (parent_child_rel h)"
using \<open>ptr \<noteq> child\<close>
by (metis "1.prems" rtranclE)
obtain child_node where child_node: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child"
using \<open>(child_parent, child) \<in> parent_child_rel h\<close> node_ptr_casts_commute3
parent_child_rel_node_ptr
by blast
then have "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some child_parent"
using \<open>(child_parent, child) \<in> (parent_child_rel h)\<close>
by (meson assms(1) assms(2) assms(3) is_OK_returns_result_E l_get_parent_wf.child_parent_dual
l_heap_is_wellformed.parent_child_rel_child local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_get_parent_wf_axioms
local.l_heap_is_wellformed_axioms local.parent_child_rel_parent_in_heap)
then show ?thesis
using 1(1) child_node \<open>(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*\<close>
using assms(1) assms(2) assms(3) assms(4) to_tree_order_parent by blast
qed
qed
next
assume "child \<in> set to"
then show "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
proof (induct child rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
then have "\<exists>parent. (parent, child) \<in> (parent_child_rel h)"
using 1(2) assms(4) to_tree_order_child2[OF assms(1) assms(2) assms(3) assms(4)]
to_tree_order_node_ptrs
by (metis assms(1) assms(2) assms(3) node_ptr_casts_commute3 parent_child_rel_parent)
then obtain child_node where child_node: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child"
using node_ptr_casts_commute3 parent_child_rel_node_ptr by blast
then obtain child_parent where child_parent: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some child_parent"
using \<open>\<exists>parent. (parent, child) \<in> (parent_child_rel h)\<close>
by (metis "1.prems" False assms(1) assms(2) assms(3) assms(4) to_tree_order_child2)
then have "(child_parent, child) \<in> (parent_child_rel h)"
using assms(1) child_node parent_child_rel_parent by blast
moreover have "child_parent \<in> set to"
by (metis "1.prems" False assms(1) assms(2) assms(3) assms(4) child_node child_parent
get_parent_child_dual to_tree_order_child)
then have "(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*"
using 1 child_node child_parent by blast
ultimately show ?thesis
by auto
qed
qed
qed
end
interpretation i_to_tree_order_wf?: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent
get_parent_locs heap_is_wellformed parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs
using instances
apply(simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
done
declare l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_to_tree_order_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_to_tree_order_defs
+ l_get_parent_defs + l_get_child_nodes_defs +
assumes to_tree_order_ok:
"heap_is_wellformed h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (to_tree_order ptr)"
assumes to_tree_order_ptrs_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> ptr' \<in> set to \<Longrightarrow> ptr' |\<in>| object_ptr_kinds h"
assumes to_tree_order_parent_child_rel:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> (ptr, child_ptr) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> child_ptr \<in> set to"
assumes to_tree_order_child2:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> cast child \<noteq> ptr \<Longrightarrow> cast child \<in> set nodes
\<Longrightarrow> (\<And>parent. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent
\<Longrightarrow> parent \<in> set nodes \<Longrightarrow> thesis)
\<Longrightarrow> thesis"
assumes to_tree_order_node_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> ptr' \<noteq> ptr \<Longrightarrow> ptr' \<in> set nodes \<Longrightarrow> is_node_ptr_kind ptr'"
assumes to_tree_order_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow> cast child \<noteq> ptr
\<Longrightarrow> child \<in> set children \<Longrightarrow> cast child \<in> set nodes
\<Longrightarrow> parent \<in> set nodes"
assumes to_tree_order_ptr_in_result:
"h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<Longrightarrow> ptr \<in> set nodes"
assumes to_tree_order_parent:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent \<Longrightarrow> parent \<in> set nodes
\<Longrightarrow> cast child \<in> set nodes"
assumes to_tree_order_subset:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<Longrightarrow> node \<in> set nodes
\<Longrightarrow> h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> set nodes' \<subseteq> set nodes"
lemma to_tree_order_wf_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
using instances
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def)[1]
using to_tree_order_ok
apply blast
using to_tree_order_ptrs_in_heap
apply blast
using to_tree_order_parent_child_rel
apply(blast, blast)
using to_tree_order_child2
apply blast
using to_tree_order_node_ptrs
apply blast
using to_tree_order_child
apply blast
using to_tree_order_ptr_in_result
apply blast
using to_tree_order_parent
apply blast
using to_tree_order_subset
apply blast
done
subsubsection \<open>get\_root\_node\<close>
locale l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_to_tree_order_wf
begin
lemma to_tree_order_get_root_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
assumes "ptr'' \<in> set to"
shows "h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
proof -
obtain ancestors' where ancestors': "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_ok is_OK_returns_result_E
to_tree_order_ptrs_in_heap )
moreover have "ptr \<in> set ancestors'"
using \<open>h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'\<close>
using assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_parent_child_rel
to_tree_order_parent_child_rel by blast
ultimately have "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr\<close>
using assms(1) assms(2) assms(3) get_ancestors_ptr get_ancestors_same_root_node by blast
obtain ancestors'' where ancestors'': "h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''"
by (meson assms(1) assms(2) assms(3) assms(4) assms(7) get_ancestors_ok is_OK_returns_result_E
to_tree_order_ptrs_in_heap)
moreover have "ptr \<in> set ancestors''"
using \<open>h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''\<close>
using assms(1) assms(2) assms(3) assms(4) assms(7) get_ancestors_parent_child_rel
to_tree_order_parent_child_rel by blast
ultimately show ?thesis
using \<open>h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr\<close> assms(1) assms(2) assms(3) get_ancestors_ptr
get_ancestors_same_root_node by blast
qed
lemma to_tree_order_same_root:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
assumes "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
shows "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
proof (insert assms(1)(* assms(4) assms(5) *) assms(6), induct ptr' rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
proof (cases "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child")
case True
then have "child = root_ptr"
using assms(1) assms(2) assms(3) assms(5) step.prems
by (metis (no_types, lifting) get_root_node_same_no_parent node_ptr_casts_commute3
option.simps(3) returns_result_eq to_tree_order_child2 to_tree_order_node_ptrs)
then show ?thesis
using True by blast
next
case False
then obtain child_node parent where "cast child_node = child"
and "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
by (metis assms(1) assms(2) assms(3) assms(4) assms(5) local.get_root_node_no_parent
local.get_root_node_not_node_same local.get_root_node_same_no_parent
local.to_tree_order_child2 local.to_tree_order_ptrs_in_heap node_ptr_casts_commute3
step.prems)
then show ?thesis
proof (cases "child = root_ptr")
case True
then have "h \<turnstile> get_root_node root_ptr \<rightarrow>\<^sub>r root_ptr"
using assms(4)
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child\<close> assms(1) assms(2) assms(3)
get_root_node_no_parent get_root_node_same_no_parent
by blast
then show ?thesis
using step assms(4)
using True by blast
next
case False
then have "parent \<in> set to"
using assms(5) step(2) to_tree_order_child \<open>h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent\<close>
\<open>cast child_node = child\<close>
by (metis False assms(1) assms(2) assms(3) get_parent_child_dual)
then show ?thesis
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child\<close> \<open>h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent\<close>
get_root_node_parent_same
using step.hyps by blast
qed
qed
qed
end
interpretation i_to_tree_order_wf_get_root_node_wf?: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs to_tree_order
using instances
by(simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
locale l_to_tree_order_wf_get_root_node_wf = l_type_wf + l_known_ptrs + l_to_tree_order_defs
+ l_get_root_node_defs + l_heap_is_wellformed_defs +
assumes to_tree_order_get_root_node:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> ptr' \<in> set to \<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr
\<Longrightarrow> ptr'' \<in> set to \<Longrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
assumes to_tree_order_same_root:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr
\<Longrightarrow> h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r to \<Longrightarrow> ptr' \<in> set to
\<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
lemma to_tree_order_wf_get_root_node_wf_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf type_wf known_ptr known_ptrs to_tree_order
get_root_node heap_is_wellformed"
using instances
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def
l_to_tree_order_wf_get_root_node_wf_axioms_def)[1]
using to_tree_order_get_root_node apply blast
using to_tree_order_same_root apply blast
done
subsection \<open>get\_owner\_document\<close>
locale l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_known_ptrs
+ l_heap_is_wellformed
+ l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_ancestors
+ l_get_ancestors_wf
+ l_get_parent
+ l_get_parent_wf
+ l_get_root_node_wf
+ l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_owner_document_disconnected_nodes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
assumes known_ptrs: "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
proof -
have 2: "node_ptr |\<in>| node_ptr_kinds h"
using assms heap_is_wellformed_disc_nodes_in_heap
by blast
have 3: "document_ptr |\<in>| document_ptr_kinds h"
using assms(2) get_disconnected_nodes_ptr_in_heap by blast
have 0:
"\<exists>!document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by (metis (no_types, lifting) "3" DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) assms(2) assms(3)
disjoint_iff_not_equal l_heap_is_wellformed.heap_is_wellformed_one_disc_parent
local.get_disconnected_nodes_ok local.l_heap_is_wellformed_axioms
returns_result_select_result select_result_I2 type_wf)
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
using heap_is_wellformed_children_disc_nodes_different child_parent_dual assms
using "2" disjoint_iff_not_equal local.get_parent_child_dual local.get_parent_ok
returns_result_select_result split_option_ex
by (metis (no_types, lifting))
then have 4: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using 2 get_root_node_no_parent
by blast
obtain document_ptrs where document_ptrs: "h \<turnstile> document_ptr_kinds_M \<rightarrow>\<^sub>r document_ptrs"
by simp
then
have "h \<turnstile> ok (filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs)"
using assms(1) get_disconnected_nodes_ok type_wf unfolding heap_is_wellformed_def
by(auto intro!: bind_is_OK_I2 filter_M_is_OK_I bind_pure_I)
then obtain candidates where
candidates: "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r candidates"
by auto
have eq: "\<And>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<Longrightarrow> node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r \<longleftrightarrow> |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}|\<^sub>r"
apply(auto dest!: get_disconnected_nodes_ok[OF type_wf]
intro!: select_result_I[where P=id, simplified] elim!: bind_returns_result_E2)[1]
apply(drule select_result_E[where P=id, simplified])
by(auto elim!: bind_returns_result_E2)
have filter: "filter (\<lambda>document_ptr. |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \<in> cast ` set disconnected_nodes)
}|\<^sub>r) document_ptrs = [document_ptr]"
apply(rule filter_ex1)
using 0 document_ptrs apply(simp)[1]
using eq
using local.get_disconnected_nodes_ok apply auto[1]
using assms(2) assms(3)
apply(auto intro!: intro!: select_result_I[where P=id, simplified]
elim!: bind_returns_result_E2)[1]
using returns_result_eq apply fastforce
using document_ptrs 3 apply(simp)
using document_ptrs
by simp
have "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r [document_ptr]"
apply(rule filter_M_filter2)
using get_disconnected_nodes_ok document_ptrs 3 assms(1) type_wf filter
unfolding heap_is_wellformed_def
by(auto intro: bind_pure_I bind_is_OK_I2)
with 4 document_ptrs have "h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r document_ptr"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I
split: option.splits)[1]
moreover have "known_ptr (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)"
using "4" assms(1) known_ptrs type_wf known_ptrs_known_ptr "2" node_ptr_kinds_commutes by blast
ultimately show ?thesis
using 2
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto split: option.splits intro!: bind_pure_returns_result_I)
qed
lemma in_disconnected_nodes_no_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
and "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document"
and "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
have 2: "cast node_ptr |\<in>| object_ptr_kinds h"
using assms(3) get_owner_document_ptr_in_heap by fast
then have 3: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using assms(2) local.get_root_node_no_parent by blast
have "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
apply(auto)[1]
using assms(2) child_parent_dual[OF assms(1)] type_wf
assms(1) assms(5) get_child_nodes_ok known_ptrs_known_ptr option.simps(3)
returns_result_eq returns_result_select_result
by (metis (no_types, opaque_lifting))
moreover have "node_ptr |\<in>| node_ptr_kinds h"
using assms(2) get_parent_ptr_in_heap by blast
ultimately
have 0: "\<exists>document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by (metis DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) finite_set_in heap_is_wellformed_children_disc_nodes)
then obtain document_ptr where
document_ptr: "document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r" and
node_ptr_in_disc_nodes: "node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by auto
then show ?thesis
using get_owner_document_disconnected_nodes known_ptrs type_wf assms
using DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) assms(3) assms(4) get_disconnected_nodes_ok
returns_result_select_result select_result_I2
by (metis (no_types, opaque_lifting) )
qed
lemma get_owner_document_owner_document_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
using assms
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_split_asm)+
proof -
assume "h \<turnstile> invoke [] ptr () \<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by (meson invoke_empty is_OK_returns_result_I)
next
assume "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())
\<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: if_splits)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then obtain root where
root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using 4 5 root
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using "0" "1" "2" document_ptr_kinds_commutes local.get_root_node_root_in_heap by blast
next
case False
have "known_ptr root"
using "0" "1" "2" local.get_root_node_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using "0" "1" "2" local.get_root_node_root_in_heap
by blast
then have "is_node_ptr_kind root"
using False \<open>known_ptr root\<close>
apply(simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h).
root \<in> cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
by (metis (no_types, lifting) "0" "1" "2" \<open>root |\<in>| object_ptr_kinds h\<close> local.child_parent_dual
local.get_child_nodes_ok local.get_root_node_same_no_parent local.heap_is_wellformed_children_disc_nodes
local.known_ptrs_known_ptr node_ptr_casts_commute3 node_ptr_inclusion node_ptr_kinds_commutes notin_fset
option.distinct(1) returns_result_eq returns_result_select_result root)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) "1" bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure notin_fset
return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
apply (simp add: \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>)
using "1" \<open>root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
\<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
local.get_disconnected_nodes_ok by auto
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using 5 root 4
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then obtain root where
root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using 3 4 root
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using "0" "1" "2" document_ptr_kinds_commutes local.get_root_node_root_in_heap by blast
next
case False
have "known_ptr root"
using "0" "1" "2" local.get_root_node_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using "0" "1" "2" local.get_root_node_root_in_heap
by blast
then have "is_node_ptr_kind root"
using False \<open>known_ptr root\<close>
apply(simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). root \<in>
cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
by (metis (no_types, lifting) "0" "1" "2" \<open>root |\<in>| object_ptr_kinds h\<close>
local.child_parent_dual local.get_child_nodes_ok local.get_root_node_same_no_parent
local.heap_is_wellformed_children_disc_nodes local.known_ptrs_known_ptr node_ptr_casts_commute3
node_ptr_inclusion node_ptr_kinds_commutes notin_fset option.distinct(1) returns_result_eq
returns_result_select_result root)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) "1" bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure notin_fset
return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
by (simp add: "1" local.get_disconnected_nodes_ok)
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using 4 root 3
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
qed
lemma get_owner_document_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_owner_document ptr)"
proof -
have "known_ptr ptr"
using assms(2) assms(4) local.known_ptrs_known_ptr
by blast
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(auto simp add: known_ptr_impl)[1]
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_element_ptr
apply blast
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply (metis (no_types, lifting) document_ptr_casts_commute3 document_ptr_kinds_commutes
is_document_ptr_kind_none option.case_eq_if)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply (metis (no_types, lifting) assms(1) assms(2) assms(3) is_node_ptr_kind_none
local.get_root_node_ok node_ptr_casts_commute3 option.case_eq_if)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply(auto split: option.splits
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I)[1]
using assms(3) local.get_disconnected_nodes_ok
apply blast
apply (simp add: assms(1) assms(2) assms(3) local.get_root_node_ok)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply(auto split: option.splits
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I)[1]
apply (simp add: assms(1) assms(2) assms(3) local.get_root_node_ok)[1]
apply(auto split: option.splits
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I)[1]
using assms(3) local.get_disconnected_nodes_ok by blast
qed
lemma get_owner_document_child_same:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_child_nodes_ptr_in_heap)
then have "known_ptr ptr"
using assms(2) local.known_ptrs_known_ptr by blast
have "cast child |\<in>| object_ptr_kinds h"
using assms(1) assms(4) assms(5) local.heap_is_wellformed_children_in_heap node_ptr_kinds_commutes
by blast
then
have "known_ptr (cast child)"
using assms(2) local.known_ptrs_known_ptr by blast
obtain root where root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_root_node_ok)
then have "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root"
using assms(1) assms(2) assms(3) assms(4) assms(5) local.child_parent_dual
local.get_root_node_parent_same
by blast
have "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr ptr")
case True
then obtain document_ptr where document_ptr: "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr = ptr"
using case_optionE document_ptr_casts_commute by blast
then have "root = cast document_ptr"
using root
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have "h \<turnstile> a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using document_ptr
\<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast document_ptr\<close> document_ptr]
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>
[simplified \<open>root = cast document_ptr\<close> document_ptr], rotated]
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I
split: if_splits option.splits)[1]
using \<open>ptr |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
by blast
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> True
by(auto simp add: document_ptr[symmetric]
intro!: bind_pure_returns_result_I
split: option.splits)
next
case False
then obtain node_ptr where node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = ptr"
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
then have "h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using root \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>
unfolding a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
by (meson bind_pure_returns_result_I bind_returns_result_E3 local.get_root_node_pure)
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply (meson invoke_empty is_OK_returns_result_I)
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
by(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
qed
then show ?thesis
using \<open>known_ptr (cast child)\<close>
apply(auto simp add: get_owner_document_def[of "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child"]
a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
by (smt (verit) \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child |\<in>| object_ptr_kinds h\<close> cast_document_ptr_not_node_ptr(1)
comp_apply invoke_empty invoke_not invoke_returns_result is_OK_returns_result_I
node_ptr_casts_commute2 option.sel)
qed
end
locale l_get_owner_document_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_get_disconnected_nodes_defs + l_get_owner_document_defs
+ l_get_parent_defs +
assumes get_owner_document_disconnected_nodes:
"heap_is_wellformed h \<Longrightarrow>
known_ptrs h \<Longrightarrow>
type_wf h \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
node_ptr \<in> set disc_nodes \<Longrightarrow>
h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
assumes in_disconnected_nodes_no_parent:
"heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None\<Longrightarrow>
h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
known_ptrs h \<Longrightarrow>
type_wf h\<Longrightarrow>
node_ptr \<in> set disc_nodes"
assumes get_owner_document_owner_document_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow>
h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<Longrightarrow>
owner_document |\<in>| document_ptr_kinds h"
assumes get_owner_document_ok:
"heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h
\<Longrightarrow> h \<turnstile> ok (get_owner_document ptr)"
interpretation i_get_owner_document_wf?: l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr known_ptrs type_wf heap_is_wellformed parent_child_rel get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs get_owner_document
by(auto simp add: l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_wf_is_l_get_owner_document_wf [instances]:
"l_get_owner_document_wf heap_is_wellformed type_wf known_ptr known_ptrs get_disconnected_nodes
get_owner_document get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_owner_document_wf_def l_get_owner_document_wf_axioms_def)[1]
using get_owner_document_disconnected_nodes apply fast
using in_disconnected_nodes_no_parent apply fast
using get_owner_document_owner_document_in_heap apply fast
using get_owner_document_ok apply fast
done
subsubsection \<open>get\_root\_node\<close>
locale l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node_wf +
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf
begin
lemma get_root_node_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
assumes "is_document_ptr_kind root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r the (cast root)"
proof -
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_result_I local.get_root_node_ptr_in_heap)
then have "known_ptr ptr"
using assms(3) local.known_ptrs_known_ptr by blast
{
assume "is_document_ptr_kind ptr"
then have "ptr = root"
using assms(4)
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have ?thesis
using \<open>is_document_ptr_kind ptr\<close> \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I
split: option.splits)
}
moreover
{
assume "is_node_ptr_kind ptr"
then have ?thesis
using \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
apply(auto split: option.splits)[1]
using \<open>h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root\<close> assms(5)
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def
intro!: bind_pure_returns_result_I
split: option.splits)[2]
}
ultimately
show ?thesis
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
qed
lemma get_root_node_same_owner_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_root_node_ptr_in_heap)
have "root |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_root_in_heap by blast
have "known_ptr ptr"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
have "known_ptr root"
using \<open>root |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
show ?thesis
proof (cases "is_document_ptr_kind ptr")
case True
then
have "ptr = root"
using assms(4)
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
by (metis document_ptr_casts_commute3 last_ConsL local.get_ancestors_not_node
node_ptr_no_document_ptr_cast)
then show ?thesis
by auto
next
case False
then have "is_node_ptr_kind ptr"
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
then obtain node_ptr where node_ptr: "ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"
by (metis node_ptr_casts_commute3)
show ?thesis
proof
assume "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
using node_ptr
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto elim!: bind_returns_result_E2 split: option.splits)
show "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
have "is_document_ptr root"
using True \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
have "root = cast owner_document"
using True
by (metis \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3) assms(4)
document_ptr_casts_commute3 get_root_node_document returns_result_eq)
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root\<close> apply blast
using \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_node_ptr_kind_none)
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> assms(4)
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis assms(1) assms(2) assms(3) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq)
using \<open>is_node_ptr_kind root\<close> node_ptr returns_result_eq by fastforce
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_node_ptr_kind root\<close> \<open>known_ptr root\<close>
apply(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
apply(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: root_node_ptr)
qed
next
assume "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
show "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
have "root = cast owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
apply(auto simp add: True a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: if_splits)[1]
apply (metis True cast_document_ptr_not_node_ptr(2) is_document_ptr_kind_obtains
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
by (metis True cast_document_ptr_not_node_ptr(1) document_ptr_casts_commute3
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) get_root_node_document
by fastforce
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto simp add: is_document_ptr_kind_none elim!: bind_returns_result_E2)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq root_node_ptr
by fastforce+
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using node_ptr \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
intro!: bind_pure_returns_result_I split: option.splits)
qed
qed
qed
qed
end
interpretation get_owner_document_wf_get_root_node_wf?: l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs heap_is_wellformed parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs get_owner_document
by(auto simp add: l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_owner_document_wf_get_root_node_wf = l_heap_is_wellformed_defs + l_type_wf +
l_known_ptrs + l_get_root_node_defs + l_get_owner_document_defs +
assumes get_root_node_document:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow>
is_document_ptr_kind root \<Longrightarrow> h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r the (cast root)"
assumes get_root_node_same_owner_document:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow>
h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
lemma get_owner_document_wf_get_root_node_wf_is_l_get_owner_document_wf_get_root_node_wf [instances]:
"l_get_owner_document_wf_get_root_node_wf heap_is_wellformed type_wf known_ptr known_ptrs
get_root_node get_owner_document"
apply(auto simp add: l_get_owner_document_wf_get_root_node_wf_def
l_get_owner_document_wf_get_root_node_wf_axioms_def instances)[1]
using get_root_node_document apply blast
using get_root_node_same_owner_document apply (blast, blast)
done
subsection \<open>Preserving heap-wellformedness\<close>
subsection \<open>set\_attribute\<close>
locale l_set_attribute_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_attribute_get_disconnected_nodes +
l_set_attribute_get_child_nodes
begin
lemma set_attribute_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> set_attribute element_ptr k v \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
thm preserves_wellformedness_writes_needed
apply(rule preserves_wellformedness_writes_needed[OF assms set_attribute_writes])
using set_attribute_get_child_nodes
apply(fast)
using set_attribute_get_disconnected_nodes apply(fast)
by(auto simp add: all_args_def set_attribute_locs_def)
end
subsection \<open>remove\_child\<close>
locale l_remove_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_set_disconnected_nodes_get_child_nodes
begin
lemma remove_child_removes_parent:
assumes wellformed: "heap_is_wellformed h"
and remove_child: "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h2"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "h2 \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof -
obtain children where children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using remove_child remove_child_def by auto
then have "child \<in> set children"
using remove_child remove_child_def
by(auto elim!: bind_returns_heap_E dest: returns_result_eq split: if_splits)
then have h1: "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
using assms(1) known_ptrs type_wf child_parent_dual
by (meson child_parent_dual children option.inject returns_result_eq)
have known_ptr: "known_ptr ptr"
using known_ptrs
by (meson is_OK_returns_heap_I l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms
remove_child remove_child_ptr_in_heap)
obtain owner_document disc_nodes h' where
owner_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document" and
disc_nodes: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h': "h \<turnstile> set_disconnected_nodes owner_document (child # disc_nodes) \<rightarrow>\<^sub>h h'" and
h2: "h' \<turnstile> set_child_nodes ptr (remove1 child children) \<rightarrow>\<^sub>h h2"
using assms children unfolding remove_child_def
apply(auto split: if_splits elim!: bind_returns_heap_E)[1]
by (metis (full_types) get_child_nodes_pure get_disconnected_nodes_pure
get_owner_document_pure pure_returns_heap_eq returns_result_eq)
have "object_ptr_kinds h = object_ptr_kinds h2"
using remove_child_writes remove_child unfolding remove_child_locs_def
apply(rule writes_small_big)
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
then have "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
unfolding object_ptr_kinds_M_defs by simp
have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF remove_child_writes remove_child] unfolding remove_child_locs_def
using set_disconnected_nodes_types_preserved set_child_nodes_types_preserved type_wf
apply(auto simp add: reflp_def transp_def)[1]
by blast
then obtain children' where children': "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'"
using h2 set_child_nodes_get_child_nodes known_ptr
by (metis \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> children get_child_nodes_ok
get_child_nodes_ptr_in_heap is_OK_returns_result_E is_OK_returns_result_I)
have "child \<notin> set children'"
by (metis (mono_tags, lifting) \<open>type_wf h'\<close> children children' distinct_remove1_removeAll h2
known_ptr local.heap_is_wellformed_children_distinct
local.set_child_nodes_get_child_nodes member_remove remove_code(1) select_result_I2
wellformed)
moreover have "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
proof -
fix other_ptr other_children
assume a1: "other_ptr \<noteq> ptr" and a3: "h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
have "h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
using get_child_nodes_reads set_disconnected_nodes_writes h' a3
apply(rule reads_writes_separate_backwards)
using set_disconnected_nodes_get_child_nodes by fast
show "child \<notin> set other_children"
using \<open>h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children\<close> a1 h1 by blast
qed
then have "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
proof -
fix other_ptr other_children
assume a1: "other_ptr \<noteq> ptr" and a3: "h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
have "h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
using get_child_nodes_reads set_child_nodes_writes h2 a3
apply(rule reads_writes_separate_backwards)
using set_disconnected_nodes_get_child_nodes a1 set_child_nodes_get_child_nodes_different_pointers
by metis
then show "child \<notin> set other_children"
using \<open>\<And>other_ptr other_children. \<lbrakk>other_ptr \<noteq> ptr; h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children\<rbrakk>
\<Longrightarrow> child \<notin> set other_children\<close> a1 by blast
qed
ultimately have ha: "\<And>other_ptr other_children. h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children
\<Longrightarrow> child \<notin> set other_children"
by (metis (full_types) children' returns_result_eq)
moreover obtain ptrs where ptrs: "h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by (simp add: object_ptr_kinds_M_defs)
moreover have "\<And>ptr. ptr \<in> set ptrs \<Longrightarrow> h2 \<turnstile> ok (get_child_nodes ptr)"
using \<open>type_wf h2\<close> ptrs get_child_nodes_ok known_ptr
using \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> known_ptrs local.known_ptrs_known_ptr by auto
ultimately show "h2 \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
apply(auto simp add: get_parent_def intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I)[1]
proof -
have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child |\<in>| object_ptr_kinds h"
using get_owner_document_ptr_in_heap owner_document by blast
then show "h2 \<turnstile> check_in_heap (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r ()"
by (simp add: \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> check_in_heap_def)
next
show "(\<And>other_ptr other_children. h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children
\<Longrightarrow> child \<notin> set other_children) \<Longrightarrow>
ptrs = sorted_list_of_set (fset (object_ptr_kinds h2)) \<Longrightarrow>
(\<And>ptr. ptr |\<in>| object_ptr_kinds h2 \<Longrightarrow> h2 \<turnstile> ok get_child_nodes ptr) \<Longrightarrow>
h2 \<turnstile> filter_M (\<lambda>ptr. Heap_Error_Monad.bind (get_child_nodes ptr)
(\<lambda>children. return (child \<in> set children))) (sorted_list_of_set (fset (object_ptr_kinds h2))) \<rightarrow>\<^sub>r []"
by(auto intro!: filter_M_empty_I bind_pure_I)
qed
qed
end
locale l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_child_parent_child_rel_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "parent_child_rel h' \<subseteq> parent_child_rel h"
proof (standard, safe)
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure]
split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_eq: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
using node_ptr_kinds_M_eq by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
using document_ptr_kinds_M_eq by auto
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow>
h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children =h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq:
"\<And>document_ptr disconnected_nodes. document_ptr \<noteq> owner_document
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_child_nodes_get_disconnected_nodes set_disconnected_nodes_get_disconnected_nodes_different_pointers
by (metis (no_types, lifting) Un_iff owner_document select_result_I2)
then have disconnected_nodes_eq2:
"\<And>document_ptr. document_ptr \<noteq> owner_document
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes
h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes
h2]
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_child_nodes_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(2) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply(simp)
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
fix parent child
assume a1: "(parent, child) \<in> parent_child_rel h'"
then show "(parent, child) \<in> parent_child_rel h"
proof (cases "parent = ptr")
case True
then show ?thesis
using a1 remove_child_removes_parent[OF assms(1) assms(2)] children_h children_h'
get_child_nodes_ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_eq )[1]
by (metis notin_set_remove1)
next
case False
then show ?thesis
using a1
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq3 children_eq2)
qed
qed
lemma remove_child_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure] split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_eq: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
using node_ptr_kinds_M_eq by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
using document_ptr_kinds_M_eq by auto
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow>
h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq: "\<And>document_ptr disconnected_nodes. document_ptr \<noteq> owner_document
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_child_nodes_get_disconnected_nodes set_disconnected_nodes_get_disconnected_nodes_different_pointers
by (metis (no_types, lifting) Un_iff owner_document select_result_I2)
then have disconnected_nodes_eq2:
"\<And>document_ptr. document_ptr \<noteq> owner_document
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes
h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
show "known_ptrs h'"
using object_ptr_kinds_eq3 known_ptrs_preserved \<open>known_ptrs h\<close> by blast
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_child_nodes_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(2) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply simp
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
have disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using owner_document assms(2) h2 disconnected_nodes_h
apply (auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E2)
apply(auto split: if_splits)[1]
apply(simp)
by(auto simp add: local.set_disconnected_nodes_get_disconnected_nodes split: if_splits)
then have disconnected_nodes_h': "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
apply(rule reads_writes_separate_forwards[OF get_disconnected_nodes_reads set_child_nodes_writes h'])
by (simp add: set_child_nodes_get_disconnected_nodes)
moreover have "a_acyclic_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
proof (standard, safe)
fix parent child
assume a1: "(parent, child) \<in> parent_child_rel h'"
then show "(parent, child) \<in> parent_child_rel h"
proof (cases "parent = ptr")
case True
then show ?thesis
using a1 remove_child_removes_parent[OF assms(1) assms(2)] children_h children_h'
get_child_nodes_ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_eq )[1]
by (metis imageI notin_set_remove1)
next
case False
then show ?thesis
using a1
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq3 children_eq2)
qed
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3 disconnected_nodes_eq)[1]
apply (metis (no_types, lifting) \<open>type_wf h'\<close> assms(2) assms(3) local.get_child_nodes_ok
local.known_ptrs_known_ptr local.remove_child_children_subset notin_fset object_ptr_kinds_eq3
returns_result_select_result subset_code(1) type_wf)
apply (metis (no_types, lifting) assms(2) disconnected_nodes_eq2 disconnected_nodes_h
disconnected_nodes_h' document_ptr_kinds_eq3 finite_set_in local.remove_child_child_in_heap
node_ptr_kinds_eq3 select_result_I2 set_ConsD subset_code(1))
done
moreover have "a_owner_document_valid h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def object_ptr_kinds_eq3 document_ptr_kinds_eq3
node_ptr_kinds_eq3)[1]
proof -
fix node_ptr
assume 0: "\<forall>node_ptr\<in>fset (node_ptr_kinds h'). (\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h' \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
and 1: "node_ptr |\<in>| node_ptr_kinds h'"
and 2: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<longrightarrow>
node_ptr \<notin> set |h' \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
then show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h'
\<and> node_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
proof (cases "node_ptr = child")
case True
show ?thesis
apply(rule exI[where x=owner_document])
using children_eq2 disconnected_nodes_eq2 children_h children_h' disconnected_nodes_h' True
by (metis (no_types, lifting) get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I
list.set_intros(1) select_result_I2)
next
case False
then show ?thesis
using 0 1 2 children_eq2 children_h children_h' disconnected_nodes_eq2 disconnected_nodes_h
disconnected_nodes_h'
apply(auto simp add: children_eq2 disconnected_nodes_eq2 dest!: select_result_I2)[1]
by (metis children_eq2 disconnected_nodes_eq2 finite_set_in in_set_remove1 list.set_intros(2))
qed
qed
moreover
{
have h0: "a_distinct_lists h"
using assms(1) by (simp add: heap_is_wellformed_def)
moreover have ha1: "(\<Union>x\<in>set |h \<turnstile> object_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
using \<open>a_distinct_lists h\<close>
unfolding a_distinct_lists_def
by(auto)
have ha2: "ptr |\<in>| object_ptr_kinds h"
using children_h get_child_nodes_ptr_in_heap by blast
have ha3: "child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
using child_in_children_h children_h
by(simp)
have child_not_in: "\<And>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<Longrightarrow> child \<notin> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using ha1 ha2 ha3
apply(simp)
using IntI by fastforce
moreover have "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: object_ptr_kinds_M_defs)
moreover have "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: document_ptr_kinds_M_defs)
ultimately have "a_distinct_lists h'"
proof(simp (no_asm) add: a_distinct_lists_def, safe)
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
have 4: "distinct (concat ((map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)))"
using 1 by(auto simp add: a_distinct_lists_def)
show "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 3[unfolded object_ptr_kinds_eq2], simplified])
fix x
assume 5: "x |\<in>| object_ptr_kinds h'"
then have 6: "distinct |h \<turnstile> get_child_nodes x|\<^sub>r"
using 4 distinct_concat_map_E object_ptr_kinds_eq2 by fastforce
obtain children where children: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children"
and distinct_children: "distinct children"
by (metis "5" "6" type_wf assms(3) get_child_nodes_ok local.known_ptrs_known_ptr
object_ptr_kinds_eq3 select_result_I)
obtain children' where children': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
then have "distinct children'"
proof (cases "ptr = x")
case True
then show ?thesis
using children distinct_children children_h children_h'
by (metis children' distinct_remove1 returns_result_eq)
next
case False
then show ?thesis
using children distinct_children children_eq[OF False]
using children' distinct_lists_children h0
using select_result_I2 by fastforce
qed
then show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
using children' by(auto simp add: )
next
fix x y
assume 5: "x |\<in>| object_ptr_kinds h'" and 6: "y |\<in>| object_ptr_kinds h'" and 7: "x \<noteq> y"
obtain children_x where children_x: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x"
by (metis "5" type_wf assms(3) get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_y where children_y: "h \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y"
by (metis "6" type_wf assms(3) get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_x' where children_x': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x'"
using children_eq children_h' children_x by fastforce
obtain children_y' where children_y': "h' \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y'"
using children_eq children_h' children_y by fastforce
have "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r))"
using h0 by(auto simp add: a_distinct_lists_def)
then have 8: "set children_x \<inter> set children_y = {}"
using "7" assms(1) children_x children_y local.heap_is_wellformed_one_parent by blast
have "set children_x' \<inter> set children_y' = {}"
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
by(simp add: 7)
have "children_x' = remove1 child children_x"
using children_h children_h' children_x children_x' True returns_result_eq by fastforce
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
have "children_y' = remove1 child children_y"
using children_h children_h' children_y children_y' True returns_result_eq by fastforce
moreover have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 by simp
qed
qed
then show "set |h' \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_child_nodes y|\<^sub>r = {}"
using children_x' children_y'
by (metis (no_types, lifting) select_result_I2)
qed
next
assume 2: "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
then have 4: "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by simp
have 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
using h0
by(simp add: a_distinct_lists_def document_ptr_kinds_eq3)
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 4[unfolded document_ptr_kinds_eq3]])
fix x
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 5: "distinct |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_lists_disconnected_nodes[OF h0] 4 get_disconnected_nodes_ok
by (simp add: type_wf document_ptr_kinds_eq3 select_result_I)
show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "x = owner_document")
case True
have "child \<notin> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using child_not_in document_ptr_kinds_eq2 "4" by fastforce
moreover have "|h' \<turnstile> get_disconnected_nodes x|\<^sub>r = child # |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using disconnected_nodes_h' disconnected_nodes_h unfolding True
by(simp)
ultimately show ?thesis
using 5 unfolding True
by simp
next
case False
show ?thesis
using "5" False disconnected_nodes_eq2 by auto
qed
next
fix x y
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and 5: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))" and "x \<noteq> y"
obtain disc_nodes_x where disc_nodes_x: "h \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y where disc_nodes_y: "h \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of y] document_ptr_kinds_eq2
by auto
obtain disc_nodes_x' where disc_nodes_x': "h' \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x'"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y' where disc_nodes_y': "h' \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y'"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of y] document_ptr_kinds_eq2
by auto
have "distinct
(concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using h0 by (simp add: a_distinct_lists_def)
then have 6: "set disc_nodes_x \<inter> set disc_nodes_y = {}"
using \<open>x \<noteq> y\<close> assms(1) disc_nodes_x disc_nodes_y local.heap_is_wellformed_one_disc_parent
by blast
have "set disc_nodes_x' \<inter> set disc_nodes_y' = {}"
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using \<open>x \<noteq> y\<close> by simp
then have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y'
by auto
have "disc_nodes_x' = child # disc_nodes_x"
using disconnected_nodes_h' disc_nodes_x disc_nodes_x' True disconnected_nodes_h
returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_y"
using child_not_in disc_nodes_y 5
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_x' = child # disc_nodes_x\<close> \<open>disc_nodes_y' = disc_nodes_y\<close>)
using 6 by auto
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x'
by auto
have "disc_nodes_y' = child # disc_nodes_y"
using disconnected_nodes_h' disc_nodes_y disc_nodes_y' True disconnected_nodes_h
returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_x"
using child_not_in disc_nodes_x 4
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_y' = child # disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
next
case False
have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x'
by auto
have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y'
by auto
then show ?thesis
apply(unfold \<open>disc_nodes_y' = disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
qed
qed
then show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using disc_nodes_x' disc_nodes_y' by auto
qed
next
fix x xa xb
assume 1: "xa \<in> fset (object_ptr_kinds h')"
and 2: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 3: "xb \<in> fset (document_ptr_kinds h')"
and 4: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
obtain disc_nodes where disc_nodes: "h \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain disc_nodes' where disc_nodes': "h' \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes'"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain children where children: "h \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children"
by (metis "1" type_wf assms(3) finite_set_in get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children' where children': "h' \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
have "\<And>x. x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r \<Longrightarrow> x \<in> set |h \<turnstile> get_disconnected_nodes xb|\<^sub>r \<Longrightarrow> False"
using 1 3
apply(fold \<open> object_ptr_kinds h = object_ptr_kinds h'\<close>)
apply(fold \<open> document_ptr_kinds h = document_ptr_kinds h'\<close>)
using children disc_nodes h0 apply(auto simp add: a_distinct_lists_def)[1]
by (metis (no_types, lifting) h0 local.distinct_lists_no_parent select_result_I2)
then have 5: "\<And>x. x \<in> set children \<Longrightarrow> x \<in> set disc_nodes \<Longrightarrow> False"
using children disc_nodes by fastforce
have 6: "|h' \<turnstile> get_child_nodes xa|\<^sub>r = children'"
using children' by simp
have 7: "|h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = disc_nodes'"
using disc_nodes' by simp
have "False"
proof (cases "xa = ptr")
case True
have "distinct children_h"
using children_h distinct_lists_children h0 \<open>known_ptr ptr\<close> by blast
have "|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h"
using children_h'
by simp
have "children = children_h"
using True children children_h by auto
show ?thesis
using disc_nodes' children' 5 2 4 children_h \<open>distinct children_h\<close> disconnected_nodes_h'
apply(auto simp add: 6 7
\<open>xa = ptr\<close> \<open>|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h\<close> \<open>children = children_h\<close>)[1]
by (metis (no_types, lifting) disc_nodes disconnected_nodes_eq2 disconnected_nodes_h
select_result_I2 set_ConsD)
next
case False
have "children' = children"
using children' children children_eq[OF False[symmetric]]
by auto
then show ?thesis
proof (cases "xb = owner_document")
case True
then show ?thesis
using disc_nodes disconnected_nodes_h disconnected_nodes_h'
using "2" "4" "5" "6" "7" False \<open>children' = children\<close> assms(1) child_in_children_h
child_parent_dual children children_h disc_nodes' get_child_nodes_ptr_in_heap
list.set_cases list.simps(3) option.simps(1) returns_result_eq set_ConsD
by (metis (no_types, opaque_lifting) assms(3) type_wf)
next
case False
then show ?thesis
using "2" "4" "5" "6" "7" \<open>children' = children\<close> disc_nodes disc_nodes'
disconnected_nodes_eq returns_result_eq
by metis
qed
qed
then show "x \<in> {}"
by simp
qed
}
ultimately show "heap_is_wellformed h'"
using heap_is_wellformed_def by blast
qed
lemma remove_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
using assms
by(auto simp add: remove_def intro: remove_child_heap_is_wellformed_preserved
elim!: bind_returns_heap_E2 split: option.splits)
lemma remove_child_removes_child:
assumes wellformed: "heap_is_wellformed h"
and remove_child: "h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h'"
and children: "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "child \<notin> set children"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr' (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure]
split: if_splits)[1]
using pure_returns_heap_eq
by fastforce
have "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes remove_child])
unfolding remove_child_locs_def
using set_child_nodes_pointers_preserved set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
moreover have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes assms(2)]
using set_child_nodes_types_preserved set_disconnected_nodes_types_preserved type_wf
unfolding remove_child_locs_def
apply(auto simp add: reflp_def transp_def)[1]
by blast
ultimately show ?thesis
using remove_child_removes_parent remove_child_heap_is_wellformed_preserved child_parent_dual
by (meson children known_ptrs local.known_ptrs_preserved option.distinct(1) remove_child
returns_result_eq type_wf wellformed)
qed
lemma remove_child_removes_first_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
assumes "h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
obtain h2 disc_nodes owner_document where
"h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document" and
"h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (node_ptr # disc_nodes) \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'"
using assms(5)
apply(auto simp add: remove_child_def
dest!: bind_returns_heap_E3[rotated, OF assms(4) get_child_nodes_pure, rotated])[1]
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated,OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])
have "known_ptr ptr"
by (meson assms(3) assms(4) is_OK_returns_result_I get_child_nodes_ptr_in_heap known_ptrs_known_ptr)
moreover have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes h2 assms(4)])
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
moreover have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h2]
using \<open>type_wf h\<close> set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
ultimately show ?thesis
using set_child_nodes_get_child_nodes\<open>h2 \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'\<close>
by fast
qed
lemma remove_removes_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
assumes "h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some ptr"
using child_parent_dual assms by fastforce
show ?thesis
using assms remove_child_removes_first_child
by(auto simp add: remove_def
dest!: bind_returns_heap_E3[rotated, OF \<open>h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some ptr\<close>, rotated]
bind_returns_heap_E3[rotated, OF assms(4) get_child_nodes_pure, rotated])
qed
lemma remove_for_all_empty_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using assms
proof(induct children arbitrary: h h')
case Nil
then show ?case
by simp
next
case (Cons a children)
have "h \<turnstile> get_parent a \<rightarrow>\<^sub>r Some ptr"
using child_parent_dual Cons by fastforce
with Cons show ?case
proof(auto elim!: bind_returns_heap_E)[1]
fix h2
assume 0: "(\<And>h h'. heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r [])"
and 1: "heap_is_wellformed h"
and 2: "type_wf h"
and 3: "known_ptrs h"
and 4: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r a # children"
and 5: "h \<turnstile> get_parent a \<rightarrow>\<^sub>r Some ptr"
and 7: "h \<turnstile> remove a \<rightarrow>\<^sub>h h2"
and 8: "h2 \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h'"
then have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using remove_removes_child by blast
moreover have "heap_is_wellformed h2"
using 7 1 2 3 remove_child_heap_is_wellformed_preserved(3)
by(auto simp add: remove_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
split: option.splits)
moreover have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_writes 7]
using \<open>type_wf h\<close> remove_child_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
moreover have "object_ptr_kinds h = object_ptr_kinds h2"
using 7
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have "known_ptrs h2"
using 3 known_ptrs_preserved by blast
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using 0 8 by fast
qed
qed
end
locale l_remove_child_wf2 = l_type_wf + l_known_ptrs + l_remove_child_defs + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_remove_defs +
assumes remove_child_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes remove_child_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes remove_child_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
assumes remove_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes remove_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes remove_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
assumes remove_child_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> child \<notin> set children"
assumes remove_child_removes_first_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children
\<Longrightarrow> h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes remove_removes_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children
\<Longrightarrow> h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes remove_for_all_empty_children:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
interpretation i_remove_child_wf2?: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs get_parent get_parent_locs get_owner_document
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel
by unfold_locales
lemma remove_child_wf2_is_l_remove_child_wf2 [instances]:
"l_remove_child_wf2 type_wf known_ptr known_ptrs remove_child heap_is_wellformed get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using remove_child_heap_is_wellformed_preserved apply(fast, fast, fast)
using remove_heap_is_wellformed_preserved apply(fast, fast, fast)
using remove_child_removes_child apply fast
using remove_child_removes_first_child apply fast
using remove_removes_child apply fast
using remove_for_all_empty_children apply fast
done
subsection \<open>adopt\_node\<close>
locale l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_heap_is_wellformed
begin
lemma adopt_node_removes_first_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children"
shows "h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> do { remove_child parent node }
| None \<Rightarrow> do { return ()}) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node # disc_nodes)
} else do { return () }) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have "h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h2 remove_child_removes_first_child assms(1) assms(2) assms(3) assms(5)
by (metis list.set_intros(1) local.child_parent_dual option.simps(5) parent_opt returns_result_eq)
then
show ?thesis
using h'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
dest!: reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes]
split: if_splits)
qed
lemma adopt_node_document_in_heap:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> ok (adopt_node owner_document node)"
shows "owner_document |\<in>| document_ptr_kinds h"
proof -
obtain old_document parent_opt h2 h' where
old_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> do { remove_child parent node } | None \<Rightarrow> do { return ()}) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node # disc_nodes)
} else do { return () }) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: adopt_node_def
elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
using old_document get_owner_document_owner_document_in_heap assms(1) assms(2) assms(3)
by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes where
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 node old_disc_nodes) \<rightarrow>\<^sub>h h3" and
old_disc_nodes: "h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h': "h3 \<turnstile> set_disconnected_nodes owner_document (node # disc_nodes) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "owner_document |\<in>| document_ptr_kinds h3"
by (meson is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap)
moreover have "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
moreover have "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
ultimately show ?thesis
by(auto simp add: document_ptr_kinds_def)
qed
qed
end
locale l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_removes_child_step:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2"
and children: "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<notin> set children"
proof -
obtain old_document parent_opt h' where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h': "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return () ) \<rightarrow>\<^sub>h h'"
using adopt_node get_parent_pure
by(auto simp add: adopt_node_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: if_splits)
then have "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using adopt_node
apply(auto simp add: adopt_node_def
dest!: bind_returns_heap_E3[rotated, OF old_document, rotated]
bind_returns_heap_E3[rotated, OF parent_opt, rotated]
elim!: bind_returns_heap_E4[rotated, OF h', rotated])[1]
apply(auto split: if_splits
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
apply (simp add: set_disconnected_nodes_get_child_nodes children
reads_writes_preserved[OF get_child_nodes_reads set_disconnected_nodes_writes])
using children by blast
show ?thesis
proof(insert parent_opt h', induct parent_opt)
case None
then show ?case
using child_parent_dual wellformed known_ptrs type_wf
\<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> returns_result_eq
by fastforce
next
case (Some option)
then show ?case
using remove_child_removes_child \<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> known_ptrs type_wf
wellformed
by auto
qed
qed
lemma adopt_node_removes_child:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
shows "\<And>ptr' children'.
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> node_ptr \<notin> set children'"
using adopt_node_removes_child_step assms by blast
lemma adopt_node_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document"
and
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have object_ptr_kinds_h_eq3: "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "type_wf h2"
using h2 remove_child_preserves_type_wf known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "known_ptrs h2"
using h2 remove_child_preserves_known_ptrs known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
proof(cases "document_ptr = old_document")
case True
then show ?thesis
using h' wellformed_h2 \<open>type_wf h2\<close> \<open>known_ptrs h2\<close> by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes_document_ptr_h3 where
docs_neq: "document_ptr \<noteq> old_document" and
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3" and
disc_nodes_document_ptr_h3:
"h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes_document_ptr_h3) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2:
"\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h3_eq3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h3: "node_ptr_kinds h3 = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
have children_eq_h3:
"\<And>ptr children. h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. old_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
obtain disc_nodes_old_document_h2 where disc_nodes_old_document_h2:
"h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
using old_disc_nodes by blast
then have disc_nodes_old_document_h3:
"h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
using h3 old_disc_nodes returns_result_eq set_disconnected_nodes_get_disconnected_nodes
by fastforce
have "distinct disc_nodes_old_document_h2"
using disc_nodes_old_document_h2 local.heap_is_wellformed_disconnected_nodes_distinct wellformed_h2
by blast
have "type_wf h2"
proof (insert h2, induct parent_opt)
case None
then show ?case
using type_wf by simp
next
case (Some option)
then show ?case
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes]
type_wf remove_child_types_preserved
by (simp add: reflp_def transp_def)
qed
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have "known_ptrs h3"
using known_ptrs local.known_ptrs_preserved object_ptr_kinds_h2_eq3 object_ptr_kinds_h_eq3
by blast
then have "known_ptrs h'"
using local.known_ptrs_preserved object_ptr_kinds_h3_eq3 by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2:
"h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
using disconnected_nodes_eq_h2 docs_neq disc_nodes_document_ptr_h3 by auto
have disc_nodes_document_ptr_h': "
h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
using h' disc_nodes_document_ptr_h3
using set_disconnected_nodes_get_disconnected_nodes by blast
have document_ptr_in_heap: "document_ptr |\<in>| document_ptr_kinds h2"
using disc_nodes_document_ptr_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using disc_nodes_document_ptr_h2 get_disconnected_nodes_ptr_in_heap by blast
have old_document_in_heap: "old_document |\<in>| document_ptr_kinds h2"
using disc_nodes_old_document_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using get_disconnected_nodes_ptr_in_heap old_disc_nodes by blast
have "child \<in> set disc_nodes_old_document_h2"
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h2"
by(auto)
moreover have "a_owner_document_valid h"
using assms(1) heap_is_wellformed_def by(simp add: heap_is_wellformed_def)
ultimately show ?case
using old_document disc_nodes_old_document_h2 None(1) child_parent_dual[OF assms(1)]
in_disconnected_nodes_no_parent assms(1) known_ptrs type_wf by blast
next
case (Some option)
then show ?case
apply(simp split: option.splits)
using assms(1) disc_nodes_old_document_h2 old_document remove_child_in_disconnected_nodes
known_ptrs
by blast
qed
have "child \<notin> set (remove1 child disc_nodes_old_document_h2)"
using disc_nodes_old_document_h3 h3 known_ptrs wellformed_h2 \<open>distinct disc_nodes_old_document_h2\<close>
by auto
have "child \<notin> set disc_nodes_document_ptr_h3"
proof -
have "a_distinct_lists h2"
using heap_is_wellformed_def wellformed_h2 by blast
then have 0: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r))"
by(simp add: a_distinct_lists_def)
show ?thesis
using distinct_concat_map_E(1)[OF 0] \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h2 disc_nodes_document_ptr_h2
by (meson \<open>type_wf h2\<close> docs_neq known_ptrs local.get_owner_document_disconnected_nodes
local.known_ptrs_preserved object_ptr_kinds_h_eq3 returns_result_eq wellformed_h2)
qed
have child_in_heap: "child |\<in>| node_ptr_kinds h"
using get_owner_document_ptr_in_heap[OF is_OK_returns_result_I[OF old_document]]
node_ptr_kinds_commutes by blast
have "a_acyclic_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h2"
using object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 children_eq2_h2 children_eq2_h3
mem_Collect_eq object_ptr_kinds_M_eq_h3 select_result_eq split_cong
unfolding parent_child_rel_def
by(simp)
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h2\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h2 children_eq_h2)[1]
apply (simp add: children_eq2_h2 object_ptr_kinds_h2_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> \<open>type_wf h2\<close>
disc_nodes_old_document_h2 disc_nodes_old_document_h3 disconnected_nodes_eq2_h2
document_ptr_kinds_eq3_h2 in_set_remove1 local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2 returns_result_select_result
select_result_I2 wellformed_h2)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h3 children_eq_h3)[1]
apply (simp add: children_eq2_h3 object_ptr_kinds_h3_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2 disc_nodes_old_document_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq3_h3 finite_set_in
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
select_result_I2 set_ConsD subset_code(1) wellformed_h2)
moreover have "a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(simp add: a_owner_document_valid_def node_ptr_kinds_eq_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 children_eq2_h2 children_eq2_h3 )
by (smt (verit) disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2
disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_in_heap
document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 in_set_remove1
list.set_intros(1) list.set_intros(2) node_ptr_kinds_eq3_h2
node_ptr_kinds_eq3_h3 object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3
select_result_I2)
have a_distinct_lists_h2: "a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h3 object_ptr_kinds_eq_h2
children_eq2_h2 children_eq2_h3)[1]
proof -
assume 1: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 3: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I)
show "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by(auto simp add: document_ptr_kinds_M_def )
next
fix x
assume a1: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 4: "distinct |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a_distinct_lists_h2 "2" a1 concat_map_all_distinct document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3
by fastforce
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "old_document \<noteq> x")
case True
then show ?thesis
proof (cases "document_ptr \<noteq> x")
case True
then show ?thesis
using disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>]
disconnected_nodes_eq2_h3[OF \<open>document_ptr \<noteq> x\<close>] 4
by(auto)
next
case False
then show ?thesis
using disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' 4
\<open>child \<notin> set disc_nodes_document_ptr_h3\<close>
by(auto simp add: disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>] )
qed
next
case False
then show ?thesis
by (metis (no_types, opaque_lifting) \<open>distinct disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h3 disconnected_nodes_eq2_h3
distinct_remove1 docs_neq select_result_I2)
qed
next
fix x y
assume a0: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a1: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a2: "x \<noteq> y"
moreover have 5: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using 2 calculation
by (auto simp add: document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 dest: distinct_concat_map_E(1))
ultimately show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
proof(cases "old_document = x")
case True
have "old_document \<noteq> y"
using \<open>x \<noteq> y\<close> \<open>old_document = x\<close> by simp
have "document_ptr \<noteq> x"
using docs_neq \<open>old_document = x\<close> by auto
show ?thesis
proof(cases "document_ptr = y")
case True
then show ?thesis
using 5 True select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document = x\<close>
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
\<open>document_ptr \<noteq> x\<close> disconnected_nodes_eq2_h3 disjoint_iff_not_equal
notin_set_remove1 set_ConsD)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 \<open>old_document = x\<close>
docs_neq \<open>old_document \<noteq> y\<close>
by (metis (no_types, lifting) disjoint_iff_not_equal notin_set_remove1)
qed
next
case False
then show ?thesis
proof(cases "old_document = y")
case True
then show ?thesis
proof(cases "document_ptr = x")
case True
show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr = x\<close>
apply(simp)
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr \<noteq> x\<close>
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal docs_neq notin_set_remove1)
qed
next
case False
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
by (metis DocumentMonad.ptr_kinds_M_ok DocumentMonad.ptr_kinds_M_ptr_kinds False
\<open>type_wf h2\<close> a1 disc_nodes_old_document_h2 document_ptr_kinds_M_def
document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
wellformed_h2)
then show ?thesis
proof(cases "document_ptr = x")
case True
then have "document_ptr \<noteq> y"
using \<open>x \<noteq> y\<close> by auto
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
using \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by blast
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document \<noteq> y\<close> \<open>document_ptr = x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
\<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by(auto)
next
case False
then show ?thesis
proof(cases "document_ptr = y")
case True
have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set disc_nodes_document_ptr_h3 = {}"
using 2 a1 document_ptr_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>document_ptr \<noteq> x\<close> select_result_I2[OF disc_nodes_document_ptr_h3, symmetric]
disconnected_nodes_eq2_h2[OF docs_neq[symmetric], symmetric]
by (simp add: "5" True)
moreover have f1:
"set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = {}"
using 2 a1 old_document_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>old_document \<noteq> x\<close>
by (metis (no_types, lifting) a0 distinct_concat_map_E(1) document_ptr_kinds_eq3_h2
- document_ptr_kinds_eq3_h3 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ document_ptr_kinds_eq3_h3 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
ultimately show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr = y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by auto
next
case False
then show ?thesis
using 5
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close>
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
by (metis \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
empty_iff inf.idem)
qed
qed
qed
qed
qed
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show False
using \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 old_document_in_heap
apply(auto)[1]
apply(cases "xb = old_document")
proof -
assume a1: "xb = old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a3: "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
assume a4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a5: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f6: "old_document |\<in>| document_ptr_kinds h'"
using a1 \<open>xb |\<in>| document_ptr_kinds h'\<close> by blast
have f7: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a2 by simp
have "x \<in> set disc_nodes_old_document_h2"
using f6 a3 a1 by (metis (no_types) \<open>type_wf h'\<close> \<open>x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close>
disconnected_nodes_eq_h3 docs_neq get_disconnected_nodes_ok returns_result_eq
returns_result_select_result set_remove1_subset subsetCE)
then have "set |h' \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using f7 f6 a5 a4 \<open>xa |\<in>| object_ptr_kinds h'\<close>
by fastforce
then show ?thesis
using \<open>x \<in> set disc_nodes_old_document_h2\<close> a1 a4 f7 by blast
next
assume a1: "xb \<noteq> old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
assume a3: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a4: "xa |\<in>| object_ptr_kinds h'"
assume a5: "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
assume a6: "old_document |\<in>| document_ptr_kinds h'"
assume a7: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume a8: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume a9: "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a10: "\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a11: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a12: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f13: "\<And>d. d \<notin> set |h' \<turnstile> document_ptr_kinds_M|\<^sub>r \<or> h2 \<turnstile> ok get_disconnected_nodes d"
using a9 \<open>type_wf h2\<close> get_disconnected_nodes_ok
by simp
then have f14: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a6 a3 by simp
have "x \<notin> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
using a12 a8 a4 \<open>xb |\<in>| document_ptr_kinds h'\<close>
- by (meson UN_I disjoint_iff_not_equal fmember.rep_eq)
+ by (meson UN_I disjoint_iff_not_equal fmember_iff_member_fset)
then have "x = child"
using f13 a11 a10 a7 a5 a2 a1
by (metis (no_types, lifting) select_result_I2 set_ConsD)
then have "child \<notin> set disc_nodes_old_document_h2"
using f14 a12 a8 a6 a4
by (metis \<open>type_wf h'\<close> adopt_node_removes_child assms(1) assms(2) type_wf
get_child_nodes_ok known_ptrs local.known_ptrs_known_ptr object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3 returns_result_select_result)
then show ?thesis
using \<open>child \<in> set disc_nodes_old_document_h2\<close> by fastforce
qed
qed
ultimately show ?thesis
using \<open>type_wf h'\<close> \<open>known_ptrs h'\<close> \<open>a_owner_document_valid h'\<close> heap_is_wellformed_def by blast
qed
then show "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
by auto
qed
lemma adopt_node_node_in_disconnected_nodes:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
and "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node_ptr old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node_ptr # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h'"
using h2 h' by(auto)
then show ?case
using in_disconnected_nodes_no_parent assms None old_document by blast
next
case (Some parent)
then show ?case
using remove_child_in_disconnected_nodes known_ptrs True h' assms(3) old_document by auto
qed
next
case False
then show ?thesis
using assms(3) h' list.set_intros(1) select_result_I2 set_disconnected_nodes_get_disconnected_nodes
apply(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
proof -
fix x and h'a and xb
assume a1: "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assume a2: "\<And>h document_ptr disc_nodes h'. h \<turnstile> set_disconnected_nodes document_ptr disc_nodes \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume "h'a \<turnstile> set_disconnected_nodes owner_document (node_ptr # xb) \<rightarrow>\<^sub>h h'"
then have "node_ptr # xb = disc_nodes"
using a2 a1 by (meson returns_result_eq)
then show ?thesis
by (meson list.set_intros(1))
qed
qed
qed
end
interpretation i_adopt_node_wf?: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs known_ptr
type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs
remove heap_is_wellformed parent_child_rel
by(simp add: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
interpretation i_adopt_node_wf2?: l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs known_ptr
type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs
remove heap_is_wellformed parent_child_rel get_root_node get_root_node_locs
by(simp add: l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_adopt_node_wf = l_heap_is_wellformed + l_known_ptrs + l_type_wf + l_adopt_node_defs
+ l_get_child_nodes_defs + l_get_disconnected_nodes_defs +
assumes adopt_node_preserves_wellformedness:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> heap_is_wellformed h'"
assumes adopt_node_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2
\<Longrightarrow> h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> node_ptr \<notin> set children"
assumes adopt_node_node_in_disconnected_nodes:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> node_ptr \<in> set disc_nodes"
assumes adopt_node_removes_first_child: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
assumes adopt_node_document_in_heap: "heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (adopt_node owner_document node)
\<Longrightarrow> owner_document |\<in>| document_ptr_kinds h"
assumes adopt_node_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> type_wf h'"
assumes adopt_node_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h'"
lemma adopt_node_wf_is_l_adopt_node_wf [instances]:
"l_adopt_node_wf type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes known_ptrs adopt_node"
using heap_is_wellformed_is_l_heap_is_wellformed known_ptrs_is_l_known_ptrs
apply(auto simp add: l_adopt_node_wf_def l_adopt_node_wf_axioms_def)[1]
using adopt_node_preserves_wellformedness apply blast
using adopt_node_removes_child apply blast
using adopt_node_node_in_disconnected_nodes apply blast
using adopt_node_removes_first_child apply blast
using adopt_node_document_in_heap apply blast
using adopt_node_preserves_wellformedness apply blast
using adopt_node_preserves_wellformedness apply blast
done
subsection \<open>insert\_before\<close>
locale l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_wf +
l_set_disconnected_nodes_get_child_nodes +
l_heap_is_wellformed
begin
lemma insert_before_removes_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "ptr \<noteq> ptr'"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children"
shows "h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
proof -
obtain owner_document h2 h3 disc_nodes reference_child where
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
"h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disc_nodes) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: if_splits option.splits)
have "h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h2 adopt_node_removes_first_child assms(1) assms(2) assms(3) assms(6)
by simp
then have "h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h3
by(auto simp add: set_disconnected_nodes_get_child_nodes
dest!: reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes])
then show ?thesis
using h' assms(4)
apply(auto simp add: a_insert_node_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated])[1]
by(auto simp add: set_child_nodes_get_child_nodes_different_pointers
elim!: reads_writes_separate_forwards[OF get_child_nodes_reads set_child_nodes_writes])
qed
end
locale l_insert_before_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_insert_before_defs + l_get_child_nodes_defs +
assumes insert_before_removes_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> ptr \<noteq> ptr'
\<Longrightarrow> h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
interpretation i_insert_before_wf?: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs
get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_ancestors get_ancestors_locs
adopt_node adopt_node_locs set_disconnected_nodes
set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before
insert_before_locs append_child type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel
by(simp add: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf_is_l_insert_before_wf [instances]:
"l_insert_before_wf heap_is_wellformed type_wf known_ptr known_ptrs insert_before get_child_nodes"
apply(auto simp add: l_insert_before_wf_def l_insert_before_wf_axioms_def instances)[1]
using insert_before_removes_child apply fast
done
locale l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_disconnected_nodes +
l_remove_child +
l_get_root_node_wf +
l_set_disconnected_nodes_get_disconnected_nodes_wf +
l_set_disconnected_nodes_get_ancestors +
l_get_ancestors_wf +
l_get_owner_document +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf
begin
lemma insert_before_preserves_acyclitity:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
shows "acyclic (parent_child_rel h')"
proof -
obtain ancestors reference_child owner_document h2 h3
disconnected_nodes_h2
where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node
else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document
\<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document
(remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I assms
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using assms adopt_node_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have "known_ptrs h2"
using assms object_ptr_kinds_M_eq3_h known_ptrs_preserved by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF assms(1) h2] assms by simp
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have "known_ptrs h3"
using object_ptr_kinds_M_eq3_h2 known_ptrs_preserved \<open>known_ptrs h2\<close> by blast
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3:
"|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
have "known_ptrs h'"
using object_ptr_kinds_M_eq3_h' known_ptrs_preserved \<open>known_ptrs h3\<close> by blast
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> owner_document
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3:
"h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr'
\<Longrightarrow> h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3:
"\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children:
"\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using assms h2 adopt_node_removes_child by auto
have "node \<in> set disconnected_nodes_h2"
using disconnected_nodes_h2 h2 adopt_node_node_in_disconnected_nodes assms(1)
\<open>type_wf h\<close> \<open>known_ptrs h\<close> by blast
have node_not_in_disconnected_nodes:
"\<And>d. d |\<in>| document_ptr_kinds h3 \<Longrightarrow> node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof -
fix d
assume "d |\<in>| document_ptr_kinds h3"
show "node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof (cases "d = owner_document")
case True
then show ?thesis
using disconnected_nodes_h2 wellformed_h2 h3 remove_from_disconnected_nodes_removes
wellformed_h2 \<open>d |\<in>| document_ptr_kinds h3\<close> disconnected_nodes_h3
by fastforce
next
case False
then have
"set |h2 \<turnstile> get_disconnected_nodes d|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes owner_document|\<^sub>r = {}"
using distinct_concat_map_E(1) wellformed_h2
by (metis (no_types, lifting) \<open>d |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h2\<close>
disconnected_nodes_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
select_result_I2)
then show ?thesis
using disconnected_nodes_eq2_h2[OF False] \<open>node \<in> set disconnected_nodes_h2\<close>
disconnected_nodes_h2 by fastforce
qed
qed
have "cast node \<noteq> ptr"
using ancestors node_not_in_ancestors get_ancestors_ptr
by fast
obtain ancestors_h2 where ancestors_h2: "h2 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_ok object_ptr_kinds_M_eq2_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close>
by (metis is_OK_returns_result_E object_ptr_kinds_M_eq3_h2 ptr_in_heap wellformed_h2)
have ancestors_h3: "h3 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_separate_forwards)
using \<open>heap_is_wellformed h2\<close> ancestors_h2
by (auto simp add: set_disconnected_nodes_get_ancestors)
have node_not_in_ancestors_h2: "cast node \<notin> set ancestors_h2"
apply(rule get_ancestors_remains_not_in_ancestors[OF assms(1) wellformed_h2 ancestors ancestors_h2])
using adopt_node_children_subset using h2 \<open>known_ptrs h\<close> \<open> type_wf h\<close> apply(blast)
using node_not_in_ancestors apply(blast)
using object_ptr_kinds_M_eq3_h apply(blast)
using \<open>known_ptrs h\<close> apply(blast)
using \<open>type_wf h\<close> apply(blast)
using \<open>type_wf h2\<close> by blast
have "acyclic (parent_child_rel h2)"
using wellformed_h2 by (simp add: heap_is_wellformed_def acyclic_heap_def)
then have "acyclic (parent_child_rel h3)"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover
have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h2)\<^sup>*}"
using adopt_node_removes_child
using ancestors node_not_in_ancestors
using \<open>known_ptrs h2\<close> \<open>type_wf h2\<close> ancestors_h2 local.get_ancestors_parent_child_rel
node_not_in_ancestors_h2 wellformed_h2
by blast
then have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3)\<^sup>*}"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "parent_child_rel h'
= insert (ptr, cast node) ((parent_child_rel h3))"
using children_h3 children_h' ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h' children_eq2_h3
insert_before_list_node_in_set)[1]
apply (metis (no_types, lifting) children_eq2_h3 insert_before_list_in_set select_result_I2)
by (metis (no_types, lifting) children_eq2_h3 imageI insert_before_list_in_set select_result_I2)
ultimately show "acyclic (parent_child_rel h')"
by (auto simp add: heap_is_wellformed_def)
qed
lemma insert_before_heap_is_wellformed_preserved:
assumes wellformed: "heap_is_wellformed h"
and insert_before: "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I known_ptrs
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using type_wf adopt_node_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have "known_ptrs h2"
using known_ptrs object_ptr_kinds_M_eq3_h known_ptrs_preserved by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF wellformed h2] known_ptrs type_wf .
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have "known_ptrs h3"
using object_ptr_kinds_M_eq3_h2 known_ptrs_preserved \<open>known_ptrs h2\<close> by blast
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3:
"|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
show "known_ptrs h'"
using object_ptr_kinds_M_eq3_h' known_ptrs_preserved \<open>known_ptrs h3\<close> by blast
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> owner_document
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3:
"h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr'
\<Longrightarrow> h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3:
"\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children:
"\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using wellformed h2 adopt_node_removes_child \<open>type_wf h\<close> \<open>known_ptrs h\<close> by auto
have "node \<in> set disconnected_nodes_h2"
using disconnected_nodes_h2 h2 adopt_node_node_in_disconnected_nodes assms(1)
\<open>type_wf h\<close> \<open>known_ptrs h\<close> by blast
have node_not_in_disconnected_nodes:
"\<And>d. d |\<in>| document_ptr_kinds h3 \<Longrightarrow> node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof -
fix d
assume "d |\<in>| document_ptr_kinds h3"
show "node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof (cases "d = owner_document")
case True
then show ?thesis
using disconnected_nodes_h2 wellformed_h2 h3 remove_from_disconnected_nodes_removes
wellformed_h2 \<open>d |\<in>| document_ptr_kinds h3\<close> disconnected_nodes_h3
by fastforce
next
case False
then have
"set |h2 \<turnstile> get_disconnected_nodes d|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes owner_document|\<^sub>r = {}"
using distinct_concat_map_E(1) wellformed_h2
by (metis (no_types, lifting) \<open>d |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h2\<close>
disconnected_nodes_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
select_result_I2)
then show ?thesis
using disconnected_nodes_eq2_h2[OF False] \<open>node \<in> set disconnected_nodes_h2\<close>
disconnected_nodes_h2 by fastforce
qed
qed
have "cast node \<noteq> ptr"
using ancestors node_not_in_ancestors get_ancestors_ptr
by fast
obtain ancestors_h2 where ancestors_h2: "h2 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_ok object_ptr_kinds_M_eq2_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close>
by (metis is_OK_returns_result_E object_ptr_kinds_M_eq3_h2 ptr_in_heap wellformed_h2)
have ancestors_h3: "h3 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_separate_forwards)
using \<open>heap_is_wellformed h2\<close> ancestors_h2
by (auto simp add: set_disconnected_nodes_get_ancestors)
have node_not_in_ancestors_h2: "cast node \<notin> set ancestors_h2"
apply(rule get_ancestors_remains_not_in_ancestors[OF assms(1) wellformed_h2 ancestors ancestors_h2])
using adopt_node_children_subset using h2 \<open>known_ptrs h\<close> \<open> type_wf h\<close> apply(blast)
using node_not_in_ancestors apply(blast)
using object_ptr_kinds_M_eq3_h apply(blast)
using \<open>known_ptrs h\<close> apply(blast)
using \<open>type_wf h\<close> apply(blast)
using \<open>type_wf h2\<close> by blast
moreover have "a_acyclic_heap h'"
proof -
have "acyclic (parent_child_rel h2)"
using wellformed_h2 by (simp add: heap_is_wellformed_def acyclic_heap_def)
then have "acyclic (parent_child_rel h3)"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h2)\<^sup>*}"
using get_ancestors_parent_child_rel node_not_in_ancestors_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close>
using ancestors_h2 wellformed_h2 by blast
then have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3)\<^sup>*}"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))"
using children_h3 children_h' ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h' children_eq2_h3
insert_before_list_node_in_set)[1]
apply (metis (no_types, lifting) children_eq2_h3 insert_before_list_in_set select_result_I2)
by (metis (no_types, lifting) children_eq2_h3 imageI insert_before_list_in_set select_result_I2)
ultimately show ?thesis
by(auto simp add: acyclic_heap_def)
qed
moreover have "a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
have "a_all_ptrs_in_heap h'"
proof -
have "a_all_ptrs_in_heap h3"
using \<open>a_all_ptrs_in_heap h2\<close>
apply(auto simp add: a_all_ptrs_in_heap_def object_ptr_kinds_M_eq2_h2 node_ptr_kinds_eq2_h2
children_eq_h2)[1]
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
using node_ptr_kinds_eq2_h2 apply auto[1]
apply (metis \<open>known_ptrs h2\<close> \<open>type_wf h3\<close> children_eq_h2 local.get_child_nodes_ok
local.heap_is_wellformed_children_in_heap local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h2
returns_result_select_result wellformed_h2)
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 document_ptr_kinds_commutes finite_set_in node_ptr_kinds_commutes
object_ptr_kinds_M_eq3_h2 select_result_I2 set_remove1_subset subsetD)
have "set children_h3 \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using children_h3 \<open>a_all_ptrs_in_heap h3\<close>
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq2_h3)[1]
by (metis children_eq_h2 l_heap_is_wellformed.heap_is_wellformed_children_in_heap
local.l_heap_is_wellformed_axioms node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2 wellformed_h2)
then have "set (insert_before_list node reference_child children_h3) \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_in_heap
apply(auto simp add: node_ptr_kinds_eq2_h node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3)[1]
by (metis (no_types, opaque_lifting) contra_subsetD finite_set_in insert_before_list_in_set
node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2)
then show ?thesis
using \<open>a_all_ptrs_in_heap h3\<close>
apply(auto simp add: object_ptr_kinds_M_eq3_h' a_all_ptrs_in_heap_def node_ptr_kinds_def
node_ptr_kinds_eq2_h3 disconnected_nodes_eq_h3)[1]
using children_eq_h3 children_h'
apply (metis (no_types, lifting) children_eq2_h3 finite_set_in select_result_I2 subsetD)
by (metis (no_types) \<open>type_wf h'\<close> disconnected_nodes_eq2_h3 disconnected_nodes_eq_h3
finite_set_in is_OK_returns_result_I local.get_disconnected_nodes_ok
local.get_disconnected_nodes_ptr_in_heap returns_result_select_result subsetD)
qed
moreover have "a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h3"
proof(auto simp add: a_distinct_lists_def object_ptr_kinds_M_eq2_h2 document_ptr_kinds_eq2_h2
children_eq2_h2 intro!: distinct_concat_map_I)[1]
fix x
assume 1: "x |\<in>| document_ptr_kinds h3"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
show "distinct |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_concat_map_E(2)[OF 2] select_result_I2[OF disconnected_nodes_h3]
disconnected_nodes_eq2_h2 select_result_I2[OF disconnected_nodes_h2] 1
- by (metis (full_types) distinct_remove1 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ by (metis (full_types) distinct_remove1 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and 2: "x |\<in>| document_ptr_kinds h3"
and 3: "y |\<in>| document_ptr_kinds h3"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
and 6: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r"
show False
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using 4 by simp
show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>y \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>x \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using distinct_concat_map_E(1)[OF 1, simplified, OF 2 3 4] 5 6
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
- disjoint_iff_not_equal finite_fset fmember.rep_eq notin_set_remove1 select_result_I2
+ disjoint_iff_not_equal finite_fset fmember_iff_member_fset notin_set_remove1 select_result_I2
set_sorted_list_of_set
by (metis (no_types, lifting))
qed
qed
next
fix x xa xb
assume 1: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h3 \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 2: "xa |\<in>| object_ptr_kinds h3"
and 3: "x \<in> set |h3 \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h3"
and 5: "x \<in> set |h3 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 4
by (metis \<open>type_wf h2\<close> children_eq2_h2 document_ptr_kinds_commutes known_ptrs
local.get_child_nodes_ok local.get_disconnected_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h2 returns_result_select_result
wellformed_h2)
show False
proof (cases "xb = owner_document")
case True
then show ?thesis
using select_result_I2[OF disconnected_nodes_h3,folded select_result_I2[OF disconnected_nodes_h2]]
by (metis (no_types, lifting) "3" "5" "6" disjoint_iff_not_equal notin_set_remove1)
next
case False
show ?thesis
using 2 3 4 5 6 unfolding disconnected_nodes_eq2_h2[OF False] by auto
qed
qed
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def document_ptr_kinds_eq2_h3 object_ptr_kinds_M_eq2_h3
disconnected_nodes_eq2_h3 intro!: distinct_concat_map_I)[1]
fix x
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))" and
2: "x |\<in>| object_ptr_kinds h'"
have 3: "\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> distinct |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using 1 by (auto elim: distinct_concat_map_E)
show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
proof(cases "ptr = x")
case True
show ?thesis
using 3[OF 2] children_h3 children_h'
by(auto simp add: True insert_before_list_distinct
dest: child_not_in_any_children[unfolded children_eq_h2])
next
case False
show ?thesis
using children_eq2_h3[OF False] 3[OF 2] by auto
qed
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "x |\<in>| object_ptr_kinds h'"
and 3: "y |\<in>| object_ptr_kinds h'"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h' \<turnstile> get_child_nodes x|\<^sub>r"
and 6: "xa \<in> set |h' \<turnstile> get_child_nodes y|\<^sub>r"
have 7:"set |h3 \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_child_nodes y|\<^sub>r = {}"
using distinct_concat_map_E(1)[OF 1] 2 3 4 by auto
show False
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
using 4 by simp
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> y\<close>])[1]
by (metis (no_types, opaque_lifting) "3" "7" \<open>type_wf h3\<close> children_eq2_h3 disjoint_iff_not_equal
get_child_nodes_ok insert_before_list_in_set known_ptrs local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2 returns_result_select_result select_result_I2)
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> x\<close>])[1]
by (metis (no_types, opaque_lifting) "2" "4" "7" IntI \<open>known_ptrs h3\<close> \<open>type_wf h'\<close>
children_eq_h3 empty_iff insert_before_list_in_set local.get_child_nodes_ok
local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h'
returns_result_select_result select_result_I2)
next
case False
then show ?thesis
using children_eq2_h3[OF \<open>ptr \<noteq> x\<close>] children_eq2_h3[OF \<open>ptr \<noteq> y\<close>] 5 6 7 by auto
qed
qed
next
fix x xa xb
assume 1: " (\<Union>x\<in>fset (object_ptr_kinds h'). set |h3 \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r) = {} "
and 2: "xa |\<in>| object_ptr_kinds h'"
and 3: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h'"
and 5: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 3 4 5
proof -
have "\<forall>h d. \<not> type_wf h \<or> d |\<notin>| document_ptr_kinds h \<or> h \<turnstile> ok get_disconnected_nodes d"
using local.get_disconnected_nodes_ok by satx
then have "h' \<turnstile> ok get_disconnected_nodes xb"
using "4" \<open>type_wf h'\<close> by fastforce
then have f1: "h3 \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
by (simp add: disconnected_nodes_eq_h3)
have "xa |\<in>| object_ptr_kinds h3"
using "2" object_ptr_kinds_M_eq3_h' by blast
then show ?thesis
using f1 \<open>local.a_distinct_lists h3\<close> local.distinct_lists_no_parent by fastforce
qed
show False
proof (cases "ptr = xa")
case True
show ?thesis
using 6 node_not_in_disconnected_nodes 3 4 5 select_result_I2[OF children_h']
select_result_I2[OF children_h3] True disconnected_nodes_eq2_h3
by (metis (no_types, lifting) "2" DocumentMonad.ptr_kinds_ptr_kinds_M
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disconnected_nodes_eq_h3
distinct_lists_no_parent document_ptr_kinds_eq2_h3 get_disconnected_nodes_ok
insert_before_list_in_set object_ptr_kinds_M_eq3_h' returns_result_select_result)
next
case False
then show ?thesis
using 1 2 3 4 5 children_eq2_h3[OF False] by fastforce
qed
qed
moreover have "a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def object_ptr_kinds_M_eq2_h2
object_ptr_kinds_M_eq2_h3 node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3
document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3 children_eq2_h2)[1]
apply(auto simp add: document_ptr_kinds_eq2_h2[simplified] document_ptr_kinds_eq2_h3[simplified]
object_ptr_kinds_M_eq2_h2[simplified] object_ptr_kinds_M_eq2_h3[simplified]
node_ptr_kinds_eq2_h2[simplified] node_ptr_kinds_eq2_h3[simplified])[1]
apply(auto simp add: disconnected_nodes_eq2_h3[symmetric])[1]
by (smt (verit) children_eq2_h3 children_h' children_h3 disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 finite_set_in in_set_remove1 insert_before_list_in_set object_ptr_kinds_M_eq3_h'
ptr_in_heap select_result_I2)
ultimately show "heap_is_wellformed h'"
by (simp add: heap_is_wellformed_def)
qed
lemma adopt_node_children_remain_distinct:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
shows "\<And>ptr' children'.
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> distinct children'"
using assms(1) assms(2) assms(3) assms(4) local.adopt_node_preserves_wellformedness
local.heap_is_wellformed_children_distinct
by blast
lemma insert_node_children_remain_distinct:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> a_insert_node ptr new_child reference_child_opt \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "new_child \<notin> set children"
shows "\<And>children'.
h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children' \<Longrightarrow> distinct children'"
proof -
fix children'
assume a1: "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'"
have "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r (insert_before_list new_child reference_child_opt children)"
using assms(4) assms(5) apply(auto simp add: a_insert_node_def elim!: bind_returns_heap_E)[1]
using returns_result_eq set_child_nodes_get_child_nodes assms(2) assms(3)
by (metis is_OK_returns_result_I local.get_child_nodes_ptr_in_heap local.get_child_nodes_pure
local.known_ptrs_known_ptr pure_returns_heap_eq)
moreover have "a_distinct_lists h"
using assms local.heap_is_wellformed_def by blast
then have "\<And>children. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> distinct children"
using assms local.heap_is_wellformed_children_distinct by blast
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children' \<Longrightarrow> distinct children'"
using assms(5) assms(6) insert_before_list_distinct returns_result_eq by fastforce
qed
lemma insert_before_children_remain_distinct:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> insert_before ptr new_child child_opt \<rightarrow>\<^sub>h h'"
shows "\<And>ptr' children'.
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> distinct children'"
proof -
obtain reference_child owner_document h2 h3 disconnected_nodes_h2 where
reference_child:
"h \<turnstile> (if Some new_child = child_opt then a_next_sibling new_child else return child_opt) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document new_child \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 new_child disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr new_child reference_child \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> distinct children"
using adopt_node_children_remain_distinct
using assms(1) assms(2) assms(3) h2
by blast
moreover have "\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> new_child \<notin> set children"
using adopt_node_removes_child
using assms(1) assms(2) assms(3) h2
by blast
moreover have "\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
ultimately show "\<And>ptr children. h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> distinct children"
using insert_node_children_remain_distinct
by (meson assms(1) assms(2) assms(3) assms(4) insert_before_heap_is_wellformed_preserved(1)
local.heap_is_wellformed_children_distinct)
qed
lemma insert_before_removes_child:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
assumes "ptr \<noteq> ptr'"
shows "\<And>children'. h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> node \<notin> set children'"
proof -
fix children'
assume a1: "h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'"
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I assms(2)
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using assms(3) adopt_node_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have "known_ptrs h2"
using assms object_ptr_kinds_M_eq3_h known_ptrs_preserved by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF assms(1) h2] assms by simp
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have "known_ptrs h3"
using object_ptr_kinds_M_eq3_h2 known_ptrs_preserved \<open>known_ptrs h2\<close> by blast
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3:
"|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
have "known_ptrs h'"
using object_ptr_kinds_M_eq3_h' known_ptrs_preserved \<open>known_ptrs h3\<close> by blast
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> owner_document
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3:
"h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr'
\<Longrightarrow> h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3:
"\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children:
"\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using assms(1) assms(2) assms(3) h2 local.adopt_node_removes_child by blast
show "node \<notin> set children'"
using a1 assms(5) child_not_in_any_children children_eq_h2 children_eq_h3 by blast
qed
lemma ensure_pre_insertion_validity_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "\<not>is_character_data_ptr_kind parent"
assumes "cast node \<notin> set |h \<turnstile> get_ancestors parent|\<^sub>r"
assumes "h \<turnstile> get_parent ref \<rightarrow>\<^sub>r Some parent"
assumes "is_document_ptr parent \<Longrightarrow> h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r []"
assumes "is_document_ptr parent \<Longrightarrow> \<not>is_character_data_ptr_kind node"
shows "h \<turnstile> ok (a_ensure_pre_insertion_validity node parent (Some ref))"
proof -
have "h \<turnstile> (if is_character_data_ptr_kind parent
then error HierarchyRequestError else return ()) \<rightarrow>\<^sub>r ()"
using assms
by (simp add: assms(4))
moreover have "h \<turnstile> do {
ancestors \<leftarrow> get_ancestors parent;
(if cast node \<in> set ancestors then error HierarchyRequestError else return ())
} \<rightarrow>\<^sub>r ()"
using assms(6)
apply(auto intro!: bind_pure_returns_result_I)[1]
using assms(1) assms(2) assms(3) assms(7) local.get_ancestors_ok local.get_parent_parent_in_heap
by auto
moreover have "h \<turnstile> do {
(case Some ref of
Some child \<Rightarrow> do {
child_parent \<leftarrow> get_parent child;
(if child_parent \<noteq> Some parent then error NotFoundError else return ())}
| None \<Rightarrow> return ())
} \<rightarrow>\<^sub>r ()"
using assms(7)
by(auto split: option.splits)
moreover have "h \<turnstile> do {
children \<leftarrow> get_child_nodes parent;
(if children \<noteq> [] \<and> is_document_ptr parent
then error HierarchyRequestError else return ())
} \<rightarrow>\<^sub>r ()"
by (smt (verit, best) assms(5) assms(7) assms(8) bind_pure_returns_result_I2 calculation(1)
is_OK_returns_result_I local.get_child_nodes_pure local.get_parent_child_dual returns_result_eq)
moreover have "h \<turnstile> do {
(if is_character_data_ptr node \<and> is_document_ptr parent
then error HierarchyRequestError else return ())
} \<rightarrow>\<^sub>r ()"
using assms
using is_character_data_ptr_kind_none by force
ultimately show ?thesis
unfolding a_ensure_pre_insertion_validity_def
apply(intro bind_is_OK_pure_I)
apply auto[1]
apply auto[1]
apply auto[1]
using assms(1) assms(2) assms(3) assms(7) local.get_ancestors_ok local.get_parent_parent_in_heap
apply blast
apply auto[1]
apply auto[1]
using assms(6)
apply auto[1]
using assms(1) assms(2) assms(3) assms(7) local.get_ancestors_ok local.get_parent_parent_in_heap
apply auto[1]
apply (smt (verit) bind_returns_heap_E is_OK_returns_heap_E local.get_parent_pure pure_def
pure_returns_heap_eq return_returns_heap returns_result_eq)
apply(blast)
using local.get_child_nodes_pure
apply blast
apply (meson assms(7) is_OK_returns_result_I local.get_parent_child_dual)
apply (simp)
apply (smt (verit) assms(5) assms(8) is_OK_returns_result_I returns_result_eq)
by(auto)
qed
end
locale l_insert_before_wf2 = l_type_wf + l_known_ptrs + l_insert_before_defs
+ l_heap_is_wellformed_defs + l_get_child_nodes_defs + l_remove_defs +
assumes insert_before_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes insert_before_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes insert_before_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
interpretation i_insert_before_wf2?: l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs
get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_ancestors get_ancestors_locs
adopt_node adopt_node_locs set_disconnected_nodes
set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before
insert_before_locs append_child type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel remove_child
remove_child_locs get_root_node get_root_node_locs
by(simp add: l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf2_is_l_insert_before_wf2 [instances]:
"l_insert_before_wf2 type_wf known_ptr known_ptrs insert_before heap_is_wellformed"
apply(auto simp add: l_insert_before_wf2_def l_insert_before_wf2_axioms_def instances)[1]
using insert_before_heap_is_wellformed_preserved apply(fast, fast, fast)
done
locale l_insert_before_wf3\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child_wf2
begin
lemma next_sibling_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "node_ptr |\<in>| node_ptr_kinds h"
shows "h \<turnstile> ok (a_next_sibling node_ptr)"
proof -
have "known_ptr (cast node_ptr)"
using assms(2) assms(4) local.known_ptrs_known_ptr node_ptr_kinds_commutes by blast
then show ?thesis
using assms
apply(auto simp add: a_next_sibling_def intro!: bind_is_OK_pure_I split: option.splits list.splits)[1]
using get_child_nodes_ok local.get_parent_parent_in_heap local.known_ptrs_known_ptr by blast
qed
lemma remove_child_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "h \<turnstile> ok (remove_child ptr child)"
proof -
have "ptr |\<in>| object_ptr_kinds h"
using assms(4) local.get_child_nodes_ptr_in_heap by blast
have "child |\<in>| node_ptr_kinds h"
using assms(1) assms(4) assms(5) local.heap_is_wellformed_children_in_heap by blast
have "\<not>is_character_data_ptr ptr"
proof (rule ccontr, simp)
assume "is_character_data_ptr ptr"
then have "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(simp add: get_child_nodes_def a_get_child_nodes_tups_def)
apply(split invoke_splits)+
by(auto simp add: get_child_nodes\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I split: option.splits)
then
show False
using assms returns_result_eq by fastforce
qed
have "is_character_data_ptr child \<Longrightarrow> \<not>is_document_ptr_kind ptr"
proof (rule ccontr, simp)
assume "is_character_data_ptr\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child"
and "is_document_ptr_kind ptr"
then show False
using assms
using \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(simp add: get_child_nodes_def a_get_child_nodes_tups_def)
apply(split invoke_splits)+
apply(auto split: option.splits)[1]
apply (meson invoke_empty is_OK_returns_result_I)
apply (meson invoke_empty is_OK_returns_result_I)
by(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: option.splits)
qed
obtain owner_document where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document"
by (meson \<open>child |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_owner_document_ok node_ptr_kinds_commutes)
obtain disconnected_nodes_h where
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h"
by (meson assms(1) assms(2) assms(3) is_OK_returns_result_E local.get_disconnected_nodes_ok
local.get_owner_document_owner_document_in_heap owner_document)
obtain h2 where
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2"
by (meson assms(1) assms(2) assms(3) is_OK_returns_heap_E
l_set_disconnected_nodes.set_disconnected_nodes_ok local.get_owner_document_owner_document_in_heap
local.l_set_disconnected_nodes_axioms owner_document)
have "known_ptr ptr"
using assms(2) assms(4) local.known_ptrs_known_ptr
using \<open>ptr |\<in>| object_ptr_kinds h\<close> by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved assms(3)
by(auto simp add: reflp_def transp_def)
have "object_ptr_kinds h = object_ptr_kinds h2"
using h2
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
have "h2 \<turnstile> ok (set_child_nodes ptr (remove1 child children))"
proof (cases "is_element_ptr_kind ptr")
case True
then show ?thesis
using set_child_nodes_element_ok \<open>known_ptr ptr\<close> \<open>object_ptr_kinds h = object_ptr_kinds h2\<close>
\<open>type_wf h2\<close> assms(4)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> by blast
next
case False
then have "is_document_ptr_kind ptr"
using \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> \<open>\<not>is_character_data_ptr ptr\<close>
by(auto simp add:known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
moreover have "is_document_ptr ptr"
using \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not>is_character_data_ptr ptr\<close>
by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
ultimately show ?thesis
using assms(4)
apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def)[1]
apply(split invoke_splits)+
apply(auto elim!: bind_returns_result_E2 split: option.splits)[1]
apply(auto simp add: get_child_nodes\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: option.splits)[1]
using assms(5) apply auto[1]
using \<open>is_document_ptr_kind ptr\<close> \<open>known_ptr ptr\<close> \<open>object_ptr_kinds h = object_ptr_kinds h2\<close>
\<open>ptr |\<in>| object_ptr_kinds h\<close> \<open>type_wf h2\<close> local.set_child_nodes_document1_ok apply blast
using \<open>is_document_ptr_kind ptr\<close> \<open>known_ptr ptr\<close> \<open>object_ptr_kinds h = object_ptr_kinds h2\<close>
\<open>ptr |\<in>| object_ptr_kinds h\<close> \<open>type_wf h2\<close> is_element_ptr_kind_cast local.set_child_nodes_document2_ok
apply blast
using \<open>\<not> is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close> apply blast
by (metis False is_element_ptr_implies_kind option.case_eq_if)
qed
then
obtain h' where
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children) \<rightarrow>\<^sub>h h'"
by auto
show ?thesis
using assms
apply(auto simp add: remove_child_def
simp add: is_OK_returns_heap_I[OF h2] is_OK_returns_heap_I[OF h']
is_OK_returns_result_I[OF assms(4)] is_OK_returns_result_I[OF owner_document]
is_OK_returns_result_I[OF disconnected_nodes_h]
intro!: bind_is_OK_pure_I[OF get_owner_document_pure]
bind_is_OK_pure_I[OF get_child_nodes_pure]
bind_is_OK_pure_I[OF get_disconnected_nodes_pure]
bind_is_OK_I[rotated, OF h2]
dest!: returns_result_eq[OF assms(4)] returns_result_eq[OF owner_document]
returns_result_eq[OF disconnected_nodes_h]
)[1]
using h2 returns_result_select_result by force
qed
lemma adopt_node_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "document_ptr |\<in>| document_ptr_kinds h"
assumes "child |\<in>| node_ptr_kinds h"
shows "h \<turnstile> ok (adopt_node document_ptr child)"
proof -
obtain old_document where
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document"
by (meson assms(1) assms(2) assms(3) assms(5) is_OK_returns_result_E local.get_owner_document_ok
node_ptr_kinds_commutes)
then have "h \<turnstile> ok (get_owner_document (cast child))"
by auto
obtain parent_opt where
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
by (meson assms(2) assms(3) is_OK_returns_result_I l_get_owner_document.get_owner_document_ptr_in_heap
local.get_parent_ok local.l_get_owner_document_axioms node_ptr_kinds_commutes old_document
returns_result_select_result)
then have "h \<turnstile> ok (get_parent child)"
by auto
have "h \<turnstile> ok (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ())"
apply(auto split: option.splits)[1]
using remove_child_ok
by (metis assms(1) assms(2) assms(3) local.get_parent_child_dual parent_opt)
then
obtain h2 where
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
by auto
have "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then
have "old_document |\<in>| document_ptr_kinds h2"
using assms(1) assms(2) assms(3) document_ptr_kinds_commutes
local.get_owner_document_owner_document_in_heap old_document
by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved assms
by(auto split: option.splits)
have "type_wf h2"
using h2 remove_child_preserves_type_wf assms
by(auto split: option.splits)
have "known_ptrs h2"
using h2 remove_child_preserves_known_ptrs assms
by(auto split: option.splits)
have "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have "document_ptr_kinds h = document_ptr_kinds h2"
by(auto simp add: document_ptr_kinds_def)
have "h2 \<turnstile> ok (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
})"
proof(cases "document_ptr = old_document")
case True
then show ?thesis
by simp
next
case False
then have "h2 \<turnstile> ok (get_disconnected_nodes old_document)"
by (simp add: \<open>old_document |\<in>| document_ptr_kinds h2\<close> \<open>type_wf h2\<close> local.get_disconnected_nodes_ok)
then obtain old_disc_nodes where
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes"
by auto
have "h2 \<turnstile> ok (set_disconnected_nodes old_document (remove1 child old_disc_nodes))"
by (simp add: \<open>old_document |\<in>| document_ptr_kinds h2\<close> \<open>type_wf h2\<close> local.set_disconnected_nodes_ok)
then obtain h3 where
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3"
by auto
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2:
"\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h3"
using \<open>type_wf h2\<close>
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
moreover have "document_ptr |\<in>| document_ptr_kinds h3"
using \<open>document_ptr_kinds h = document_ptr_kinds h2\<close> assms(4) document_ptr_kinds_eq3_h2 by auto
ultimately have "h3 \<turnstile> ok (get_disconnected_nodes document_ptr)"
by (simp add: local.get_disconnected_nodes_ok)
then obtain disc_nodes where
disc_nodes: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
by auto
have "h3 \<turnstile> ok (set_disconnected_nodes document_ptr (child # disc_nodes))"
using \<open>document_ptr |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h3\<close> local.set_disconnected_nodes_ok by auto
then obtain h' where
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes) \<rightarrow>\<^sub>h h'"
by auto
then show ?thesis
using False
using \<open>h2 \<turnstile> ok get_disconnected_nodes old_document\<close>
using \<open>h3 \<turnstile> ok get_disconnected_nodes document_ptr\<close>
apply(auto dest!: returns_result_eq[OF old_disc_nodes] returns_result_eq[OF disc_nodes]
intro!: bind_is_OK_I[rotated, OF h3] bind_is_OK_pure_I[OF get_disconnected_nodes_pure] )[1]
using \<open>h2 \<turnstile> ok set_disconnected_nodes old_document (remove1 child old_disc_nodes)\<close> by auto
qed
then obtain h' where
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
by auto
show ?thesis
using \<open>h \<turnstile> ok (get_owner_document (cast child))\<close>
using \<open>h \<turnstile> ok (get_parent child)\<close>
using h2 h'
apply(auto simp add: adopt_node_def
simp add: is_OK_returns_heap_I[OF h2]
intro!: bind_is_OK_pure_I[OF get_owner_document_pure]
bind_is_OK_pure_I[OF get_parent_pure]
bind_is_OK_I[rotated, OF h2]
dest!: returns_result_eq[OF parent_opt] returns_result_eq[OF old_document])[1]
using \<open>h \<turnstile> ok (case parent_opt of None \<Rightarrow> return () | Some parent \<Rightarrow> remove_child parent child)\<close>
by auto
qed
lemma insert_node_ok:
assumes "known_ptr parent" and "type_wf h"
assumes "parent |\<in>| object_ptr_kinds h"
assumes "\<not>is_character_data_ptr_kind parent"
assumes "is_document_ptr parent \<Longrightarrow> h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r []"
assumes "is_document_ptr parent \<Longrightarrow> \<not>is_character_data_ptr_kind node"
assumes "known_ptr (cast node)"
shows "h \<turnstile> ok (a_insert_node parent node ref)"
proof(auto simp add: a_insert_node_def get_child_nodes_ok[OF assms(1) assms(2) assms(3)]
intro!: bind_is_OK_pure_I)
fix children'
assume "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'"
show "h \<turnstile> ok set_child_nodes parent (insert_before_list node ref children')"
proof (cases "is_element_ptr_kind parent")
case True
then show ?thesis
using set_child_nodes_element_ok
using assms(1) assms(2) assms(3) by blast
next
case False
then have "is_document_ptr_kind parent"
using assms(4) assms(1)
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then have "is_document_ptr parent"
using assms(1)
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children" and "children = []"
using assms(5) by blast
have "insert_before_list node ref children' = [node]"
by (metis \<open>children = []\<close> \<open>h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'\<close> append.left_neutral
children insert_Nil l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.insert_before_list.elims
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.insert_before_list.simps(3) neq_Nil_conv returns_result_eq)
moreover have "\<not>is_character_data_ptr_kind node"
using \<open>is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r parent\<close> assms(6) by blast
then have "is_element_ptr_kind node"
by (metis (no_types, lifting) CharacterDataClass.a_known_ptr_def DocumentClass.a_known_ptr_def
ElementClass.a_known_ptr_def NodeClass.a_known_ptr_def assms(7) cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject
document_ptr_no_node_ptr_cast is_character_data_ptr_kind_none is_document_ptr_kind_none
is_element_ptr_implies_kind is_node_ptr_kind_cast local.known_ptr_impl node_ptr_casts_commute3
option.case_eq_if)
ultimately
show ?thesis
using set_child_nodes_document2_ok
by (metis \<open>is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r parent\<close> assms(1) assms(2) assms(3) assms(5)
is_document_ptr_kind_none option.case_eq_if)
qed
qed
lemma insert_before_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "parent |\<in>| object_ptr_kinds h"
assumes "node |\<in>| node_ptr_kinds h"
assumes "\<not>is_character_data_ptr_kind parent"
assumes "cast node \<notin> set |h \<turnstile> get_ancestors parent|\<^sub>r"
assumes "h \<turnstile> get_parent ref \<rightarrow>\<^sub>r Some parent"
assumes "is_document_ptr parent \<Longrightarrow> h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r []"
assumes "is_document_ptr parent \<Longrightarrow> \<not>is_character_data_ptr_kind node"
shows "h \<turnstile> ok (insert_before parent node (Some ref))"
proof -
have "h \<turnstile> ok (a_ensure_pre_insertion_validity node parent (Some ref))"
using assms ensure_pre_insertion_validity_ok by blast
have "h \<turnstile> ok (if Some node = Some ref
then a_next_sibling node
else return (Some ref))" (is "h \<turnstile> ok ?P")
apply(auto split: if_splits)[1]
using assms(1) assms(2) assms(3) assms(5) next_sibling_ok by blast
then obtain reference_child where
reference_child: "h \<turnstile> ?P \<rightarrow>\<^sub>r reference_child"
by auto
obtain owner_document where
owner_document: "h \<turnstile> get_owner_document parent \<rightarrow>\<^sub>r owner_document"
using assms get_owner_document_ok
by (meson returns_result_select_result)
then have "h \<turnstile> ok (get_owner_document parent)"
by auto
have "owner_document |\<in>| document_ptr_kinds h"
using assms(1) assms(2) assms(3) local.get_owner_document_owner_document_in_heap owner_document
by blast
obtain h2 where
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2"
by (meson assms(1) assms(2) assms(3) assms(5) is_OK_returns_heap_E adopt_node_ok
l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
local.get_owner_document_owner_document_in_heap owner_document)
then have "h \<turnstile> ok (adopt_node owner_document node)"
by auto
have "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have "document_ptr_kinds h = document_ptr_kinds h2"
by(auto simp add: document_ptr_kinds_def)
have "heap_is_wellformed h2"
using h2 adopt_node_preserves_wellformedness assms by blast
have "known_ptrs h2"
using h2 adopt_node_preserves_known_ptrs assms by blast
have "type_wf h2"
using h2 adopt_node_preserves_type_wf assms by blast
obtain disconnected_nodes_h2 where
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2"
by (metis \<open>document_ptr_kinds h = document_ptr_kinds h2\<close> \<open>type_wf h2\<close> assms(1) assms(2) assms(3)
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_owner_document_owner_document_in_heap
owner_document)
obtain h3 where
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3"
by (metis \<open>document_ptr_kinds h = document_ptr_kinds h2\<close> \<open>owner_document |\<in>| document_ptr_kinds h\<close>
\<open>type_wf h2\<close> document_ptr_kinds_def is_OK_returns_heap_E
l_set_disconnected_nodes.set_disconnected_nodes_ok local.l_set_disconnected_nodes_axioms)
have "type_wf h3"
using \<open>type_wf h2\<close>
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
have "parent |\<in>| object_ptr_kinds h3"
using \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> assms(4) object_ptr_kinds_M_eq3_h2 by blast
moreover have "known_ptr parent"
using assms(2) assms(4) local.known_ptrs_known_ptr by blast
moreover have "known_ptr (cast node)"
using assms(2) assms(5) local.known_ptrs_known_ptr node_ptr_kinds_commutes by blast
moreover have "is_document_ptr parent \<Longrightarrow> h3 \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r []"
by (metis assms(8) assms(9) distinct.simps(2) distinct_singleton local.get_parent_child_dual
returns_result_eq)
ultimately obtain h' where
h': "h3 \<turnstile> a_insert_node parent node reference_child \<rightarrow>\<^sub>h h'"
using insert_node_ok \<open>type_wf h3\<close> assms by blast
show ?thesis
using \<open>h \<turnstile> ok (a_ensure_pre_insertion_validity node parent (Some ref))\<close>
using reference_child \<open>h \<turnstile> ok (get_owner_document parent)\<close> \<open>h \<turnstile> ok (adopt_node owner_document node)\<close>
h3 h'
apply(auto simp add: insert_before_def
simp add: is_OK_returns_result_I[OF disconnected_nodes_h2]
simp add: is_OK_returns_heap_I[OF h3] is_OK_returns_heap_I[OF h']
intro!: bind_is_OK_I2
bind_is_OK_pure_I[OF ensure_pre_insertion_validity_pure]
bind_is_OK_pure_I[OF next_sibling_pure]
bind_is_OK_pure_I[OF get_owner_document_pure]
bind_is_OK_pure_I[OF get_disconnected_nodes_pure]
dest!: returns_result_eq[OF owner_document] returns_result_eq[OF disconnected_nodes_h2]
returns_heap_eq[OF h2] returns_heap_eq[OF h3]
dest!: sym[of node ref]
)[1]
using returns_result_eq by fastforce
qed
end
interpretation i_insert_before_wf3?: l_insert_before_wf3\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_parent get_parent_locs get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs
get_ancestors get_ancestors_locs adopt_node adopt_node_locs set_disconnected_nodes
set_disconnected_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_owner_document
insert_before insert_before_locs append_child type_wf known_ptr known_ptrs heap_is_wellformed
parent_child_rel remove_child remove_child_locs get_root_node get_root_node_locs remove
by(auto simp add: l_insert_before_wf3\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf3\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before_wf +
l_insert_before_wf2 +
l_get_child_nodes
begin
lemma append_child_heap_is_wellformed_preserved:
assumes wellformed: "heap_is_wellformed h"
and append_child: "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
using assms
by(auto simp add: append_child_def intro: insert_before_preserves_type_wf
insert_before_preserves_known_ptrs insert_before_heap_is_wellformed_preserved)
lemma append_child_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
assumes "node \<notin> set xs"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [node]"
proof -
obtain ancestors owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node None \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: append_child_def insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr"
using assms(1) assms(4) assms(6)
by (metis (no_types, lifting) assms(2) assms(3) h2 is_OK_returns_heap_I is_OK_returns_result_E
local.adopt_node_child_in_heap local.get_parent_child_dual local.get_parent_ok
select_result_I2)
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads adopt_node_writes h2 assms(4)
apply(rule reads_writes_separate_forwards)
using \<open>\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>
apply(auto simp add: adopt_node_locs_def remove_child_locs_def)[1]
by (meson local.set_child_nodes_get_child_nodes_different_pointers)
have "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads set_disconnected_nodes_writes h3 \<open>h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
apply(rule reads_writes_separate_forwards)
by(auto)
have "ptr |\<in>| object_ptr_kinds h"
by (meson ancestors is_OK_returns_result_I local.get_ancestors_ptr_in_heap)
then
have "known_ptr ptr"
using assms(3)
using local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using adopt_node_types_preserved \<open>type_wf h\<close>
by(auto simp add: adopt_node_locs_def remove_child_locs_def reflp_def transp_def split: if_splits)
then
have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@[node]"
using h'
apply(auto simp add: a_insert_node_def
dest!: bind_returns_heap_E3[rotated, OF \<open>h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
get_child_nodes_pure, rotated])[1]
using \<open>type_wf h3\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close>
by metis
qed
lemma append_child_for_all_on_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "set nodes \<inter> set xs = {}"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@nodes"
using assms
apply(induct nodes arbitrary: h xs)
apply(simp)
proof(auto elim!: bind_returns_heap_E)[1]fix a nodes h xs h'a
assume 0: "(\<And>h xs. heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs \<Longrightarrow> h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'
\<Longrightarrow> set nodes \<inter> set xs = {} \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ nodes)"
and 1: "heap_is_wellformed h"
and 2: "type_wf h"
and 3: "known_ptrs h"
and 4: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
and 5: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>r ()"
and 6: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>h h'a"
and 7: "h'a \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
and 8: "a \<notin> set xs"
and 9: "set nodes \<inter> set xs = {}"
and 10: "a \<notin> set nodes"
and 11: "distinct nodes"
then have "h'a \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [a]"
using append_child_children 6
using "1" "2" "3" "4" "8" by blast
moreover have "heap_is_wellformed h'a" and "type_wf h'a" and "known_ptrs h'a"
using insert_before_heap_is_wellformed_preserved insert_before_preserves_known_ptrs
insert_before_preserves_type_wf 1 2 3 6 append_child_def
by metis+
moreover have "set nodes \<inter> set (xs @ [a]) = {}"
using 9 10
by auto
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ a # nodes"
using 0 7
by fastforce
qed
lemma append_child_for_all_on_no_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r nodes"
using assms append_child_for_all_on_children
by force
end
locale l_append_child_wf = l_type_wf + l_known_ptrs + l_append_child_defs + l_heap_is_wellformed_defs +
assumes append_child_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes append_child_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes append_child_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
interpretation i_append_child_wf?: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent
get_parent_locs remove_child remove_child_locs
get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs
adopt_node adopt_node_locs known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs set_child_nodes
set_child_nodes_locs remove get_ancestors get_ancestors_locs
insert_before insert_before_locs append_child heap_is_wellformed
parent_child_rel
by(auto simp add: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma append_child_wf_is_l_append_child_wf [instances]: "l_append_child_wf type_wf known_ptr
known_ptrs append_child heap_is_wellformed"
apply(auto simp add: l_append_child_wf_def l_append_child_wf_axioms_def instances)[1]
using append_child_heap_is_wellformed_preserved by fast+
subsection \<open>create\_element\<close>
locale l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel +
l_new_element_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs
get_disconnected_nodes get_disconnected_nodes_locs +
l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf create_element known_ptr +
l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes set_disconnected_nodes_locs
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_disconnected_nodes_get_disconnected_nodes type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs +
l_new_element type_wf +
l_known_ptrs known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
begin
lemma create_element_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
apply (metis \<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1)
assms(3) funion_iff local.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child_in_heap local.parent_child_rel_child_nodes2 node_ptr_kinds_commutes
node_ptr_kinds_eq_h returns_result_select_result)
by (metis assms(1) assms(3) disconnected_nodes_eq2_h document_ptr_kinds_eq_h funion_iff
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h
returns_result_select_result)
then have "a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
local.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "a_all_ptrs_in_heap h'"
by (smt (verit) children_eq2_h3 disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3 element_ptr_kinds_commutes finite_set_in
h' h2 l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
new_element_ptr new_element_ptr_in_heap node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3
object_ptr_kinds_eq_h3 select_result_I2 set_ConsD subsetD subsetI)
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_element_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_element_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_element_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_element_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_element_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff local.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open>local.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok returns_result_select_result)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3
intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set disc_nodes_h3\<close>
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
apply(-)
apply(cases "x = document_ptr")
apply (smt (verit) NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>local.a_all_ptrs_in_heap h\<close>
disc_nodes_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
by (smt (verit) NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>local.a_all_ptrs_in_heap h\<close>
disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply -
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3
\<Longrightarrow> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open>a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open>a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: a_owner_document_valid_def)[1]
apply(auto simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )[1]
apply(auto simp add: object_ptr_kinds_eq_h2)[1]
apply(auto simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )[1]
apply(auto simp add: document_ptr_kinds_eq_h2)[1]
apply(auto simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )[1]
apply(auto simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )[1]
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by (smt (verit) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h
children_eq2_h2 children_eq2_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h' list.set_intros(2)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_element_wf?: l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
set_tag_name set_tag_name_locs
set_disconnected_nodes set_disconnected_nodes_locs create_element
using instances
by(auto simp add: l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>create\_character\_data\<close>
locale l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
+ l_new_character_data_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_val_get_disconnected_nodes
type_wf set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_val set_val_locs type_wf create_character_data known_ptr
+ l_new_character_data_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_set_val_get_child_nodes
type_wf set_val set_val_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes_get_child_nodes
set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes
type_wf set_disconnected_nodes set_disconnected_nodes_locs
+ l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_new_character_data
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_character_data_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then
have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2
get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M \<open>parent_child_rel h = parent_child_rel h2\<close>
children_eq2_h finite_set_in finsert_iff funion_finsert_right local.parent_child_rel_child
local.parent_child_rel_parent_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq_h
select_result_I2 subsetD sup_bot.right_neutral)
by (metis assms(1) assms(3) disconnected_nodes_eq2_h document_ptr_kinds_eq_h funionI1
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap
node_ptr_kinds_eq_h returns_result_select_result)
then have "a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
local.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "a_all_ptrs_in_heap h'"
by (smt (verit) character_data_ptr_kinds_commutes children_eq2_h3 disc_nodes_document_ptr_h2
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3
finite_set_in h' h2 local.a_all_ptrs_in_heap_def
local.set_disconnected_nodes_get_disconnected_nodes new_character_data_ptr
new_character_data_ptr_in_heap node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3
object_ptr_kinds_eq_h3 select_result_I2 set_ConsD subset_code(1))
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_character_data_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_character_data_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_character_data_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_character_data_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff local.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr
returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open>local.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok returns_result_select_result)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast new_character_data_ptr \<notin> set disc_nodes_h3\<close>
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
by (smt (verit) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>local.a_all_ptrs_in_heap h\<close> disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 disjoint_iff_not_equal
document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open>a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open>a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(simp add: a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric] disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by (smt (verit) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h' list.set_intros(2)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
have "known_ptr (cast new_character_data_ptr)"
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
local.create_character_data_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_character_data_wf?: l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel set_val set_val_locs set_disconnected_nodes
set_disconnected_nodes_locs create_character_data known_ptrs
using instances
by (auto simp add: l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>create\_document\<close>
locale l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
+ l_new_document_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
create_document
+ l_new_document_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_new_document
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_document :: "((_) heap, exception, (_) document_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_document_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'"
proof -
obtain new_document_ptr where
new_document_ptr: "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr" and
h': "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
using assms(2)
apply(simp add: create_document_def)
using new_document_ok by blast
have "new_document_ptr \<notin> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have "new_document_ptr |\<notin>| document_ptr_kinds h"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr |\<notin>| object_ptr_kinds h"
by simp
have object_ptr_kinds_eq: "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using new_document_new_ptr h' new_document_ptr by blast
then have node_ptr_kinds_eq: "node_ptr_kinds h' = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h' = character_data_ptr_kinds h"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h' = element_ptr_kinds h"
using object_ptr_kinds_eq
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h' = document_ptr_kinds h |\<union>| {|new_document_ptr|}"
using object_ptr_kinds_eq
apply(auto simp add: document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_kinds_commutes document_ptr_kinds_def finsertI1 fset.map_comp)
have children_eq:
"\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h' get_child_nodes_new_document[rotated, OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2: "\<And>ptr'. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
using new_document_ptr h' new_document_ptr_in_heap[OF h' new_document_ptr]
new_document_is_document_ptr[OF new_document_ptr] new_document_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h' get_disconnected_nodes_new_document_different_pointers new_document_ptr
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis(full_types) \<open>\<And>thesis. (\<And>new_document_ptr.
\<lbrakk>h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr; h \<turnstile> new_document \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
local.get_disconnected_nodes_new_document_different_pointers new_document_ptr)+
then have disconnected_nodes_eq2_h: "\<And>doc_ptr. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
using h' local.new_document_no_disconnected_nodes new_document_ptr by blast
have "type_wf h'"
using \<open>type_wf h\<close> new_document_types_preserved h' by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h'"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h'"
by (simp add: object_ptr_kinds_eq)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 empty_iff empty_set image_eqI select_result_I2)
qed
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
using ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> assms(1) children_eq fset_of_list_elem
local.heap_is_wellformed_children_in_heap local.parent_child_rel_child
local.parent_child_rel_parent_in_heap node_ptr_kinds_eq
apply (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 finite_set_in finsert_iff funion_finsert_right object_ptr_kinds_eq
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
\<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> \<open>type_wf h'\<close> assms(1) disconnected_nodes_eq_h
local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap local.parent_child_rel_child
local.parent_child_rel_parent_in_heap
node_ptr_kinds_eq returns_result_select_result select_result_I2)
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
using \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: children_eq2[symmetric] a_distinct_lists_def insort_split object_ptr_kinds_eq
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(auto simp add: dest: distinct_concat_map_E)[1]
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close>
apply(auto simp add: distinct_insort dest: distinct_concat_map_E)[1]
using disconnected_nodes_eq_h
apply (metis assms(1) assms(3) disconnected_nodes_eq2_h local.get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct
returns_result_select_result)
proof -
fix x :: "(_) document_ptr" and y :: "(_) document_ptr" and xa :: "(_) node_ptr"
assume a1: "x \<noteq> y"
assume a2: "x |\<in>| document_ptr_kinds h"
assume a3: "x \<noteq> new_document_ptr"
assume a4: "y |\<in>| document_ptr_kinds h"
assume a5: "y \<noteq> new_document_ptr"
assume a6: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
assume a7: "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a8: "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
have f9: "xa \<in> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a7 a3 disconnected_nodes_eq2_h by presburger
have f10: "xa \<in> set |h \<turnstile> get_disconnected_nodes y|\<^sub>r"
using a8 a5 disconnected_nodes_eq2_h by presburger
have f11: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a4 by simp
have "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a2 by simp
then show False
using f11 f10 f9 a6 a1 by (meson disjoint_iff_not_equal distinct_concat_map_E(1))
next
fix x xa xb
assume 0: "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
and 1: "h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []"
and 2: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
and 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
and 4: "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h). set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 5: "x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
and 7: "xa |\<in>| object_ptr_kinds h"
and 8: "xa \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr"
and 9: "xb |\<in>| document_ptr_kinds h"
and 10: "xb \<noteq> new_document_ptr"
then show "False"
by (metis \<open>local.a_distinct_lists h\<close> assms(3) disconnected_nodes_eq2_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok
returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def)[1]
by (metis \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
children_eq2 disconnected_nodes_eq2_h document_ptr_kinds_commutes finite_set_in
funion_iff node_ptr_kinds_eq object_ptr_kinds_eq)
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_document_wf?: l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
set_val set_val_locs set_disconnected_nodes
set_disconnected_nodes_locs create_document known_ptrs
using instances
by (auto simp add: l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/Core_SC_DOM/common/classes/CharacterDataClass.thy b/thys/Core_SC_DOM/common/classes/CharacterDataClass.thy
--- a/thys/Core_SC_DOM/common/classes/CharacterDataClass.thy
+++ b/thys/Core_SC_DOM/common/classes/CharacterDataClass.thy
@@ -1,355 +1,355 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>CharacterData\<close>
text\<open>In this theory, we introduce the types for the CharacterData class.\<close>
theory CharacterDataClass
imports
ElementClass
begin
subsubsection\<open>CharacterData\<close>
text\<open>The type @{type "DOMString"} is a type synonym for @{type "string"}, defined
\autoref{sec:Core_DOM_Basic_Datatypes}.\<close>
record RCharacterData = RNode +
nothing :: unit
val :: DOMString
register_default_tvars "'CharacterData RCharacterData_ext"
type_synonym 'CharacterData CharacterData = "'CharacterData option RCharacterData_scheme"
register_default_tvars "'CharacterData CharacterData"
type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node,
'Element, 'CharacterData) Node
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
'CharacterData option RCharacterData_ext + 'Node, 'Element) Node"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Node,
'Element, 'CharacterData) Node"
type_synonym ('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node,
'Element, 'CharacterData) Object
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object,
'CharacterData option RCharacterData_ext + 'Node,
'Element) Object"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object,
'Node, 'Element, 'CharacterData) Object"
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap
= "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr, 'shadow_root_ptr,
'Object, 'CharacterData option RCharacterData_ext + 'Node, 'Element) heap"
register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap"
definition character_data_ptr_kinds :: "(_) heap \<Rightarrow> (_) character_data_ptr fset"
where
"character_data_ptr_kinds heap = the |`| (cast |`| (ffilter is_character_data_ptr_kind
(node_ptr_kinds heap)))"
lemma character_data_ptr_kinds_simp [simp]:
"character_data_ptr_kinds (Heap (fmupd (cast character_data_ptr) character_data (the_heap h)))
= {|character_data_ptr|} |\<union>| character_data_ptr_kinds h"
apply(auto simp add: character_data_ptr_kinds_def)[1]
by force
definition character_data_ptrs :: "(_) heap \<Rightarrow> _ character_data_ptr fset"
where
"character_data_ptrs heap = ffilter is_character_data_ptr (character_data_ptr_kinds heap)"
abbreviation "character_data_ptr_exts heap \<equiv> character_data_ptr_kinds heap - character_data_ptrs heap"
definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Node \<Rightarrow> (_) CharacterData option"
where
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = (case RNode.more node of
Inr (Inl character_data) \<Rightarrow> Some (RNode.extend (RNode.truncate node) character_data)
| _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
abbreviation cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) Object \<Rightarrow> (_) CharacterData option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a obj \<equiv> (case cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj of Some node \<Rightarrow> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node
| None \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
definition cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) CharacterData \<Rightarrow> (_) Node"
where
"cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = RNode.extend (RNode.truncate character_data)
(Inr (Inl (RNode.more character_data)))"
adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e
abbreviation cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) CharacterData \<Rightarrow> (_) Object"
where
"cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \<equiv> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr)"
adhoc_overloading cast cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
consts is_character_data_kind :: 'a
definition is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Node \<Rightarrow> bool"
where
"is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \<longleftrightarrow> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \<noteq> None"
adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e
lemmas is_character_data_kind_def = is_character_data_kind\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
abbreviation is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t :: "(_) Object \<Rightarrow> bool"
where
"is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr \<equiv> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr \<noteq> None"
adhoc_overloading is_character_data_kind is_character_data_kind\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
lemma character_data_ptr_kinds_commutes [simp]:
"cast character_data_ptr |\<in>| node_ptr_kinds h
\<longleftrightarrow> character_data_ptr |\<in>| character_data_ptr_kinds h"
apply(auto simp add: character_data_ptr_kinds_def)[1]
by (metis character_data_ptr_casts_commute2 comp_eq_dest_lhs ffmember_filter fimage_eqI
is_character_data_ptr_kind_none
option.distinct(1) option.sel)
definition get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) CharacterData option"
where
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h = Option.bind (get\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr) h) cast"
adhoc_overloading get get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
locale l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (ElementClass.type_wf h
\<and> (\<forall>character_data_ptr \<in> fset (character_data_ptr_kinds h).
get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: "type_wf h \<Longrightarrow> CharacterDataClass.type_wf h"
sublocale l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a \<subseteq> l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
apply(unfold_locales)
using ElementClass.a_type_wf_def
by (meson CharacterDataClass.a_type_wf_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
locale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas = l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
sublocale l_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas by unfold_locales
lemma get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_type_wf:
assumes "type_wf h"
shows "character_data_ptr |\<in>| character_data_ptr_kinds h
\<longleftrightarrow> get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h \<noteq> None"
using l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_axioms assms
apply(simp add: type_wf_defs get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
- by (metis assms bind.bind_lzero character_data_ptr_kinds_commutes fmember.rep_eq
+ by (metis assms bind.bind_lzero character_data_ptr_kinds_commutes fmember_iff_member_fset
local.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf option.exhaust option.simps(3))
end
global_interpretation l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas type_wf
by unfold_locales
definition put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) character_data_ptr \<Rightarrow> (_) CharacterData \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data = put\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast character_data_ptr)
(cast character_data)"
adhoc_overloading put put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap:
assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'"
shows "character_data_ptr |\<in>| character_data_ptr_kinds h'"
using assms put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap
unfolding put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def character_data_ptr_kinds_def
by (metis character_data_ptr_kinds_commutes character_data_ptr_kinds_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap)
lemma put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs:
assumes "put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast character_data_ptr|}"
using assms
by (simp add: put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs)
lemma cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inject [simp]: "cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e x = cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def)
by (metis (full_types) RNode.surjective old.unit.exhaust)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_none [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = None \<longleftrightarrow> \<not> (\<exists>character_data. cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node)"
apply(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def
split: sum.splits)[1]
by (metis (full_types) RNode.select_convs(2) RNode.surjective old.unit.exhaust)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_some [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a node = Some character_data \<longleftrightarrow> cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data = node"
by(auto simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RObject.extend_def RNode.extend_def
split: sum.splits)
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_inv [simp]:
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a (cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data) = Some character_data"
by simp
lemma cast_element_not_character_data [simp]:
"(cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element \<noteq> cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data)"
"(cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e character_data \<noteq> cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e element)"
by(auto simp add: cast\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def RNode.extend_def)
lemma get_CharacterData_simp1 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr character_data h)
= Some character_data"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp2 [simp]:
"character_data_ptr \<noteq> character_data_ptr' \<Longrightarrow> get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr
(put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr' character_data h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp3 [simp]:
"get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h"
by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma get_CharacterData_simp4 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t character_data_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a element_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
abbreviation "create_character_data_obj val_arg
\<equiv> \<lparr> RObject.nothing = (), RNode.nothing = (), RCharacterData.nothing = (), val = val_arg, \<dots> = None \<rparr>"
definition new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a :: "(_) heap \<Rightarrow> ((_) character_data_ptr \<times> (_) heap)"
where
"new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h =
(let new_character_data_ptr = character_data_ptr.Ref (Suc (fMax (character_data_ptr.the_ref
|`| (character_data_ptrs h)))) in
(new_character_data_ptr, put new_character_data_ptr (create_character_data_obj '''') h))"
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "new_character_data_ptr |\<in>| character_data_ptr_kinds h'"
using assms
unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def
using put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_in_heap by blast
lemma new_character_data_ptr_new:
"character_data_ptr.Ref (Suc (fMax (finsert 0 (character_data_ptr.the_ref |`| character_data_ptrs h))))
|\<notin>| character_data_ptrs h"
by (metis Suc_n_not_le_n character_data_ptr.sel(1) fMax_ge fimage_finsert finsertI1
finsertI2 set_finsert)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "new_character_data_ptr |\<notin>| character_data_ptr_kinds h"
using assms
unfolding new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def
by (metis Pair_inject character_data_ptrs_def fMax_finsert fempty_iff ffmember_filter
fimage_is_fempty is_character_data_ptr_ref max_0L new_character_data_ptr_new)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_new_ptr:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using assms
by (metis Pair_inject new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_put_ptrs)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_is_character_data_ptr:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "is_character_data_ptr new_character_data_ptr"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> cast new_character_data_ptr"
shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> cast new_character_data_ptr"
shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
assumes "ptr \<noteq> new_character_data_ptr"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
locale l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = (known_ptr ptr \<or> is_character_data_ptr ptr)"
lemma known_ptr_not_character_data_ptr:
"\<not>is_character_data_ptr ptr \<Longrightarrow> a_known_ptr ptr \<Longrightarrow> known_ptr ptr"
by(simp add: a_known_ptr_def)
end
global_interpretation l_known_ptr\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved known_ptrs_subset known_ptrs_new_ptr l_known_ptrs_def
by blast
end
diff --git a/thys/Core_SC_DOM/common/classes/DocumentClass.thy b/thys/Core_SC_DOM/common/classes/DocumentClass.thy
--- a/thys/Core_SC_DOM/common/classes/DocumentClass.thy
+++ b/thys/Core_SC_DOM/common/classes/DocumentClass.thy
@@ -1,345 +1,345 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Document\<close>
text\<open>In this theory, we introduce the types for the Document class.\<close>
theory DocumentClass
imports
CharacterDataClass
begin
text\<open>The type @{type "doctype"} is a type synonym for @{type "string"}, defined
in \autoref{sec:Core_DOM_Basic_Datatypes}.\<close>
record ('node_ptr, 'element_ptr, 'character_data_ptr) RDocument = RObject +
nothing :: unit
doctype :: doctype
document_element :: "(_) element_ptr option"
disconnected_nodes :: "('node_ptr, 'element_ptr, 'character_data_ptr) node_ptr list"
type_synonym
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_scheme"
register_default_tvars
"('node_ptr, 'element_ptr, 'character_data_ptr, 'Document) Document"
type_synonym
('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr, 'Object, 'Node,
'Element, 'CharacterData, 'Document) Object
= "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option)
RDocument_ext + 'Object, 'Node, 'Element, 'CharacterData) Object"
register_default_tvars "('node_ptr, 'element_ptr, 'character_data_ptr, 'shadow_root_ptr,
'Object, 'Node, 'Element, 'CharacterData, 'Document) Object"
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap
= "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr,
('node_ptr, 'element_ptr, 'character_data_ptr, 'Document option) RDocument_ext + 'Object, 'Node,
'Element, 'CharacterData) heap"
register_default_tvars
"('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit, unit, unit, unit, unit, unit, unit, unit) heap"
definition document_ptr_kinds :: "(_) heap \<Rightarrow> (_) document_ptr fset"
where
"document_ptr_kinds heap = the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`|
(ffilter is_document_ptr_kind (object_ptr_kinds heap)))"
definition document_ptrs :: "(_) heap \<Rightarrow> (_) document_ptr fset"
where
"document_ptrs heap = ffilter is_document_ptr (document_ptr_kinds heap)"
definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) Object \<Rightarrow> (_) Document option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = (case RObject.more obj of
Inr (Inl document) \<Rightarrow> Some (RObject.extend (RObject.truncate obj) document)
| _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
definition cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Document \<Rightarrow> (_) Object"
where
"cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = (RObject.extend (RObject.truncate document)
(Inr (Inl (RObject.more document))))"
adhoc_overloading cast cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
definition is_document_kind :: "(_) Object \<Rightarrow> bool"
where
"is_document_kind ptr \<longleftrightarrow> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr \<noteq> None"
lemma document_ptr_kinds_simp [simp]:
"document_ptr_kinds (Heap (fmupd (cast document_ptr) document (the_heap h)))
= {|document_ptr|} |\<union>| document_ptr_kinds h"
apply(auto simp add: document_ptr_kinds_def)[1]
by force
lemma document_ptr_kinds_commutes [simp]:
"cast document_ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> document_ptr |\<in>| document_ptr_kinds h"
apply(auto simp add: object_ptr_kinds_def document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_casts_commute2 document_ptr_document_ptr_cast
ffmember_filter fimage_eqI fset.map_comp option.sel)
definition get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) Document option"
where
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h = Option.bind (get (cast document_ptr) h) cast"
adhoc_overloading get get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (CharacterDataClass.type_wf h \<and>
(\<forall>document_ptr \<in> fset (document_ptr_kinds h). get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: "type_wf h \<Longrightarrow> DocumentClass.type_wf h"
sublocale l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t \<subseteq> l_type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
apply(unfold_locales)
by (metis (full_types) type_wf_defs l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
locale l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
lemma get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf:
assumes "type_wf h"
shows "document_ptr |\<in>| document_ptr_kinds h \<longleftrightarrow> get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h \<noteq> None"
using l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms assms
apply(simp add: type_wf_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
- by (metis document_ptr_kinds_commutes fmember.rep_eq is_none_bind is_none_simps(1)
+ by (metis document_ptr_kinds_commutes fmember_iff_member_fset is_none_bind is_none_simps(1)
is_none_simps(2) local.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
end
global_interpretation l_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
definition put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_) document_ptr \<Rightarrow> (_) Document \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document = put (cast document_ptr) (cast document)"
adhoc_overloading put put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap:
assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'"
shows "document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
by (metis document_ptr_kinds_commutes put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap)
lemma put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs:
assumes "put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast document_ptr|}"
using assms
by (simp add: put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs)
lemma cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
by (metis (full_types) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = None \<longleftrightarrow> \<not> (\<exists>document. cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document = obj)"
apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def
split: sum.splits)[1]
by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_some [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t obj = Some document \<longleftrightarrow> cast document = obj"
by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def
split: sum.splits)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t (cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document) = Some document"
by simp
lemma cast_document_not_node [simp]:
"cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document \<noteq> cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node"
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node \<noteq> cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t document"
by(auto simp add: cast\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
lemma get_document_ptr_simp1 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr document h) = Some document"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp2 [simp]:
"document_ptr \<noteq> document_ptr'
\<Longrightarrow> get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' document h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp3 [simp]:
"get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr h"
by(auto simp add: get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp4 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma get_document_ptr_simp5 [simp]:
"get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr (put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr f h) = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr h"
by(auto simp add: get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma get_document_ptr_simp6 [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr f h) = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr h"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_element_ptr, h')"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a h = (new_character_data_ptr, h')"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def)
abbreviation
create_document_obj :: "char list \<Rightarrow> (_) element_ptr option \<Rightarrow> (_) node_ptr list \<Rightarrow> (_) Document"
where
"create_document_obj doctype_arg document_element_arg disconnected_nodes_arg
\<equiv> \<lparr> RObject.nothing = (), RDocument.nothing = (), doctype = doctype_arg,
document_element = document_element_arg,
disconnected_nodes = disconnected_nodes_arg, \<dots> = None \<rparr>"
definition new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t :: "(_)heap \<Rightarrow> ((_) document_ptr \<times> (_) heap)"
where
"new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h =
(let new_document_ptr = document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| (document_ptrs h)))))
in
(new_document_ptr, put new_document_ptr (create_document_obj '''' None []) h))"
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "new_document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
using put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap by blast
lemma new_document_ptr_new:
"document_ptr.Ref (Suc (fMax (finsert 0 (document_ptr.the_ref |`| document_ptrs h))))
|\<notin>| document_ptrs h"
by (metis Suc_n_not_le_n document_ptr.sel(1) fMax_ge fimage_finsert finsertI1 finsertI2 set_finsert)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "new_document_ptr |\<notin>| document_ptr_kinds h"
using assms
unfolding new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
by (metis Pair_inject document_ptrs_def fMax_finsert fempty_iff ffmember_filter
fimage_is_fempty is_document_ptr_ref max_0L new_document_ptr_new)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using assms
by (metis Pair_inject new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_put_ptrs)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "is_document_ptr new_document_ptr"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
assumes "ptr \<noteq> cast new_document_ptr"
shows "get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h = get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr h'"
using assms
apply(simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
shows "get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h = get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
lemma new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t [simp]:
assumes "new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h = (new_document_ptr, h')"
assumes "ptr \<noteq> new_document_ptr"
shows "get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h = get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr h'"
using assms
by(auto simp add: new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def)
locale l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = (known_ptr ptr \<or> is_document_ptr ptr)"
lemma known_ptr_not_document_ptr: "\<not>is_document_ptr ptr \<Longrightarrow> a_known_ptr ptr \<Longrightarrow> known_ptr ptr"
by(simp add: a_known_ptr_def)
end
global_interpretation l_known_ptr\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs [instances]: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset known_ptrs_new_ptr
by blast
end
diff --git a/thys/Core_SC_DOM/common/classes/NodeClass.thy b/thys/Core_SC_DOM/common/classes/NodeClass.thy
--- a/thys/Core_SC_DOM/common/classes/NodeClass.thy
+++ b/thys/Core_SC_DOM/common/classes/NodeClass.thy
@@ -1,209 +1,209 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Node\<close>
text\<open>In this theory, we introduce the types for the Node class.\<close>
theory NodeClass
imports
ObjectClass
"../pointers/NodePointer"
begin
subsubsection\<open>Node\<close>
record RNode = RObject
+ nothing :: unit
register_default_tvars "'Node RNode_ext"
type_synonym 'Node Node = "'Node RNode_scheme"
register_default_tvars "'Node Node"
type_synonym ('Object, 'Node) Object = "('Node RNode_ext + 'Object) Object"
register_default_tvars "('Object, 'Node) Object"
type_synonym ('object_ptr, 'node_ptr, 'Object, 'Node) heap
= "('node_ptr node_ptr + 'object_ptr, 'Node RNode_ext + 'Object) heap"
register_default_tvars
"('object_ptr, 'node_ptr, 'Object, 'Node) heap"
type_synonym heap\<^sub>f\<^sub>i\<^sub>n\<^sub>a\<^sub>l = "(unit, unit, unit, unit) heap"
definition node_ptr_kinds :: "(_) heap \<Rightarrow> (_) node_ptr fset"
where
"node_ptr_kinds heap =
(the |`| (cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r |`| (ffilter is_node_ptr_kind (object_ptr_kinds heap))))"
lemma node_ptr_kinds_simp [simp]:
"node_ptr_kinds (Heap (fmupd (cast node_ptr) node (the_heap h)))
= {|node_ptr|} |\<union>| node_ptr_kinds h"
apply(auto simp add: node_ptr_kinds_def)[1]
by force
definition cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) Object \<Rightarrow> (_) Node option"
where
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = (case RObject.more obj of Inl node
\<Rightarrow> Some (RObject.extend (RObject.truncate obj) node) | _ \<Rightarrow> None)"
adhoc_overloading cast cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e
definition cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:: "(_) Node \<Rightarrow> (_) Object"
where
"cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = (RObject.extend (RObject.truncate node) (Inl (RObject.more node)))"
adhoc_overloading cast cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
definition is_node_kind :: "(_) Object \<Rightarrow> bool"
where
"is_node_kind ptr \<longleftrightarrow> cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr \<noteq> None"
definition get\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \<Rightarrow> (_) heap \<Rightarrow> (_) Node option"
where
"get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h = Option.bind (get (cast node_ptr) h) cast"
adhoc_overloading get get\<^sub>N\<^sub>o\<^sub>d\<^sub>e
locale l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
definition a_type_wf :: "(_) heap \<Rightarrow> bool"
where
"a_type_wf h = (ObjectClass.type_wf h
\<and> (\<forall>node_ptr \<in> fset( node_ptr_kinds h). get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \<noteq> None))"
end
global_interpretation l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines type_wf = a_type_wf .
lemmas type_wf_defs = a_type_wf_def
locale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_type_wf type_wf for type_wf :: "((_) heap \<Rightarrow> bool)" +
assumes type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e: "type_wf h \<Longrightarrow> NodeClass.type_wf h"
sublocale l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e \<subseteq> l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
apply(unfold_locales)
using ObjectClass.a_type_wf_def by auto
locale l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas = l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
sublocale l_get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas by unfold_locales
lemma get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf:
assumes "type_wf h"
shows "node_ptr |\<in>| node_ptr_kinds h \<longleftrightarrow> get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h \<noteq> None"
using l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_axioms assms
apply(simp add: type_wf_defs get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def l_type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
- by (metis bind_eq_None_conv ffmember_filter fimage_eqI fmember.rep_eq is_node_ptr_kind_cast
+ by (metis bind_eq_None_conv ffmember_filter fimage_eqI fmember_iff_member_fset is_node_ptr_kind_cast
get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf node_ptr_casts_commute2 node_ptr_kinds_def option.sel option.simps(3))
end
global_interpretation l_get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_lemmas type_wf
by unfold_locales
definition put\<^sub>N\<^sub>o\<^sub>d\<^sub>e :: "(_) node_ptr \<Rightarrow> (_) Node \<Rightarrow> (_) heap \<Rightarrow> (_) heap"
where
"put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node = put (cast node_ptr) (cast node)"
adhoc_overloading put put\<^sub>N\<^sub>o\<^sub>d\<^sub>e
lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_ptr_in_heap:
assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'"
shows "node_ptr |\<in>| node_ptr_kinds h'"
using assms
unfolding put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def node_ptr_kinds_def
by (metis ffmember_filter fimage_eqI is_node_ptr_kind_cast node_ptr_casts_commute2
option.sel put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap)
lemma put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_put_ptrs:
assumes "put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h = h'"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast node_ptr|}"
using assms
by (simp add: put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_put_ptrs)
lemma node_ptr_kinds_commutes [simp]:
"cast node_ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> node_ptr |\<in>| node_ptr_kinds h"
apply(auto simp add: node_ptr_kinds_def split: option.splits)[1]
by (metis (no_types, lifting) ffmember_filter fimage_eqI fset.map_comp
is_node_ptr_kind_none node_ptr_casts_commute2
option.distinct(1) option.sel)
lemma node_empty [simp]:
"\<lparr>RObject.nothing = (), RNode.nothing = (), \<dots> = RNode.more node\<rparr> = node"
by simp
lemma cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_inject [simp]: "cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t x = cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t y \<longleftrightarrow> x = y"
apply(simp add: cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def)
by (metis (full_types) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_none [simp]:
"cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = None \<longleftrightarrow> \<not> (\<exists>node. cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node = obj)"
apply(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits)[1]
by (metis (full_types) RObject.select_convs(2) RObject.surjective old.unit.exhaust)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_some [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e obj = Some node \<longleftrightarrow> cast node = obj"
by(auto simp add: cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def RObject.extend_def split: sum.splits)
lemma cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e_inv [simp]: "cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>N\<^sub>o\<^sub>d\<^sub>e (cast\<^sub>N\<^sub>o\<^sub>d\<^sub>e\<^sub>2\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t node) = Some node"
by simp
locale l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e
begin
definition a_known_ptr :: "(_) object_ptr \<Rightarrow> bool"
where
"a_known_ptr ptr = False"
end
global_interpretation l_known_ptr\<^sub>N\<^sub>o\<^sub>d\<^sub>e defines known_ptr = a_known_ptr .
lemmas known_ptr_defs = a_known_ptr_def
locale l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e = l_known_ptr known_ptr for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
begin
definition a_known_ptrs :: "(_) heap \<Rightarrow> bool"
where
"a_known_ptrs h = (\<forall>ptr \<in> fset (object_ptr_kinds h). known_ptr ptr)"
lemma known_ptrs_known_ptr: "a_known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptr ptr"
apply(simp add: a_known_ptrs_def)
using notin_fset by fastforce
lemma known_ptrs_preserved:
"object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> a_known_ptrs h = a_known_ptrs h'"
by(auto simp add: a_known_ptrs_def)
lemma known_ptrs_subset:
"object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h \<Longrightarrow> a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def less_eq_fset.rep_eq subsetD)
lemma known_ptrs_new_ptr:
"object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|new_ptr|} \<Longrightarrow> known_ptr new_ptr \<Longrightarrow>
a_known_ptrs h \<Longrightarrow> a_known_ptrs h'"
by(simp add: a_known_ptrs_def)
end
global_interpretation l_known_ptrs\<^sub>N\<^sub>o\<^sub>d\<^sub>e known_ptr defines known_ptrs = a_known_ptrs .
lemmas known_ptrs_defs = a_known_ptrs_def
lemma known_ptrs_is_l_known_ptrs: "l_known_ptrs known_ptr known_ptrs"
using known_ptrs_known_ptr known_ptrs_preserved l_known_ptrs_def known_ptrs_subset
known_ptrs_new_ptr
by blast
lemma get_node_ptr_simp1 [simp]: "get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr node h) = Some node"
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
lemma get_node_ptr_simp2 [simp]:
"node_ptr \<noteq> node_ptr' \<Longrightarrow> get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr (put\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr' node h) = get\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr h"
by(auto simp add: get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def)
end
diff --git a/thys/Core_SC_DOM/common/monads/DocumentMonad.thy b/thys/Core_SC_DOM/common/monads/DocumentMonad.thy
--- a/thys/Core_SC_DOM/common/monads/DocumentMonad.thy
+++ b/thys/Core_SC_DOM/common/monads/DocumentMonad.thy
@@ -1,614 +1,614 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Document\<close>
text\<open>In this theory, we introduce the monadic method setup for the Document class.\<close>
theory DocumentMonad
imports
CharacterDataMonad
"../classes/DocumentClass"
begin
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog
= "((_) heap, exception, 'result) prog"
register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'result) dom_prog"
global_interpretation l_ptr_kinds_M document_ptr_kinds defines document_ptr_kinds_M = a_ptr_kinds_M .
lemmas document_ptr_kinds_M_defs = a_ptr_kinds_M_def
lemma document_ptr_kinds_M_eq:
assumes "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
shows "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using assms
by(auto simp add: document_ptr_kinds_M_defs object_ptr_kinds_M_defs document_ptr_kinds_def)
lemma document_ptr_kinds_M_reads:
"reads (\<Union>object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) document_ptr_kinds_M h h'"
using object_ptr_kinds_M_reads
apply (simp add: reads_def object_ptr_kinds_M_defs document_ptr_kinds_M_defs
document_ptr_kinds_def preserved_def cong del: image_cong_simp)
apply (metis (mono_tags, opaque_lifting) object_ptr_kinds_preserved_small old.unit.exhaust preserved_def)
done
global_interpretation l_dummy defines get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = "l_get_M.a_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" .
lemma get_M_is_l_get_M: "l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds"
apply(simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf l_get_M_def)
by (metis ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf ObjectClass.type_wf_defs bind_eq_None_conv
document_ptr_kinds_commutes get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def option.simps(3))
lemmas get_M_defs = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]]
adhoc_overloading get_M get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_get_M get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t type_wf document_ptr_kinds
apply(unfold_locales)
apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def)
lemmas get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = get_M_ok[folded get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def]
end
global_interpretation l_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
global_interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
rewrites "a_get_M = get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t" defines put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t = a_put_M
apply (simp add: get_M_is_l_get_M l_put_M_def)
by (simp add: get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def)
lemmas put_M_defs = a_put_M_def
adhoc_overloading put_M put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
locale l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas = l_type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
begin
sublocale l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_put_M type_wf document_ptr_kinds get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
apply(unfold_locales)
apply (simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_type_wf local.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
by (meson DocumentMonad.get_M_is_l_get_M l_get_M_def)
lemmas put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok = put_M_ok[folded put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def]
end
global_interpretation l_put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas type_wf by unfold_locales
lemma document_put_get [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = v)
\<Longrightarrow> h' \<turnstile> get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter \<rightarrow>\<^sub>r v"
by(auto simp add: put_M_defs get_M_defs split: option.splits)
lemma get_M_Mdocument_preserved1 [simp]:
"document_ptr \<noteq> document_ptr'
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'"
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma document_put_get_preserved [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = getter x)
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr' getter) h h'"
apply(cases "document_ptr = document_ptr'")
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved2 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved3 [simp]:
"cast document_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved4 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast document_ptr \<noteq> object_ptr")[1]
by(auto simp add: put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
ObjectMonad.get_M_defs preserved_def
split: option.splits bind_splits dest: get_heap_E)
lemma get_M_Mdocument_preserved5 [simp]:
"cast document_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved6 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'"
by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved7 [simp]:
"h \<turnstile> put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved8 [simp]:
"h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'"
by(auto simp add: put_M_defs CharacterDataMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved9 [simp]:
"h \<turnstile> put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: CharacterDataMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mdocument_preserved10 [simp]:
"(\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast document_ptr = object_ptr")
by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv
split: option.splits)
lemma new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_element_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_character_data_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_character_data_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
subsection \<open>Creating Documents\<close>
definition new_document :: "(_, (_) document_ptr) dom_prog"
where
"new_document = do {
h \<leftarrow> get_heap;
(new_ptr, h') \<leftarrow> return (new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t h);
return_heap h';
return new_ptr
}"
lemma new_document_ok [simp]:
"h \<turnstile> ok new_document"
by(auto simp add: new_document_def split: prod.splits)
lemma new_document_ptr_in_heap:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "new_document_ptr |\<in>| document_ptr_kinds h'"
using assms
unfolding new_document_def
by(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap is_OK_returns_result_I
elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_ptr_not_in_heap:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "new_document_ptr |\<notin>| document_ptr_kinds h"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_not_in_heap
by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_new_ptr:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_new_ptr
by(auto simp add: new_document_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_is_document_ptr:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "is_document_ptr new_document_ptr"
using assms new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_is_document_ptr
by(auto simp add: new_document_def elim!: bind_returns_result_E split: prod.splits)
lemma new_document_doctype:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr doctype \<rightarrow>\<^sub>r ''''"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_document_element:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr document_element \<rightarrow>\<^sub>r None"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_disconnected_nodes:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
shows "h' \<turnstile> get_M new_document_ptr disconnected_nodes \<rightarrow>\<^sub>r []"
using assms
by(auto simp add: get_M_defs new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> ptr \<noteq> cast new_document_ptr \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def ObjectMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'"
by(auto simp add: new_document_def NodeMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def ElementMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'"
by(auto simp add: new_document_def CharacterDataMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> ptr \<noteq> new_document_ptr
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
subsection \<open>Modified Heaps\<close>
lemma get_document_ptr_simp [simp]:
"get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)
= (if ptr = cast document_ptr then cast obj else get document_ptr h)"
by(auto simp add: get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def split: option.splits Option.bind_splits)
lemma document_ptr_kidns_simp [simp]:
"document_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)
= document_ptr_kinds h |\<union>| (if is_document_ptr_kind ptr then {|the (cast ptr)|} else {||})"
by(auto simp add: document_ptr_kinds_def split: option.splits)
lemma type_wf_put_I:
assumes "type_wf h"
assumes "CharacterDataClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "is_document_ptr_kind ptr \<Longrightarrow> is_document_kind obj"
shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
using assms
by(auto simp add: type_wf_defs is_document_kind_def split: option.splits)
lemma type_wf_put_ptr_not_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<notin>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_not_in_heap_E
split: option.splits if_splits)
lemma type_wf_put_ptr_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "CharacterDataClass.type_wf h"
assumes "is_document_ptr_kind ptr \<Longrightarrow> is_document_kind (the (get ptr h))"
shows "type_wf h"
using assms
apply(auto simp add: type_wf_defs elim!: CharacterDataMonad.type_wf_put_ptr_in_heap_E
split: option.splits if_splits)[1]
by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf bind.bind_lunit get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
is_document_kind_def notin_fset option.exhaust_sel)
subsection \<open>Preserving Types\<close>
lemma new_element_type_wf_preserved [simp]:
"h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: new_element_def new\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def element_ptrs_def
elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: if_splits)[1]
apply fastforce
by (metis Suc_n_not_le_n element_ptr.sel(1) element_ptrs_def fMax_ge ffmember_filter
fimage_eqI is_element_ptr_ref)
lemma new_element_is_l_new_element [instances]:
"l_new_element type_wf"
using l_new_element.intro new_element_type_wf_preserved
by blast
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_name_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr tag_name_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs NodeClass.type_wf_defs
ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr child_nodes_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr attrs_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]:
"h \<turnstile> put_M element_ptr shadow_root_opt_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis NodeClass.a_type_wf_def NodeClass.get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_type_wf ObjectClass.a_type_wf_def
bind.bind_lzero finite_set_in get\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def l_type_wf_def\<^sub>N\<^sub>o\<^sub>d\<^sub>e.a_type_wf_def option.collapse
option.distinct(1) option.simps(3))
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma new_character_data_type_wf_preserved [simp]:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: ElementMonad.put_M_defs put\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_kind_def
new_character_data_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def Let_def put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
dest!: get_heap_E
elim!: bind_returns_heap_E2 bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
by (meson new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def new\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_ptr_not_in_heap)
lemma new_character_data_is_l_new_character_data [instances]:
"l_new_character_data type_wf"
using l_new_character_data.intro new_character_data_type_wf_preserved
by blast
lemma put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_val_type_wf_preserved [simp]:
"h \<turnstile> put_M character_data_ptr val_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: CharacterDataMonad.put_M_defs put\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_kind_def
dest!: get_heap_E elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I ElementMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_node_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs CharacterDataMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply (metis bind.bind_lzero finite_set_in get\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_def option.distinct(1) option.exhaust_sel)
by (metis finite_set_in)
lemma new_document_type_wf_preserved [simp]: "h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: new_document_def new\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def Let_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_ptr_kind_none
elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I ElementMonad.type_wf_put_I CharacterDataMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: if_splits)[1]
apply(auto simp add: type_wf_defs ElementClass.type_wf_defs CharacterDataClass.type_wf_defs
NodeClass.type_wf_defs ObjectClass.type_wf_defs is_document_kind_def
split: option.splits)[1]
using document_ptrs_def apply fastforce
apply (simp add: is_document_kind_def)
apply (metis Suc_n_not_le_n document_ptr.sel(1) document_ptrs_def fMax_ge ffmember_filter
fimage_eqI is_document_ptr_ref)
done
locale l_new_document = l_type_wf +
assumes new_document_types_preserved: "h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma new_document_is_l_new_document [instances]: "l_new_document type_wf"
using l_new_document.intro new_document_type_wf_preserved
by blast
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_doctype_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr doctype_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
apply(auto simp add: get_M_defs)[1]
by (metis (mono_tags) error_returns_result finite_set_in option.exhaust_sel option.simps(4))
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_document_element_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr document_element_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t is_node_ptr_kind_none
cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I
ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: get_M_defs is_document_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs
split: option.splits)[1]
by (metis finite_set_in)
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_disconnected_nodes_type_wf_preserved [simp]:
"h \<turnstile> put_M document_ptr disconnected_nodes_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: put_M_defs put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
DocumentClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a
DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
DocumentClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e
DocumentClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_ptr_kind_none
cast\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>2\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_none is_document_kind_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I
ObjectMonad.type_wf_put_I)[1]
apply(auto simp add: is_document_kind_def get_M_defs type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs split: option.splits)[1]
by (metis finite_set_in)
lemma document_ptr_kinds_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "document_ptr_kinds h = document_ptr_kinds h'"
by(simp add: document_ptr_kinds_def preserved_def object_ptr_kinds_preserved_small[OF assms])
lemma document_ptr_kinds_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h'. \<forall>w \<in> SW. h \<turnstile> w \<rightarrow>\<^sub>h h'
\<longrightarrow> (\<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')"
shows "document_ptr_kinds h = document_ptr_kinds h'"
using writes_small_big[OF assms]
apply(simp add: reflp_def transp_def preserved_def document_ptr_kinds_def)
by (metis assms object_ptr_kinds_preserved)
lemma type_wf_preserved_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>character_data_ptr. preserved
(get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
shows "DocumentClass.type_wf h = DocumentClass.type_wf h'"
using type_wf_preserved_small[OF assms(1) assms(2) assms(3) assms(4)]
allI[OF assms(5), of id, simplified] document_ptr_kinds_small[OF assms(1)]
apply(auto simp add: type_wf_defs )[1]
apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)]
split: option.splits)[1]
apply force
apply(auto simp add: type_wf_defs preserved_def get_M_defs document_ptr_kinds_small[OF assms(1)]
split: option.splits)[1]
by force
lemma type_wf_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>character_data_ptr. preserved
(get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
shows "DocumentClass.type_wf h = DocumentClass.type_wf h'"
proof -
have "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> DocumentClass.type_wf h = DocumentClass.type_wf h'"
using assms type_wf_preserved_small by fast
with assms(1) assms(2) show ?thesis
apply(rule writes_small_big)
by(auto simp add: reflp_def transp_def)
qed
lemma type_wf_drop: "type_wf h \<Longrightarrow> type_wf (Heap (fmdrop ptr (the_heap h)))"
apply(auto simp add: type_wf_defs)[1]
using type_wf_drop
apply blast
by (metis (no_types, lifting) CharacterDataClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf CharacterDataMonad.type_wf_drop
document_ptr_kinds_commutes finite_set_in fmlookup_drop get\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def heap.sel)
end
diff --git a/thys/Core_SC_DOM/common/monads/ObjectMonad.thy b/thys/Core_SC_DOM/common/monads/ObjectMonad.thy
--- a/thys/Core_SC_DOM/common/monads/ObjectMonad.thy
+++ b/thys/Core_SC_DOM/common/monads/ObjectMonad.thy
@@ -1,258 +1,258 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Object\<close>
text\<open>In this theory, we introduce the monadic method setup for the Object class.\<close>
theory ObjectMonad
imports
BaseMonad
"../classes/ObjectClass"
begin
type_synonym ('object_ptr, 'Object, 'result) dom_prog
= "((_) heap, exception, 'result) prog"
register_default_tvars "('object_ptr, 'Object, 'result) dom_prog"
global_interpretation l_ptr_kinds_M object_ptr_kinds defines object_ptr_kinds_M = a_ptr_kinds_M .
lemmas object_ptr_kinds_M_defs = a_ptr_kinds_M_def
global_interpretation l_dummy defines get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = "l_get_M.a_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t" .
lemma get_M_is_l_get_M: "l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds"
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_get_M_def)
lemmas get_M_defs = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]]
adhoc_overloading get_M get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
locale l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
begin
interpretation l_get_M get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t type_wf object_ptr_kinds
apply(unfold_locales)
apply (simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf local.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t)
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = get_M_ok[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
lemmas get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = get_M_ptr_in_heap[folded get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
end
global_interpretation l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf
by (simp add: l_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms)
lemma object_ptr_kinds_M_reads:
"reads (\<Union>object_ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing)}) object_ptr_kinds_M h h'"
apply(auto simp add: object_ptr_kinds_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf type_wf_defs reads_def
preserved_def get_M_defs
split: option.splits)[1]
using a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf by blast+
global_interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
rewrites "a_get_M = get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t"
defines put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t = a_put_M
apply (simp add: get_M_is_l_get_M l_put_M_def)
by (simp add: get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def)
lemmas put_M_defs = a_put_M_def
adhoc_overloading put_M put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
locale l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas = l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
begin
interpretation l_put_M type_wf object_ptr_kinds get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
apply(unfold_locales)
using get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t local.l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms apply blast
by (simp add: a_type_wf_def get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf)
lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok = put_M_ok[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
lemmas put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap = put_M_ptr_in_heap[folded put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def]
end
global_interpretation l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas type_wf
by (simp add: l_put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_lemmas_def l_type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_axioms)
definition check_in_heap :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog"
where
"check_in_heap ptr = do {
h \<leftarrow> get_heap;
(if ptr |\<in>| object_ptr_kinds h then
return ()
else
error SegmentationFault
)}"
lemma check_in_heap_ptr_in_heap: "ptr |\<in>| object_ptr_kinds h \<longleftrightarrow> h \<turnstile> ok (check_in_heap ptr)"
by(auto simp add: check_in_heap_def)
lemma check_in_heap_pure [simp]: "pure (check_in_heap ptr) h"
by(auto simp add: check_in_heap_def intro!: bind_pure_I)
lemma check_in_heap_is_OK [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (check_in_heap ptr \<bind> f) = h \<turnstile> ok (f ())"
by(simp add: check_in_heap_def)
lemma check_in_heap_returns_result [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> (check_in_heap ptr \<bind> f) \<rightarrow>\<^sub>r x = h \<turnstile> f () \<rightarrow>\<^sub>r x"
by(simp add: check_in_heap_def)
lemma check_in_heap_returns_heap [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> h \<turnstile> (check_in_heap ptr \<bind> f) \<rightarrow>\<^sub>h h' = h \<turnstile> f () \<rightarrow>\<^sub>h h'"
by(simp add: check_in_heap_def)
lemma check_in_heap_reads:
"reads {preserved (get_M object_ptr nothing)} (check_in_heap object_ptr) h h'"
apply(simp add: check_in_heap_def reads_def preserved_def)
by (metis a_type_wf_def get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ok get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_ptr_in_heap is_OK_returns_result_E
is_OK_returns_result_I unit_all_impI)
subsection\<open>Invoke\<close>
fun invoke_rec :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog)) list \<Rightarrow> (_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog"
where
"invoke_rec ((P, f)#xs) ptr args = (if P ptr then f ptr args else invoke_rec xs ptr args)"
| "invoke_rec [] ptr args = error InvokeError"
definition invoke :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> 'args
\<Rightarrow> (_, 'result) dom_prog)) list
\<Rightarrow> (_) object_ptr \<Rightarrow> 'args \<Rightarrow> (_, 'result) dom_prog"
where
"invoke xs ptr args = do { check_in_heap ptr; invoke_rec xs ptr args}"
lemma invoke_split: "P (invoke ((Pred, f) # xs) ptr args) =
((\<not>(Pred ptr) \<longrightarrow> P (invoke xs ptr args))
\<and> (Pred ptr \<longrightarrow> P (do {check_in_heap ptr; f ptr args})))"
by(simp add: invoke_def)
lemma invoke_split_asm: "P (invoke ((Pred, f) # xs) ptr args) =
(\<not>((\<not>(Pred ptr) \<and> (\<not> P (invoke xs ptr args)))
\<or> (Pred ptr \<and> (\<not> P (do {check_in_heap ptr; f ptr args})))))"
by(simp add: invoke_def)
lemmas invoke_splits = invoke_split invoke_split_asm
lemma invoke_ptr_in_heap: "h \<turnstile> ok (invoke xs ptr args) \<Longrightarrow> ptr |\<in>| object_ptr_kinds h"
by (metis bind_is_OK_E check_in_heap_ptr_in_heap invoke_def is_OK_returns_heap_I)
lemma invoke_pure [simp]: "pure (invoke [] ptr args) h"
by(auto simp add: invoke_def intro!: bind_pure_I)
lemma invoke_is_OK [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> ok (invoke ((Pred, f) # xs) ptr args) = h \<turnstile> ok (f ptr args)"
by(simp add: invoke_def)
lemma invoke_returns_result [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> (invoke ((Pred, f) # xs) ptr args) \<rightarrow>\<^sub>r x = h \<turnstile> f ptr args \<rightarrow>\<^sub>r x"
by(simp add: invoke_def)
lemma invoke_returns_heap [simp]:
"ptr |\<in>| object_ptr_kinds h \<Longrightarrow> Pred ptr
\<Longrightarrow> h \<turnstile> (invoke ((Pred, f) # xs) ptr args) \<rightarrow>\<^sub>h h' = h \<turnstile> f ptr args \<rightarrow>\<^sub>h h'"
by(simp add: invoke_def)
lemma invoke_not [simp]: "\<not>Pred ptr \<Longrightarrow> invoke ((Pred, f) # xs) ptr args = invoke xs ptr args"
by(auto simp add: invoke_def)
lemma invoke_empty [simp]: "\<not>h \<turnstile> ok (invoke [] ptr args)"
by(auto simp add: invoke_def check_in_heap_def)
lemma invoke_empty_reads [simp]: "\<forall>P \<in> S. reflp P \<and> transp P \<Longrightarrow> reads S (invoke [] ptr args) h h'"
apply(simp add: invoke_def reads_def preserved_def)
by (meson bind_returns_result_E error_returns_result)
subsection\<open>Modified Heaps\<close>
lemma get_object_ptr_simp [simp]:
"get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = (if ptr = object_ptr then Some obj else get object_ptr h)"
by(auto simp add: get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits Option.bind_splits)
lemma object_ptr_kinds_simp [simp]: "object_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = object_ptr_kinds h |\<union>| {|ptr|}"
by(auto simp add: object_ptr_kinds_def put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: option.splits)
lemma type_wf_put_I:
assumes "type_wf h"
shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
using assms
by(auto simp add: type_wf_defs split: option.splits)
lemma type_wf_put_ptr_not_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<notin>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs split: option.splits if_splits)
lemma type_wf_put_ptr_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs split: option.splits if_splits)
subsection\<open>Preserving Types\<close>
lemma type_wf_preserved: "type_wf h = type_wf h'"
by(auto simp add: type_wf_defs)
lemma object_ptr_kinds_preserved_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms
apply(auto simp add: object_ptr_kinds_def preserved_def get_M_defs get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def
split: option.splits)[1]
- apply (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq
+ apply (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember_iff_member_fset
old.unit.exhaust option.case_eq_if return_returns_result)
- by (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember.rep_eq
+ by (metis (mono_tags, lifting) domIff error_returns_result fmdom.rep_eq fmember_iff_member_fset
old.unit.exhaust option.case_eq_if return_returns_result)
lemma object_ptr_kinds_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' w object_ptr. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
proof -
{
fix object_ptr w
have "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
apply(rule writes_small_big[OF assms])
by auto
}
then show ?thesis
using object_ptr_kinds_preserved_small by blast
qed
lemma reads_writes_preserved2:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' x. \<forall>w \<in> SW. h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
shows "preserved (get_M ptr getter) h h'"
apply(clarsimp simp add: preserved_def)
using reads_singleton assms(1) assms(2)
apply(rule reads_writes_preserved)
using assms(3)
by(auto simp add: preserved_def)
end
diff --git a/thys/Core_SC_DOM/safely_composable/Core_DOM_Heap_WF.thy b/thys/Core_SC_DOM/safely_composable/Core_DOM_Heap_WF.thy
--- a/thys/Core_SC_DOM/safely_composable/Core_DOM_Heap_WF.thy
+++ b/thys/Core_SC_DOM/safely_composable/Core_DOM_Heap_WF.thy
@@ -1,6965 +1,6965 @@
(***********************************************************************************
* Copyright (c) 2016-2018 The University of Sheffield, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Wellformedness\<close>
text\<open>In this theory, we discuss the wellformedness of the DOM. First, we define
wellformedness and, second, we show for all functions for querying and modifying the
DOM to what extend they preserve wellformendess.\<close>
theory Core_DOM_Heap_WF
imports
"Core_DOM_Functions"
begin
locale l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_owner_document_valid :: "(_) heap \<Rightarrow> bool"
where
"a_owner_document_valid h \<longleftrightarrow> (\<forall>node_ptr \<in> fset (node_ptr_kinds h).
((\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
\<or> (\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)))"
lemma a_owner_document_valid_code [code]: "a_owner_document_valid h \<longleftrightarrow> node_ptr_kinds h |\<subseteq>|
fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)) @
map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))
"
apply(auto simp add: a_owner_document_valid_def l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_owner_document_valid_def)[1]
proof -
fix x
assume 1: " \<forall>node_ptr\<in>fset (node_ptr_kinds h).
(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
assume 2: "x |\<in>| node_ptr_kinds h"
assume 3: "x |\<notin>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
have "\<not>(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and> x \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using 1 2 3
by (smt UN_I fset_of_list_elem image_eqI notin_fset set_concat set_map sorted_list_of_fset_simps(1))
then
have "(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> x \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using 1 2
by auto
then obtain parent_ptr where parent_ptr: "parent_ptr |\<in>| object_ptr_kinds h \<and>
x \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
by auto
moreover have "parent_ptr \<in> set (sorted_list_of_fset (object_ptr_kinds h))"
using parent_ptr by auto
moreover have "|h \<turnstile> get_child_nodes parent_ptr|\<^sub>r \<in> set (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))"
using calculation(2) by auto
ultimately
show "x |\<in>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h))))"
using fset_of_list_elem by fastforce
next
fix node_ptr
assume 1: "node_ptr_kinds h |\<subseteq>| fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))) |\<union>|
fset_of_list (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
assume 2: "node_ptr |\<in>| node_ptr_kinds h"
assume 3: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<longrightarrow> node_ptr \<notin> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
have "node_ptr \<in> set (concat (map (\<lambda>parent. |h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))) \<or>
node_ptr \<in> set (concat (map (\<lambda>parent. |h \<turnstile> get_disconnected_nodes parent|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h))))"
using 1 2
by (meson fin_mono fset_of_list_elem funion_iff)
then
show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using 3
by auto
qed
definition a_parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
where
"a_parent_child_rel h = {(parent, child). parent |\<in>| object_ptr_kinds h
\<and> child \<in> cast ` set |h \<turnstile> get_child_nodes parent|\<^sub>r}"
lemma a_parent_child_rel_code [code]: "a_parent_child_rel h = set (concat (map
(\<lambda>parent. map
(\<lambda>child. (parent, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child))
|h \<turnstile> get_child_nodes parent|\<^sub>r)
(sorted_list_of_fset (object_ptr_kinds h)))
)"
by(auto simp add: a_parent_child_rel_def)
definition a_acyclic_heap :: "(_) heap \<Rightarrow> bool"
where
"a_acyclic_heap h = acyclic (a_parent_child_rel h)"
definition a_all_ptrs_in_heap :: "(_) heap \<Rightarrow> bool"
where
"a_all_ptrs_in_heap h \<longleftrightarrow>
(\<forall>ptr \<in> fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes ptr|\<^sub>r \<subseteq> fset (node_ptr_kinds h)) \<and>
(\<forall>document_ptr \<in> fset (document_ptr_kinds h).
set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r \<subseteq> fset (node_ptr_kinds h))"
definition a_distinct_lists :: "(_) heap \<Rightarrow> bool"
where
"a_distinct_lists h = distinct (concat (
(map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)
@ (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r)
))"
definition a_heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
where
"a_heap_is_wellformed h \<longleftrightarrow>
a_acyclic_heap h \<and> a_all_ptrs_in_heap h \<and> a_distinct_lists h \<and> a_owner_document_valid h"
end
locale l_heap_is_wellformed_defs =
fixes heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
fixes parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
global_interpretation l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
defines heap_is_wellformed = "l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_heap_is_wellformed get_child_nodes
get_disconnected_nodes"
and parent_child_rel = "l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_parent_child_rel get_child_nodes"
and acyclic_heap = a_acyclic_heap
and all_ptrs_in_heap = a_all_ptrs_in_heap
and distinct_lists = a_distinct_lists
and owner_document_valid = a_owner_document_valid
.
locale l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
+ l_heap_is_wellformed_defs heap_is_wellformed parent_child_rel
+ l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set" +
assumes heap_is_wellformed_impl: "heap_is_wellformed = a_heap_is_wellformed"
assumes parent_child_rel_impl: "parent_child_rel = a_parent_child_rel"
begin
lemmas heap_is_wellformed_def = heap_is_wellformed_impl[unfolded a_heap_is_wellformed_def]
lemmas parent_child_rel_def = parent_child_rel_impl[unfolded a_parent_child_rel_def]
lemmas acyclic_heap_def = a_acyclic_heap_def[folded parent_child_rel_impl]
lemma parent_child_rel_node_ptr:
"(parent, child) \<in> parent_child_rel h \<Longrightarrow> is_node_ptr_kind child"
by(auto simp add: parent_child_rel_def)
lemma parent_child_rel_child_nodes:
assumes "known_ptr parent"
and "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "child \<in> set children"
shows "(parent, cast child) \<in> parent_child_rel h"
using assms
apply(auto simp add: parent_child_rel_def is_OK_returns_result_I )[1]
using get_child_nodes_ptr_in_heap by blast
lemma parent_child_rel_child_nodes2:
assumes "known_ptr parent"
and "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "child \<in> set children"
and "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = child_obj"
shows "(parent, child_obj) \<in> parent_child_rel h"
using assms parent_child_rel_child_nodes by blast
lemma parent_child_rel_finite: "finite (parent_child_rel h)"
proof -
have "parent_child_rel h = (\<Union>ptr \<in> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r.
(\<Union>child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r. {(ptr, cast child)}))"
by(auto simp add: parent_child_rel_def)
moreover have "finite (\<Union>ptr \<in> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r.
(\<Union>child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r. {(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)}))"
by simp
ultimately show ?thesis
by simp
qed
lemma distinct_lists_no_parent:
assumes "a_distinct_lists h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
shows "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h
\<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using assms
apply(auto simp add: a_distinct_lists_def)[1]
proof -
fix parent_ptr :: "(_) object_ptr"
assume a1: "parent_ptr |\<in>| object_ptr_kinds h"
assume a2: "(\<Union>x\<in>fset (object_ptr_kinds h).
set |h \<turnstile> get_child_nodes x|\<^sub>r) \<inter> (\<Union>x\<in>fset (document_ptr_kinds h).
set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
assume a3: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume a4: "node_ptr \<in> set disc_nodes"
assume a5: "node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
have f6: "parent_ptr \<in> fset (object_ptr_kinds h)"
using a1 by auto
have f7: "document_ptr \<in> fset (document_ptr_kinds h)"
- using a3 by (meson fmember.rep_eq get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I)
+ using a3 by (meson fmember_iff_member_fset get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I)
have "|h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = disc_nodes"
using a3 by simp
then show False
using f7 f6 a5 a4 a2 by blast
qed
lemma distinct_lists_disconnected_nodes:
assumes "a_distinct_lists h"
and "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
shows "distinct disc_nodes"
proof -
have h1: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using assms(1)
by(simp add: a_distinct_lists_def)
then show ?thesis
using concat_map_all_distinct[OF h1] assms(2) is_OK_returns_result_I get_disconnected_nodes_ok
by (metis (no_types, lifting) DocumentMonad.ptr_kinds_ptr_kinds_M
l_get_disconnected_nodes.get_disconnected_nodes_ptr_in_heap
l_get_disconnected_nodes_axioms select_result_I2)
qed
lemma distinct_lists_children:
assumes "a_distinct_lists h"
and "known_ptr ptr"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
shows "distinct children"
proof (cases "children = []", simp)
assume "children \<noteq> []"
have h1: "distinct (concat ((map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)))"
using assms(1)
by(simp add: a_distinct_lists_def)
show ?thesis
using concat_map_all_distinct[OF h1] assms(2) assms(3)
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M get_child_nodes_ptr_in_heap
is_OK_returns_result_I select_result_I2)
qed
lemma heap_is_wellformed_children_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "child |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: heap_is_wellformed_def a_all_ptrs_in_heap_def)[1]
by (metis (no_types, lifting) finite_set_in is_OK_returns_result_I
local.get_child_nodes_ptr_in_heap select_result_I2 subsetD)
lemma heap_is_wellformed_one_parent:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'"
assumes "set children \<inter> set children' \<noteq> {}"
shows "ptr = ptr'"
using assms
proof (auto simp add: heap_is_wellformed_def a_distinct_lists_def)[1]
fix x :: "(_) node_ptr"
assume a1: "ptr \<noteq> ptr'"
assume a2: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assume a3: "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'"
assume a4: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
have f5: "|h \<turnstile> get_child_nodes ptr|\<^sub>r = children"
using a2 by simp
have "|h \<turnstile> get_child_nodes ptr'|\<^sub>r = children'"
using a3 by (meson select_result_I2)
then have "ptr \<notin> set (sorted_list_of_set (fset (object_ptr_kinds h)))
\<or> ptr' \<notin> set (sorted_list_of_set (fset (object_ptr_kinds h)))
\<or> set children \<inter> set children' = {}"
using f5 a4 a1 by (meson distinct_concat_map_E(1))
then show False
- using a3 a2 by (metis (no_types) assms(4) finite_fset fmember.rep_eq is_OK_returns_result_I
+ using a3 a2 by (metis (no_types) assms(4) finite_fset fmember_iff_member_fset is_OK_returns_result_I
local.get_child_nodes_ptr_in_heap set_sorted_list_of_set)
qed
lemma parent_child_rel_child:
"h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children \<longleftrightarrow> (ptr, cast child) \<in> parent_child_rel h"
by (simp add: is_OK_returns_result_I get_child_nodes_ptr_in_heap parent_child_rel_def)
lemma parent_child_rel_acyclic: "heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
by (simp add: acyclic_heap_def local.heap_is_wellformed_def)
lemma heap_is_wellformed_disconnected_nodes_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> distinct disc_nodes"
using distinct_lists_disconnected_nodes local.heap_is_wellformed_def by blast
lemma parent_child_rel_parent_in_heap:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> parent |\<in>| object_ptr_kinds h"
using local.parent_child_rel_def by blast
lemma parent_child_rel_child_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent
\<Longrightarrow> (parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
apply(auto simp add: heap_is_wellformed_def parent_child_rel_def a_all_ptrs_in_heap_def)[1]
using get_child_nodes_ok
by (meson finite_set_in subsetD)
lemma heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
by (metis (no_types, lifting) finite_set_in is_OK_returns_result_I local.a_all_ptrs_in_heap_def
local.get_disconnected_nodes_ptr_in_heap local.heap_is_wellformed_def select_result_I2 subsetD)
lemma heap_is_wellformed_one_disc_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {} \<Longrightarrow> document_ptr = document_ptr'"
using DocumentMonad.ptr_kinds_ptr_kinds_M concat_append distinct_append distinct_concat_map_E(1)
is_OK_returns_result_I local.a_distinct_lists_def local.get_disconnected_nodes_ptr_in_heap
local.heap_is_wellformed_def select_result_I2
proof -
assume a1: "heap_is_wellformed h"
assume a2: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume a3: "h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'"
assume a4: "set disc_nodes \<inter> set disc_nodes' \<noteq> {}"
have f5: "|h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = disc_nodes"
using a2 by (meson select_result_I2)
have f6: "|h \<turnstile> get_disconnected_nodes document_ptr'|\<^sub>r = disc_nodes'"
using a3 by (meson select_result_I2)
have "\<And>nss nssa. \<not> distinct (concat (nss @ nssa)) \<or> distinct (concat nssa::(_) node_ptr list)"
by (metis (no_types) concat_append distinct_append)
then have "distinct (concat (map (\<lambda>d. |h \<turnstile> get_disconnected_nodes d|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using a1 local.a_distinct_lists_def local.heap_is_wellformed_def by blast
then show ?thesis
using f6 f5 a4 a3 a2 by (meson DocumentMonad.ptr_kinds_ptr_kinds_M distinct_concat_map_E(1)
is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap)
qed
lemma heap_is_wellformed_children_disc_nodes_different:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> set children \<inter> set disc_nodes = {}"
by (metis (no_types, opaque_lifting) disjoint_iff_not_equal distinct_lists_no_parent
is_OK_returns_result_I local.get_child_nodes_ptr_in_heap
local.heap_is_wellformed_def select_result_I2)
lemma heap_is_wellformed_children_disc_nodes:
"heap_is_wellformed h \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h
\<Longrightarrow> \<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)
\<Longrightarrow> (\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
apply(auto simp add: heap_is_wellformed_def a_distinct_lists_def a_owner_document_valid_def)[1]
- by (meson fmember.rep_eq)
+ by (meson fmember_iff_member_fset)
lemma heap_is_wellformed_children_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M concat_append distinct_append
distinct_concat_map_E(2) is_OK_returns_result_I local.a_distinct_lists_def
local.get_child_nodes_ptr_in_heap local.heap_is_wellformed_def
select_result_I2)
end
locale l_heap_is_wellformed = l_type_wf + l_known_ptr + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_get_disconnected_nodes_defs +
assumes heap_is_wellformed_children_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children
\<Longrightarrow> child |\<in>| node_ptr_kinds h"
assumes heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
assumes heap_is_wellformed_one_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr'"
assumes heap_is_wellformed_one_disc_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {} \<Longrightarrow> document_ptr = document_ptr'"
assumes heap_is_wellformed_children_disc_nodes_different:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> set children \<inter> set disc_nodes = {}"
assumes heap_is_wellformed_disconnected_nodes_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> distinct disc_nodes"
assumes heap_is_wellformed_children_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
assumes heap_is_wellformed_children_disc_nodes:
"heap_is_wellformed h \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h
\<Longrightarrow> \<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)
\<Longrightarrow> (\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
assumes parent_child_rel_child:
"h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<longleftrightarrow> (ptr, cast child) \<in> parent_child_rel h"
assumes parent_child_rel_finite:
"heap_is_wellformed h \<Longrightarrow> finite (parent_child_rel h)"
assumes parent_child_rel_acyclic:
"heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
assumes parent_child_rel_node_ptr:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> is_node_ptr_kind child_ptr"
assumes parent_child_rel_parent_in_heap:
"(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> parent |\<in>| object_ptr_kinds h"
assumes parent_child_rel_child_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent
\<Longrightarrow> (parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
interpretation i_heap_is_wellformed?: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel
apply(unfold_locales)
by(auto simp add: heap_is_wellformed_def parent_child_rel_def)
declare l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma heap_is_wellformed_is_l_heap_is_wellformed [instances]:
"l_heap_is_wellformed type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def)[1]
using heap_is_wellformed_children_in_heap
apply blast
using heap_is_wellformed_disc_nodes_in_heap
apply blast
using heap_is_wellformed_one_parent
apply blast
using heap_is_wellformed_one_disc_parent
apply blast
using heap_is_wellformed_children_disc_nodes_different
apply blast
using heap_is_wellformed_disconnected_nodes_distinct
apply blast
using heap_is_wellformed_children_distinct
apply blast
using heap_is_wellformed_children_disc_nodes
apply blast
using parent_child_rel_child
apply (blast)
using parent_child_rel_child
apply(blast)
using parent_child_rel_finite
apply blast
using parent_child_rel_acyclic
apply blast
using parent_child_rel_node_ptr
apply blast
using parent_child_rel_parent_in_heap
apply blast
using parent_child_rel_child_in_heap
apply blast
done
subsection \<open>get\_parent\<close>
locale l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
+ l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma child_parent_dual:
assumes heap_is_wellformed: "heap_is_wellformed h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
assumes "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
proof -
obtain ptrs where ptrs: "h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have h1: "ptr \<in> set ptrs"
using get_child_nodes_ok assms(2) is_OK_returns_result_I
by (metis (no_types, opaque_lifting) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>\<And>thesis. (\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
get_child_nodes_ptr_in_heap returns_result_eq select_result_I2)
let ?P = "(\<lambda>ptr. get_child_nodes ptr \<bind> (\<lambda>children. return (child \<in> set children)))"
let ?filter = "filter_M ?P ptrs"
have "h \<turnstile> ok ?filter"
using ptrs type_wf
using get_child_nodes_ok
apply(auto intro!: filter_M_is_OK_I bind_is_OK_pure_I get_child_nodes_ok simp add: bind_pure_I)[1]
using assms(4) local.known_ptrs_known_ptr by blast
then obtain parent_ptrs where parent_ptrs: "h \<turnstile> ?filter \<rightarrow>\<^sub>r parent_ptrs"
by auto
have h5: "\<exists>!x. x \<in> set ptrs \<and> h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
apply(auto intro!: bind_pure_returns_result_I)[1]
using heap_is_wellformed_one_parent
proof -
have "h \<turnstile> (return (child \<in> set children)::((_) heap, exception, bool) prog) \<rightarrow>\<^sub>r True"
by (simp add: assms(3))
then show
"\<exists>z. z \<in> set ptrs \<and> h \<turnstile> Heap_Error_Monad.bind (get_child_nodes z)
(\<lambda>ns. return (child \<in> set ns)) \<rightarrow>\<^sub>r True"
by (metis (no_types) assms(2) bind_pure_returns_result_I2 h1 is_OK_returns_result_I
local.get_child_nodes_pure select_result_I2)
next
fix x y
assume 0: "x \<in> set ptrs"
and 1: "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
and 2: "y \<in> set ptrs"
and 3: "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes y)
(\<lambda>children. return (child \<in> set children)) \<rightarrow>\<^sub>r True"
and 4: "(\<And>h ptr children ptr' children'. heap_is_wellformed h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr')"
then show "x = y"
by (metis (no_types, lifting) bind_returns_result_E disjoint_iff_not_equal heap_is_wellformed
return_returns_result)
qed
have "child |\<in>| node_ptr_kinds h"
using heap_is_wellformed_children_in_heap heap_is_wellformed assms(2) assms(3)
by fast
moreover have "parent_ptrs = [ptr]"
apply(rule filter_M_ex1[OF parent_ptrs h1 h5])
using ptrs assms(2) assms(3)
by(auto simp add: object_ptr_kinds_M_defs bind_pure_I intro!: bind_pure_returns_result_I)
ultimately show ?thesis
using ptrs parent_ptrs
by(auto simp add: bind_pure_I get_parent_def
elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I) (*slow, ca 1min *)
qed
lemma parent_child_rel_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
shows "(parent, cast child_node) \<in> parent_child_rel h"
using assms parent_child_rel_child get_parent_child_dual by auto
lemma heap_wellformed_induct [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
and step: "\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child)) \<Longrightarrow> P parent"
shows "P ptr"
proof -
fix ptr
have "wf ((parent_child_rel h)\<inverse>)"
by (simp add: assms(1) finite_acyclic_wf_converse parent_child_rel_acyclic parent_child_rel_finite)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
using assms parent_child_rel_child
by (meson converse_iff)
qed
qed
lemma heap_wellformed_induct2 [consumes 3, case_names not_in_heap empty_children step]:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
and not_in_heap: "\<And>parent. parent |\<notin>| object_ptr_kinds h \<Longrightarrow> P parent"
and empty_children: "\<And>parent. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r [] \<Longrightarrow> P parent"
and step: "\<And>parent children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child) \<Longrightarrow> P parent"
shows "P ptr"
proof(insert assms(1), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof(cases "parent |\<in>| object_ptr_kinds h")
case True
then obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(2) assms(3)
by (meson is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?thesis
proof (cases "children = []")
case True
then show ?thesis
using children empty_children
by simp
next
case False
then show ?thesis
using assms(6) children last_in_set step.hyps by blast
qed
next
case False
then show ?thesis
by (simp add: not_in_heap)
qed
qed
lemma heap_wellformed_induct_rev [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
and step: "\<And>child. (\<And>parent child_node. cast child_node = child
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent) \<Longrightarrow> P child"
shows "P ptr"
proof -
fix ptr
have "wf ((parent_child_rel h))"
by (simp add: assms(1) local.parent_child_rel_acyclic local.parent_child_rel_finite
wf_iff_acyclic_if_finite)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less child)
show ?case
using assms get_parent_child_dual
by (metis less.hyps parent_child_rel_parent)
qed
qed
end
interpretation i_get_parent_wf?: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed
parent_child_rel get_disconnected_nodes
using instances
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
heap_is_wellformed parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
+ l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma preserves_wellformedness_writes_needed:
assumes heap_is_wellformed: "heap_is_wellformed h"
and "h \<turnstile> f \<rightarrow>\<^sub>h h'"
and "writes SW f h h'"
and preserved_get_child_nodes:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. \<forall>r \<in> get_child_nodes_locs object_ptr. r h h'"
and preserved_get_disconnected_nodes:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>document_ptr. \<forall>r \<in> get_disconnected_nodes_locs document_ptr. r h h'"
and preserved_object_pointers:
"\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h'
\<Longrightarrow> \<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "heap_is_wellformed h'"
proof -
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
using assms(2) assms(3) object_ptr_kinds_preserved preserved_object_pointers by blast
then have object_ptr_kinds_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
by auto
have children_eq:
"\<And>ptr children. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads assms(3) assms(2)])
using preserved_get_child_nodes by fast
then have children_eq2: "\<And>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq:
"\<And>document_ptr disconnected_nodes.
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads assms(3) assms(2)])
using preserved_get_disconnected_nodes by fast
then have disconnected_nodes_eq2:
"\<And>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r
= |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have get_parent_eq: "\<And>ptr parent. h \<turnstile> get_parent ptr \<rightarrow>\<^sub>r parent = h' \<turnstile> get_parent ptr \<rightarrow>\<^sub>r parent"
apply(rule reads_writes_preserved[OF get_parent_reads assms(3) assms(2)])
using preserved_get_child_nodes preserved_object_pointers unfolding get_parent_locs_def by fast
have "a_acyclic_heap h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h"
by(simp add: parent_child_rel_def children_eq2 object_ptr_kinds_eq3)
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
by (simp add: children_eq2 disconnected_nodes_eq2 document_ptr_kinds_eq3
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_all_ptrs_in_heap_def node_ptr_kinds_eq3 object_ptr_kinds_eq3)
moreover have h0: "a_distinct_lists h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
have h1: "map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h)))
= map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h')))"
by (simp add: children_eq2 object_ptr_kinds_eq3)
have h2: "map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))
= map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))"
using disconnected_nodes_eq document_ptr_kinds_eq2 select_result_eq by force
have "a_distinct_lists h'"
using h0
by(simp add: a_distinct_lists_def h1 h2)
moreover have "a_owner_document_valid h"
using heap_is_wellformed by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
by(auto simp add: a_owner_document_valid_def children_eq2 disconnected_nodes_eq2
object_ptr_kinds_eq3 node_ptr_kinds_eq3 document_ptr_kinds_eq3)
ultimately show ?thesis
by (simp add: heap_is_wellformed_def)
qed
end
interpretation i_get_parent_wf2?: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs
heap_is_wellformed parent_child_rel get_disconnected_nodes
get_disconnected_nodes_locs
using l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by (simp add: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_get_parent_wf = l_type_wf + l_known_ptrs + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_get_parent_defs +
assumes child_parent_dual:
"heap_is_wellformed h
\<Longrightarrow> type_wf h
\<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children
\<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
assumes heap_wellformed_induct [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children
\<Longrightarrow> child \<in> set children \<Longrightarrow> P (cast child)) \<Longrightarrow> P parent)
\<Longrightarrow> P ptr"
assumes heap_wellformed_induct_rev [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>child. (\<And>parent child_node. cast child_node = child
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent) \<Longrightarrow> P child)
\<Longrightarrow> P ptr"
assumes parent_child_rel_parent: "heap_is_wellformed h
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent
\<Longrightarrow> (parent, cast child_node) \<in> parent_child_rel h"
lemma get_parent_wf_is_l_get_parent_wf [instances]:
"l_get_parent_wf type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def)[1]
using child_parent_dual heap_wellformed_induct heap_wellformed_induct_rev parent_child_rel_parent
by metis+
subsection \<open>get\_disconnected\_nodes\<close>
subsection \<open>set\_disconnected\_nodes\<close>
subsubsection \<open>get\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma remove_from_disconnected_nodes_removes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "h \<turnstile> set_disconnected_nodes ptr (remove1 node_ptr disc_nodes) \<rightarrow>\<^sub>h h'"
assumes "h' \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes'"
shows "node_ptr \<notin> set disc_nodes'"
using assms
by (metis distinct_remove1_removeAll heap_is_wellformed_disconnected_nodes_distinct
set_disconnected_nodes_get_disconnected_nodes member_remove remove_code(1)
returns_result_eq)
end
locale l_set_disconnected_nodes_get_disconnected_nodes_wf = l_heap_is_wellformed
+ l_set_disconnected_nodes_get_disconnected_nodes +
assumes remove_from_disconnected_nodes_removes:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> h \<turnstile> set_disconnected_nodes ptr (remove1 node_ptr disc_nodes) \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes'
\<Longrightarrow> node_ptr \<notin> set disc_nodes'"
interpretation i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M?:
l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs heap_is_wellformed
parent_child_rel get_child_nodes
using instances
by (simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_disconnected_nodes_wf_is_l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]:
"l_set_disconnected_nodes_get_disconnected_nodes_wf type_wf known_ptr heap_is_wellformed parent_child_rel
get_child_nodes get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def
l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
using remove_from_disconnected_nodes_removes apply fast
done
subsection \<open>get\_root\_node\<close>
locale l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed
type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
+ l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs get_parent get_parent_locs
+ l_get_parent_wf
type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel get_child_nodes
get_child_nodes_locs get_parent get_parent_locs
+ l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_ancestors :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_ancestors_reads:
assumes "heap_is_wellformed h"
shows "reads get_ancestors_locs (get_ancestors node_ptr) h h'"
proof (insert assms(1), induct rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
using [[simproc del: Product_Type.unit_eq]] get_parent_reads[unfolded reads_def]
apply(simp (no_asm) add: get_ancestors_def)
by(auto simp add: get_ancestors_locs_def reads_subset[OF return_reads] get_parent_reads_pointers
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads]
reads_subset[OF get_parent_reads] reads_subset[OF get_child_nodes_reads]
split: option.splits)
qed
lemma get_ancestors_ok:
assumes "heap_is_wellformed h"
and "ptr |\<in>| object_ptr_kinds h"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "h \<turnstile> ok (get_ancestors ptr)"
proof (insert assms(1) assms(2), induct rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
using assms(3) assms(4)
apply(simp (no_asm) add: get_ancestors_def)
apply(simp add: assms(1) get_parent_parent_in_heap)
by(auto intro!: bind_is_OK_pure_I bind_pure_I get_parent_ok split: option.splits)
qed
lemma get_root_node_ptr_in_heap:
assumes "h \<turnstile> ok (get_root_node ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
unfolding get_root_node_def
using get_ancestors_ptr_in_heap
by auto
lemma get_root_node_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_root_node ptr)"
unfolding get_root_node_def
using assms get_ancestors_ok
by auto
lemma get_ancestors_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
shows "h \<turnstile> get_ancestors (cast child) \<rightarrow>\<^sub>r (cast child) # parent # ancestors
\<longleftrightarrow> h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
proof
assume a1: "h \<turnstile> get_ancestors (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
then have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child))
(\<lambda>_. Heap_Error_Monad.bind (get_parent child)
(\<lambda>x. Heap_Error_Monad.bind (case x of None \<Rightarrow> return [] | Some x \<Rightarrow> get_ancestors x)
(\<lambda>ancestors. return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # ancestors))))
\<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
by(simp add: get_ancestors_def)
then show "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
using assms(2) apply(auto elim!: bind_returns_result_E2 split: option.splits)[1]
using returns_result_eq by fastforce
next
assume "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r parent # ancestors"
then show "h \<turnstile> get_ancestors (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child # parent # ancestors"
using assms(2)
apply(simp (no_asm) add: get_ancestors_def)
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
by (metis (full_types) assms(2) check_in_heap_ptr_in_heap is_OK_returns_result_I
local.get_parent_ptr_in_heap node_ptr_kinds_commutes old.unit.exhaust
select_result_I)
qed
lemma get_ancestors_never_empty:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors"
shows "ancestors \<noteq> []"
proof(insert assms(2), induct arbitrary: ancestors rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
next
case (Some child_node)
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
with Some show ?case
proof(induct parent_opt)
case None
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
next
case (Some option)
then show ?case
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
qed
qed
qed
lemma get_ancestors_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors ancestor \<rightarrow>\<^sub>r ancestor_ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "set ancestor_ancestors \<subseteq> set ancestors"
proof (insert assms(1) assms(2) assms(3), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_ptr_in_heap step(2) by auto
(* then have "h \<turnstile> check_in_heap child \<rightarrow>\<^sub>r ()"
using returns_result_select_result by force *)
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then have "ancestors = [child]"
using step(2) step(3)
by(auto simp add: get_ancestors_def elim!: bind_returns_result_E2)
show ?case
using step(2) step(3)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric] get_parent_ok[OF type_wf known_ptrs]
by (metis (no_types, lifting) is_OK_returns_result_E known_ptrs get_parent_ok
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(2) step(3) s1
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(2) step(3)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some parent)
have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap child)
(\<lambda>_. Heap_Error_Monad.bind
(case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child of None \<Rightarrow> return []
| Some node_ptr \<Rightarrow> Heap_Error_Monad.bind (get_parent node_ptr)
(\<lambda>parent_ptr_opt. case parent_ptr_opt of None \<Rightarrow> return []
| Some x \<Rightarrow> get_ancestors x))
(\<lambda>ancestors. return (child # ancestors)))
\<rightarrow>\<^sub>r ancestors"
using step(2)
by(simp add: get_ancestors_def)
moreover obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using calculation
by(auto elim!: bind_returns_result_E2 split: option.splits)
ultimately have "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 Some
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(1)[OF s1[symmetric, simplified] Some \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors\<close>]
step(3)
apply(auto simp add: tl_ancestors)[1]
by (metis assms(4) insert_iff list.simps(15) local.step(2) returns_result_eq tl_ancestors)
qed
qed
qed
lemma get_ancestors_also_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast child \<in> set ancestors"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "parent \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors (cast child) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(4) get_ancestors_ok is_OK_returns_result_I known_ptrs
local.get_parent_ptr_in_heap node_ptr_kinds_commutes returns_result_select_result
type_wf)
then have "parent \<in> set child_ancestors"
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_subset by blast
qed
lemma get_ancestors_obtains_children:
assumes "heap_is_wellformed h"
and "ancestor \<noteq> ptr"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
obtains children ancestor_child where "h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children" and "cast ancestor_child \<in> set ancestors"
proof -
assume 0: "(\<And>children ancestor_child.
h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<Longrightarrow>
ancestor_child \<in> set children \<Longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set ancestors
\<Longrightarrow> thesis)"
have "\<exists>child. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ancestor \<and> cast child \<in> set ancestors"
proof (insert assms(1) assms(2) assms(3) assms(4), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_ptr_in_heap step(4) by auto
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then have "ancestors = [child]"
using step(3) step(4)
by(auto simp add: get_ancestors_def elim!: bind_returns_result_E2)
show ?case
using step(2) step(3) step(4)
by(auto simp add: \<open>ancestors = [child]\<close>)
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric]
using get_parent_ok known_ptrs type_wf
by (metis (no_types, lifting) is_OK_returns_result_E node_ptr_casts_commute
node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(2) step(3) step(4) s1
apply(simp add: get_ancestors_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(2) step(3) step(4)
by(auto simp add: \<open>ancestors = [child]\<close>)
next
case (Some parent)
have "h \<turnstile> Heap_Error_Monad.bind (check_in_heap child)
(\<lambda>_. Heap_Error_Monad.bind
(case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child of None \<Rightarrow> return []
| Some node_ptr \<Rightarrow> Heap_Error_Monad.bind (get_parent node_ptr)
(\<lambda>parent_ptr_opt. case parent_ptr_opt of None \<Rightarrow> return []
| Some x \<Rightarrow> get_ancestors x))
(\<lambda>ancestors. return (child # ancestors)))
\<rightarrow>\<^sub>r ancestors"
using step(4)
by(simp add: get_ancestors_def)
moreover obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using calculation
by(auto elim!: bind_returns_result_E2 split: option.splits)
ultimately have "h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 Some
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
(* have "ancestor \<noteq> parent" *)
have "ancestor \<in> set tl_ancestors"
using tl_ancestors step(2) step(3) by auto
show ?case
proof (cases "ancestor \<noteq> parent")
case True
show ?thesis
using step(1)[OF s1[symmetric, simplified] Some True
\<open>ancestor \<in> set tl_ancestors\<close> \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r tl_ancestors\<close>]
using tl_ancestors by auto
next
case False
have "child \<in> set ancestors"
using step(4) get_ancestors_ptr by simp
then show ?thesis
using Some False s1[symmetric] by(auto)
qed
qed
qed
qed
then obtain child where child: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ancestor"
and in_ancestors: "cast child \<in> set ancestors"
by auto
then obtain children where
children: "h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children" and
child_in_children: "child \<in> set children"
using get_parent_child_dual by blast
show thesis
using 0[OF children child_in_children] child assms(3) in_ancestors by blast
qed
lemma get_ancestors_parent_child_rel:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "(ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
proof (safe)
assume 3: "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
show "ptr \<in> set ancestors"
proof (insert 3, induct ptr rule: heap_wellformed_induct[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by (metis (no_types, lifting) assms(2) bind_returns_result_E get_ancestors_def
in_set_member member_rec(1) return_returns_result)
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h) \<and> (ptr_child, child) \<in> (parent_child_rel h)\<^sup>*"
using converse_rtranclE[OF 1(2)] \<open>ptr \<noteq> child\<close>
by metis
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 parent_child_rel_node_ptr
by (metis )
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using local.parent_child_rel_parent_in_heap ptr_child by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis calculation known_ptrs local.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child ptr_child ptr_child_ptr_child_node
returns_result_select_result type_wf)
ultimately show ?thesis
using a1 get_child_nodes_ok type_wf known_ptrs
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h)\<^sup>*"
using ptr_child ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using known_ptrs type_wf by blast
ultimately show ?thesis
using get_ancestors_also_parent assms type_wf by blast
qed
qed
next
assume 3: "ptr \<in> set ancestors"
show "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
proof (insert 3, induct ptr rule: heap_wellformed_induct[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
then obtain children ptr_child_node where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children" and
ptr_child_node_in_ancestors: "cast ptr_child_node \<in> set ancestors"
using 1(2) assms(2) get_ancestors_obtains_children assms(1)
using known_ptrs type_wf by blast
then have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h)\<^sup>*"
using 1(1) by blast
moreover have "(ptr, cast ptr_child_node) \<in> parent_child_rel h"
using children ptr_child_node assms(1) parent_child_rel_child_nodes2
using child_parent_dual known_ptrs parent_child_rel_parent type_wf
by blast
ultimately show ?thesis
by auto
qed
qed
qed
lemma get_root_node_parent_child_rel:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r root"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "(root, child) \<in> (parent_child_rel h)\<^sup>*"
using assms get_ancestors_parent_child_rel
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
using get_ancestors_never_empty last_in_set by blast
lemma get_ancestors_eq:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "\<And>object_ptr w. object_ptr \<noteq> ptr \<Longrightarrow> w \<in> get_child_nodes_locs object_ptr \<Longrightarrow> w h h'"
and pointers_preserved: "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
and known_ptrs: "known_ptrs h"
and known_ptrs': "known_ptrs h'"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
proof -
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
using pointers_preserved object_ptr_kinds_preserved_small by blast
then have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
have "h' \<turnstile> ok (get_ancestors ptr)"
using get_ancestors_ok get_ancestors_ptr_in_heap object_ptr_kinds_eq3 assms(1) known_ptrs
known_ptrs' assms(2) assms(7) type_wf'
by blast
then obtain ancestors' where ancestors': "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'"
by auto
obtain root where root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
proof -
assume 0: "(\<And>root. h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow> thesis)"
show thesis
apply(rule 0)
using assms(7)
by(auto simp add: get_root_node_def elim!: bind_returns_result_E2 split: option.splits)
qed
have children_eq:
"\<And>p children. p \<noteq> ptr \<Longrightarrow> h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
using get_child_nodes_reads assms(3)
apply(simp add: reads_def reflp_def transp_def preserved_def)
by blast
have "acyclic (parent_child_rel h)"
using assms(1) local.parent_child_rel_acyclic by auto
have "acyclic (parent_child_rel h')"
using assms(2) local.parent_child_rel_acyclic by blast
have 2: "\<And>c parent_opt. cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c \<in> set ancestors \<inter> set ancestors'
\<Longrightarrow> h \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt = h' \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt"
proof -
fix c parent_opt
assume 1: " cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c \<in> set ancestors \<inter> set ancestors'"
obtain ptrs where ptrs: "h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by simp
let ?P = "(\<lambda>ptr. Heap_Error_Monad.bind (get_child_nodes ptr) (\<lambda>children. return (c \<in> set children)))"
have children_eq_True: "\<And>p. p \<in> set ptrs \<Longrightarrow> h \<turnstile> ?P p \<rightarrow>\<^sub>r True \<longleftrightarrow> h' \<turnstile> ?P p \<rightarrow>\<^sub>r True"
proof -
fix p
assume "p \<in> set ptrs"
then show "h \<turnstile> ?P p \<rightarrow>\<^sub>r True \<longleftrightarrow> h' \<turnstile> ?P p \<rightarrow>\<^sub>r True"
proof (cases "p = ptr")
case True
have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h)\<^sup>*"
using get_ancestors_parent_child_rel 1 assms by blast
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)"
proof (cases "cast c = ptr")
case True
then show ?thesis
using \<open>acyclic (parent_child_rel h)\<close> by(auto simp add: acyclic_def)
next
case False
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)\<^sup>*"
using \<open>acyclic (parent_child_rel h)\<close> False rtrancl_eq_or_trancl rtrancl_trancl_trancl
\<open>(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h)\<^sup>*\<close>
by (metis acyclic_def)
then show ?thesis
using r_into_rtrancl by auto
qed
obtain children where children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using type_wf
by (metis \<open>h' \<turnstile> ok get_ancestors ptr\<close> assms(1) get_ancestors_ptr_in_heap get_child_nodes_ok
heap_is_wellformed_def is_OK_returns_result_E known_ptrs local.known_ptrs_known_ptr
object_ptr_kinds_eq3)
then have "c \<notin> set children"
using \<open>(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h)\<close> assms(1)
using parent_child_rel_child_nodes2
using child_parent_dual known_ptrs parent_child_rel_parent
type_wf by blast
with children have "h \<turnstile> ?P p \<rightarrow>\<^sub>r False"
by(auto simp add: True)
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h')\<^sup>*"
using get_ancestors_parent_child_rel assms(2) ancestors' 1 known_ptrs' type_wf
type_wf' by blast
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')"
proof (cases "cast c = ptr")
case True
then show ?thesis
using \<open>acyclic (parent_child_rel h')\<close> by(auto simp add: acyclic_def)
next
case False
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')\<^sup>*"
using \<open>acyclic (parent_child_rel h')\<close> False rtrancl_eq_or_trancl rtrancl_trancl_trancl
\<open>(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c, ptr) \<in> (parent_child_rel h')\<^sup>*\<close>
by (metis acyclic_def)
then show ?thesis
using r_into_rtrancl by auto
qed
then have "(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')"
using r_into_rtrancl by auto
obtain children' where children': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'"
using type_wf type_wf'
by (meson \<open>h' \<turnstile> ok (get_ancestors ptr)\<close> assms(2) get_ancestors_ptr_in_heap
get_child_nodes_ok is_OK_returns_result_E known_ptrs'
local.known_ptrs_known_ptr)
then have "c \<notin> set children'"
using \<open>(ptr, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<notin> (parent_child_rel h')\<close> assms(2) type_wf type_wf'
using parent_child_rel_child_nodes2 child_parent_dual known_ptrs' parent_child_rel_parent
by auto
with children' have "h' \<turnstile> ?P p \<rightarrow>\<^sub>r False"
by(auto simp add: True)
ultimately show ?thesis
by (metis returns_result_eq)
next
case False
then show ?thesis
using children_eq ptrs
by (metis (no_types, lifting) bind_pure_returns_result_I bind_returns_result_E
get_child_nodes_pure return_returns_result)
qed
qed
have "\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))"
using assms(1) assms(2) object_ptr_kinds_eq ptrs type_wf type_wf'
by (metis (no_types, lifting) ObjectMonad.ptr_kinds_ptr_kinds_M bind_is_OK_pure_I
get_child_nodes_ok get_child_nodes_pure known_ptrs'
local.known_ptrs_known_ptr return_ok select_result_I2)
have children_eq_False:
"\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
proof
fix pa
assume "pa \<in> set ptrs"
and "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
have "h \<turnstile> ok (get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))
\<Longrightarrow> h' \<turnstile> ok ( get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))"
using \<open>pa \<in> set ptrs\<close> \<open>\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))\<close>
by auto
moreover have "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False
\<Longrightarrow> h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
by (metis (mono_tags, lifting) \<open>\<And>pa. pa \<in> set ptrs
\<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True\<close> \<open>pa \<in> set ptrs\<close>
calculation is_OK_returns_result_I returns_result_eq returns_result_select_result)
ultimately show "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
using \<open>h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False\<close>
by auto
next
fix pa
assume "pa \<in> set ptrs"
and "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
have "h' \<turnstile> ok (get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))
\<Longrightarrow> h \<turnstile> ok ( get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)))"
using \<open>pa \<in> set ptrs\<close> \<open>\<And>pa. pa \<in> set ptrs
\<Longrightarrow> h \<turnstile> ok (get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children))) = h' \<turnstile> ok ( get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)))\<close>
by auto
moreover have "h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False
\<Longrightarrow> h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
by (metis (mono_tags, lifting)
\<open>\<And>pa. pa \<in> set ptrs \<Longrightarrow> h \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True = h' \<turnstile> get_child_nodes pa
\<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r True\<close> \<open>pa \<in> set ptrs\<close>
calculation is_OK_returns_result_I returns_result_eq returns_result_select_result)
ultimately show "h \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False"
using \<open>h' \<turnstile> get_child_nodes pa \<bind> (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r False\<close> by blast
qed
have filter_eq: "\<And>xs. h \<turnstile> filter_M ?P ptrs \<rightarrow>\<^sub>r xs = h' \<turnstile> filter_M ?P ptrs \<rightarrow>\<^sub>r xs"
proof (rule filter_M_eq)
show
"\<And>xs x. pure (Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children))) h"
by(auto intro!: bind_pure_I)
next
show
"\<And>xs x. pure (Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children))) h'"
by(auto intro!: bind_pure_I)
next
fix xs b x
assume 0: "x \<in> set ptrs"
then show "h \<turnstile> Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r b
= h' \<turnstile> Heap_Error_Monad.bind (get_child_nodes x) (\<lambda>children. return (c \<in> set children)) \<rightarrow>\<^sub>r b"
apply(induct b)
using children_eq_True apply blast
using children_eq_False apply blast
done
qed
show "h \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt = h' \<turnstile> get_parent c \<rightarrow>\<^sub>r parent_opt"
apply(simp add: get_parent_def)
apply(rule bind_cong_2)
apply(simp)
apply(simp)
apply(simp add: check_in_heap_def node_ptr_kinds_def object_ptr_kinds_eq3)
apply(rule bind_cong_2)
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(auto simp add: object_ptr_kinds_M_eq object_ptr_kinds_eq3)[1]
apply(rule bind_cong_2)
apply(auto intro!: filter_M_pure_I bind_pure_I)[1]
apply(auto intro!: filter_M_pure_I bind_pure_I)[1]
apply(auto simp add: filter_eq (* dest!: returns_result_eq[OF ptrs] *))[1]
using filter_eq ptrs apply auto[1]
using filter_eq ptrs by auto
qed
have "ancestors = ancestors'"
proof(insert assms(1) assms(7) ancestors' 2, induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev)
case (step child)
show ?case
using step(2) step(3) step(4)
apply(simp add: get_ancestors_def)
apply(auto intro!: elim!: bind_returns_result_E2 split: option.splits)[1]
using returns_result_eq apply fastforce
apply (meson option.simps(3) returns_result_eq)
by (metis IntD1 IntD2 option.inject returns_result_eq step.hyps)
qed
then show ?thesis
using assms(5) ancestors'
by simp
qed
lemma get_ancestors_remains_not_in_ancestors:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
and "h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'"
and "\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children' \<Longrightarrow> set children' \<subseteq> set children"
and "node \<notin> set ancestors"
and object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "node \<notin> set ancestors'"
proof -
have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
using object_ptr_kinds_eq3
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
show ?thesis
proof (insert assms(1) assms(3) assms(4) assms(6), induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev)
case (step child)
have 1: "\<And>p parent. h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent \<Longrightarrow> h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
proof -
fix p parent
assume "h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
then obtain children' where
children': "h' \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'" and
p_in_children': "p \<in> set children'"
using get_parent_child_dual by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(1) get_child_nodes_ptr_in_heap object_ptr_kinds_eq children'
known_ptrs
using type_wf type_wf'
by (metis \<open>h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent\<close> get_parent_parent_in_heap is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
have "p \<in> set children"
using assms(5) children children' p_in_children'
by blast
then show "h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
using child_parent_dual assms(1) children known_ptrs type_wf by blast
qed
have "node \<noteq> child"
using assms(1) get_ancestors_parent_child_rel step.prems(1) step.prems(3) known_ptrs
using type_wf type_wf'
by blast
then show ?case
using step(2) step(3)
apply(simp add: get_ancestors_def)
using step(4)
apply(auto elim!: bind_returns_result_E2 split: option.splits)[1]
using 1
apply (meson option.distinct(1) returns_result_eq)
by (metis "1" option.inject returns_result_eq step.hyps)
qed
qed
lemma get_ancestors_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
shows "ptr' |\<in>| object_ptr_kinds h"
proof (insert assms(4) assms(5), induct ancestors arbitrary: ptr)
case Nil
then show ?case
by(auto)
next
case (Cons a ancestors)
then obtain x where x: "h \<turnstile> get_ancestors x \<rightarrow>\<^sub>r a # ancestors"
by(auto simp add: get_ancestors_def[of a] elim!: bind_returns_result_E2 split: option.splits)
then have "x = a"
by(auto simp add: get_ancestors_def[of x] elim!: bind_returns_result_E2 split: option.splits)
then show ?case
using Cons.hyps Cons.prems(2) get_ancestors_ptr_in_heap x
by (metis assms(1) assms(2) assms(3) get_ancestors_obtains_children get_child_nodes_ptr_in_heap
is_OK_returns_result_I)
qed
lemma get_ancestors_prefix:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
assumes "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
shows "\<exists>pre. ancestors = pre @ ancestors'"
proof (insert assms(1) assms(5) assms(6), induct ptr' arbitrary: ancestors'
rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof (cases "parent \<noteq> ptr" )
case True
then obtain children ancestor_child where "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children" and "cast ancestor_child \<in> set ancestors"
using assms(1) assms(2) assms(3) assms(4) get_ancestors_obtains_children step.prems(1) by blast
then have "h \<turnstile> get_parent ancestor_child \<rightarrow>\<^sub>r Some parent"
using assms(1) assms(2) assms(3) child_parent_dual by blast
then have "h \<turnstile> get_ancestors (cast ancestor_child) \<rightarrow>\<^sub>r cast ancestor_child # ancestors'"
apply(simp add: get_ancestors_def)
using \<open>h \<turnstile> get_ancestors parent \<rightarrow>\<^sub>r ancestors'\<close> get_parent_ptr_in_heap
by(auto simp add: check_in_heap_def is_OK_returns_result_I intro!: bind_pure_returns_result_I)
then show ?thesis
using step(1) \<open>h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children\<close> \<open>ancestor_child \<in> set children\<close>
\<open>cast ancestor_child \<in> set ancestors\<close> \<open>h \<turnstile> get_ancestors (cast ancestor_child) \<rightarrow>\<^sub>r cast ancestor_child # ancestors'\<close>
by fastforce
next
case False
then show ?thesis
by (metis append_Nil assms(4) returns_result_eq step.prems(2))
qed
qed
lemma get_ancestors_same_root_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
assumes "ptr'' \<in> set ancestors"
shows "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr \<longleftrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
proof -
have "ptr' |\<in>| object_ptr_kinds h"
by (metis assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_obtains_children
get_ancestors_ptr_in_heap get_child_nodes_ptr_in_heap is_OK_returns_result_I)
then obtain ancestors' where ancestors': "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
by (meson assms(1) assms(2) assms(3) get_ancestors_ok is_OK_returns_result_E)
then have "\<exists>pre. ancestors = pre @ ancestors'"
using get_ancestors_prefix assms by blast
moreover have "ptr'' |\<in>| object_ptr_kinds h"
by (metis assms(1) assms(2) assms(3) assms(4) assms(6) get_ancestors_obtains_children
get_ancestors_ptr_in_heap get_child_nodes_ptr_in_heap is_OK_returns_result_I)
then obtain ancestors'' where ancestors'': "h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''"
by (meson assms(1) assms(2) assms(3) get_ancestors_ok is_OK_returns_result_E)
then have "\<exists>pre. ancestors = pre @ ancestors''"
using get_ancestors_prefix assms by blast
ultimately show ?thesis
using ancestors' ancestors''
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I)[1]
apply (metis (no_types, lifting) assms(1) get_ancestors_never_empty last_appendR
returns_result_eq)
by (metis assms(1) get_ancestors_never_empty last_appendR returns_result_eq)
qed
lemma get_root_node_parent_same:
assumes "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr"
shows "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root \<longleftrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
proof
assume 1: " h \<turnstile> get_root_node (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r root"
show "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
using 1[unfolded get_root_node_def] assms
apply(simp add: get_ancestors_def)
apply(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)[1]
using returns_result_eq apply fastforce
using get_ancestors_ptr by fastforce
next
assume 1: " h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
show "h \<turnstile> get_root_node (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r root"
apply(simp add: get_root_node_def)
using assms 1
apply(simp add: get_ancestors_def)
apply(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)[1]
apply (simp add: check_in_heap_def is_OK_returns_result_I)
using get_ancestors_ptr get_parent_ptr_in_heap
apply (simp add: is_OK_returns_result_I)
by (meson list.distinct(1) list.set_cases local.get_ancestors_ptr)
qed
lemma get_root_node_same_no_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r cast child"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof (insert assms(1) assms(4), induct ptr rule: heap_wellformed_induct_rev)
case (step c)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r c")
case None
then have "c = cast child"
using step(2)
by(auto simp add: get_root_node_def get_ancestors_def[of c] elim!: bind_returns_result_E2)
then show ?thesis
using None by auto
next
case (Some child_node)
note s = this
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
by (metis (no_types, lifting) assms(2) assms(3) get_root_node_ptr_in_heap
is_OK_returns_result_I local.get_parent_ok node_ptr_casts_commute
node_ptr_kinds_commutes returns_result_select_result step.prems)
then show ?thesis
proof(induct parent_opt)
case None
then show ?case
using Some get_root_node_no_parent returns_result_eq step.prems by fastforce
next
case (Some parent)
then show ?case
using step s
apply(auto simp add: get_root_node_def get_ancestors_def[of c]
elim!: bind_returns_result_E2 split: option.splits list.splits)[1]
using get_root_node_parent_same step.hyps step.prems by auto
qed
qed
qed
lemma get_root_node_not_node_same:
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "\<not>is_node_ptr_kind ptr"
shows "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r ptr"
using assms
apply(simp add: get_root_node_def get_ancestors_def)
by(auto simp add: get_root_node_def dest: returns_result_eq elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I split: option.splits)
lemma get_root_node_root_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
shows "root |\<in>| object_ptr_kinds h"
using assms
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
by (simp add: get_ancestors_never_empty get_ancestors_ptrs_in_heap)
lemma get_root_node_same_no_parent_parent_child_rel:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r ptr'"
shows "\<not>(\<exists>p. (p, ptr') \<in> (parent_child_rel h))"
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) get_root_node_same_no_parent
l_heap_is_wellformed.parent_child_rel_child local.child_parent_dual local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_heap_is_wellformed_axioms local.parent_child_rel_node_ptr
local.parent_child_rel_parent_in_heap node_ptr_casts_commute3 option.simps(3) returns_result_eq
returns_result_select_result)
end
locale l_get_ancestors_wf = l_heap_is_wellformed_defs + l_known_ptrs + l_type_wf + l_get_ancestors_defs
+ l_get_child_nodes_defs + l_get_parent_defs +
assumes get_ancestors_never_empty:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ancestors \<noteq> []"
assumes get_ancestors_ok:
"heap_is_wellformed h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (get_ancestors ptr)"
assumes get_ancestors_reads:
"heap_is_wellformed h \<Longrightarrow> reads get_ancestors_locs (get_ancestors node_ptr) h h'"
assumes get_ancestors_ptrs_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ptr' \<in> set ancestors
\<Longrightarrow> ptr' |\<in>| object_ptr_kinds h"
assumes get_ancestors_remains_not_in_ancestors:
"heap_is_wellformed h \<Longrightarrow> heap_is_wellformed h' \<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors
\<Longrightarrow> h' \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors'
\<Longrightarrow> (\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children'
\<Longrightarrow> set children' \<subseteq> set children)
\<Longrightarrow> node \<notin> set ancestors
\<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> type_wf h' \<Longrightarrow> node \<notin> set ancestors'"
assumes get_ancestors_also_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors some_ptr \<rightarrow>\<^sub>r ancestors
\<Longrightarrow> cast child_node \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> type_wf h
\<Longrightarrow> known_ptrs h \<Longrightarrow> parent \<in> set ancestors"
assumes get_ancestors_obtains_children:
"heap_is_wellformed h \<Longrightarrow> ancestor \<noteq> ptr \<Longrightarrow> ancestor \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> (\<And>children ancestor_child . h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children
\<Longrightarrow> ancestor_child \<in> set children
\<Longrightarrow> cast ancestor_child \<in> set ancestors
\<Longrightarrow> thesis)
\<Longrightarrow> thesis"
assumes get_ancestors_parent_child_rel:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_ancestors child \<rightarrow>\<^sub>r ancestors \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> (ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
locale l_get_root_node_wf = l_heap_is_wellformed_defs + l_get_root_node_defs + l_type_wf
+ l_known_ptrs + l_get_ancestors_defs + l_get_parent_defs +
assumes get_root_node_ok:
"heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h
\<Longrightarrow> h \<turnstile> ok (get_root_node ptr)"
assumes get_root_node_ptr_in_heap:
"h \<turnstile> ok (get_root_node ptr) \<Longrightarrow> ptr |\<in>| object_ptr_kinds h"
assumes get_root_node_root_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow> root |\<in>| object_ptr_kinds h"
assumes get_ancestors_same_root_node:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors \<Longrightarrow> ptr' \<in> set ancestors
\<Longrightarrow> ptr'' \<in> set ancestors
\<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr \<longleftrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
assumes get_root_node_same_no_parent:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r cast child \<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
assumes get_root_node_parent_same:
"h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some ptr
\<Longrightarrow> h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root \<longleftrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
interpretation i_get_root_node_wf?:
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_parent get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
using instances
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed parent_child_rel known_ptr known_ptrs type_wf get_ancestors
get_ancestors_locs get_child_nodes get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def)[1]
using get_ancestors_never_empty apply blast
using get_ancestors_ok apply blast
using get_ancestors_reads apply blast
using get_ancestors_ptrs_in_heap apply blast
using get_ancestors_remains_not_in_ancestors apply blast
using get_ancestors_also_parent apply blast
using get_ancestors_obtains_children apply blast
using get_ancestors_parent_child_rel apply blast
using get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed get_root_node type_wf known_ptr known_ptrs
get_ancestors get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def)[1]
using get_root_node_ok apply blast
using get_root_node_ptr_in_heap apply blast
using get_root_node_root_in_heap apply blast
using get_ancestors_same_root_node apply(blast, blast)
using get_root_node_same_no_parent apply blast
using get_root_node_parent_same apply (blast, blast)
done
subsection \<open>to\_tree\_order\<close>
locale l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent +
l_get_parent_wf +
l_heap_is_wellformed
(* l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M *)
begin
lemma to_tree_order_ptr_in_heap:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> ok (to_tree_order ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
proof(insert assms(1) assms(4), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
apply(auto simp add: to_tree_order_def[of parent] map_M_pure_I elim!: bind_is_OK_E3)[1]
using get_child_nodes_ptr_in_heap by blast
qed
lemma to_tree_order_either_ptr_or_in_children:
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "node \<in> set nodes"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "node \<noteq> ptr"
obtains child child_to where "child \<in> set children"
and "h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r child_to" and "node \<in> set child_to"
proof -
obtain treeorders where treeorders: "h \<turnstile> map_M to_tree_order (map cast children) \<rightarrow>\<^sub>r treeorders"
using assms
apply(auto simp add: to_tree_order_def elim!: bind_returns_result_E)[1]
using pure_returns_heap_eq returns_result_eq by fastforce
then have "node \<in> set (concat treeorders)"
using assms[simplified to_tree_order_def]
by(auto elim!: bind_returns_result_E4 dest: pure_returns_heap_eq)
then obtain treeorder where "treeorder \<in> set treeorders"
and node_in_treeorder: "node \<in> set treeorder"
by auto
then obtain child where "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r treeorder"
and "child \<in> set children"
using assms[simplified to_tree_order_def] treeorders
by(auto elim!: map_M_pure_E2)
then show ?thesis
using node_in_treeorder returns_result_eq that by auto
qed
lemma to_tree_order_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
shows "ptr' |\<in>| object_ptr_kinds h"
proof(insert assms(1) assms(4) assms(5), induct ptr arbitrary: to rule: heap_wellformed_induct)
case (step parent)
have "parent |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) step.prems(1) to_tree_order_ptr_in_heap by blast
then obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then have "to = [parent]"
using step(2) children
apply(auto simp add: to_tree_order_def[of parent] map_M_pure_I elim!: bind_returns_result_E2)[1]
by (metis list.distinct(1) list.map_disc_iff list.set_cases map_M_pure_E2 returns_result_eq)
then show ?thesis
using \<open>parent |\<in>| object_ptr_kinds h\<close> step.prems(2) by auto
next
case False
note f = this
then show ?thesis
using children step to_tree_order_either_ptr_or_in_children
proof (cases "ptr' = parent")
case True
then show ?thesis
using \<open>parent |\<in>| object_ptr_kinds h\<close> by blast
next
case False
then show ?thesis
using children step.hyps to_tree_order_either_ptr_or_in_children
by (metis step.prems(1) step.prems(2))
qed
qed
qed
lemma to_tree_order_ok:
assumes wellformed: "heap_is_wellformed h"
and "ptr |\<in>| object_ptr_kinds h"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "h \<turnstile> ok (to_tree_order ptr)"
proof(insert assms(1) assms(2), induct rule: heap_wellformed_induct)
case (step parent)
then show ?case
using assms(3) type_wf
apply(simp add: to_tree_order_def)
apply(auto simp add: heap_is_wellformed_def intro!: map_M_ok_I bind_is_OK_pure_I map_M_pure_I)[1]
using get_child_nodes_ok known_ptrs_known_ptr apply blast
by (simp add: local.heap_is_wellformed_children_in_heap local.to_tree_order_def wellformed)
qed
lemma to_tree_order_child_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "node \<in> set children"
and "h \<turnstile> to_tree_order (cast node) \<rightarrow>\<^sub>r nodes'"
shows "set nodes' \<subseteq> set nodes"
proof
fix x
assume a1: "x \<in> set nodes'"
moreover obtain treeorders
where treeorders: "h \<turnstile> map_M to_tree_order (map cast children) \<rightarrow>\<^sub>r treeorders"
using assms(2) assms(3)
apply(auto simp add: to_tree_order_def elim!: bind_returns_result_E)[1]
using pure_returns_heap_eq returns_result_eq by fastforce
then have "nodes' \<in> set treeorders"
using assms(4) assms(5)
by(auto elim!: map_M_pure_E dest: returns_result_eq)
moreover have "set (concat treeorders) \<subseteq> set nodes"
using treeorders assms(2) assms(3)
by(auto simp add: to_tree_order_def elim!: bind_returns_result_E4 dest: pure_returns_heap_eq)
ultimately show "x \<in> set nodes"
by auto
qed
lemma to_tree_order_ptr_in_result:
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
shows "ptr \<in> set nodes"
using assms
apply(simp add: to_tree_order_def)
by(auto elim!: bind_returns_result_E2 intro!: map_M_pure_I bind_pure_I)
lemma to_tree_order_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
and "node \<in> set nodes"
and "h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "set nodes' \<subseteq> set nodes"
proof -
have "\<forall>nodes. h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<longrightarrow> (\<forall>node. node \<in> set nodes
\<longrightarrow> (\<forall>nodes'. h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<longrightarrow> set nodes' \<subseteq> set nodes))"
proof(insert assms(1), induct ptr rule: heap_wellformed_induct)
case (step parent)
then show ?case
proof safe
fix nodes node nodes' x
assume 1: "(\<And>children child.
h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> \<forall>nodes. h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes
\<longrightarrow> (\<forall>node. node \<in> set nodes \<longrightarrow> (\<forall>nodes'. h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'
\<longrightarrow> set nodes' \<subseteq> set nodes)))"
and 2: "h \<turnstile> to_tree_order parent \<rightarrow>\<^sub>r nodes"
and 3: "node \<in> set nodes"
and "h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'"
and "x \<in> set nodes'"
have h1: "(\<And>children child nodes node nodes'.
h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes
\<longrightarrow> (node \<in> set nodes \<longrightarrow> (h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<longrightarrow> set nodes' \<subseteq> set nodes)))"
using 1
by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using 2
by(auto simp add: to_tree_order_def elim!: bind_returns_result_E)
then have "set nodes' \<subseteq> set nodes"
proof (cases "children = []")
case True
then show ?thesis
by (metis "2" "3" \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> children empty_iff list.set(1)
subsetI to_tree_order_either_ptr_or_in_children)
next
case False
then show ?thesis
proof (cases "node = parent")
case True
then show ?thesis
using "2" \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> returns_result_eq by fastforce
next
case False
then obtain child nodes_of_child where
"child \<in> set children" and
"h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes_of_child" and
"node \<in> set nodes_of_child"
using 2[simplified to_tree_order_def] 3
to_tree_order_either_ptr_or_in_children[where node=node and ptr=parent] children
apply(auto elim!: bind_returns_result_E2 intro: map_M_pure_I)[1]
using is_OK_returns_result_E 2 a_all_ptrs_in_heap_def assms(1) heap_is_wellformed_def
using "3" by blast
then have "set nodes' \<subseteq> set nodes_of_child"
using h1
using \<open>h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes'\<close> children by blast
moreover have "set nodes_of_child \<subseteq> set nodes"
using "2" \<open>child \<in> set children\<close> \<open>h \<turnstile> to_tree_order (cast child) \<rightarrow>\<^sub>r nodes_of_child\<close>
assms children to_tree_order_child_subset by auto
ultimately show ?thesis
by blast
qed
qed
then show "x \<in> set nodes"
using \<open>x \<in> set nodes'\<close> by blast
qed
qed
then show ?thesis
using assms by blast
qed
lemma to_tree_order_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
assumes "parent \<in> set nodes"
shows "cast child \<in> set nodes"
proof -
obtain nodes' where nodes': "h \<turnstile> to_tree_order parent \<rightarrow>\<^sub>r nodes'"
using assms to_tree_order_ok get_parent_parent_in_heap
by (meson get_parent_parent_in_heap is_OK_returns_result_E)
then have "set nodes' \<subseteq> set nodes"
using to_tree_order_subset assms
by blast
moreover obtain children where
children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children" and
child: "child \<in> set children"
using assms get_parent_child_dual by blast
then obtain child_to where child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r child_to"
by (meson assms(1) assms(2) assms(3) assms(5) is_OK_returns_result_E is_OK_returns_result_I
get_parent_ptr_in_heap node_ptr_kinds_commutes to_tree_order_ok)
then have "cast child \<in> set child_to"
apply(simp add: to_tree_order_def)
by(auto elim!: bind_returns_result_E2 map_M_pure_E
dest!: bind_returns_result_E3[rotated, OF children, rotated] intro!: map_M_pure_I)
have "cast child \<in> set nodes'"
using nodes' child
apply(simp add: to_tree_order_def)
apply(auto elim!: bind_returns_result_E2 map_M_pure_E
dest!: bind_returns_result_E3[rotated, OF children, rotated] intro!: map_M_pure_I)[1]
using child_to \<open>cast child \<in> set child_to\<close> returns_result_eq by fastforce
ultimately show ?thesis
by auto
qed
lemma to_tree_order_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
assumes "cast child \<noteq> ptr"
assumes "child \<in> set children"
assumes "cast child \<in> set nodes"
shows "parent \<in> set nodes"
proof(insert assms(1) assms(4) assms(6) assms(8), induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"cast child \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
by (metis (full_types) assms(1) assms(2) assms(3) get_parent_ptr_in_heap
is_OK_returns_result_I l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.child_parent_dual
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_kinds_commutes
returns_result_select_result step.prems(1) step.prems(2) step.prems(3)
to_tree_order_either_ptr_or_in_children to_tree_order_ok)
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
show ?thesis
proof (cases "c = child")
case True
then have "parent = p"
using step(3) children child assms(5) assms(7)
by (meson assms(1) assms(2) assms(3) child_parent_dual option.inject returns_result_eq)
then show ?thesis
using step.prems(1) to_tree_order_ptr_in_result by blast
next
case False
then show ?thesis
using step(1)[OF children child child_to] step(3) step(4)
using \<open>set child_to \<subseteq> set nodes\<close>
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child \<in> set child_to\<close> by auto
qed
qed
qed
lemma to_tree_order_node_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "ptr' \<noteq> ptr"
assumes "ptr' \<in> set nodes"
shows "is_node_ptr_kind ptr'"
proof(insert assms(1) assms(4) assms(5) assms(6), induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"ptr' \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
using step.prems(1) step.prems(2) step.prems(3) to_tree_order_either_ptr_or_in_children by blast
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
show ?thesis
proof (cases "cast c = ptr")
case True
then show ?thesis
using step \<open>ptr' \<in> set child_to\<close> assms(5) child child_to children by blast
next
case False
then show ?thesis
using \<open>ptr' \<in> set child_to\<close> child child_to children is_node_ptr_kind_cast step.hyps by blast
qed
qed
qed
lemma to_tree_order_child2:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "cast child \<noteq> ptr"
assumes "cast child \<in> set nodes"
obtains parent where "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent" and "parent \<in> set nodes"
proof -
assume 1: "(\<And>parent. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent \<Longrightarrow> parent \<in> set nodes \<Longrightarrow> thesis)"
show thesis
proof(insert assms(1) assms(4) assms(5) assms(6) 1, induct ptr arbitrary: nodes
rule: heap_wellformed_induct)
case (step p)
have "p |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> to_tree_order p \<rightarrow>\<^sub>r nodes\<close> to_tree_order_ptr_in_heap
using assms(1) assms(2) assms(3) by blast
then obtain children where children: "h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children"
by (meson assms(2) assms(3) get_child_nodes_ok is_OK_returns_result_E local.known_ptrs_known_ptr)
then show ?case
proof (cases "children = []")
case True
then show ?thesis
using step(2) step(3) step(4) children
by(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])
next
case False
then obtain c child_to where
child: "c \<in> set children" and
child_to: "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r c) \<rightarrow>\<^sub>r child_to" and
"cast child \<in> set child_to"
using step(2) children
apply(auto simp add: to_tree_order_def[of p] map_M_pure_I elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF children, rotated])[1]
using step.prems(1) step.prems(2) step.prems(3) to_tree_order_either_ptr_or_in_children
by blast
then have "set child_to \<subseteq> set nodes"
using assms(1) child children step.prems(1) to_tree_order_child_subset by auto
have "cast child |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) assms(4) assms(6) to_tree_order_ptrs_in_heap by blast
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
by (meson assms(2) assms(3) is_OK_returns_result_E get_parent_ok node_ptr_kinds_commutes)
then show ?thesis
proof (induct parent_opt)
case None
then show ?case
by (metis \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child \<in> set child_to\<close> assms(1) assms(2) assms(3)
cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject child child_parent_dual child_to children
option.distinct(1) returns_result_eq step.hyps)
next
case (Some option)
then show ?case
by (meson assms(1) assms(2) assms(3) get_parent_child_dual step.prems(1) step.prems(2)
step.prems(3) step.prems(4) to_tree_order_child)
qed
qed
qed
qed
lemma to_tree_order_parent_child_rel:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
shows "(ptr, child) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> child \<in> set to"
proof
assume 3: "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
show "child \<in> set to"
proof (insert 3, induct child rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4)
apply(simp add: to_tree_order_def)
by(auto simp add: map_M_pure_I elim!: bind_returns_result_E2)
next
case False
obtain child_parent where
"(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*" and
"(child_parent, child) \<in> (parent_child_rel h)"
using \<open>ptr \<noteq> child\<close>
by (metis "1.prems" rtranclE)
obtain child_node where child_node: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child"
using \<open>(child_parent, child) \<in> parent_child_rel h\<close> node_ptr_casts_commute3
parent_child_rel_node_ptr
by blast
then have "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some child_parent"
using \<open>(child_parent, child) \<in> (parent_child_rel h)\<close>
by (meson assms(1) assms(2) assms(3) is_OK_returns_result_E l_get_parent_wf.child_parent_dual
l_heap_is_wellformed.parent_child_rel_child local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_get_parent_wf_axioms
local.l_heap_is_wellformed_axioms local.parent_child_rel_parent_in_heap)
then show ?thesis
using 1(1) child_node \<open>(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*\<close>
using assms(1) assms(2) assms(3) assms(4) to_tree_order_parent by blast
qed
qed
next
assume "child \<in> set to"
then show "(ptr, child) \<in> (parent_child_rel h)\<^sup>*"
proof (induct child rule: heap_wellformed_induct_rev[OF assms(1)])
case (1 child)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
then have "\<exists>parent. (parent, child) \<in> (parent_child_rel h)"
using 1(2) assms(4) to_tree_order_child2[OF assms(1) assms(2) assms(3) assms(4)]
to_tree_order_node_ptrs
by (metis assms(1) assms(2) assms(3) node_ptr_casts_commute3 parent_child_rel_parent)
then obtain child_node where child_node: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child"
using node_ptr_casts_commute3 parent_child_rel_node_ptr by blast
then obtain child_parent where child_parent: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some child_parent"
using \<open>\<exists>parent. (parent, child) \<in> (parent_child_rel h)\<close>
by (metis "1.prems" False assms(1) assms(2) assms(3) assms(4) to_tree_order_child2)
then have "(child_parent, child) \<in> (parent_child_rel h)"
using assms(1) child_node parent_child_rel_parent by blast
moreover have "child_parent \<in> set to"
by (metis "1.prems" False assms(1) assms(2) assms(3) assms(4) child_node child_parent
get_parent_child_dual to_tree_order_child)
then have "(ptr, child_parent) \<in> (parent_child_rel h)\<^sup>*"
using 1 child_node child_parent by blast
ultimately show ?thesis
by auto
qed
qed
qed
end
interpretation i_to_tree_order_wf?: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent
get_parent_locs heap_is_wellformed parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs
using instances
apply(simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
done
declare l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_to_tree_order_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_to_tree_order_defs
+ l_get_parent_defs + l_get_child_nodes_defs +
assumes to_tree_order_ok:
"heap_is_wellformed h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (to_tree_order ptr)"
assumes to_tree_order_ptrs_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> ptr' \<in> set to \<Longrightarrow> ptr' |\<in>| object_ptr_kinds h"
assumes to_tree_order_parent_child_rel:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> (ptr, child_ptr) \<in> (parent_child_rel h)\<^sup>* \<longleftrightarrow> child_ptr \<in> set to"
assumes to_tree_order_child2:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> cast child \<noteq> ptr \<Longrightarrow> cast child \<in> set nodes
\<Longrightarrow> (\<And>parent. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent
\<Longrightarrow> parent \<in> set nodes \<Longrightarrow> thesis)
\<Longrightarrow> thesis"
assumes to_tree_order_node_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> ptr' \<noteq> ptr \<Longrightarrow> ptr' \<in> set nodes \<Longrightarrow> is_node_ptr_kind ptr'"
assumes to_tree_order_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow> cast child \<noteq> ptr
\<Longrightarrow> child \<in> set children \<Longrightarrow> cast child \<in> set nodes
\<Longrightarrow> parent \<in> set nodes"
assumes to_tree_order_ptr_in_result:
"h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<Longrightarrow> ptr \<in> set nodes"
assumes to_tree_order_parent:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes
\<Longrightarrow> h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent \<Longrightarrow> parent \<in> set nodes
\<Longrightarrow> cast child \<in> set nodes"
assumes to_tree_order_subset:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes \<Longrightarrow> node \<in> set nodes
\<Longrightarrow> h \<turnstile> to_tree_order node \<rightarrow>\<^sub>r nodes' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> set nodes' \<subseteq> set nodes"
lemma to_tree_order_wf_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
using instances
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def)[1]
using to_tree_order_ok
apply blast
using to_tree_order_ptrs_in_heap
apply blast
using to_tree_order_parent_child_rel
apply(blast, blast)
using to_tree_order_child2
apply blast
using to_tree_order_node_ptrs
apply blast
using to_tree_order_child
apply blast
using to_tree_order_ptr_in_result
apply blast
using to_tree_order_parent
apply blast
using to_tree_order_subset
apply blast
done
subsubsection \<open>get\_root\_node\<close>
locale l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_to_tree_order_wf
begin
lemma to_tree_order_get_root_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
assumes "ptr'' \<in> set to"
shows "h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
proof -
obtain ancestors' where ancestors': "h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_ok is_OK_returns_result_E
to_tree_order_ptrs_in_heap )
moreover have "ptr \<in> set ancestors'"
using \<open>h \<turnstile> get_ancestors ptr' \<rightarrow>\<^sub>r ancestors'\<close>
using assms(1) assms(2) assms(3) assms(4) assms(5) get_ancestors_parent_child_rel
to_tree_order_parent_child_rel by blast
ultimately have "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr\<close>
using assms(1) assms(2) assms(3) get_ancestors_ptr get_ancestors_same_root_node by blast
obtain ancestors'' where ancestors'': "h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''"
by (meson assms(1) assms(2) assms(3) assms(4) assms(7) get_ancestors_ok is_OK_returns_result_E
to_tree_order_ptrs_in_heap)
moreover have "ptr \<in> set ancestors''"
using \<open>h \<turnstile> get_ancestors ptr'' \<rightarrow>\<^sub>r ancestors''\<close>
using assms(1) assms(2) assms(3) assms(4) assms(7) get_ancestors_parent_child_rel
to_tree_order_parent_child_rel by blast
ultimately show ?thesis
using \<open>h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr\<close> assms(1) assms(2) assms(3) get_ancestors_ptr
get_ancestors_same_root_node by blast
qed
lemma to_tree_order_same_root:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
assumes "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r to"
assumes "ptr' \<in> set to"
shows "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
proof (insert assms(1)(* assms(4) assms(5) *) assms(6), induct ptr' rule: heap_wellformed_induct_rev)
case (step child)
then show ?case
proof (cases "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child")
case True
then have "child = root_ptr"
using assms(1) assms(2) assms(3) assms(5) step.prems
by (metis (no_types, lifting) get_root_node_same_no_parent node_ptr_casts_commute3
option.simps(3) returns_result_eq to_tree_order_child2 to_tree_order_node_ptrs)
then show ?thesis
using True by blast
next
case False
then obtain child_node parent where "cast child_node = child"
and "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
by (metis assms(1) assms(2) assms(3) assms(4) assms(5) local.get_root_node_no_parent
local.get_root_node_not_node_same local.get_root_node_same_no_parent
local.to_tree_order_child2 local.to_tree_order_ptrs_in_heap node_ptr_casts_commute3
step.prems)
then show ?thesis
proof (cases "child = root_ptr")
case True
then have "h \<turnstile> get_root_node root_ptr \<rightarrow>\<^sub>r root_ptr"
using assms(4)
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child\<close> assms(1) assms(2) assms(3)
get_root_node_no_parent get_root_node_same_no_parent
by blast
then show ?thesis
using step assms(4)
using True by blast
next
case False
then have "parent \<in> set to"
using assms(5) step(2) to_tree_order_child \<open>h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent\<close>
\<open>cast child_node = child\<close>
by (metis False assms(1) assms(2) assms(3) get_parent_child_dual)
then show ?thesis
using \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node = child\<close> \<open>h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent\<close>
get_root_node_parent_same
using step.hyps by blast
qed
qed
qed
end
interpretation i_to_tree_order_wf_get_root_node_wf?: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs get_ancestors
get_ancestors_locs get_root_node get_root_node_locs to_tree_order
using instances
by(simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
locale l_to_tree_order_wf_get_root_node_wf = l_type_wf + l_known_ptrs + l_to_tree_order_defs
+ l_get_root_node_defs + l_heap_is_wellformed_defs +
assumes to_tree_order_get_root_node:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to
\<Longrightarrow> ptr' \<in> set to \<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr
\<Longrightarrow> ptr'' \<in> set to \<Longrightarrow> h \<turnstile> get_root_node ptr'' \<rightarrow>\<^sub>r root_ptr"
assumes to_tree_order_same_root:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr
\<Longrightarrow> h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r to \<Longrightarrow> ptr' \<in> set to
\<Longrightarrow> h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
lemma to_tree_order_wf_get_root_node_wf_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf type_wf known_ptr known_ptrs to_tree_order
get_root_node heap_is_wellformed"
using instances
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def
l_to_tree_order_wf_get_root_node_wf_axioms_def)[1]
using to_tree_order_get_root_node apply blast
using to_tree_order_same_root apply blast
done
subsection \<open>get\_owner\_document\<close>
locale l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_known_ptrs
+ l_heap_is_wellformed
+ l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_ancestors
+ l_get_ancestors_wf
+ l_get_parent
+ l_get_parent_wf
+ l_get_root_node_wf
+ l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_owner_document_disconnected_nodes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
assumes known_ptrs: "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
proof -
have 2: "node_ptr |\<in>| node_ptr_kinds h"
using assms heap_is_wellformed_disc_nodes_in_heap
by blast
have 3: "document_ptr |\<in>| document_ptr_kinds h"
using assms(2) get_disconnected_nodes_ptr_in_heap by blast
have 0:
"\<exists>!document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by (metis (no_types, lifting) "3" DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) assms(2) assms(3)
disjoint_iff_not_equal l_heap_is_wellformed.heap_is_wellformed_one_disc_parent
local.get_disconnected_nodes_ok local.l_heap_is_wellformed_axioms
returns_result_select_result select_result_I2 type_wf)
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
using heap_is_wellformed_children_disc_nodes_different child_parent_dual assms
using "2" disjoint_iff_not_equal local.get_parent_child_dual local.get_parent_ok
returns_result_select_result split_option_ex
by (metis (no_types, lifting))
then have 4: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using 2 get_root_node_no_parent
by blast
obtain document_ptrs where document_ptrs: "h \<turnstile> document_ptr_kinds_M \<rightarrow>\<^sub>r document_ptrs"
by simp
then
have "h \<turnstile> ok (filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs)"
using assms(1) get_disconnected_nodes_ok type_wf unfolding heap_is_wellformed_def
by(auto intro!: bind_is_OK_I2 filter_M_is_OK_I bind_pure_I)
then obtain candidates where
candidates: "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r candidates"
by auto
have eq: "\<And>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<Longrightarrow> node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r \<longleftrightarrow> |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}|\<^sub>r"
apply(auto dest!: get_disconnected_nodes_ok[OF type_wf]
intro!: select_result_I[where P=id, simplified] elim!: bind_returns_result_E2)[1]
apply(drule select_result_E[where P=id, simplified])
by(auto elim!: bind_returns_result_E2)
have filter: "filter (\<lambda>document_ptr. |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \<in> cast ` set disconnected_nodes)
}|\<^sub>r) document_ptrs = [document_ptr]"
apply(rule filter_ex1)
using 0 document_ptrs apply(simp)[1]
using eq
using local.get_disconnected_nodes_ok apply auto[1]
using assms(2) assms(3)
apply(auto intro!: intro!: select_result_I[where P=id, simplified]
elim!: bind_returns_result_E2)[1]
using returns_result_eq apply fastforce
using document_ptrs 3 apply(simp)
using document_ptrs
by simp
have "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r [document_ptr]"
apply(rule filter_M_filter2)
using get_disconnected_nodes_ok document_ptrs 3 assms(1) type_wf filter
unfolding heap_is_wellformed_def
by(auto intro: bind_pure_I bind_is_OK_I2)
with 4 document_ptrs have "h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r document_ptr"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I
split: option.splits)[1]
moreover have "known_ptr (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)"
using "4" assms(1) known_ptrs type_wf known_ptrs_known_ptr "2" node_ptr_kinds_commutes by blast
ultimately show ?thesis
using 2
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto split: option.splits intro!: bind_pure_returns_result_I)
qed
lemma in_disconnected_nodes_no_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
and "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document"
and "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
have 2: "cast node_ptr |\<in>| object_ptr_kinds h"
using assms(3) get_owner_document_ptr_in_heap by fast
then have 3: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using assms(2) local.get_root_node_no_parent by blast
have "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
apply(auto)[1]
using assms(2) child_parent_dual[OF assms(1)] type_wf
assms(1) assms(5) get_child_nodes_ok known_ptrs_known_ptr option.simps(3)
returns_result_eq returns_result_select_result
by (metis (no_types, opaque_lifting))
moreover have "node_ptr |\<in>| node_ptr_kinds h"
using assms(2) get_parent_ptr_in_heap by blast
ultimately
have 0: "\<exists>document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by (metis DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) finite_set_in heap_is_wellformed_children_disc_nodes)
then obtain document_ptr where
document_ptr: "document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r" and
node_ptr_in_disc_nodes: "node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by auto
then show ?thesis
using get_owner_document_disconnected_nodes known_ptrs type_wf assms
using DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) assms(3) assms(4) get_disconnected_nodes_ok
returns_result_select_result select_result_I2
by (metis (no_types, opaque_lifting) )
qed
lemma get_owner_document_owner_document_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
using assms
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_split_asm)+
proof -
assume "h \<turnstile> invoke [] ptr () \<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by (meson invoke_empty is_OK_returns_result_I)
next
assume "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())
\<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: if_splits)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then obtain root where
root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using 4 5 root
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using "0" "1" "2" document_ptr_kinds_commutes local.get_root_node_root_in_heap by blast
next
case False
have "known_ptr root"
using "0" "1" "2" local.get_root_node_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using "0" "1" "2" local.get_root_node_root_in_heap
by blast
then have "is_node_ptr_kind root"
using False \<open>known_ptr root\<close>
apply(simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). root \<in> cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
by (metis (no_types, lifting) "0" "1" "2" \<open>root |\<in>| object_ptr_kinds h\<close> local.child_parent_dual
local.get_child_nodes_ok local.get_root_node_same_no_parent local.heap_is_wellformed_children_disc_nodes
local.known_ptrs_known_ptr node_ptr_casts_commute3 node_ptr_inclusion node_ptr_kinds_commutes
notin_fset option.distinct(1) returns_result_eq returns_result_select_result root)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) "1" bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure notin_fset
return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
apply (simp add: \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>)
using "1" \<open>root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
\<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
local.get_disconnected_nodes_ok by auto
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using 5 root 4
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr) (\<lambda>_. (local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then obtain root where
root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using 3 4 root
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using "0" "1" "2" document_ptr_kinds_commutes local.get_root_node_root_in_heap by blast
next
case False
have "known_ptr root"
using "0" "1" "2" local.get_root_node_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using "0" "1" "2" local.get_root_node_root_in_heap
by blast
then have "is_node_ptr_kind root"
using False \<open>known_ptr root\<close>
apply(simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). root \<in> cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
by (metis (no_types, lifting) "0" "1" "2" \<open>root |\<in>| object_ptr_kinds h\<close>
local.child_parent_dual local.get_child_nodes_ok local.get_root_node_same_no_parent
local.heap_is_wellformed_children_disc_nodes local.known_ptrs_known_ptr node_ptr_casts_commute3
node_ptr_inclusion node_ptr_kinds_commutes notin_fset option.distinct(1) returns_result_eq
returns_result_select_result root)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) "1" bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure notin_fset
return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
apply (simp add: \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>)
using "1" \<open>root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
\<open>some_owner_document |\<in>| document_ptr_kinds h\<close> local.get_disconnected_nodes_ok
by auto
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using 4 root 3
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
qed
lemma get_owner_document_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_owner_document ptr)"
proof -
have "known_ptr ptr"
using assms(2) assms(4) local.known_ptrs_known_ptr
by blast
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(auto simp add: known_ptr_impl)[1]
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_element_ptr
apply blast
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply (metis (no_types, lifting) document_ptr_casts_commute3 document_ptr_kinds_commutes
is_document_ptr_kind_none option.case_eq_if)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply (metis (no_types, lifting) assms(1) assms(2) assms(3) is_node_ptr_kind_none
local.get_root_node_ok node_ptr_casts_commute3 option.case_eq_if)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply(auto split: option.splits intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
filter_M_is_OK_I)[1]
using assms(3) local.get_disconnected_nodes_ok
apply blast
apply (simp add: assms(1) assms(2) assms(3) local.get_root_node_ok)
using assms(4)
apply(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I)[1]
apply(auto split: option.splits intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
filter_M_is_OK_I)[1]
apply (simp add: assms(1) assms(2) assms(3) local.get_root_node_ok)[1]
apply(auto split: option.splits intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
filter_M_is_OK_I)[1]
using assms(3) local.get_disconnected_nodes_ok by blast
qed
lemma get_owner_document_child_same:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_child_nodes_ptr_in_heap)
then have "known_ptr ptr"
using assms(2) local.known_ptrs_known_ptr by blast
have "cast child |\<in>| object_ptr_kinds h"
using assms(1) assms(4) assms(5) local.heap_is_wellformed_children_in_heap node_ptr_kinds_commutes
by blast
then
have "known_ptr (cast child)"
using assms(2) local.known_ptrs_known_ptr by blast
obtain root where root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_root_node_ok)
then have "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root"
using assms(1) assms(2) assms(3) assms(4) assms(5) local.child_parent_dual
local.get_root_node_parent_same
by blast
have "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr ptr")
case True
then obtain document_ptr where document_ptr: "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr = ptr"
using case_optionE document_ptr_casts_commute by blast
then have "root = cast document_ptr"
using root
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have "h \<turnstile> a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using document_ptr
\<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast document_ptr\<close> document_ptr]
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2 dest!: bind_returns_result_E3[rotated,
OF \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast document_ptr\<close> document_ptr], rotated]
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: if_splits option.splits)[1]
using \<open>ptr |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes by blast
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> True
by(auto simp add: document_ptr[symmetric] intro!: bind_pure_returns_result_I
split: option.splits)
next
case False
then obtain node_ptr where node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = ptr"
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then have "h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using root \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>
unfolding a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
by (meson bind_pure_returns_result_I bind_returns_result_E3 local.get_root_node_pure)
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply (meson invoke_empty is_OK_returns_result_I)
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
by(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
qed
then show ?thesis
using \<open>known_ptr (cast child)\<close>
apply(auto simp add: get_owner_document_def[of "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child"]
a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
by (smt \<open>cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child |\<in>| object_ptr_kinds h\<close> cast_document_ptr_not_node_ptr(1)
comp_apply invoke_empty invoke_not invoke_returns_result is_OK_returns_result_I
node_ptr_casts_commute2 option.sel)
qed
end
locale l_get_owner_document_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_get_disconnected_nodes_defs + l_get_owner_document_defs
+ l_get_parent_defs + l_get_child_nodes_defs +
assumes get_owner_document_disconnected_nodes:
"heap_is_wellformed h \<Longrightarrow>
known_ptrs h \<Longrightarrow>
type_wf h \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
node_ptr \<in> set disc_nodes \<Longrightarrow>
h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
assumes in_disconnected_nodes_no_parent:
"heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None\<Longrightarrow>
h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
known_ptrs h \<Longrightarrow>
type_wf h\<Longrightarrow>
node_ptr \<in> set disc_nodes"
assumes get_owner_document_owner_document_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow>
h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<Longrightarrow>
owner_document |\<in>| document_ptr_kinds h"
assumes get_owner_document_ok:
"heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h
\<Longrightarrow> h \<turnstile> ok (get_owner_document ptr)"
assumes get_owner_document_child_same:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document"
interpretation i_get_owner_document_wf?: l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr known_ptrs type_wf heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs get_ancestors
get_ancestors_locs get_root_node get_root_node_locs get_owner_document
by(auto simp add: l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_wf_is_l_get_owner_document_wf [instances]:
"l_get_owner_document_wf heap_is_wellformed type_wf known_ptr known_ptrs get_disconnected_nodes
get_owner_document get_parent get_child_nodes"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_owner_document_wf_def l_get_owner_document_wf_axioms_def)[1]
using get_owner_document_disconnected_nodes apply fast
using in_disconnected_nodes_no_parent apply fast
using get_owner_document_owner_document_in_heap apply fast
using get_owner_document_ok apply fast
using get_owner_document_child_same apply (fast, fast)
done
subsubsection \<open>get\_root\_node\<close>
locale l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node_wf +
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf
begin
lemma get_root_node_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
assumes "is_document_ptr_kind root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r the (cast root)"
proof -
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_result_I local.get_root_node_ptr_in_heap)
then have "known_ptr ptr"
using assms(3) local.known_ptrs_known_ptr by blast
{
assume "is_document_ptr_kind ptr"
then have "ptr = root"
using assms(4)
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have ?thesis
using \<open>is_document_ptr_kind ptr\<close> \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I
split: option.splits)
}
moreover
{
assume "is_node_ptr_kind ptr"
then have ?thesis
using \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
apply(auto split: option.splits)[1]
using \<open>h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root\<close> assms(5)
by(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def
intro!: bind_pure_returns_result_I split: option.splits)[2]
}
ultimately
show ?thesis
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
qed
lemma get_root_node_same_owner_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_root_node_ptr_in_heap)
have "root |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_root_in_heap by blast
have "known_ptr ptr"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
have "known_ptr root"
using \<open>root |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
show ?thesis
proof (cases "is_document_ptr_kind ptr")
case True
then
have "ptr = root"
using assms(4)
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
by (metis document_ptr_casts_commute3 last_ConsL local.get_ancestors_not_node node_ptr_no_document_ptr_cast)
then show ?thesis
by auto
next
case False
then have "is_node_ptr_kind ptr"
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain node_ptr where node_ptr: "ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"
by (metis node_ptr_casts_commute3)
show ?thesis
proof
assume "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
using node_ptr
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto elim!: bind_returns_result_E2 split: option.splits)
show "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
have "is_document_ptr root"
using True \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
have "root = cast owner_document"
using True
by (smt \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3) assms(4)
document_ptr_casts_commute3 get_root_node_document returns_result_eq)
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root\<close> apply blast
using \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_node_ptr_kind_none)
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> assms(4)
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis assms(1) assms(2) assms(3) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq)
using \<open>is_node_ptr_kind root\<close> node_ptr returns_result_eq by fastforce
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_node_ptr_kind root\<close> \<open>known_ptr root\<close>
apply(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
apply(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: root_node_ptr)
qed
next
assume "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
show "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
have "root = cast owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
apply(auto simp add: True a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: if_splits)[1]
apply (metis True cast_document_ptr_not_node_ptr(2) is_document_ptr_kind_obtains
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
by (metis True cast_document_ptr_not_node_ptr(1) document_ptr_casts_commute3
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) get_root_node_document
by fastforce
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto simp add: is_document_ptr_kind_none elim!: bind_returns_result_E2)
then have "h \<turnstile> local.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
apply(auto simp add: a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq root_node_ptr
by fastforce+
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using node_ptr \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
by(auto simp add: known_ptr_impl DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
intro!: bind_pure_returns_result_I split: option.splits)
qed
qed
qed
qed
end
interpretation get_owner_document_wf_get_root_node_wf?: l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs heap_is_wellformed
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs get_owner_document
by(auto simp add: l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_owner_document_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_owner_document_wf_get_root_node_wf = l_heap_is_wellformed_defs + l_type_wf +
l_known_ptrs + l_get_root_node_defs + l_get_owner_document_defs +
assumes get_root_node_document:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow>
is_document_ptr_kind root \<Longrightarrow> h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r the (cast root)"
assumes get_root_node_same_owner_document:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root \<Longrightarrow>
h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
lemma get_owner_document_wf_get_root_node_wf_is_l_get_owner_document_wf_get_root_node_wf [instances]:
"l_get_owner_document_wf_get_root_node_wf heap_is_wellformed type_wf known_ptr known_ptrs
get_root_node get_owner_document"
apply(auto simp add: l_get_owner_document_wf_get_root_node_wf_def
l_get_owner_document_wf_get_root_node_wf_axioms_def instances)[1]
using get_root_node_document apply blast
using get_root_node_same_owner_document apply (blast, blast)
done
subsection \<open>Preserving heap-wellformedness\<close>
subsection \<open>set\_attribute\<close>
locale l_set_attribute_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_attribute\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_attribute_get_disconnected_nodes +
l_set_attribute_get_child_nodes
begin
lemma set_attribute_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> set_attribute element_ptr k v \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
thm preserves_wellformedness_writes_needed
apply(rule preserves_wellformedness_writes_needed[OF assms set_attribute_writes])
using set_attribute_get_child_nodes
apply(fast)
using set_attribute_get_disconnected_nodes apply(fast)
by(auto simp add: all_args_def set_attribute_locs_def)
end
subsection \<open>remove\_child\<close>
locale l_remove_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_set_disconnected_nodes_get_child_nodes
begin
lemma remove_child_removes_parent:
assumes wellformed: "heap_is_wellformed h"
and remove_child: "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h2"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "h2 \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof -
obtain children where children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using remove_child remove_child_def by auto
then have "child \<in> set children"
using remove_child remove_child_def
by(auto elim!: bind_returns_heap_E dest: returns_result_eq split: if_splits)
then have h1: "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
using assms(1) known_ptrs type_wf child_parent_dual
by (meson child_parent_dual children option.inject returns_result_eq)
have known_ptr: "known_ptr ptr"
using known_ptrs
by (meson is_OK_returns_heap_I l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms
remove_child remove_child_ptr_in_heap)
obtain owner_document disc_nodes h' where
owner_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document" and
disc_nodes: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h': "h \<turnstile> set_disconnected_nodes owner_document (child # disc_nodes) \<rightarrow>\<^sub>h h'" and
h2: "h' \<turnstile> set_child_nodes ptr (remove1 child children) \<rightarrow>\<^sub>h h2"
using assms children unfolding remove_child_def
apply(auto split: if_splits elim!: bind_returns_heap_E)[1]
by (metis (full_types) get_child_nodes_pure get_disconnected_nodes_pure
get_owner_document_pure pure_returns_heap_eq returns_result_eq)
have "object_ptr_kinds h = object_ptr_kinds h2"
using remove_child_writes remove_child unfolding remove_child_locs_def
apply(rule writes_small_big)
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
then have "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
unfolding object_ptr_kinds_M_defs by simp
have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF remove_child_writes remove_child] unfolding remove_child_locs_def
using set_disconnected_nodes_types_preserved set_child_nodes_types_preserved type_wf
apply(auto simp add: reflp_def transp_def)[1]
by blast
then obtain children' where children': "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'"
using h2 set_child_nodes_get_child_nodes known_ptr
by (metis \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> children get_child_nodes_ok
get_child_nodes_ptr_in_heap is_OK_returns_result_E is_OK_returns_result_I)
have "child \<notin> set children'"
by (metis (mono_tags, lifting) \<open>type_wf h'\<close> children children' distinct_remove1_removeAll h2
known_ptr local.heap_is_wellformed_children_distinct
local.set_child_nodes_get_child_nodes member_remove remove_code(1) select_result_I2
wellformed)
moreover have "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
proof -
fix other_ptr other_children
assume a1: "other_ptr \<noteq> ptr" and a3: "h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
have "h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
using get_child_nodes_reads set_disconnected_nodes_writes h' a3
apply(rule reads_writes_separate_backwards)
using set_disconnected_nodes_get_child_nodes by fast
show "child \<notin> set other_children"
using \<open>h \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children\<close> a1 h1 by blast
qed
then have "\<And>other_ptr other_children. other_ptr \<noteq> ptr
\<Longrightarrow> h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children \<Longrightarrow> child \<notin> set other_children"
proof -
fix other_ptr other_children
assume a1: "other_ptr \<noteq> ptr" and a3: "h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
have "h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children"
using get_child_nodes_reads set_child_nodes_writes h2 a3
apply(rule reads_writes_separate_backwards)
using set_disconnected_nodes_get_child_nodes a1 set_child_nodes_get_child_nodes_different_pointers
by metis
then show "child \<notin> set other_children"
using \<open>\<And>other_ptr other_children. \<lbrakk>other_ptr \<noteq> ptr; h' \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children\<rbrakk>
\<Longrightarrow> child \<notin> set other_children\<close> a1 by blast
qed
ultimately have ha: "\<And>other_ptr other_children. h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children
\<Longrightarrow> child \<notin> set other_children"
by (metis (full_types) children' returns_result_eq)
moreover obtain ptrs where ptrs: "h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by (simp add: object_ptr_kinds_M_defs)
moreover have "\<And>ptr. ptr \<in> set ptrs \<Longrightarrow> h2 \<turnstile> ok (get_child_nodes ptr)"
using \<open>type_wf h2\<close> ptrs get_child_nodes_ok known_ptr
using \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> known_ptrs local.known_ptrs_known_ptr by auto
ultimately show "h2 \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
apply(auto simp add: get_parent_def intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I)[1]
proof -
have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child |\<in>| object_ptr_kinds h"
using get_owner_document_ptr_in_heap owner_document by blast
then show "h2 \<turnstile> check_in_heap (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r ()"
by (simp add: \<open>object_ptr_kinds h = object_ptr_kinds h2\<close> check_in_heap_def)
next
show "(\<And>other_ptr other_children. h2 \<turnstile> get_child_nodes other_ptr \<rightarrow>\<^sub>r other_children
\<Longrightarrow> child \<notin> set other_children) \<Longrightarrow>
ptrs = sorted_list_of_set (fset (object_ptr_kinds h2)) \<Longrightarrow>
(\<And>ptr. ptr |\<in>| object_ptr_kinds h2 \<Longrightarrow> h2 \<turnstile> ok get_child_nodes ptr) \<Longrightarrow>
h2 \<turnstile> filter_M (\<lambda>ptr. Heap_Error_Monad.bind (get_child_nodes ptr)
(\<lambda>children. return (child \<in> set children))) (sorted_list_of_set (fset (object_ptr_kinds h2))) \<rightarrow>\<^sub>r []"
by(auto intro!: filter_M_empty_I bind_pure_I)
qed
qed
end
locale l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_child_parent_child_rel_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "parent_child_rel h' \<subseteq> parent_child_rel h"
proof (standard, safe)
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure]
split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_eq: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
using node_ptr_kinds_M_eq by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
using document_ptr_kinds_M_eq by auto
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq:
"\<And>document_ptr disconnected_nodes. document_ptr \<noteq> owner_document
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_child_nodes_get_disconnected_nodes set_disconnected_nodes_get_disconnected_nodes_different_pointers
by (metis (no_types, lifting) Un_iff owner_document select_result_I2)
then have disconnected_nodes_eq2:
"\<And>document_ptr. document_ptr \<noteq> owner_document
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_child_nodes_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(2) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply(simp)
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
fix parent child
assume a1: "(parent, child) \<in> parent_child_rel h'"
then show "(parent, child) \<in> parent_child_rel h"
proof (cases "parent = ptr")
case True
then show ?thesis
using a1 remove_child_removes_parent[OF assms(1) assms(2)] children_h children_h'
get_child_nodes_ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_eq )[1]
by (metis notin_set_remove1)
next
case False
then show ?thesis
using a1
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq3 children_eq2)
qed
qed
lemma remove_child_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure] split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_eq: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
using node_ptr_kinds_M_eq by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
using document_ptr_kinds_M_eq by auto
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children =
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq: "\<And>document_ptr disconnected_nodes. document_ptr \<noteq> owner_document
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads remove_child_writes assms(2)])
unfolding remove_child_locs_def
using set_child_nodes_get_disconnected_nodes
set_disconnected_nodes_get_disconnected_nodes_different_pointers
by (metis (no_types, lifting) Un_iff owner_document select_result_I2)
then have disconnected_nodes_eq2:
"\<And>document_ptr. document_ptr \<noteq> owner_document
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads
set_disconnected_nodes_writes h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
show "known_ptrs h'"
using object_ptr_kinds_eq3 known_ptrs_preserved \<open>known_ptrs h\<close> by blast
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved type_wf
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_child_nodes_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(2) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply simp
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
have disconnected_nodes_h2:
"h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using owner_document assms(2) h2 disconnected_nodes_h
apply (auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E2)
apply(auto split: if_splits)[1]
apply(simp)
by(auto simp add: local.set_disconnected_nodes_get_disconnected_nodes split: if_splits)
then have disconnected_nodes_h':
"h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
apply(rule reads_writes_separate_forwards[OF get_disconnected_nodes_reads set_child_nodes_writes h'])
by (simp add: set_child_nodes_get_disconnected_nodes)
moreover have "a_acyclic_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
proof (standard, safe)
fix parent child
assume a1: "(parent, child) \<in> parent_child_rel h'"
then show "(parent, child) \<in> parent_child_rel h"
proof (cases "parent = ptr")
case True
then show ?thesis
using a1 remove_child_removes_parent[OF assms(1) assms(2)] children_h children_h'
get_child_nodes_ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_eq )[1]
by (metis imageI notin_set_remove1)
next
case False
then show ?thesis
using a1
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq3 children_eq2)
qed
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3 disconnected_nodes_eq)[1]
apply (metis (no_types, lifting) \<open>type_wf h'\<close> assms(2) assms(3) local.get_child_nodes_ok
local.known_ptrs_known_ptr local.remove_child_children_subset notin_fset object_ptr_kinds_eq3
returns_result_select_result subset_code(1) type_wf)
apply (metis (no_types, lifting) assms(2) disconnected_nodes_eq2 disconnected_nodes_h
disconnected_nodes_h' document_ptr_kinds_eq3 finite_set_in local.remove_child_child_in_heap
node_ptr_kinds_eq3 select_result_I2 set_ConsD subset_code(1))
done
moreover have "a_owner_document_valid h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def object_ptr_kinds_eq3 document_ptr_kinds_eq3
node_ptr_kinds_eq3)[1]
proof -
fix node_ptr
assume 0: "\<forall>node_ptr\<in>fset (node_ptr_kinds h'). (\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h' \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
and 1: "node_ptr |\<in>| node_ptr_kinds h'"
and 2: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<longrightarrow>
node_ptr \<notin> set |h' \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
then show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h'
\<and> node_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
proof (cases "node_ptr = child")
case True
show ?thesis
apply(rule exI[where x=owner_document])
using children_eq2 disconnected_nodes_eq2 children_h children_h' disconnected_nodes_h' True
by (metis (no_types, lifting) get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I
list.set_intros(1) select_result_I2)
next
case False
then show ?thesis
using 0 1 2 children_eq2 children_h children_h' disconnected_nodes_eq2 disconnected_nodes_h
disconnected_nodes_h'
apply(auto simp add: children_eq2 disconnected_nodes_eq2 dest!: select_result_I2)[1]
by (metis children_eq2 disconnected_nodes_eq2 finite_set_in in_set_remove1 list.set_intros(2))
qed
qed
moreover
{
have h0: "a_distinct_lists h"
using assms(1) by (simp add: heap_is_wellformed_def)
moreover have ha1: "(\<Union>x\<in>set |h \<turnstile> object_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
using \<open>a_distinct_lists h\<close>
unfolding a_distinct_lists_def
by(auto)
have ha2: "ptr |\<in>| object_ptr_kinds h"
using children_h get_child_nodes_ptr_in_heap by blast
have ha3: "child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
using child_in_children_h children_h
by(simp)
have child_not_in: "\<And>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<Longrightarrow> child \<notin> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using ha1 ha2 ha3
apply(simp)
using IntI by fastforce
moreover have "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: object_ptr_kinds_M_defs)
moreover have "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: document_ptr_kinds_M_defs)
ultimately have "a_distinct_lists h'"
proof(simp (no_asm) add: a_distinct_lists_def, safe)
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
have 4: "distinct (concat ((map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)))"
using 1 by(auto simp add: a_distinct_lists_def)
show "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 3[unfolded object_ptr_kinds_eq2], simplified])
fix x
assume 5: "x |\<in>| object_ptr_kinds h'"
then have 6: "distinct |h \<turnstile> get_child_nodes x|\<^sub>r"
using 4 distinct_concat_map_E object_ptr_kinds_eq2 by fastforce
obtain children where children: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children"
and distinct_children: "distinct children"
by (metis "5" "6" type_wf assms(3) get_child_nodes_ok local.known_ptrs_known_ptr
object_ptr_kinds_eq3 select_result_I)
obtain children' where children': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
then have "distinct children'"
proof (cases "ptr = x")
case True
then show ?thesis
using children distinct_children children_h children_h'
by (metis children' distinct_remove1 returns_result_eq)
next
case False
then show ?thesis
using children distinct_children children_eq[OF False]
using children' distinct_lists_children h0
using select_result_I2 by fastforce
qed
then show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
using children' by(auto simp add: )
next
fix x y
assume 5: "x |\<in>| object_ptr_kinds h'" and 6: "y |\<in>| object_ptr_kinds h'" and 7: "x \<noteq> y"
obtain children_x where children_x: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x"
by (metis "5" type_wf assms(3) get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_y where children_y: "h \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y"
by (metis "6" type_wf assms(3) get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_x' where children_x': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x'"
using children_eq children_h' children_x by fastforce
obtain children_y' where children_y': "h' \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y'"
using children_eq children_h' children_y by fastforce
have "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r))"
using h0 by(auto simp add: a_distinct_lists_def)
then have 8: "set children_x \<inter> set children_y = {}"
using "7" assms(1) children_x children_y local.heap_is_wellformed_one_parent by blast
have "set children_x' \<inter> set children_y' = {}"
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
by(simp add: 7)
have "children_x' = remove1 child children_x"
using children_h children_h' children_x children_x' True returns_result_eq by fastforce
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
have "children_y' = remove1 child children_y"
using children_h children_h' children_y children_y' True returns_result_eq by fastforce
moreover have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 by simp
qed
qed
then show "set |h' \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_child_nodes y|\<^sub>r = {}"
using children_x' children_y'
by (metis (no_types, lifting) select_result_I2)
qed
next
assume 2: "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
then have 4: "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by simp
have 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
using h0
by(simp add: a_distinct_lists_def document_ptr_kinds_eq3)
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 4[unfolded document_ptr_kinds_eq3]])
fix x
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 5: "distinct |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_lists_disconnected_nodes[OF h0] 4 get_disconnected_nodes_ok
by (simp add: type_wf document_ptr_kinds_eq3 select_result_I)
show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "x = owner_document")
case True
have "child \<notin> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using child_not_in document_ptr_kinds_eq2 "4" by fastforce
moreover have "|h' \<turnstile> get_disconnected_nodes x|\<^sub>r = child # |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using disconnected_nodes_h' disconnected_nodes_h unfolding True
by(simp)
ultimately show ?thesis
using 5 unfolding True
by simp
next
case False
show ?thesis
using "5" False disconnected_nodes_eq2 by auto
qed
next
fix x y
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and 5: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))" and "x \<noteq> y"
obtain disc_nodes_x where disc_nodes_x: "h \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y where disc_nodes_y: "h \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of y] document_ptr_kinds_eq2
by auto
obtain disc_nodes_x' where disc_nodes_x': "h' \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x'"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y' where disc_nodes_y': "h' \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y'"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of y] document_ptr_kinds_eq2
by auto
have "distinct
(concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using h0 by (simp add: a_distinct_lists_def)
then have 6: "set disc_nodes_x \<inter> set disc_nodes_y = {}"
using \<open>x \<noteq> y\<close> assms(1) disc_nodes_x disc_nodes_y local.heap_is_wellformed_one_disc_parent
by blast
have "set disc_nodes_x' \<inter> set disc_nodes_y' = {}"
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using \<open>x \<noteq> y\<close> by simp
then have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y'
by auto
have "disc_nodes_x' = child # disc_nodes_x"
using disconnected_nodes_h' disc_nodes_x disc_nodes_x' True disconnected_nodes_h returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_y"
using child_not_in disc_nodes_y 5
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_x' = child # disc_nodes_x\<close> \<open>disc_nodes_y' = disc_nodes_y\<close>)
using 6 by auto
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x' by auto
have "disc_nodes_y' = child # disc_nodes_y"
using disconnected_nodes_h' disc_nodes_y disc_nodes_y' True disconnected_nodes_h returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_x"
using child_not_in disc_nodes_x 4
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_y' = child # disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
next
case False
have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x' by auto
have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y' by auto
then show ?thesis
apply(unfold \<open>disc_nodes_y' = disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
qed
qed
then show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using disc_nodes_x' disc_nodes_y' by auto
qed
next
fix x xa xb
assume 1: "xa \<in> fset (object_ptr_kinds h')"
and 2: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 3: "xb \<in> fset (document_ptr_kinds h')"
and 4: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
obtain disc_nodes where disc_nodes: "h \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain disc_nodes' where disc_nodes': "h' \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes'"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain children where children: "h \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children"
by (metis "1" type_wf assms(3) finite_set_in get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children' where children': "h' \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
have "\<And>x. x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r \<Longrightarrow> x \<in> set |h \<turnstile> get_disconnected_nodes xb|\<^sub>r \<Longrightarrow> False"
using 1 3
apply(fold \<open> object_ptr_kinds h = object_ptr_kinds h'\<close>)
apply(fold \<open> document_ptr_kinds h = document_ptr_kinds h'\<close>)
using children disc_nodes h0 apply(auto simp add: a_distinct_lists_def)[1]
by (metis (no_types, lifting) h0 local.distinct_lists_no_parent select_result_I2)
then have 5: "\<And>x. x \<in> set children \<Longrightarrow> x \<in> set disc_nodes \<Longrightarrow> False"
using children disc_nodes by fastforce
have 6: "|h' \<turnstile> get_child_nodes xa|\<^sub>r = children'"
using children' by simp
have 7: "|h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = disc_nodes'"
using disc_nodes' by simp
have "False"
proof (cases "xa = ptr")
case True
have "distinct children_h"
using children_h distinct_lists_children h0 \<open>known_ptr ptr\<close> by blast
have "|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h"
using children_h'
by simp
have "children = children_h"
using True children children_h by auto
show ?thesis
using disc_nodes' children' 5 2 4 children_h \<open>distinct children_h\<close> disconnected_nodes_h'
apply(auto simp add: 6 7
\<open>xa = ptr\<close> \<open>|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h\<close> \<open>children = children_h\<close>)[1]
by (metis (no_types, lifting) disc_nodes disconnected_nodes_eq2 disconnected_nodes_h
select_result_I2 set_ConsD)
next
case False
have "children' = children"
using children' children children_eq[OF False[symmetric]]
by auto
then show ?thesis
proof (cases "xb = owner_document")
case True
then show ?thesis
using disc_nodes disconnected_nodes_h disconnected_nodes_h'
using "2" "4" "5" "6" "7" False \<open>children' = children\<close> assms(1) child_in_children_h
child_parent_dual children children_h disc_nodes' get_child_nodes_ptr_in_heap
list.set_cases list.simps(3) option.simps(1) returns_result_eq set_ConsD
by (metis (no_types, opaque_lifting) assms(3) type_wf)
next
case False
then show ?thesis
using "2" "4" "5" "6" "7" \<open>children' = children\<close> disc_nodes disc_nodes'
disconnected_nodes_eq returns_result_eq
by metis
qed
qed
then show "x \<in> {}"
by simp
qed
}
ultimately show "heap_is_wellformed h'"
using heap_is_wellformed_def by blast
qed
lemma remove_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h"
and "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
and "known_ptrs h"
and type_wf: "type_wf h"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
using assms
by(auto simp add: remove_def intro: remove_child_heap_is_wellformed_preserved
elim!: bind_returns_heap_E2 split: option.splits)
lemma remove_child_removes_child:
assumes wellformed: "heap_is_wellformed h"
and remove_child: "h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h'"
and children: "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "child \<notin> set children"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr' (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure]
split: if_splits)[1]
using pure_returns_heap_eq
by fastforce
have "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes remove_child])
unfolding remove_child_locs_def
using set_child_nodes_pointers_preserved set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
moreover have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes assms(2)]
using set_child_nodes_types_preserved set_disconnected_nodes_types_preserved type_wf
unfolding remove_child_locs_def
apply(auto simp add: reflp_def transp_def)[1]
by blast
ultimately show ?thesis
using remove_child_removes_parent remove_child_heap_is_wellformed_preserved child_parent_dual
by (meson children known_ptrs local.known_ptrs_preserved option.distinct(1) remove_child
returns_result_eq type_wf wellformed)
qed
lemma remove_child_removes_first_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
assumes "h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
obtain h2 disc_nodes owner_document where
"h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document" and
"h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (node_ptr # disc_nodes) \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'"
using assms(5)
apply(auto simp add: remove_child_def
dest!: bind_returns_heap_E3[rotated, OF assms(4) get_child_nodes_pure, rotated])[1]
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated,OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])
have "known_ptr ptr"
by (meson assms(3) assms(4) is_OK_returns_result_I get_child_nodes_ptr_in_heap known_ptrs_known_ptr)
moreover have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes h2 assms(4)])
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
moreover have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h2]
using \<open>type_wf h\<close> set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
ultimately show ?thesis
using set_child_nodes_get_child_nodes\<open>h2 \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'\<close>
by fast
qed
lemma remove_removes_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children"
assumes "h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some ptr"
using child_parent_dual assms by fastforce
show ?thesis
using assms remove_child_removes_first_child
by(auto simp add: remove_def
dest!: bind_returns_heap_E3[rotated, OF \<open>h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some ptr\<close>, rotated]
bind_returns_heap_E3[rotated, OF assms(4) get_child_nodes_pure, rotated])
qed
lemma remove_for_all_empty_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using assms
proof(induct children arbitrary: h h')
case Nil
then show ?case
by simp
next
case (Cons a children)
have "h \<turnstile> get_parent a \<rightarrow>\<^sub>r Some ptr"
using child_parent_dual Cons by fastforce
with Cons show ?case
proof(auto elim!: bind_returns_heap_E)[1]
fix h2
assume 0: "(\<And>h h'. heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r [])"
and 1: "heap_is_wellformed h"
and 2: "type_wf h"
and 3: "known_ptrs h"
and 4: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r a # children"
and 5: "h \<turnstile> get_parent a \<rightarrow>\<^sub>r Some ptr"
and 7: "h \<turnstile> remove a \<rightarrow>\<^sub>h h2"
and 8: "h2 \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h'"
then have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using remove_removes_child by blast
moreover have "heap_is_wellformed h2"
using 7 1 2 3 remove_child_heap_is_wellformed_preserved(3)
by(auto simp add: remove_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
split: option.splits)
moreover have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_writes 7]
using \<open>type_wf h\<close> remove_child_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
moreover have "object_ptr_kinds h = object_ptr_kinds h2"
using 7
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have "known_ptrs h2"
using 3 known_ptrs_preserved by blast
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using 0 8 by fast
qed
qed
end
locale l_remove_child_wf2 = l_type_wf + l_known_ptrs + l_remove_child_defs + l_heap_is_wellformed_defs
+ l_get_child_nodes_defs + l_remove_defs +
assumes remove_child_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes remove_child_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes remove_child_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
assumes remove_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes remove_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes remove_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
assumes remove_child_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> child \<notin> set children"
assumes remove_child_removes_first_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children
\<Longrightarrow> h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes remove_removes_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children
\<Longrightarrow> h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes remove_for_all_empty_children:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
interpretation i_remove_child_wf2?: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs get_parent get_parent_locs get_owner_document
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel
by unfold_locales
declare l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma remove_child_wf2_is_l_remove_child_wf2 [instances]:
"l_remove_child_wf2 type_wf known_ptr known_ptrs remove_child heap_is_wellformed get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using remove_child_heap_is_wellformed_preserved apply(fast, fast, fast)
using remove_heap_is_wellformed_preserved apply(fast, fast, fast)
using remove_child_removes_child apply fast
using remove_child_removes_first_child apply fast
using remove_removes_child apply fast
using remove_for_all_empty_children apply fast
done
subsection \<open>adopt\_node\<close>
locale l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_heap_is_wellformed
begin
lemma adopt_node_removes_first_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children"
shows "h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> do { remove_child parent node }
| None \<Rightarrow> do { return ()}) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node # disc_nodes)
} else do { return () }) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have "h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h2 remove_child_removes_first_child assms(1) assms(2) assms(3) assms(5)
by (metis list.set_intros(1) local.child_parent_dual option.simps(5) parent_opt returns_result_eq)
then
show ?thesis
using h'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
dest!: reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes]
split: if_splits)
qed
lemma adopt_node_document_in_heap:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> ok (adopt_node owner_document node)"
shows "owner_document |\<in>| document_ptr_kinds h"
proof -
obtain old_document parent_opt h2 h' where
old_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> do { remove_child parent node } | None \<Rightarrow> do { return ()}) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node # disc_nodes)
} else do { return () }) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: adopt_node_def
elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
using old_document get_owner_document_owner_document_in_heap assms(1) assms(2) assms(3)
by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes where
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 node old_disc_nodes) \<rightarrow>\<^sub>h h3" and
old_disc_nodes: "h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h': "h3 \<turnstile> set_disconnected_nodes owner_document (node # disc_nodes) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "owner_document |\<in>| document_ptr_kinds h3"
by (meson is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap)
moreover have "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
moreover have "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
ultimately show ?thesis
by(auto simp add: document_ptr_kinds_def)
qed
qed
end
locale l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_removes_child_step:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2"
and children: "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<notin> set children"
proof -
obtain old_document parent_opt h' where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h': "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return () ) \<rightarrow>\<^sub>h h'"
using adopt_node get_parent_pure
by(auto simp add: adopt_node_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: if_splits)
then have "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using adopt_node
apply(auto simp add: adopt_node_def
dest!: bind_returns_heap_E3[rotated, OF old_document, rotated]
bind_returns_heap_E3[rotated, OF parent_opt, rotated]
elim!: bind_returns_heap_E4[rotated, OF h', rotated])[1]
apply(auto split: if_splits
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
apply (simp add: set_disconnected_nodes_get_child_nodes children
reads_writes_preserved[OF get_child_nodes_reads set_disconnected_nodes_writes])
using children by blast
show ?thesis
proof(insert parent_opt h', induct parent_opt)
case None
then show ?case
using child_parent_dual wellformed known_ptrs type_wf
\<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> returns_result_eq
by fastforce
next
case (Some option)
then show ?case
using remove_child_removes_child \<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> known_ptrs type_wf
wellformed
by auto
qed
qed
lemma adopt_node_removes_child:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
shows "\<And>ptr' children'.
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> node_ptr \<notin> set children'"
using adopt_node_removes_child_step assms by blast
lemma adopt_node_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document"
and
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have object_ptr_kinds_h_eq3: "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "type_wf h2"
using h2 remove_child_preserves_type_wf known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "known_ptrs h2"
using h2 remove_child_preserves_known_ptrs known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
proof(cases "document_ptr = old_document")
case True
then show ?thesis
using h' wellformed_h2 \<open>type_wf h2\<close> \<open>known_ptrs h2\<close> by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes_document_ptr_h3 where
docs_neq: "document_ptr \<noteq> old_document" and
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3" and
disc_nodes_document_ptr_h3:
"h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes_document_ptr_h3) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2:
"\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h3_eq3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h3: "node_ptr_kinds h3 = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
have children_eq_h3:
"\<And>ptr children. h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. old_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
obtain disc_nodes_old_document_h2 where disc_nodes_old_document_h2:
"h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
using old_disc_nodes by blast
then have disc_nodes_old_document_h3:
"h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
using h3 old_disc_nodes returns_result_eq set_disconnected_nodes_get_disconnected_nodes
by fastforce
have "distinct disc_nodes_old_document_h2"
using disc_nodes_old_document_h2 local.heap_is_wellformed_disconnected_nodes_distinct wellformed_h2
by blast
have "type_wf h2"
proof (insert h2, induct parent_opt)
case None
then show ?case
using type_wf by simp
next
case (Some option)
then show ?case
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes]
type_wf remove_child_types_preserved
by (simp add: reflp_def transp_def)
qed
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have "known_ptrs h3"
using known_ptrs local.known_ptrs_preserved object_ptr_kinds_h2_eq3 object_ptr_kinds_h_eq3 by blast
then have "known_ptrs h'"
using local.known_ptrs_preserved object_ptr_kinds_h3_eq3 by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2:
"h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
using disconnected_nodes_eq_h2 docs_neq disc_nodes_document_ptr_h3 by auto
have disc_nodes_document_ptr_h': "
h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
using h' disc_nodes_document_ptr_h3
using set_disconnected_nodes_get_disconnected_nodes by blast
have document_ptr_in_heap: "document_ptr |\<in>| document_ptr_kinds h2"
using disc_nodes_document_ptr_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using disc_nodes_document_ptr_h2 get_disconnected_nodes_ptr_in_heap by blast
have old_document_in_heap: "old_document |\<in>| document_ptr_kinds h2"
using disc_nodes_old_document_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using get_disconnected_nodes_ptr_in_heap old_disc_nodes by blast
have "child \<in> set disc_nodes_old_document_h2"
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h2"
by(auto)
moreover have "a_owner_document_valid h"
using assms(1) heap_is_wellformed_def by(simp add: heap_is_wellformed_def)
ultimately show ?case
using old_document disc_nodes_old_document_h2 None(1) child_parent_dual[OF assms(1)]
in_disconnected_nodes_no_parent assms(1) known_ptrs type_wf by blast
next
case (Some option)
then show ?case
apply(simp split: option.splits)
using assms(1) disc_nodes_old_document_h2 old_document remove_child_in_disconnected_nodes known_ptrs
by blast
qed
have "child \<notin> set (remove1 child disc_nodes_old_document_h2)"
using disc_nodes_old_document_h3 h3 known_ptrs wellformed_h2 \<open>distinct disc_nodes_old_document_h2\<close>
by auto
have "child \<notin> set disc_nodes_document_ptr_h3"
proof -
have "a_distinct_lists h2"
using heap_is_wellformed_def wellformed_h2 by blast
then have 0: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r))"
by(simp add: a_distinct_lists_def)
show ?thesis
using distinct_concat_map_E(1)[OF 0] \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h2 disc_nodes_document_ptr_h2
by (meson \<open>type_wf h2\<close> docs_neq known_ptrs local.get_owner_document_disconnected_nodes
local.known_ptrs_preserved object_ptr_kinds_h_eq3 returns_result_eq wellformed_h2)
qed
have child_in_heap: "child |\<in>| node_ptr_kinds h"
using get_owner_document_ptr_in_heap[OF is_OK_returns_result_I[OF old_document]]
node_ptr_kinds_commutes by blast
have "a_acyclic_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h2"
using object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 children_eq2_h2 children_eq2_h3
mem_Collect_eq object_ptr_kinds_M_eq_h3 select_result_eq split_cong
unfolding parent_child_rel_def
by(simp)
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h2\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h2 children_eq_h2)[1]
apply (simp add: children_eq2_h2 object_ptr_kinds_h2_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> \<open>type_wf h2\<close>
disc_nodes_old_document_h2 disc_nodes_old_document_h3 disconnected_nodes_eq2_h2
document_ptr_kinds_eq3_h2 in_set_remove1 local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2 returns_result_select_result
select_result_I2 wellformed_h2)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h3 children_eq_h3)[1]
apply (simp add: children_eq2_h3 object_ptr_kinds_h3_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq3_h3
finite_set_in local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
select_result_I2 set_ConsD subset_code(1) wellformed_h2)
moreover have "a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(simp add: a_owner_document_valid_def node_ptr_kinds_eq_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 children_eq2_h2 children_eq2_h3 )
by (smt disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2
disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_in_heap
document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 in_set_remove1
list.set_intros(1) node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 select_result_I2
set_subset_Cons subset_code(1))
have a_distinct_lists_h2: "a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h3 object_ptr_kinds_eq_h2
children_eq2_h2 children_eq2_h3)[1]
proof -
assume 1: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 3: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I)
show "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by(auto simp add: document_ptr_kinds_M_def )
next
fix x
assume a1: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 4: "distinct |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a_distinct_lists_h2 "2" a1 concat_map_all_distinct document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3
by fastforce
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "old_document \<noteq> x")
case True
then show ?thesis
proof (cases "document_ptr \<noteq> x")
case True
then show ?thesis
using disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>]
disconnected_nodes_eq2_h3[OF \<open>document_ptr \<noteq> x\<close>] 4
by(auto)
next
case False
then show ?thesis
using disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' 4
\<open>child \<notin> set disc_nodes_document_ptr_h3\<close>
by(auto simp add: disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>] )
qed
next
case False
then show ?thesis
by (metis (no_types, opaque_lifting) \<open>distinct disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h3 disconnected_nodes_eq2_h3
distinct_remove1 docs_neq select_result_I2)
qed
next
fix x y
assume a0: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a1: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a2: "x \<noteq> y"
moreover have 5: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using 2 calculation
by (auto simp add: document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 dest: distinct_concat_map_E(1))
ultimately show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
proof(cases "old_document = x")
case True
have "old_document \<noteq> y"
using \<open>x \<noteq> y\<close> \<open>old_document = x\<close> by simp
have "document_ptr \<noteq> x"
using docs_neq \<open>old_document = x\<close> by auto
show ?thesis
proof(cases "document_ptr = y")
case True
then show ?thesis
using 5 True select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document = x\<close>
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
\<open>document_ptr \<noteq> x\<close> disconnected_nodes_eq2_h3 disjoint_iff_not_equal
notin_set_remove1 set_ConsD)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 \<open>old_document = x\<close>
docs_neq \<open>old_document \<noteq> y\<close>
by (metis (no_types, lifting) disjoint_iff_not_equal notin_set_remove1)
qed
next
case False
then show ?thesis
proof(cases "old_document = y")
case True
then show ?thesis
proof(cases "document_ptr = x")
case True
show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr = x\<close>
apply(simp)
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr \<noteq> x\<close>
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal docs_neq notin_set_remove1)
qed
next
case False
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
by (metis DocumentMonad.ptr_kinds_M_ok DocumentMonad.ptr_kinds_M_ptr_kinds False
\<open>type_wf h2\<close> a1 disc_nodes_old_document_h2 document_ptr_kinds_M_def
document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
wellformed_h2)
then show ?thesis
proof(cases "document_ptr = x")
case True
then have "document_ptr \<noteq> y"
using \<open>x \<noteq> y\<close> by auto
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
using \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by blast
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document \<noteq> y\<close> \<open>document_ptr = x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
\<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by(auto)
next
case False
then show ?thesis
proof(cases "document_ptr = y")
case True
have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set disc_nodes_document_ptr_h3 = {}"
using 2 a1 document_ptr_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>document_ptr \<noteq> x\<close> select_result_I2[OF disc_nodes_document_ptr_h3, symmetric]
disconnected_nodes_eq2_h2[OF docs_neq[symmetric], symmetric]
by (simp add: "5" True)
moreover have f1:
"set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = {}"
using 2 a1 old_document_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>old_document \<noteq> x\<close>
by (metis (no_types, lifting) a0 distinct_concat_map_E(1) document_ptr_kinds_eq3_h2
- document_ptr_kinds_eq3_h3 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ document_ptr_kinds_eq3_h3 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
ultimately show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr = y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by auto
next
case False
then show ?thesis
using 5
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close>
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
by (metis \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
empty_iff inf.idem)
qed
qed
qed
qed
qed
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show False
using \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 old_document_in_heap
apply(auto)[1]
apply(cases "xb = old_document")
proof -
assume a1: "xb = old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a3: "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
assume a4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a5: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f6: "old_document |\<in>| document_ptr_kinds h'"
using a1 \<open>xb |\<in>| document_ptr_kinds h'\<close> by blast
have f7: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a2 by simp
have "x \<in> set disc_nodes_old_document_h2"
using f6 a3 a1 by (metis (no_types) \<open>type_wf h'\<close> \<open>x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close>
disconnected_nodes_eq_h3 docs_neq get_disconnected_nodes_ok returns_result_eq
returns_result_select_result set_remove1_subset subsetCE)
then have "set |h' \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using f7 f6 a5 a4 \<open>xa |\<in>| object_ptr_kinds h'\<close>
by fastforce
then show ?thesis
using \<open>x \<in> set disc_nodes_old_document_h2\<close> a1 a4 f7 by blast
next
assume a1: "xb \<noteq> old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
assume a3: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a4: "xa |\<in>| object_ptr_kinds h'"
assume a5: "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
assume a6: "old_document |\<in>| document_ptr_kinds h'"
assume a7: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume a8: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume a9: "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a10: "\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a11: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a12: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f13: "\<And>d. d \<notin> set |h' \<turnstile> document_ptr_kinds_M|\<^sub>r \<or> h2 \<turnstile> ok get_disconnected_nodes d"
using a9 \<open>type_wf h2\<close> get_disconnected_nodes_ok
by simp
then have f14: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a6 a3 by simp
have "x \<notin> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
using a12 a8 a4 \<open>xb |\<in>| document_ptr_kinds h'\<close>
- by (meson UN_I disjoint_iff_not_equal fmember.rep_eq)
+ by (meson UN_I disjoint_iff_not_equal fmember_iff_member_fset)
then have "x = child"
using f13 a11 a10 a7 a5 a2 a1
by (metis (no_types, lifting) select_result_I2 set_ConsD)
then have "child \<notin> set disc_nodes_old_document_h2"
using f14 a12 a8 a6 a4
by (metis \<open>type_wf h'\<close> adopt_node_removes_child assms(1) assms(2) type_wf
get_child_nodes_ok known_ptrs local.known_ptrs_known_ptr object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3 returns_result_select_result)
then show ?thesis
using \<open>child \<in> set disc_nodes_old_document_h2\<close> by fastforce
qed
qed
ultimately show ?thesis
using \<open>type_wf h'\<close> \<open>known_ptrs h'\<close> \<open>a_owner_document_valid h'\<close> heap_is_wellformed_def by blast
qed
then show "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
by auto
qed
lemma adopt_node_node_in_disconnected_nodes:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
and "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node_ptr old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node_ptr # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h'"
using h2 h' by(auto)
then show ?case
using in_disconnected_nodes_no_parent assms None old_document by blast
next
case (Some parent)
then show ?case
using remove_child_in_disconnected_nodes known_ptrs True h' assms(3) old_document by auto
qed
next
case False
then show ?thesis
using assms(3) h' list.set_intros(1) select_result_I2 set_disconnected_nodes_get_disconnected_nodes
apply(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
proof -
fix x and h'a and xb
assume a1: "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assume a2: "\<And>h document_ptr disc_nodes h'. h \<turnstile> set_disconnected_nodes document_ptr disc_nodes \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume "h'a \<turnstile> set_disconnected_nodes owner_document (node_ptr # xb) \<rightarrow>\<^sub>h h'"
then have "node_ptr # xb = disc_nodes"
using a2 a1 by (meson returns_result_eq)
then show ?thesis
by (meson list.set_intros(1))
qed
qed
qed
end
interpretation i_adopt_node_wf?: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs known_ptr
type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs
remove heap_is_wellformed parent_child_rel
by(simp add: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
interpretation i_adopt_node_wf2?: l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs known_ptr
type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs
remove heap_is_wellformed parent_child_rel get_root_node get_root_node_locs
by(simp add: l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_adopt_node_wf = l_heap_is_wellformed + l_known_ptrs + l_type_wf + l_adopt_node_defs
+ l_get_child_nodes_defs + l_get_disconnected_nodes_defs +
assumes adopt_node_preserves_wellformedness:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h' \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> heap_is_wellformed h'"
assumes adopt_node_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2
\<Longrightarrow> h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> known_ptrs h
\<Longrightarrow> type_wf h \<Longrightarrow> node_ptr \<notin> set children"
assumes adopt_node_node_in_disconnected_nodes:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> node_ptr \<in> set disc_nodes"
assumes adopt_node_removes_first_child: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
assumes adopt_node_document_in_heap: "heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (adopt_node owner_document node)
\<Longrightarrow> owner_document |\<in>| document_ptr_kinds h"
lemma adopt_node_wf_is_l_adopt_node_wf [instances]:
"l_adopt_node_wf type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes known_ptrs adopt_node"
using heap_is_wellformed_is_l_heap_is_wellformed known_ptrs_is_l_known_ptrs
apply(auto simp add: l_adopt_node_wf_def l_adopt_node_wf_axioms_def)[1]
using adopt_node_preserves_wellformedness apply blast
using adopt_node_removes_child apply blast
using adopt_node_node_in_disconnected_nodes apply blast
using adopt_node_removes_first_child apply blast
using adopt_node_document_in_heap apply blast
done
subsection \<open>insert\_before\<close>
locale l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_wf +
l_set_disconnected_nodes_get_child_nodes +
l_heap_is_wellformed
begin
lemma insert_before_removes_child:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "ptr \<noteq> ptr'"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children"
shows "h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
proof -
obtain owner_document h2 h3 disc_nodes reference_child where
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
"h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disc_nodes) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: if_splits option.splits)
have "h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h2 adopt_node_removes_first_child assms(1) assms(2) assms(3) assms(6)
by simp
then have "h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using h3
by(auto simp add: set_disconnected_nodes_get_child_nodes
dest!: reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes])
then show ?thesis
using h' assms(4)
apply(auto simp add: a_insert_node_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated])[1]
by(auto simp add: set_child_nodes_get_child_nodes_different_pointers
elim!: reads_writes_separate_forwards[OF get_child_nodes_reads set_child_nodes_writes])
qed
end
locale l_insert_before_wf = l_heap_is_wellformed_defs + l_type_wf + l_known_ptrs
+ l_insert_before_defs + l_get_child_nodes_defs +
assumes insert_before_removes_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> ptr \<noteq> ptr'
\<Longrightarrow> h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
interpretation i_insert_before_wf?: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs
get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_ancestors get_ancestors_locs
adopt_node adopt_node_locs set_disconnected_nodes
set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before
insert_before_locs append_child type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel
by(simp add: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf_is_l_insert_before_wf [instances]:
"l_insert_before_wf heap_is_wellformed type_wf known_ptr known_ptrs insert_before get_child_nodes"
apply(auto simp add: l_insert_before_wf_def l_insert_before_wf_axioms_def instances)[1]
using insert_before_removes_child apply fast
done
locale l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_disconnected_nodes +
l_remove_child +
l_get_root_node_wf +
l_set_disconnected_nodes_get_disconnected_nodes_wf +
l_set_disconnected_nodes_get_ancestors +
l_get_ancestors_wf +
l_get_owner_document +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma insert_before_heap_is_wellformed_preserved:
assumes wellformed: "heap_is_wellformed h"
and insert_before: "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I known_ptrs
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using type_wf adopt_node_types_preserved
by(auto simp add: a_remove_child_locs_def reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have "known_ptrs h2"
using known_ptrs object_ptr_kinds_M_eq3_h known_ptrs_preserved by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF wellformed h2] known_ptrs type_wf .
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have "known_ptrs h3"
using object_ptr_kinds_M_eq3_h2 known_ptrs_preserved \<open>known_ptrs h2\<close> by blast
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3:
"|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
show "known_ptrs h'"
using object_ptr_kinds_M_eq3_h' known_ptrs_preserved \<open>known_ptrs h3\<close> by blast
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> owner_document
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3:
"h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr'
\<Longrightarrow> h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3:
"\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children:
"\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using wellformed h2 adopt_node_removes_child \<open>type_wf h\<close> \<open>known_ptrs h\<close> by auto
have "node \<in> set disconnected_nodes_h2"
using disconnected_nodes_h2 h2 adopt_node_node_in_disconnected_nodes assms(1)
\<open>type_wf h\<close> \<open>known_ptrs h\<close> by blast
have node_not_in_disconnected_nodes:
"\<And>d. d |\<in>| document_ptr_kinds h3 \<Longrightarrow> node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof -
fix d
assume "d |\<in>| document_ptr_kinds h3"
show "node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof (cases "d = owner_document")
case True
then show ?thesis
using disconnected_nodes_h2 wellformed_h2 h3 remove_from_disconnected_nodes_removes
wellformed_h2 \<open>d |\<in>| document_ptr_kinds h3\<close> disconnected_nodes_h3
by fastforce
next
case False
then have
"set |h2 \<turnstile> get_disconnected_nodes d|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes owner_document|\<^sub>r = {}"
using distinct_concat_map_E(1) wellformed_h2
by (metis (no_types, lifting) \<open>d |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h2\<close>
disconnected_nodes_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
select_result_I2)
then show ?thesis
using disconnected_nodes_eq2_h2[OF False] \<open>node \<in> set disconnected_nodes_h2\<close>
disconnected_nodes_h2 by fastforce
qed
qed
have "cast node \<noteq> ptr"
using ancestors node_not_in_ancestors get_ancestors_ptr
by fast
obtain ancestors_h2 where ancestors_h2: "h2 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_ok object_ptr_kinds_M_eq2_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close>
by (metis is_OK_returns_result_E object_ptr_kinds_M_eq3_h2 ptr_in_heap wellformed_h2)
have ancestors_h3: "h3 \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_separate_forwards)
using \<open>heap_is_wellformed h2\<close> ancestors_h2
by (auto simp add: set_disconnected_nodes_get_ancestors)
have node_not_in_ancestors_h2: "cast node \<notin> set ancestors_h2"
apply(rule get_ancestors_remains_not_in_ancestors[OF assms(1) wellformed_h2 ancestors ancestors_h2])
using adopt_node_children_subset using h2 \<open>known_ptrs h\<close> \<open> type_wf h\<close> apply(blast)
using node_not_in_ancestors apply(blast)
using object_ptr_kinds_M_eq3_h apply(blast)
using \<open>known_ptrs h\<close> apply(blast)
using \<open>type_wf h\<close> apply(blast)
using \<open>type_wf h2\<close> by blast
moreover have "a_acyclic_heap h'"
proof -
have "acyclic (parent_child_rel h2)"
using wellformed_h2 by (simp add: heap_is_wellformed_def acyclic_heap_def)
then have "acyclic (parent_child_rel h3)"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h2)\<^sup>*}"
using get_ancestors_parent_child_rel node_not_in_ancestors_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close>
using ancestors_h2 wellformed_h2 by blast
then have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3)\<^sup>*}"
by(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))"
using children_h3 children_h' ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_M_eq3_h' children_eq2_h3
insert_before_list_node_in_set)[1]
apply (metis (no_types, lifting) children_eq2_h3 insert_before_list_in_set select_result_I2)
by (metis (no_types, lifting) children_eq2_h3 imageI insert_before_list_in_set select_result_I2)
ultimately show ?thesis
by(auto simp add: acyclic_heap_def)
qed
moreover have "a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
have "a_all_ptrs_in_heap h'"
proof -
have "a_all_ptrs_in_heap h3"
using \<open>a_all_ptrs_in_heap h2\<close>
apply(auto simp add: a_all_ptrs_in_heap_def object_ptr_kinds_M_eq2_h2 node_ptr_kinds_eq2_h2
children_eq_h2)[1]
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
using node_ptr_kinds_eq2_h2 apply auto[1]
apply (metis \<open>known_ptrs h2\<close> \<open>type_wf h3\<close> children_eq_h2 local.get_child_nodes_ok
local.heap_is_wellformed_children_in_heap local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h2
returns_result_select_result wellformed_h2)
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 document_ptr_kinds_commutes finite_set_in node_ptr_kinds_commutes
object_ptr_kinds_M_eq3_h2 select_result_I2 set_remove1_subset subsetD)
have "set children_h3 \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using children_h3 \<open>a_all_ptrs_in_heap h3\<close>
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq2_h3)[1]
by (metis children_eq_h2 l_heap_is_wellformed.heap_is_wellformed_children_in_heap
local.l_heap_is_wellformed_axioms node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2 wellformed_h2)
then have "set (insert_before_list node reference_child children_h3) \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_in_heap
apply(auto simp add: node_ptr_kinds_eq2_h node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3)[1]
by (metis (no_types, opaque_lifting) contra_subsetD finite_set_in insert_before_list_in_set
node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2)
then show ?thesis
using \<open>a_all_ptrs_in_heap h3\<close>
apply(auto simp add: object_ptr_kinds_M_eq3_h' a_all_ptrs_in_heap_def node_ptr_kinds_def
node_ptr_kinds_eq2_h3 disconnected_nodes_eq_h3)[1]
using children_eq_h3 children_h'
apply (metis (no_types, lifting) children_eq2_h3 finite_set_in select_result_I2 subsetD)
by (metis (no_types) \<open>type_wf h'\<close> disconnected_nodes_eq2_h3 disconnected_nodes_eq_h3
finite_set_in is_OK_returns_result_I local.get_disconnected_nodes_ok
local.get_disconnected_nodes_ptr_in_heap returns_result_select_result subsetD)
qed
moreover have "a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h3"
proof(auto simp add: a_distinct_lists_def object_ptr_kinds_M_eq2_h2 document_ptr_kinds_eq2_h2
children_eq2_h2 intro!: distinct_concat_map_I)[1]
fix x
assume 1: "x |\<in>| document_ptr_kinds h3"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
show "distinct |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_concat_map_E(2)[OF 2] select_result_I2[OF disconnected_nodes_h3]
disconnected_nodes_eq2_h2 select_result_I2[OF disconnected_nodes_h2] 1
- by (metis (full_types) distinct_remove1 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ by (metis (full_types) distinct_remove1 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and 2: "x |\<in>| document_ptr_kinds h3"
and 3: "y |\<in>| document_ptr_kinds h3"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
and 6: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r"
show False
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using 4 by simp
show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>y \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>x \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using distinct_concat_map_E(1)[OF 1, simplified, OF 2 3 4] 5 6
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
- disjoint_iff_not_equal finite_fset fmember.rep_eq notin_set_remove1 select_result_I2
+ disjoint_iff_not_equal finite_fset fmember_iff_member_fset notin_set_remove1 select_result_I2
set_sorted_list_of_set
by (metis (no_types, lifting))
qed
qed
next
fix x xa xb
assume 1: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h3 \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 2: "xa |\<in>| object_ptr_kinds h3"
and 3: "x \<in> set |h3 \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h3"
and 5: "x \<in> set |h3 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 4
by (metis \<open>type_wf h2\<close> children_eq2_h2 document_ptr_kinds_commutes known_ptrs
local.get_child_nodes_ok local.get_disconnected_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h2 returns_result_select_result
wellformed_h2)
show False
proof (cases "xb = owner_document")
case True
then show ?thesis
using select_result_I2[OF disconnected_nodes_h3,folded select_result_I2[OF disconnected_nodes_h2]]
by (metis (no_types, lifting) "3" "5" "6" disjoint_iff_not_equal notin_set_remove1)
next
case False
show ?thesis
using 2 3 4 5 6 unfolding disconnected_nodes_eq2_h2[OF False] by auto
qed
qed
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def document_ptr_kinds_eq2_h3 object_ptr_kinds_M_eq2_h3
disconnected_nodes_eq2_h3 intro!: distinct_concat_map_I)[1]
fix x
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))" and
2: "x |\<in>| object_ptr_kinds h'"
have 3: "\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> distinct |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using 1 by (auto elim: distinct_concat_map_E)
show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
proof(cases "ptr = x")
case True
show ?thesis
using 3[OF 2] children_h3 children_h'
by(auto simp add: True insert_before_list_distinct
dest: child_not_in_any_children[unfolded children_eq_h2])
next
case False
show ?thesis
using children_eq2_h3[OF False] 3[OF 2] by auto
qed
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "x |\<in>| object_ptr_kinds h'"
and 3: "y |\<in>| object_ptr_kinds h'"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h' \<turnstile> get_child_nodes x|\<^sub>r"
and 6: "xa \<in> set |h' \<turnstile> get_child_nodes y|\<^sub>r"
have 7:"set |h3 \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_child_nodes y|\<^sub>r = {}"
using distinct_concat_map_E(1)[OF 1] 2 3 4 by auto
show False
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
using 4 by simp
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> y\<close>])[1]
by (metis (no_types, opaque_lifting) "3" "7" \<open>type_wf h3\<close> children_eq2_h3 disjoint_iff_not_equal
get_child_nodes_ok insert_before_list_in_set known_ptrs local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2 returns_result_select_result select_result_I2)
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> x\<close>])[1]
by (metis (no_types, opaque_lifting) "2" "4" "7" IntI \<open>known_ptrs h3\<close> \<open>type_wf h'\<close>
children_eq_h3 empty_iff insert_before_list_in_set local.get_child_nodes_ok
local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h'
returns_result_select_result select_result_I2)
next
case False
then show ?thesis
using children_eq2_h3[OF \<open>ptr \<noteq> x\<close>] children_eq2_h3[OF \<open>ptr \<noteq> y\<close>] 5 6 7 by auto
qed
qed
next
fix x xa xb
assume 1: " (\<Union>x\<in>fset (object_ptr_kinds h'). set |h3 \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r) = {} "
and 2: "xa |\<in>| object_ptr_kinds h'"
and 3: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h'"
and 5: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 3 4 5
proof -
have "\<forall>h d. \<not> type_wf h \<or> d |\<notin>| document_ptr_kinds h \<or> h \<turnstile> ok get_disconnected_nodes d"
using local.get_disconnected_nodes_ok by satx
then have "h' \<turnstile> ok get_disconnected_nodes xb"
using "4" \<open>type_wf h'\<close> by fastforce
then have f1: "h3 \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
by (simp add: disconnected_nodes_eq_h3)
have "xa |\<in>| object_ptr_kinds h3"
using "2" object_ptr_kinds_M_eq3_h' by blast
then show ?thesis
using f1 \<open>local.a_distinct_lists h3\<close> local.distinct_lists_no_parent by fastforce
qed
show False
proof (cases "ptr = xa")
case True
show ?thesis
using 6 node_not_in_disconnected_nodes 3 4 5 select_result_I2[OF children_h']
select_result_I2[OF children_h3] True disconnected_nodes_eq2_h3
by (metis (no_types, lifting) "2" DocumentMonad.ptr_kinds_ptr_kinds_M
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disconnected_nodes_eq_h3
distinct_lists_no_parent document_ptr_kinds_eq2_h3 get_disconnected_nodes_ok
insert_before_list_in_set object_ptr_kinds_M_eq3_h' returns_result_select_result)
next
case False
then show ?thesis
using 1 2 3 4 5 children_eq2_h3[OF False] by fastforce
qed
qed
moreover have "a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def object_ptr_kinds_M_eq2_h2
object_ptr_kinds_M_eq2_h3 node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3
document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3 children_eq2_h2)[1]
apply(auto simp add: document_ptr_kinds_eq2_h2[simplified] document_ptr_kinds_eq2_h3[simplified]
object_ptr_kinds_M_eq2_h2[simplified] object_ptr_kinds_M_eq2_h3[simplified]
node_ptr_kinds_eq2_h2[simplified] node_ptr_kinds_eq2_h3[simplified])[1]
apply(auto simp add: disconnected_nodes_eq2_h3[symmetric])[1]
by (smt children_eq2_h3 children_h' children_h3 disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 finite_set_in in_set_remove1 insert_before_list_in_set
object_ptr_kinds_M_eq3_h' ptr_in_heap select_result_I2)
ultimately show "heap_is_wellformed h'"
by (simp add: heap_is_wellformed_def)
qed
end
locale l_insert_before_wf2 = l_type_wf + l_known_ptrs + l_insert_before_defs
+ l_heap_is_wellformed_defs + l_get_child_nodes_defs + l_remove_defs +
assumes insert_before_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes insert_before_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes insert_before_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> insert_before ptr child ref \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
interpretation i_insert_before_wf2?: l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs
get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_ancestors get_ancestors_locs
adopt_node adopt_node_locs set_disconnected_nodes
set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before
insert_before_locs append_child type_wf known_ptr known_ptrs
heap_is_wellformed parent_child_rel remove_child
remove_child_locs get_root_node get_root_node_locs
by(simp add: l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf2_is_l_insert_before_wf2 [instances]:
"l_insert_before_wf2 type_wf known_ptr known_ptrs insert_before heap_is_wellformed"
apply(auto simp add: l_insert_before_wf2_def l_insert_before_wf2_axioms_def instances)[1]
using insert_before_heap_is_wellformed_preserved apply(fast, fast, fast)
done
locale l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before_wf +
l_insert_before_wf2 +
l_get_child_nodes
begin
lemma append_child_heap_is_wellformed_preserved:
assumes wellformed: "heap_is_wellformed h"
and append_child: "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
using assms
by(auto simp add: append_child_def intro: insert_before_preserves_type_wf
insert_before_preserves_known_ptrs insert_before_heap_is_wellformed_preserved)
lemma append_child_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
assumes "node \<notin> set xs"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [node]"
proof -
obtain ancestors owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node None \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: append_child_def insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr"
using assms(1) assms(4) assms(6)
by (metis (no_types, lifting) assms(2) assms(3) h2 is_OK_returns_heap_I is_OK_returns_result_E
local.adopt_node_child_in_heap local.get_parent_child_dual local.get_parent_ok
select_result_I2)
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads adopt_node_writes h2 assms(4)
apply(rule reads_writes_separate_forwards)
using \<open>\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>
apply(auto simp add: adopt_node_locs_def remove_child_locs_def)[1]
by (meson local.set_child_nodes_get_child_nodes_different_pointers)
have "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads set_disconnected_nodes_writes h3 \<open>h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
apply(rule reads_writes_separate_forwards)
by(auto)
have "ptr |\<in>| object_ptr_kinds h"
by (meson ancestors is_OK_returns_result_I local.get_ancestors_ptr_in_heap)
then
have "known_ptr ptr"
using assms(3)
using local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using adopt_node_types_preserved \<open>type_wf h\<close>
by(auto simp add: adopt_node_locs_def remove_child_locs_def reflp_def transp_def split: if_splits)
then
have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@[node]"
using h'
apply(auto simp add: a_insert_node_def
dest!: bind_returns_heap_E3[rotated, OF \<open>h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
get_child_nodes_pure, rotated])[1]
using \<open>type_wf h3\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close>
by metis
qed
lemma append_child_for_all_on_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "set nodes \<inter> set xs = {}"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@nodes"
using assms
apply(induct nodes arbitrary: h xs)
apply(simp)
proof(auto elim!: bind_returns_heap_E)[1]fix a nodes h xs h'a
assume 0: "(\<And>h xs. heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs \<Longrightarrow> h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'
\<Longrightarrow> set nodes \<inter> set xs = {} \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ nodes)"
and 1: "heap_is_wellformed h"
and 2: "type_wf h"
and 3: "known_ptrs h"
and 4: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
and 5: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>r ()"
and 6: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>h h'a"
and 7: "h'a \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
and 8: "a \<notin> set xs"
and 9: "set nodes \<inter> set xs = {}"
and 10: "a \<notin> set nodes"
and 11: "distinct nodes"
then have "h'a \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [a]"
using append_child_children 6
using "1" "2" "3" "4" "8" by blast
moreover have "heap_is_wellformed h'a" and "type_wf h'a" and "known_ptrs h'a"
using insert_before_heap_is_wellformed_preserved insert_before_preserves_known_ptrs
insert_before_preserves_type_wf 1 2 3 6 append_child_def
by metis+
moreover have "set nodes \<inter> set (xs @ [a]) = {}"
using 9 10
by auto
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ a # nodes"
using 0 7
by fastforce
qed
lemma append_child_for_all_on_no_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r nodes"
using assms append_child_for_all_on_children
by force
end
locale l_append_child_wf = l_type_wf + l_known_ptrs + l_append_child_defs + l_heap_is_wellformed_defs +
assumes append_child_preserves_type_wf:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> type_wf h'"
assumes append_child_preserves_known_ptrs:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> known_ptrs h'"
assumes append_child_heap_is_wellformed_preserved:
"type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> heap_is_wellformed h \<Longrightarrow> h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'
\<Longrightarrow> heap_is_wellformed h'"
interpretation i_append_child_wf?: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent
get_parent_locs remove_child remove_child_locs
get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs
adopt_node adopt_node_locs known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs set_child_nodes
set_child_nodes_locs remove get_ancestors get_ancestors_locs
insert_before insert_before_locs append_child heap_is_wellformed
parent_child_rel
by(auto simp add: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma append_child_wf_is_l_append_child_wf [instances]: "l_append_child_wf type_wf known_ptr
known_ptrs append_child heap_is_wellformed"
apply(auto simp add: l_append_child_wf_def l_append_child_wf_axioms_def instances)[1]
using append_child_heap_is_wellformed_preserved by fast+
subsection \<open>create\_element\<close>
locale l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel +
l_new_element_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs
get_disconnected_nodes get_disconnected_nodes_locs +
l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf create_element known_ptr +
l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes set_disconnected_nodes_locs
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_disconnected_nodes_get_disconnected_nodes type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs +
l_new_element type_wf +
l_known_ptrs known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
begin
lemma create_element_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
apply (metis \<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1)
assms(3) funion_iff local.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child_in_heap local.parent_child_rel_child_nodes2 node_ptr_kinds_commutes
node_ptr_kinds_eq_h returns_result_select_result)
by (metis assms(1) assms(3) disconnected_nodes_eq2_h document_ptr_kinds_eq_h funion_iff
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h
returns_result_select_result)
then have "a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
local.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "a_all_ptrs_in_heap h'"
by (smt \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> children_eq2_h3
disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_eq_h3 finite_set_in h' is_OK_returns_result_I
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.get_child_nodes_ptr_in_heap
local.l_set_disconnected_nodes_get_disconnected_nodes_axioms node_ptr_kinds_commutes
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 select_result_I2 set_ConsD subset_code(1))
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_element_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_element_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_element_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_element_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_element_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff local.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open>local.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok returns_result_select_result)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3
intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set disc_nodes_h3\<close>
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
apply(-)
apply(cases "x = document_ptr")
apply (smt NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>local.a_all_ptrs_in_heap h\<close>
disc_nodes_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
by (smt NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> \<open>local.a_all_ptrs_in_heap h\<close>
disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply -
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3
\<Longrightarrow> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open>a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open>a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: a_owner_document_valid_def)[1]
apply(auto simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )[1]
apply(auto simp add: object_ptr_kinds_eq_h2)[1]
apply(auto simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )[1]
apply(auto simp add: document_ptr_kinds_eq_h2)[1]
apply(auto simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )[1]
apply(auto simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )[1]
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by(metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> children_eq2_h children_eq2_h2
children_eq2_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_eq_h finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
node_ptr_kinds_commutes select_result_I2)
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_element_wf?: l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
set_tag_name set_tag_name_locs
set_disconnected_nodes set_disconnected_nodes_locs create_element
using instances
by(auto simp add: l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>create\_character\_data\<close>
locale l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
+ l_new_character_data_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_val_get_disconnected_nodes
type_wf set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_val set_val_locs type_wf create_character_data known_ptr
+ l_new_character_data_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_set_val_get_child_nodes
type_wf set_val set_val_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes_get_child_nodes
set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes
type_wf set_disconnected_nodes set_disconnected_nodes_locs
+ l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_new_character_data
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_character_data_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_character_data_ptr)"
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
local.create_character_data_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M \<open>parent_child_rel h = parent_child_rel h2\<close>
children_eq2_h finite_set_in finsert_iff funion_finsert_right local.parent_child_rel_child
local.parent_child_rel_parent_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq_h
select_result_I2 subsetD sup_bot.right_neutral)
by (metis assms(1) assms(3) disconnected_nodes_eq2_h document_ptr_kinds_eq_h funionI1
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap
node_ptr_kinds_eq_h returns_result_select_result)
then have "a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
local.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "a_all_ptrs_in_heap h'"
by (smt character_data_ptr_kinds_commutes children_eq2_h3 disc_nodes_document_ptr_h2
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3
finite_set_in h' h2 local.a_all_ptrs_in_heap_def
local.set_disconnected_nodes_get_disconnected_nodes new_character_data_ptr
new_character_data_ptr_in_heap node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3
object_ptr_kinds_eq_h3 select_result_I2 set_ConsD subset_code(1))
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_character_data_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_character_data_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_character_data_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_character_data_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff local.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr
returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open>local.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok returns_result_select_result)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast new_character_data_ptr \<notin> set disc_nodes_h3\<close>
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
by (smt NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>local.a_all_ptrs_in_heap h\<close> disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 disjoint_iff_not_equal
document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open>a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open>a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(simp add: a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric] disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by (metis (mono_tags, lifting) \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
children_eq2_h disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h'
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms object_ptr_kinds_M_def
select_result_I2)
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_character_data_wf?: l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel set_val set_val_locs set_disconnected_nodes
set_disconnected_nodes_locs create_character_data known_ptrs
using instances
by (auto simp add: l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>create\_document\<close>
locale l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
+ l_new_document_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
create_document
+ l_new_document_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_new_document
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_document :: "((_) heap, exception, (_) document_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_document_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'"
proof -
obtain new_document_ptr where
new_document_ptr: "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr" and
h': "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
using assms(2)
apply(simp add: create_document_def)
using new_document_ok by blast
have "new_document_ptr \<notin> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have "new_document_ptr |\<notin>| document_ptr_kinds h"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr |\<notin>| object_ptr_kinds h"
by simp
have object_ptr_kinds_eq: "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using new_document_new_ptr h' new_document_ptr by blast
then have node_ptr_kinds_eq: "node_ptr_kinds h' = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h' = character_data_ptr_kinds h"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h' = element_ptr_kinds h"
using object_ptr_kinds_eq
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h' = document_ptr_kinds h |\<union>| {|new_document_ptr|}"
using object_ptr_kinds_eq
apply(auto simp add: document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_kinds_commutes document_ptr_kinds_def finsertI1 fset.map_comp)
have children_eq:
"\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h' get_child_nodes_new_document[rotated, OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2: "\<And>ptr'. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
using new_document_ptr h' new_document_ptr_in_heap[OF h' new_document_ptr]
new_document_is_document_ptr[OF new_document_ptr] new_document_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h' get_disconnected_nodes_new_document_different_pointers new_document_ptr
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis(full_types) \<open>\<And>thesis. (\<And>new_document_ptr.
\<lbrakk>h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr; h \<turnstile> new_document \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
local.get_disconnected_nodes_new_document_different_pointers new_document_ptr)+
then have disconnected_nodes_eq2_h: "\<And>doc_ptr. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
using h' local.new_document_no_disconnected_nodes new_document_ptr by blast
have "type_wf h'"
using \<open>type_wf h\<close> new_document_types_preserved h' by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h'"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h'"
by (simp add: object_ptr_kinds_eq)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 empty_iff empty_set image_eqI select_result_I2)
qed
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
using ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> assms(1) children_eq fset_of_list_elem
local.heap_is_wellformed_children_in_heap local.parent_child_rel_child
local.parent_child_rel_parent_in_heap node_ptr_kinds_eq
apply (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 finite_set_in finsert_iff funion_finsert_right object_ptr_kinds_eq
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
\<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> \<open>type_wf h'\<close> assms(1) disconnected_nodes_eq_h
local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap local.parent_child_rel_child
local.parent_child_rel_parent_in_heap
node_ptr_kinds_eq returns_result_select_result select_result_I2)
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
using \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: children_eq2[symmetric] a_distinct_lists_def insort_split object_ptr_kinds_eq
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(auto simp add: dest: distinct_concat_map_E)[1]
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close>
apply(auto simp add: distinct_insort dest: distinct_concat_map_E)[1]
using disconnected_nodes_eq_h
apply (metis assms(1) assms(3) disconnected_nodes_eq2_h local.get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct
returns_result_select_result)
proof -
fix x :: "(_) document_ptr" and y :: "(_) document_ptr" and xa :: "(_) node_ptr"
assume a1: "x \<noteq> y"
assume a2: "x |\<in>| document_ptr_kinds h"
assume a3: "x \<noteq> new_document_ptr"
assume a4: "y |\<in>| document_ptr_kinds h"
assume a5: "y \<noteq> new_document_ptr"
assume a6: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
assume a7: "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a8: "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
have f9: "xa \<in> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a7 a3 disconnected_nodes_eq2_h by presburger
have f10: "xa \<in> set |h \<turnstile> get_disconnected_nodes y|\<^sub>r"
using a8 a5 disconnected_nodes_eq2_h by presburger
have f11: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a4 by simp
have "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a2 by simp
then show False
using f11 f10 f9 a6 a1 by (meson disjoint_iff_not_equal distinct_concat_map_E(1))
next
fix x xa xb
assume 0: "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
and 1: "h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []"
and 2: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
and 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
and 4: "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h). set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 5: "x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
and 7: "xa |\<in>| object_ptr_kinds h"
and 8: "xa \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr"
and 9: "xb |\<in>| document_ptr_kinds h"
and 10: "xb \<noteq> new_document_ptr"
then show "False"
by (metis \<open>local.a_distinct_lists h\<close> assms(3) disconnected_nodes_eq2_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok
returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def)[1]
by (metis \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
children_eq2 disconnected_nodes_eq2_h document_ptr_kinds_commutes finite_set_in
funion_iff node_ptr_kinds_eq object_ptr_kinds_eq)
show "heap_is_wellformed h'"
using \<open>a_acyclic_heap h'\<close> \<open>a_all_ptrs_in_heap h'\<close> \<open>a_distinct_lists h'\<close> \<open>a_owner_document_valid h'\<close>
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_create_document_wf?: l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed parent_child_rel
set_val set_val_locs set_disconnected_nodes
set_disconnected_nodes_locs create_document known_ptrs
using instances
by (auto simp add: l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_create_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/Decl_Sem_Fun_PL/ValuesFSetProps.thy b/thys/Decl_Sem_Fun_PL/ValuesFSetProps.thy
--- a/thys/Decl_Sem_Fun_PL/ValuesFSetProps.thy
+++ b/thys/Decl_Sem_Fun_PL/ValuesFSetProps.thy
@@ -1,39 +1,39 @@
theory ValuesFSetProps
imports ValuesFSet
begin
inductive_cases
vfun_le_inv[elim!]: "VFun t1 \<sqsubseteq> VFun t2" and
le_fun_nat_inv[elim!]: "VFun t2 \<sqsubseteq> VNat x1" and
le_any_nat_inv[elim!]: "v \<sqsubseteq> VNat n" and
le_nat_any_inv[elim!]: "VNat n \<sqsubseteq> v" and
le_fun_any_inv[elim!]: "VFun t \<sqsubseteq> v" and
le_any_fun_inv[elim!]: "v \<sqsubseteq> VFun t"
proposition val_le_refl[simp]: fixes v::val shows "v \<sqsubseteq> v" by (induction v) auto
proposition val_le_trans[trans]: fixes v2::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v3 \<rbrakk> \<Longrightarrow> v1 \<sqsubseteq> v3"
by (induction v2 arbitrary: v1 v3) blast+
lemma fsubset[intro!]: "fset A \<subseteq> fset B \<Longrightarrow> A |\<subseteq>| B"
proof (rule fsubsetI)
fix x assume ab: "fset A \<subseteq> fset B" and xa: "x |\<in>| A"
- from xa have "x \<in> fset A" using fmember.rep_eq[of x A] by simp
+ from xa have "x \<in> fset A" using fmember_iff_member_fset[of x A] by simp
from this ab have "x \<in> fset B" by blast
- from this show "x |\<in>| B" using fmember.rep_eq[of x B] by simp
+ from this show "x |\<in>| B" using fmember_iff_member_fset[of x B] by simp
qed
proposition val_le_antisymm: fixes v1::val shows "\<lbrakk> v1 \<sqsubseteq> v2; v2 \<sqsubseteq> v1 \<rbrakk> \<Longrightarrow> v1 = v2"
by (induction v1 arbitrary: v2) auto
lemma le_nat_any[simp]: "VNat n \<sqsubseteq> v \<Longrightarrow> v = VNat n"
by (cases v) auto
lemma le_any_nat[simp]: "v \<sqsubseteq> VNat n \<Longrightarrow> v = VNat n"
by (cases v) auto
lemma le_nat_nat[simp]: "VNat n \<sqsubseteq> VNat n' \<Longrightarrow> n = n'"
by auto
end
diff --git a/thys/Extended_Finite_State_Machines/EFSM.thy b/thys/Extended_Finite_State_Machines/EFSM.thy
--- a/thys/Extended_Finite_State_Machines/EFSM.thy
+++ b/thys/Extended_Finite_State_Machines/EFSM.thy
@@ -1,1496 +1,1496 @@
section \<open>Extended Finite State Machines\<close>
text\<open>This theory defines extended finite state machines as presented in \cite{foster2018}. States
are indexed by natural numbers, however, since transition matrices are implemented by finite sets,
the number of reachable states in $S$ is necessarily finite. For ease of implementation, we
implicitly make the initial state zero for all EFSMs. This allows EFSMs to be represented purely by
their transition matrix which, in this implementation, is a finite set of tuples of the form
$((s_1, s_2), t)$ in which $s_1$ is the origin state, $s_2$ is the destination state, and $t$ is a
transition.\<close>
theory EFSM
imports "HOL-Library.FSet" Transition FSet_Utils
begin
declare One_nat_def [simp del]
type_synonym cfstate = nat
type_synonym inputs = "value list"
type_synonym outputs = "value option list"
type_synonym action = "(label \<times> inputs)"
type_synonym execution = "action list"
type_synonym observation = "outputs list"
type_synonym transition_matrix = "((cfstate \<times> cfstate) \<times> transition) fset"
no_notation relcomp (infixr "O" 75) and comp (infixl "o" 55)
type_synonym event = "(label \<times> inputs \<times> value list)"
type_synonym trace = "event list"
type_synonym log = "trace list"
definition Str :: "string \<Rightarrow> value" where
"Str s \<equiv> value.Str (String.implode s)"
lemma str_not_num: "Str s \<noteq> Num x1"
by (simp add: Str_def)
definition S :: "transition_matrix \<Rightarrow> nat fset" where
"S m = (fimage (\<lambda>((s, s'), t). s) m) |\<union>| fimage (\<lambda>((s, s'), t). s') m"
lemma S_ffUnion: "S e = ffUnion (fimage (\<lambda>((s, s'), _). {|s, s'|}) e)"
unfolding S_def
by(induct e, auto)
subsection\<open>Possible Steps\<close>
text\<open>From a given state, the possible steps for a given action are those transitions with labels
which correspond to the action label, arities which correspond to the number of inputs, and guards
which are satisfied by those inputs.\<close>
definition possible_steps :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (cfstate \<times> transition) fset" where
"possible_steps e s r l i = fimage (\<lambda>((origin, dest), t). (dest, t)) (ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> (length i) = (Arity t) \<and> apply_guards (Guards t) (join_ir i r)) e)"
lemma possible_steps_finsert:
"possible_steps (finsert ((s, s'), t) e) ss r l i = (
if s = ss \<and> (Label t) = l \<and> (length i) = (Arity t) \<and> apply_guards (Guards t) (join_ir i r) then
finsert (s', t) (possible_steps e s r l i)
else
possible_steps e ss r l i
)"
by (simp add: possible_steps_def ffilter_finsert)
lemma split_origin:
"ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r) e =
ffilter (\<lambda>((origin, dest), t). Label t = l \<and> can_take_transition t i r) (ffilter (\<lambda>((origin, dest), t). origin = s) e)"
by auto
lemma split_label:
"ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r) e =
ffilter (\<lambda>((origin, dest), t). origin = s \<and> can_take_transition t i r) (ffilter (\<lambda>((origin, dest), t). Label t = l) e)"
by auto
lemma possible_steps_empty_guards_false:
"\<forall>((s1, s2), t) |\<in>| ffilter (\<lambda>((origin, dest), t). Label t = l) e. \<not>can_take_transition t i r \<Longrightarrow>
possible_steps e s r l i = {||}"
apply (simp add: possible_steps_def can_take[symmetric] split_label)
by (simp add: Abs_ffilter fBall_def Ball_def)
lemma fmember_possible_steps: "(s', t) |\<in>| possible_steps e s r l i = (((s, s'), t) \<in> {((origin, dest), t) \<in> fset e. origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)})"
apply (simp add: possible_steps_def ffilter_def fimage_def fmember_def Abs_fset_inverse)
by force
lemma possible_steps_alt_aux:
"possible_steps e s r l i = {|(d, t)|} \<Longrightarrow>
ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e = {|((s, d), t)|}"
proof(induct e)
case empty
then show ?case
by (simp add: fempty_not_finsert possible_steps_def)
next
case (insert x e)
then show ?case
apply (case_tac x)
subgoal for a b
apply (case_tac a)
subgoal for aa _
apply (simp add: possible_steps_def)
apply (simp add: ffilter_finsert)
apply (case_tac "aa = s \<and> Label b = l \<and> length i = Arity b \<and> apply_guards (Guards b) (join_ir i r)")
by auto
done
done
qed
lemma possible_steps_alt: "(possible_steps e s r l i = {|(d, t)|}) = (ffilter
(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r))
e = {|((s, d), t)|})"
apply standard
apply (simp add: possible_steps_alt_aux)
by (simp add: possible_steps_def)
lemma possible_steps_alt3: "(possible_steps e s r l i = {|(d, t)|}) = (ffilter
(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r)
e = {|((s, d), t)|})"
apply standard
apply (simp add: possible_steps_alt_aux can_take)
by (simp add: possible_steps_def can_take)
lemma possible_steps_alt_atom: "(possible_steps e s r l i = {|dt|}) = (ffilter
(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> can_take_transition t i r)
e = {|((s, fst dt), snd dt)|})"
apply (cases dt)
by (simp add: possible_steps_alt can_take_transition_def can_take_def)
lemma possible_steps_alt2: "(possible_steps e s r l i = {|(d, t)|}) = (
(ffilter (\<lambda>((origin, dest), t). Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) (ffilter (\<lambda>((origin, dest), t). origin = s) e) = {|((s, d), t)|}))"
apply (simp add: possible_steps_alt)
apply (simp only: filter_filter)
apply (rule arg_cong [of "(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r))"])
by (rule ext, auto)
lemma possible_steps_single_out:
"ffilter (\<lambda>((origin, dest), t). origin = s) e = {|((s, d), t)|} \<Longrightarrow>
Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r) \<Longrightarrow>
possible_steps e s r l i = {|(d, t)|}"
apply (simp add: possible_steps_alt2 Abs_ffilter)
by blast
lemma possible_steps_singleton: "(possible_steps e s r l i = {|(d, t)|}) =
({((origin, dest), t) \<in> fset e. origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)} = {((s, d), t)})"
apply (simp add: possible_steps_alt Abs_ffilter Set.filter_def)
by fast
lemma possible_steps_apply_guards:
"possible_steps e s r l i = {|(s', t)|} \<Longrightarrow>
apply_guards (Guards t) (join_ir i r)"
apply (simp add: possible_steps_singleton)
by auto
lemma possible_steps_empty:
"(possible_steps e s r l i = {||}) = (\<forall>((origin, dest), t) \<in> fset e. origin \<noteq> s \<or> Label t \<noteq> l \<or> \<not> can_take_transition t i r)"
apply (simp add: can_take_transition_def can_take_def)
apply (simp add: possible_steps_def Abs_ffilter Set.filter_def)
by auto
lemma singleton_dest:
assumes "fis_singleton (possible_steps e s r aa b)"
and "fthe_elem (possible_steps e s r aa b) = (baa, aba)"
shows "((s, baa), aba) |\<in>| e"
using assms
apply (simp add: fis_singleton_fthe_elem)
using possible_steps_alt_aux by force
lemma no_outgoing_transitions:
"ffilter (\<lambda>((s', _), _). s = s') e = {||} \<Longrightarrow>
possible_steps e s r l i = {||}"
apply (simp add: possible_steps_def)
by auto
lemma ffilter_split: "ffilter (\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e =
ffilter (\<lambda>((origin, dest), t). Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) (ffilter (\<lambda>((origin, dest), t). origin = s) e)"
by auto
lemma one_outgoing_transition:
defines "outgoing s \<equiv> (\<lambda>((origin, dest), t). origin = s)"
assumes prem: "size (ffilter (outgoing s) e) = 1"
shows "size (possible_steps e s r l i) \<le> 1"
proof-
have less_eq_1: "\<And>x::nat. (x \<le> 1) = (x = 1 \<or> x = 0)"
by auto
have size_empty: "\<And>f. (size f = 0) = (f = {||})"
subgoal for f
by (induct f, auto)
done
show ?thesis
using prem
apply (simp only: possible_steps_def)
apply (rule fimage_size_le)
apply (simp only: ffilter_split outgoing_def[symmetric])
by (metis (no_types, lifting) size_ffilter)
qed
subsection\<open>Choice\<close>
text\<open>Here we define the \texttt{choice} operator which determines whether or not two transitions are
nondeterministic.\<close>
definition choice :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
"choice t t' = (\<exists> i r. apply_guards (Guards t) (join_ir i r) \<and> apply_guards (Guards t') (join_ir i r))"
definition choice_alt :: "transition \<Rightarrow> transition \<Rightarrow> bool" where
"choice_alt t t' = (\<exists> i r. apply_guards (Guards t@Guards t') (join_ir i r))"
lemma choice_alt: "choice t t' = choice_alt t t'"
by (simp add: choice_def choice_alt_def apply_guards_append)
lemma choice_symmetry: "choice x y = choice y x"
using choice_def by auto
definition deterministic :: "transition_matrix \<Rightarrow> bool" where
"deterministic e = (\<forall>s r l i. size (possible_steps e s r l i) \<le> 1)"
lemma deterministic_alt_aux: "size (possible_steps e s r l i) \<le> 1 =(
possible_steps e s r l i = {||} \<or>
(\<exists>s' t.
ffilter
(\<lambda>((origin, dest), t). origin = s \<and> Label t = l \<and> length i = Arity t \<and> apply_guards (Guards t) (join_ir i r)) e =
{|((s, s'), t)|}))"
apply (case_tac "size (possible_steps e s r l i) = 0")
apply (simp add: fset_equiv)
apply (case_tac "possible_steps e s r l i = {||}")
apply simp
apply (simp only: possible_steps_alt[symmetric])
by (metis le_neq_implies_less le_numeral_extra(4) less_one prod.collapse size_fsingleton)
lemma deterministic_alt: "deterministic e = (
\<forall>s r l i.
possible_steps e s r l i = {||} \<or>
(\<exists>s' t. ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> (length i) = (Arity t) \<and> apply_guards (Guards t) (join_ir i r)) e = {|((s, s'), t)|})
)"
using deterministic_alt_aux
by (simp add: deterministic_def)
lemma size_le_1: "size f \<le> 1 = (f = {||} \<or> (\<exists>e. f = {|e|}))"
apply standard
apply (metis bot.not_eq_extremum gr_implies_not0 le_neq_implies_less less_one size_fsingleton size_fsubset)
by auto
lemma ffilter_empty_if: "\<forall>x |\<in>| xs. \<not> P x \<Longrightarrow> ffilter P xs = {||}"
by auto
lemma empty_ffilter: "ffilter P xs = {||} = (\<forall>x |\<in>| xs. \<not> P x)"
by auto
lemma all_states_deterministic:
"(\<forall>s l i r.
ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> can_take_transition t i r) e = {||} \<or>
(\<exists>x. ffilter (\<lambda>((origin, dest), t). origin = s \<and> (Label t) = l \<and> can_take_transition t i r) e = {|x|})
) \<Longrightarrow> deterministic e"
unfolding deterministic_def
apply clarify
subgoal for s r l i
apply (erule_tac x=s in allE)
apply (erule_tac x=l in allE)
apply (erule_tac x=i in allE)
apply (erule_tac x=r in allE)
apply (simp only: size_le_1)
apply (erule disjE)
apply (rule_tac disjI1)
apply (simp add: possible_steps_def can_take_transition_def can_take_def)
apply (erule exE)
subgoal for x
apply (case_tac x)
subgoal for a b
apply (case_tac a)
apply simp
apply (induct e)
apply auto[1]
subgoal for _ _ _ ba
apply (rule disjI2)
apply (rule_tac x=ba in exI)
apply (rule_tac x=b in exI)
by (simp add: possible_steps_def can_take_transition_def[symmetric] can_take_def[symmetric])
done
done
done
done
lemma deterministic_finsert:
"\<forall>i r l.
\<forall>((a, b), t) |\<in>| ffilter (\<lambda>((origin, dest), t). origin = s) (finsert ((s, s'), t') e).
Label t = l \<and> can_take_transition t i r \<longrightarrow> \<not> can_take_transition t' i r \<Longrightarrow>
deterministic e \<Longrightarrow>
deterministic (finsert ((s, s'), t') e)"
apply (simp add: deterministic_def possible_steps_finsert can_take del: size_fset_overloaded_simps)
apply clarify
subgoal for r i
apply (erule_tac x=s in allE)
apply (erule_tac x=r in allE)
apply (erule_tac x="Label t'" in allE)
apply (erule_tac x=i in allE)
apply (erule_tac x=r in allE)
apply (erule_tac x=i in allE)
apply (erule_tac x="Label t'" in allE)
by auto
done
lemma ffilter_fBall: "(\<forall>x |\<in>| xs. P x) = (ffilter P xs = xs)"
by auto
lemma fsubset_if: "\<forall>x. x |\<in>| f1 \<longrightarrow> x |\<in>| f2 \<Longrightarrow> f1 |\<subseteq>| f2"
by auto
lemma in_possible_steps: "(((s, s'), t)|\<in>|e \<and> Label t = l \<and> can_take_transition t i r) = ((s', t) |\<in>| possible_steps e s r l i)"
apply (simp add: fmember_possible_steps)
- by (simp add: can_take_def can_take_transition_def fmember.rep_eq)
+ by (simp add: can_take_def can_take_transition_def fmember_iff_member_fset)
lemma possible_steps_can_take_transition:
"(s2, t1) |\<in>| possible_steps e1 s1 r l i \<Longrightarrow> can_take_transition t1 i r"
using in_possible_steps by blast
lemma not_deterministic:
"\<exists>s l i r.
\<exists>d1 d2 t1 t2.
d1 \<noteq> d2 \<and> t1 \<noteq> t2 \<and>
((s, d1), t1) |\<in>| e \<and>
((s, d2), t2) |\<in>| e \<and>
Label t1 = Label t2 \<and>
can_take_transition t1 i r \<and>
can_take_transition t2 i r \<Longrightarrow>
\<not>deterministic e"
apply (simp add: deterministic_def not_le del: size_fset_overloaded_simps)
apply clarify
subgoal for s i r d1 d2 t1 t2
apply (rule_tac x=s in exI)
apply (rule_tac x=r in exI)
apply (rule_tac x="Label t1" in exI)
apply (rule_tac x=i in exI)
apply (case_tac "(d1, t1) |\<in>| possible_steps e s r (Label t1) i")
defer using in_possible_steps apply blast
apply (case_tac "(d2, t2) |\<in>| possible_steps e s r (Label t1) i")
apply (metis fempty_iff fsingleton_iff not_le_imp_less prod.inject size_le_1)
using in_possible_steps by force
done
lemma not_deterministic_conv:
"\<not>deterministic e \<Longrightarrow>
\<exists>s l i r.
\<exists>d1 d2 t1 t2.
(d1 \<noteq> d2 \<or> t1 \<noteq> t2) \<and>
((s, d1), t1) |\<in>| e \<and>
((s, d2), t2) |\<in>| e \<and>
Label t1 = Label t2 \<and>
can_take_transition t1 i r \<and>
can_take_transition t2 i r"
apply (simp add: deterministic_def not_le del: size_fset_overloaded_simps)
apply clarify
subgoal for s r l i
apply (case_tac "\<exists>e1 e2 f'. e1 \<noteq> e2 \<and> possible_steps e s r l i = finsert e1 (finsert e2 f')")
defer using size_gt_1 apply blast
apply (erule exE)+
subgoal for e1 e2 f'
apply (case_tac e1, case_tac e2)
subgoal for a b aa ba
apply (simp del: size_fset_overloaded_simps)
apply (rule_tac x=s in exI)
apply (rule_tac x=i in exI)
apply (rule_tac x=r in exI)
apply (rule_tac x=a in exI)
apply (rule_tac x=aa in exI)
apply (rule_tac x=b in exI)
apply (rule_tac x=ba in exI)
by (metis finsertI1 finsert_commute in_possible_steps)
done
done
done
lemma deterministic_if:
"\<nexists>s l i r.
\<exists>d1 d2 t1 t2.
(d1 \<noteq> d2 \<or> t1 \<noteq> t2) \<and>
((s, d1), t1) |\<in>| e \<and>
((s, d2), t2) |\<in>| e \<and>
Label t1 = Label t2 \<and>
can_take_transition t1 i r \<and>
can_take_transition t2 i r \<Longrightarrow>
deterministic e"
using not_deterministic_conv by blast
lemma "\<forall>l i r.
(\<forall>((s, s'), t) |\<in>| e. Label t = l \<and> can_take_transition t i r \<and>
(\<nexists>t' s''. ((s, s''), t') |\<in>| e \<and> (s' \<noteq> s'' \<or> t' \<noteq> t) \<and> Label t' = l \<and> can_take_transition t' i r))
\<Longrightarrow> deterministic e"
apply (simp add: deterministic_def del: size_fset_overloaded_simps)
apply (rule allI)+
apply (simp only: size_le_1 possible_steps_empty)
apply (case_tac "\<exists>t s'. ((s, s'), t)|\<in>|e \<and> Label t = l \<and> can_take_transition t i r")
defer using notin_fset apply fastforce
apply (rule disjI2)
apply clarify
apply (rule_tac x="(s', t)" in exI)
apply standard
defer apply (meson fempty_fsubsetI finsert_fsubset in_possible_steps)
apply standard
apply (case_tac x)
apply (simp add: in_possible_steps[symmetric])
apply (erule_tac x="Label t" in allE)
apply (erule_tac x=i in allE)
apply (erule_tac x=r in allE)
apply (erule_tac x="((s, s'), t)" in fBallE)
defer apply simp
apply simp
apply (erule_tac x=b in allE)
apply simp
apply (erule_tac x=a in allE)
by simp
definition "outgoing_transitions e s = ffilter (\<lambda>((o, _), _). o = s) e"
lemma in_outgoing: "((s1, s2), t) |\<in>| outgoing_transitions e s = (((s1, s2), t) |\<in>| e \<and> s1 = s)"
by (simp add: outgoing_transitions_def)
lemma outgoing_transitions_deterministic:
"\<forall>s.
\<forall>((s1, s2), t) |\<in>| outgoing_transitions e s.
\<forall>((s1', s2'), t') |\<in>| outgoing_transitions e s.
s2 \<noteq> s2' \<or> t \<noteq> t' \<longrightarrow> Label t = Label t' \<longrightarrow> \<not> choice t t' \<Longrightarrow> deterministic e"
apply (rule deterministic_if)
apply simp
apply (rule allI)
subgoal for s
apply (erule_tac x=s in allE)
apply (simp add: fBall_def Ball_def)
apply (rule allI)+
subgoal for i r d1 d2 t1
apply (erule_tac x=s in allE)
apply (erule_tac x=d1 in allE)
apply (erule_tac x=t1 in allE)
apply (rule impI, rule allI)
subgoal for t2
apply (case_tac "((s, d1), t1) \<in> fset (outgoing_transitions e s)")
apply simp
apply (erule_tac x=s in allE)
apply (erule_tac x=d2 in allE)
apply (erule_tac x=t2 in allE)
apply (simp add: outgoing_transitions_def choice_def can_take)
apply (meson fmember_implies_member)
apply (simp add: outgoing_transitions_def)
by (meson fmember_implies_member)
done
done
done
lemma outgoing_transitions_deterministic2: "(\<And>s a b ba aa bb bc.
((a, b), ba) |\<in>| outgoing_transitions e s \<Longrightarrow>
((aa, bb), bc) |\<in>| (outgoing_transitions e s) - {|((a, b), ba)|} \<Longrightarrow> b \<noteq> bb \<or> ba \<noteq> bc \<Longrightarrow> \<not>choice ba bc)
\<Longrightarrow> deterministic e"
apply (rule outgoing_transitions_deterministic)
by blast
lemma outgoing_transitions_fprod_deterministic:
"(\<And>s b ba bb bc.
(((s, b), ba), ((s, bb), bc)) \<in> fset (outgoing_transitions e s) \<times> fset (outgoing_transitions e s)
\<Longrightarrow> b \<noteq> bb \<or> ba \<noteq> bc \<Longrightarrow> Label ba = Label bc \<Longrightarrow> \<not>choice ba bc)
\<Longrightarrow> deterministic e"
apply (rule outgoing_transitions_deterministic)
apply clarify
by (metis SigmaI fmember_implies_member in_outgoing)
text\<open>The \texttt{random\_member} function returns a random member from a finite set, or
\texttt{None}, if the set is empty.\<close>
definition random_member :: "'a fset \<Rightarrow> 'a option" where
"random_member f = (if f = {||} then None else Some (Eps (\<lambda>x. x |\<in>| f)))"
lemma random_member_nonempty: "s \<noteq> {||} = (random_member s \<noteq> None)"
by (simp add: random_member_def)
lemma random_member_singleton [simp]: "random_member {|a|} = Some a"
by (simp add: random_member_def)
lemma random_member_is_member:
"random_member ss = Some s \<Longrightarrow> s |\<in>| ss"
apply (simp add: random_member_def)
by (metis equalsffemptyI option.distinct(1) option.inject verit_sko_ex_indirect)
lemma random_member_None[simp]: "random_member ss = None = (ss = {||})"
by (simp add: random_member_def)
lemma random_member_empty[simp]: "random_member {||} = None"
by simp
definition step :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> label \<Rightarrow> inputs \<Rightarrow> (transition \<times> cfstate \<times> outputs \<times> registers) option" where
"step e s r l i = (case random_member (possible_steps e s r l i) of
None \<Rightarrow> None |
Some (s', t) \<Rightarrow> Some (t, s', evaluate_outputs t i r, evaluate_updates t i r)
)"
lemma possible_steps_not_empty_iff:
"step e s r a b \<noteq> None \<Longrightarrow>
\<exists>aa ba. (aa, ba) |\<in>| possible_steps e s r a b"
apply (simp add: step_def)
apply (case_tac "possible_steps e s r a b")
apply (simp add: random_member_def)
by auto
lemma step_member: "step e s r l i = Some (t, s', p, r') \<Longrightarrow> (s', t) |\<in>| possible_steps e s r l i"
apply (simp add: step_def)
apply (case_tac "random_member (possible_steps e s r l i)")
apply simp
subgoal for a by (case_tac a, simp add: random_member_is_member)
done
lemma step_outputs: "step e s r l i = Some (t, s', p, r') \<Longrightarrow> evaluate_outputs t i r = p"
apply (simp add: step_def)
apply (case_tac "random_member (possible_steps e s r l i)")
by auto
lemma step:
"possibilities = (possible_steps e s r l i) \<Longrightarrow>
random_member possibilities = Some (s', t) \<Longrightarrow>
evaluate_outputs t i r = p \<Longrightarrow>
evaluate_updates t i r = r' \<Longrightarrow>
step e s r l i = Some (t, s', p, r')"
by (simp add: step_def)
lemma step_None: "step e s r l i = None = (possible_steps e s r l i = {||})"
by (simp add: step_def prod.case_eq_if random_member_def)
lemma step_Some: "step e s r l i = Some (t, s', p, r') =
(
random_member (possible_steps e s r l i) = Some (s', t) \<and>
evaluate_outputs t i r = p \<and>
evaluate_updates t i r = r'
)"
apply (simp add: step_def)
apply (case_tac "random_member (possible_steps e s r l i)")
apply simp
subgoal for a by (case_tac a, auto)
done
lemma no_possible_steps_1:
"possible_steps e s r l i = {||} \<Longrightarrow> step e s r l i = None"
by (simp add: step_def random_member_def)
subsection\<open>Execution Observation\<close>
text\<open>One of the key features of this formalisation of EFSMs is their ability to produce
\emph{outputs}, which represent function return values. When action sequences are executed in an
EFSM, they produce a corresponding \emph{observation}.\<close>
text_raw\<open>\snip{observe}{1}{2}{%\<close>
fun observe_execution :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> outputs list" where
"observe_execution _ _ _ [] = []" |
"observe_execution e s r ((l, i)#as) = (
let viable = possible_steps e s r l i in
if viable = {||} then
[]
else
let (s', t) = Eps (\<lambda>x. x |\<in>| viable) in
(evaluate_outputs t i r)#(observe_execution e s' (evaluate_updates t i r) as)
)"
text_raw\<open>}%endsnip\<close>
lemma observe_execution_step_def: "observe_execution e s r ((l, i)#as) = (
case step e s r l i of
None \<Rightarrow> []|
Some (t, s', p, r') \<Rightarrow> p#(observe_execution e s' r' as)
)"
apply (simp add: step_def)
apply (case_tac "possible_steps e s r l i")
apply simp
subgoal for x S'
apply (simp add: random_member_def)
apply (case_tac "SOME xa. xa = x \<or> xa |\<in>| S'")
by simp
done
lemma observe_execution_first_outputs_equiv:
"observe_execution e1 s1 r1 ((l, i) # ts) = observe_execution e2 s2 r2 ((l, i) # ts) \<Longrightarrow>
step e1 s1 r1 l i = Some (t, s', p, r') \<Longrightarrow>
\<exists>(s2', t2)|\<in>|possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = p"
apply (simp only: observe_execution_step_def)
apply (case_tac "step e2 s2 r2 l i")
apply simp
subgoal for a
apply simp
apply (case_tac a)
apply clarsimp
by (meson step_member case_prodI rev_fBexI step_outputs)
done
lemma observe_execution_step:
"step e s r (fst h) (snd h) = Some (t, s', p, r') \<Longrightarrow>
observe_execution e s' r' es = obs \<Longrightarrow>
observe_execution e s r (h#es) = p#obs"
apply (cases h, simp add: step_def)
apply (case_tac "possible_steps e s r a b = {||}")
apply simp
subgoal for a b
apply (case_tac "SOME x. x |\<in>| possible_steps e s r a b")
by (simp add: random_member_def)
done
lemma observe_execution_possible_step:
"possible_steps e s r (fst h) (snd h) = {|(s', t)|} \<Longrightarrow>
apply_outputs (Outputs t) (join_ir (snd h) r) = p \<Longrightarrow>
apply_updates (Updates t) (join_ir (snd h) r) r = r' \<Longrightarrow>
observe_execution e s' r' es = obs \<Longrightarrow>
observe_execution e s r (h#es) = p#obs"
by (simp add: observe_execution_step step)
lemma observe_execution_no_possible_step:
"possible_steps e s r (fst h) (snd h) = {||} \<Longrightarrow>
observe_execution e s r (h#es) = []"
by (cases h, simp)
lemma observe_execution_no_possible_steps:
"possible_steps e1 s1 r1 (fst h) (snd h) = {||} \<Longrightarrow>
possible_steps e2 s2 r2 (fst h) (snd h) = {||} \<Longrightarrow>
(observe_execution e1 s1 r1 (h#t)) = (observe_execution e2 s2 r2 (h#t))"
by (simp add: observe_execution_no_possible_step)
lemma observe_execution_one_possible_step:
"possible_steps e1 s1 r (fst h) (snd h) = {|(s1', t1)|} \<Longrightarrow>
possible_steps e2 s2 r (fst h) (snd h) = {|(s2', t2)|} \<Longrightarrow>
apply_outputs (Outputs t1) (join_ir (snd h) r) = apply_outputs (Outputs t2) (join_ir (snd h) r) \<Longrightarrow>
apply_updates (Updates t1) (join_ir (snd h) r) r = r' \<Longrightarrow>
apply_updates (Updates t2) (join_ir (snd h) r) r = r' \<Longrightarrow>
(observe_execution e1 s1' r' t) = (observe_execution e2 s2' r' t) \<Longrightarrow>
(observe_execution e1 s1 r (h#t)) = (observe_execution e2 s2 r (h#t))"
by (simp add: observe_execution_possible_step)
subsubsection\<open>Utilities\<close>
text\<open>Here we define some utility functions to access the various key properties of a given EFSM.\<close>
definition max_reg :: "transition_matrix \<Rightarrow> nat option" where
"max_reg e = (let maxes = (fimage (\<lambda>(_, t). Transition.max_reg t) e) in if maxes = {||} then None else fMax maxes)"
definition enumerate_ints :: "transition_matrix \<Rightarrow> int set" where
"enumerate_ints e = \<Union> (image (\<lambda>(_, t). Transition.enumerate_ints t) (fset e))"
definition max_int :: "transition_matrix \<Rightarrow> int" where
"max_int e = Max (insert 0 (enumerate_ints e))"
definition max_output :: "transition_matrix \<Rightarrow> nat" where
"max_output e = fMax (fimage (\<lambda>(_, t). length (Outputs t)) e)"
definition all_regs :: "transition_matrix \<Rightarrow> nat set" where
"all_regs e = \<Union> (image (\<lambda>(_, t). enumerate_regs t) (fset e))"
text_raw\<open>\snip{finiteRegs}{1}{2}{%\<close>
lemma finite_all_regs: "finite (all_regs e)"
text_raw\<open>}%endsnip\<close>
apply (simp add: all_regs_def enumerate_regs_def)
apply clarify
apply standard
apply (rule finite_UnI)+
using GExp.finite_enumerate_regs apply blast
using AExp.finite_enumerate_regs apply blast
apply (simp add: AExp.finite_enumerate_regs prod.case_eq_if)
by auto
definition max_input :: "transition_matrix \<Rightarrow> nat option" where
"max_input e = fMax (fimage (\<lambda>(_, t). Transition.max_input t) e)"
fun maxS :: "transition_matrix \<Rightarrow> nat" where
"maxS t = (if t = {||} then 0 else fMax ((fimage (\<lambda>((origin, dest), t). origin) t) |\<union>| (fimage (\<lambda>((origin, dest), t). dest) t)))"
subsection\<open>Execution Recognition\<close>
text\<open>The \texttt{recognises} function returns true if the given EFSM recognises a given execution.
That is, the EFSM is able to respond to each event in sequence. There is no restriction on the
outputs produced. When a recognised execution is observed, it produces an accepted trace of the
EFSM.\<close>
text_raw\<open>\snip{recognises}{1}{2}{%\<close>
inductive recognises_execution :: "transition_matrix \<Rightarrow> nat \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
base [simp]: "recognises_execution e s r []" |
step: "\<exists>(s', T) |\<in>| possible_steps e s r l i.
recognises_execution e s' (evaluate_updates T i r) t \<Longrightarrow>
recognises_execution e s r ((l, i)#t)"
text_raw\<open>}%endsnip\<close>
abbreviation "recognises e t \<equiv> recognises_execution e 0 <> t"
definition "E e = {x. recognises e x}"
lemma no_possible_steps_rejects:
"possible_steps e s r l i = {||} \<Longrightarrow> \<not> recognises_execution e s r ((l, i)#t)"
apply clarify
by (rule recognises_execution.cases, auto)
lemma recognises_step_equiv: "recognises_execution e s r ((l, i)#t) =
(\<exists>(s', T) |\<in>| possible_steps e s r l i. recognises_execution e s' (evaluate_updates T i r) t)"
apply standard
apply (rule recognises_execution.cases)
by (auto simp: recognises_execution.step)
fun recognises_prim :: "transition_matrix \<Rightarrow> nat \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
"recognises_prim e s r [] = True" |
"recognises_prim e s r ((l, i)#t) = (
let poss_steps = possible_steps e s r l i in
(\<exists>(s', T) |\<in>| poss_steps. recognises_prim e s' (evaluate_updates T i r) t)
)"
lemma recognises_prim [code]: "recognises_execution e s r t = recognises_prim e s r t"
proof(induct t arbitrary: r s)
case Nil
then show ?case
by simp
next
case (Cons h t)
then show ?case
apply (cases h)
apply simp
apply standard
apply (rule recognises_execution.cases, simp)
apply simp
apply auto[1]
using recognises_execution.step by blast
qed
lemma recognises_single_possible_step:
assumes "possible_steps e s r l i = {|(s', t)|}"
and "recognises_execution e s' (evaluate_updates t i r) trace"
shows "recognises_execution e s r ((l, i)#trace)"
apply (rule recognises_execution.step)
using assms by auto
lemma recognises_single_possible_step_atomic:
assumes "possible_steps e s r (fst h) (snd h) = {|(s', t)|}"
and "recognises_execution e s' (apply_updates (Updates t) (join_ir (snd h) r) r) trace"
shows "recognises_execution e s r (h#trace)"
by (metis assms prod.collapse recognises_single_possible_step)
lemma recognises_must_be_possible_step:
"recognises_execution e s r (h # t) \<Longrightarrow>
\<exists>aa ba. (aa, ba) |\<in>| possible_steps e s r (fst h) (snd h)"
using recognises_step_equiv by fastforce
lemma recognises_possible_steps_not_empty:
"recognises_execution e s r (h#t) \<Longrightarrow> possible_steps e s r (fst h) (snd h) \<noteq> {||}"
apply (rule recognises_execution.cases)
by auto
lemma recognises_must_be_step:
"recognises_execution e s r (h#ts) \<Longrightarrow>
\<exists>t s' p d'. step e s r (fst h) (snd h) = Some (t, s', p, d')"
apply (cases h)
subgoal for a b
apply (simp add: recognises_step_equiv step_def)
apply clarify
apply (case_tac "(possible_steps e s r a b)")
apply (simp add: random_member_def)
apply (simp add: random_member_def)
subgoal for _ _ x S' apply (case_tac "SOME xa. xa = x \<or> xa |\<in>| S'")
by simp
done
done
lemma recognises_cons_step:
"recognises_execution e s r (h # t) \<Longrightarrow> step e s r (fst h) (snd h) \<noteq> None"
by (simp add: recognises_must_be_step)
lemma no_step_none:
"step e s r aa ba = None \<Longrightarrow> \<not> recognises_execution e s r ((aa, ba) # p)"
using recognises_cons_step by fastforce
lemma step_none_rejects:
"step e s r (fst h) (snd h) = None \<Longrightarrow> \<not> recognises_execution e s r (h#t)"
using no_step_none surjective_pairing by fastforce
lemma trace_reject:
"(\<not> recognises_execution e s r ((l, i)#t)) = (possible_steps e s r l i = {||} \<or> (\<forall>(s', T) |\<in>| possible_steps e s r l i. \<not> recognises_execution e s' (evaluate_updates T i r) t))"
using recognises_prim by fastforce
lemma trace_reject_no_possible_steps_atomic:
"possible_steps e s r (fst a) (snd a) = {||} \<Longrightarrow> \<not> recognises_execution e s r (a#t)"
using recognises_possible_steps_not_empty by auto
lemma trace_reject_later:
"\<forall>(s', T) |\<in>| possible_steps e s r l i. \<not> recognises_execution e s' (evaluate_updates T i r) t \<Longrightarrow>
\<not> recognises_execution e s r ((l, i)#t)"
using trace_reject by auto
lemma recognition_prefix_closure: "recognises_execution e s r (t@t') \<Longrightarrow> recognises_execution e s r t"
proof(induct t arbitrary: s r)
case (Cons a t)
then show ?case
apply (cases a, clarsimp)
apply (rule recognises_execution.cases)
apply simp
apply simp
by (rule recognises_execution.step, auto)
qed auto
lemma rejects_prefix: "\<not> recognises_execution e s r t \<Longrightarrow> \<not> recognises_execution e s r (t @ t')"
using recognition_prefix_closure by blast
lemma recognises_head: "recognises_execution e s r (h#t) \<Longrightarrow> recognises_execution e s r [h]"
by (simp add: recognition_prefix_closure)
subsubsection\<open>Trace Acceptance\<close>
text\<open>The \texttt{accepts} function returns true if the given EFSM accepts a given trace. That is,
the EFSM is able to respond to each event in sequence \emph{and} is able to produce the expected
output. Accepted traces represent valid runs of an EFSM.\<close>
text_raw\<open>\snip{accepts}{1}{2}{%\<close>
inductive accepts_trace :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
base [simp]: "accepts_trace e s r []" |
step: "\<exists>(s', T) |\<in>| possible_steps e s r l i.
evaluate_outputs T i r = map Some p \<and> accepts_trace e s' (evaluate_updates T i r) t \<Longrightarrow>
accepts_trace e s r ((l, i, p)#t)"
text_raw\<open>}%endsnip\<close>
text_raw\<open>\snip{T}{1}{2}{%\<close>
definition T :: "transition_matrix \<Rightarrow> trace set" where
"T e = {t. accepts_trace e 0 <> t}"
text_raw\<open>}%endsnip\<close>
abbreviation "rejects_trace e s r t \<equiv> \<not> accepts_trace e s r t"
lemma accepts_trace_step:
"accepts_trace e s r ((l, i, p)#t) = (\<exists>(s', T) |\<in>| possible_steps e s r l i.
evaluate_outputs T i r = map Some p \<and>
accepts_trace e s' (evaluate_updates T i r) t)"
apply standard
by (rule accepts_trace.cases, auto simp: accepts_trace.step)
lemma accepts_trace_exists_possible_step:
"accepts_trace e1 s1 r1 ((aa, b, c) # t) \<Longrightarrow>
\<exists>(s1', t1)|\<in>|possible_steps e1 s1 r1 aa b.
evaluate_outputs t1 b r1 = map Some c"
using accepts_trace_step by auto
lemma rejects_trace_step:
"rejects_trace e s r ((l, i, p)#t) = (
(\<forall>(s', T) |\<in>| possible_steps e s r l i. evaluate_outputs T i r \<noteq> map Some p \<or> rejects_trace e s' (evaluate_updates T i r) t)
)"
apply (simp add: accepts_trace_step)
by auto
definition accepts_log :: "trace set \<Rightarrow> transition_matrix \<Rightarrow> bool" where
"accepts_log l e = (\<forall>t \<in> l. accepts_trace e 0 <> t)"
text_raw\<open>\snip{prefixClosure}{1}{2}{%\<close>
lemma prefix_closure: "accepts_trace e s r (t@t') \<Longrightarrow> accepts_trace e s r t"
text_raw\<open>}%endsnip\<close>
proof(induct t arbitrary: s r)
next
case (Cons a t)
then show ?case
apply (cases a, clarsimp)
apply (simp add: accepts_trace_step)
by auto
qed auto
text\<open>For code generation, it is much more efficient to re-implement the \texttt{accepts\_trace}
function primitively than to use the code generator's default setup for inductive definitions.\<close>
fun accepts_trace_prim :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
"accepts_trace_prim _ _ _ [] = True" |
"accepts_trace_prim e s r ((l, i, p)#t) = (
let poss_steps = possible_steps e s r l i in
if fis_singleton poss_steps then
let (s', T) = fthe_elem poss_steps in
if evaluate_outputs T i r = map Some p then
accepts_trace_prim e s' (evaluate_updates T i r) t
else False
else
(\<exists>(s', T) |\<in>| poss_steps.
evaluate_outputs T i r = (map Some p) \<and>
accepts_trace_prim e s' (evaluate_updates T i r) t))"
lemma accepts_trace_prim [code]: "accepts_trace e s r l = accepts_trace_prim e s r l"
proof(induct l arbitrary: s r)
case (Cons a l)
then show ?case
apply (cases a)
apply (simp add: accepts_trace_step Let_def fis_singleton_alt)
by auto
qed auto
subsection\<open>EFSM Comparison\<close>
text\<open>Here, we define some different metrics of EFSM equality.\<close>
subsubsection\<open>State Isomporphism\<close>
text\<open>Two EFSMs are isomorphic with respect to states if there exists a bijective function between
the state names of the two EFSMs, i.e. the only difference between the two models is the way the
states are indexed.\<close>
definition isomorphic :: "transition_matrix \<Rightarrow> transition_matrix \<Rightarrow> bool" where
"isomorphic e1 e2 = (\<exists>f. bij f \<and> (\<forall>((s1, s2), t) |\<in>| e1. ((f s1, f s2), t) |\<in>| e2))"
subsubsection\<open>Register Isomporphism\<close>
text\<open>Two EFSMs are isomorphic with respect to registers if there exists a bijective function between
the indices of the registers in the two EFSMs, i.e. the only difference between the two models is
the way the registers are indexed.\<close>
definition rename_regs :: "(nat \<Rightarrow> nat) \<Rightarrow> transition_matrix \<Rightarrow> transition_matrix" where
"rename_regs f e = fimage (\<lambda>(tf, t). (tf, Transition.rename_regs f t)) e"
definition eq_upto_rename_strong :: "transition_matrix \<Rightarrow> transition_matrix \<Rightarrow> bool" where
"eq_upto_rename_strong e1 e2 = (\<exists>f. bij f \<and> rename_regs f e1 = e2)"
subsubsection\<open>Trace Simulation\<close>
text\<open>An EFSM, $e_1$ simulates another EFSM $e_2$ if there is a function between the states of the
states of $e_1$ and $e_1$ such that in each state, if $e_1$ can respond to the event and produce
the correct output, so can $e_2$.\<close>
text_raw\<open>\snip{traceSim}{1}{2}{%\<close>
inductive trace_simulation :: "(cfstate \<Rightarrow> cfstate) \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow>
transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> trace \<Rightarrow> bool" where
base: "s2 = f s1 \<Longrightarrow> trace_simulation f e1 s1 r1 e2 s2 r2 []" |
step: "s2 = f s1 \<Longrightarrow>
\<forall>(s1', t1) |\<in>| ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i).
\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = map Some o \<and>
trace_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es)"
text_raw\<open>}%endsnip\<close>
lemma trace_simulation_step:
"trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es) = (
(s2 = f s1) \<and> (\<forall>(s1', t1) |\<in>| ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i).
(\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t2 i r2 = map Some o \<and>
trace_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es))
)"
apply standard
apply (rule trace_simulation.cases, simp+)
apply (rule trace_simulation.step)
apply simp
by blast
lemma trace_simulation_step_none:
"s2 = f s1 \<Longrightarrow>
\<nexists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i. evaluate_outputs t1 i r1 = map Some o \<Longrightarrow>
trace_simulation f e1 s1 r1 e2 s2 r2 ((l, i, o)#es)"
apply (rule trace_simulation.step)
apply simp
apply (case_tac "ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i)")
apply simp
by fastforce
definition "trace_simulates e1 e2 = (\<exists>f. \<forall>t. trace_simulation f e1 0 <> e2 0 <> t)"
lemma rejects_trace_simulation:
"rejects_trace e2 s2 r2 t \<Longrightarrow>
accepts_trace e1 s1 r1 t \<Longrightarrow>
\<not>trace_simulation f e1 s1 r1 e2 s2 r2 t"
proof(induct t arbitrary: s1 r1 s2 r2)
case Nil
then show ?case
using accepts_trace.base by blast
next
case (Cons a t)
then show ?case
apply (cases a)
apply (simp add: rejects_trace_step)
apply (simp add: accepts_trace_step)
apply clarify
apply (rule trace_simulation.cases)
apply simp
apply simp
apply clarsimp
subgoal for l o _ _ i
apply (case_tac "ffilter (\<lambda>(s1', t1). evaluate_outputs t1 i r1 = map Some o) (possible_steps e1 s1 r1 l i) = {||}")
apply auto[1]
by fastforce
done
qed
lemma accepts_trace_simulation:
"accepts_trace e1 s1 r1 t \<Longrightarrow>
trace_simulation f e1 s1 r1 e2 s2 r2 t \<Longrightarrow>
accepts_trace e2 s2 r2 t"
using rejects_trace_simulation by blast
lemma simulates_trace_subset: "trace_simulates e1 e2 \<Longrightarrow> T e1 \<subseteq> T e2"
using T_def accepts_trace_simulation trace_simulates_def by fastforce
subsubsection\<open>Trace Equivalence\<close>
text\<open>Two EFSMs are trace equivalent if they accept the same traces. This is the intuitive definition
of ``observable equivalence'' between the behaviours of the two models. If two EFSMs are trace
equivalent, there is no trace which can distinguish the two.\<close>
text_raw\<open>\snip{traceEquiv}{1}{2}{%\<close>
definition "trace_equivalent e1 e2 = (T e1 = T e2)"
text_raw\<open>}%endsnip\<close>
text_raw\<open>\snip{simEquiv}{1}{2}{%\<close>
lemma simulation_implies_trace_equivalent:
"trace_simulates e1 e2 \<Longrightarrow> trace_simulates e2 e1 \<Longrightarrow> trace_equivalent e1 e2"
text_raw\<open>}%endsnip\<close>
using simulates_trace_subset trace_equivalent_def by auto
lemma trace_equivalent_reflexive: "trace_equivalent e1 e1"
by (simp add: trace_equivalent_def)
lemma trace_equivalent_symmetric:
"trace_equivalent e1 e2 = trace_equivalent e2 e1"
using trace_equivalent_def by auto
lemma trace_equivalent_transitive:
"trace_equivalent e1 e2 \<Longrightarrow>
trace_equivalent e2 e3 \<Longrightarrow>
trace_equivalent e1 e3"
by (simp add: trace_equivalent_def)
text\<open>Two EFSMs are trace equivalent if they accept the same traces.\<close>
lemma trace_equivalent:
"\<forall>t. accepts_trace e1 0 <> t = accepts_trace e2 0 <> t \<Longrightarrow> trace_equivalent e1 e2"
by (simp add: T_def trace_equivalent_def)
lemma accepts_trace_step_2: "(s2', t2) |\<in>| possible_steps e2 s2 r2 l i \<Longrightarrow>
accepts_trace e2 s2' (evaluate_updates t2 i r2) t \<Longrightarrow>
evaluate_outputs t2 i r2 = map Some p \<Longrightarrow>
accepts_trace e2 s2 r2 ((l, i, p)#t)"
by (rule accepts_trace.step, auto)
subsubsection\<open>Execution Simulation\<close>
text\<open>Execution simulation is similar to trace simulation but for executions rather than traces.
Execution simulation has no notion of ``expected'' output. It simply requires that the simulating
EFSM must be able to produce equivalent output for each action.\<close>
text_raw\<open>\snip{execSim}{1}{2}{%\<close>
inductive execution_simulation :: "(cfstate \<Rightarrow> cfstate) \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow>
registers \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
base: "s2 = f s1 \<Longrightarrow> execution_simulation f e1 s1 r1 e2 s2 r2 []" |
step: "s2 = f s1 \<Longrightarrow>
\<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i).
\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
execution_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
execution_simulation f e1 s1 r1 e2 s2 r2 ((l, i)#es)"
text_raw\<open>}%endsnip\<close>
definition "execution_simulates e1 e2 = (\<exists>f. \<forall>t. execution_simulation f e1 0 <> e2 0 <> t)"
lemma execution_simulation_step:
"execution_simulation f e1 s1 r1 e2 s2 r2 ((l, i)#es) =
(s2 = f s1 \<and>
(\<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i).
(\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
execution_simulation f e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es))
)"
apply standard
apply (rule execution_simulation.cases)
apply simp
apply simp
apply simp
apply (rule execution_simulation.step)
apply simp
by blast
text_raw\<open>\snip{execTraceSim}{1}{2}{%\<close>
lemma execution_simulation_trace_simulation:
"execution_simulation f e1 s1 r1 e2 s2 r2 (map (\<lambda>(l, i, o). (l, i)) t) \<Longrightarrow>
trace_simulation f e1 s1 r1 e2 s2 r2 t"
text_raw\<open>}%endsnip\<close>
proof(induct t arbitrary: s1 s2 r1 r2)
case Nil
then show ?case
apply (rule execution_simulation.cases)
apply (simp add: trace_simulation.base)
by simp
next
case (Cons a t)
then show ?case
apply (cases a, clarsimp)
apply (rule execution_simulation.cases)
apply simp
apply simp
apply (rule trace_simulation.step)
apply simp
apply clarsimp
subgoal for _ _ _ aa ba
apply (erule_tac x="(aa, ba)" in fBallE)
apply clarsimp
apply blast
by simp
done
qed
lemma execution_simulates_trace_simulates:
"execution_simulates e1 e2 \<Longrightarrow> trace_simulates e1 e2"
apply (simp add: execution_simulates_def trace_simulates_def)
using execution_simulation_trace_simulation by blast
subsubsection\<open>Executional Equivalence\<close>
text\<open>Two EFSMs are executionally equivalent if there is no execution which can distinguish between
the two. That is, for every execution, they must produce equivalent outputs.\<close>
text_raw\<open>\snip{execEquiv}{1}{2}{%\<close>
inductive executionally_equivalent :: "transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow>
transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
base [simp]: "executionally_equivalent e1 s1 r1 e2 s2 r2 []" |
step: "\<forall>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i.
\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
\<forall>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i.
\<exists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i.
evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es \<Longrightarrow>
executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
text_raw\<open>}%endsnip\<close>
lemma executionally_equivalent_step:
"executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es) = (
(\<forall>(s1', t1) |\<in>| (possible_steps e1 s1 r1 l i). (\<exists>(s2', t2) |\<in>| possible_steps e2 s2 r2 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es)) \<and>
(\<forall>(s2', t2) |\<in>| (possible_steps e2 s2 r2 l i). (\<exists>(s1', t1) |\<in>| possible_steps e1 s1 r1 l i. evaluate_outputs t1 i r1 = evaluate_outputs t2 i r2 \<and>
executionally_equivalent e1 s1' (evaluate_updates t1 i r1) e2 s2' (evaluate_updates t2 i r2) es)))"
apply standard
apply (rule executionally_equivalent.cases)
apply simp
apply simp
apply simp
by (rule executionally_equivalent.step, auto)
lemma execution_end:
"possible_steps e1 s1 r1 l i = {||} \<Longrightarrow>
possible_steps e2 s2 r2 l i = {||} \<Longrightarrow>
executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
by (simp add: executionally_equivalent_step)
lemma possible_steps_disparity:
"possible_steps e1 s1 r1 l i \<noteq> {||} \<Longrightarrow>
possible_steps e2 s2 r2 l i = {||} \<Longrightarrow>
\<not>executionally_equivalent e1 s1 r1 e2 s2 r2 ((l, i)#es)"
by (simp add: executionally_equivalent_step, auto)
lemma executionally_equivalent_acceptance_map:
"executionally_equivalent e1 s1 r1 e2 s2 r2 (map (\<lambda>(l, i, o). (l, i)) t) \<Longrightarrow>
accepts_trace e2 s2 r2 t = accepts_trace e1 s1 r1 t"
proof(induct t arbitrary: s1 s2 r1 r2)
case (Cons a t)
then show ?case
apply (cases a, simp)
apply (rule executionally_equivalent.cases)
apply simp
apply simp
apply clarsimp
apply standard
subgoal for i p l
apply (rule accepts_trace.cases)
apply simp
apply simp
apply clarsimp
subgoal for aa b
apply (rule accepts_trace.step)
apply (erule_tac x="(aa, b)" in fBallE[of "possible_steps e2 s2 r2 l i"])
defer apply simp
apply simp
by blast
done
apply (rule accepts_trace.cases)
apply simp
apply simp
apply clarsimp
subgoal for _ _ _ aa b
apply (rule accepts_trace.step)
apply (erule_tac x="(aa, b)" in fBallE)
defer apply simp
apply simp
by fastforce
done
qed auto
lemma executionally_equivalent_acceptance:
"\<forall>x. executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow> accepts_trace e1 s1 r1 t \<Longrightarrow> accepts_trace e2 s2 r2 t"
using executionally_equivalent_acceptance_map by blast
lemma executionally_equivalent_trace_equivalent:
"\<forall>x. executionally_equivalent e1 0 <> e2 0 <> x \<Longrightarrow> trace_equivalent e1 e2"
apply (rule trace_equivalent)
apply clarify
subgoal for t apply (erule_tac x="map (\<lambda>(l, i, o). (l, i)) t" in allE)
by (simp add: executionally_equivalent_acceptance_map)
done
lemma executionally_equivalent_symmetry:
"executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow>
executionally_equivalent e2 s2 r2 e1 s1 r1 x"
proof(induct x arbitrary: s1 s2 r1 r2)
case (Cons a x)
then show ?case
apply (cases a, clarsimp)
apply (simp add: executionally_equivalent_step)
apply standard
apply (rule fBallI)
apply clarsimp
subgoal for aa b aaa ba
apply (erule_tac x="(aaa, ba)" in fBallE[of "possible_steps e2 s2 r2 aa b"])
by (force, simp)
apply (rule fBallI)
apply clarsimp
subgoal for aa b aaa ba
apply (erule_tac x="(aaa, ba)" in fBallE)
by (force, simp)
done
qed auto
lemma executionally_equivalent_transitivity:
"executionally_equivalent e1 s1 r1 e2 s2 r2 x \<Longrightarrow>
executionally_equivalent e2 s2 r2 e3 s3 r3 x \<Longrightarrow>
executionally_equivalent e1 s1 r1 e3 s3 r3 x"
proof(induct x arbitrary: s1 s2 s3 r1 r2 r3)
case (Cons a x)
then show ?case
apply (cases a, clarsimp)
apply (simp add: executionally_equivalent_step)
apply clarsimp
apply standard
apply (rule fBallI)
apply clarsimp
subgoal for aa b ab ba
apply (erule_tac x="(ab, ba)" in fBallE[of "possible_steps e1 s1 r1 aa b"])
prefer 2 apply simp
apply simp
apply (erule fBexE)
subgoal for x apply (case_tac x)
apply simp
by blast
done
apply (rule fBallI)
apply clarsimp
subgoal for aa b ab ba
apply (erule_tac x="(ab, ba)" in fBallE[of "possible_steps e3 s3 r3 aa b"])
prefer 2 apply simp
apply simp
apply (erule fBexE)
subgoal for x apply (case_tac x)
apply clarsimp
subgoal for aaa baa
apply (erule_tac x="(aaa, baa)" in fBallE[of "possible_steps e2 s2 r2 aa b"])
prefer 2 apply simp
apply simp
by blast
done
done
done
qed auto
subsection\<open>Reachability\<close>
text\<open>Here, we define the function \texttt{visits} which returns true if the given execution
leaves the given EFSM in the given state.\<close>
text_raw\<open>\snip{reachable}{1}{2}{%\<close>
inductive visits :: "cfstate \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
base [simp]: "visits s e s r []" |
step: "\<exists>(s', T) |\<in>| possible_steps e s r l i. visits target e s' (evaluate_updates T i r) t \<Longrightarrow>
visits target e s r ((l, i)#t)"
definition "reachable s e = (\<exists>t. visits s e 0 <> t)"
text_raw\<open>}%endsnip\<close>
lemma no_further_steps:
"s \<noteq> s' \<Longrightarrow> \<not> visits s e s' r []"
apply safe
apply (rule visits.cases)
by auto
lemma visits_base: "visits target e s r [] = (s = target)"
by (metis visits.base no_further_steps)
lemma visits_step:
"visits target e s r (h#t) = (\<exists>(s', T) |\<in>| possible_steps e s r (fst h) (snd h). visits target e s' (evaluate_updates T (snd h) r) t)"
apply standard
apply (rule visits.cases)
apply simp+
apply (cases h)
using visits.step by auto
lemma reachable_initial: "reachable 0 e"
apply (simp add: reachable_def)
apply (rule_tac x="[]" in exI)
by simp
lemma visits_finsert:
"visits s e s' r t \<Longrightarrow> visits s (finsert ((aa, ba), b) e) s' r t"
proof(induct t arbitrary: s' r)
case Nil
then show ?case
by (simp add: visits_base)
next
case (Cons a t)
then show ?case
apply (simp add: visits_step)
apply (erule fBexE)
apply (rule_tac x=x in fBexI)
apply auto[1]
by (simp add: possible_steps_finsert)
qed
lemma reachable_finsert:
"reachable s e \<Longrightarrow> reachable s (finsert ((aa, ba), b) e)"
apply (simp add: reachable_def)
by (meson visits_finsert)
lemma reachable_finsert_contra:
"\<not> reachable s (finsert ((aa, ba), b) e) \<Longrightarrow> \<not>reachable s e"
using reachable_finsert by blast
lemma visits_empty: "visits s e s' r [] = (s = s')"
apply standard
by (rule visits.cases, auto)
definition "remove_state s e = ffilter (\<lambda>((from, to), t). from \<noteq> s \<and> to \<noteq> s) e"
text_raw\<open>\snip{obtainable}{1}{2}{%\<close>
inductive "obtains" :: "cfstate \<Rightarrow> registers \<Rightarrow> transition_matrix \<Rightarrow> cfstate \<Rightarrow> registers \<Rightarrow> execution \<Rightarrow> bool" where
base [simp]: "obtains s r e s r []" |
step: "\<exists>(s'', T) |\<in>| possible_steps e s' r' l i. obtains s r e s'' (evaluate_updates T i r') t \<Longrightarrow>
obtains s r e s' r' ((l, i)#t)"
definition "obtainable s r e = (\<exists>t. obtains s r e 0 <> t)"
text_raw\<open>}%endsnip\<close>
lemma obtains_obtainable:
"obtains s r e 0 <> t \<Longrightarrow> obtainable s r e"
apply (simp add: obtainable_def)
by auto
lemma obtains_base: "obtains s r e s' r' [] = (s = s' \<and> r = r')"
apply standard
by (rule obtains.cases, auto)
lemma obtains_step: "obtains s r e s' r' ((l, i)#t) = (\<exists>(s'', T) |\<in>| possible_steps e s' r' l i. obtains s r e s'' (evaluate_updates T i r') t)"
apply standard
by (rule obtains.cases, auto simp add: obtains.step)
lemma obtains_recognises:
"obtains s c e s' r t \<Longrightarrow> recognises_execution e s' r t"
proof(induct t arbitrary: s' r)
case Nil
then show ?case
by (simp add: obtains_base)
next
case (Cons a t)
then show ?case
apply (cases a)
apply simp
apply (rule obtains.cases)
apply simp
apply simp
apply clarsimp
using recognises_execution.step by fastforce
qed
lemma ex_comm4:
"(\<exists>c1 s a b. (a, b) \<in> fset (possible_steps e s' r l i) \<and> obtains s c1 e a (evaluate_updates b i r) t) =
(\<exists>a b s c1. (a, b) \<in> fset (possible_steps e s' r l i) \<and> obtains s c1 e a (evaluate_updates b i r) t)"
by auto
lemma recognises_execution_obtains:
"recognises_execution e s' r t \<Longrightarrow> \<exists>c1 s. obtains s c1 e s' r t"
proof(induct t arbitrary: s' r)
case Nil
then show ?case
by (simp add: obtains_base)
next
case (Cons a t)
then show ?case
apply (cases a)
apply (simp add: obtains_step)
apply (rule recognises_execution.cases)
apply simp
apply simp
apply clarsimp
apply (simp add: fBex_def Bex_def ex_comm4)
subgoal for _ _ aa ba
apply (rule_tac x=aa in exI)
apply (rule_tac x=ba in exI)
apply (simp add: fmember_implies_member)
by blast
done
qed
lemma obtainable_empty_efsm:
"obtainable s c {||} = (s=0 \<and> c = <>)"
apply (simp add: obtainable_def)
apply standard
apply (metis ffilter_empty no_outgoing_transitions no_step_none obtains.cases obtains_recognises step_None)
using obtains_base by blast
lemma obtains_visits: "obtains s r e s' r' t \<Longrightarrow> visits s e s' r' t"
proof(induct t arbitrary: s' r')
case Nil
then show ?case
by (simp add: obtains_base)
next
case (Cons a t)
then show ?case
apply (cases a)
apply (rule obtains.cases)
apply simp
apply simp
apply clarsimp
apply (rule visits.step)
by auto
qed
lemma unobtainable_if: "\<not> visits s e s' r' t \<Longrightarrow> \<not> obtains s r e s' r' t"
using obtains_visits by blast
lemma obtainable_if_unreachable: "\<not>reachable s e \<Longrightarrow> \<not>obtainable s r e"
by (simp add: reachable_def obtainable_def unobtainable_if)
lemma obtains_step_append:
"obtains s r e s' r' t \<Longrightarrow>
(s'', ta) |\<in>| possible_steps e s r l i \<Longrightarrow>
obtains s'' (evaluate_updates ta i r) e s' r' (t @ [(l, i)])"
proof(induct t arbitrary: s' r')
case Nil
then show ?case
apply (simp add: obtains_base)
apply (rule obtains.step)
apply (rule_tac x="(s'', ta)" in fBexI)
by auto
next
case (Cons a t)
then show ?case
apply simp
apply (rule obtains.cases)
apply simp
apply simp
apply clarsimp
apply (rule obtains.step)
by auto
qed
lemma reachable_if_obtainable_step:
"obtainable s r e \<Longrightarrow> \<exists>l i t. (s', t) |\<in>| possible_steps e s r l i \<Longrightarrow> reachable s' e"
apply (simp add: reachable_def obtainable_def)
apply clarify
subgoal for t l i
apply (rule_tac x="t@[(l, i)]" in exI)
using obtains_step_append unobtainable_if by blast
done
lemma possible_steps_remove_unreachable:
"obtainable s r e \<Longrightarrow>
\<not> reachable s' e \<Longrightarrow>
possible_steps (remove_state s' e) s r l i = possible_steps e s r l i"
apply standard
apply (simp add: fsubset_eq)
apply (rule fBallI)
apply clarsimp
apply (metis ffmember_filter in_possible_steps remove_state_def)
apply (simp add: fsubset_eq)
apply (rule fBallI)
apply clarsimp
subgoal for a b
apply (case_tac "a = s'")
using reachable_if_obtainable_step apply blast
apply (simp add: remove_state_def)
by (metis (mono_tags, lifting) ffmember_filter in_possible_steps obtainable_if_unreachable old.prod.case)
done
text_raw\<open>\snip{removeUnreachableArb}{1}{2}{%\<close>
lemma executionally_equivalent_remove_unreachable_state_arbitrary:
"obtainable s r e \<Longrightarrow> \<not> reachable s' e \<Longrightarrow> executionally_equivalent e s r (remove_state s' e) s r x"
text_raw\<open>}%endsnip\<close>
proof(induct x arbitrary: s r)
case (Cons a x)
then show ?case
apply (cases a, simp)
apply (rule executionally_equivalent.step)
apply (simp add: possible_steps_remove_unreachable)
apply standard
apply clarsimp
subgoal for aa b ab ba
apply (rule_tac x="(ab, ba)" in fBexI)
apply (metis (mono_tags, lifting) obtainable_def obtains_step_append case_prodI)
apply simp
done
apply (rule fBallI)
apply clarsimp
apply (rule_tac x="(ab, ba)" in fBexI)
apply simp
apply (metis obtainable_def obtains_step_append possible_steps_remove_unreachable)
by (simp add: possible_steps_remove_unreachable)
qed auto
text_raw\<open>\snip{removeUnreachable}{1}{2}{%\<close>
lemma executionally_equivalent_remove_unreachable_state:
"\<not> reachable s' e \<Longrightarrow> executionally_equivalent e 0 <> (remove_state s' e) 0 <> x"
text_raw\<open>}%endsnip\<close>
by (meson executionally_equivalent_remove_unreachable_state_arbitrary
obtains.simps obtains_obtainable)
subsection\<open>Transition Replacement\<close>
text\<open>Here, we define the function \texttt{replace} to replace one transition with another, and prove
some of its properties.\<close>
definition "replace e1 old new = fimage (\<lambda>x. if x = old then new else x) e1"
lemma replace_finsert:
"replace (finsert ((aaa, baa), b) e1) old new = (if ((aaa, baa), b) = old then (finsert new (replace e1 old new)) else (finsert ((aaa, baa), b) (replace e1 old new)))"
by (simp add: replace_def)
lemma possible_steps_replace_unchanged:
"((s, aa), ba) \<noteq> ((s1, s2), t1) \<Longrightarrow>
(aa, ba) |\<in>| possible_steps e1 s r l i \<Longrightarrow>
(aa, ba) |\<in>| possible_steps (replace e1 ((s1, s2), t1) ((s1, s2), t2)) s r l i"
apply (simp add: in_possible_steps[symmetric] replace_def)
by fastforce
end
diff --git a/thys/Extended_Finite_State_Machines/FSet_Utils.thy b/thys/Extended_Finite_State_Machines/FSet_Utils.thy
--- a/thys/Extended_Finite_State_Machines/FSet_Utils.thy
+++ b/thys/Extended_Finite_State_Machines/FSet_Utils.thy
@@ -1,341 +1,341 @@
section\<open>FSet Utilities\<close>
text\<open>This theory provides various additional lemmas, definitions, and syntax over the fset data type.\<close>
theory FSet_Utils
imports "HOL-Library.FSet"
begin
notation (latex output)
"FSet.fempty" ("\<emptyset>") and
"FSet.fmember" ("\<in>")
syntax (ASCII)
"_fBall" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3ALL (_/:_)./ _)" [0, 0, 10] 10)
"_fBex" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3EX (_/:_)./ _)" [0, 0, 10] 10)
"_fBex1" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3EX! (_/:_)./ _)" [0, 0, 10] 10)
syntax (input)
"_fBall" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3! (_/:_)./ _)" [0, 0, 10] 10)
"_fBex" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3? (_/:_)./ _)" [0, 0, 10] 10)
"_fBex1" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3?! (_/:_)./ _)" [0, 0, 10] 10)
syntax
"_fBall" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
"_fBex" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
"_fBnex" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3\<nexists>(_/|\<in>|_)./ _)" [0, 0, 10] 10)
"_fBex1" :: "pttrn \<Rightarrow> 'a fset \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>!(_/|\<in>|_)./ _)" [0, 0, 10] 10)
translations
"\<forall>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. P)"
"\<exists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBex A (\<lambda>x. P)"
"\<nexists>x|\<in>|A. P" \<rightleftharpoons> "CONST fBall A (\<lambda>x. \<not>P)"
"\<exists>!x|\<in>|A. P" \<rightharpoonup> "\<exists>!x. x |\<in>| A \<and> P"
lemma fset_of_list_remdups [simp]: "fset_of_list (remdups l) = fset_of_list l"
apply (induct l)
apply simp
by (simp add: finsert_absorb fset_of_list_elem)
definition "fSum \<equiv> fsum (\<lambda>x. x)"
lemma fset_both_sides: "(Abs_fset s = f) = (fset (Abs_fset s) = fset f)"
by (simp add: fset_inject)
lemma Abs_ffilter: "(ffilter f s = s') = ({e \<in> (fset s). f e} = (fset s'))"
by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)
lemma size_ffilter_card: "size (ffilter f s) = card ({e \<in> (fset s). f e})"
by (simp add: ffilter_def fset_both_sides Abs_fset_inverse Set.filter_def)
lemma ffilter_empty [simp]: "ffilter f {||} = {||}"
by auto
lemma ffilter_finsert:
"ffilter f (finsert a s) = (if f a then finsert a (ffilter f s) else (ffilter f s))"
apply simp
apply standard
apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
apply auto[1]
apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
by auto
lemma fset_equiv: "(f1 = f2) = (fset f1 = fset f2)"
by (simp add: fset_inject)
lemma finsert_equiv: "(finsert e f = f') = (insert e (fset f) = (fset f'))"
by (simp add: finsert_def fset_both_sides Abs_fset_inverse)
lemma filter_elements:
"x |\<in>| Abs_fset (Set.filter f (fset s)) = (x \<in> (Set.filter f (fset s)))"
by (metis ffilter.rep_eq fset_inverse notin_fset)
lemma sorted_list_of_fempty [simp]: "sorted_list_of_fset {||} = []"
by (simp add: sorted_list_of_fset_def)
lemma fmember_implies_member: "e |\<in>| f \<Longrightarrow> e \<in> fset f"
by (simp add: fmember_def)
lemma fold_union_ffUnion: "fold (|\<union>|) l {||} = ffUnion (fset_of_list l)"
by(induct l rule: rev_induct, auto)
lemma filter_filter:
"ffilter P (ffilter Q xs) = ffilter (\<lambda>x. Q x \<and> P x) xs"
by auto
lemma fsubset_strict:
"x2 |\<subset>| x1 \<Longrightarrow> \<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
by auto
lemma fsubset:
"x2 |\<subset>| x1 \<Longrightarrow> \<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
by auto
lemma size_fsubset_elem:
assumes "\<exists>e. e |\<in>| x1 \<and> e |\<notin>| x2"
and "\<nexists>e. e |\<in>| x2 \<and> e |\<notin>| x1"
shows "size x2 < size x1"
using assms
apply (simp add: fmember_def)
by (metis card_seteq finite_fset linorder_not_le subsetI)
lemma size_fsubset: "x2 |\<subset>| x1 \<Longrightarrow> size x2 < size x1"
by (metis fsubset fsubset_strict size_fsubset_elem)
definition fremove :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset"
where [code_abbrev]: "fremove x A = A - {|x|}"
lemma arg_cong_ffilter:
"\<forall>e |\<in>| f. p e = p' e \<Longrightarrow> ffilter p f = ffilter p' f"
by auto
lemma ffilter_singleton: "f e \<Longrightarrow> ffilter f {|e|} = {|e|}"
apply (simp add: ffilter_def fset_both_sides Abs_fset_inverse)
by auto
lemma fset_eq_alt: "(x = y) = (x |\<subseteq>| y \<and> size x = size y)"
by (metis exists_least_iff le_less size_fsubset)
lemma ffold_empty [simp]: "ffold f b {||} = b"
by (simp add: ffold_def)
lemma sorted_list_of_fset_sort:
"sorted_list_of_fset (fset_of_list l) = sort (remdups l)"
by (simp add: fset_of_list.rep_eq sorted_list_of_fset.rep_eq sorted_list_of_set_sort_remdups)
lemma fMin_Min: "fMin (fset_of_list l) = Min (set l)"
by (simp add: fMin.F.rep_eq fset_of_list.rep_eq)
lemma sorted_hd_Min:
"sorted l \<Longrightarrow>
l \<noteq> [] \<Longrightarrow>
hd l = Min (set l)"
by (metis List.finite_set Min_eqI eq_iff hd_Cons_tl insertE list.set_sel(1) list.simps(15) sorted_simps(2))
lemma hd_sort_Min: "l \<noteq> [] \<Longrightarrow> hd (sort l) = Min (set l)"
by (metis sorted_hd_Min set_empty set_sort sorted_sort)
lemma hd_sort_remdups: "hd (sort (remdups l)) = hd (sort l)"
by (metis hd_sort_Min remdups_eq_nil_iff set_remdups)
lemma exists_fset_of_list: "\<exists>l. f = fset_of_list l"
using exists_fset_of_list by fastforce
lemma hd_sorted_list_of_fset:
"s \<noteq> {||} \<Longrightarrow> hd (sorted_list_of_fset s) = (fMin s)"
apply (insert exists_fset_of_list[of s])
apply (erule exE)
apply simp
apply (simp add: sorted_list_of_fset_sort fMin_Min hd_sort_remdups)
by (metis fset_of_list_simps(1) hd_sort_Min)
lemma fminus_filter_singleton:
"fset_of_list l |-| {|x|} = fset_of_list (filter (\<lambda>e. e \<noteq> x) l)"
by auto
lemma card_minus_fMin:
"s \<noteq> {||} \<Longrightarrow> card (fset s - {fMin s}) < card (fset s)"
by (metis Min_in bot_fset.rep_eq card_Diff1_less fMin.F.rep_eq finite_fset fset_equiv)
(* Provides a deterministic way to fold fsets similar to List.fold that works with the code generator *)
function ffold_ord :: "(('a::linorder) \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b \<Rightarrow> 'b" where
"ffold_ord f s b = (
if s = {||} then
b
else
let
h = fMin s;
t = s - {|h|}
in
ffold_ord f t (f h b)
)"
by auto
termination
apply (relation "measures [\<lambda>(a, s, ab). size s]")
apply simp
by (simp add: card_minus_fMin)
lemma sorted_list_of_fset_Cons:
"\<exists>h t. (sorted_list_of_fset (finsert s ss)) = h#t"
apply (simp add: sorted_list_of_fset_def)
by (cases "insort s (sorted_list_of_set (fset ss - {s}))", auto)
lemma list_eq_hd_tl:
"l \<noteq> [] \<Longrightarrow>
hd l = h \<Longrightarrow>
tl l = t \<Longrightarrow>
l = (h#t)"
by auto
lemma fset_of_list_sort: "fset_of_list l = fset_of_list (sort l)"
by (simp add: fset_of_list.abs_eq)
lemma exists_sorted_distinct_fset_of_list:
"\<exists>l. sorted l \<and> distinct l \<and> f = fset_of_list l"
by (metis distinct_sorted_list_of_set sorted_list_of_fset.rep_eq sorted_list_of_fset_simps(2) sorted_sorted_list_of_set)
lemma fset_of_list_empty [simp]: "(fset_of_list l = {||}) = (l = [])"
by (metis fset_of_list.rep_eq fset_of_list_simps(1) set_empty)
lemma ffold_ord_cons: assumes sorted: "sorted (h#t)"
and distinct: "distinct (h#t)"
shows "ffold_ord f (fset_of_list (h#t)) b = ffold_ord f (fset_of_list t) (f h b)"
proof-
have h_is_min: "h = fMin (fset_of_list (h#t))"
by (metis sorted fMin_Min list.sel(1) list.simps(3) sorted_hd_Min)
have remove_min: "fset_of_list t = (fset_of_list (h#t)) - {|h|}"
using distinct fset_of_list_elem by force
show ?thesis
apply (simp only: ffold_ord.simps[of f "fset_of_list (h#t)"])
by (metis h_is_min remove_min fset_of_list_empty list.distinct(1))
qed
lemma sorted_distinct_ffold_ord: assumes "sorted l"
and "distinct l"
shows "ffold_ord f (fset_of_list l) b = fold f l b"
using assms
apply (induct l arbitrary: b)
apply simp
by (metis distinct.simps(2) ffold_ord_cons fold_simps(2) sorted_simps(2))
lemma ffold_ord_fold_sorted: "ffold_ord f s b = fold f (sorted_list_of_fset s) b"
by (metis exists_sorted_distinct_fset_of_list sorted_distinct_ffold_ord distinct_remdups_id sorted_list_of_fset_sort sorted_sort_id)
context includes fset.lifting begin
lift_definition fprod :: "'a fset \<Rightarrow> 'b fset \<Rightarrow> ('a \<times> 'b) fset " (infixr "|\<times>|" 80) is "\<lambda>a b. fset a \<times> fset b"
by simp
lift_definition fis_singleton :: "'a fset \<Rightarrow> bool" is "\<lambda>A. is_singleton (fset A)".
end
lemma fprod_empty_l: "{||} |\<times>| a = {||}"
using bot_fset_def fprod.abs_eq by force
lemma fprod_empty_r: "a |\<times>| {||} = {||}"
by (simp add: fprod_def bot_fset_def Abs_fset_inverse)
lemmas fprod_empty = fprod_empty_l fprod_empty_r
lemma fprod_finsert: "(finsert a as) |\<times>| (finsert b bs) =
finsert (a, b) (fimage (\<lambda>b. (a, b)) bs |\<union>| fimage (\<lambda>a. (a, b)) as |\<union>| (as |\<times>| bs))"
apply (simp add: fprod_def fset_both_sides Abs_fset_inverse)
by auto
lemma fprod_member:
"x |\<in>| xs \<Longrightarrow>
y |\<in>| ys \<Longrightarrow>
(x, y) |\<in>| xs |\<times>| ys"
by (simp add: fmember_def fprod_def Abs_fset_inverse)
lemma fprod_subseteq:
"x |\<subseteq>| x' \<and> y |\<subseteq>| y' \<Longrightarrow> x |\<times>| y |\<subseteq>| x' |\<times>| y'"
apply (simp add: fprod_def less_eq_fset_def Abs_fset_inverse)
by auto
lemma fimage_fprod:
"(a, b) |\<in>| A |\<times>| B \<Longrightarrow> f a b |\<in>| (\<lambda>(x, y). f x y) |`| (A |\<times>| B)"
by force
lemma fprod_singletons: "{|a|} |\<times>| {|b|} = {|(a, b)|}"
apply (simp add: fprod_def)
by (metis fset_inverse fset_simps(1) fset_simps(2))
lemma fprod_equiv:
"(fset (f |\<times>| f') = s) = (((fset f) \<times> (fset f')) = s)"
by (simp add: fprod_def Abs_fset_inverse)
lemma fis_singleton_alt: "fis_singleton f = (\<exists>e. f = {|e|})"
by (metis fis_singleton.rep_eq fset_inverse fset_simps(1) fset_simps(2) is_singleton_def)
lemma singleton_singleton [simp]: "fis_singleton {|a|}"
by (simp add: fis_singleton_def)
lemma not_singleton_empty [simp]: "\<not> fis_singleton {||}"
apply (simp add: fis_singleton_def)
by (simp add: is_singleton_altdef)
lemma fis_singleton_fthe_elem:
"fis_singleton A \<longleftrightarrow> A = {|fthe_elem A|}"
by (metis fis_singleton_alt fthe_felem_eq)
lemma fBall_ffilter:
"\<forall>x |\<in>| X. f x \<Longrightarrow> ffilter f X = X"
by auto
lemma fBall_ffilter2:
"X = Y \<Longrightarrow>
\<forall>x |\<in>| X. f x \<Longrightarrow>
ffilter f X = Y"
by auto
lemma size_fset_of_list: "size (fset_of_list l) = length (remdups l)"
apply (induct l)
apply simp
by (simp add: fset_of_list.rep_eq insert_absorb)
lemma size_fsingleton: "(size f = 1) = (\<exists>e. f = {|e|})"
apply (insert exists_fset_of_list[of f])
apply clarify
apply (simp only: size_fset_of_list)
apply (simp add: fset_of_list_def fset_both_sides Abs_fset_inverse)
by (metis List.card_set One_nat_def card.insert card_1_singletonE card.empty empty_iff finite.intros(1))
lemma ffilter_mono: "(ffilter X xs = f) \<Longrightarrow> \<forall>x |\<in>| xs. X x = Y x \<Longrightarrow> (ffilter Y xs = f)"
by auto
lemma size_fimage: "size (fimage f s) \<le> size s"
apply (induct s)
apply simp
by (simp add: card_insert_if)
lemma size_ffilter: "size (ffilter P f) \<le> size f"
apply (induct f)
apply simp
apply (simp only: ffilter_finsert)
apply (case_tac "P x")
- apply (simp add: fmember.rep_eq)
+ apply (simp add: fmember_iff_member_fset)
by (simp add: card_insert_if)
lemma fimage_size_le: "\<And>f s. size s \<le> n \<Longrightarrow> size (fimage f s) \<le> n"
using le_trans size_fimage by blast
lemma ffilter_size_le: "\<And>f s. size s \<le> n \<Longrightarrow> size (ffilter f s) \<le> n"
using dual_order.trans size_ffilter by blast
lemma set_membership_eq: "A = B \<longleftrightarrow> (\<lambda>x. Set.member x A) = (\<lambda>x. Set.member x B)"
apply standard
apply simp
by (meson equalityI subsetI)
lemmas ffilter_eq_iff = Abs_ffilter set_membership_eq fun_eq_iff
lemma size_le_1: "size f \<le> 1 = (f = {||} \<or> (\<exists>e. f = {|e|}))"
apply standard
apply (metis bot.not_eq_extremum gr_implies_not0 le_neq_implies_less less_one size_fsingleton size_fsubset)
by auto
lemma size_gt_1: "1 < size f \<Longrightarrow> \<exists>e1 e2 f'. e1 \<noteq> e2 \<and> f = finsert e1 (finsert e2 f')"
apply (induct f)
apply simp
apply (rule_tac x=x in exI)
by (metis finsertCI leD not_le_imp_less size_le_1)
end
diff --git a/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy b/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy
--- a/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy
+++ b/thys/FO_Theory_Rewriting/Closure/TA_Clousure_Const.thy
@@ -1,1019 +1,1019 @@
section \<open>(Multihole)Context closure of recognized tree languages\<close>
theory TA_Clousure_Const
imports Tree_Automata_Derivation_Split
begin
subsection \<open>Tree Automata closure constructions\<close>
declare ta_union_def [simp]
subsubsection \<open>Reflexive closure over a given signature\<close>
definition "reflcl_rules \<F> q \<equiv> (\<lambda> (f, n). TA_rule f (replicate n q) q) |`| \<F>"
definition "refl_ta \<F> q = TA (reflcl_rules \<F> q) {||}"
definition gen_reflcl_automaton :: "('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
"gen_reflcl_automaton \<F> \<A> q = ta_union \<A> (refl_ta \<F> q)"
definition "reflcl_automaton \<F> \<A> = (let \<B> = fmap_states_ta Some \<A> in
gen_reflcl_automaton \<F> \<B> None)"
definition "reflcl_reg \<F> \<A> = Reg (finsert None (Some |`| fin \<A>)) (reflcl_automaton \<F> (ta \<A>))"
subsubsection \<open>Multihole context closure over a given signature\<close>
definition "refl_over_states_ta Q \<F> \<A> q = TA (reflcl_rules \<F> q) ((\<lambda> p. (p, q)) |`| (Q |\<inter>| \<Q> \<A>))"
definition gen_parallel_closure_automaton :: "'q fset \<Rightarrow> ('f \<times> nat) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q \<Rightarrow> ('q, 'f) ta" where
"gen_parallel_closure_automaton Q \<F> \<A> q = ta_union \<A> (refl_over_states_ta Q \<F> \<A> q)"
definition parallel_closure_reg where
"parallel_closure_reg \<F> \<A> = (let \<B> = fmap_states_reg Some \<A> in
Reg {|None|} (gen_parallel_closure_automaton (fin \<B>) \<F> (ta \<B>) None))"
subsubsection \<open>Context closure of regular tree language\<close>
definition "semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
|\<Union>| ((\<lambda> (f, n). fset_of_list (map (\<lambda> i. TA_rule f ((replicate n q\<^sub>c)[i := q\<^sub>i]) q\<^sub>f) [0..< n])) |`| \<F>)"
definition "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f \<equiv>
TA (reflcl_rules \<F> q\<^sub>c |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>f)) |`| Q)"
definition "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f = ta_union \<A> (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
definition "gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f =
Reg {|q\<^sub>f|} (gen_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>f)"
definition "ctxt_closure_reg \<F> \<A> =
(let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
gen_ctxt_closure_reg \<F> \<B> (Inr False) (Inr True))"
subsubsection \<open>Not empty context closure of regular tree language\<close>
datatype cl_states = cl_state | tr_state | fin_state | fin_clstate
definition "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
TA (reflcl_rules \<F> q\<^sub>c |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f |\<union>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f) ((\<lambda> p. (p, q\<^sub>i)) |`| Q)"
definition "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
ta_union \<A> (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
definition "gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
Reg {|q\<^sub>f|} (gen_nhole_ctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
definition "nhole_ctxt_closure_reg \<F> \<A> =
(let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
(gen_nhole_ctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
subsubsection \<open>Non empty multihole context closure of regular tree language\<close>
abbreviation "add_eps \<A> e \<equiv> TA (rules \<A>) (eps \<A> |\<union>| e)"
definition "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<equiv>
add_eps (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) {|(q\<^sub>i, q\<^sub>c)|}"
definition "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
ta_union \<A> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
definition "gen_nhole_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
Reg {|q\<^sub>f|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
definition "nhole_mctxt_closure_reg \<F> \<A> =
(let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
(gen_nhole_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
subsubsection \<open>Not empty multihole context closure of regular tree language\<close>
definition "gen_mctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f =
Reg {|q\<^sub>f, q\<^sub>i|} (gen_nhole_mctxt_closure_automaton (fin \<A>) \<F> (ta \<A>) q\<^sub>c q\<^sub>i q\<^sub>f)"
definition "mctxt_closure_reg \<F> \<A> =
(let \<B> = fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>) in
(gen_mctxt_closure_reg \<F> \<B> (Inr cl_state) (Inr tr_state) (Inr fin_state)))"
subsubsection \<open>Multihole context closure of regular tree language\<close>
definition "nhole_mctxt_reflcl_reg \<F> \<A> =
reg_union (nhole_mctxt_closure_reg \<F> \<A>) (Reg {|fin_clstate|} (refl_ta \<F> (fin_clstate)))"
subsubsection \<open>Lemmas about @{const ta_der'}\<close>
lemma ta_det'_ground_id:
"t |\<in>| ta_der' \<A> s \<Longrightarrow> ground t \<Longrightarrow> t = s"
by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)
lemma ta_det'_vars_term_id:
"t |\<in>| ta_der' \<A> s \<Longrightarrow> vars_term t \<inter> fset (\<Q> \<A>) = {} \<Longrightarrow> t = s"
proof (induct s arbitrary: t)
case (Fun f ss)
from Fun(2-) obtain ts where [simp]: "t = Fun f ts" and len: "length ts = length ss"
- by (cases t) (auto simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)
+ by (cases t) (auto simp flip: fmember_iff_member_fset dest: rule_statesD eps_dest_all)
from Fun(1)[OF nth_mem, of i "ts ! i" for i] show ?case using Fun(2-) len
- by (auto simp add: ta_der'.simps Union_disjoint simp flip: fmember.rep_eq
+ by (auto simp add: ta_der'.simps Union_disjoint simp flip: fmember_iff_member_fset
dest: rule_statesD eps_dest_all intro!: nth_equalityI)
-qed (auto simp add: ta_der'.simps simp flip: fmember.rep_eq dest: rule_statesD eps_dest_all)
+qed (auto simp add: ta_der'.simps simp flip: fmember_iff_member_fset dest: rule_statesD eps_dest_all)
lemma fresh_states_ta_der'_pres:
assumes st: "q \<in> vars_term s" "q |\<notin>| \<Q> \<A>"
and reach: "t |\<in>| ta_der' \<A> s"
shows "q \<in> vars_term t" using reach st(1)
proof (induct s arbitrary: t)
case (Var x)
then show ?case using assms(2)
by (cases t) (auto simp: ta_der'.simps dest: eps_trancl_statesD)
next
case (Fun f ss)
from Fun(3) obtain i where w: "i < length ss" "q \<in> vars_term (ss ! i)" by (auto simp: in_set_conv_nth)
have "i < length (args t) \<and> q \<in> vars_term (args t ! i)" using Fun(2) w assms(2) Fun(1)[OF nth_mem[OF w(1)] _ w(2)]
using rule_statesD(3) ta_der_to_ta_der'
by (auto simp: ta_der'.simps dest: rule_statesD(3)) fastforce+
then show ?case by (cases t) auto
qed
lemma ta_der'_states:
"t |\<in>| ta_der' \<A> s \<Longrightarrow> vars_term t \<subseteq> vars_term s \<union> fset (\<Q> \<A>)"
proof (induct s arbitrary: t)
case (Var x) then show ?case
- by (auto simp: ta_der'.simps simp flip: fmember.rep_eq dest: eps_dest_all)
+ by (auto simp: ta_der'.simps simp flip: fmember_iff_member_fset dest: eps_dest_all)
next
case (Fun f ts) then show ?case
- by (auto simp: ta_der'.simps rule_statesD simp flip: fmember.rep_eq dest: eps_dest_all)
+ by (auto simp: ta_der'.simps rule_statesD simp flip: fmember_iff_member_fset dest: eps_dest_all)
(metis (no_types, opaque_lifting) Un_iff in_set_conv_nth notin_fset subsetD)
qed
lemma ta_der'_gterm_states:
"t |\<in>| ta_der' \<A> (term_of_gterm s) \<Longrightarrow> vars_term t \<subseteq> fset (\<Q> \<A>)"
using ta_der'_states[of t \<A> "term_of_gterm s"]
by auto
lemma ta_der'_Var_funas:
"Var q |\<in>| ta_der' \<A> s \<Longrightarrow> funas_term s \<subseteq> fset (ta_sig \<A>)"
by (auto simp: less_eq_fset.rep_eq ffunas_term.rep_eq dest!: ta_der_term_sig ta_der'_to_ta_der)
lemma ta_sig_fsubsetI:
assumes "\<And> r. r |\<in>| rules \<A> \<Longrightarrow> (r_root r, length (r_lhs_states r)) |\<in>| \<F>"
shows "ta_sig \<A> |\<subseteq>| \<F>" using assms
by (auto simp: ta_sig_def)
subsubsection \<open>Signature induced by @{const refl_ta} and @{const refl_over_states_ta}\<close>
lemma refl_ta_sig [simp]:
"ta_sig (refl_ta \<F> q) = \<F>"
"ta_sig (refl_over_states_ta Q \<F> \<A> q ) = \<F>"
by (auto simp: ta_sig_def refl_ta_def reflcl_rules_def refl_over_states_ta_def fimage_iff fBex_def)
subsubsection \<open>Correctness of @{const refl_ta}, @{const gen_reflcl_automaton}, and @{const reflcl_automaton}\<close>
lemma refl_ta_eps [simp]: "eps (refl_ta \<F> q) = {||}"
by (auto simp: refl_ta_def)
lemma refl_ta_sound:
"s \<in> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> q |\<in>| ta_der (refl_ta \<F> q) (term_of_gterm s)"
by (induct rule: \<T>\<^sub>G.induct) (auto simp: refl_ta_def reflcl_rules_def
- fimage_iff fBex_def simp flip: fmember.rep_eq)
+ fimage_iff fBex_def simp flip: fmember_iff_member_fset)
lemma reflcl_rules_args:
"length ps = n \<Longrightarrow> f ps \<rightarrow> p |\<in>| reflcl_rules \<F> q \<Longrightarrow> ps = replicate n q"
by (auto simp: reflcl_rules_def)
lemma \<Q>_refl_ta:
"\<Q> (refl_ta \<F> q) |\<subseteq>| {|q|}"
by (auto simp: \<Q>_def refl_ta_def rule_states_def reflcl_rules_def fset_of_list_elem)
lemma refl_ta_complete1:
"Var p |\<in>| ta_der' (refl_ta \<F> q) s \<Longrightarrow> p \<noteq> q \<Longrightarrow> s = Var p"
by (cases s) (auto simp: ta_der'.simps refl_ta_def reflcl_rules_def)
lemma refl_ta_complete2:
"Var q |\<in>| ta_der' (refl_ta \<F> q) s \<Longrightarrow> funas_term s \<subseteq> fset \<F> \<and> vars_term s \<subseteq> {q}"
unfolding ta_der_to_ta_der'[symmetric]
using ta_der_term_sig[of q "refl_ta \<F> q" s] ta_der_states'[of q "refl_ta \<F> q" s]
using fsubsetD[OF \<Q>_refl_ta[of \<F> q]]
- by (auto simp: fmember.rep_eq ffunas_term.rep_eq)
+ by (auto simp: fmember_iff_member_fset ffunas_term.rep_eq)
(metis Term.term.simps(17) fresh_states_ta_der'_pres notin_fset singletonD ta_der_to_ta_der')
lemma gen_reflcl_lang:
assumes "q |\<notin>| \<Q> \<A>"
shows "gta_lang (finsert q Q) (gen_reflcl_automaton \<F> \<A> q) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_reflcl_automaton \<F> \<A> q"
interpret sq: derivation_split ?A "\<A>" "refl_ta \<F> q"
using assms unfolding derivation_split_def
by (auto simp: gen_reflcl_automaton_def refl_ta_def reflcl_rules_def \<Q>_def)
show ?thesis
proof
{fix s assume "s \<in> ?Ls" then obtain p u where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var p |\<in>| ta_der' (refl_ta \<F> q) u" and
fin: "p |\<in>| finsert q Q"
by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
have "vars_term u \<subseteq> {q} \<Longrightarrow> u = term_of_gterm s" using assms
- by (intro ta_det'_vars_term_id[OF seq(1)]) (auto simp flip: fmember.rep_eq)
+ by (intro ta_det'_vars_term_id[OF seq(1)]) (auto simp flip: fmember_iff_member_fset)
then have "s \<in> ?Rs" using assms fin seq funas_term_of_gterm_conv
using refl_ta_complete1[OF seq(2)]
by (cases "p = q") (auto simp: ta_der_to_ta_der' \<T>\<^sub>G_funas_gterm_conv dest!: refl_ta_complete2)}
then show "?Ls \<subseteq> gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)" by blast
next
show "gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>) \<subseteq> ?Ls"
using sq.ta_der_monos unfolding gta_lang_def gta_der_def
by (auto dest: refl_ta_sound)
qed
qed
lemma reflcl_lang:
"gta_lang (finsert None (Some |`| Q)) (reflcl_automaton \<F> \<A>) = gta_lang Q \<A> \<union> \<T>\<^sub>G (fset \<F>)"
proof -
have st: "None |\<notin>| \<Q> (fmap_states_ta Some \<A>)" by auto
have "gta_lang Q \<A> = gta_lang (Some |`| Q) (fmap_states_ta Some \<A>)"
by (simp add: finj_Some fmap_states_ta_lang2)
then show ?thesis
unfolding reflcl_automaton_def Let_def gen_reflcl_lang[OF st, of "Some |`| Q" \<F>]
by simp
qed
lemma \<L>_reflcl_reg:
"\<L> (reflcl_reg \<F> \<A>) = \<L> \<A> \<union> \<T>\<^sub>G (fset \<F>)"
by (simp add: \<L>_def reflcl_lang reflcl_reg_def )
subsubsection \<open>Correctness of @{const gen_parallel_closure_automaton} and @{const parallel_closure_reg}\<close>
lemma set_list_subset_nth_conv:
"set xs \<subseteq> A \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i \<in> A"
by (metis in_set_conv_nth subset_code(1))
lemma ground_gmctxt_of_mctxt_fill_holes':
"num_holes C = length ss \<Longrightarrow> ground_mctxt C \<Longrightarrow> \<forall>s\<in>set ss. ground s \<Longrightarrow>
fill_gholes (gmctxt_of_mctxt C) (map gterm_of_term ss) = gterm_of_term (fill_holes C ss)"
using ground_gmctxt_of_mctxt_fill_holes
by (metis term_of_gterm_inv)
lemma refl_over_states_ta_eps_trancl [simp]:
"(eps (refl_over_states_ta Q \<F> \<A> q))|\<^sup>+| = eps (refl_over_states_ta Q \<F> \<A> q)"
using ftranclD ftranclE unfolding refl_over_states_ta_def
by fastforce
lemma refl_over_states_ta_epsD:
"(p, q) |\<in>| (eps (refl_over_states_ta Q \<F> \<A> q)) \<Longrightarrow> p |\<in>| Q"
by (auto simp: refl_over_states_ta_def)
lemma refl_over_states_ta_vars_term:
"q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) u \<Longrightarrow> vars_term u \<subseteq> insert q (fset Q)"
proof (induct u)
case (Fun f ts)
from Fun(2) reflcl_rules_args[of _ "length ts" f _ \<F> q]
have "i < length ts \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
by (fastforce simp: refl_over_states_ta_def)
then have "i < length ts \<Longrightarrow> x \<in> vars_term (ts ! i) \<Longrightarrow> x = q \<or> x |\<in>| Q" for i x
using Fun(1)[OF nth_mem, of i]
by (meson insert_iff notin_fset subsetD)
- then show ?case by (fastforce simp: in_set_conv_nth fmember.rep_eq)
-qed (auto simp flip: fmember.rep_eq dest: refl_over_states_ta_epsD)
+ then show ?case by (fastforce simp: in_set_conv_nth fmember_iff_member_fset)
+qed (auto simp flip: fmember_iff_member_fset dest: refl_over_states_ta_epsD)
lemmas refl_over_states_ta_vars_term' =
refl_over_states_ta_vars_term[unfolded ta_der_to_ta_der' ta_der'_target_args_vars_term_conv,
- THEN set_list_subset_nth_conv, unfolded fmember.rep_eq[symmetric] finsert.rep_eq[symmetric]]
+ THEN set_list_subset_nth_conv, unfolded fmember_iff_member_fset[symmetric] finsert.rep_eq[symmetric]]
lemma refl_over_states_ta_sound:
"funas_term u \<subseteq> fset \<F> \<Longrightarrow> vars_term u \<subseteq> insert q (fset (Q |\<inter>| \<Q> \<A>)) \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) u"
proof (induct u)
case (Fun f ts)
have reach: "i < length ts \<Longrightarrow> q |\<in>| ta_der (refl_over_states_ta Q \<F> \<A> q) (ts ! i)" for i
using Fun(2-) by (intro Fun(1)[OF nth_mem]) (auto simp: SUP_le_iff)
from Fun(2) have "TA_rule f (replicate (length ts) q) q |\<in>| rules (refl_over_states_ta Q \<F> \<A> q)"
- by (auto simp: refl_over_states_ta_def reflcl_rules_def fimage_iff fBex_def simp flip: fmember.rep_eq)
+ by (auto simp: refl_over_states_ta_def reflcl_rules_def fimage_iff fBex_def simp flip: fmember_iff_member_fset)
then show ?case using reach
by force
-qed (auto simp: refl_over_states_ta_def simp flip: fmember.rep_eq)
+qed (auto simp: refl_over_states_ta_def simp flip: fmember_iff_member_fset)
lemma gen_parallelcl_lang:
fixes \<A> :: "('q, 'f) ta"
assumes "q |\<notin>| \<Q> \<A>"
shows "gta_lang {|q|} (gen_parallel_closure_automaton Q \<F> \<A> q) =
{fill_gholes C ss | C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> (fset \<F>) \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_parallel_closure_automaton Q \<F> \<A> q" let ?B = "refl_over_states_ta Q \<F> \<A> q"
interpret sq: derivation_split "?A" "\<A>" "?B"
using assms unfolding derivation_split_def
by (auto simp: gen_parallel_closure_automaton_def refl_over_states_ta_def \<Q>_def reflcl_rules_def)
{fix s assume "s \<in> ?Ls" then obtain u where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q |\<in>| ta_der'?B u" and
fin: "q |\<in>| finsert q Q"
by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)] fin
using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms
using refl_over_states_ta_vars_term'[OF seq(2)]
using ta_der'_ground_mctxt_structure[OF seq(1)]
by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
gta_langI[of "ta_der'_target_args u ! i" Q \<A>
"gterm_of_term (?w i)" for i])}
then have ls: "?Ls \<subseteq> ?Rs" by blast
{fix t assume "t \<in> ?Rs"
then obtain C ss where len: "num_gholes C = length ss" and
gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
const: "t = fill_gholes C ss" by auto
from reachA obtain qs where "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
then have "q |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
using reachA len gr_fun
by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q])
- (auto simp: funas_mctxt_of_gmctxt_conv simp flip: fmember.rep_eq
+ (auto simp: funas_mctxt_of_gmctxt_conv simp flip: fmember_iff_member_fset
dest!: in_set_idx intro!: refl_over_states_ta_sound)
then have "t \<in> ?Ls" unfolding const
by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
then show ?thesis using ls by blast
qed
lemma parallelcl_gmctxt_lang:
fixes \<A> :: "('q, 'f) reg"
shows "\<L> (parallel_closure_reg \<F> \<A>) =
{fill_gholes C ss |
C ss. num_gholes C = length ss \<and> funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
proof -
have *: "gta_lang (fin (fmap_states_reg Some \<A>)) (fmap_states_ta Some (ta \<A>)) = gta_lang (fin \<A>) (ta \<A>)"
by (simp add: finj_Some fmap_states_reg_def fmap_states_ta_lang2)
have " None |\<notin>| \<Q> (fmap_states_ta Some (ta \<A>))" by auto
from gen_parallelcl_lang[OF this, of "fin (fmap_states_reg Some \<A>)" \<F>] show ?thesis
unfolding \<L>_def parallel_closure_reg_def Let_def * fmap_states_reg_def
by (simp add: finj_Some fmap_states_ta_lang2)
qed
lemma parallelcl_mctxt_lang:
shows "\<L> (parallel_closure_reg \<F> \<A>) =
{(gterm_of_term :: ('f, 'q option) term \<Rightarrow> 'f gterm) (fill_holes C (map term_of_gterm ss)) |
C ss. num_holes C = length ss \<and> ground_mctxt C \<and> funas_mctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
by (auto simp: parallelcl_gmctxt_lang) (metis funas_gmctxt_of_mctxt num_gholes_gmctxt_of_mctxt
ground_gmctxt_of_gterm_of_term funas_mctxt_of_gmctxt_conv
ground_mctxt_of_gmctxt mctxt_of_gmctxt_fill_holes num_holes_mctxt_of_gmctxt)+
subsubsection \<open>Correctness of @{const gen_ctxt_closure_reg} and @{const ctxt_closure_reg}\<close>
lemma semantic_path_rules_rhs:
"r |\<in>| semantic_path_rules Q q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> r_rhs r = q\<^sub>f"
by (auto simp: semantic_path_rules_def)
lemma reflcl_over_single_ta_transl [simp]:
"(eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f))|\<^sup>+| = eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
using ftranclD ftranclE unfolding reflcl_over_single_ta_def
by fastforce
lemma reflcl_over_single_ta_epsD:
"(p, q\<^sub>f) |\<in>| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> p |\<in>| Q"
"(p, q) |\<in>| eps (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow> q = q\<^sub>f"
by (auto simp: reflcl_over_single_ta_def)
lemma reflcl_over_single_ta_rules_split:
"r |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) \<Longrightarrow>
r |\<in>| reflcl_rules \<F> q\<^sub>c \<or> r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
by (auto simp: reflcl_over_single_ta_def)
lemma reflcl_over_single_ta_rules_semantic_path_rulesI:
"r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f \<Longrightarrow> r |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
by (auto simp: reflcl_over_single_ta_def)
lemma semantic_path_rules_fmember [intro]:
"TA_rule f qs q |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<longleftrightarrow> (\<exists> n i. (f, n) |\<in>| \<F> \<and> i < n \<and> q = q\<^sub>f \<and>
(qs = (replicate n q\<^sub>c)[i := q\<^sub>i]))" (is "?Ls \<longleftrightarrow> ?Rs")
by (force simp: semantic_path_rules_def fBex_def fimage_iff fset_of_list_elem)
lemma semantic_path_rules_fmemberD:
"r |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f \<Longrightarrow> (\<exists> n i. (r_root r, n) |\<in>| \<F> \<and> i < n \<and> r_rhs r = q\<^sub>f \<and>
(r_lhs_states r = (replicate n q\<^sub>c)[i := q\<^sub>i]))"
by (cases r) (simp add: semantic_path_rules_fmember)
lemma reflcl_over_single_ta_vars_term_q\<^sub>c:
"q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
proof (induct u)
case (Fun f ts)
have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)" for i using Fun(2, 3)
by (auto dest!: reflcl_over_single_ta_rules_split reflcl_over_single_ta_epsD
reflcl_rules_args semantic_path_rules_rhs)
then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
using Fun(1)[OF nth_mem Fun(2)]
by (metis (no_types, lifting) length_map nth_concat_split nth_map nth_replicate)
then show ?case using Fun(1)[OF nth_mem Fun(2)]
by (auto intro: nth_equalityI)
-qed (auto simp flip: fmember.rep_eq dest: reflcl_over_single_ta_epsD)
+qed (auto simp flip: fmember_iff_member_fset dest: reflcl_over_single_ta_epsD)
lemma reflcl_over_single_ta_vars_term:
"q\<^sub>c |\<notin>| Q \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) u \<Longrightarrow>
length (vars_term_list u) = n \<Longrightarrow> (\<exists> i q. i < n \<and> q |\<in>| finsert q\<^sub>f Q \<and> vars_term_list u = (replicate n q\<^sub>c)[i := q])"
proof (induct u arbitrary: n)
case (Var x) then show ?case
by (intro exI[of _ 0] exI[of _ x]) (auto dest: reflcl_over_single_ta_epsD(1))
next
case (Fun f ts)
from Fun(2, 3, 4) obtain qs where rule: "TA_rule f qs q\<^sub>f |\<in>| semantic_path_rules \<F> q\<^sub>c q\<^sub>f q\<^sub>f"
"length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ts ! i)"
using semantic_path_rules_rhs reflcl_over_single_ta_epsD
by (fastforce simp: reflcl_rules_def dest!: reflcl_over_single_ta_rules_split)
from rule(1, 2) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q\<^sub>f]"
by (auto simp: semantic_path_rules_fmember)
then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
using reflcl_over_single_ta_vars_term_q\<^sub>c[OF Fun(3)] rule
by force
from Fun(1)[OF nth_mem, of i] Fun(2, 3) rule states obtain k q where
qf: "k < length (vars_term_list (ts ! i))" "q |\<in>| finsert q\<^sub>f Q"
"vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k := q]"
by (auto simp: nth_list_update split: if_splits)
let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
show ?case using qc qf rule(2) Fun(5) states(1)
apply (intro exI[of _ ?l] exI[of _ q])
apply (auto simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
done
qed
lemma refl_ta_reflcl_over_single_ta_mono:
"q |\<in>| ta_der (refl_ta \<F> q) t \<Longrightarrow> q |\<in>| ta_der (reflcl_over_single_ta Q \<F> q q\<^sub>f) t"
by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_single_ta Q \<F> q q\<^sub>f"])
(auto simp: refl_ta_def reflcl_over_single_ta_def)
lemma reflcl_over_single_ta_sound:
assumes "funas_gctxt C \<subseteq> fset \<F>" "q |\<in>| Q"
shows "q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1)
proof (induct C)
case GHole then show ?case using assms(2)
by (auto simp add: reflcl_over_single_ta_def)
next
case (GMore f ss C ts)
let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
- from GMore have "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember.rep_eq)
+ from GMore have "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember_iff_member_fset)
then have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f)"
using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
using less_add_Suc1
by (intro reflcl_over_single_ta_rules_semantic_path_rulesI) blast
moreover from GMore(2) have "i < length ss \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ss ! i))" for i
by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
moreover from GMore(2) have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (term_of_gterm (ts ! i))" for i
by (intro refl_ta_reflcl_over_single_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
moreover from GMore have "q\<^sub>f |\<in>| ta_der (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" by auto
ultimately show ?case
by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
qed
lemma reflcl_over_single_ta_sig: "ta_sig (reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f) |\<subseteq>| \<F>"
by (intro ta_sig_fsubsetI)
(auto simp: reflcl_rules_def dest!: semantic_path_rules_fmemberD reflcl_over_single_ta_rules_split)
lemma gen_gctxtcl_lang:
assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>f |\<notin>| \<Q> \<A>" and "q\<^sub>c |\<notin>| Q" and "q\<^sub>c \<noteq> q\<^sub>f"
shows "gta_lang {|q\<^sub>f|} (gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f) =
{C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>f" let ?B = "reflcl_over_single_ta Q \<F> q\<^sub>c q\<^sub>f"
interpret sq: derivation_split ?A \<A> ?B
using assms unfolding derivation_split_def
by (auto simp: gen_ctxt_closure_automaton_def reflcl_over_single_ta_def \<Q>_def reflcl_rules_def
dest!: semantic_path_rules_rhs)
{fix s assume "s \<in> ?Ls" then obtain u where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u" using sq.ta_der'_split
by (force simp: ta_der_to_ta_der' elim!: gta_langE)
have "q\<^sub>c \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1, 2)
- by (auto simp flip: set_vars_term_list fmember.rep_eq)
+ by (auto simp flip: set_vars_term_list fmember_iff_member_fset)
then obtain q where vars: "vars_term_list u = [q]" and fin: "q |\<in>| Q" unfolding set_vars_term_list[symmetric]
using reflcl_over_single_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(3, 4) seq(2), of "length (vars_term_list u)"]
by (metis (no_types, lifting) finsertE in_set_conv_nth length_0_conv length_Suc_conv
length_replicate lessI less_Suc_eq_0_disj nth_Cons_0 nth_list_update nth_replicate zero_less_Suc)
have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars]
using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_single_ta_sig[unfolded less_eq_fset.rep_eq]]
by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
(metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv subset_eq)
}
then have ls: "?Ls \<subseteq> ?Rs" by blast
{fix t assume "t \<in> ?Rs"
then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" and reachA: "s \<in> gta_lang Q \<A>" and
const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
from reachA obtain q where der_A: "q |\<in>| Q |\<inter>| \<Q> \<A>" "q |\<in>| ta_der \<A> (term_of_gterm s)"
by auto
have "q\<^sub>f |\<in>| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
using reflcl_over_single_ta_sound[OF gr_fun]
by force
then have "t \<in> ?Ls" unfolding const
by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
then show ?thesis using ls by blast
qed
lemma gen_gctxt_closure_sound:
fixes \<A> :: "('q, 'f) reg"
assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>c |\<notin>| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) = {C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
using gen_gctxtcl_lang[OF assms] unfolding \<L>_def
by (simp add: gen_ctxt_closure_reg_def)
lemma gen_ctxt_closure_sound:
fixes \<A> :: "('q, 'f) reg"
assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>" and "q\<^sub>c |\<notin>| fin \<A>" and "q\<^sub>c \<noteq> q\<^sub>f"
shows "\<L> (gen_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>f) =
{(gterm_of_term :: ('f, 'q) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> | C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
unfolding gen_gctxt_closure_sound[OF assms]
by (metis (no_types, opaque_lifting) ctxt_of_gctxt_apply funas_ctxt_of_gctxt_conv gctxt_of_ctxt_inv ground_ctxt_of_gctxt)
lemma gctxt_closure_lang:
shows "\<L> (ctxt_closure_reg \<F> \<A>) =
{ C\<langle>s\<rangle>\<^sub>G | C s. funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
proof -
let ?B = "fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)"
have ts: "Inr False |\<notin>| \<Q>\<^sub>r ?B" "Inr True |\<notin>| \<Q>\<^sub>r ?B" "Inr False |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
by (auto simp: fmap_states_reg_def fmap_states_ta_def' \<Q>_def rule_states_def)
from gen_gctxt_closure_sound[OF ts] show ?thesis
by (simp add: ctxt_closure_reg_def)
qed
lemma ctxt_closure_lang:
shows "\<L> (ctxt_closure_reg \<F> \<A>) =
{(gterm_of_term :: ('f, 'q + bool) term \<Rightarrow> 'f gterm) C\<langle>term_of_gterm s\<rangle> |
C s. ground_ctxt C \<and> funas_ctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
unfolding gctxt_closure_lang
by (metis (mono_tags, opaque_lifting) ctxt_of_gctxt_inv funas_gctxt_of_ctxt
ground_ctxt_of_gctxt ground_gctxt_of_ctxt_apply_gterm term_of_gterm_inv)
subsubsection \<open>Correctness of @{const gen_nhole_ctxt_closure_automaton} and @{const nhole_ctxt_closure_reg}\<close>
lemma reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c:
"q\<^sub>c \<noteq> q\<^sub>f \<Longrightarrow> q\<^sub>c \<noteq> q\<^sub>i \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u \<Longrightarrow>
vars_term_list u = replicate (length (vars_term_list u)) q\<^sub>c"
proof (induct u)
case (Fun f ts)
have "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)" for i using Fun(2, 3, 4)
by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2 reflcl_rules_args semantic_path_rules_rhs)
then have "i < length (concat (map vars_term_list ts)) \<Longrightarrow> concat (map vars_term_list ts) ! i = q\<^sub>c" for i
using Fun(1)[OF nth_mem Fun(2, 3)]
by (metis (no_types, lifting) length_map map_nth_eq_conv nth_concat_split' nth_replicate)
then show ?case using Fun(1)[OF nth_mem Fun(2)]
by (auto intro: nth_equalityI)
-qed (auto simp flip: fmember.rep_eq simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
+qed (auto simp flip: fmember_iff_member_fset simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
lemma reflcl_over_nhole_ctxt_ta_vars_term_Var:
assumes disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
and reach: "q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
shows "(\<exists> q. q |\<in>| finsert q\<^sub>i Q \<and> u = Var q)" using assms
by (cases u) (fastforce simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD semantic_path_rules_rhs)+
lemma reflcl_over_nhole_ctxt_ta_vars_term:
assumes disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f" "q\<^sub>c \<noteq> q\<^sub>i"
and reach: "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) u"
shows "(\<exists> i q. i < length (vars_term_list u) \<and> q |\<in>| {|q\<^sub>i, q\<^sub>f|} |\<union>| Q \<and> vars_term_list u = (replicate (length (vars_term_list u)) q\<^sub>c)[i := q])"
using assms
proof (induct u)
case (Var q) then show ?case
by (intro exI[of _ 0] exI[of _ q]) (auto simp: reflcl_over_nhole_ctxt_ta_def dest: ftranclD2)
next
case (Fun f ts)
from Fun(2 - 7) obtain q qs where rule: "TA_rule f qs q\<^sub>f |\<in>| semantic_path_rules \<F> q\<^sub>c q q\<^sub>f" "q = q\<^sub>i \<or> q = q\<^sub>f"
"length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
by (auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest: ftranclD2)
from rule(1- 3) obtain i where states: "i < length ts" "qs = (replicate (length ts) q\<^sub>c)[i := q]"
by (auto simp: semantic_path_rules_fmember)
then have qc: "j < length ts \<Longrightarrow> j \<noteq> i \<Longrightarrow> vars_term_list (ts ! j) = replicate (length (vars_term_list (ts ! j))) q\<^sub>c" for j
using reflcl_over_nhole_ctxt_ta_vars_term_q\<^sub>c[OF Fun(4, 6)] rule
by force
from rule states have "q |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ts ! i)"
by auto
from this Fun(1)[OF nth_mem, of i, OF _ Fun(2 - 6)] rule(2) states(1) obtain k q' where
qf: "k < length (vars_term_list (ts ! i))" "q' |\<in>| {|q\<^sub>i, q\<^sub>f|} |\<union>| Q "
"vars_term_list (ts ! i) = (replicate (length (vars_term_list (ts ! i))) q\<^sub>c)[k := q']"
using reflcl_over_nhole_ctxt_ta_vars_term_Var[OF Fun(2 - 6), of \<F> "ts ! i"]
by (auto simp: nth_list_update split: if_splits) blast
let ?l = "sum_list (map length (take i (map vars_term_list ts))) + k"
show ?case using qc qf rule(3) states(1)
apply (intro exI[of _ ?l] exI[of _ q'])
apply (auto 0 0 simp: concat_nth_length nth_list_update elim!: nth_concat_split' intro!: nth_equalityI)
apply (metis length_replicate nth_list_update_eq nth_list_update_neq nth_replicate)+
done
qed
lemma reflcl_over_nhole_ctxt_ta_mono:
"q |\<in>| ta_der (refl_ta \<F> q) t \<Longrightarrow> q |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f) t"
by (intro ta_der_el_mono[where ?\<B> = "reflcl_over_nhole_ctxt_ta Q \<F> q q\<^sub>i q\<^sub>f"])
(auto simp: refl_ta_def reflcl_over_nhole_ctxt_ta_def)
lemma reflcl_over_nhole_ctxt_ta_sound:
assumes "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" "q |\<in>| Q"
shows "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using assms(1, 2)
proof (induct C)
case GHole then show ?case using assms(2)
by (auto simp add: reflcl_over_single_ta_def)
next
case (GMore f ss C ts) note IH = this
let ?i = "length ss" let ?n = "Suc (length ss + length ts)"
- from GMore have funas: "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember.rep_eq)
+ from GMore have funas: "(f, ?n) |\<in>| \<F>" by (auto simp flip: fmember_iff_member_fset)
from GMore(2) have args_ss: "i < length ss \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ss ! i))" for i
by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
from GMore(2) have args_ts: "i < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (term_of_gterm (ts ! i))" for i
by (intro reflcl_over_nhole_ctxt_ta_mono refl_ta_sound) (auto simp: SUP_le_iff \<T>\<^sub>G_funas_gterm_conv)
note args = this
show ?case
proof (cases C)
case [simp]: GHole
from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>i]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]" q\<^sub>f \<F> q\<^sub>c q\<^sub>i q\<^sub>f]
unfolding reflcl_over_nhole_ctxt_ta_def
by (metis funionCI less_add_Suc1 ta.sel(1))
moreover have "q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
using assms(3) by (auto simp: reflcl_over_nhole_ctxt_ta_def)
ultimately show ?thesis using args_ss args_ts
by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>i]"] exI[of _ q\<^sub>f])
next
case (GMore x21 x22 x23 x24)
then have "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) (ctxt_of_gctxt C)\<langle>Var q\<rangle>"
using IH(1, 2) by auto
moreover from funas have "f ((replicate ?n q\<^sub>c)[?i := q\<^sub>f]) \<rightarrow> q\<^sub>f |\<in>| rules (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
using semantic_path_rules_fmember[of f "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]" q\<^sub>f \<F> q\<^sub>c q\<^sub>f q\<^sub>f]
unfolding reflcl_over_nhole_ctxt_ta_def
by (metis funionI2 less_add_Suc1 ta.sel(1))
ultimately show ?thesis using args_ss args_ts
by (auto simp: nth_append_Cons simp del: replicate.simps intro!: exI[of _ "(replicate ?n q\<^sub>c)[?i := q\<^sub>f]"] exI[of _ q\<^sub>f])
qed
qed
lemma reflcl_over_nhole_ctxt_ta_sig: "ta_sig (reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) |\<subseteq>| \<F>"
by (intro ta_sig_fsubsetI)
(auto simp: reflcl_over_nhole_ctxt_ta_def reflcl_rules_def dest!: semantic_path_rules_fmemberD)
lemma gen_nhole_gctxt_closure_lang:
assumes "q\<^sub>c |\<notin>| \<Q> \<A>" "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
and "q\<^sub>c |\<notin>| Q" "q\<^sub>f |\<notin>| Q"
and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
shows "gta_lang {|q\<^sub>f|} (gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
{C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> gta_lang Q \<A>}"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_nhole_ctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_ctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
interpret sq: derivation_split ?A \<A> ?B
using assms unfolding derivation_split_def
by (auto simp: gen_nhole_ctxt_closure_automaton_def reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def
dest!: semantic_path_rules_rhs)
{fix s assume "s \<in> ?Ls" then obtain u where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u" using sq.ta_der'_split
by (force simp: ta_der_to_ta_der' elim!: gta_langE)
have "q\<^sub>c \<notin> vars_term u" "q\<^sub>i \<notin> vars_term u" "q\<^sub>f \<notin> vars_term u"
using subsetD[OF ta_der'_gterm_states[OF seq(1)]] assms(1 - 3)
- by (auto simp flip: set_vars_term_list fmember.rep_eq)
+ by (auto simp flip: set_vars_term_list fmember_iff_member_fset)
then obtain q where vars: "vars_term_list u = [q]" and fin: "q |\<in>| Q"
unfolding set_vars_term_list[symmetric]
using reflcl_over_nhole_ctxt_ta_vars_term[unfolded ta_der_to_ta_der', OF assms(4, 5, 7 - 8, 6) seq(2)]
by (metis (no_types, opaque_lifting) finsert_iff funion_commute funion_finsert_right
length_greater_0_conv lessI list.size(3) list_update_code(2) not0_implies_Suc
nth_list_update_neq nth_mem nth_replicate replicate_Suc replicate_empty sup_bot.right_neutral)
from seq(2) have "ta_der'_gctxt u \<noteq> GHole" using ta_der'_ground_ctxt_structure(1)[OF seq(1) vars]
using fin assms(4, 5, 8) by (auto simp: reflcl_over_nhole_ctxt_ta_def dest!: ftranclD2)
then have "s \<in> ?Rs" using fin ta_der'_ground_ctxt_structure[OF seq(1) vars] seq(2)
using ta_der'_Var_funas[OF seq(2), THEN subset_trans, OF reflcl_over_nhole_ctxt_ta_sig[unfolded less_eq_fset.rep_eq]]
by (auto intro!: exI[of _ "ta_der'_gctxt u"] exI[of _ "ta_der'_source_gctxt_arg u s"])
(metis Un_iff funas_ctxt_apply funas_ctxt_of_gctxt_conv in_mono)}
then have ls: "?Ls \<subseteq> ?Rs" by blast
{fix t assume "t \<in> ?Rs"
then obtain C s where gr_fun: "funas_gctxt C \<subseteq> fset \<F>" "C \<noteq> GHole" and reachA: "s \<in> gta_lang Q \<A>" and
const: "t = C\<langle>s\<rangle>\<^sub>G" by auto
from reachA obtain q where der_A: "q |\<in>| Q |\<inter>| \<Q> \<A>" "q |\<in>| ta_der \<A> (term_of_gterm s)"
by auto
have "q\<^sub>f |\<in>| ta_der ?B (ctxt_of_gctxt C)\<langle>Var q\<rangle>" using gr_fun der_A(1)
using reflcl_over_nhole_ctxt_ta_sound[OF gr_fun]
by force
then have "t \<in> ?Ls" unfolding const
by (meson der_A(2) finsertI1 gta_langI sq.gctxt_const_to_ta_der)}
then show ?thesis using ls by blast
qed
lemma gen_nhole_gctxt_closure_sound:
assumes "q\<^sub>c |\<notin>| \<Q>\<^sub>r \<A>" "q\<^sub>i |\<notin>| \<Q>\<^sub>r \<A>" "q\<^sub>f |\<notin>| \<Q>\<^sub>r \<A>"
and "q\<^sub>c |\<notin>| (fin \<A>)" "q\<^sub>f |\<notin>| (fin \<A>)"
and "q\<^sub>c \<noteq> q\<^sub>i" "q\<^sub>c \<noteq> q\<^sub>f" "q\<^sub>i \<noteq> q\<^sub>f"
shows "\<L> (gen_nhole_ctxt_closure_reg \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
{ C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
using gen_nhole_gctxt_closure_lang[OF assms] unfolding \<L>_def
by (auto simp: gen_nhole_ctxt_closure_reg_def)
lemma nhole_ctxtcl_lang:
"\<L> (nhole_ctxt_closure_reg \<F> \<A>) =
{ C\<langle>s\<rangle>\<^sub>G | C s. C \<noteq> GHole \<and> funas_gctxt C \<subseteq> fset \<F> \<and> s \<in> \<L> \<A>}"
proof -
let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
by (auto simp: fmap_states_reg_def)
then have "Inr cl_state |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
"Inr fin_state |\<notin>| fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))"
using finj_Inl_Inr(1) fmap_states_reg_Restr_Q\<^sub>f_fin by blast+
from gen_nhole_gctxt_closure_sound[OF ts this] show ?thesis
by (simp add: nhole_ctxt_closure_reg_def Let_def)
qed
subsubsection \<open>Correctness of @{const gen_nhole_mctxt_closure_automaton}\<close>
lemmas reflcl_over_nhole_mctxt_ta_simp = reflcl_over_nhole_mctxt_ta_def reflcl_over_nhole_ctxt_ta_def
lemma reflcl_rules_rhsD:
"f ps \<rightarrow> q |\<in>| reflcl_rules \<F> q\<^sub>c \<Longrightarrow> q = q\<^sub>c"
by (auto simp: reflcl_rules_def)
lemma reflcl_over_nhole_mctxt_ta_vars_term:
assumes "q |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t"
and "q\<^sub>c |\<notin>| Q" "q \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>i \<noteq> q\<^sub>c"
shows "vars_term t \<noteq> {}" using assms
proof (induction t arbitrary: q)
case (Fun f ts)
let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
from Fun(2) obtain p ps where rule: "TA_rule f ps p |\<in>| rules ?A"
"length ps = length ts" "\<forall> i < length ts. ps ! i |\<in>| ta_der ?A (ts ! i)"
"p = q \<or> (p, q) |\<in>| (eps ?A)|\<^sup>+|"
by force
from rule(1, 4) Fun(3-) have "p \<noteq> q\<^sub>c"
by (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD)
then have "\<exists> i < length ts. ps ! i \<noteq> q\<^sub>c" using rule(1, 2) Fun(4-)
using semantic_path_rules_fmemberD
by (force simp: reflcl_over_nhole_mctxt_ta_simp dest: reflcl_rules_rhsD)
then show ?case using Fun(1)[OF nth_mem _ Fun(3) _ Fun(5, 6)] rule(2, 3)
by fastforce
qed auto
lemma reflcl_over_nhole_mctxt_ta_Fun:
assumes "q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "t \<noteq> Var q\<^sub>f"
and "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i"
shows "is_Fun t" using assms
by (cases t) (auto simp: reflcl_over_nhole_mctxt_ta_simp dest: ftranclD2)
lemma rule_states_reflcl_rulesD:
"p |\<in>| rule_states (reflcl_rules \<F> q) \<Longrightarrow> p = q"
by (auto simp: reflcl_rules_def rule_states_def fset_of_list_elem)
lemma rule_states_semantic_path_rulesD:
"p |\<in>| rule_states (semantic_path_rules \<F> q\<^sub>c q\<^sub>i q\<^sub>f) \<Longrightarrow> p = q\<^sub>c \<or> p = q\<^sub>i \<or> p = q\<^sub>f"
by (auto simp: rule_states_def dest!: semantic_path_rules_fmemberD)
(metis in_fset_conv_nth length_list_update length_replicate nth_list_update nth_replicate)
lemma \<Q>_reflcl_over_nhole_mctxt_ta:
"\<Q> (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) |\<subseteq>| Q |\<union>| {|q\<^sub>c, q\<^sub>i, q\<^sub>f|}"
by (auto 0 0 simp: eps_states_def reflcl_over_nhole_mctxt_ta_simp \<Q>_def
dest!: rule_states_reflcl_rulesD rule_states_semantic_path_rulesD)
lemma reflcl_over_nhole_mctxt_ta_vars_term_subset_eq:
assumes "q |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" "q = q\<^sub>f \<or> q = q\<^sub>i"
shows "vars_term t \<subseteq> {q\<^sub>c, q\<^sub>i, q\<^sub>f} \<union> fset Q"
using fresh_states_ta_der'_pres[OF _ _ assms(1)[unfolded ta_der_to_ta_der']] assms(2)
using fsubsetD[OF \<Q>_reflcl_over_nhole_mctxt_ta[of Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f]]
by auto (meson notin_fset)+
lemma sig_reflcl_over_nhole_mctxt_ta [simp]:
"ta_sig (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) = \<F>"
by (force simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def
dest!: semantic_path_rules_fmemberD intro!: ta_sig_fsubsetI)
lemma reflcl_over_nhole_mctxt_ta_aux_sound:
assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q"
shows "q\<^sub>c |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t" using assms
proof (induct t)
case (Var x)
then show ?case
- by (auto simp: reflcl_over_nhole_mctxt_ta_simp fimage_iff simp flip: fmember.rep_eq)
+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp fimage_iff simp flip: fmember_iff_member_fset)
(meson finsertI1 finsertI2 fr_into_trancl ftrancl_into_trancl rev_fimage_eqI)
next
case (Fun f ts)
from Fun(2) have "TA_rule f (replicate (length ts) q\<^sub>c) q\<^sub>c |\<in>| rules (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f)"
by (auto simp: reflcl_over_nhole_mctxt_ta_simp reflcl_rules_def fimage_iff fBall_def
- simp flip: fmember.rep_eq split: prod.splits)
+ simp flip: fmember_iff_member_fset split: prod.splits)
then show ?case using Fun(1)[OF nth_mem] Fun(2-)
by (auto simp: SUP_le_iff) (metis length_replicate nth_replicate)
qed
lemma reflcl_over_nhole_mctxt_ta_sound:
assumes "funas_term t \<subseteq> fset \<F>" "vars_term t \<subseteq> fset Q" "vars_term t \<noteq> {}"
shows "(is_Var t \<longrightarrow> q\<^sub>i |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t) \<and>
(is_Fun t \<longrightarrow> q\<^sub>f |\<in>| ta_der (reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f) t)" using assms
proof (induct t)
case (Fun f ts)
let ?A = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
from Fun(4) obtain i where vars: "i < length ts" "vars_term (ts ! i) \<noteq> {}"
by (metis SUP_le_iff in_set_conv_nth subset_empty term.set(4))
consider (v) "is_Var (ts ! i)" | (f) "is_Fun (ts ! i)" by blast
then show ?case
proof cases
case v
from v Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>i |\<in>| ta_der ?A (ts ! i)"
using vars Fun(2-) by (auto simp: SUP_le_iff)
moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>i] \<rightarrow> q\<^sub>f |\<in>| rules ?A"
using Fun(2) vars(1)
- by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember_iff_member_fset)
moreover have "j < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der ?A (ts ! j)" for j using Fun(2-)
by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
ultimately show ?thesis using vars
by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
next
case f
from f Fun(1)[OF nth_mem[OF vars(1)]] have "q\<^sub>f |\<in>| ta_der ?A (ts ! i)"
using vars Fun(2-) by (auto simp: SUP_le_iff)
moreover have "f (replicate (length ts) q\<^sub>c)[i := q\<^sub>f] \<rightarrow> q\<^sub>f |\<in>| rules ?A"
using Fun(2) vars(1)
- by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember.rep_eq)
+ by (auto simp: reflcl_over_nhole_mctxt_ta_simp semantic_path_rules_fmember simp flip: fmember_iff_member_fset)
moreover have "j < length ts \<Longrightarrow> q\<^sub>c |\<in>| ta_der ?A (ts ! j)" for j using Fun(2-)
by (intro reflcl_over_nhole_mctxt_ta_aux_sound) (auto simp: SUP_le_iff)
ultimately show ?thesis using vars
by auto (metis length_list_update length_replicate nth_list_update nth_replicate)
qed
-qed (auto simp: reflcl_over_nhole_mctxt_ta_simp simp flip: fmember.rep_eq dest!: ftranclD2)
+qed (auto simp: reflcl_over_nhole_mctxt_ta_simp simp flip: fmember_iff_member_fset dest!: ftranclD2)
lemma gen_nhole_gmctxt_closure_lang:
assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
and "q\<^sub>c |\<notin>| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
shows "gta_lang {|q\<^sub>f|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
{ fill_gholes C ss |
C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and> C \<noteq> GMHole \<and>
funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
interpret sq: derivation_split "?A" "\<A>" "?B"
using assms unfolding derivation_split_def
by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
{fix s assume "s \<in> ?Ls" then obtain u where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q\<^sub>f |\<in>| ta_der'?B u"
by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
note der = seq(2)[unfolded ta_der_to_ta_der'[symmetric]]
have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
using ta_der'_gterm_states[OF seq(1)] assms(1 - 3)
using reflcl_over_nhole_mctxt_ta_vars_term[OF der assms(4) assms(5) assms(5) assms(7)]
using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF der]
by (metis Un_insert_left insert_is_Un notin_fset subset_iff subset_insert)+
then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i |\<in>| Q" for i
by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
- fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
+ fmember_iff_member_fset set_list_subset_nth_conv simp flip: set_vars_term_list)
have hole: "ta_der'_target_mctxt u \<noteq> MHole" using vars assms(3-)
using reflcl_over_nhole_mctxt_ta_Fun[OF der]
using ta_der'_mctxt_structure(1, 3)[OF seq(1)]
by auto (metis fill_holes_MHole gterm_ta_der_states length_map lessI map_nth_eq_conv seq(1) ta_der_to_ta_der' term.disc(1))
let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
using ta_der'_ground_mctxt_structure[OF seq(1)] hole
by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
gta_langI[of "ta_der'_target_args u ! i" Q \<A>
"gterm_of_term (?w i)" for i])}
then have ls: "?Ls \<subseteq> ?Rs" by blast
{fix t assume "t \<in> ?Rs"
then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" "C \<noteq> GMHole" and
gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
const: "t = fill_gholes C ss" by auto
from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
have [simp]: "is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> True"
"is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) \<longleftrightarrow> False"
using len(3) by (cases C, auto)+
have "q\<^sub>f |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
using reachA len gr_fun states
using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
- (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
- simp flip: fmember.rep_eq dest!: in_set_idx)
+ (auto simp: funas_mctxt_of_gmctxt_conv fmember_iff_member_fset set_list_subset_eq_nth_conv
+ simp flip: fmember_iff_member_fset dest!: in_set_idx)
then have "t \<in> ?Ls" unfolding const
by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes gta_langI len)}
then show ?thesis using ls by blast
qed
lemma nhole_gmctxt_closure_lang:
"\<L> (nhole_mctxt_closure_reg \<F> \<A>) =
{ fill_gholes C ss | C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and> C \<noteq> GMHole \<and>
funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
(is "?Ls = ?Rs")
proof -
let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
"Inr cl_state |\<notin>| fin ?B"
by (auto simp: fmap_states_reg_def)
have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
= gta_lang (fin \<A>) (ta \<A>)"
by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
from gen_nhole_gmctxt_closure_lang[OF ts] show ?thesis
by (auto simp add: nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def Let_def \<L>_def)
qed
subsubsection \<open>Correctness of @{const gen_mctxt_closure_reg} and @{const mctxt_closure_reg}\<close>
lemma gen_gmctxt_closure_lang:
assumes "q\<^sub>c |\<notin>| \<Q> \<A>" and "q\<^sub>i |\<notin>| \<Q> \<A>" "q\<^sub>f |\<notin>| \<Q> \<A>"
and disj: "q\<^sub>c |\<notin>| Q" "q\<^sub>f \<noteq> q\<^sub>c" "q\<^sub>f \<noteq> q\<^sub>i" "q\<^sub>i \<noteq> q\<^sub>c"
shows "gta_lang {|q\<^sub>f, q\<^sub>i|} (gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f) =
{ fill_gholes C ss |
C ss. 0 < num_gholes C \<and> num_gholes C = length ss \<and>
funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>)}"
(is "?Ls = ?Rs")
proof -
let ?A = "gen_nhole_mctxt_closure_automaton Q \<F> \<A> q\<^sub>c q\<^sub>i q\<^sub>f" let ?B = "reflcl_over_nhole_mctxt_ta Q \<F> q\<^sub>c q\<^sub>i q\<^sub>f"
interpret sq: derivation_split "?A" "\<A>" "?B"
using assms unfolding derivation_split_def
by (auto simp: gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
reflcl_over_nhole_ctxt_ta_def \<Q>_def reflcl_rules_def dest!: semantic_path_rules_rhs)
{fix s assume "s \<in> ?Ls" then obtain u q where
seq: "u |\<in>| ta_der' \<A> (term_of_gterm s)" "Var q |\<in>| ta_der'?B u" "q = q\<^sub>f \<or> q = q\<^sub>i"
by (auto simp: ta_der_to_ta_der' elim!: gta_langE dest!: sq.ta_der'_split)
have "vars_term u \<subseteq> fset Q" "vars_term u \<noteq> {}"
using ta_der'_gterm_states[OF seq(1)] assms seq(3)
using reflcl_over_nhole_mctxt_ta_vars_term[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] disj(1) _ disj(2, 4)]
using reflcl_over_nhole_mctxt_ta_vars_term_subset_eq[OF seq(2)[unfolded ta_der_to_ta_der'[symmetric]] seq(3)]
by (metis Un_insert_left notin_fset subsetD subset_insert sup_bot_left)+
then have vars: "\<not> ground u" "i < length (ta_der'_target_args u) \<Longrightarrow> ta_der'_target_args u ! i |\<in>| Q" for i
by (auto simp: ta_der'_target_args_def split_vars_vars_term_list
- fmember.rep_eq set_list_subset_nth_conv simp flip: set_vars_term_list)
+ fmember_iff_member_fset set_list_subset_nth_conv simp flip: set_vars_term_list)
let ?w = "\<lambda> i. ta_der'_source_args u (term_of_gterm s) ! i"
have "s \<in> ?Rs" using seq(1) ta_der'_Var_funas[OF seq(2)]
using ground_ta_der_statesD[of "?w i" "ta_der'_target_args u ! i" \<A> for i] assms vars
using ta_der'_ground_mctxt_structure[OF seq(1)]
by (force simp: ground_gmctxt_of_mctxt_fill_holes' ta_der'_source_args_term_of_gterm
intro!: exI[of _ "gmctxt_of_mctxt (ta_der'_target_mctxt u)"]
exI[of _ "map gterm_of_term (ta_der'_source_args u (term_of_gterm s))"]
gta_langI[of "ta_der'_target_args u ! i" Q \<A>
"gterm_of_term (?w i)" for i])}
then have "?Ls \<subseteq> ?Rs" by blast
moreover
{fix t assume "t \<in> ?Rs"
then obtain C ss where len: "0 < num_gholes C" "num_gholes C = length ss" and
gr_fun: "funas_gmctxt C \<subseteq> fset \<F>" and
reachA: "\<forall> i < length ss. ss ! i \<in> gta_lang Q \<A>" and
const: "t = fill_gholes C ss" by auto
from const have const': "term_of_gterm t = fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss)"
by (simp add: fill_holes_mctxt_of_gmctxt_to_fill_gholes len(2))
from reachA obtain qs where states: "length ss = length qs" "\<forall> i < length qs. qs ! i |\<in>| Q |\<inter>| \<Q> \<A>"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> ((map term_of_gterm ss) ! i)"
using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> q |\<in>| Q"]
by (metis (full_types) finterI gta_langE gterm_ta_der_states length_map map_nth_eq_conv)
have "C = GMHole \<Longrightarrow> is_Var (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True" using len states(1)
by (metis fill_holes_MHole length_map mctxt_of_gmctxt.simps(1) nth_map num_gholes.simps(1) term.disc(1))
then have hole: "C = GMHole \<Longrightarrow> q\<^sub>i |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
using reachA len gr_fun states len
using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>i])
- (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
- simp flip: fmember.rep_eq dest!: in_set_idx)
+ (auto simp: funas_mctxt_of_gmctxt_conv fmember_iff_member_fset set_list_subset_eq_nth_conv
+ simp flip: fmember_iff_member_fset dest!: in_set_idx)
have "C \<noteq> GMHole \<Longrightarrow> is_Fun (fill_holes (mctxt_of_gmctxt C) (map Var qs)) = True"
by (cases C) auto
then have "C \<noteq> GMHole \<Longrightarrow> q\<^sub>f |\<in>| ta_der ?A (fill_holes (mctxt_of_gmctxt C) (map term_of_gterm ss))"
using reachA len gr_fun states
using reflcl_over_nhole_mctxt_ta_sound[of "fill_holes (mctxt_of_gmctxt C) (map Var qs)"]
by (intro sq.mctxt_const_to_ta_der[of "mctxt_of_gmctxt C" "map term_of_gterm ss" qs q\<^sub>f])
- (auto simp: funas_mctxt_of_gmctxt_conv fmember.rep_eq set_list_subset_eq_nth_conv
- simp flip: fmember.rep_eq dest!: in_set_idx)
+ (auto simp: funas_mctxt_of_gmctxt_conv fmember_iff_member_fset set_list_subset_eq_nth_conv
+ simp flip: fmember_iff_member_fset dest!: in_set_idx)
then have "t \<in> ?Ls" using hole const' unfolding gta_lang_def gta_der_def
by (metis (mono_tags, lifting) fempty_iff finsert_iff finterI mem_Collect_eq)}
ultimately show ?thesis
by (meson subsetI subset_antisym)
qed
lemma gmctxt_closure_lang:
"\<L> (mctxt_closure_reg \<F> \<A>) =
{ fill_gholes C ss | C ss. num_gholes C = length ss \<and> 0 < num_gholes C \<and>
funas_gmctxt C \<subseteq> fset \<F> \<and> (\<forall> i < length ss. ss ! i \<in> \<L> \<A>)}"
(is "?Ls = ?Rs")
proof -
let ?B = "fmap_states_reg (Inl :: 'b \<Rightarrow> 'b + cl_states) (reg_Restr_Q\<^sub>f \<A>)"
have ts: "Inr cl_state |\<notin>| \<Q>\<^sub>r ?B" "Inr tr_state |\<notin>| \<Q>\<^sub>r ?B" "Inr fin_state |\<notin>| \<Q>\<^sub>r ?B"
"Inr cl_state |\<notin>| fin ?B"
by (auto simp: fmap_states_reg_def)
have [simp]: "gta_lang (fin (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>))) (ta (fmap_states_reg Inl (reg_Restr_Q\<^sub>f \<A>)))
= gta_lang (fin \<A>) (ta \<A>)"
by (metis \<L>_def \<L>_fmap_states_reg_Inl_Inr(1) reg_Rest_fin_states)
from gen_gmctxt_closure_lang[OF ts] show ?thesis
by (auto simp add: mctxt_closure_reg_def gen_mctxt_closure_reg_def Let_def \<L>_def)
qed
subsubsection \<open>Correctness of @{const nhole_mctxt_reflcl_reg}\<close>
lemma nhole_mctxt_reflcl_lang:
"\<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>) \<union> \<T>\<^sub>G (fset \<F>)"
proof -
let ?refl = "Reg {|fin_clstate|} (refl_ta \<F> (fin_clstate))"
{fix t assume "t \<in> \<L> ?refl" then have "t \<in> \<T>\<^sub>G (fset \<F>)"
using reg_funas by fastforce}
moreover
{fix t assume "t \<in> \<T>\<^sub>G (fset \<F>)" then have "t \<in> \<L> ?refl"
by (simp add: \<L>_def gta_langI refl_ta_sound)}
ultimately have *: "\<L> ?refl = \<T>\<^sub>G (fset \<F>)"
by blast
show ?thesis unfolding nhole_mctxt_reflcl_reg_def \<L>_union * by simp
qed
declare ta_union_def [simp del]
end
\ No newline at end of file
diff --git a/thys/FO_Theory_Rewriting/FOR_Check.thy b/thys/FO_Theory_Rewriting/FOR_Check.thy
--- a/thys/FO_Theory_Rewriting/FOR_Check.thy
+++ b/thys/FO_Theory_Rewriting/FOR_Check.thy
@@ -1,1193 +1,1193 @@
theory FOR_Check
imports
FOR_Semantics
FOL_Extra
GTT_RRn
First_Order_Terms.Option_Monad
LV_to_GTT
NF
Regular_Tree_Relations.GTT_Transitive_Closure
Regular_Tree_Relations.AGTT
Regular_Tree_Relations.RR2_Infinite_Q_infinity
Regular_Tree_Relations.RRn_Automata
begin
section \<open>Check inference steps\<close>
type_synonym ('f, 'v) fin_trs = "('f, 'v) rule fset"
lemma tl_drop_conv:
"tl xs = drop 1 xs"
by (induct xs) auto
definition rrn_drop_fst where
"rrn_drop_fst \<A> = relabel_reg (trim_reg (collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) (trim_reg \<A>))))"
lemma rrn_drop_fst_lang:
assumes "RRn_spec n A T" "1 < n"
shows "RRn_spec (n - 1) (rrn_drop_fst A) (drop 1 ` T)"
using drop_automaton_reg[OF _ assms(2), of "trim_reg A" T] assms(1)
unfolding rrn_drop_fst_def
by (auto simp: trim_ta_reach)
definition liftO1 :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option" where
"liftO1 = map_option"
definition liftO2 :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a option \<Rightarrow> 'b option \<Rightarrow> 'c option" where
"liftO2 f a b = case_option None (\<lambda>a'. liftO1 (f a') b) a"
lemma liftO1_Some [simp]:
"liftO1 f x = Some y \<longleftrightarrow> (\<exists>x'. x = Some x') \<and> y = f (the x)"
by (cases x) (auto simp: liftO1_def)
lemma liftO2_Some [simp]:
"liftO2 f x y = Some z \<longleftrightarrow> (\<exists>x' y'. x = Some x' \<and> y = Some y') \<and> z = f (the x) (the y)"
by (cases x; cases y) (auto simp: liftO2_def)
subsection \<open>Computing TRSs\<close>
lemma is_to_trs_props:
assumes "\<forall> R \<in> set Rs. finite R \<and> lv_trs R \<and> funas_trs R \<subseteq> \<F>" "\<forall>i \<in> set is. case_ftrs id id i < length Rs"
shows "funas_trs (is_to_trs Rs is) \<subseteq> \<F>" "lv_trs (is_to_trs Rs is)" "finite (is_to_trs Rs is)"
proof (goal_cases \<F> lv fin)
case \<F> show ?case using assms nth_mem
apply (auto simp: is_to_trs_def funas_trs_def case_prod_beta split: ftrs.splits)
apply fastforce
apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
apply (metis (no_types, lifting) assms(1) in_mono rhs_wf)
by (smt (z3) UN_subset_iff fst_conv in_mono le_sup_iff)
qed (insert assms, (fastforce simp: is_to_trs_def funas_trs_def lv_trs_def split: ftrs.splits)+)
definition is_to_fin_trs :: "('f, 'v) fin_trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) fin_trs" where
"is_to_fin_trs Rs is = |\<Union>| (fset_of_list (map (case_ftrs ((!) Rs) ((|`|) prod.swap \<circ> (!) Rs)) is))"
lemma is_to_fin_trs_conv:
assumes "\<forall>i \<in> set is. case_ftrs id id i < length Rs"
shows "is_to_trs (map fset Rs) is = fset (is_to_fin_trs Rs is)"
using assms unfolding is_to_trs_def is_to_fin_trs_def
by (auto simp: ffUnion.rep_eq fset_of_list.rep_eq split: ftrs.splits)
definition is_to_trs' :: "('f, 'v) fin_trs list \<Rightarrow> ftrs list \<Rightarrow> ('f, 'v) fin_trs option" where
"is_to_trs' Rs is = do {
guard (\<forall>i \<in> set is. case_ftrs id id i < length Rs);
Some (is_to_fin_trs Rs is)
}"
lemma is_to_trs_conv:
"is_to_trs' Rs is = Some S \<Longrightarrow> is_to_trs (map fset Rs) is = fset S"
using is_to_fin_trs_conv unfolding is_to_trs'_def
by (auto simp add: guard_simps split: bind_splits)
lemma is_to_trs'_props:
assumes "\<forall> R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>" and "is_to_trs' Rs is = Some S"
shows "ffunas_trs S |\<subseteq>| \<F>" "lv_trs (fset S)"
proof -
from assms(2) have well: "\<forall>i \<in> set is. case_ftrs id id i < length Rs" "is_to_fin_trs Rs is = S"
unfolding is_to_trs'_def
by (auto simp add: guard_simps split: bind_splits)
have "\<forall> R \<in> set Rs. finite (fset R) \<and> lv_trs (fset R) \<and> funas_trs (fset R) \<subseteq> (fset \<F>)"
using assms(1) by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
from is_to_trs_props[of "map fset Rs" "fset \<F>" "is"] this well(1)
have "lv_trs (is_to_trs (map fset Rs) is)" "funas_trs (is_to_trs (map fset Rs) is) \<subseteq> fset \<F>"
by auto
then show "lv_trs (fset S)" "ffunas_trs S |\<subseteq>| \<F>"
using is_to_fin_trs_conv[OF well(1)] unfolding well(2)
by (auto simp: ffunas_trs.rep_eq less_eq_fset.rep_eq)
qed
subsection \<open>Computing GTTs\<close>
fun gtt_of_gtt_rel :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> (nat, 'f) gtt option" where
"gtt_of_gtt_rel \<F> Rs (ARoot is) = liftO1 (\<lambda>R. relabel_gtt (agtt_grrstep R \<F>)) (is_to_trs' Rs is)"
| "gtt_of_gtt_rel \<F> Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel \<F> Rs g)"
| "gtt_of_gtt_rel \<F> Rs (AUnion g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
| "gtt_of_gtt_rel \<F> Rs (ATrancl g) = liftO1 (relabel_gtt \<circ> AGTT_trancl) (gtt_of_gtt_rel \<F> Rs g)"
| "gtt_of_gtt_rel \<F> Rs (GTrancl g) = liftO1 GTT_trancl (gtt_of_gtt_rel \<F> Rs g)"
| "gtt_of_gtt_rel \<F> Rs (AComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_comp' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
| "gtt_of_gtt_rel \<F> Rs (GComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (GTT_comp' g1 g2)) (gtt_of_gtt_rel \<F> Rs g1) (gtt_of_gtt_rel \<F> Rs g2)"
lemma gtt_of_gtt_rel_correct:
assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
shows "gtt_of_gtt_rel \<F> Rs g = Some g' \<Longrightarrow> agtt_lang g' = eval_gtt_rel (fset \<F>) (map fset Rs) g"
proof (induct g arbitrary: g')
note [simp] = bind_eq_Some_conv guard_simps
have proj_sq: "fst ` (X \<times> X) = X" "snd ` (X \<times> X) = X" for X by auto
{
case (ARoot "is")
then obtain w where w:"is_to_trs' Rs is = Some w" by auto
then show ?case using ARoot is_to_trs'_props[OF assms w] is_to_trs_conv[OF w]
using agtt_grrstep
by auto
next
case (GInv g) then show ?case by (simp add: agtt_lang_swap gtt_states_def)
next
case (AUnion g1 g2)
from AUnion(3)[simplified, THEN conjunct1] AUnion(3)[simplified, THEN conjunct2, THEN conjunct1]
obtain w1 w2 where
[simp]: "gtt_of_gtt_rel \<F> Rs g1 = Some w1" "gtt_of_gtt_rel \<F> Rs g2 = Some w2"
by blast
then show ?case using AUnion(3)
by (simp add: AGTT_union'_sound AUnion)
next
case (ATrancl g)
from ATrancl[simplified] obtain w1 where
[simp]: "gtt_of_gtt_rel \<F> Rs g = Some w1" "g' = relabel_gtt (AGTT_trancl w1)" by auto
then have fin_lang: "eval_gtt_rel (fset \<F>) (map fset Rs) g = agtt_lang w1"
using ATrancl by auto
from fin_lang show ?case using AGTT_trancl_sound[of w1]
by auto
next
case (GTrancl g) note * = GTrancl(2)[simplified, THEN conjunct2]
show ?case unfolding gtt_of_gtt_rel.simps GTT_trancl_alang * gtrancl_rel_def eval_gtt_rel.simps gmctxt_cl_gmctxtex_onp_conv
proof ((intro conjI equalityI subrelI; (elim relcompE)?), goal_cases LR RL)
case (LR _ _ s _ z s' t' t)
show ?case using lift_root_steps_sig_transfer'[OF LR(2)[folded lift_root_step.simps], of "fset \<F>"]
lift_root_steps_sig_transfer[OF LR(5)[folded lift_root_step.simps], of "fset \<F>"]
image_mono[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g], of fst, unfolded proj_sq]
image_mono[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g], of snd, unfolded proj_sq]
subsetD[OF eval_gtt_rel_sig[of "fset \<F>" "map fset Rs" g]] LR(1, 3, 4) GTrancl
by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
(auto simp: \<T>\<^sub>G_funas_gterm_conv lift_root_step.simps)
next
case (RL _ _ s _ z s' t' t)
then show ?case using GTrancl
lift_root_step_mono[of "fset \<F>" UNIV PAny ESingle "eval_gtt_rel (fset \<F>) (map fset Rs) g", THEN rtrancl_mono]
unfolding lift_root_step.simps[symmetric]
by (intro relcompI[OF _ relcompI, of _ s' _ t' _])
(auto simp: \<T>\<^sub>G_funas_gterm_conv lift_root_step_mono trancl_mono)
qed
next
case (AComp g1 g2)
from AComp[simplified] obtain w1 w2 where
[simp]: "gtt_of_gtt_rel \<F> Rs g1 = Some w1" "gtt_of_gtt_rel \<F> Rs g2 = Some w2"
"g' = relabel_gtt (AGTT_comp' w1 w2)" by auto
then have fin_lang: "eval_gtt_rel (fset \<F>) (map fset Rs) g1 = agtt_lang w1"
"eval_gtt_rel (fset \<F>) (map fset Rs) g2 = agtt_lang w2"
using AComp by auto
from fin_lang AGTT_comp'_sound[of w1 w2]
show ?case by simp
next
case (GComp g1 g2)
let ?r = "\<lambda> g. eval_gtt_rel (fset \<F>) (map fset Rs) g"
have *: "gmctxtex_onp (\<lambda>C. True) (?r g1) = lift_root_step UNIV PAny EParallel (?r g1)"
"gmctxtex_onp (\<lambda>C. True) (?r g2) = lift_root_step UNIV PAny EParallel (?r g2)"
by (auto simp: lift_root_step.simps)
show ?case using GComp(3)
apply (intro conjI equalityI subrelI; simp add: gmctxt_cl_gmctxtex_onp_conv GComp(1,2) gtt_comp'_alang gcomp_rel_def * flip: lift_root_step.simps; elim conjE disjE exE relcompE)
subgoal for s t _ _ _ _ _ u
using image_mono[OF eval_gtt_rel_sig, of snd "fset \<F>" "map fset Rs", unfolded proj_sq]
apply (subst relcompI[of _ u "eval_gtt_rel _ _ g1", OF _ lift_root_step_sig_transfer[of _ UNIV PAny EParallel "_ g2" "fset \<F>"]])
apply (force simp add: subsetI \<T>\<^sub>G_equivalent_def)+
done
subgoal for s t _ _ _ _ _ u
using image_mono[OF eval_gtt_rel_sig, of fst "fset \<F>" "map fset Rs", unfolded proj_sq]
apply (subst relcompI[of _ u _ _ "eval_gtt_rel _ _ g2", OF lift_root_step_sig_transfer'[of _ UNIV PAny EParallel "_ g1" "fset \<F>"]])
apply (force simp add: subsetI \<T>\<^sub>G_equivalent_def)+
done
by (auto intro: subsetD[OF lift_root_step_mono[of "fset \<F>" UNIV]])
}
qed
subsection \<open>Computing RR1 and RR2 relations\<close>
definition "simplify_reg \<A> = (relabel_reg (trim_reg \<A>))"
lemma \<L>_simplify_reg [simp]: "\<L> (simplify_reg \<A>) = \<L> \<A>"
by (simp add: simplify_reg_def \<L>_trim)
lemma RR1_spec_simplify_reg[simp]:
"RR1_spec (simplify_reg \<A>) R = RR1_spec \<A> R"
by (auto simp: RR1_spec_def)
lemma RR2_spec_simplify_reg[simp]:
"RR2_spec (simplify_reg \<A>) R = RR2_spec \<A> R"
by (auto simp: RR2_spec_def)
lemma RRn_spec_simplify_reg[simp]:
"RRn_spec n (simplify_reg \<A>) R = RRn_spec n \<A> R"
by (auto simp: RRn_spec_def)
lemma RR1_spec_eps_free_reg[simp]:
"RR1_spec (eps_free_reg \<A>) R = RR1_spec \<A> R"
by (auto simp: RR1_spec_def \<L>_eps_free)
lemma RR2_spec_eps_free_reg[simp]:
"RR2_spec (eps_free_reg \<A>) R = RR2_spec \<A> R"
by (auto simp: RR2_spec_def \<L>_eps_free)
lemma RRn_spec_eps_free_reg[simp]:
"RRn_spec n (eps_free_reg \<A>) R = RRn_spec n \<A> R"
by (auto simp: RRn_spec_def \<L>_eps_free)
fun rr1_of_rr1_rel :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option"
and rr2_of_rr2_rel :: "('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option" where
"rr1_of_rr1_rel \<F> Rs R1Terms = Some (relabel_reg (term_reg \<F>))"
| "rr1_of_rr1_rel \<F> Rs (R1NF is) = liftO1 (\<lambda>R. (simplify_reg (nf_reg (fst |`| R) \<F>))) (is_to_trs' Rs is)"
| "rr1_of_rr1_rel \<F> Rs (R1Inf r) = liftO1 (\<lambda>R.
let \<A> = trim_reg R in
simplify_reg (proj_1_reg (Inf_reg_impl \<A>))
) (rr2_of_rr2_rel \<F> Rs r)"
| "rr1_of_rr1_rel \<F> Rs (R1Proj i r) = (case i of 0 \<Rightarrow>
liftO1 (trim_reg \<circ> proj_1_reg) (rr2_of_rr2_rel \<F> Rs r)
| _ \<Rightarrow> liftO1 (trim_reg \<circ> proj_2_reg) (rr2_of_rr2_rel \<F> Rs r))"
| "rr1_of_rr1_rel \<F> Rs (R1Union s1 s2) =
liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
| "rr1_of_rr1_rel \<F> Rs (R1Inter s1 s2) =
liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
| "rr1_of_rr1_rel \<F> Rs (R1Diff s1 s2) = liftO2 (\<lambda> x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
| "rr2_of_rr2_rel \<F> Rs (R2GTT_Rel g w x) =
(case w of PRoot \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g))
| PNonRoot \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> nhole_mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g))
| PAny \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> parallel_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_reg \<circ> mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel \<F> Rs g)))"
| "rr2_of_rr2_rel \<F> Rs (R2Diag s) =
liftO1 (\<lambda> x. fmap_funs_reg (\<lambda>f. (Some f, Some f)) x) (rr1_of_rr1_rel \<F> Rs s)"
| "rr2_of_rr2_rel \<F> Rs (R2Prod s1 s2) =
liftO2 (\<lambda> x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel \<F> Rs s1) (rr1_of_rr1_rel \<F> Rs s2)"
| "rr2_of_rr2_rel \<F> Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel \<F> Rs r)"
| "rr2_of_rr2_rel \<F> Rs (R2Union r1 r2) =
liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
| "rr2_of_rr2_rel \<F> Rs (R2Inter r1 r2) =
liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
| "rr2_of_rr2_rel \<F> Rs (R2Diff r1 r2) = liftO2 (\<lambda> x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
| "rr2_of_rr2_rel \<F> Rs (R2Comp r1 r2) = liftO2 (\<lambda> x y. simplify_reg (rr2_compositon \<F> x y))
(rr2_of_rr2_rel \<F> Rs r1) (rr2_of_rr2_rel \<F> Rs r2)"
abbreviation lhss where
"lhss R \<equiv> fst |`| R"
lemma rr12_of_rr12_rel_correct:
fixes Rs :: "(('f :: linorder, 'v) Term.term \<times> ('f, 'v) Term.term) fset list"
assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
shows "\<forall>ta1. rr1_of_rr1_rel \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
"\<forall>ta2. rr2_of_rr2_rel \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
proof (induct r1 and r2)
note [simp] = bind_eq_Some_conv guard_simps
let ?F = "fset \<F>" let ?Rs = "map fset Rs"
{
case R1Terms
then show ?case using term_automaton[of \<F>]
by (simp add: \<T>\<^sub>G_equivalent_def)
next
case (R1NF r)
consider (a) "\<exists> R. is_to_trs' Rs r = Some R" | (b) "is_to_trs' Rs r = None" by auto
then show ?case
proof (cases)
case a
from a obtain R where [simp]: "is_to_trs' Rs r = Some R" "is_to_fin_trs Rs r = R"
by (auto simp: is_to_trs'_def)
from is_to_trs'_props[OF assms this(1)] have inv: "ffunas_trs R |\<subseteq>| \<F>" "lv_trs (fset R)" .
from inv have fl: "\<forall> l |\<in>| lhss R. linear_term l"
- by (auto simp: lv_trs_def fmember.rep_eq split!: prod.splits)
+ by (auto simp: lv_trs_def fmember_iff_member_fset split!: prod.splits)
{fix s t assume ass: "(s, t) \<in> grstep (fset R)"
then obtain C l r \<sigma> where step: "(l, r) |\<in>| R" "term_of_gterm s = (C :: ('f, 'v) ctxt) \<langle>l \<cdot> \<sigma>\<rangle>" "term_of_gterm t = C\<langle>r \<cdot> \<sigma>\<rangle>"
- unfolding grstep_def by (auto simp: fmember.rep_eq dest!: rstep_imp_C_s_r)
+ unfolding grstep_def by (auto simp: fmember_iff_member_fset dest!: rstep_imp_C_s_r)
from step ta_nf_lang_sound[of l "lhss R" C \<sigma> \<F>]
have "s \<notin> \<L> (nf_reg (lhss R) \<F>)" unfolding \<L>_def
by (metis fimage_eqI fst_conv nf_reg_def reg.sel(1, 2) term_of_gterm_in_ta_lang_conv)}
note mem = this
have funas: "funas_trs (fset R) \<subseteq> ?F" using inv(1)
by (simp add: ffunas_trs.rep_eq less_eq_fset.rep_eq subsetD)
{fix s assume "s \<in> \<L> (nf_reg (lhss R) \<F>)"
then have "s \<in> NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
by (meson IntI NF_I \<T>\<^sub>G_funas_gterm_conv gta_lang_nf_ta_funas inf.cobounded1 mem subset_iff)}
moreover
{fix s assume ass: "s \<in> NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
then have *: "(term_of_gterm s, term_of_gterm t) \<notin> rstep (fset R)" for t using funas
- by (auto simp: funas_trs_def grstep_def NF_iff_no_step \<T>\<^sub>G_funas_gterm_conv fmember.rep_eq)
+ by (auto simp: funas_trs_def grstep_def NF_iff_no_step \<T>\<^sub>G_funas_gterm_conv fmember_iff_member_fset)
(meson R1NF_reps funas rstep.cases)
then have "s \<in> \<L> (nf_reg (lhss R) \<F>)" using fl ass
using ta_nf_\<L>_complete[OF fl, of _ \<F>] gta_lang_nf_ta_funas[of _ "lhss R" \<F>]
by (smt (verit, ccfv_SIG) IntE R1NF_reps \<T>\<^sub>G_sound fimageE funas notin_fset surjective_pairing)}
ultimately have "\<L> (nf_reg (lhss R) \<F>) = NF (Restr (grstep (fset R)) (\<T>\<^sub>G (fset \<F>))) \<inter> \<T>\<^sub>G (fset \<F>)"
by blast
then show ?thesis using fl(1)
by (simp add: RR1_spec_def is_to_trs_conv)
qed auto
next
case (R1Inf r)
consider (a) "\<exists> A. rr2_of_rr2_rel \<F> Rs r = Some A" | (b) " rr2_of_rr2_rel \<F> Rs r = None" by auto
then show ?case
proof cases
case a
have [simp]: "{u. (t, u) \<in> eval_rr2_rel ?F ?Rs r \<and> funas_gterm u \<subseteq> ?F} =
{u. (t, u) \<in> eval_rr2_rel ?F ?Rs r}" for t
using eval_rr12_rel_sig(2)[of ?F ?Rs r] by (auto simp: \<T>\<^sub>G_equivalent_def)
have [simp]: "infinite {u. (t, u) \<in> eval_rr2_rel ?F ?Rs r} \<Longrightarrow> funas_gterm t \<subseteq> ?F" for t
using eval_rr12_rel_sig(2)[of ?F ?Rs r] not_finite_existsD by (fastforce simp: \<T>\<^sub>G_equivalent_def)
from a obtain A where [simp]: "rr2_of_rr2_rel \<F> Rs r = Some A" by blast
from R1Inf this have spec: "RR2_spec A (eval_rr2_rel ?F ?Rs r)" by auto
then have spec_trim: "RR2_spec (trim_reg A) (eval_rr2_rel ?F ?Rs r)" by auto
let ?B = "(Inf_reg (trim_reg A) (Q_infty (ta (trim_reg A)) \<F>))"
have B: "RR2_spec ?B {(s, t) | s t. gpair s t \<in> \<L> ?B}"
using subset_trans[OF Inf_automata_subseteq[of "trim_reg A" \<F>], of "\<L> A"] spec
by (auto simp: RR2_spec_def \<L>_trim)
have *: "\<L> (Inf_reg_impl (trim_reg A)) = \<L> ?B" using spec
using eval_rr12_rel_sig(2)[of ?F ?Rs r]
by (intro Inf_reg_impl_sound) (auto simp: \<L>_trim RR2_spec_def \<T>\<^sub>G_equivalent_def)
then have **: "RR2_spec (Inf_reg_impl (trim_reg A)) {(s, t) | s t. gpair s t \<in> \<L> ?B}" using B
by (auto simp: RR2_spec_def)
show ?thesis
using spec eval_rr12_rel_sig(2)[of ?F ?Rs r]
using \<L>_Inf_reg[OF spec_trim, of \<F>]
by (auto simp: \<T>\<^sub>G_equivalent_def * RR1_spec_def \<L>_trim \<L>_proj(1)[OF **]
Inf_branching_terms_def fImage_singleton)
(metis (no_types, lifting) SigmaD1 in_mono mem_Collect_eq not_finite_existsD)
qed auto
next
case (R1Proj i r)
then show ?case
proof (cases i)
case [simp]:0 show ?thesis using R1Proj
using proj_automaton_gta_lang(1)[of "the (rr2_of_rr2_rel \<F> Rs r)" "eval_rr2_rel ?F ?Rs r"]
by simp
next
case (Suc nat) then show ?thesis using R1Proj
using proj_automaton_gta_lang(2)[of "the (rr2_of_rr2_rel \<F> Rs r)" "eval_rr2_rel ?F ?Rs r"]
by simp
qed
next
case (R1Union s1 s2)
then show ?case
by (auto simp: RR1_spec_def \<L>_union)
next
case (R1Inter s1 s2)
from R1Inter show ?case
by (auto simp: \<L>_intersect RR1_spec_def)
next
case (R1Diff s1 s2)
then show ?case
by (auto intro: RR1_difference)
next
case (R2GTT_Rel g w x)
note ass = R2GTT_Rel
consider (a) "\<exists> A. gtt_of_gtt_rel \<F> Rs g = Some A" | (b) "gtt_of_gtt_rel \<F> Rs g = None" by blast
then show ?case
proof cases
case a then obtain A where [simp]: "gtt_of_gtt_rel \<F> Rs g = Some A" by blast
from gtt_of_gtt_rel_correct[OF assms this]
have spec [simp]: "eval_gtt_rel ?F ?Rs g = agtt_lang A" by auto
let ?B = "GTT_to_RR2_root_reg A" note [simp] = GTT_to_RR2_root[of A]
show ?thesis
proof (cases w)
case [simp]: PRoot show ?thesis
proof (cases x)
case EParallel
then show ?thesis using reflcl_automaton[of ?B "agtt_lang A" \<F>]
by auto
qed (auto simp: GTT_to_RR2_root)
next
case PNonRoot
then show ?thesis
using nhole_ctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
using nhole_mctxt_reflcl_automaton[of ?B "agtt_lang A" \<F>]
using nhole_mctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
by (cases x) auto
next
case PAny
then show ?thesis
using ctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
using parallel_closure_automaton[of ?B "agtt_lang A" \<F>]
using mctxt_closure_automaton[of ?B "agtt_lang A" \<F>]
by (cases x) auto
qed
qed (cases w; cases x, auto)
next
case (R2Diag s)
then show ?case
by (auto simp: RR2_spec_def RR1_spec_def fmap_funs_\<L> Id_on_iff
fmap_funs_gta_lang map_funs_term_some_gpair)
next
case (R2Prod s1 s2)
then show ?case using pair_automaton[of "the (rr1_of_rr1_rel \<F> Rs s1)" _ "the (rr1_of_rr1_rel \<F> Rs s2)"]
by auto
next
case (R2Inv r)
show ?case using R2Inv by (auto simp: swap_RR2_spec)
next
case (R2Union r1 r2)
then show ?case using union_automaton
by (auto simp: RR2_spec_def \<L>_union)
next
case (R2Inter r1 r2)
then show ?case
by (auto simp: \<L>_intersect RR2_spec_def)
next
case (R2Diff r1 r2)
then show ?case by (auto intro: RR2_difference)
next
case (R2Comp r1 r2)
then show ?case using eval_rr12_rel_sig
by (auto intro!: rr2_compositon) blast+
}
qed
subsection \<open>Misc\<close>
lemma eval_formula_arity_cong:
assumes "\<And>i. i < formula_arity f \<Longrightarrow> \<alpha>' i = \<alpha> i"
shows "eval_formula \<F> Rs \<alpha>' f = eval_formula \<F> Rs \<alpha> f"
proof -
have [simp]: "j < length fs \<Longrightarrow> i < formula_arity (fs ! j) \<Longrightarrow> i < max_list (map formula_arity fs)" for i j fs
by (simp add: less_le_trans max_list)
show ?thesis using assms
proof (induct f arbitrary: \<alpha> \<alpha>')
case (FAnd fs)
show ?case using FAnd(1)[OF nth_mem, of _ \<alpha>' \<alpha>] FAnd(2) by (auto simp: all_set_conv_all_nth)
next
case (FOr fs)
show ?case using FOr(1)[OF nth_mem, of _ \<alpha>' \<alpha>] FOr(2) by (auto simp: ex_set_conv_ex_nth)
next
case (FNot f)
show ?case using FNot(1)[of \<alpha>' \<alpha>] FNot(2) by simp
next
case (FExists f)
show ?case using FExists(1)[of "\<alpha>'\<langle>0 : z\<rangle>" "\<alpha>\<langle>0 : z\<rangle>" for z] FExists(2) by (auto simp: shift_def)
next
case (FForall f)
show ?case using FForall(1)[of "\<alpha>'\<langle>0 : z\<rangle>" "\<alpha>\<langle>0 : z\<rangle>" for z] FForall(2) by (auto simp: shift_def)
qed simp_all
qed
subsection \<open>Connect semantics to FOL-Fitting\<close>
primrec form_of_formula :: "'trs formula \<Rightarrow> (unit, 'trs rr1_rel + 'trs rr2_rel) form" where
"form_of_formula (FRR1 r1 x) = Pred (Inl r1) [Var x]"
| "form_of_formula (FRR2 r2 x y) = Pred (Inr r2) [Var x, Var y]"
| "form_of_formula (FAnd fs) = foldr And (map form_of_formula fs) TT"
| "form_of_formula (FOr fs) = foldr Or (map form_of_formula fs) FF"
| "form_of_formula (FNot f) = Neg (form_of_formula f)"
| "form_of_formula (FExists f) = Exists (And (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"
| "form_of_formula (FForall f) = Forall (Impl (Pred (Inl R1Terms) [Var 0]) (form_of_formula f))"
fun for_eval_rel :: "('f \<times> nat) set \<Rightarrow> ('f, 'v) trs list \<Rightarrow> ftrs rr1_rel + ftrs rr2_rel \<Rightarrow> 'f gterm list \<Rightarrow> bool" where
"for_eval_rel \<F> Rs (Inl r1) [t] \<longleftrightarrow> t \<in> eval_rr1_rel \<F> Rs r1"
| "for_eval_rel \<F> Rs (Inr r2) [t, u] \<longleftrightarrow> (t, u) \<in> eval_rr2_rel \<F> Rs r2"
lemma eval_formula_conv:
"eval_formula \<F> Rs \<alpha> f = eval \<alpha> undefined (for_eval_rel \<F> Rs) (form_of_formula f)"
proof (induct f arbitrary: \<alpha>)
case (FAnd fs) then show ?case
unfolding eval_formula.simps by (induct fs) auto
next
case (FOr fs) then show ?case
unfolding eval_formula.simps by (induct fs) auto
qed auto
subsection \<open>RRn relations and formulas\<close>
lemma shift_rangeI [intro!]:
"range \<alpha> \<subseteq> T \<Longrightarrow> x \<in> T \<Longrightarrow> range (shift \<alpha> i x) \<subseteq> T"
by (auto simp: shift_def)
definition formula_relevant where
"formula_relevant \<F> Rs vs fm \<longleftrightarrow>
(\<forall>\<alpha> \<alpha>'. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G \<F> \<longrightarrow> map \<alpha> vs = map \<alpha>' vs \<longrightarrow> eval_formula \<F> Rs \<alpha> fm \<longrightarrow> eval_formula \<F> Rs \<alpha>' fm)"
lemma formula_relevant_mono:
"set vs \<subseteq> set ws \<Longrightarrow> formula_relevant \<F> Rs vs fm \<Longrightarrow> formula_relevant \<F> Rs ws fm"
unfolding formula_relevant_def
by (meson map_eq_conv subset_code(1))
lemma formula_relevantD:
"formula_relevant \<F> Rs vs fm \<Longrightarrow>
range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> map \<alpha> vs = map \<alpha>' vs \<Longrightarrow>
eval_formula \<F> Rs \<alpha> fm \<Longrightarrow> eval_formula \<F> Rs \<alpha>' fm"
unfolding formula_relevant_def
by blast
lemma trivial_formula_relevant:
assumes "\<And>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> \<not> eval_formula \<F> Rs \<alpha> fm"
shows "formula_relevant \<F> Rs vs fm"
using assms unfolding formula_relevant_def
by auto
lemma formula_relevant_0_FExists:
assumes "formula_relevant \<F> Rs [0] fm"
shows "formula_relevant \<F> Rs [] (FExists fm)"
unfolding formula_relevant_def
proof (intro allI, intro impI)
fix \<alpha> \<alpha>' assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range (\<alpha>' :: fvar \<Rightarrow> 'a gterm) \<subseteq> \<T>\<^sub>G \<F>"
"eval_formula \<F> Rs \<alpha> (FExists fm)"
from ass(3) obtain z where "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) fm"
by auto
then show "eval_formula \<F> Rs \<alpha>' (FExists fm)"
using ass(1, 2) formula_relevantD[OF assms, of "\<alpha>\<langle>0:z\<rangle>" "\<alpha>'\<langle>0:z\<rangle>"]
by (auto simp: shift_rangeI intro!: exI[of _ z])
qed
definition formula_spec where
"formula_spec \<F> Rs vs A fm \<longleftrightarrow> sorted vs \<and> distinct vs \<and>
formula_relevant \<F> Rs vs fm \<and>
RRn_spec (length vs) A {map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm}"
lemma formula_spec_RRn_spec:
"formula_spec \<F> Rs vs A fm \<Longrightarrow> RRn_spec (length vs) A {map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm}"
by (simp add: formula_spec_def)
lemma formula_spec_nt_empty_form_sat:
"\<not> reg_empty A \<Longrightarrow> formula_spec \<F> Rs vs A fm \<Longrightarrow> \<exists> \<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm"
unfolding formula_spec_def
by (auto simp: RRn_spec_def \<L>_def)
lemma formula_spec_empty:
"reg_empty A \<Longrightarrow> formula_spec \<F> Rs vs A fm \<Longrightarrow> range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<Longrightarrow> eval_formula \<F> Rs \<alpha> fm \<longleftrightarrow> False"
unfolding formula_spec_def
by (auto simp: RRn_spec_def \<L>_def)
text \<open>In each inference step, we obtain a triple consisting of a formula @{term "fm"}, a list of
relevant variables @{term "vs"} (typically a sublist of @{term "[0..<formula_arity fm]"}), and
an RRn automaton @{term "A"}, such that the property @{term "formula_spec \<F> Rs vs A fm"} holds.\<close>
lemma false_formula_spec:
"sorted vs \<Longrightarrow> distinct vs \<Longrightarrow> formula_spec \<F> Rs vs empty_reg FFalse"
by (auto simp: formula_spec_def false_RRn_spec FFalse_def formula_relevant_def)
lemma true_formula_spec:
assumes "vs \<noteq> [] \<or> \<T>\<^sub>G (fset \<F>) \<noteq> {}" "sorted vs" "distinct vs"
shows "formula_spec (fset \<F>) Rs vs (true_RRn \<F> (length vs)) FTrue"
proof -
have "{ts. length ts = length vs \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} = {map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>)}"
proof (intro equalityI subsetI CollectI, goal_cases LR RL)
case (LR ts)
moreover obtain t0 where "funas_gterm t0 \<subseteq> fset \<F>" using LR assms(1) unfolding \<T>\<^sub>G_equivalent_def
by (cases vs) fastforce+
ultimately show ?case using `distinct vs`
apply (intro exI[of _ "\<lambda>t. if t \<in> set vs then ts ! inv_into {0..<length vs} ((!) vs) t else t0"])
apply (auto intro!: nth_equalityI dest!: inj_on_nth[of vs "{0..<length vs}"] simp: in_set_conv_nth \<T>\<^sub>G_equivalent_def)
by (metis inv_to_set mem_Collect_eq subsetD)
qed fastforce
then show ?thesis using assms true_RRn_spec[of "length vs" \<F>]
by (auto simp: formula_spec_def FTrue_def formula_relevant_def \<T>\<^sub>G_equivalent_def)
qed
lemma relabel_formula_spec:
"formula_spec \<F> Rs vs A fm \<Longrightarrow> formula_spec \<F> Rs vs (relabel_reg A) fm"
by (simp add: formula_spec_def)
lemma trim_formula_spec:
"formula_spec \<F> Rs vs A fm \<Longrightarrow> formula_spec \<F> Rs vs (trim_reg A) fm"
by (simp add: formula_spec_def)
definition fit_permute :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
"fit_permute vs vs' vs'' = map (\<lambda>v. if v \<in> set vs then the (mem_idx v vs) else length vs + the (mem_idx v vs'')) vs'"
definition fit_rrn :: "('f \<times> nat) fset \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> (nat, 'f option list) reg \<Rightarrow> (_, 'f option list) reg" where
"fit_rrn \<F> vs vs' A = (let vs'' = subtract_list_sorted vs' vs in
fmap_funs_reg (\<lambda>fs. map ((!) fs) (fit_permute vs vs' vs''))
(fmap_funs_reg (pad_with_Nones (length vs) (length vs'')) (pair_automaton_reg A (true_RRn \<F> (length vs'')))))"
lemma the_mem_idx_simp [simp]:
"distinct xs \<Longrightarrow> i < length xs \<Longrightarrow> the (mem_idx (xs ! i) xs) = i"
using mem_idx_sound[THEN iffD1, OF nth_mem, of i xs] mem_idx_sound_output[of "xs ! i" xs] distinct_conv_nth
by fastforce
lemma fit_rrn:
assumes spec: "formula_spec (fset \<F>) Rs vs A fm" and vs: "sorted vs'" "distinct vs'" "set vs \<subseteq> set vs'"
shows "formula_spec (fset \<F>) Rs vs' (fit_rrn \<F> vs vs' A) fm"
using spec unfolding formula_spec_def formula_relevant_def
apply (elim conjE)
proof (intro conjI vs(1,2) allI, goal_cases rel spec)
case (rel \<alpha> \<alpha>') show ?case using vs(3)
by (fastforce intro!: rel(3)[rule_format, of \<alpha> \<alpha>'])
next
case spec
define vs'' where "vs'' = subtract_list_sorted vs' vs"
have evalI: "range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> range \<alpha>' \<subseteq> \<T>\<^sub>G (fset \<F>) \<Longrightarrow> map \<alpha> vs = map \<alpha>' vs
\<Longrightarrow> eval_formula (fset \<F>) Rs \<alpha> fm \<Longrightarrow> eval_formula (fset \<F>) Rs \<alpha>' fm" for \<alpha> \<alpha>'
using spec(3) by blast
have [simp]: "set vs' = set vs \<union> set vs''" "set vs'' \<inter> set vs = {}" "set vs \<inter> set vs'' = {}" and d: "distinct vs''"
using vs spec(1,2) by (auto simp: vs''_def)
then have [dest]: "v \<in> set vs'' \<Longrightarrow> v \<in> set vs \<Longrightarrow> False" for v by blast
note * = permute_automaton[OF append_automaton[OF spec(4) true_RRn_spec, of "length vs''"]]
have [simp]: "distinct vs \<Longrightarrow> i \<in> set vs \<Longrightarrow> vs ! the (mem_idx i vs) = (i :: nat)" for vs i
by (simp add: mem_idx_sound mem_idx_sound_output)
have [dest]: "distinct vs \<Longrightarrow> i \<in> set vs \<Longrightarrow> \<not> the (mem_idx i vs) < length vs \<Longrightarrow> False" for i
by (meson mem_idx_sound2 mem_idx_sound_output option.exhaust_sel)
show ?case unfolding fit_rrn_def Let_def vs''_def[symmetric] \<T>\<^sub>G_equivalent_def
apply (rule subst[where P = "\<lambda>l. RRn_spec l _ _", OF _ subst[where P = "\<lambda>ta. RRn_spec _ _ ta", OF _ *]])
subgoal by (simp add: fit_permute_def)
subgoal
apply (intro equalityI subsetI CollectI imageI; elim imageE CollectE exE conjE; unfold \<T>\<^sub>G_equivalent_def)
subgoal for x fs ts us \<alpha>
using spec(1, 2) d
apply (intro exI[of _ "\<lambda>v. if v \<in> set vs'' then us ! the (mem_idx v vs'') else \<alpha> v"])
apply (auto simp: fit_permute_def nth_append \<T>\<^sub>G_equivalent_def
intro!: nth_equalityI evalI[of \<alpha> "\<lambda>v. if v \<in> set vs'' then us ! the (mem_idx v vs'') else \<alpha> v"])
apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
apply (metis distinct_Ex1 in_mono mem_Collect_eq nth_mem the_mem_idx_simp)
apply blast
by (meson \<open>\<And>va. \<lbrakk>va \<in> set vs''; va \<in> set vs\<rbrakk> \<Longrightarrow> False\<close> nth_mem)
subgoal premises p for xs \<alpha>
apply (intro rev_image_eqI[of "map \<alpha> (vs @ vs'')"])
subgoal using p by (force intro!: exI[of _ "map \<alpha> vs", OF exI[of _ "map \<alpha> vs''"]])
subgoal using p(1)
by (force intro!: nth_equalityI simp: fit_permute_def comp_def nth_append dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
done
done
subgoal using vs spec(1,2) unfolding fit_permute_def
apply (intro equalityI subsetI)
subgoal by (auto 0 3 dest: iffD1[OF mem_idx_sound] mem_idx_sound_output)
subgoal for x
apply (simp add: Compl_eq[symmetric] Diff_eq[symmetric] Un_Diff Diff_triv Int_absorb1)
apply (simp add: nth_image[symmetric, of "length xs" xs for xs, simplified] image_iff comp_def)
using image_cong[OF refl arg_cong[OF the_mem_idx_simp]] \<open>distinct vs''\<close>
by (smt (z3) add_diff_inverse_nat add_less_cancel_left atLeast0LessThan lessThan_iff the_mem_idx_simp)
done
done
qed
definition fit_rrns :: "('f \<times> nat) fset \<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list \<Rightarrow>
nat list \<times> ((nat, 'f option list) reg) list" where
"fit_rrns \<F> rrns = (let vs' = fold union_list_sorted (map (fst \<circ> snd) rrns) [] in
(vs', map (\<lambda>(fm, vs, ta). relabel_reg (trim_reg (fit_rrn \<F> vs vs' ta))) rrns))"
lemma sorted_union_list_sortedI [simp]:
"sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> sorted (union_list_sorted xs ys)"
by (induct xs ys rule: union_list_sorted.induct) auto
lemma distinct_union_list_sortedI [simp]:
"sorted xs \<Longrightarrow> sorted ys \<Longrightarrow> distinct xs \<Longrightarrow> distinct ys \<Longrightarrow> distinct (union_list_sorted xs ys)"
by (induct xs ys rule: union_list_sorted.induct) auto
lemma fit_rrns:
assumes infs: "\<And>fvA. fvA \<in> set rrns \<Longrightarrow> formula_spec (fset \<F>) Rs (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
assumes "(vs', tas') = fit_rrns \<F> rrns"
shows "length tas' = length rrns" "\<And>i. i < length rrns \<Longrightarrow> formula_spec (fset \<F>) Rs vs' (tas' ! i) (fst (rrns ! i))"
"distinct vs'" "sorted vs'"
proof (goal_cases)
have vs': "vs' = fold union_list_sorted (map (fst \<circ> snd) rrns) []" using assms(2) by (simp add: fit_rrns_def Let_def)
have *: "sorted vs'" "distinct vs'" "\<And>fvA. fvA \<in> set rrns \<Longrightarrow> set (fst (snd fvA)) \<subseteq> set vs'"
using infs[unfolded formula_spec_def, THEN conjunct2, THEN conjunct1]
infs[unfolded formula_spec_def, THEN conjunct1]
unfolding vs' by (induct rrns rule: rev_induct) auto
{
case 1 then show ?case using assms(2) by (simp add: fit_rrns_def Let_def)
next
case (2 i)
have tas': "tas' ! i = relabel_reg (trim_reg (fit_rrn \<F> (fst (snd (rrns ! i))) vs' (snd (snd (rrns ! i)))))"
using 2 assms(2) by (simp add: fit_rrns_def Let_def split: prod.splits)
from *(1,2) *(3)[OF nth_mem] show ?case using 2 unfolding tas'
by (auto intro!: relabel_formula_spec trim_formula_spec fit_rrn 2 assms(1,2))
next
case 3 show ?case by (rule *)
next
case 4 show ?case by (rule *)
}
qed
subsection \<open>Building blocks\<close>
definition for_rrn where
"for_rrn tas = fold (\<lambda>A B. relabel_reg (reg_union A B)) tas (Reg {||} (TA {||} {||}))"
lemma for_rrn:
assumes "length tas = length fs" "\<And>i. i < length fs \<Longrightarrow> formula_spec \<F> Rs vs (tas ! i) (fs ! i)"
and vs: "sorted vs" "distinct vs"
shows "formula_spec \<F> Rs vs (for_rrn tas) (FOr fs)"
using assms(1,2) unfolding for_rrn_def
proof (induct fs arbitrary: tas rule: rev_induct)
case Nil then show ?case using vs false_formula_spec[of vs \<F> Rs] by (auto simp: FFalse_def)
next
case (snoc fm fs)
have *: "Bex (set [x]) P = P x" for P x by auto
have [intro!]: "formula_spec \<F> Rs vs (reg_union A B) (FOr (fs @ [fm]))" if
"formula_spec \<F> Rs vs A fm" "formula_spec \<F> Rs vs B (FOr fs)" for A B using that
unfolding formula_spec_def
apply (intro conjI, blast, blast)
subgoal unfolding formula_relevant_def eval_formula.simps set_append bex_Un * by blast
apply (elim conjE)
subgoal premises p by (rule subst[of _ _ "RRn_spec _ _", OF _ union_automaton[OF p(6,8)]]) auto
done
show ?case using snoc(1)[of "take (length fs) tas"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
by (cases tas rule: rev_exhaust) (auto simp: min_def nth_append intro!: relabel_formula_spec)
qed
fun fand_rrn where
"fand_rrn \<F> n [] = true_RRn \<F> n"
| "fand_rrn \<F> n (A # tas) = fold (\<lambda>A B. simplify_reg (reg_intersect A B)) tas A"
lemma fand_rrn:
assumes "\<T>\<^sub>G (fset \<F>) \<noteq> {}" "length tas = length fs" "\<And>i. i < length fs \<Longrightarrow> formula_spec (fset \<F>) Rs vs (tas ! i) (fs ! i)"
and vs: "sorted vs" "distinct vs"
shows "formula_spec (fset \<F>) Rs vs (fand_rrn \<F> (length vs) tas) (FAnd fs)"
proof (cases fs)
case Nil
have "tas = []" using assms(2) by (auto simp: Nil)
then show ?thesis using true_formula_spec[OF _ vs, of \<F> Rs] assms(1) Nil
by (simp add: FTrue_def)
next
case (Cons fm fs)
obtain ta tas' where tas: "tas = ta # tas'" using assms(2) Cons by (cases tas) auto
show ?thesis using assms(2) assms(3)[of "Suc _"] unfolding tas Cons
unfolding list.size add_Suc_right add_0_right nat.inject Suc_less_eq nth_Cons_Suc fand_rrn.simps
proof (induct fs arbitrary: tas' rule: rev_induct)
case Nil
have "formula_relevant (fset \<F>) Rs vs (FAnd [fm])" using assms(3)[of 0]
apply (simp add: tas Cons formula_spec_def)
unfolding formula_relevant_def eval_formula.simps in_set_simps by blast
then show ?case using assms(3)[of 0, unfolded tas Cons, simplified] Nil by (simp add: formula_spec_def)
next
case (snoc fm' fs)
have *: "Ball (insert x X) P \<longleftrightarrow> P x \<and> Ball X P" for P x X by auto
have [intro!]: "formula_spec (fset \<F>) Rs vs (reg_intersect A B) (FAnd (fm # fs @ [fm']))" if
"formula_spec (fset \<F>) Rs vs A fm'" "formula_spec (fset \<F>) Rs vs B (FAnd (fm # fs))" for A B using that
unfolding formula_spec_def
apply (intro conjI, blast, blast)
subgoal unfolding formula_relevant_def eval_formula.simps set_append set_simps ball_simps ball_Un in_set_simps *
by blast
apply (elim conjE)
subgoal premises p
by (rule subst[of _ _ "RRn_spec _ _", OF _ intersect_automaton[OF p(6,8)]])
(auto dest: p(5)[unfolded formula_relevant_def, rule_format])
done
show ?case using snoc(1)[of "take (length fs) tas'"] snoc(2) snoc(3)[simplified, OF less_SucI] snoc(3)[of "length fs"] vs
by (cases tas' rule: rev_exhaust) (auto simp: min_def nth_append simplify_reg_def intro!: relabel_formula_spec trim_formula_spec)
qed
qed
subsubsection \<open>IExists inference rule\<close>
lemma lift_fun_gpairD:
"map_gterm lift_fun s = gpair t u \<Longrightarrow> t = s"
"map_gterm lift_fun s = gpair t u \<Longrightarrow> u = s"
by (metis gfst_gpair gsnd_gpair map_funs_term_some_gpair)+
definition upd_bruijn :: "nat list \<Rightarrow> nat list" where
"upd_bruijn vs = tl (map (\<lambda> x. x - 1) vs)"
lemma upd_bruijn_length[simp]:
"length (upd_bruijn vs) = length vs - 1"
by (induct vs) (auto simp: upd_bruijn_def)
lemma pres_sorted_dec:
"sorted xs \<Longrightarrow> sorted (map (\<lambda>x. x - Suc 0) xs)"
by (induct xs) auto
lemma upd_bruijn_pres_sorted:
"sorted xs \<Longrightarrow> sorted (upd_bruijn xs)"
unfolding upd_bruijn_def
by (intro sorted_tl) (auto simp: pres_sorted_dec)
lemma pres_distinct_not_0_list_dec:
"distinct xs \<Longrightarrow> 0 \<notin> set xs \<Longrightarrow> distinct (map (\<lambda>x. x - Suc 0) xs)"
by (induct xs) (auto, metis Suc_pred neq0_conv)
lemma upd_bruijn_pres_distinct:
assumes "sorted xs" "distinct xs"
shows "distinct (upd_bruijn xs)"
proof -
have "sorted (ys :: nat list) \<Longrightarrow> distinct ys \<Longrightarrow> 0 \<notin> set (tl ys)" for ys
by (induct ys) auto
from this[OF assms] show ?thesis using assms(2)
using pres_distinct_not_0_list_dec[OF distinct_tl, OF assms(2)]
unfolding upd_bruijn_def
by (simp add: map_tl)
qed
lemma upd_bruijn_relevant_inv:
assumes "sorted vs" "distinct vs" "0 \<in> set vs"
and "\<And> x. x \<in> set (upd_bruijn vs) \<Longrightarrow> \<alpha> x = \<alpha>' x"
shows "\<And> x. x \<in> set vs \<Longrightarrow> (shift \<alpha> 0 z) x = (shift \<alpha>' 0 z) x"
using assms unfolding upd_bruijn_def
by (induct vs) (auto simp add: FOL_Fitting.shift_def)
lemma ExistsI_upd_brujin_0:
assumes "sorted vs" "distinct vs" "0 \<in> set vs" "formula_relevant \<F> Rs vs fm"
shows "formula_relevant \<F> Rs (upd_bruijn vs) (FExists fm)"
unfolding formula_relevant_def
proof (intro allI, intro impI)
fix \<alpha> \<alpha>' assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range (\<alpha>' :: fvar \<Rightarrow> 'a gterm) \<subseteq> \<T>\<^sub>G \<F>"
"map \<alpha> (upd_bruijn vs) = map \<alpha>' (upd_bruijn vs)" "eval_formula \<F> Rs \<alpha> (FExists fm)"
from ass(4) obtain z where "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0 : z\<rangle>) fm"
by auto
then show "eval_formula \<F> Rs \<alpha>' (FExists fm)"
using ass(1 - 3) formula_relevantD[OF assms(4), of "\<alpha>\<langle>0:z\<rangle>" "\<alpha>'\<langle>0:z\<rangle>"]
using upd_bruijn_relevant_inv[OF assms(1 - 3), of "\<alpha>" "\<alpha>'"]
by (auto simp: shift_rangeI intro!: exI[of _ z])
qed
declare subsetI[rule del]
lemma ExistsI_upd_brujin_no_0:
assumes "0 \<notin> set vs" and "formula_relevant \<F> Rs vs fm"
shows "formula_relevant \<F> Rs (map (\<lambda>x. x - Suc 0) vs) (FExists fm)"
unfolding formula_relevant_def
proof ((intro allI)+ , (intro impI)+, unfold eval_formula.simps)
fix \<alpha> \<alpha>' assume st: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "range \<alpha>' \<subseteq> \<T>\<^sub>G \<F>"
"map \<alpha> (map (\<lambda>x. x - Suc 0) vs) = map \<alpha>' (map (\<lambda>x. x - Suc 0) vs)"
"\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (shift \<alpha> 0 z) fm"
then obtain z where w: "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift \<alpha> 0 z) fm" by auto
from this(1) have "eval_formula \<F> Rs (shift \<alpha>' 0 z) fm"
using st(1 - 3) assms(1) FOL_Fitting.shift_def
apply (intro formula_relevantD[OF assms(2) _ _ _ w(2), of "shift \<alpha>' 0 z"])
by auto (simp add: FOL_Fitting.shift_def)
then show "\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (shift \<alpha>' 0 z) fm" using w(1)
by blast
qed
definition shift_right where
"shift_right \<alpha> \<equiv> \<lambda> i. \<alpha> (i + 1)"
lemma shift_right_nt_0:
"i \<noteq> 0 \<Longrightarrow> \<alpha> i = shift_right \<alpha> (i - Suc 0)"
unfolding shift_right_def
by auto
lemma shift_shift_right_id [simp]:
"shift (shift_right \<alpha>) 0 (\<alpha> 0) = \<alpha>"
by (auto simp: shift_def shift_right_def)
lemma shift_right_rangeI [intro]:
"range \<alpha> \<subseteq> T \<Longrightarrow> range (shift_right \<alpha>) \<subseteq> T"
by (auto simp: shift_right_def intro: subsetI)
lemma eval_formula_shift_right_eval:
"eval_formula \<F> Rs \<alpha> fm \<Longrightarrow> eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
"eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm \<Longrightarrow> eval_formula \<F> Rs \<alpha> fm"
by (auto)
declare subsetI[intro!]
lemma nt_rel_0_trivial_shift:
assumes "0 \<notin> set vs"
shows "{map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm} =
{map (\<lambda>x. \<alpha> (x - Suc 0)) vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists>z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)}"
(is "?Ls = ?Rs")
proof
{fix \<alpha> assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
then have "map \<alpha> vs = map (\<lambda>x. (shift_right \<alpha>) (x - Suc 0)) vs"
"range (shift_right \<alpha>) \<subseteq> \<T>\<^sub>G \<F>" "\<alpha> 0 \<in>\<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
using shift_right_rangeI[OF ass(1)] assms
by (auto intro: eval_formula_shift_right_eval(1), metis shift_right_nt_0)}
then show "?Ls \<subseteq> ?Rs"
by blast
next
show "?Rs \<subseteq> ?Ls"
by auto (metis FOL_Fitting.shift_def One_nat_def assms not_less0 shift_rangeI)
qed
lemma relevant_vars_upd_bruijn_tl:
assumes "sorted vs" "distinct vs"
shows "map (shift_right \<alpha>) (upd_bruijn vs) = tl (map \<alpha> vs)" using assms
proof (induct vs)
case (Cons a vs) then show ?case
using le_antisym
by (auto simp: upd_bruijn_def shift_right_def)
(metis One_nat_def Suc_eq_plus1 le_0_eq shift_right_def shift_right_nt_0)
qed (auto simp: upd_bruijn_def)
lemma drop_upd_bruijn_set:
assumes "sorted vs" "distinct vs"
shows "drop 1 ` {map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> eval_formula \<F> Rs \<alpha> fm} =
{map \<alpha> (upd_bruijn vs) |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists>z\<in>\<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)}"
(is "?Ls = ?Rs")
proof
{fix \<alpha> assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
then have "drop 1 (map \<alpha> vs) = map (shift_right \<alpha>) (upd_bruijn vs)"
"range (shift_right \<alpha>) \<subseteq> \<T>\<^sub>G \<F>" "\<alpha> 0 \<in>\<T>\<^sub>G \<F>" "eval_formula \<F> Rs (shift (shift_right \<alpha>) 0 (\<alpha> 0)) fm"
using shift_right_rangeI[OF ass(1)]
by (auto simp: tl_drop_conv relevant_vars_upd_bruijn_tl[OF assms(1, 2)])}
then show "?Ls \<subseteq> ?Rs"
by blast
next
have [dest]: "0 \<in> set (tl vs) \<Longrightarrow> False" using assms(1, 2)
by (cases vs) auto
{fix \<alpha> z assume ass: "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "z \<in> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm"
then have "map \<alpha> (upd_bruijn vs) = tl (map (\<alpha>\<langle>0:z\<rangle>) vs)"
"range (\<alpha>\<langle>0:z\<rangle>) \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm"
using shift_rangeI[OF ass(1)]
by (auto simp: upd_bruijn_def shift_def simp flip: map_tl)}
then show "?Rs \<subseteq> ?Ls"
by (auto simp: tl_drop_conv image_def) blast
qed
lemma closed_sat_form_env_dom:
assumes "formula_relevant \<F> Rs [] (FExists fm)" "range \<alpha> \<subseteq> \<T>\<^sub>G \<F>" "eval_formula \<F> Rs \<alpha> fm"
shows "{[\<alpha> 0] |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G \<F> \<and> (\<exists> z \<in> \<T>\<^sub>G \<F>. eval_formula \<F> Rs (\<alpha>\<langle>0:z\<rangle>) fm)} = {[t] | t. t \<in> \<T>\<^sub>G \<F>}"
using formula_relevantD[OF assms(1)] assms(2-)
apply auto
apply blast
by (smt rangeI shift_eq shift_rangeI shift_right_rangeI shift_shift_right_id subsetD)
(* MOVE *)
lemma find_append:
"find P (xs @ ys) = (if find P xs \<noteq> None then find P xs else find P ys)"
by (induct xs arbitrary: ys) (auto split!: if_splits)
subsection \<open>Checking inferences\<close>
derive linorder ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs
derive compare ext_step pos_step gtt_rel rr1_rel rr2_rel ftrs
fun check_inference :: "(('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option)
\<Rightarrow> (('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option)
\<Rightarrow> ('f \<times> nat) fset \<Rightarrow> ('f :: compare, 'v) fin_trs list
\<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list
\<Rightarrow> (nat \<times> ftrs inference \<times> ftrs formula \<times> info list)
\<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) option" where
"check_inference rr1c rr2c \<F> Rs infs (l, step, fm, is) = do {
guard (l = length infs);
case step of
IRR1 s x \<Rightarrow> do {
guard (fm = FRR1 s x);
liftO1 (\<lambda>ta. (FRR1 s x, [x], fmap_funs_reg (\<lambda>f. [Some f]) ta)) (rr1c \<F> Rs s)
}
| IRR2 r x y \<Rightarrow> do {
guard (fm = FRR2 r x y);
case compare x y of
Lt \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [x, y], fmap_funs_reg (\<lambda>(f, g). [f, g]) ta)) (rr2c \<F> Rs r)
| Eq \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [x], fmap_funs_reg (\<lambda>f. [Some f]) ta))
(liftO1 (simplify_reg \<circ> proj_1_reg)
(liftO2 (\<lambda> t1 t2. simplify_reg (reg_intersect t1 t2)) (rr2c \<F> Rs r) (rr2c \<F> Rs (R2Diag R1Terms))))
| Gt \<Rightarrow> liftO1 (\<lambda>ta. (FRR2 r x y, [y, x], fmap_funs_reg (\<lambda>(f, g). [g, f]) ta)) (rr2c \<F> Rs r)
}
| IAnd ls \<Rightarrow> do {
guard (\<forall>l' \<in> set ls. l' < l);
guard (fm = FAnd (map (\<lambda>l'. fst (infs ! l')) ls));
let (vs', tas') = fit_rrns \<F> (map ((!) infs) ls) in
Some (fm, vs', fand_rrn \<F> (length vs') tas')
}
| IOr ls \<Rightarrow> do {
guard (\<forall>l' \<in> set ls. l' < l);
guard (fm = FOr (map (\<lambda>l'. fst (infs ! l')) ls));
let (vs', tas') = fit_rrns \<F> (map ((!) infs) ls) in
Some (fm, vs', for_rrn tas')
}
| INot l' \<Rightarrow> do {
guard (l' < l);
guard (fm = FNot (fst (infs ! l')));
let (vs', tas') = snd (infs ! l');
Some (fm, vs', simplify_reg (difference_reg (true_RRn \<F> (length vs')) tas'))
}
| IExists l' \<Rightarrow> do {
guard (l' < l);
guard (fm = FExists (fst (infs ! l')));
let (vs', tas') = snd (infs ! l');
if length vs' = 0 then Some (fm, [], tas') else
if reg_empty tas' then Some (fm, [], empty_reg)
else if 0 \<notin> set vs' then Some (fm, map (\<lambda> x. x - 1) vs', tas')
else if 1 = length vs' then Some (fm, [], true_RRn \<F> 0)
else Some (fm, upd_bruijn vs', rrn_drop_fst tas')
}
| IRename l' vs \<Rightarrow> guard (l' < l) \<then> None
| INNFPlus l' \<Rightarrow> do {
guard (l' < l);
let fm' = fst (infs ! l');
guard (ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm'))) = ord_form_list_aci (nnf_to_list_aci (nnf (form_of_formula fm))));
Some (fm, snd (infs ! l'))
}
| IRepl eq pos l' \<Rightarrow> guard (l' < l) \<then> None
}"
lemma RRn_spec_true_RRn:
"RRn_spec (Suc 0) (true_RRn \<F> (Suc 0)) {[t] |t. t \<in> \<T>\<^sub>G (fset \<F>)}"
apply (auto simp: RRn_spec_def \<T>\<^sub>G_equivalent_def fmap_funs_\<L>
image_def term_automaton[of \<F>, unfolded RR1_spec_def])
apply (metis gencode_singleton)+
done
lemma check_inference_correct:
assumes sig: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" and Rs: "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
assumes infs: "\<And>fvA. fvA \<in> set infs \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
assumes inf: "check_inference rr1c rr2c \<F> Rs infs (l, step, fm, is) = Some (fm', vs, A')"
assumes rr1: "\<And>r1. \<forall>ta1. rr1c \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
assumes rr2: "\<And>r2. \<forall>ta2. rr2c \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
shows "l = length infs \<and> fm = fm' \<and> formula_spec (fset \<F>) (map fset Rs) vs A' fm'"
using inf
proof (induct step)
note [simp] = bind_eq_Some_conv guard_simps
let ?F = "fset \<F>" let ?Rs = "map fset Rs"
{
case (IRR1 s x)
then show ?case
using rr1[rule_format, of s]
subsetD[OF eval_rr12_rel_sig(1), of _ ?F ?Rs s]
by (force simp: formula_spec_def formula_relevant_def RR1_spec_def \<T>\<^sub>G_equivalent_def
intro!: RR1_to_RRn_spec[of _ "(\<lambda>\<alpha>. \<alpha> x) ` Collect P" for P, unfolded image_comp, unfolded image_Collect comp_def One_nat_def])
next
case (IRR2 r x y)
then show ?case using rr2[rule_format, of r]
subsetD[OF eval_rr12_rel_sig(2), of _ ?F ?Rs r]
two_comparisons_into_compare(1)[of x y "x = y" "x < y" "x > y"]
proof (induct "compare x y")
note [intro!] = RR1_to_RRn_spec[of _ "(\<lambda>\<alpha>. \<alpha> y) ` Collect P" for P, unfolded image_comp,
unfolded image_Collect comp_def One_nat_def prod.simps]
case Eq
then obtain A where w[simp]: "rr2c \<F> Rs r = Some A" by auto
from Eq obtain B where [simp]:"rr2c \<F> Rs (R2Diag R1Terms) = Some B" by auto
let ?B = "reg_intersect A B"
from Eq(3)[OF w] have "RR2_spec ?B (eval_rr2_rel ?F ?Rs r \<inter> Restr Id (\<T>\<^sub>G ?F))"
using rr2[rule_format, of "R2Diag R1Terms" B]
by (auto simp add: \<L>_intersect RR2_spec_def dest: lift_fun_gpairD)
then have "RR2_spec (relabel_reg (trim_reg ?B)) (eval_rr2_rel ?F ?Rs r \<inter> Restr Id (\<T>\<^sub>G ?F))" by simp
from proj_1(1)[OF this]
have "RR1_spec (proj_1_reg (relabel_reg (trim_reg ?B))) {\<alpha> y |\<alpha>. range \<alpha> \<subseteq> gterms ?F \<and> (\<alpha> y, \<alpha> y) \<in> eval_rr2_rel ?F ?Rs r}"
apply (auto simp: RR1_spec_def \<T>\<^sub>G_equivalent_def image_iff)
by (metis Eq.prems(3) IdI IntI \<T>\<^sub>G_equivalent_def fst_conv)
then show ?thesis using Eq
by (auto simp: formula_spec_def formula_relevant_def liftO1_def \<T>\<^sub>G_equivalent_def simplify_reg_def RR2_spec_def
split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
next
note [intro!] = RR2_to_RRn_spec[of _ "(\<lambda>\<alpha>. (\<alpha> x, \<alpha> y)) ` Collect P" for P, unfolded image_comp,
unfolded image_Collect comp_def numeral_2_eq_2 prod.simps]
case Lt then show ?thesis by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def \<T>\<^sub>G_equivalent_def
split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
next
note [intro!] = RR2_to_RRn_spec[of _ "prod.swap ` (\<lambda>\<alpha>. (\<alpha> x, \<alpha> y)) ` Collect P" for P, OF swap_RR2_spec,
unfolded image_comp, unfolded image_Collect comp_def numeral_2_eq_2 prod.simps fmap_funs_reg_comp case_swap]
case Gt then show ?thesis
by (fastforce simp: formula_spec_def formula_relevant_def RR2_spec_def \<T>\<^sub>G_equivalent_def
split: if_splits intro!: exI[of _ "\<lambda>z. if z = x then _ else _"])
qed
next
case (IAnd ls)
have [simp]: "(fm, vs, ta) \<in> (!) infs ` set ls \<Longrightarrow> formula_spec ?F ?Rs vs ta fm" for fm vs ta
using infs IAnd by auto
show ?case using IAnd fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
by (force split: prod.splits intro!: fand_rrn[OF assms(1)])
next
case (IOr ls)
have [simp]: "(fm, vs, ta) \<in> (!) infs ` set ls \<Longrightarrow> formula_spec ?F ?Rs vs ta fm" for fm vs ta
using infs IOr by auto
show ?case using IOr fit_rrns[OF assms(3), of "map ((!) infs) ls", OF _ prod.collapse]
by (force split: prod.splits intro!: for_rrn)
next
case (INot l')
obtain fm vs' ta where [simp]: "infs ! l' = (fm, vs', ta)" by (cases "infs ! l'") auto
then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] INot
by auto
have rel: "formula_relevant (fset \<F>) (map fset Rs) vs (FNot fm)" using spec
unfolding formula_spec_def formula_relevant_def
by (metis (no_types, lifting) eval_formula.simps(5))
have vs: "sorted vs" "distinct vs" using spec by (auto simp: formula_spec_def)
{fix xs assume ass: "\<forall>\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<longrightarrow> xs = map \<alpha> vs \<longrightarrow> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm"
"length xs = length vs" "set xs \<subseteq> \<T>\<^sub>G (fset \<F>)"
from sig obtain s where mem: "s \<in> \<T>\<^sub>G (fset \<F>)" by blast
let ?g = "\<lambda> i. find (\<lambda> p. fst p = i) (zip vs [0 ..< length vs])"
let ?f = "\<lambda> i. if ?g i = None then s else xs ! snd (the (?g i))"
from vs(1) have *: "sorted (zip vs [0 ..< length vs])"
by (induct vs rule: rev_induct) (auto simp: sorted_append elim!: in_set_zipE intro!: sorted_append_bigger)
have "i < length vs \<Longrightarrow> ?g (vs ! i) = Some (vs ! i, i)" for i using vs(2)
by (induct vs rule: rev_induct) (auto simp: nth_append find_append find_Some_iff nth_eq_iff_index_eq split!: if_splits)
then have "map ?f vs = xs" using vs(2) ass(2)
by (intro nth_equalityI) (auto simp: find_None_iff set_zip)
moreover have "range ?f \<subseteq> \<T>\<^sub>G (fset \<F>)" using ass(2, 3) mem
using find_SomeD(2) set_zip_rightD by auto fastforce
ultimately have "\<exists>\<alpha>. xs = map \<alpha> vs \<and> range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm" using ass(1)
by (intro exI[of _ ?f]) auto}
then have *: "{ts. length ts = length vs \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} -
{map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm} =
{map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm}"
apply auto
apply force
using formula_relevantD[OF rel] unfolding eval_formula.simps
by (meson map_ext)
have "RRn_spec (length vs) (difference_reg (true_RRn \<F> (length vs)) ta)
{map \<alpha> vs |\<alpha>. range \<alpha> \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> \<not> eval_formula (fset \<F>) (map fset Rs) \<alpha> fm}"
using RRn_difference[OF true_RRn_spec[of "length vs" \<F>] formula_spec_RRn_spec[OF spec]]
unfolding * by simp
then show ?case using INot spec rel
by (auto split: prod.splits simp: formula_spec_def)
next
case (IExists l')
obtain fm vs ta where [simp]: "infs ! l' = (fm, vs, ta)" by (cases "infs ! l'") auto
then have spec: "formula_spec ?F ?Rs vs ta fm" using infs[OF nth_mem, of l'] IExists
by auto
show ?case
proof (cases "length vs = 0")
case True
then show ?thesis using IExists spec
apply (auto simp: formula_spec_def)
subgoal apply (auto simp: formula_relevant_def)
apply (meson shift_rangeI)
done
subgoal apply (auto simp: RRn_spec_def image_iff)
apply (meson eval_formula_shift_right_eval(1) rangeI shift_right_rangeI subsetD)
apply (meson shift_rangeI)
done
done
next
case False note len = this
then have *[simp]: "vs \<noteq> []" by (cases vs) auto
show ?thesis
proof (cases "reg_empty ta")
case True
then show ?thesis using IExists spec formula_spec_empty[OF _ spec]
by (auto simp: \<T>\<^sub>G_equivalent_def comp_def formula_spec_def
shift_rangeI RRn_spec_def image_iff \<L>_epmty
intro!: trivial_formula_relevant)
next
case False
then have nt_empty [simp]: "\<L> ta \<noteq> {}" by auto
show ?thesis
proof (cases "0 \<notin> set vs")
case True
then have ta: "ta = A'" using spec IExists
by (auto simp: formula_spec_def)
from True have relv: "formula_relevant ?F ?Rs (map (\<lambda>x. x - Suc 0) vs) (FExists fm)"
using spec IExists
by (intro ExistsI_upd_brujin_no_0) (auto simp: formula_spec_def)
then show ?thesis using True spec IExists nt_rel_0_trivial_shift[OF True, of ?F ?Rs ]
by (auto simp: formula_spec_def \<T>\<^sub>G_equivalent_def comp_def
elim!: formula_relevantD
intro!: pres_distinct_not_0_list_dec pres_sorted_dec)
next
case False
then have rel_0: "0 \<in> set vs" by simp
show ?thesis
proof (cases "1 = length vs")
case True
then have [simp]: "vs = [0]" using rel_0 by (induct vs) auto
{fix t assume "0 |\<in>| ta_der (TA {|[] [] \<rightarrow> 0|} {||}) (term_of_gterm t)"
then have "t = GFun [] []" by (cases t) auto}
then have [simp]: "\<L> (Reg {|0|} (TA {|TA_rule [] [] 0|} {||})) = {GFun [] []}"
by (auto simp: \<L>_def gta_der_def gta_lang_def)
have [simp]: "GFun [] [] = gencode []"
by (auto simp: gencode_def gunions_def)
show ?thesis using IExists spec nt_empty
by (auto simp: formula_spec_def RRn_spec_true_RRn RRn_spec_def formula_relevant_0_FExists image_iff)
(meson eval_formula_shift_right_eval(1) in_mono rangeI shift_right_rangeI)
next
case False
from False show ?thesis using spec IExists rel_0 nt_empty
using rrn_drop_fst_lang[OF formula_spec_RRn_spec[OF spec]]
by (auto simp: formula_spec_def Suc_lessI simp flip: drop_upd_bruijn_set
split: prod.splits
intro: upd_bruijn_pres_sorted upd_bruijn_pres_distinct ExistsI_upd_brujin_0)
qed
qed
qed
qed
next
case (IRename l' vs)
then show ?case by simp
next
case (INNFPlus l')
show ?case using infs[OF nth_mem, of l'] INNFPlus
apply (auto simp: formula_spec_def formula_relevant_def eval_formula_conv)
apply (simp_all only: check_equivalence_by_nnf_sortedlist_aci[of "form_of_formula (fst (infs ! l'))" "form_of_formula fm"])
done
next
case (IRepl eq pos l')
then show ?case by simp
}
qed
end
\ No newline at end of file
diff --git a/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy b/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy
--- a/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy
+++ b/thys/FO_Theory_Rewriting/FOR_Check_Impl.thy
@@ -1,773 +1,773 @@
theory FOR_Check_Impl
imports FOR_Check
Regular_Tree_Relations.Regular_Relation_Impl
NF_Impl
begin
section \<open>Inference checking implementation\<close>
(* we define epsilon free agtt/gtt constructions *)
definition "ftrancl_eps_free_closures \<A> = eps_free_automata (eps \<A>) \<A>"
abbreviation "ftrancl_eps_free_reg \<A> \<equiv> Reg (fin \<A>) (ftrancl_eps_free_closures (ta \<A>))"
lemma ftrancl_eps_free_ta_derI:
"(eps \<A>)|\<^sup>+| = eps \<A> \<Longrightarrow> ta_der (ftrancl_eps_free_closures \<A>) (term_of_gterm t) = ta_der \<A> (term_of_gterm t)"
using eps_free[of \<A>] ta_res_eps_free[of \<A>]
by (auto simp add: ftrancl_eps_free_closures_def)
lemma \<L>_ftrancl_eps_free_closuresI:
"(eps (ta \<A>))|\<^sup>+| = eps (ta \<A>) \<Longrightarrow> \<L> (ftrancl_eps_free_reg \<A>) = \<L> \<A>"
using ftrancl_eps_free_ta_derI[of "ta \<A>"]
unfolding \<L>_def by (auto simp: gta_lang_def gta_der_def)
definition "root_step R \<F> \<equiv> (let (TA1, TA2) = agtt_grrstep R \<F> in
(ftrancl_eps_free_closures TA1, TA2))"
definition AGTT_trancl_eps_free :: "('q, 'f) gtt \<Rightarrow> ('q + 'q, 'f) gtt" where
"AGTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = AGTT_trancl \<G> in
(ftrancl_eps_free_closures \<A>, \<B>))"
definition GTT_trancl_eps_free where
"GTT_trancl_eps_free \<G> = (let (\<A>, \<B>) = GTT_trancl \<G> in
(ftrancl_eps_free_closures \<A>,
ftrancl_eps_free_closures \<B>))"
definition AGTT_comp_eps_free where
"AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 = (let (\<A>, \<B>) = AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
(ftrancl_eps_free_closures \<A>, \<B>))"
definition GTT_comp_eps_free where
"GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2 =(let (\<A>, \<B>) = GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 in
(ftrancl_eps_free_closures \<A>, ftrancl_eps_free_closures \<B>))"
(* epsilon free proves *)
lemma eps_free_relable [simp]:
"is_gtt_eps_free (relabel_gtt \<G>) = is_gtt_eps_free \<G>"
by (auto simp: is_gtt_eps_free_def relabel_gtt_def fmap_states_gtt_def fmap_states_ta_def)
lemma eps_free_prod_swap:
"is_gtt_eps_free (\<A>, \<B>) \<Longrightarrow> is_gtt_eps_free (\<B>, \<A>)"
by (auto simp: is_gtt_eps_free_def)
lemma eps_free_root_step:
"is_gtt_eps_free (root_step R \<F>)"
by (auto simp add: case_prod_beta is_gtt_eps_free_def root_step_def pair_at_to_agtt'_def ftrancl_eps_free_closures_def)
lemma eps_free_AGTT_trancl_eps_free:
"is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (AGTT_trancl_eps_free \<G>)"
by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_trancl_def Let_def
AGTT_trancl_eps_free_def ftrancl_eps_free_closures_def)
lemma eps_free_GTT_trancl_eps_free:
"is_gtt_eps_free \<G> \<Longrightarrow> is_gtt_eps_free (GTT_trancl_eps_free \<G>)"
by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_trancl_eps_free_def ftrancl_eps_free_closures_def)
lemma eps_free_AGTT_comp_eps_free:
"is_gtt_eps_free \<G>\<^sub>2 \<Longrightarrow> is_gtt_eps_free (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
by (auto simp: case_prod_beta is_gtt_eps_free_def AGTT_comp_eps_free_def
ftrancl_eps_free_closures_def AGTT_comp_def fmap_states_gtt_def fmap_states_ta_def)
lemma eps_free_GTT_comp_eps_free:
"is_gtt_eps_free (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2)"
by (auto simp: case_prod_beta is_gtt_eps_free_def GTT_comp_eps_free_def ftrancl_eps_free_closures_def)
lemmas eps_free_const =
eps_free_prod_swap
eps_free_root_step
eps_free_AGTT_trancl_eps_free
eps_free_GTT_trancl_eps_free
eps_free_AGTT_comp_eps_free
eps_free_GTT_comp_eps_free
(* lang preserve proofs *)
lemma agtt_lang_derI:
assumes "\<And> t. ta_der (fst \<A>) (term_of_gterm t) = ta_der (fst \<B>) (term_of_gterm t)"
and "\<And> t. ta_der (snd \<A>) (term_of_gterm t) = ta_der (snd \<B>) (term_of_gterm t)"
shows "agtt_lang \<A> = agtt_lang \<B>" using assms
by (auto simp: agtt_lang_def gta_der_def)
lemma agtt_lang_root_step_conv:
"agtt_lang (root_step R \<F>) = agtt_lang (agtt_grrstep R \<F>)"
using ftrancl_eps_free_ta_derI[OF agtt_grrstep_eps_trancl(1), of R \<F>]
by (auto simp: case_prod_beta root_step_def intro!: agtt_lang_derI)
lemma agtt_lang_AGTT_trancl_eps_free_conv:
assumes "is_gtt_eps_free \<G>"
shows "agtt_lang (AGTT_trancl_eps_free \<G>) = agtt_lang (AGTT_trancl \<G>)"
proof -
let ?eps = "eps (fst (AGTT_trancl \<G>))"
have "?eps |O| ?eps = {||}" using assms
by (auto simp: AGTT_trancl_def is_gtt_eps_free_def Let_def fmap_states_ta_def)
from ftrancl_eps_free_ta_derI[OF frelcomp_empty_ftrancl_simp[OF this]]
show ?thesis
by (auto simp: case_prod_beta AGTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed
lemma agtt_lang_GTT_trancl_eps_free_conv:
assumes "is_gtt_eps_free \<G>"
shows "agtt_lang (GTT_trancl_eps_free \<G>) = agtt_lang (GTT_trancl \<G>)"
proof -
have "(eps (fst (GTT_trancl \<G>)))|\<^sup>+| = eps (fst (GTT_trancl \<G>))"
"(eps (snd (GTT_trancl \<G>)))|\<^sup>+| = eps (snd (GTT_trancl \<G>))" using assms
by (auto simp: GTT_trancl_def Let_def is_gtt_eps_free_def \<Delta>_trancl_inv)
from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
show ?thesis
by (auto simp: case_prod_beta GTT_trancl_eps_free_def intro!: agtt_lang_derI)
qed
lemma agtt_lang_AGTT_comp_eps_free_conv:
assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
shows "agtt_lang (AGTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
proof -
have "(eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (fst (AGTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def
case_prod_beta AGTT_comp_def gtt_interface_def \<Q>_def intro!: frelcomp_empty_ftrancl_simp)
from ftrancl_eps_free_ta_derI[OF this] show ?thesis
by (auto simp: case_prod_beta AGTT_comp_eps_free_def intro!: agtt_lang_derI)
qed
lemma agtt_lang_GTT_comp_eps_free_conv:
assumes "is_gtt_eps_free \<G>\<^sub>1" "is_gtt_eps_free \<G>\<^sub>2"
shows "agtt_lang (GTT_comp_eps_free \<G>\<^sub>1 \<G>\<^sub>2) = agtt_lang (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)"
proof -
have "(eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (fst (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))"
"(eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| = eps (snd (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2))" using assms
by (auto simp: is_gtt_eps_free_def fmap_states_gtt_def fmap_states_ta_def \<Delta>\<^sub>\<epsilon>_fmember
case_prod_beta GTT_comp_def gtt_interface_def \<Q>_def dest!: ground_ta_der_statesD
intro!: frelcomp_empty_ftrancl_simp)
from ftrancl_eps_free_ta_derI[OF this(1)] ftrancl_eps_free_ta_derI[OF this(2)]
show ?thesis
by (auto simp: case_prod_beta GTT_comp_eps_free_def intro!: agtt_lang_derI)
qed
fun gtt_of_gtt_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs gtt_rel \<Rightarrow> (nat, 'f) gtt option" where
"gtt_of_gtt_rel_impl \<F> Rs (ARoot is) = liftO1 (\<lambda>R. relabel_gtt (root_step R \<F>)) (is_to_trs' Rs is)"
| "gtt_of_gtt_rel_impl \<F> Rs (GInv g) = liftO1 prod.swap (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (AUnion g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_union' g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
| "gtt_of_gtt_rel_impl \<F> Rs (ATrancl g) = liftO1 (relabel_gtt \<circ> AGTT_trancl_eps_free) (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (GTrancl g) = liftO1 GTT_trancl_eps_free (gtt_of_gtt_rel_impl \<F> Rs g)"
| "gtt_of_gtt_rel_impl \<F> Rs (AComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (AGTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
| "gtt_of_gtt_rel_impl \<F> Rs (GComp g1 g2) = liftO2 (\<lambda>g1 g2. relabel_gtt (GTT_comp_eps_free g1 g2)) (gtt_of_gtt_rel_impl \<F> Rs g1) (gtt_of_gtt_rel_impl \<F> Rs g2)"
lemma gtt_of_gtt_rel_impl_is_gtt_eps_free:
"gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> is_gtt_eps_free g'"
proof (induct g arbitrary: g')
case (AUnion g1 g2)
then show ?case
by (auto simp: is_gtt_eps_free_def AGTT_union_def fmap_states_gtt_def fmap_states_ta_def ta_union_def relabel_gtt_def)
qed (auto simp: eps_free_const)
lemma gtt_of_gtt_rel_impl_gtt_of_gtt_rel:
"gtt_of_gtt_rel_impl \<F> Rs g \<noteq> None \<longleftrightarrow> gtt_of_gtt_rel \<F> Rs g \<noteq> None" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
have "?Ls \<Longrightarrow> ?Rs" by (induct g) auto
moreover have "?Rs \<Longrightarrow> ?Ls" by (induct g) auto
ultimately show ?thesis by blast
qed
lemma gtt_of_gtt_rel_impl_sound:
"gtt_of_gtt_rel_impl \<F> Rs g = Some g' \<Longrightarrow> gtt_of_gtt_rel \<F> Rs g = Some g'' \<Longrightarrow> agtt_lang g' = agtt_lang g''"
proof (induct g arbitrary: g' g'')
case (ARoot x)
then show ?case by (simp add: agtt_lang_root_step_conv)
next
case (GInv g)
then have "agtt_lang (prod.swap g') = agtt_lang (prod.swap g'')" by auto
then show ?case
by (metis converse_agtt_lang converse_converse)
next
case (AUnion g1 g2)
then show ?case
by simp (metis AGTT_union'_sound option.sel)
next
case (ATrancl g)
then show ?case
using agtt_lang_AGTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
by simp (metis AGTT_trancl_sound option.sel)
next
case (GTrancl g)
then show ?case
using agtt_lang_GTT_trancl_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g]
by simp (metis GTT_trancl_alang option.sel)
next
case (AComp g1 g2)
then show ?case
using agtt_lang_AGTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
"the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
by simp (metis AGTT_comp'_sound agtt_lang_AGTT_comp_eps_free_conv gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
next
case (GComp g1 g2)
then show ?case
using agtt_lang_GTT_comp_eps_free_conv[OF gtt_of_gtt_rel_impl_is_gtt_eps_free, of \<F> Rs g
"the (gtt_of_gtt_rel_impl \<F> Rs g1)" "the (gtt_of_gtt_rel_impl \<F> Rs g2)"]
by simp (metis agtt_lang_GTT_comp_eps_free_conv gtt_comp'_alang gtt_of_gtt_rel_impl_is_gtt_eps_free option.sel)
qed
(* eps free closure constructions *)
lemma \<L>_eps_free_nhole_ctxt_closure_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (ftrancl_eps_free_reg (nhole_ctxt_closure_reg \<F> \<A>)) = \<L> (nhole_ctxt_closure_reg \<F> \<A>)"
proof -
have "eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) |O| eps (ta (nhole_ctxt_closure_reg \<F> \<A>)) = {||}" using assms
by (auto simp: nhole_ctxt_closure_reg_def gen_nhole_ctxt_closure_reg_def
gen_nhole_ctxt_closure_automaton_def ta_union_def reflcl_over_nhole_ctxt_ta_def
fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed
lemma \<L>_eps_free_ctxt_closure_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (ftrancl_eps_free_reg (ctxt_closure_reg \<F> \<A>)) = \<L> (ctxt_closure_reg \<F> \<A>)"
proof -
have "eps (ta (ctxt_closure_reg \<F> \<A>)) |O| eps (ta (ctxt_closure_reg \<F> \<A>)) = {||}" using assms
by (auto simp: ctxt_closure_reg_def gen_ctxt_closure_reg_def Let_def
gen_ctxt_closure_automaton_def ta_union_def reflcl_over_single_ta_def
fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed
lemma \<L>_eps_free_parallel_closure_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (ftrancl_eps_free_reg (parallel_closure_reg \<F> \<A>)) = \<L> (parallel_closure_reg \<F> \<A>)"
proof -
have "eps (ta (parallel_closure_reg \<F> \<A>)) |O| eps (ta (parallel_closure_reg \<F> \<A>)) = {||}" using assms
by (auto simp: parallel_closure_reg_def gen_parallel_closure_automaton_def Let_def ta_union_def
refl_over_states_ta_def fmap_states_reg_def is_ta_eps_free_def fmap_states_ta_def reg_Restr_Q\<^sub>f_def)
from frelcomp_empty_ftrancl_simp[OF this] show ?thesis
by (intro \<L>_ftrancl_eps_free_closuresI) simp
qed
abbreviation "eps_free_reg' S R \<equiv> Reg (fin R) (eps_free_automata S (ta R))"
definition "eps_free_mctxt_closure_reg \<F> \<A> =
(let \<B> = mctxt_closure_reg \<F> \<A> in
eps_free_reg' ((\<lambda> p. (fst p, Inr cl_state)) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"
definition "eps_free_nhole_mctxt_reflcl_reg \<F> \<A> =
(let \<B> = nhole_mctxt_reflcl_reg \<F> \<A> in
eps_free_reg' ((\<lambda> p. (fst p, Inl (Inr cl_state))) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"
definition "eps_free_nhole_mctxt_closure_reg \<F> \<A> =
(let \<B> = nhole_mctxt_closure_reg \<F> \<A> in
eps_free_reg' ((\<lambda> p. (fst p, (Inr cl_state))) |`| (eps (ta \<B>)) |\<union>| eps (ta \<B>)) \<B>)"
lemma \<L>_eps_free_reg'I:
"(eps (ta \<A>))|\<^sup>+| = S \<Longrightarrow> \<L> (eps_free_reg' S \<A>) = \<L> \<A>"
by (auto simp: \<L>_def gta_lang_def gta_der_def ta_res_eps_free simp flip: eps_free)
lemma \<L>_eps_free_mctxt_closure_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (eps_free_mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<F> \<A>)" using assms
unfolding eps_free_mctxt_closure_reg_def Let_def
apply (intro \<L>_eps_free_reg'I)
apply (auto simp: comp_def mctxt_closure_reg_def is_ta_eps_free_def Let_def
gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
reflcl_over_nhole_ctxt_ta_def gen_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def
fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
lemma \<L>_eps_free_nhole_mctxt_reflcl_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (eps_free_nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<F> \<A>)" using assms
unfolding eps_free_nhole_mctxt_reflcl_reg_def Let_def
apply (intro \<L>_eps_free_reg'I)
apply (auto simp: comp_def nhole_mctxt_reflcl_reg_def is_ta_eps_free_def Let_def
nhole_mctxt_closure_reg_def gen_nhole_mctxt_closure_reg_def reg_union_def ta_union_def
gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def
reflcl_over_nhole_ctxt_ta_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def dest: ftranclD ftranclD2)
by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
lemma \<L>_eps_free_nhole_mctxt_closure_reg:
assumes "is_ta_eps_free (ta \<A>)"
shows "\<L> (eps_free_nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<F> \<A>)" using assms
unfolding eps_free_nhole_mctxt_closure_reg_def Let_def
apply (intro \<L>_eps_free_reg'I)
apply (auto simp: comp_def nhole_mctxt_closure_reg_def is_ta_eps_free_def Let_def
gen_nhole_mctxt_closure_reg_def reg_Restr_Q\<^sub>f_def fmap_states_reg_def fmap_states_ta_def
gen_nhole_mctxt_closure_automaton_def reflcl_over_nhole_mctxt_ta_def ta_union_def
reflcl_over_nhole_ctxt_ta_def dest: ftranclD ftranclD2)
by (meson fimageI finsert_iff finterI fr_into_trancl ftrancl_into_trancl)
fun rr1_of_rr1_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f :: linorder, 'v) fin_trs list \<Rightarrow> ftrs rr1_rel \<Rightarrow> (nat, 'f) reg option"
and rr2_of_rr2_rel_impl :: "('f \<times> nat) fset \<Rightarrow> ('f, 'v) fin_trs list \<Rightarrow> ftrs rr2_rel \<Rightarrow> (nat, 'f option \<times> 'f option) reg option" where
"rr1_of_rr1_rel_impl \<F> Rs R1Terms = Some (relabel_reg (term_reg \<F>))"
| "rr1_of_rr1_rel_impl \<F> Rs (R1NF is) = liftO1 (\<lambda>R. (simplify_reg (nf_reg (fst |`| R) \<F>))) (is_to_trs' Rs is)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Inf r) = liftO1 (\<lambda>R.
let \<A> = trim_reg R in
simplify_reg (proj_1_reg (Inf_reg_impl \<A>))
) (rr2_of_rr2_rel_impl \<F> Rs r)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Proj i r) = (case i of 0 \<Rightarrow>
liftO1 (trim_reg \<circ> proj_1_reg) (rr2_of_rr2_rel_impl \<F> Rs r)
| _ \<Rightarrow> liftO1 (trim_reg \<circ> proj_2_reg) (rr2_of_rr2_rel_impl \<F> Rs r))"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Union s1 s2) =
liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Inter s1 s2) =
liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr1_of_rr1_rel_impl \<F> Rs (R1Diff s1 s2) = liftO2 (\<lambda> x y. relabel_reg (trim_reg (difference_reg x y))) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2GTT_Rel g w x) =
(case w of PRoot \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
| PNonRoot \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> nhole_ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_reflcl_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_nhole_mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g))
| PAny \<Rightarrow>
(case x of ESingle \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> ctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EParallel \<Rightarrow> liftO1 (simplify_reg \<circ> ftrancl_eps_free_reg \<circ> parallel_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)
| EStrictParallel \<Rightarrow> liftO1 (simplify_reg \<circ> eps_free_mctxt_closure_reg (lift_sig_RR2 |`| \<F>) \<circ> GTT_to_RR2_root_reg) (gtt_of_gtt_rel_impl \<F> Rs g)))"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Diag s) =
liftO1 (\<lambda> x. fmap_funs_reg (\<lambda>f. (Some f, Some f)) x) (rr1_of_rr1_rel_impl \<F> Rs s)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Prod s1 s2) =
liftO2 (\<lambda> x y. simplify_reg (pair_automaton_reg x y)) (rr1_of_rr1_rel_impl \<F> Rs s1) (rr1_of_rr1_rel_impl \<F> Rs s2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Inv r) = liftO1 (fmap_funs_reg prod.swap) (rr2_of_rr2_rel_impl \<F> Rs r)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Union r1 r2) =
liftO2 (\<lambda> x y. relabel_reg (reg_union x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Inter r1 r2) =
liftO2 (\<lambda> x y. simplify_reg (reg_intersect x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Diff r1 r2) = liftO2 (\<lambda> x y. simplify_reg (difference_reg x y)) (rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
| "rr2_of_rr2_rel_impl \<F> Rs (R2Comp r1 r2) = liftO2 (\<lambda> x y. simplify_reg (rr2_compositon \<F> x y))
(rr2_of_rr2_rel_impl \<F> Rs r1) (rr2_of_rr2_rel_impl \<F> Rs r2)"
lemmas ta_simp_unfold = simplify_reg_def relabel_reg_def trim_reg_def relabel_ta_def term_reg_def
lemma is_ta_eps_free_trim_reg [intro!]:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (trim_reg R))"
by (simp add: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)
lemma is_ta_eps_free_relabel_reg [intro!]:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (relabel_reg R))"
by (simp add: is_ta_eps_free_def relabel_reg_def relabel_ta_def fmap_states_ta_def)
lemma is_ta_eps_free_simplify_reg [intro!]:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (simplify_reg R))"
by (simp add: is_ta_eps_free_def ta_simp_unfold fmap_states_ta_def trim_ta_def ta_restrict_def)
lemma is_ta_emptyI [simp]:
"is_ta_eps_free (TA R {||}) \<longleftrightarrow> True"
by (simp add: is_ta_eps_free_def)
lemma is_ta_empty_trim_reg:
"is_ta_eps_free (ta A) \<Longrightarrow> eps (ta (trim_reg A)) = {||}"
by (auto simp: is_ta_eps_free_def trim_reg_def trim_ta_def ta_restrict_def)
lemma is_proj_ta_eps_empty:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_1_reg R))"
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (proj_2_reg R))"
by (auto simp: is_ta_eps_free_def proj_1_reg_def proj_2_reg_def collapse_automaton_reg_def collapse_automaton_def
fmap_funs_reg_def fmap_funs_ta_def trim_reg_def trim_ta_def ta_restrict_def)
lemma is_pod_ta_eps_empty:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (reg_intersect R L))"
by (auto simp: reg_intersect_def prod_ta_def prod_epsRp_def prod_epsLp_def is_ta_eps_free_def)
lemma is_fmap_funs_reg_eps_empty:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (fmap_funs_reg f R))"
by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
lemma is_collapse_automaton_reg_eps_empty:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta (collapse_automaton_reg R))"
by (auto simp: collapse_automaton_reg_def collapse_automaton_def is_ta_eps_free_def)
lemma is_pair_automaton_reg_eps_empty:
"is_ta_eps_free (ta R) \<Longrightarrow> is_ta_eps_free (ta L) \<Longrightarrow> is_ta_eps_free (ta (pair_automaton_reg R L))"
by (auto simp: pair_automaton_reg_def pair_automaton_def is_ta_eps_free_def)
lemma is_reflcl_automaton_eps_free:
"is_ta_eps_free A \<Longrightarrow> is_ta_eps_free (reflcl_automaton (lift_sig_RR2 |`| \<F>) A)"
by (auto simp: is_ta_eps_free_def reflcl_automaton_def ta_union_def gen_reflcl_automaton_def Let_def fmap_states_ta_def)
lemma is_GTT_to_RR2_root_eps_empty:
"is_gtt_eps_free \<G> \<Longrightarrow> is_ta_eps_free (GTT_to_RR2_root \<G>)"
by (auto simp: is_gtt_eps_free_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def)
lemma is_term_automata_eps_empty:
"is_ta_eps_free (ta (term_reg \<F>)) \<longleftrightarrow> True"
by (auto simp: is_ta_eps_free_def term_reg_def term_automaton_def)
lemma is_ta_eps_free_eps_free_automata [simp]:
" is_ta_eps_free (eps_free_automata S R) \<longleftrightarrow> True"
by (auto simp: eps_free_automata_def is_ta_eps_free_def)
lemma rr2_of_rr2_rel_impl_eps_free:
shows "\<forall> A. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
"\<forall> A. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<longrightarrow> is_ta_eps_free (ta A)"
proof (induct r1 and r2)
case R1Terms
then show ?case
by (auto simp: is_ta_eps_free_def term_automaton_def fmap_states_ta_def ta_simp_unfold)
next
case (R1NF x)
then show ?case
by (auto simp: nf_reg_def nf_ta_def)
next
case (R1Inf x)
then show ?case
by (auto simp: Inf_reg_impl_def Let_def Inf_reg_def Inf_automata_def is_ta_empty_trim_reg intro!: is_proj_ta_eps_empty)
next
case (R1Proj n x2)
then show ?case
by (cases n) (auto intro!: is_proj_ta_eps_empty)
next
case (R1Union x1 x2)
then show ?case
by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
case (R1Inter x1 x2)
then show ?case
by (auto intro: is_pod_ta_eps_empty)
next
case (R1Diff x1 x2)
then show ?case
by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
case (R2GTT_Rel x1 x2 x3)
then show ?case
by (cases x2; cases x3) (auto simp: GTT_to_RR2_root_reg_def ftrancl_eps_free_closures_def
eps_free_nhole_mctxt_closure_reg_def eps_free_nhole_mctxt_reflcl_reg_def Let_def
eps_free_mctxt_closure_reg_def reflcl_reg_def
dest: gtt_of_gtt_rel_impl_is_gtt_eps_free
intro!: is_GTT_to_RR2_root_eps_empty is_reflcl_automaton_eps_free)
next
case (R2Diag x)
then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
case (R2Prod x1 x2)
then show ?case by (auto intro: is_pair_automaton_reg_eps_empty)
next
case (R2Inv x)
then show ?case by (auto simp: fmap_funs_reg_def fmap_funs_ta_def is_ta_eps_free_def)
next
case (R2Union x1 x2)
then show ?case by (simp add: reg_union_def ta_union_def fmap_states_ta_def is_ta_eps_free_def relabel_reg_def relabel_ta_def)
next
case (R2Inter x1 x2)
then show ?case by (auto intro: is_pod_ta_eps_empty)
next
case (R2Diff x1 x2)
then show ?case by (auto simp: difference_reg_def Let_def complement_reg_def ps_reg_def ps_ta_def intro!: is_pod_ta_eps_empty)
next
case (R2Comp x1 x2)
then show ?case by (auto simp: is_term_automata_eps_empty rr2_compositon_def Let_def
intro!: is_pod_ta_eps_empty is_fmap_funs_reg_eps_empty is_collapse_automaton_reg_eps_empty is_pair_automaton_reg_eps_empty)
qed
lemma rr_of_rr_rel_impl_complete:
"rr1_of_rr1_rel_impl \<F> Rs r1 \<noteq> None \<longleftrightarrow> rr1_of_rr1_rel \<F> Rs r1 \<noteq> None"
"rr2_of_rr2_rel_impl \<F> Rs r2 \<noteq> None \<longleftrightarrow> rr2_of_rr2_rel \<F> Rs r2 \<noteq> None"
proof (induct r1 and r2)
case (R1Proj n x2)
then show ?case by (cases n) auto
next
case (R2GTT_Rel x1 n p)
then show ?case using gtt_of_gtt_rel_impl_gtt_of_gtt_rel[of \<F> Rs]
by (cases p; cases n) auto
qed auto
lemma \<Q>_fmap_funs_reg [simp]:
"\<Q>\<^sub>r (fmap_funs_reg f \<A>) = \<Q>\<^sub>r \<A>"
by (auto simp: fmap_funs_reg_def)
lemma ta_reachable_fmap_funs_reg [simp]:
"ta_reachable (ta (fmap_funs_reg f \<A>)) = ta_reachable (ta \<A>)"
by (auto simp: fmap_funs_reg_def)
lemma collapse_reg_cong:
"\<Q>\<^sub>r \<A> |\<subseteq>| ta_reachable (ta \<A>) \<Longrightarrow> \<Q>\<^sub>r \<B> |\<subseteq>| ta_reachable (ta \<B>) \<Longrightarrow> \<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (collapse_automaton_reg \<A>) = \<L> (collapse_automaton_reg \<B>)"
by (auto simp: collapse_automaton_reg_def \<L>_def collapse_automaton')
lemma \<L>_fmap_funs_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (fmap_funs_reg h \<A>) = \<L> (fmap_funs_reg h \<B>)"
by (auto simp: fmap_funs_\<L>)
lemma \<L>_pair_automaton_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> \<C> = \<L> \<D> \<Longrightarrow> \<L> (pair_automaton_reg \<A> \<C>) = \<L> (pair_automaton_reg \<B> \<D>)"
by (auto simp: pair_automaton')
lemma \<L>_nhole_ctxt_closure_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_ctxt_closure_reg \<F> \<A>) = \<L> (nhole_ctxt_closure_reg \<G> \<B>)"
by (auto simp: nhole_ctxtcl_lang)
lemma \<L>_nhole_mctxt_closure_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_closure_reg \<F> \<A>) = \<L> (nhole_mctxt_closure_reg \<G> \<B>)"
by (auto simp: nhole_gmctxt_closure_lang)
lemma \<L>_ctxt_closure_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (ctxt_closure_reg \<F> \<A>) = \<L> (ctxt_closure_reg \<G> \<B>)"
by (auto simp: gctxt_closure_lang)
lemma \<L>_parallel_closure_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (parallel_closure_reg \<F> \<A>) = \<L> (parallel_closure_reg \<G> \<B>)"
by (auto simp: parallelcl_gmctxt_lang)
lemma \<L>_mctxt_closure_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (mctxt_closure_reg \<F> \<A>) = \<L> (mctxt_closure_reg \<G> \<B>)"
by (auto simp: gmctxt_closure_lang)
lemma \<L>_nhole_mctxt_reflcl_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<F> = \<G> \<Longrightarrow> \<L> (nhole_mctxt_reflcl_reg \<F> \<A>) = \<L> (nhole_mctxt_reflcl_reg \<G> \<B>)"
unfolding nhole_mctxt_reflcl_lang
by (intro arg_cong2[where ?f = "(\<union>)"] \<L>_nhole_mctxt_closure_reg_cong) auto
declare equalityI[rule del]
declare fsubsetI[rule del]
lemma \<L>_proj_1_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_1_reg \<A>) = \<L> (proj_1_reg \<B>)"
by (auto simp: proj_1_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)
lemma \<L>_proj_2_reg_cong:
"\<L> \<A> = \<L> \<B> \<Longrightarrow> \<L> (proj_2_reg \<A>) = \<L> (proj_2_reg \<B>)"
by (auto simp: proj_2_reg_def \<L>_trim intro!: collapse_reg_cong \<L>_fmap_funs_reg_cong)
lemma rr2_of_rr2_rel_impl_sound:
assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
shows "\<And> A B. rr1_of_rr1_rel_impl \<F> Rs r1 = Some A \<Longrightarrow> rr1_of_rr1_rel \<F> Rs r1 = Some B \<Longrightarrow> \<L> A = \<L> B"
"\<And> A B. rr2_of_rr2_rel_impl \<F> Rs r2 = Some A \<Longrightarrow> rr2_of_rr2_rel \<F> Rs r2 = Some B \<Longrightarrow> \<L> A = \<L> B"
proof (induct r1 and r2)
case (R1Inf r)
then obtain C D where inf: "rr2_of_rr2_rel_impl \<F> Rs r = Some C" "rr2_of_rr2_rel \<F> Rs r = Some D"
"\<L> C = \<L> D" by auto
have spec: "RR2_spec C (eval_rr2_rel (fset \<F>) (map fset Rs) r)" "RR2_spec D (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
using rr12_of_rr12_rel_correct(2)[OF assms, rule_format, OF inf(2)] inf(3)
by (auto simp: RR2_spec_def)
then have trim_spec: "RR2_spec (trim_reg C) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
"RR2_spec (trim_reg D) (eval_rr2_rel (fset \<F>) (map fset Rs) r)"
by (auto simp: RR2_spec_def \<L>_trim)
let ?C = "Inf_reg (trim_reg C) (Q_infty (ta (trim_reg C)) \<F>)" let ?D = "Inf_reg (trim_reg D) (Q_infty (ta (trim_reg D)) \<F>)"
from spec have *: "\<L> (Inf_reg_impl (trim_reg C)) = \<L> ?C"
using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
from spec have **: "\<L> (Inf_reg_impl (trim_reg D)) = \<L> ?D"
using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
by (intro Inf_reg_impl_sound) (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def)
then have C: "RR2_spec ?C {(s, t) | s t. gpair s t \<in> \<L> ?C}" and
D: "RR2_spec ?D {(s, t) | s t. gpair s t \<in> \<L> ?D}"
using subset_trans[OF Inf_automata_subseteq[of "trim_reg C" \<F>], of "\<L> C"] spec
using subset_trans[OF Inf_automata_subseteq[of "trim_reg D" \<F>], of "\<L> D"]
using eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
by (auto simp: RR2_spec_def \<L>_trim \<T>\<^sub>G_equivalent_def intro!: equalityI fsubsetI)
from * ** have r: "\<L> (proj_1_reg (Inf_reg_impl (trim_reg C))) = \<L> (proj_1_reg ?C)"
"\<L> (proj_1_reg (Inf_reg_impl (trim_reg D))) = \<L> (proj_1_reg ?D)"
by (auto intro: \<L>_proj_1_reg_cong)
from \<L>_Inf_reg[OF trim_spec(1), of \<F>] \<L>_Inf_reg[OF trim_spec(2), of \<F>]
show ?case using R1Inf eval_rr12_rel_sig(2)[of "fset \<F>" "map fset Rs" r]
by (auto simp: liftO1_def r inf \<T>\<^sub>G_equivalent_def \<L>_proj(1)[OF C] \<L>_proj(1)[OF D])
next
case (R1Proj n x2)
then show ?case by (cases n)
(auto simp: liftO1_def \<L>_trim proj_1_reg_def proj_2_reg_def intro!: fsubsetI \<L>_fmap_funs_reg_cong collapse_reg_cong, (meson fin_mono trim_reg_reach)+)
next
case (R2GTT_Rel g p n) note IH = this
note ass = R2GTT_Rel
consider (a) "\<exists> A. gtt_of_gtt_rel_impl \<F> Rs g = Some A" | (b) "gtt_of_gtt_rel_impl \<F> Rs g = None" by blast
then show ?case
proof cases
case a then obtain C D where gtt [simp]: "gtt_of_gtt_rel_impl \<F> Rs g = Some C"
"gtt_of_gtt_rel \<F> Rs g = Some D" using gtt_of_gtt_rel_impl_gtt_of_gtt_rel by blast
from gtt_of_gtt_rel_impl_sound[OF this]
have spec [simp]: "agtt_lang C = agtt_lang D" by auto
have eps [simp]: "is_ta_eps_free (ta (GTT_to_RR2_root_reg C))"
using gtt_of_gtt_rel_impl_is_gtt_eps_free[OF gtt(1)]
by (auto simp: GTT_to_RR2_root_reg_def GTT_to_RR2_root_def pair_automaton_def is_ta_eps_free_def is_gtt_eps_free_def)
have lang: "\<L> (GTT_to_RR2_root_reg C) = \<L> (GTT_to_RR2_root_reg D)"
by (metis (no_types, lifting) GTT_to_RR2_root RR2_spec_def spec)
show ?thesis
proof (cases p)
case PRoot
then show ?thesis using IH spec lang
by (cases n) (auto simp: \<L>_eps_free \<L>_reflcl_reg)
next
case PNonRoot
then show ?thesis using IH
by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_nhole_ctxt_closure_reg[OF eps]
\<L>_eps_free_nhole_mctxt_reflcl_reg[OF eps] \<L>_eps_free_nhole_mctxt_closure_reg[OF eps]
lang intro: \<L>_nhole_ctxt_closure_reg_cong \<L>_nhole_mctxt_reflcl_reg_cong \<L>_nhole_mctxt_closure_reg_cong)
next
case PAny
then show ?thesis using IH
by (cases n) (auto simp: \<L>_eps_free \<L>_eps_free_ctxt_closure_reg[OF eps]
\<L>_eps_free_parallel_closure_reg[OF eps] \<L>_eps_free_mctxt_closure_reg[OF eps] lang
intro!: \<L>_ctxt_closure_reg_cong \<L>_parallel_closure_reg_cong \<L>_mctxt_closure_reg_cong)
qed
next
case b then show ?thesis using IH
by (cases p; cases n) auto
qed
next
case (R2Comp x1 x2)
then show ?case
by (auto simp: liftO1_def rr2_compositon_def \<L>_trim \<L>_intersect Let_def
intro!: \<L>_pair_automaton_reg_cong \<L>_fmap_funs_reg_cong collapse_reg_cong arg_cong2[where ?f = "(\<inter>)"])
qed (auto simp: liftO1_def \<L>_intersect \<L>_union \<L>_trim \<L>_difference_reg intro!: \<L>_fmap_funs_reg_cong \<L>_pair_automaton_reg_cong)
declare equalityI[intro!]
declare fsubsetI[intro!]
lemma rr12_of_rr12_rel_impl_correct:
assumes "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
shows "\<forall>ta1. rr1_of_rr1_rel_impl \<F> Rs r1 = Some ta1 \<longrightarrow> RR1_spec ta1 (eval_rr1_rel (fset \<F>) (map fset Rs) r1)"
"\<forall>ta2. rr2_of_rr2_rel_impl \<F> Rs r2 = Some ta2 \<longrightarrow> RR2_spec ta2 (eval_rr2_rel (fset \<F>) (map fset Rs) r2)"
using rr12_of_rr12_rel_correct(1)[OF assms, of r1]
using rr12_of_rr12_rel_correct(2)[OF assms, of r2]
using rr2_of_rr2_rel_impl_sound(1)[OF assms, of r1]
using rr2_of_rr2_rel_impl_sound(2)[OF assms, of r2]
using rr_of_rr_rel_impl_complete(1)[of \<F> Rs r1]
using rr_of_rr_rel_impl_complete(2)[of \<F> Rs r2]
by (force simp: RR1_spec_def RR2_spec_def)+
lemma check_inference_rrn_impl_correct:
assumes sig: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" and Rs: "\<forall>R \<in> set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
assumes infs: "\<And>fvA. fvA \<in> set infs \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)"
assumes inf: "check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs infs (l, step, fm, is) = Some (fm', vs, A')"
shows "l = length infs \<and> fm = fm' \<and> formula_spec (fset \<F>) (map fset Rs) vs A' fm'"
using check_inference_correct[where ?rr1c = rr1_of_rr1_rel_impl and ?rr2c = rr2_of_rr2_rel_impl, OF assms]
using rr12_of_rr12_rel_impl_correct[OF Rs]
by auto
definition check_sig_nempty where
"check_sig_nempty \<F> = (0 |\<in>| snd |`| \<F>)"
definition check_trss where
"check_trss \<R> \<F> = list_all (\<lambda> R. lv_trs (fset R) \<and> funas_trs (fset R) \<subseteq> fset \<F>) \<R>"
lemma check_sig_nempty:
"check_sig_nempty \<F> \<longleftrightarrow> \<T>\<^sub>G (fset \<F>) \<noteq> {}" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
{assume ?Ls then obtain a where "(a, 0) |\<in>| \<F>" by (auto simp: check_sig_nempty_def)
then have "GFun a [] \<in> \<T>\<^sub>G (fset \<F>)"
- by (intro const) (simp add: fmember.rep_eq)
+ by (intro const) (simp add: fmember_iff_member_fset)
then have ?Rs by blast}
moreover
{assume ?Rs then obtain s where "s \<in> \<T>\<^sub>G (fset \<F>)" by blast
- then obtain a where "(a, 0) |\<in>| \<F>" unfolding fmember.rep_eq
+ then obtain a where "(a, 0) |\<in>| \<F>" unfolding fmember_iff_member_fset
by (induct s) (auto, force)
then have ?Ls unfolding check_sig_nempty_def
by (auto simp: fimage_iff fBex_def)}
ultimately show ?thesis by blast
qed
lemma check_trss:
"check_trss \<R> \<F> \<longleftrightarrow> (\<forall> R \<in> set \<R>. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>)"
unfolding check_trss_def list_all_iff
- by (auto simp: fmember.rep_eq ffunas_trs.rep_eq less_eq_fset.rep_eq)
+ by (auto simp: fmember_iff_member_fset ffunas_trs.rep_eq less_eq_fset.rep_eq)
fun check_inference_list :: "('f \<times> nat) fset \<Rightarrow> ('f :: {compare,linorder}, 'v) fin_trs list
\<Rightarrow> (nat \<times> ftrs inference \<times> ftrs formula \<times> info list) list
\<Rightarrow> (ftrs formula \<times> nat list \<times> (nat, 'f option list) reg) list option" where
"check_inference_list \<F> Rs infs = do {
guard (check_sig_nempty \<F>);
guard (check_trss Rs \<F>);
foldl (\<lambda> tas inf. do {
tas' \<leftarrow> tas;
r \<leftarrow> check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs tas' inf;
Some (tas' @ [r])
})
(Some []) infs
}"
lemma check_inference_list_correct:
assumes "check_inference_list \<F> Rs infs = Some fvAs"
shows "length infs = length fvAs \<and> (\<forall> i < length fvAs. fst (snd (snd (infs ! i))) = fst (fvAs ! i)) \<and>
(\<forall> i < length fvAs. formula_spec (fset \<F>) (map fset Rs) (fst (snd (fvAs ! i))) (snd (snd (fvAs ! i))) (fst (fvAs ! i)))"
using assms
proof (induct infs arbitrary: fvAs rule: rev_induct)
note [simp] = bind_eq_Some_conv guard_simps
{case Nil
then show ?case by auto
next
case (snoc a infs)
have inv: "\<T>\<^sub>G (fset \<F>) \<noteq> {}" "\<forall>R\<in>set Rs. lv_trs (fset R) \<and> ffunas_trs R |\<subseteq>| \<F>"
using snoc(2) by (auto simp: check_sig_nempty check_trss)
from snoc(2) obtain fvAs' l steps fm fm' is' vs A' where
ch: "check_inference_list \<F> Rs infs = Some fvAs'" "a = (l, steps, fm, is')"
"check_inference rr1_of_rr1_rel_impl rr2_of_rr2_rel_impl \<F> Rs fvAs' (l, steps, fm, is') = Some (fm', vs, A')" "fvAs = fvAs' @ [(fm', vs, A')]"
by (auto simp del: check_inference.simps) (metis prod_cases4)
from snoc(1)[OF ch(1)] have "fvA \<in> set fvAs' \<Longrightarrow> formula_spec (fset \<F>) (map fset Rs) (fst (snd fvA)) (snd (snd fvA)) (fst fvA)" for fvA
by (auto dest: in_set_idx)
from check_inference_rrn_impl_correct[OF inv this, of fvAs'] this
show ?case using snoc(1)[OF ch(1)] ch
by (auto simp del: check_inference.simps simp: nth_append)
}
qed
fun check_certificate where
"check_certificate \<F> Rs A fm (Certificate infs claim n) = do {
guard (n < length infs);
guard (A \<longleftrightarrow> claim = Nonempty);
guard (fm = fst (snd (snd (infs ! n))));
fvA \<leftarrow> check_inference_list \<F> Rs (take (Suc n) infs);
(let E = reg_empty (snd (snd (last fvA))) in
case claim of Empty \<Rightarrow> Some E
| _ \<Rightarrow> Some (\<not> E))
}"
definition formula_unsatisfiable where
"formula_unsatisfiable \<F> Rs fm \<longleftrightarrow> (formula_satisfiable \<F> Rs fm = False)"
definition correct_certificate where
"correct_certificate \<F> Rs claim infs n \<equiv>
(claim = Empty \<longleftrightarrow> (formula_unsatisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n))))) \<and>
claim = Nonempty \<longleftrightarrow> formula_satisfiable (fset \<F>) (map fset Rs) (fst (snd (snd (infs ! n)))))"
lemma check_certificate_sound:
assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
shows "fm = fst (snd (snd (infs ! n)))" "A \<longleftrightarrow> claim = Nonempty"
using assms by (auto simp: bind_eq_Some_conv guard_simps)
lemma check_certificate_correct:
assumes "check_certificate \<F> Rs A fm (Certificate infs claim n) = Some B"
shows "(B = True \<longrightarrow> correct_certificate \<F> Rs claim infs n) \<and>
(B = False \<longrightarrow> correct_certificate \<F> Rs (case_claim Nonempty Empty claim) infs n)"
proof -
note [simp] = bind_eq_Some_conv guard_simps
from assms obtain fvAs where inf: "check_inference_list \<F> Rs (take (Suc n) infs) = Some fvAs"
by auto
from assms have len: "n < length infs" by auto
from check_inference_list_correct[OF inf] have
inv: "length fvAs = n + 1"
"fst (snd (snd (infs ! n))) = fst (fvAs ! n)"
"formula_spec (fset \<F>) (map fset Rs) (fst (snd (last fvAs))) (snd (snd (last fvAs))) (fst (last fvAs))"
using len last_conv_nth[of fvAs] by force+
have nth: "fst (last fvAs) = fst (fvAs ! n)" using inv(1)
using len last_conv_nth[of fvAs] by force
note spec = formula_spec_empty[OF _ inv(3)] formula_spec_nt_empty_form_sat[OF _ inv(3)]
consider (a) "claim = Empty" | (b) "claim = Nonempty" using claim.exhaust by blast
then show ?thesis
proof cases
case a
then have *: "B = reg_empty (snd (snd (last fvAs)))" using inv
using assms len last_conv_nth[of fvAs]
by (auto simp: inf simp del: check_inference_list.simps)
show ?thesis using a inv spec unfolding *
by (auto simp: formula_satisfiable_def nth correct_certificate_def formula_unsatisfiable_def simp del: reg_empty)
next
case b
then have *: "B \<longleftrightarrow> \<not> (reg_empty (snd (snd (last fvAs))))" using inv
using assms len last_conv_nth[of fvAs]
by (auto simp: inf simp del: check_inference_list.simps)
show ?thesis using b inv spec unfolding *
by (auto simp: formula_satisfiable_def nth formula_unsatisfiable_def correct_certificate_def simp del: reg_empty)
qed
qed
definition check_certificate_string ::
"(integer list \<times> fvar) fset \<Rightarrow>
((integer list, integer list) Term.term \<times> (integer list, integer list) Term.term) fset list \<Rightarrow>
bool \<Rightarrow> ftrs formula \<Rightarrow> ftrs certificate \<Rightarrow> bool option"
where "check_certificate_string = check_certificate"
(***********************************)
export_code check_certificate_string Var Fun fset_of_list nat_of_integer Certificate
R2GTT_Rel R2Eq R2Reflc R2Step R2StepEq R2Steps R2StepsEq R2StepsNF R2ParStep R2RootStep
R2RootStepEq R2RootSteps R2RootStepsEq R2NonRootStep R2NonRootStepEq R2NonRootSteps
R2NonRootStepsEq R2Meet R2Join
ARoot GSteps PRoot ESingle Empty Size EDistribAndOr
R1Terms R1Fin
FRR1 FRestrict FTrue FFalse
IRR1 Fwd in Haskell module_name FOR
end
\ No newline at end of file
diff --git a/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy b/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy
--- a/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy
+++ b/thys/FO_Theory_Rewriting/Primitives/LV_to_GTT.thy
@@ -1,330 +1,330 @@
section \<open>Primitive constructions\<close>
theory LV_to_GTT
imports Regular_Tree_Relations.Pair_Automaton
Bot_Terms
Rewriting
begin
subsection \<open>Recognizing subterms of linear terms\<close>
(* Pattern recognizer automaton *)
abbreviation ffunas_terms where
"ffunas_terms R \<equiv> |\<Union>| (ffunas_term |`| R)"
definition "states R \<equiv> {t\<^sup>\<bottom> | s t. s \<in> R \<and> s \<unrhd> t}"
lemma states_conv:
"states R = term_to_bot_term ` (\<Union> s \<in> R. subterms s)"
unfolding states_def set_all_subteq_subterms
by auto
lemma finite_states:
assumes "finite R" shows "finite (states R)"
proof -
have conv: "states R = term_to_bot_term ` (\<Union> s \<in> R. {t | t. s \<unrhd> t})"
unfolding states_def by auto
from assms have "finite (\<Union> s \<in> R. {t | t. s \<unrhd> t})"
by (intro finite_UN_I2 finite_imageI) (simp add: finite_subterms)+
then show ?thesis using conv by auto
qed
lemma root_bot_diff:
"root_bot ` (R - {Bot}) = (root_bot ` R) - {None}"
using root_bot.elims by auto
lemma root_bot_states_root_subterms:
"the ` (root_bot ` (states R - {Bot})) = the ` (root ` (\<Union> s \<in> R. subterms s) - {None})"
unfolding states_conv root_bot_diff
unfolding image_comp
by simp
context
includes fset.lifting
begin
lift_definition fstates :: "('f, 'v) term fset \<Rightarrow> 'f bot_term fset" is states
by (simp add: finite_states)
lift_definition fsubterms :: "('f, 'v) term \<Rightarrow> ('f, 'v) term fset" is subterms
by (simp add: finite_subterms_fun)
lemmas fsubterms [code] = subterms.simps[Transfer.transferred]
lift_definition ffunas_trs :: "(('f, 'v) term \<times> ('f, 'v) term) fset \<Rightarrow> ('f \<times> nat) fset" is funas_trs
by (simp add: finite_funas_trs)
lemma fstates_def':
"t |\<in>| fstates R \<longleftrightarrow> (\<exists> s u. s |\<in>| R \<and> s \<unrhd> u \<and> u\<^sup>\<bottom> = t)"
by transfer (auto simp: states_def)
lemma fstates_fmemberE [elim!]:
assumes "t |\<in>| fstates R"
obtains s u where "s |\<in>| R \<and> s \<unrhd> u \<and> u\<^sup>\<bottom> = t"
using assms unfolding fstates_def'
by blast
lemma fstates_fmemberI [intro]:
"s |\<in>| R \<Longrightarrow> s \<unrhd> u \<Longrightarrow> u\<^sup>\<bottom> |\<in>| fstates R"
unfolding fstates_def' by blast
lemmas froot_bot_states_root_subterms = root_bot_states_root_subterms[Transfer.transferred]
lemmas root_fsubsterms_ffunas_term_fset = root_substerms_funas_term_set[Transfer.transferred]
lemma fstates[code]:
"fstates R = term_to_bot_term |`| ( |\<Union>| (fsubterms |`| R))"
by transfer (auto simp: states_conv)
end
definition ta_rule_sig where
"ta_rule_sig = (\<lambda> r. (r_root r, length (r_lhs_states r)))"
primrec term_to_ta_rule where
"term_to_ta_rule (BFun f ts) = TA_rule f ts (BFun f ts)"
lemma ta_rule_sig_term_to_ta_rule_root:
"t \<noteq> Bot \<Longrightarrow> ta_rule_sig (term_to_ta_rule t) = the (root_bot t)"
by (cases t) (auto simp: ta_rule_sig_def)
lemma ta_rule_sig_term_to_ta_rule_root_set:
assumes "Bot |\<notin>| R"
shows "ta_rule_sig |`| (term_to_ta_rule |`| R) = the |`| (root_bot |`| R)"
proof -
{fix x assume "x |\<in>| R" then have "ta_rule_sig (term_to_ta_rule x) = the (root_bot x)"
using ta_rule_sig_term_to_ta_rule_root[of x] assms
by auto}
then show ?thesis
by (force simp: fimage_iff)
qed
definition pattern_automaton_rules where
"pattern_automaton_rules \<F> R =
(let states = (fstates R) - {|Bot|} in
term_to_ta_rule |`| states |\<union>| (\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) |`| \<F>)"
lemma pattern_automaton_rules_BotD:
assumes "TA_rule f ss Bot |\<in>| pattern_automaton_rules \<F> R"
shows "TA_rule f ss Bot |\<in>| (\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) |`| \<F>" using assms
by (auto simp: pattern_automaton_rules_def)
(metis ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)
lemma pattern_automaton_rules_FunD:
assumes "TA_rule f ss (BFun g ts) |\<in>| pattern_automaton_rules \<F> R"
shows "g = f \<and> ts = ss \<and>
TA_rule f ss (BFun g ts) |\<in>| term_to_ta_rule |`| ((fstates R) - {|Bot|})" using assms
apply (auto simp: pattern_automaton_rules_def)
apply (metis bot_term.exhaust ta_rule.inject term_to_ta_rule.simps)
by (metis (no_types, lifting) ta_rule.inject term_to_bot_term.elims term_to_ta_rule.simps)
definition pattern_automaton where
"pattern_automaton \<F> R = TA (pattern_automaton_rules \<F> R) {||}"
lemma ta_sig_pattern_automaton [simp]:
"ta_sig (pattern_automaton \<F> R) = \<F> |\<union>| ffunas_terms R"
proof -
let ?r = "ta_rule_sig"
have *:"Bot |\<notin>| (fstates R) - {|Bot|}" by simp
have f: "\<F> = ?r |`| ((\<lambda> (f, n). TA_rule f (replicate n Bot) Bot) |`| \<F>)"
by (auto simp: fimage_iff fBex_def ta_rule_sig_def split!: prod.splits)
moreover have "ffunas_terms R = ?r |`| (term_to_ta_rule |`| ((fstates R) - {|Bot|}))"
unfolding ta_rule_sig_term_to_ta_rule_root_set[OF *]
unfolding froot_bot_states_root_subterms root_fsubsterms_ffunas_term_fset
by simp
ultimately show ?thesis unfolding pattern_automaton_def ta_sig_def
unfolding ta_rule_sig_def pattern_automaton_rules_def
by (auto simp add: Let_def comp_def fimage_funion)
qed
lemma terms_reach_Bot:
assumes "ffunas_gterm t |\<subseteq>| \<F>"
shows "Bot |\<in>| ta_der (pattern_automaton \<F> R) (term_of_gterm t)" using assms
proof (induct t)
case (GFun f ts)
have [simp]: "s \<in> set ts \<Longrightarrow> ffunas_gterm s |\<subseteq>| \<F>" for s using GFun(2)
using in_set_idx by fastforce
from GFun show ?case
by (auto simp: pattern_automaton_def pattern_automaton_rules_def rev_fimage_eqI
intro!: exI[of _ "replicate (length ts) Bot"])
qed
lemma pattern_automaton_reach_smaller_term:
assumes "l |\<in>| R" "l \<unrhd> s" "s\<^sup>\<bottom> \<le>\<^sub>b (term_of_gterm t)\<^sup>\<bottom>" "ffunas_gterm t |\<subseteq>| \<F>"
shows "s\<^sup>\<bottom> |\<in>| ta_der (pattern_automaton \<F> R) (term_of_gterm t)" using assms(2-)
proof (induct t arbitrary: s)
case (GFun f ts) show ?case
proof (cases s)
case (Var x)
then show ?thesis using terms_reach_Bot[OF GFun(4)]
by (auto simp del: ta_der_Fun)
next
case [simp]: (Fun g ss)
let ?ss = "map term_to_bot_term ss"
have [simp]: "s \<in> set ts \<Longrightarrow> ffunas_gterm s |\<subseteq>| \<F>" for s using GFun(4)
using in_set_idx by fastforce
from GFun(3) have s: "g = f" "length ss = length ts" by auto
from GFun(2) s(2) assms(1) have rule: "TA_rule f ?ss (BFun f ?ss) |\<in>| pattern_automaton_rules \<F> R"
by (auto simp: s(1) pattern_automaton_rules_def fimage_iff fBex_def)
{fix i assume bound: "i < length ts"
then have sub: "l \<unrhd> ss ! i" using GFun(2) arg_subteq[OF nth_mem, of i ss f]
unfolding Fun s(1) using s(2) by (metis subterm.order.trans)
have "ss ! i\<^sup>\<bottom> \<le>\<^sub>b (term_of_gterm (ts ! i):: ('a, 'c) term)\<^sup>\<bottom>" using GFun(3) bound s(2)
by (auto simp: s elim!: bless_eq.cases)
from GFun(1)[OF nth_mem sub this] bound
have "ss ! i\<^sup>\<bottom> |\<in>| ta_der (pattern_automaton \<F> R) (term_of_gterm (ts ! i))"
by auto}
then show ?thesis using GFun(2-) s(2) rule
by (auto simp: s(1) pattern_automaton_def intro!: exI[of _ ?ss] exI[of _ "BFun f ?ss"])
qed
qed
lemma bot_term_of_gterm_conv:
"term_of_gterm s\<^sup>\<bottom> = term_of_gterm s\<^sup>\<bottom>"
by (induct s) auto
lemma pattern_automaton_ground_instance_reach:
assumes "l |\<in>| R" "l \<cdot> \<sigma> = (term_of_gterm t)" "ffunas_gterm t |\<subseteq>| \<F>"
shows "l\<^sup>\<bottom> |\<in>| ta_der (pattern_automaton \<F> R) (term_of_gterm t)"
proof -
let ?t = "(term_of_gterm t) :: ('a, 'a bot_term) term"
from instance_to_bless_eq[OF assms(2)] have sm: "l\<^sup>\<bottom> \<le>\<^sub>b ?t\<^sup>\<bottom>"
using bot_term_of_gterm_conv by metis
show ?thesis using pattern_automaton_reach_smaller_term[OF assms(1) _ sm] assms(3-)
by auto
qed
lemma pattern_automaton_reach_smallet_term:
assumes "l\<^sup>\<bottom> |\<in>| ta_der (pattern_automaton \<F> R) t" "ground t"
shows "l\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>" using assms
proof (induct t arbitrary: l)
case (Fun f ts) note IH = this show ?case
proof (cases l)
case (Fun g ss)
let ?ss = "map term_to_bot_term ss"
from IH(2) have rule: "g = f" "length ss = length ts"
"TA_rule f ?ss (BFun f ?ss) |\<in>| rules (pattern_automaton \<F> R)"
by (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)
{fix i assume "i < length ts"
then have "ss ! i\<^sup>\<bottom> \<le>\<^sub>b ts ! i\<^sup>\<bottom>" using IH(2, 3) rule(2)
by (intro IH(1)) (auto simp: Fun pattern_automaton_def dest: pattern_automaton_rules_FunD)}
then show ?thesis using rule(2)
by (auto simp: Fun rule(1))
qed auto
qed auto
subsection \<open>Recognizing root step relation of LV-TRSs\<close>
definition lv_trs :: "('f, 'v) trs \<Rightarrow> bool" where
"lv_trs R \<equiv> \<forall>(l, r) \<in> R. linear_term l \<and> linear_term r \<and> (vars_term l \<inter> vars_term r = {})"
lemma subst_unification:
assumes "vars_term s \<inter> vars_term t = {}"
obtains \<mu> where "s \<cdot> \<sigma> = s \<cdot> \<mu>" "t \<cdot> \<tau> = t \<cdot> \<mu>"
using assms
by (auto intro!: that[of "\<lambda>x. if x \<in> vars_term s then \<sigma> x else \<tau> x"] simp: term_subst_eq_conv)
lemma lv_trs_subst_unification:
assumes "lv_trs R" "(l, r) \<in> R" "s = l \<cdot> \<sigma>" "t = r \<cdot> \<tau>"
obtains \<mu> where "s = l \<cdot> \<mu> \<and> t = r \<cdot> \<mu>"
using assms subst_unification[of l r \<sigma> \<tau>]
unfolding lv_trs_def
by (force split!: prod.splits)
definition Rel\<^sub>f where
"Rel\<^sub>f R = map_both term_to_bot_term |`| R"
definition root_pair_automaton where
"root_pair_automaton \<F> R = (pattern_automaton \<F> (fst |`| R),
pattern_automaton \<F> (snd |`| R))"
definition agtt_grrstep where
"agtt_grrstep \<R> \<F> = pair_at_to_agtt' (root_pair_automaton \<F> \<R>) (Rel\<^sub>f \<R>)"
lemma agtt_grrstep_eps_trancl [simp]:
"(eps (fst (agtt_grrstep \<R> \<F>)))|\<^sup>+| = eps (fst (agtt_grrstep \<R> \<F>))"
"(eps (snd (agtt_grrstep \<R> \<F>))) = {||}"
by (auto simp add: agtt_grrstep_def pair_at_to_agtt'_def
pair_at_to_agtt_def Let_def root_pair_automaton_def pattern_automaton_def
fmap_states_ta_def intro!: frelcomp_empty_ftrancl_simp)
lemma root_pair_automaton_grrstep:
fixes R :: "('f, 'v) rule fset"
assumes "lv_trs (fset R)" "ffunas_trs R |\<subseteq>| \<F>"
shows "pair_at_lang (root_pair_automaton \<F> R) (Rel\<^sub>f R) = Restr (grrstep (fset R)) (\<T>\<^sub>G (fset \<F>))" (is "?Ls = ?Rs")
proof
let ?t_o_g = "term_of_gterm :: 'f gterm \<Rightarrow> ('f, 'v) Term.term"
have [simp]: "\<F> |\<union>| |\<Union>| ((ffunas_term \<circ> fst) |`| R) = \<F>"
"\<F> |\<union>| |\<Union>| ((ffunas_term \<circ> snd) |`| R) = \<F>" using assms(2)
- by (force simp: less_eq_fset.rep_eq ffunas_trs.rep_eq funas_trs_def ffunas_term.rep_eq fmember.rep_eq ffUnion.rep_eq)+
+ by (force simp: less_eq_fset.rep_eq ffunas_trs.rep_eq funas_trs_def ffunas_term.rep_eq fmember_iff_member_fset ffUnion.rep_eq)+
{fix s t assume "(s, t) \<in> ?Ls"
from pair_at_langE[OF this] obtain p q where st: "(q, p) |\<in>| Rel\<^sub>f R"
"q |\<in>| gta_der (fst (root_pair_automaton \<F> R)) s" "p |\<in>| gta_der (snd (root_pair_automaton \<F> R)) t"
by blast
from st(1) obtain l r where tm: "q = l\<^sup>\<bottom>" "p = r\<^sup>\<bottom>" "(l, r) |\<in>| R" unfolding Rel\<^sub>f_def
using assms(1) by (auto simp: fmember.abs_eq)
have sm: "l\<^sup>\<bottom> \<le>\<^sub>b (?t_o_g s)\<^sup>\<bottom>" "r\<^sup>\<bottom> \<le>\<^sub>b (?t_o_g t)\<^sup>\<bottom>"
using pattern_automaton_reach_smallet_term[of l \<F> "fst |`| R" "term_of_gterm s"]
using pattern_automaton_reach_smallet_term[of r \<F> "snd |`| R" "term_of_gterm t"]
using st(2, 3) tm(3) unfolding tm
by (auto simp: gta_der_def root_pair_automaton_def) (smt bot_term_of_gterm_conv)+
have "linear_term l" "linear_term r" using tm(3) assms(1)
- by (auto simp: lv_trs_def fmember.rep_eq)
+ by (auto simp: lv_trs_def fmember_iff_member_fset)
then obtain \<sigma> \<tau> where "l \<cdot> \<sigma> = ?t_o_g s" "r \<cdot> \<tau> = ?t_o_g t" using sm
by (auto dest!: bless_eq_to_instance)
then obtain \<mu> where subst: "l \<cdot> \<mu> = ?t_o_g s" "r \<cdot> \<mu> = ?t_o_g t"
- using lv_trs_subst_unification[OF assms(1) tm(3)[unfolded fmember.rep_eq], of "?t_o_g s" \<sigma> "?t_o_g t" \<tau>]
+ using lv_trs_subst_unification[OF assms(1) tm(3)[unfolded fmember_iff_member_fset], of "?t_o_g s" \<sigma> "?t_o_g t" \<tau>]
by metis
moreover have "s \<in> \<T>\<^sub>G (fset \<F>)" "t \<in> \<T>\<^sub>G (fset \<F>)" using st(2-) assms
using ta_der_gterm_sig[of q "pattern_automaton \<F> (fst |`| R)" s]
using ta_der_gterm_sig[of p "pattern_automaton \<F> (snd |`| R)" t]
by (auto simp: gta_der_def root_pair_automaton_def \<T>\<^sub>G_equivalent_def less_eq_fset.rep_eq ffunas_gterm.rep_eq)
ultimately have "(s, t) \<in> ?Rs" using tm(3)
- by (auto simp: grrstep_def rrstep_def' fmember.rep_eq) metis}
+ by (auto simp: grrstep_def rrstep_def' fmember_iff_member_fset) metis}
then show "?Ls \<subseteq> ?Rs" by auto
next
let ?t_o_g = "term_of_gterm :: 'f gterm \<Rightarrow> ('f, 'v) Term.term"
{fix s t assume "(s, t) \<in> ?Rs"
then obtain \<sigma> l r where st: "(l, r) |\<in>| R" "l \<cdot> \<sigma> = ?t_o_g s" "r \<cdot> \<sigma> = ?t_o_g t" "s \<in> \<T>\<^sub>G (fset \<F>)" "t \<in> \<T>\<^sub>G (fset \<F>)"
- by (auto simp: grrstep_def rrstep_def' fmember.rep_eq)
+ by (auto simp: grrstep_def rrstep_def' fmember_iff_member_fset)
have funas: "ffunas_gterm s |\<subseteq>| \<F>" "ffunas_gterm t |\<subseteq>| \<F>" using st(4, 5)
by (auto simp: \<T>\<^sub>G_equivalent_def)
(metis ffunas_gterm.rep_eq notin_fset subsetD)+
from st(1) have "(l\<^sup>\<bottom>, r\<^sup>\<bottom>) |\<in>| Rel\<^sub>f R" unfolding Rel\<^sub>f_def using assms(1)
by (auto simp: fimage_iff fBex_def)
then have "(s, t) \<in> ?Ls" using st
using pattern_automaton_ground_instance_reach[of l "fst |`| R" \<sigma>, OF _ _ funas(1)]
using pattern_automaton_ground_instance_reach[of r "snd |`| R" \<sigma>, OF _ _ funas(2)]
by (auto simp: \<T>\<^sub>G_equivalent_def fimage_iff fBex_def fmember.abs_eq root_pair_automaton_def gta_der_def pair_at_lang_def)}
then show "?Rs \<subseteq> ?Ls" by auto
qed
lemma agtt_grrstep:
fixes R :: "('f, 'v) rule fset"
assumes "lv_trs (fset R)" "ffunas_trs R |\<subseteq>| \<F>"
shows "agtt_lang (agtt_grrstep R \<F>) = Restr (grrstep (fset R)) (\<T>\<^sub>G (fset \<F>))"
using root_pair_automaton_grrstep[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
by simp
(* Results for set as input *)
lemma root_pair_automaton_grrstep_set:
fixes R :: "('f, 'v) rule set"
assumes "finite R" "finite \<F>" "lv_trs R" "funas_trs R \<subseteq> \<F>"
shows "pair_at_lang (root_pair_automaton (Abs_fset \<F>) (Abs_fset R)) (Rel\<^sub>f (Abs_fset R)) = Restr (grrstep R) (\<T>\<^sub>G \<F>)"
proof -
from assms(1, 2, 4) have "ffunas_trs (Abs_fset R) |\<subseteq>| Abs_fset \<F>"
- by (auto simp add: Abs_fset_inverse ffunas_trs.rep_eq fmember.rep_eq subset_eq)
+ by (auto simp add: Abs_fset_inverse ffunas_trs.rep_eq fmember_iff_member_fset subset_eq)
from root_pair_automaton_grrstep[OF _ this] assms
show ?thesis
by (auto simp: Abs_fset_inverse)
qed
lemma agtt_grrstep_set:
fixes R :: "('f, 'v) rule set"
assumes "finite R" "finite \<F>" "lv_trs R" "funas_trs R \<subseteq> \<F>"
shows "agtt_lang (agtt_grrstep (Abs_fset R) (Abs_fset \<F>)) = Restr (grrstep R) (\<T>\<^sub>G \<F>)"
using root_pair_automaton_grrstep_set[OF assms] unfolding pair_at_agtt_cost agtt_grrstep_def
by simp
end
diff --git a/thys/FO_Theory_Rewriting/Primitives/NF.thy b/thys/FO_Theory_Rewriting/Primitives/NF.thy
--- a/thys/FO_Theory_Rewriting/Primitives/NF.thy
+++ b/thys/FO_Theory_Rewriting/Primitives/NF.thy
@@ -1,295 +1,295 @@
theory NF
imports
Saturation
Bot_Terms
Regular_Tree_Relations.Tree_Automata
begin
subsection \<open>Recognizing normal forms of left linear TRSs\<close>
interpretation lift_total: semilattice_closure_partial_operator "\<lambda> x y. (x, y) \<in> mergeP" "(\<up>)" "\<lambda> x y. x \<le>\<^sub>b y" Bot
apply unfold_locales apply (auto simp: merge_refl merge_symmetric merge_terms_assoc merge_terms_idem merge_bot_args_bless_eq_merge)
using merge_dist apply blast
using megeP_ass apply blast
using merge_terms_commutative apply blast
apply (metis bless_eq_mergeP bless_eq_trans merge_bot_args_bless_eq_merge merge_dist merge_symmetric merge_terms_commutative)
apply (metis merge_bot_args_bless_eq_merge merge_symmetric merge_terms_commutative)
using bless_eq_closued_under_supremum bless_eq_trans bless_eq_anti_sym
by blast+
abbreviation "psubt_lhs_bot R \<equiv> {t\<^sup>\<bottom> | s t. s \<in> R \<and> s \<rhd> t}"
abbreviation "closure S \<equiv> lift_total.cl.pred_closure S"
definition states where
"states R = insert Bot (closure (psubt_lhs_bot R))"
lemma psubt_mono:
"R \<subseteq> S \<Longrightarrow> psubt_lhs_bot R \<subseteq> psubt_lhs_bot S" by auto
lemma states_mono:
"R \<subseteq> S \<Longrightarrow> states R \<subseteq> states S"
unfolding states_def using lift_total.cl.closure_mono[OF psubt_mono[of R S]]
by auto
lemma finite_lhs_subt [simp, intro]:
assumes "finite R"
shows "finite (psubt_lhs_bot R)"
proof -
have conv: "psubt_lhs_bot R = term_to_bot_term ` {t | s t . s \<in> R \<and> s \<rhd> t}" by auto
from assms have "finite {t | s t . s \<in> R \<and> s \<rhd> t}"
by (simp add: finite_strict_subterms)
then show ?thesis using conv by auto
qed
lemma states_ref_closure:
"states R \<subseteq> insert Bot (closure (psubt_lhs_bot R))"
unfolding states_def by auto
lemma finite_R_finite_states [simp, intro]:
"finite R \<Longrightarrow> finite (states R)"
using finite_lhs_subt states_ref_closure
using lift_total.cl.finite_S_finite_closure finite_subset
by fastforce
abbreviation "lift_sup_small s S \<equiv> lift_total.supremum (lift_total.smaller_subset (Some s) (Some ` S))"
abbreviation "bound_max s S \<equiv> the (lift_sup_small s S)"
lemma bound_max_state_set:
assumes "finite R"
shows "bound_max t (psubt_lhs_bot R) \<in> states R"
using lift_total.supremum_neut_or_in_closure[OF finite_lhs_subt[OF assms], of t]
unfolding states_def by auto
context
includes fset.lifting
begin
lift_definition fstates :: "('a, 'b) term fset \<Rightarrow> 'a bot_term fset" is states
by simp
lemma bound_max_state_fset:
"bound_max t (psubt_lhs_bot (fset R)) |\<in>| fstates R"
using bound_max_state_set[of "fset R" t]
using fstates.rep_eq notin_fset by fastforce
end
definition nf_rules where
"nf_rules R \<F> = {|TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and>
\<not>(\<exists> l |\<in>| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))|}"
lemma nf_rules_fmember:
"TA_rule f qs q |\<in>| nf_rules R \<F> \<longleftrightarrow> (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and>
\<not>(\<exists> l |\<in>| R. l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs) \<and> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
proof -
let ?subP = "\<lambda> n qs. fset_of_list qs |\<subseteq>| fstates R \<and> length qs = n"
let ?sub = "\<lambda> n. Collect (?subP n)"
have *: "finite (?sub n)" for n
using finite_lists_length_eq[of "fset (fstates R)" n]
by (simp add: less_eq_fset.rep_eq fset_of_list.rep_eq)
{fix f n assume mem: "(f, n) \<in> fset \<F>"
have **: "{f} \<times> (?sub n) = {(f, qs) |qs. ?subP n qs}" by auto
from mem have "finite {(f, qs) |qs. ?subP n qs}" using *
using finite_cartesian_product[OF _ *[of n], of "{f}"] unfolding ** by simp}
then have *: "finite (\<Union> (f, n) \<in> fset \<F> . {(f, qs) | qs. ?subP n qs})" by auto
have **: "(\<Union> (f, n) \<in> fset \<F> . {(f, qs) | qs. ?subP n qs}) = {(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs}"
- by (auto simp: fmember.rep_eq)
+ by (auto simp: fmember_iff_member_fset)
have *: "finite ({(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
using * unfolding ** by (intro finite_cartesian_product) auto
have **: "{TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and> q |\<in>| fstates R} =
(\<lambda> ((f, qs), q). TA_rule f qs q) ` ({(f, qs) | f qs. (f, length qs) |\<in>| \<F> \<and> ?subP (length qs) qs} \<times> fset (fstates R))"
- by (auto simp: image_def fmember.rep_eq split!: prod.splits)
+ by (auto simp: image_def fmember_iff_member_fset split!: prod.splits)
have f: "finite {TA_rule f qs q | f qs q. (f, length qs) |\<in>| \<F> \<and> fset_of_list qs |\<subseteq>| fstates R \<and> q |\<in>| fstates R}"
unfolding ** using * by auto
show ?thesis
by (auto simp: nf_rules_def bound_max_state_fset intro!: finite_subset[OF _ f])
qed
definition nf_ta where
"nf_ta R \<F> = TA (nf_rules R \<F>) {||}"
definition nf_reg where
"nf_reg R \<F> = Reg (fstates R) (nf_ta R \<F>)"
lemma bound_max_sound:
assumes "finite R"
shows "bound_max t (psubt_lhs_bot R) \<le>\<^sub>b t"
using assms lift_total.lift_ord.supremum_smaller_subset[of "Some ` psubt_lhs_bot R" "Some t"]
by auto (metis (no_types, lifting) lift_less_eq_total.elims(2) option.sel option.simps(3))
lemma Bot_in_filter:
"Bot \<in> Set.filter (\<lambda>s. s \<le>\<^sub>b t) (states R)"
by (auto simp: Set.filter_def states_def)
lemma bound_max_exists:
"\<exists> p. p = bound_max t (psubt_lhs_bot R)"
by blast
lemma bound_max_unique:
assumes "p = bound_max t (psubt_lhs_bot R)" and "q = bound_max t (psubt_lhs_bot R)"
shows "p = q" using assms by force
lemma nf_rule_to_bound_max:
"f qs \<rightarrow> q |\<in>| nf_rules R \<F> \<Longrightarrow> q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))"
by (auto simp: nf_rules_fmember)
lemma nf_rules_unique:
assumes "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" and "f qs \<rightarrow> q' |\<in>| nf_rules R \<F>"
shows "q = q'" using assms unfolding nf_rules_def
using nf_rule_to_bound_max[OF assms(1)] nf_rule_to_bound_max[OF assms(2)]
using bound_max_unique by blast
lemma nf_ta_det:
shows "ta_det (nf_ta R \<F>)"
by (auto simp add: ta_det_def nf_ta_def nf_rules_unique)
lemma term_instance_of_reach_state:
assumes "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" and "ground t"
shows "q \<le>\<^sub>b t\<^sup>\<bottom>" using assms(1, 2)
proof(induct t arbitrary: q)
case (Fun f ts)
from Fun(2) obtain qs where wit: "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" "length qs = length ts"
"\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
by (auto simp add: nf_ta_def)
then have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" using Fun(1)[OF nth_mem, of i "qs !i" for i] using Fun(3)
by auto
then show ?case using bless_eq_trans wit(1) bound_max_sound[of "fset R"]
by (auto simp: nf_rules_fmember)
qed auto
lemma [simp]: "i < length ss \<Longrightarrow> l \<rhd> Fun f ss \<Longrightarrow> l \<rhd> ss ! i"
by (meson nth_mem subterm.dual_order.strict_trans supt.arg)
lemma subt_less_eq_res_less_eq:
assumes ground: "ground t" and "l |\<in>| R" and "l \<rhd> s" and "s\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
and "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)"
shows "s\<^sup>\<bottom> \<le>\<^sub>b q" using assms(2-)
proof (induction t arbitrary: q s)
case (Var x)
then show ?case using lift_total.anti_sym by fastforce
next
case (Fun f ts) note IN = this
from IN obtain qs where rule: "f qs \<rightarrow> q |\<in>| nf_rules R \<F>" and
reach: "length qs = length ts" "\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
by (auto simp add: nf_ta_def)
have q: "lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)) = Some q"
using nf_rule_to_bound_max[OF rule]
using lift_total.supremum_smaller_exists_unique[OF finite_lhs_subt, of "fset R" "BFun f qs"]
by simp (metis option.collapse option.distinct(1))
have subst: "s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs" using IN(1)[OF nth_mem, of i "term.args s ! i" "qs ! i" for i] IN(2-) reach
by (cases s) (auto elim!: bless_eq.cases)
have "s\<^sup>\<bottom> \<in> psubt_lhs_bot (fset R)" using Fun(2 - 4)
by auto (metis notin_fset)
then have "lift_total.lifted_less_eq (Some (s\<^sup>\<bottom>)) (lift_sup_small (BFun f qs) (psubt_lhs_bot (fset R)))"
using subst
by (intro lift_total.lift_ord.supremum_sound)
(auto simp: lift_total.lift_ord.smaller_subset_def)
then show ?case using subst q finite_lhs_subt
by auto
qed
lemma ta_nf_sound1:
assumes ground: "ground t" and lhs: "l |\<in>| R" and inst: "l\<^sup>\<bottom> \<le>\<^sub>b t\<^sup>\<bottom>"
shows "ta_der (nf_ta R \<F>) (adapt_vars t) = {||}"
proof (rule ccontr)
assume ass: "ta_der (nf_ta R \<F>) (adapt_vars t) \<noteq> {||}"
show False proof (cases t)
case [simp]: (Fun f ts) from ass
obtain q qs where fin: "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (Fun f ts))" and
rule: "(f qs \<rightarrow> q) |\<in>| rules (nf_ta R \<F>)" "length qs = length ts" and
reach: "\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i))"
by (auto simp add: nf_ta_def) blast
have "l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs" using reach assms(1) inst rule(2)
using subt_less_eq_res_less_eq[OF _ lhs, of "ts ! i" "term.args l ! i" "qs ! i" \<F> for i]
by (cases l) (auto elim!: bless_eq.cases intro!: bless_eq.step)
then show ?thesis using lhs rule by (auto simp: nf_ta_def nf_rules_def)
qed (metis ground ground.simps(1))
qed
lemma ta_nf_tr_to_state:
assumes "ground t" and "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)"
shows "q |\<in>| fstates R" using assms bound_max_state_fset
by (cases t) (auto simp: states_def nf_ta_def nf_rules_def)
lemma ta_nf_sound2:
assumes linear: "\<forall> l |\<in>| R. linear_term l"
and "ground (t :: ('f, 'v) term)" and "funas_term t \<subseteq> fset \<F>"
and NF: "\<And> l s. l |\<in>| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
shows "\<exists> q. q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" using assms(2 - 4)
proof (induct t)
case (Fun f ts)
have sub: "\<And> i. i < length ts \<Longrightarrow> (\<And>l s. l |\<in>| R \<Longrightarrow> ts ! i \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>) " using Fun(4) nth_mem by blast
from Fun(1)[OF nth_mem] this Fun(2, 3) obtain qs where
reach: "(\<forall> i < length ts. qs ! i |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))" and len: "length qs = length ts"
using Ex_list_of_length_P[of "length ts" "\<lambda> x i. x |\<in>| (ta_der (nf_ta R \<F>) (adapt_vars (ts ! i)))"]
by auto (meson UN_subset_iff nth_mem)
have nt_inst: "\<not> (\<exists> s |\<in>| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
proof (rule ccontr, simp)
assume ass: "\<exists> s |\<in>| R. s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs"
from term_instance_of_reach_state[of "qs ! i" R \<F> "ts ! i" for i] reach Fun(2) len
have "BFun f qs \<le>\<^sub>b Fun f ts\<^sup>\<bottom>" by auto
then show False using ass Fun(4) bless_eq_trans by blast
qed
obtain q where "q = bound_max (BFun f qs) (psubt_lhs_bot (fset R))" by blast
then have "f qs \<rightarrow> q |\<in>| rules (nf_ta R \<F>)" using Fun(2 - 4)
using ta_nf_tr_to_state[of "ts ! i" "qs ! i" R \<F> for i] len nt_inst reach
- by (auto simp: nf_ta_def nf_rules_fmember, simp add: fmember.rep_eq)
+ by (auto simp: nf_ta_def nf_rules_fmember, simp add: fmember_iff_member_fset)
(metis (no_types, lifting) in_fset_idx nth_mem)
then show ?case using reach len by auto
qed auto
lemma ta_nf_lang_sound:
assumes "l |\<in>| R"
shows "C\<langle>l \<cdot> \<sigma>\<rangle> \<notin> ta_lang (fstates R) (nf_ta R \<F>)"
proof (rule ccontr, simp del: ta_lang_to_gta_lang)
assume *: "C\<langle>l \<cdot> \<sigma>\<rangle> \<in> ta_lang (fstates R) (nf_ta R \<F>)"
then have cgr:"ground (C\<langle>l\<cdot>\<sigma>\<rangle>)" unfolding ta_lang_def by force
then have gr: "ground (l \<cdot> \<sigma>)" by simp
then have "l\<^sup>\<bottom> \<le>\<^sub>b (l \<cdot> \<sigma>)\<^sup>\<bottom>" using instance_to_bless_eq by blast
from ta_nf_sound1[OF gr assms(1) this] have res: "ta_der (nf_ta R \<F>) (adapt_vars (l \<cdot> \<sigma>)) = {||}" .
from ta_langE * obtain q where "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars (C\<langle>l\<cdot>\<sigma>\<rangle>))"
by (metis adapt_vars_adapt_vars)
with ta_der_ctxt_decompose[OF this[unfolded adapt_vars_ctxt]] res
show False by blast
qed
lemma ta_nf_lang_complete:
assumes linear: "\<forall> l |\<in>| R. linear_term l"
and ground: "ground (t :: ('f, 'v) term)" and sig: "funas_term t \<subseteq> fset \<F>"
and nf: "\<And>C \<sigma> l. l |\<in>| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> t"
shows "t \<in> ta_lang (fstates R) (nf_ta R \<F>)"
proof -
from nf have "\<And> l s. l |\<in>| R \<Longrightarrow> t \<unrhd> s \<Longrightarrow> \<not> l\<^sup>\<bottom> \<le>\<^sub>b s\<^sup>\<bottom>"
using bless_eq_to_instance linear by blast
from ta_nf_sound2[OF linear ground sig] this
obtain q where "q |\<in>| ta_der (nf_ta R \<F>) (adapt_vars t)" by blast
from this ta_nf_tr_to_state[OF ground this] ground show ?thesis
by (intro ta_langI) (auto simp add: nf_ta_def)
qed
lemma ta_nf_\<L>_complete:
assumes linear: "\<forall> l |\<in>| R. linear_term l"
and sig: "funas_gterm t \<subseteq> fset \<F>"
and nf: "\<And>C \<sigma> l. l |\<in>| R \<Longrightarrow> C\<langle>l\<cdot>\<sigma>\<rangle> \<noteq> (term_of_gterm t)"
shows "t \<in> \<L> (nf_reg R \<F>)"
using ta_nf_lang_complete[of R "term_of_gterm t" \<F>] assms
by (force simp: \<L>_def nf_reg_def funas_term_of_gterm_conv)
lemma nf_ta_funas:
assumes "ground t" "q |\<in>| ta_der (nf_ta R \<F>) t"
shows "funas_term t \<subseteq> fset \<F>" using assms
proof (induct t arbitrary: q)
case (Fun f ts)
from Fun(2-) have "(f, length ts) |\<in>| \<F>"
by (auto simp: nf_ta_def nf_rules_def)
then show ?case using Fun
- by (auto simp: fmember.rep_eq) (metis Fun.hyps Fun.prems(2) in_set_idx subsetD ta_der_Fun)
+ by (auto simp: fmember_iff_member_fset) (metis Fun.hyps Fun.prems(2) in_set_idx subsetD ta_der_Fun)
qed auto
lemma gta_lang_nf_ta_funas:
assumes "t \<in> \<L> (nf_reg R \<F>)"
shows "funas_gterm t \<subseteq> fset \<F>" using assms nf_ta_funas[of "term_of_gterm t" _ R \<F>]
unfolding nf_reg_def \<L>_def
by (auto simp: funas_term_of_gterm_conv)
end
diff --git a/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy b/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy
--- a/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy
+++ b/thys/FO_Theory_Rewriting/Primitives/NF_Impl.thy
@@ -1,198 +1,198 @@
theory NF_Impl
imports NF
Type_Instances_Impl
begin
subsubsection \<open>Implementation of normal form construction\<close>
(* Implementation *)
fun supteq_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
where
"supteq_list (Var x) = [Var x]" |
"supteq_list (Fun f ts) = Fun f ts # concat (map supteq_list ts)"
fun supt_list :: "('f, 'v) Term.term \<Rightarrow> ('f, 'v) Term.term list"
where
"supt_list (Var x) = []" |
"supt_list (Fun f ts) = concat (map supteq_list ts)"
lemma supteq_list [simp]:
"set (supteq_list t) = {s. t \<unrhd> s}"
proof (rule set_eqI, simp)
fix s
show "s \<in> set(supteq_list t) = (t \<unrhd> s)"
proof (induct t, simp add: supteq_var_imp_eq)
case (Fun f ss)
show ?case
proof (cases "Fun f ss = s", (auto)[1])
case False
show ?thesis
proof
assume "Fun f ss \<unrhd> s"
with False have sup: "Fun f ss \<rhd> s" using supteq_supt_conv by auto
obtain C where "C \<noteq> \<box>" and "Fun f ss = C\<langle>s\<rangle>" using sup by auto
then obtain b D a where "Fun f ss = Fun f (b @ D\<langle>s\<rangle> # a)" by (cases C, auto)
then have D: "D\<langle>s\<rangle> \<in> set ss" by auto
with Fun[OF D] ctxt_imp_supteq[of D s] obtain t where "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
then show "s \<in> set (supteq_list (Fun f ss))" by auto
next
assume "s \<in> set (supteq_list (Fun f ss))"
with False obtain t where t: "t \<in> set ss" and "s \<in> set (supteq_list t)" by auto
with Fun[OF t] have "t \<unrhd> s" by auto
with t show "Fun f ss \<unrhd> s" by auto
qed
qed
qed
qed
lemma supt_list_sound [simp]:
"set (supt_list t) = {s. t \<rhd> s}"
by (cases t) auto
fun mergeP_impl where
"mergeP_impl Bot t = True"
| "mergeP_impl t Bot = True"
| "mergeP_impl (BFun f ss) (BFun g ts) =
(if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). mergeP_impl x y) (zip ss ts) else False)"
lemma [simp]: "mergeP_impl s Bot = True" by (cases s) auto
lemma [simp]: "mergeP_impl s t \<longleftrightarrow> (s, t) \<in> mergeP" (is "?LS = ?RS")
proof
show "?LS \<Longrightarrow> ?RS"
by (induct rule: mergeP_impl.induct, auto split: if_splits intro!: step)
(smt length_zip list_all_length mergeP.step min_less_iff_conj nth_mem nth_zip old.prod.case)
next
show "?RS \<Longrightarrow> ?LS" by (induct rule: mergeP.induct, auto simp add: list_all_length)
qed
fun bless_eq_impl where
"bless_eq_impl Bot t = True"
| "bless_eq_impl (BFun f ss) (BFun g ts) =
(if f = g \<and> length ss = length ts then list_all (\<lambda> (x, y). bless_eq_impl x y) (zip ss ts) else False)"
| "bless_eq_impl _ _ = False"
lemma [simp]: "bless_eq_impl s t \<longleftrightarrow> (s, t) \<in> bless_eq" (is "?RS = ?LS")
proof
show "?LS \<Longrightarrow> ?RS" by (induct rule: bless_eq.induct, auto simp add: list_all_length)
next
show "?RS \<Longrightarrow> ?LS"
by (induct rule: bless_eq_impl.induct, auto split: if_splits intro!: bless_eq.step)
(metis (full_types) length_zip list_all_length min_less_iff_conj nth_mem nth_zip old.prod.case)
qed
definition "psubt_bot_impl R \<equiv> remdups (map term_to_bot_term (concat (map supt_list R)))"
lemma psubt_bot_impl[simp]: "set (psubt_bot_impl R) = psubt_lhs_bot (set R)"
by (induct R, auto simp: psubt_bot_impl_def)
definition "states_impl R = List.insert Bot (map the (removeAll None
(closure_impl (lift_f_total mergeP_impl (\<up>)) (map Some (psubt_bot_impl R)))))"
lemma states_impl [simp]: "set (states_impl R) = states (set R)"
proof -
have [simp]: "lift_f_total mergeP_impl (\<up>) = lift_f_total (\<lambda> x y. mergeP_impl x y) (\<up>)" by blast
show ?thesis unfolding states_impl_def states_def
using lift_total.cl.closure_impl
by (simp add: lift_total.cl.pred_closure_lift_closure)
qed
abbreviation check_intance_lhs where
"check_intance_lhs qs f R \<equiv> list_all (\<lambda> u. \<not> bless_eq_impl u (BFun f qs)) R"
definition min_elem where
"min_elem s ss = (let ts = filter (\<lambda> x. bless_eq_impl x s) ss in
foldr (\<up>) ts Bot)"
lemma bound_impl [simp, code]:
"bound_max s (set ss) = min_elem s ss"
proof -
have [simp]: "{y. lift_total.lifted_less_eq y (Some s) \<and> y \<in> Some ` set ss} = Some ` {x \<in> set ss. x \<le>\<^sub>b s}"
by auto
then show ?thesis
using lift_total.supremum_impl[of "filter (\<lambda> x. bless_eq_impl x s) ss"]
using lift_total.supremum_smaller_exists_unique[of "set ss" s]
by (auto simp: min_elem_def Let_def lift_total.lift_ord.smaller_subset_def)
qed
definition nf_rule_impl where
"nf_rule_impl S R SR h = (let (f, n) = h in
let states = List.n_lists n S in
let nlhs_inst = filter (\<lambda> qs. check_intance_lhs qs f R) states in
map (\<lambda> qs. TA_rule f qs (min_elem (BFun f qs) SR)) nlhs_inst)"
abbreviation nf_rules_impl where
"nf_rules_impl R \<F> \<equiv> concat (map (nf_rule_impl (states_impl R) (map term_to_bot_term R) (psubt_bot_impl R)) \<F>)"
(* Section proves that the implementation constructs the same rule set *)
lemma nf_rules_in_impl:
assumes "TA_rule f qs q |\<in>| nf_rules (fset_of_list R) (fset_of_list \<F>)"
shows "TA_rule f qs q |\<in>| fset_of_list (nf_rules_impl R \<F>)"
proof -
have funas: "(f, length qs) \<in> set \<F>" and st: "fset_of_list qs |\<subseteq>| fstates (fset_of_list R)"
and nlhs: "\<not>(\<exists> s \<in> (set R). s\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
and min: "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
- using assms by (auto simp add: nf_rules_fmember simp flip: fset_of_list_elem fmember.rep_eq)
+ using assms by (auto simp add: nf_rules_fmember simp flip: fset_of_list_elem fmember_iff_member_fset)
then have st_impl: "qs |\<in>| fset_of_list (List.n_lists (length qs) (states_impl R))"
by (auto simp add: fset_of_list_elem subset_code(1) set_n_lists
fset_of_list.rep_eq less_eq_fset.rep_eq fstates.rep_eq)
from nlhs have nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
by (auto simp: list.pred_set)
have min_impl: "q = min_elem (BFun f qs) (psubt_bot_impl R)"
using bound_impl min
by (auto simp flip: psubt_bot_impl)
then show ?thesis using funas nlhs_impl funas st_impl unfolding nf_rule_impl_def
by (auto simp: fset_of_list_elem)
qed
lemma nf_rules_impl_in_rules:
assumes "TA_rule f qs q |\<in>| fset_of_list (nf_rules_impl R \<F>)"
shows "TA_rule f qs q |\<in>| nf_rules (fset_of_list R) (fset_of_list \<F>)"
proof -
have funas: "(f, length qs) \<in> set \<F>"
and st_impl: "qs |\<in>| fset_of_list (List.n_lists (length qs) (states_impl R))"
and nlhs_impl: "check_intance_lhs qs f (map term_to_bot_term R)"
and min: "q = min_elem (BFun f qs) (psubt_bot_impl R)" using assms
by (auto simp add: set_n_lists nf_rule_impl_def fset_of_list_elem)
from st_impl have st: "fset_of_list qs |\<subseteq>| fstates (fset_of_list R)"
- by (force simp: set_n_lists fset_of_list_elem fstates.rep_eq fmember.rep_eq fset_of_list.rep_eq)
+ by (force simp: set_n_lists fset_of_list_elem fstates.rep_eq fmember_iff_member_fset fset_of_list.rep_eq)
from nlhs_impl have nlhs: "\<not>(\<exists> l \<in> (set R). l\<^sup>\<bottom> \<le>\<^sub>b BFun f qs)"
by auto (metis (no_types, lifting) Ball_set_list_all in_set_idx length_map nth_map nth_mem)
have "q = bound_max (BFun f qs) (psubt_lhs_bot (set R))"
using bound_impl min
by (auto simp flip: psubt_bot_impl)
then show ?thesis using funas st nlhs
by (auto simp add: nf_rules_fmember fset_of_list_elem fset_of_list.rep_eq)
qed
lemma rule_set_eq:
shows "nf_rules (fset_of_list R) (fset_of_list \<F>) = fset_of_list (nf_rules_impl R \<F>)" (is "?Ls = ?Rs")
proof -
{fix r assume "r |\<in>| ?Ls" then have "r |\<in>| ?Rs"
using nf_rules_in_impl[where ?R = R and ?\<F> = \<F>]
by (cases r) auto}
moreover
{fix r assume "r |\<in>| ?Rs" then have "r |\<in>| ?Ls"
using nf_rules_impl_in_rules[where ?R = R and ?\<F> = \<F>]
by (cases r) auto}
ultimately show ?thesis by blast
qed
(* Code equation for normal form TA *)
lemma fstates_code[code]:
"fstates R = fset_of_list (states_impl (sorted_list_of_fset R))"
- by (auto simp: fmember.rep_eq fstates.rep_eq fset_of_list.rep_eq)
+ by (auto simp: fmember_iff_member_fset fstates.rep_eq fset_of_list.rep_eq)
lemma nf_ta_code [code]:
"nf_ta R \<F> = TA (fset_of_list (nf_rules_impl (sorted_list_of_fset R) (sorted_list_of_fset \<F>))) {||}"
unfolding nf_ta_def using rule_set_eq[of "sorted_list_of_fset R" "sorted_list_of_fset \<F>"]
by (intro TA_equalityI) auto
(*
export_code nf_ta in Haskell
*)
end
\ No newline at end of file
diff --git a/thys/FSM_Tests/EquivalenceTesting/Simple_Convergence_Graph.thy b/thys/FSM_Tests/EquivalenceTesting/Simple_Convergence_Graph.thy
--- a/thys/FSM_Tests/EquivalenceTesting/Simple_Convergence_Graph.thy
+++ b/thys/FSM_Tests/EquivalenceTesting/Simple_Convergence_Graph.thy
@@ -1,2003 +1,2003 @@
section \<open>Simple Convergence Graphs\<close>
text \<open>This theory introduces a very simple implementation of convergence graphs that
consists of a list of convergent classes represented as sets of traces.\<close>
theory Simple_Convergence_Graph
imports Convergence_Graph
begin
subsection \<open>Basic Definitions\<close>
type_synonym 'a simple_cg = "'a list fset list"
definition simple_cg_empty :: "'a simple_cg" where
"simple_cg_empty = []"
(* collects all traces in the same convergent class set as ys *)
fun simple_cg_lookup :: "('a::linorder) simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
"simple_cg_lookup xs ys = sorted_list_of_fset (finsert ys (foldl (|\<union>|) fempty (filter (\<lambda>x . ys |\<in>| x) xs)))"
(* collects all traces (zs@ys'') such that there exists a prefix ys' of ys with (ys=ys'@ys'')
and zs is in the same convergent class set as ys' *)
fun simple_cg_lookup_with_conv :: "('a::linorder) simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
"simple_cg_lookup_with_conv g ys = (let
lookup_for_prefix = (\<lambda>i . let
pref = take i ys;
suff = drop i ys;
pref_conv = (foldl (|\<union>|) fempty (filter (\<lambda>x . pref |\<in>| x) g))
in fimage (\<lambda> pref' . pref'@suff) pref_conv)
in sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty [0..<Suc (length ys)])))"
fun simple_cg_insert' :: "('a::linorder) simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a simple_cg" where
"simple_cg_insert' xs ys = (case find (\<lambda>x . ys |\<in>| x) xs
of Some x \<Rightarrow> xs |
None \<Rightarrow> {|ys|}#xs)"
fun simple_cg_insert :: "('a::linorder) simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a simple_cg" where
"simple_cg_insert xs ys = foldl (\<lambda> xs' ys' . simple_cg_insert' xs' ys') xs (prefixes ys)"
fun simple_cg_initial :: "('a,'b::linorder,'c::linorder) fsm \<Rightarrow> ('b\<times>'c) prefix_tree \<Rightarrow> ('b\<times>'c) simple_cg" where
"simple_cg_initial M1 T = foldl (\<lambda> xs' ys' . simple_cg_insert' xs' ys') simple_cg_empty (filter (is_in_language M1 (initial M1)) (sorted_list_of_sequences_in_tree T))"
subsection \<open>Merging by Closure\<close>
text \<open>The following implementation of the merge operation follows the closure operation described
by Simão et al. in Simão, A., Petrenko, A. and Yevtushenko, N. (2012), On reducing test length
for FSMs with extra states. Softw. Test. Verif. Reliab., 22: 435-454. https://doi.org/10.1002/stvr.452.
That is, two traces u and v are merged by adding {u,v} to the list of convergent classes
followed by computing the closure of the graph based on two operations:
(1) classes A and B can be merged if there exists some class C such that C contains some w1, w2
and there exists some w such that A contains w1.w and B contains w2.w.
(2) classes A and B can be merged if one is a subset of the other.\<close>
(* classes x1 and x2 can be merged via class x if there exist \<alpha>, \<beta> in x and some suffix \<gamma>
such that x1 contains \<alpha>@\<gamma> and x2 contains \<beta>@\<gamma> *)
fun can_merge_by_suffix :: "'a list fset \<Rightarrow> 'a list fset \<Rightarrow> 'a list fset \<Rightarrow> bool" where
"can_merge_by_suffix x x1 x2 = (\<exists> \<alpha> \<beta> \<gamma> . \<alpha> |\<in>| x \<and> \<beta> |\<in>| x \<and> \<alpha>@\<gamma> |\<in>| x1 \<and> \<beta>@\<gamma> |\<in>| x2)"
lemma can_merge_by_suffix_code[code] :
"can_merge_by_suffix x x1 x2 =
(\<exists> ys \<in> fset x .
\<exists> ys1 \<in> fset x1 .
is_prefix ys ys1 \<and>
(\<exists> ys' \<in> fset x . ys'@(drop (length ys) ys1) |\<in>| x2))"
(is "?P1 = ?P2")
proof
show "?P1 \<Longrightarrow> ?P2"
by (metis append_eq_conv_conj can_merge_by_suffix.elims(2) is_prefix_prefix notin_fset)
show "?P2 \<Longrightarrow> ?P1"
by (metis append_eq_conv_conj can_merge_by_suffix.elims(3) is_prefix_prefix notin_fset)
qed
fun prefixes_in_list_helper :: "'a \<Rightarrow> 'a list list \<Rightarrow> (bool \<times> 'a list list) \<Rightarrow> bool \<times> 'a list list" where
"prefixes_in_list_helper x [] res = res" |
"prefixes_in_list_helper x ([]#yss) res = prefixes_in_list_helper x yss (True, snd res)" |
"prefixes_in_list_helper x ((y#ys)#yss) res =
(if x = y then prefixes_in_list_helper x yss (fst res, ys # snd res)
else prefixes_in_list_helper x yss res)"
fun prefixes_in_list :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
"prefixes_in_list [] prev yss res = (if List.member yss [] then prev#res else res)" |
"prefixes_in_list (x#xs) prev yss res = (let
(b,yss') = prefixes_in_list_helper x yss (False,[])
in if b then prefixes_in_list xs (prev@[x]) yss' (prev # res)
else prefixes_in_list xs (prev@[x]) yss' res)"
fun prefixes_in_set :: "('a::linorder) list \<Rightarrow> 'a list fset \<Rightarrow> 'a list list" where
"prefixes_in_set xs yss = prefixes_in_list xs [] (sorted_list_of_fset yss) []"
value "prefixes_in_list [1::nat,2,3,4,5] []
[ [1,2,3], [1,2,4], [1,3], [], [1], [1,5,3], [2,5] ] []"
value "prefixes_in_list_helper (1::nat)
[ [1,2,3], [1,2,4], [1,3], [], [1], [1,5,3], [2,5] ]
(False,[])"
lemma prefixes_in_list_helper_prop :
shows "fst (prefixes_in_list_helper x yss res) = (fst res \<or> [] \<in> list.set yss)" (is ?P1)
and "list.set (snd (prefixes_in_list_helper x yss res)) = list.set (snd res) \<union> {ys . x#ys \<in> list.set yss}" (is ?P2)
proof -
have "?P1 \<and> ?P2"
proof (induction yss arbitrary: res)
case Nil
then show ?case by auto
next
case (Cons ys yss)
show ?case proof (cases ys)
case Nil
then show ?thesis
using Cons.IH by auto
next
case (Cons y ys')
show ?thesis proof (cases "x = y")
case True
have *: "prefixes_in_list_helper x (ys # yss) res = prefixes_in_list_helper y yss (fst res, ys' # snd res)"
unfolding Cons True by auto
show ?thesis
using Cons.IH[of "(fst res, ys' # snd res)"]
unfolding *
unfolding Cons
unfolding True
by auto
next
case False
then have *: "prefixes_in_list_helper x (ys # yss) res = prefixes_in_list_helper x yss res"
unfolding Cons by auto
show ?thesis
unfolding *
unfolding Cons
using Cons.IH[of res] False
by force
qed
qed
qed
then show ?P1 and ?P2 by blast+
qed
lemma prefixes_in_list_prop :
shows "list.set (prefixes_in_list xs prev yss res) = list.set res \<union> {prev@ys | ys . ys \<in> list.set (prefixes xs) \<and> ys \<in> list.set yss}"
proof (induction xs arbitrary: prev yss res)
case Nil
show ?case
unfolding prefixes_in_list.simps List.member_def prefixes_set by auto
next
case (Cons x xs)
obtain b yss' where "prefixes_in_list_helper x yss (False,[]) = (b,yss')"
using prod.exhaust by metis
then have "b = ([] \<in> list.set yss)"
and "list.set yss' = {ys . x#ys \<in> list.set yss}"
using prefixes_in_list_helper_prop[of x yss "(False,[])"]
by auto
show ?case proof (cases b)
case True
then have *: "prefixes_in_list (x#xs) prev yss res = prefixes_in_list xs (prev@[x]) yss' (prev # res)"
using \<open>prefixes_in_list_helper x yss (False,[]) = (b,yss')\<close> by auto
show ?thesis
unfolding *
unfolding Cons \<open>list.set yss' = {ys . x#ys \<in> list.set yss}\<close>
using True unfolding \<open>b = ([] \<in> list.set yss)\<close>
by auto
next
case False
then have *: "prefixes_in_list (x#xs) prev yss res = prefixes_in_list xs (prev@[x]) yss' res"
using \<open>prefixes_in_list_helper x yss (False,[]) = (b,yss')\<close> by auto
show ?thesis
unfolding *
unfolding Cons \<open>list.set yss' = {ys . x#ys \<in> list.set yss}\<close>
using False unfolding \<open>b = ([] \<in> list.set yss)\<close>
by auto
qed
qed
lemma prefixes_in_set_prop :
"list.set (prefixes_in_set xs yss) = list.set (prefixes xs) \<inter> fset yss"
unfolding prefixes_in_set.simps
unfolding prefixes_in_list_prop
by auto
(* alternative implementation of merging *)
(*
lemma can_merge_by_suffix_code[code] :
"can_merge_by_suffix x x1 x2 =
(\<exists> ys1 \<in> fset x1 . list_ex (\<lambda>ys . ys |\<in>| x \<and> (\<exists> ys' \<in> fset x . ys'@(drop (length ys) ys1) |\<in>| x2))
(prefixes ys1))"
(is "?P1 = ?P2")
proof
show "?P1 \<Longrightarrow> ?P2"
proof -
assume "?P1"
then obtain \<alpha> \<beta> \<gamma> where "\<alpha> |\<in>| x" and "\<beta> |\<in>| x" and "\<alpha>@\<gamma> |\<in>| x1" and "\<beta>@\<gamma> |\<in>| x2"
by auto
have "\<alpha>@\<gamma> \<in> fset x1" using \<open>\<alpha>@\<gamma> |\<in>| x1\<close> notin_fset by metis
moreover have "\<alpha> \<in> list.set (prefixes (\<alpha>@\<gamma>))" by (simp add: prefixes_take_iff)
moreover note \<open>\<alpha> |\<in>| x\<close>
moreover have "\<exists> ys'' \<in> fset x . ys''@(drop (length \<alpha>) (\<alpha>@\<gamma>)) |\<in>| x2"
using \<open>\<beta>@\<gamma> |\<in>| x2\<close> \<open>\<beta> |\<in>| x\<close>
by (metis append_eq_conv_conj notin_fset)
ultimately show "?P2"
unfolding list_ex_iff by blast
qed
show "?P2 \<Longrightarrow> ?P1"
proof -
assume "?P2"
then obtain ys1 ys ys' where "ys1 \<in> fset x1"
and "ys \<in> list.set (prefixes ys1)"
and "ys |\<in>| x"
and "ys' \<in> fset x"
and "ys'@(drop (length ys) ys1) |\<in>| x2"
unfolding list_ex_iff by blast
then show "?P1"
by (metis append_take_drop_id can_merge_by_suffix.elims(3) notin_fset prefixes_take_iff)
qed
qed
*)
lemma can_merge_by_suffix_validity :
assumes "observable M1" and "observable M2"
and "\<And> u v . u |\<in>| x \<Longrightarrow> v |\<in>| x \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> u v . u |\<in>| x1 \<Longrightarrow> v |\<in>| x1 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> u v . u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "can_merge_by_suffix x x1 x2"
and "u |\<in>| (x1 |\<union>| x2)"
and "v |\<in>| (x1 |\<union>| x2)"
and "u \<in> L M1" and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
obtain \<alpha> \<beta> \<gamma> where "\<alpha> |\<in>| x" and "\<beta> |\<in>| x" and "\<alpha>@\<gamma> |\<in>| x1" and "\<beta>@\<gamma> |\<in>| x2"
using \<open>can_merge_by_suffix x x1 x2\<close> by auto
consider "u |\<in>| x1" | "u |\<in>| x2"
using \<open>u |\<in>| (x1 |\<union>| x2)\<close> by blast
then show ?thesis proof cases
case 1
then have "converge M1 u (\<alpha>@\<gamma>)" and "converge M2 u (\<alpha>@\<gamma>)"
using \<open>u |\<in>| (x1 |\<union>| x2)\<close> assms(4)[OF _ \<open>\<alpha>@\<gamma> |\<in>| x1\<close> assms(9,10)]
by blast+
then have "(\<alpha>@\<gamma>) \<in> L M1" and "(\<alpha>@\<gamma>) \<in> L M2"
by auto
then have "\<alpha> \<in> L M1" and "\<alpha> \<in> L M2"
using language_prefix by metis+
then have "converge M1 \<alpha> \<beta>" and "converge M2 \<alpha> \<beta>"
using assms(3) \<open>\<alpha> |\<in>| x\<close> \<open>\<beta> |\<in>| x\<close>
by blast+
have "converge M1 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)"
using \<open>converge M1 \<alpha> \<beta>\<close>
by (meson \<open>\<alpha> @ \<gamma> \<in> L M1\<close> assms(1) converge.simps converge_append)
then have "\<beta>@\<gamma> \<in> L M1"
by auto
have "converge M2 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)"
using \<open>converge M2 \<alpha> \<beta>\<close>
by (meson \<open>\<alpha> @ \<gamma> \<in> L M2\<close> assms(2) converge.simps converge_append)
then have "\<beta>@\<gamma> \<in> L M2"
by auto
consider (11) "v |\<in>| x1" | (12) "v |\<in>| x2"
using \<open>v |\<in>| (x1 |\<union>| x2)\<close> by blast
then show ?thesis proof cases
case 11
show ?thesis
using "1" "11" assms(10) assms(4) assms(9) by blast
next
case 12
then have "converge M1 v (\<beta>@\<gamma>)" and "converge M2 v (\<beta>@\<gamma>)"
using assms(5)[OF \<open>\<beta>@\<gamma> |\<in>| x2\<close> _ \<open>\<beta>@\<gamma> \<in> L M1\<close> \<open>\<beta>@\<gamma> \<in> L M2\<close>]
by auto
then show ?thesis
using \<open>converge M1 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)\<close> \<open>converge M2 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)\<close> \<open>converge M1 u (\<alpha>@\<gamma>)\<close> \<open>converge M2 u (\<alpha>@\<gamma>)\<close>
by auto
qed
next
case 2
then have "converge M1 u (\<beta>@\<gamma>)" and "converge M2 u (\<beta>@\<gamma>)"
using \<open>u |\<in>| (x1 |\<union>| x2)\<close> assms(5)[OF _ \<open>\<beta>@\<gamma> |\<in>| x2\<close> assms(9,10)]
by blast+
then have "(\<beta>@\<gamma>) \<in> L M1" and "(\<beta>@\<gamma>) \<in> L M2"
by auto
then have "\<beta> \<in> L M1" and "\<beta> \<in> L M2"
using language_prefix by metis+
then have "converge M1 \<alpha> \<beta>" and "converge M2 \<alpha> \<beta>"
using assms(3)[OF \<open>\<beta> |\<in>| x\<close> \<open>\<alpha> |\<in>| x\<close>]
by auto
have "converge M1 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)"
using \<open>converge M1 \<alpha> \<beta>\<close>
using \<open>\<beta> @ \<gamma> \<in> L M1\<close> \<open>\<beta> \<in> L M1\<close> assms(1) converge_append converge_append_language_iff by blast
then have "\<alpha>@\<gamma> \<in> L M1"
by auto
have "converge M2 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)"
using \<open>converge M2 \<alpha> \<beta>\<close>
using \<open>\<beta> @ \<gamma> \<in> L M2\<close> \<open>\<beta> \<in> L M2\<close> assms(2) converge_append converge_append_language_iff by blast
then have "\<alpha>@\<gamma> \<in> L M2"
by auto
consider (21) "v |\<in>| x1" | (22) "v |\<in>| x2"
using \<open>v |\<in>| (x1 |\<union>| x2)\<close> by blast
then show ?thesis proof cases
case 22
show ?thesis
using "2" "22" assms(10) assms(5) assms(9) by blast
next
case 21
then have "converge M1 v (\<alpha>@\<gamma>)" and "converge M2 v (\<alpha>@\<gamma>)"
using assms(4)[OF \<open>\<alpha>@\<gamma> |\<in>| x1\<close> _ \<open>\<alpha>@\<gamma> \<in> L M1\<close> \<open>\<alpha>@\<gamma> \<in> L M2\<close>]
by auto
then show ?thesis
using \<open>converge M1 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)\<close> \<open>converge M2 (\<alpha>@\<gamma>) (\<beta>@\<gamma>)\<close> \<open>converge M1 u (\<beta>@\<gamma>)\<close> \<open>converge M2 u (\<beta>@\<gamma>)\<close>
by auto
qed
qed
qed
fun simple_cg_closure_phase_1_helper' :: "'a list fset \<Rightarrow> 'a list fset \<Rightarrow> 'a simple_cg \<Rightarrow> (bool \<times> 'a list fset \<times> 'a simple_cg)" where
"simple_cg_closure_phase_1_helper' x x1 xs =
(let (x2s,others) = separate_by (can_merge_by_suffix x x1) xs;
x1Union = foldl (|\<union>|) x1 x2s
in (x2s \<noteq> [],x1Union,others))"
lemma simple_cg_closure_phase_1_helper'_False :
"\<not>fst (simple_cg_closure_phase_1_helper' x x1 xs) \<Longrightarrow> simple_cg_closure_phase_1_helper' x x1 xs = (False,x1,xs)"
unfolding simple_cg_closure_phase_1_helper'.simps Let_def separate_by.simps
by (simp add: filter_empty_conv)
lemma simple_cg_closure_phase_1_helper'_True :
assumes "fst (simple_cg_closure_phase_1_helper' x x1 xs)"
shows "length (snd (snd (simple_cg_closure_phase_1_helper' x x1 xs))) < length xs"
proof -
have "snd (snd (simple_cg_closure_phase_1_helper' x x1 xs)) = filter (\<lambda>x2 . \<not> (can_merge_by_suffix x x1 x2)) xs"
by auto
moreover have "filter (\<lambda>x2 . (can_merge_by_suffix x x1 x2)) xs \<noteq> []"
using assms unfolding simple_cg_closure_phase_1_helper'.simps Let_def separate_by.simps
by fastforce
ultimately show ?thesis
using filter_not_all_length[of "can_merge_by_suffix x x1" xs]
by metis
qed
lemma simple_cg_closure_phase_1_helper'_length :
"length (snd (snd (simple_cg_closure_phase_1_helper' x x1 xs))) \<le> length xs"
by auto
lemma simple_cg_closure_phase_1_helper'_validity_fst :
assumes "observable M1" and "observable M2"
and "\<And> u v . u |\<in>| x \<Longrightarrow> v |\<in>| x \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> u v . u |\<in>| x1 \<Longrightarrow> v |\<in>| x1 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "u |\<in>| fst (snd (simple_cg_closure_phase_1_helper' x x1 xs))"
and "v |\<in>| fst (snd (simple_cg_closure_phase_1_helper' x x1 xs))"
and "u \<in> L M1" and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have *:"\<And> w . w |\<in>| fst (snd (simple_cg_closure_phase_1_helper' x x1 xs)) \<Longrightarrow> w |\<in>| x1 \<or> (\<exists> x2 . x2 \<in> list.set xs \<and> w |\<in>| x2 \<and> can_merge_by_suffix x x1 x2)"
proof -
fix w assume "w |\<in>| fst (snd (simple_cg_closure_phase_1_helper' x x1 xs))"
then have "w |\<in>| ffUnion (fset_of_list (x1#(filter (can_merge_by_suffix x x1) xs)))"
using foldl_funion_fsingleton[where xs="(filter (can_merge_by_suffix x x1) xs)"]
by auto
then obtain x2 where "w |\<in>| x2"
and "x2 |\<in>| fset_of_list (x1#(filter (can_merge_by_suffix x x1) xs))"
using ffUnion_fmember_ob
by metis
then consider "x2=x1" | "x2 \<in> list.set (filter (can_merge_by_suffix x x1) xs)"
by (meson fset_of_list_elem set_ConsD)
then show "w |\<in>| x1 \<or> (\<exists> x2 . x2 \<in> list.set xs \<and> w |\<in>| x2 \<and> can_merge_by_suffix x x1 x2)"
using \<open>w |\<in>| x2\<close> by (cases; auto)
qed
consider "u |\<in>| x1" | "(\<exists> x2 . x2 \<in> list.set xs \<and> u |\<in>| x2 \<and> can_merge_by_suffix x x1 x2)"
using *[OF assms(6)] by blast
then show ?thesis proof cases
case 1
consider (a) "v |\<in>| x1" | (b) "(\<exists> x2 . x2 \<in> list.set xs \<and> v |\<in>| x2 \<and> can_merge_by_suffix x x1 x2)"
using *[OF assms(7)] by blast
then show ?thesis proof cases
case a
then show ?thesis using assms(4)[OF 1 _ assms(8,9)] by auto
next
case b
then obtain x2v where "x2v \<in> list.set xs" and "v |\<in>| x2v" and "can_merge_by_suffix x x1 x2v"
using *[OF assms(6)]
by blast
then have "u |\<in>| x1 |\<union>| x2v" and "v |\<in>| x1 |\<union>| x2v"
using 1 by auto
show ?thesis
using can_merge_by_suffix_validity[OF assms(1,2), of x x1 x2v, OF assms(3,4) assms(5)[OF \<open>x2v \<in> list.set xs\<close>] \<open>can_merge_by_suffix x x1 x2v\<close> \<open>u |\<in>| x1 |\<union>| x2v\<close> \<open>v |\<in>| x1 |\<union>| x2v\<close> assms(8,9)]
by blast
qed
next
case 2
then obtain x2u where "x2u \<in> list.set xs" and "u |\<in>| x2u" and "can_merge_by_suffix x x1 x2u"
using *[OF assms(6)]
by blast
then have "u |\<in>| x1 |\<union>| x2u"
by auto
consider (a) "v |\<in>| x1" | (b) "(\<exists> x2 . x2 \<in> list.set xs \<and> v |\<in>| x2 \<and> can_merge_by_suffix x x1 x2)"
using *[OF assms(7)] by blast
then show ?thesis proof cases
case a
then have "v |\<in>| x1 |\<union>| x2u"
by auto
show ?thesis
using can_merge_by_suffix_validity[OF assms(1,2), of x x1 x2u, OF assms(3,4) assms(5)[OF \<open>x2u \<in> list.set xs\<close>] \<open>can_merge_by_suffix x x1 x2u\<close> \<open>u |\<in>| x1 |\<union>| x2u\<close> \<open>v |\<in>| x1 |\<union>| x2u\<close> assms(8,9)]
by blast
next
case b
then obtain x2v where "x2v \<in> list.set xs" and "v |\<in>| x2v" and "can_merge_by_suffix x x1 x2v"
using *[OF assms(6)]
by blast
then have "v |\<in>| x1 |\<union>| x2v"
by auto
have "\<And> v . v |\<in>| x1 |\<union>| x2u \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using can_merge_by_suffix_validity[OF assms(1,2), of x x1 x2u, OF assms(3,4) assms(5)[OF \<open>x2u \<in> list.set xs\<close>] \<open>can_merge_by_suffix x x1 x2u\<close> \<open>u |\<in>| x1 |\<union>| x2u\<close> _ assms(8,9)]
by blast
have "\<And> u . u |\<in>| x1 |\<union>| x2v \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using can_merge_by_suffix_validity[OF assms(1,2), of x x1 x2v, OF assms(3,4) assms(5)[OF \<open>x2v \<in> list.set xs\<close>] \<open>can_merge_by_suffix x x1 x2v\<close> _ \<open>v |\<in>| x1 |\<union>| x2v\<close>]
by blast
obtain \<alpha>v \<beta>v \<gamma>v where "\<alpha>v |\<in>| x" and "\<beta>v |\<in>| x" and "\<alpha>v@\<gamma>v |\<in>| x1" and "\<beta>v@\<gamma>v |\<in>| x2v"
using \<open>can_merge_by_suffix x x1 x2v\<close> by auto
show ?thesis
using \<open>\<And>u. \<lbrakk>u |\<in>| x1 |\<union>| x2v; u \<in> L M1; u \<in> L M2\<rbrakk> \<Longrightarrow> converge M1 u v \<and> converge M2 u v\<close> \<open>\<And>v. v |\<in>| x1 |\<union>| x2u \<Longrightarrow> converge M1 u v \<and> converge M2 u v\<close> \<open>\<alpha>v @ \<gamma>v |\<in>| x1\<close> by fastforce
qed
qed
qed
lemma simple_cg_closure_phase_1_helper'_validity_snd :
assumes "\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (snd (simple_cg_closure_phase_1_helper' x x1 xs)))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1" and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have "list.set (snd (snd (simple_cg_closure_phase_1_helper' x x1 xs))) \<subseteq> list.set xs"
by auto
then show ?thesis
using assms by blast
qed
fun simple_cg_closure_phase_1_helper :: "'a list fset \<Rightarrow> 'a simple_cg \<Rightarrow> (bool \<times> 'a simple_cg) \<Rightarrow> (bool \<times> 'a simple_cg)" where
"simple_cg_closure_phase_1_helper x [] (b,done) = (b,done)" |
"simple_cg_closure_phase_1_helper x (x1#xs) (b,done) = (let (hasChanged,x1',xs') = simple_cg_closure_phase_1_helper' x x1 xs
in simple_cg_closure_phase_1_helper x xs' (b \<or> hasChanged, x1' # done))"
lemma simple_cg_closure_phase_1_helper_validity :
assumes "observable M1" and "observable M2"
and "\<And> u v . u |\<in>| x \<Longrightarrow> v |\<in>| x \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> x2 u v . x2 \<in> list.set don \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> x2 u v . x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (simple_cg_closure_phase_1_helper x xss (b,don)))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1" and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
using assms(4,5,6)
proof (induction "length xss" arbitrary: xss don b rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
then have "x2 \<in> list.set don"
using less.prems(3) by auto
then show ?thesis
using less.prems(1) assms(7,8,9,10)
by blast
next
case (Cons x1 xs)
obtain b' x1' xs' where "simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')"
using prod.exhaust by metis
then have "simple_cg_closure_phase_1_helper x xss (b,don) = simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1' # don)"
unfolding Cons by auto
have *:"\<And> u v . u |\<in>| x1 \<Longrightarrow> v |\<in>| x1 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using less.prems(2)[of x1] unfolding Cons
by (meson list.set_intros(1))
have **:"\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using less.prems(2) unfolding Cons
by (meson list.set_intros(2))
have ***:"\<And> u v. u |\<in>| x1' \<Longrightarrow> v |\<in>| x1' \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using simple_cg_closure_phase_1_helper'_validity_fst[of M1 M2 x x1 xs _ _, OF assms(1,2,3) * **, of "\<lambda> a b c . a"]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> fst_conv snd_conv
by blast
have "length xs' < length xss"
using simple_cg_closure_phase_1_helper'_length[of x x1 xs]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> Cons by auto
have "(\<And>x2 u v. x2 \<in> list.set (x1' # don) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using *** less.prems(1)
by (metis set_ConsD)
have "xs' = snd (snd (simple_cg_closure_phase_1_helper' x x1 xs))"
using \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> by auto
have "(\<And>x2 u v. x2 \<in> list.set xs' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_1_helper'_validity_snd[of xs' M1]
unfolding \<open>xs' = snd (snd (simple_cg_closure_phase_1_helper' x x1 xs))\<close>
using ** simple_cg_closure_phase_1_helper'_validity_snd by blast
have "x2 \<in> list.set (snd (simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1' # don)))"
using less.prems(3) unfolding \<open>simple_cg_closure_phase_1_helper x xss (b,don) = simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1' # don)\<close> .
then show ?thesis
using less.hyps[OF \<open>length xs' < length xss\<close> \<open>(\<And>x2 u v. x2 \<in> list.set (x1' # don) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)\<close> \<open>(\<And>x2 u v. x2 \<in> list.set xs' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)\<close>, of "x1'#don" "\<lambda> a b c . a" "\<lambda> a b c . a"]
by force
qed
qed
lemma simple_cg_closure_phase_1_helper_length :
"length (snd (simple_cg_closure_phase_1_helper x xss (b,don))) \<le> length xss + length don"
proof (induction "length xss" arbitrary: xss b don rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
then show ?thesis by auto
next
case (Cons x1 xs)
obtain b' x1' xs' where "simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')"
using prod.exhaust by metis
then have "simple_cg_closure_phase_1_helper x xss (b,don) = simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1' # don)"
unfolding Cons by auto
have "length xs' < length xss"
using simple_cg_closure_phase_1_helper'_length[of x x1 xs]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> Cons by auto
then have "length (snd (simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1'#don))) \<le> length xs' + length (x1'#don)"
using less[of xs'] unfolding Cons by blast
moreover have "length xs' + length (x1'#don) \<le> length xss + length don"
using simple_cg_closure_phase_1_helper'_length[of x x1 xs]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> snd_conv Cons by auto
ultimately show ?thesis
unfolding \<open>simple_cg_closure_phase_1_helper x xss (b,don) = simple_cg_closure_phase_1_helper x xs' (b \<or> b', x1' # don)\<close>
by presburger
qed
qed
lemma simple_cg_closure_phase_1_helper_True :
assumes "fst (simple_cg_closure_phase_1_helper x xss (False,don))"
and "xss \<noteq> []"
shows "length (snd (simple_cg_closure_phase_1_helper x xss (False,don))) < length xss + length don"
using assms
proof (induction "length xss" arbitrary: xss don rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
then show ?thesis using less.prems(2) by auto
next
case (Cons x1 xs)
obtain b' x1' xs' where "simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')"
using prod.exhaust by metis
then have "simple_cg_closure_phase_1_helper x xss (False,don) = simple_cg_closure_phase_1_helper x xs' (b', x1' # don)"
unfolding Cons by auto
show ?thesis proof (cases b')
case True
then have "length xs' < length xs"
using simple_cg_closure_phase_1_helper'_True[of x x1 xs]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> fst_conv snd_conv
by blast
then have "length (snd (simple_cg_closure_phase_1_helper x xs' (b', x1' # don))) < length xss + length don"
using simple_cg_closure_phase_1_helper_length[of x xs' b' "x1'#don"]
unfolding Cons
by auto
then show ?thesis
unfolding \<open>simple_cg_closure_phase_1_helper x xss (False,don) = simple_cg_closure_phase_1_helper x xs' (b', x1' # don)\<close> .
next
case False
then have "simple_cg_closure_phase_1_helper x xss (False,don) = simple_cg_closure_phase_1_helper x xs' (False, x1' # don)"
using \<open>simple_cg_closure_phase_1_helper x xss (False,don) = simple_cg_closure_phase_1_helper x xs' (b', x1' # don)\<close>
by auto
then have "fst (simple_cg_closure_phase_1_helper x xs' (False, x1' # don))"
using less.prems(1) by auto
have "length xs' < length xss"
using simple_cg_closure_phase_1_helper'_length[of x x1 xs]
unfolding \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> Cons by auto
have "xs' \<noteq> []"
using \<open>simple_cg_closure_phase_1_helper' x x1 xs = (b',x1',xs')\<close> False
by (metis \<open>fst (simple_cg_closure_phase_1_helper x xs' (False, x1' # don))\<close> simple_cg_closure_phase_1_helper.simps(1) fst_eqD)
show ?thesis
using less.hyps[OF \<open>length xs' < length xss\<close> \<open>fst (simple_cg_closure_phase_1_helper x xs' (False, x1' # don))\<close> \<open>xs' \<noteq> []\<close>] \<open>length xs' < length xss\<close>
unfolding \<open>simple_cg_closure_phase_1_helper x xss (False,don) = simple_cg_closure_phase_1_helper x xs' (False, x1' # don)\<close>
unfolding Cons
by auto
qed
qed
qed
(* closure operation (1) *)
fun simple_cg_closure_phase_1 :: "'a simple_cg \<Rightarrow> (bool \<times> 'a simple_cg)" where
"simple_cg_closure_phase_1 xs = foldl (\<lambda> (b,xs) x. let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xs"
lemma simple_cg_closure_phase_1_validity :
assumes "observable M1" and "observable M2"
and "\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (simple_cg_closure_phase_1 xs))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1" and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have "\<And> xss x2 u v . (\<And> x2 u v . x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v) \<Longrightarrow> x2 \<in> list.set (snd (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss)) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
proof -
fix xss x2 u v
assume "\<And> x2 u v . x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
then show "converge M1 u v \<and> converge M2 u v"
proof (induction xss arbitrary: x2 u v rule: rev_induct)
case Nil
then have "x2 \<in> list.set xs"
by auto
then show ?case
using Nil.prems(3,4,5,6) assms(3) by blast
next
case (snoc x xss)
obtain b xss' where "(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')"
using prod.exhaust by metis
moreover obtain b' xss'' where "simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')"
using prod.exhaust by metis
ultimately have *:"(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')"
by auto
have "(\<And>u v. u |\<in>| x \<Longrightarrow> v |\<in>| x \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using snoc.prems(1)
by (metis append_Cons list.set_intros(1) list_set_sym)
moreover have "(\<And>x2 u v. x2 \<in> list.set [] \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
by auto
moreover have "(\<And>x2 u v. x2 \<in> list.set xss' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
proof -
have "(\<And>x2 u v. x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using snoc.prems(1)
by (metis (no_types, lifting) append_Cons append_Nil2 insertCI list.simps(15) list_set_sym)
then show "(\<And>x2 u v. x2 \<in> list.set xss' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using snoc.IH
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')\<close> snd_conv
by blast
qed
ultimately have "(\<And>x2 u v. x2 \<in> list.set xss'' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_1_helper_validity[OF assms(1,2), of x "[]" xss' _ False]
unfolding \<open>simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')\<close> snd_conv
by blast
then show ?case
using snoc.prems(2,3,4,5,6)
unfolding * snd_conv
by blast
qed
qed
then show ?thesis
using assms(3,4,5,6,7,8)
unfolding simple_cg_closure_phase_1.simps
by blast
qed
lemma simple_cg_closure_phase_1_length_helper :
"length (snd (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss)) \<le> length xs"
proof (induction xss rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xss)
obtain b xss' where "(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')"
using prod.exhaust by metis
moreover obtain b' xss'' where "simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')"
using prod.exhaust by metis
ultimately have *:"(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')"
by auto
have "length xss' \<le> length xs"
using snoc.IH
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')\<close>
by auto
moreover have "length xss'' \<le> length xss'"
using simple_cg_closure_phase_1_helper_length[of x xss' False "[]"]
unfolding \<open>simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')\<close>
by auto
ultimately show ?case
unfolding * snd_conv
by simp
qed
lemma simple_cg_closure_phase_1_length :
"length (snd (simple_cg_closure_phase_1 xs)) \<le> length xs"
using simple_cg_closure_phase_1_length_helper by auto
lemma simple_cg_closure_phase_1_True :
assumes "fst (simple_cg_closure_phase_1 xs)"
shows "length (snd (simple_cg_closure_phase_1 xs)) < length xs"
proof -
have "\<And> xss . fst (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) \<Longrightarrow> length (snd (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss)) < length xs"
proof -
fix xss
assume "fst (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss)"
then show "length (snd (foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss)) < length xs"
proof (induction xss rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xss)
obtain b xss' where "(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')"
using prod.exhaust by metis
moreover obtain b' xss'' where "simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')"
using prod.exhaust by metis
ultimately have "(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')"
by auto
consider b | b'
using snoc.prems
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')\<close> fst_conv
by blast
then show ?case proof cases
case 1
then have "length xss' < length xs"
using snoc.IH
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) xss) = (b,xss')\<close> fst_conv snd_conv
by auto
moreover have "length xss'' \<le> length xss'"
using simple_cg_closure_phase_1_helper_length[of x xss' False "[]"]
unfolding \<open>simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')\<close>
by auto
ultimately show ?thesis
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')\<close> snd_conv
by simp
next
case 2
have "length xss' \<le> length xs"
using simple_cg_closure_phase_1_length_helper[of xss xs]
by (metis \<open>foldl (\<lambda>(b, xs) x. let (b', xs') = simple_cg_closure_phase_1_helper x xs (False, []) in (b \<or> b', xs')) (False, xs) xss = (b, xss')\<close> simple_cg_closure_phase_1_length_helper snd_conv)
moreover have "length xss'' < length xss'"
proof -
have "xss' \<noteq> []"
using "2" \<open>simple_cg_closure_phase_1_helper x xss' (False, []) = (b', xss'')\<close> by auto
then show ?thesis
using simple_cg_closure_phase_1_helper_True[of x xss' "[]"] 2
unfolding \<open>simple_cg_closure_phase_1_helper x xss' (False,[]) = (b',xss'')\<close> fst_conv snd_conv
by auto
qed
ultimately show ?thesis
unfolding \<open>(foldl (\<lambda> (b,xs) x . let (b',xs') = simple_cg_closure_phase_1_helper x xs (False,[]) in (b\<or>b',xs')) (False,xs) (xss@[x])) = (b\<or>b',xss'')\<close> snd_conv
by simp
qed
qed
qed
then show ?thesis
using assms by auto
qed
fun can_merge_by_intersection :: "'a list fset \<Rightarrow> 'a list fset \<Rightarrow> bool" where
"can_merge_by_intersection x1 x2 = (\<exists> \<alpha> . \<alpha> |\<in>| x1 \<and> \<alpha> |\<in>| x2)"
lemma can_merge_by_intersection_code[code] :
"can_merge_by_intersection x1 x2 = (\<exists> \<alpha> \<in> fset x1 . \<alpha> |\<in>| x2)"
unfolding can_merge_by_intersection.simps
by (meson notin_fset)
lemma can_merge_by_intersection_validity :
assumes "\<And> u v . u |\<in>| x1 \<Longrightarrow> v |\<in>| x1 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> u v . u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "can_merge_by_intersection x1 x2"
and "u |\<in>| (x1 |\<union>| x2)"
and "v |\<in>| (x1 |\<union>| x2)"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
obtain \<alpha> where "\<alpha> |\<in>| x1" and "\<alpha> |\<in>| x2"
using assms(3) by auto
have "converge M1 u \<alpha> \<and> converge M2 u \<alpha>"
using \<open>\<alpha> |\<in>| x1\<close> \<open>\<alpha> |\<in>| x2\<close> assms(1,2,4,6,7) by blast
moreover have "converge M1 v \<alpha> \<and> converge M2 v \<alpha>"
by (metis \<open>\<alpha> |\<in>| x1\<close> \<open>\<alpha> |\<in>| x2\<close> assms(1) assms(2) assms(5) calculation converge.elims(2) funion_iff)
ultimately show ?thesis
by simp
qed
fun simple_cg_closure_phase_2_helper :: "'a list fset \<Rightarrow> 'a simple_cg \<Rightarrow> (bool \<times> 'a list fset \<times> 'a simple_cg)" where
"simple_cg_closure_phase_2_helper x1 xs =
(let (x2s,others) = separate_by (can_merge_by_intersection x1) xs;
x1Union = foldl (|\<union>|) x1 x2s
in (x2s \<noteq> [],x1Union,others))"
lemma simple_cg_closure_phase_2_helper_length :
"length (snd (snd (simple_cg_closure_phase_2_helper x1 xs))) \<le> length xs"
by auto
lemma simple_cg_closure_phase_2_helper_validity_fst :
assumes "\<And> u v . u |\<in>| x1 \<Longrightarrow> v |\<in>| x1 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "u |\<in>| fst (snd (simple_cg_closure_phase_2_helper x1 xs))"
and "v |\<in>| fst (snd (simple_cg_closure_phase_2_helper x1 xs))"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have *:"\<And> w . w |\<in>| fst (snd (simple_cg_closure_phase_2_helper x1 xs)) \<Longrightarrow> w |\<in>| x1 \<or> (\<exists> x2 . x2 \<in> list.set xs \<and> w |\<in>| x2 \<and> can_merge_by_intersection x1 x2)"
proof -
fix w assume "w |\<in>| fst (snd (simple_cg_closure_phase_2_helper x1 xs))"
then have "w |\<in>| ffUnion (fset_of_list (x1#(filter (can_merge_by_intersection x1) xs)))"
using foldl_funion_fsingleton[where xs="(filter (can_merge_by_intersection x1) xs)"]
by auto
then obtain x2 where "w |\<in>| x2"
and "x2 |\<in>| fset_of_list (x1#(filter (can_merge_by_intersection x1) xs))"
using ffUnion_fmember_ob
by metis
then consider "x2=x1" | "x2 \<in> list.set (filter (can_merge_by_intersection x1) xs)"
by (meson fset_of_list_elem set_ConsD)
then show "w |\<in>| x1 \<or> (\<exists> x2 . x2 \<in> list.set xs \<and> w |\<in>| x2 \<and> can_merge_by_intersection x1 x2)"
using \<open>w |\<in>| x2\<close> by (cases; auto)
qed
consider "u |\<in>| x1" | "(\<exists> x2 . x2 \<in> list.set xs \<and> u |\<in>| x2 \<and> can_merge_by_intersection x1 x2)"
using *[OF assms(3)] by blast
then show ?thesis proof cases
case 1
consider (a) "v |\<in>| x1" | (b) "(\<exists> x2 . x2 \<in> list.set xs \<and> v |\<in>| x2 \<and> can_merge_by_intersection x1 x2)"
using *[OF assms(4)] by blast
then show ?thesis proof cases
case a
then show ?thesis using assms(1)[OF 1 _ assms(5,6)] by auto
next
case b
then obtain x2v where "x2v \<in> list.set xs" and "v |\<in>| x2v" and "can_merge_by_intersection x1 x2v"
using *[OF assms(3)]
by blast
show ?thesis
using can_merge_by_intersection_validity[of x1 M1 M2 x2v, OF assms(1) assms(2)[OF \<open>x2v \<in> list.set xs\<close>] \<open>can_merge_by_intersection x1 x2v\<close>]
using 1 \<open>v |\<in>| x2v\<close> assms(5,6)
by blast
qed
next
case 2
then obtain x2u where "x2u \<in> list.set xs" and "u |\<in>| x2u" and "can_merge_by_intersection x1 x2u"
using *[OF assms(3)]
by blast
obtain \<alpha>u where "\<alpha>u |\<in>| x1" and "\<alpha>u |\<in>| x2u"
using \<open>can_merge_by_intersection x1 x2u\<close> by auto
consider (a) "v |\<in>| x1" | (b) "(\<exists> x2 . x2 \<in> list.set xs \<and> v |\<in>| x2 \<and> can_merge_by_intersection x1 x2)"
using *[OF assms(4)] by blast
then show ?thesis proof cases
case a
show ?thesis
using can_merge_by_intersection_validity[of x1 M1 M2 x2u, OF assms(1) assms(2)[OF \<open>x2u \<in> list.set xs\<close>] \<open>can_merge_by_intersection x1 x2u\<close>]
using \<open>u |\<in>| x2u\<close> a assms(5,6)
by blast
next
case b
then obtain x2v where "x2v \<in> list.set xs" and "v |\<in>| x2v" and "can_merge_by_intersection x1 x2v"
using *[OF assms(4)]
by blast
obtain \<alpha>v where "\<alpha>v |\<in>| x1" and "\<alpha>v |\<in>| x2v"
using \<open>can_merge_by_intersection x1 x2v\<close> by auto
have "\<And> v . v |\<in>| x1 |\<union>| x2u \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using can_merge_by_intersection_validity[of x1 M1 M2 x2u, OF assms(1) assms(2)[OF \<open>x2u \<in> list.set xs\<close>] \<open>can_merge_by_intersection x1 x2u\<close> _ _ assms(5,6)] \<open>u |\<in>| x2u\<close>
by blast
have "\<And> u . u |\<in>| x1 |\<union>| x2v \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using can_merge_by_intersection_validity[of x1 M1 M2 x2v, OF assms(1) assms(2)[OF \<open>x2v \<in> list.set xs\<close>] \<open>can_merge_by_intersection x1 x2v\<close> ] \<open>v |\<in>| x2v\<close>
by blast
show ?thesis
using \<open>\<And>u. \<lbrakk>u |\<in>| x1 |\<union>| x2v; u \<in> L M1; u \<in> L M2\<rbrakk> \<Longrightarrow> converge M1 u v \<and> converge M2 u v\<close> \<open>\<And>v. v |\<in>| x1 |\<union>| x2u \<Longrightarrow> converge M1 u v \<and> converge M2 u v\<close> \<open>\<alpha>u |\<in>| x1\<close> by fastforce
qed
qed
qed
lemma simple_cg_closure_phase_2_helper_validity_snd :
assumes "\<And> x2 u v . x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (snd (simple_cg_closure_phase_2_helper x1 xs)))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have "list.set (snd (snd (simple_cg_closure_phase_2_helper x1 xs))) \<subseteq> list.set xs"
by auto
then show ?thesis
using assms by blast
qed
lemma simple_cg_closure_phase_2_helper_True :
assumes "fst (simple_cg_closure_phase_2_helper x xs)"
shows "length (snd (snd (simple_cg_closure_phase_2_helper x xs))) < length xs"
proof -
have "snd (snd (simple_cg_closure_phase_2_helper x xs)) = filter (\<lambda>x2 . \<not> (can_merge_by_intersection x x2)) xs"
by auto
moreover have "filter (\<lambda>x2 . (can_merge_by_intersection x x2)) xs \<noteq> []"
using assms unfolding simple_cg_closure_phase_1_helper'.simps Let_def separate_by.simps
by fastforce
ultimately show ?thesis
using filter_not_all_length[of "can_merge_by_intersection x" xs]
by metis
qed
function simple_cg_closure_phase_2' :: "'a simple_cg \<Rightarrow> (bool \<times> 'a simple_cg) \<Rightarrow> (bool \<times> 'a simple_cg)" where
"simple_cg_closure_phase_2' [] (b,done) = (b,done)" |
"simple_cg_closure_phase_2' (x#xs) (b,done) = (let (hasChanged,x',xs') = simple_cg_closure_phase_2_helper x xs
in if hasChanged then simple_cg_closure_phase_2' xs' (True,x'#done)
else simple_cg_closure_phase_2' xs (b,x#done))"
by pat_completeness auto
termination
proof -
{
fix xa :: "(bool \<times> 'a list fset \<times> 'a simple_cg)"
fix x xs b don xb y xaa ya
assume "xa = simple_cg_closure_phase_2_helper x xs"
and "(xb, y) = xa"
and "(xaa, ya) = y"
and xb
have "length ya < Suc (length xs)"
using simple_cg_closure_phase_2_helper_True[of x xs] \<open>xb\<close>
unfolding \<open>xa = simple_cg_closure_phase_2_helper x xs\<close>[symmetric]
unfolding \<open>(xb, y) = xa\<close>[symmetric] \<open>(xaa, ya) = y\<close>[symmetric]
unfolding fst_conv snd_conv
by auto
then have "((ya, True, xaa # don), x # xs, b, don) \<in> measure (\<lambda>(xs, bd). length xs)"
by auto
}
then show ?thesis
apply (relation "measure (\<lambda> (xs,bd) . length xs)")
by force+
qed
lemma simple_cg_closure_phase_2'_validity :
assumes "\<And> x2 u v . x2 \<in> list.set don \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "\<And> x2 u v . x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (simple_cg_closure_phase_2' xss (b,don)))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
using assms(1,2,3)
proof (induction "length xss" arbitrary: xss b don rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
show ?thesis using less.prems(3) less.prems(1)[OF _ assms(4,5,6,7)] unfolding Nil
by auto
next
case (Cons x xs)
obtain hasChanged x' xs' where "simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')"
using prod.exhaust by metis
show ?thesis proof (cases hasChanged)
case True
then have "simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs' (True,x'#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
have *:"(\<And>u v. u |\<in>| x \<Longrightarrow> v |\<in>| x \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)" and
**:"(\<And>x2 u v. x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using less.prems(2) unfolding Cons
by (meson list.set_intros)+
have "length xs' < length xss"
unfolding Cons
using simple_cg_closure_phase_2_helper_True[of x xs] True
unfolding \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close> fst_conv snd_conv
by auto
moreover have "(\<And>x2 u v. x2 \<in> list.set (x' # don) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_2_helper_validity_fst[of x M1 M2 xs, OF * **, of "\<lambda> a b c . a"]
using less.prems(1)
unfolding \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close> fst_conv snd_conv
using set_ConsD[of _ x' don]
by blast
moreover have "(\<And>x2 u v. x2 \<in> list.set xs' \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_2_helper_validity_snd[of xs M1 M2 _ x, OF **, of "\<lambda> a b c . a"]
unfolding \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close> fst_conv snd_conv
by blast
moreover have "x2 \<in> list.set (snd (simple_cg_closure_phase_2' xs' (True, x' # don)))"
using less.prems(3) unfolding \<open>simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs' (True,x'#don)\<close> .
ultimately show ?thesis
using less.hyps[of xs' "x'#don"]
by blast
next
case False
then have "simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs (b,x#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
have "length xs < length xss"
unfolding Cons by auto
moreover have "(\<And>x2 u v. x2 \<in> list.set (x # don) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using less.prems(1,2) unfolding Cons
by (metis list.set_intros(1) set_ConsD)
moreover have "(\<And>x2 u v. x2 \<in> list.set xs \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using less.prems(2) unfolding Cons
by (metis list.set_intros(2))
moreover have "x2 \<in> list.set (snd (simple_cg_closure_phase_2' xs (b, x # don)))"
using less.prems(3)
unfolding \<open>simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs (b,x#don)\<close>
unfolding Cons .
ultimately show ?thesis
using less.hyps[of xs "x#don" b]
by blast
qed
qed
qed
lemma simple_cg_closure_phase_2'_length :
"length (snd (simple_cg_closure_phase_2' xss (b,don))) \<le> length xss + length don"
proof (induction "length xss" arbitrary: xss b don rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
then show ?thesis by auto
next
case (Cons x xs)
obtain hasChanged x' xs' where "simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')"
using prod.exhaust by metis
show ?thesis proof (cases hasChanged)
case True
then have "simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs' (True,x'#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
have "length xs' < length xss"
using simple_cg_closure_phase_2_helper_True[of x xs] True
unfolding \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close> snd_conv fst_conv
unfolding Cons
by auto
then show ?thesis
using less.hyps[of xs' True "x'#don"]
unfolding \<open>simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs' (True,x'#don)\<close>
unfolding Cons by auto
next
case False
then have "simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs (b,x#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
show ?thesis
using less.hyps[of xs b "x#don"]
unfolding \<open>simple_cg_closure_phase_2' xss (b,don) = simple_cg_closure_phase_2' xs (b,x#don)\<close>
unfolding Cons
by auto
qed
qed
qed
lemma simple_cg_closure_phase_2'_True :
assumes "fst (simple_cg_closure_phase_2' xss (False,don))"
and "xss \<noteq> []"
shows "length (snd (simple_cg_closure_phase_2' xss (False,don))) < length xss + length don"
using assms
proof (induction "length xss" arbitrary: xss don rule: less_induct)
case less
show ?case proof (cases xss)
case Nil
then show ?thesis
using less.prems(2) by auto
next
case (Cons x xs)
obtain hasChanged x' xs' where "simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')"
using prod.exhaust by metis
show ?thesis proof (cases hasChanged)
case True
then have "simple_cg_closure_phase_2' xss (False,don) = simple_cg_closure_phase_2' xs' (True,x'#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
have "length xs' < length xs"
using simple_cg_closure_phase_2_helper_True[of x xs] True
unfolding \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close> snd_conv fst_conv
unfolding Cons
by auto
moreover have "length (snd (simple_cg_closure_phase_2' xs' (True,x'#don))) \<le> length xs' + length (x'#don)"
using simple_cg_closure_phase_2'_length by metis
ultimately show ?thesis
unfolding \<open>simple_cg_closure_phase_2' xss (False,don) = simple_cg_closure_phase_2' xs' (True,x'#don)\<close>
unfolding Cons
by auto
next
case False
then have "simple_cg_closure_phase_2' xss (False,don) = simple_cg_closure_phase_2' xs (False,x#don)"
using \<open>simple_cg_closure_phase_2_helper x xs = (hasChanged,x',xs')\<close>
unfolding Cons
by auto
have "xs \<noteq> []"
using \<open>simple_cg_closure_phase_2' xss (False, don) = simple_cg_closure_phase_2' xs (False, x # don)\<close> less.prems(1) by auto
show ?thesis
using less.hyps[of xs "x#don", OF _ _ \<open>xs \<noteq> []\<close>]
using less.prems(1)
unfolding \<open>simple_cg_closure_phase_2' xss (False,don) = simple_cg_closure_phase_2' xs (False,x#don)\<close>
unfolding Cons
by auto
qed
qed
qed
(* closure operation (2) *)
fun simple_cg_closure_phase_2 :: "'a simple_cg \<Rightarrow> (bool \<times> 'a simple_cg)" where
"simple_cg_closure_phase_2 xs = simple_cg_closure_phase_2' xs (False,[])"
lemma simple_cg_closure_phase_2_validity :
assumes "\<And> x2 u v . x2 \<in> list.set xss \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (snd (simple_cg_closure_phase_2 xss))"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
using assms(2)
unfolding simple_cg_closure_phase_2.simps
using simple_cg_closure_phase_2'_validity[OF _ assms(1) _ assms(3,4,5,6), of "[]" xss "\<lambda> a b c . a" False]
by auto
lemma simple_cg_closure_phase_2_length :
"length (snd (simple_cg_closure_phase_2 xss)) \<le> length xss"
unfolding simple_cg_closure_phase_2.simps
using simple_cg_closure_phase_2'_length[of xss False "[]"]
by auto
lemma simple_cg_closure_phase_2_True :
assumes "fst (simple_cg_closure_phase_2 xss)"
shows "length (snd (simple_cg_closure_phase_2 xss)) < length xss"
proof -
have "xss \<noteq> []"
using assms by auto
then show ?thesis
using simple_cg_closure_phase_2'_True[of xss "[]"] assms by auto
qed
function simple_cg_closure :: "'a simple_cg \<Rightarrow> 'a simple_cg" where
"simple_cg_closure g = (let (hasChanged1,g1) = simple_cg_closure_phase_1 g;
(hasChanged2,g2) = simple_cg_closure_phase_2 g1
in if hasChanged1 \<or> hasChanged2
then simple_cg_closure g2
else g2)"
by pat_completeness auto
termination
proof -
{
fix g :: "'a simple_cg"
fix x hasChanged1 g1 xb hasChanged2 g2
assume "x = simple_cg_closure_phase_1 g"
"(hasChanged1, g1) = x"
"xb = simple_cg_closure_phase_2 g1"
"(hasChanged2, g2) = xb"
"hasChanged1 \<or> hasChanged2"
then have "simple_cg_closure_phase_1 g = (hasChanged1, g1)"
and "simple_cg_closure_phase_2 g1 = (hasChanged2, g2)"
by auto
have "length g1 \<le> length g"
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close>
using simple_cg_closure_phase_1_length[of g]
by auto
have "length g2 \<le> length g1"
using \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close>
using simple_cg_closure_phase_2_length[of g1]
by auto
consider hasChanged1 | hasChanged2
using \<open>hasChanged1 \<or> hasChanged2\<close> by blast
then have "length g2 < length g"
proof cases
case 1
then have "length g1 < length g"
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close>
using simple_cg_closure_phase_1_True[of g]
by auto
then show ?thesis
using \<open>length g2 \<le> length g1\<close>
by linarith
next
case 2
then have "length g2 < length g1"
using \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close>
using simple_cg_closure_phase_2_True[of g1]
by auto
then show ?thesis
using \<open>length g1 \<le> length g\<close>
by linarith
qed
then have "(g2, g) \<in> measure length"
by auto
}
then show ?thesis by (relation "measure length"; force)
qed
lemma simple_cg_closure_validity :
assumes "observable M1" and "observable M2"
and "\<And> x2 u v . x2 \<in> list.set g \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (simple_cg_closure g)"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
using assms(3,4)
proof (induction "length g" arbitrary: g rule: less_induct)
case less
obtain hasChanged1 hasChanged2 g1 g2 where "simple_cg_closure_phase_1 g = (hasChanged1, g1)"
and "simple_cg_closure_phase_2 g1 = (hasChanged2, g2)"
using prod.exhaust by metis
have "length g1 \<le> length g"
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close>
using simple_cg_closure_phase_1_length[of g]
by auto
have "length g2 \<le> length g1"
using \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close>
using simple_cg_closure_phase_2_length[of g1]
by auto
have "(\<And>x2 u v. x2 \<in> list.set g2 \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
proof -
have "(\<And>x2 u v. x2 \<in> list.set g1 \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_1_validity[OF assms(1,2), of g]
using less.prems(1)
unfolding \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close> snd_conv
by blast
then show "(\<And>x2 u v. x2 \<in> list.set g2 \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using simple_cg_closure_phase_2_validity[of g1]
unfolding \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close> snd_conv
by blast
qed
show ?thesis proof (cases "hasChanged1 \<or> hasChanged2")
case True
then consider hasChanged1 | hasChanged2
by blast
then have "length g2 < length g"
proof cases
case 1
then have "length g1 < length g"
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close>
using simple_cg_closure_phase_1_True[of g]
by auto
then show ?thesis
using \<open>length g2 \<le> length g1\<close>
by linarith
next
case 2
then have "length g2 < length g1"
using \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close>
using simple_cg_closure_phase_2_True[of g1]
by auto
then show ?thesis
using \<open>length g1 \<le> length g\<close>
by linarith
qed
moreover have "x2 \<in> list.set (simple_cg_closure g2)"
using less.prems(2)
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close> \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close> True
by auto
moreover note \<open>(\<And>x2 u v. x2 \<in> list.set g2 \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)\<close>
ultimately show ?thesis
using less.hyps[of g2]
by blast
next
case False
then have "(simple_cg_closure g) = g2"
using \<open>simple_cg_closure_phase_1 g = (hasChanged1, g1)\<close> \<open>simple_cg_closure_phase_2 g1 = (hasChanged2, g2)\<close>
by auto
show ?thesis
using less.prems(2)
using \<open>(\<And>x2 u v. x2 \<in> list.set g2 \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)\<close> assms(5,6,7,8)
unfolding \<open>(simple_cg_closure g) = g2\<close>
by blast
qed
qed
(* when inserting \<alpha> this also for all \<alpha>1@\<alpha>2 = \<alpha> and \<beta> in [\<alpha>1] inserts \<beta>@\<alpha>2 -- extremely inefficient *)
fun simple_cg_insert_with_conv :: "('a::linorder) simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a simple_cg" where
"simple_cg_insert_with_conv g ys = (let
insert_for_prefix = (\<lambda> g i . let
pref = take i ys;
suff = drop i ys;
pref_conv = simple_cg_lookup g pref
in foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) g pref_conv);
g' = simple_cg_insert g ys;
g'' = foldl insert_for_prefix g' [0..<length ys]
in simple_cg_closure g'')"
fun simple_cg_merge :: "'a simple_cg \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a simple_cg" where
"simple_cg_merge g ys1 ys2 = simple_cg_closure ({|ys1,ys2|}#g)"
lemma simple_cg_merge_validity :
assumes "observable M1" and "observable M2"
and "converge M1 u' v' \<and> converge M2 u' v'"
and "\<And> x2 u v . x2 \<in> list.set g \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
and "x2 \<in> list.set (simple_cg_merge g u' v')"
and "u |\<in>| x2"
and "v |\<in>| x2"
and "u \<in> L M1"
and "u \<in> L M2"
shows "converge M1 u v \<and> converge M2 u v"
proof -
have "(\<And>x2 u v. x2 \<in> list.set ({|u',v'|}#g) \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
proof -
fix x2 u v assume "x2 \<in> list.set ({|u',v'|}#g)" and "u |\<in>| x2" and "v |\<in>| x2" and "u \<in> L M1" and "u \<in> L M2"
then consider "x2 = {|u',v'|}" | "x2 \<in> list.set g"
by auto
then show "converge M1 u v \<and> converge M2 u v" proof cases
case 1
then have "u \<in> {u',v'}" and "v \<in> {u',v'}"
using \<open>u |\<in>| x2\<close> \<open>v |\<in>| x2\<close> by auto
then show ?thesis
using assms(3)
by (cases "u = u'"; cases "v = v'"; auto)
next
case 2
then show ?thesis
using assms(4) \<open>u |\<in>| x2\<close> \<open>v |\<in>| x2\<close> \<open>u \<in> L M1\<close> \<open>u \<in> L M2\<close>
by blast
qed
qed
moreover have "x2 \<in> list.set (simple_cg_closure ({|u',v'|}#g))"
using assms(5) by auto
ultimately show ?thesis
using simple_cg_closure_validity[OF assms(1,2) _ _ assms(6,7,8,9)]
by blast
qed
subsection \<open>Invariants\<close>
lemma simple_cg_lookup_iff :
"\<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longleftrightarrow> (\<beta> = \<alpha> \<or> (\<exists> x . x \<in> list.set G \<and> \<alpha> |\<in>| x \<and> \<beta> |\<in>| x))"
proof (induction G rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x G)
show ?case proof (cases "\<alpha> |\<in>| x \<and> \<beta> |\<in>| x")
case True
then have "\<beta> \<in> list.set (simple_cg_lookup (G@[x]) \<alpha>)"
unfolding simple_cg_lookup.simps
unfolding sorted_list_of_set_set
using notin_fset by force
then show ?thesis
using True by auto
next
case False
have "\<beta> \<in> list.set (simple_cg_lookup (G@[x]) \<alpha>) = (\<beta> = \<alpha> \<or> (\<beta> \<in> list.set (simple_cg_lookup G \<alpha>)))"
proof -
consider "\<alpha> |\<notin>| x" | "\<beta> |\<notin>| x"
using False by blast
then show "\<beta> \<in> list.set (simple_cg_lookup (G@[x]) \<alpha>) = (\<beta> = \<alpha> \<or> (\<beta> \<in> list.set (simple_cg_lookup G \<alpha>)))"
proof cases
case 1
then show ?thesis
unfolding simple_cg_lookup.simps
unfolding sorted_list_of_set_set
by auto
next
case 2
then have "\<beta> \<notin> list.set (sorted_list_of_fset x)"
- using fmember.rep_eq by fastforce
+ using fmember_iff_member_fset by fastforce
then have "(\<beta> \<in> list.set (simple_cg_lookup (G@[x]) \<alpha>)) = (\<beta> \<in> Set.insert \<alpha> (list.set (simple_cg_lookup G \<alpha>)))"
unfolding simple_cg_lookup.simps
unfolding sorted_list_of_set_set
by auto
then show ?thesis
by (induction G; auto)
qed
qed
moreover have "(\<exists> x' . x' \<in> list.set (G@[x]) \<and> \<alpha> |\<in>| x' \<and> \<beta> |\<in>| x') = (\<exists> x . x \<in> list.set G \<and> \<alpha> |\<in>| x \<and> \<beta> |\<in>| x)"
using False by auto
ultimately show ?thesis
using snoc.IH
by blast
qed
qed
lemma simple_cg_insert'_invar :
"convergence_graph_insert_invar M1 M2 simple_cg_lookup simple_cg_insert'"
proof -
have "\<And> G \<gamma> \<alpha> \<beta> . \<gamma> \<in> L M1 \<Longrightarrow>
\<gamma> \<in> L M2 \<Longrightarrow>
(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)) \<Longrightarrow>
\<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof
fix G \<gamma> \<alpha>
assume "\<gamma> \<in> L M1"
and "\<gamma> \<in> L M2"
and *:"(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>))"
and "\<alpha> \<in> L M1"
and "\<alpha> \<in> L M2"
show "\<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>)"
unfolding simple_cg_lookup.simps
unfolding sorted_list_of_set_set
by auto
have "\<And> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>) \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof -
fix \<beta>
assume **: "\<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>)"
show "converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof (cases "\<beta> \<in> list.set (simple_cg_lookup G \<alpha>)")
case True
then show ?thesis
using *[OF \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close>]
by presburger
next
case False
show ?thesis proof (cases "find ((|\<in>|) \<gamma>) G")
case None
then have "(simple_cg_insert' G \<gamma>) = {|\<gamma>|}#G"
by auto
have "\<alpha> = \<gamma> \<and> \<beta> = \<gamma>"
using False \<open>\<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>)\<close>
unfolding \<open>(simple_cg_insert' G \<gamma>) = {|\<gamma>|}#G\<close>
by (metis fsingleton_iff set_ConsD simple_cg_lookup_iff)
then show ?thesis
using \<open>\<gamma> \<in> L M1\<close> \<open>\<gamma> \<in> L M2\<close> by auto
next
case (Some x)
then have "(simple_cg_insert' G \<gamma>) = G"
by auto
then show ?thesis
using *[OF \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close>] **
by presburger
qed
qed
qed
then show "(\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G \<gamma>) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
by blast
qed
then show ?thesis
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
by blast
qed
lemma simple_cg_insert'_foldl_helper:
assumes "list.set xss \<subseteq> L M1 \<inter> L M2"
and "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
shows "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl (\<lambda> xs' ys' . simple_cg_insert' xs' ys') G xss) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using \<open>list.set xss \<subseteq> L M1 \<inter> L M2\<close>
proof (induction xss rule: rev_induct)
case Nil
then show ?case
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
by auto
next
case (snoc x xs)
have "x \<in> L M1" and "x \<in> L M2"
using snoc.prems by auto
have "list.set xs \<subseteq> L M1 \<inter> L M2"
using snoc.prems by auto
then have *:"(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl (\<lambda> xs' ys'. simple_cg_insert' xs' ys') G xs) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using snoc.IH
by blast
have **:"(foldl (\<lambda> xs' ys'. simple_cg_insert' xs' ys') G (xs@[x])) = simple_cg_insert' (foldl (\<lambda> xs' ys' . simple_cg_insert' xs' ys') G xs) x"
by auto
show ?case
using snoc.prems(1,2,3) * \<open>x \<in> L M1\<close> \<open>x \<in> L M2\<close>
unfolding **
using simple_cg_insert'_invar[of M1 M2]
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
using simple_cg_lookup_iff
by blast
qed
lemma simple_cg_insert_invar :
"convergence_graph_insert_invar M1 M2 simple_cg_lookup simple_cg_insert"
proof -
have "\<And> G \<gamma> \<alpha> \<beta> . \<gamma> \<in> L M1 \<Longrightarrow>
\<gamma> \<in> L M2 \<Longrightarrow>
(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)) \<Longrightarrow>
\<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert G \<gamma>) \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert G \<gamma>) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof
fix G \<gamma> \<alpha>
assume "\<gamma> \<in> L M1"
and "\<gamma> \<in> L M2"
and *:"(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>))"
and "\<alpha> \<in> L M1"
and "\<alpha> \<in> L M2"
show "\<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert G \<gamma>) \<alpha>)"
unfolding simple_cg_lookup.simps
unfolding sorted_list_of_set_set
by auto
note simple_cg_insert'_foldl_helper[of "prefixes \<gamma>" M1 M2]
moreover have "list.set (prefixes \<gamma>) \<subseteq> L M1 \<inter> L M2"
by (metis (no_types, lifting) IntI \<open>\<gamma> \<in> L M1\<close> \<open>\<gamma> \<in> L M2\<close> language_prefix prefixes_set_ob subsetI)
ultimately show "(\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert G \<gamma>) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close>
by (metis "*" simple_cg_insert.simps)
qed
then show ?thesis
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
by blast
qed
lemma simple_cg_closure_invar_helper :
assumes "observable M1" and "observable M2"
and "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
and "\<beta> \<in> list.set (simple_cg_lookup (simple_cg_closure G) \<alpha>)"
and "\<alpha> \<in> L M1" and "\<alpha> \<in> L M2"
shows "converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof (cases "\<beta> = \<alpha>")
case True
then show ?thesis using assms(5,6) by auto
next
case False
show ?thesis
proof
obtain x where "x \<in> list.set (simple_cg_closure G)" and "\<alpha> |\<in>| x" and "\<beta> |\<in>| x"
using False \<open>\<beta> \<in> list.set (simple_cg_lookup (simple_cg_closure G) \<alpha>)\<close> unfolding simple_cg_lookup_iff
by blast
have "\<And> x2 u v . x2 \<in> list.set G \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v"
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
unfolding simple_cg_lookup_iff
by blast
have "(\<And>x2 u v. x2 \<in> list.set G \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
unfolding simple_cg_lookup_iff by blast
then show "converge M1 \<alpha> \<beta>"
using \<open>\<alpha> |\<in>| x\<close> \<open>\<beta> |\<in>| x\<close> \<open>x \<in> list.set (simple_cg_closure G)\<close> assms(1) assms(2) assms(5) assms(6) simple_cg_closure_validity by blast
have "(\<And>x2 u v. x2 \<in> list.set G \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
unfolding simple_cg_lookup_iff by blast
then show "converge M2 \<alpha> \<beta>"
using \<open>\<alpha> |\<in>| x\<close> \<open>\<beta> |\<in>| x\<close> \<open>x \<in> list.set (simple_cg_closure G)\<close> assms(1) assms(2) assms(5) assms(6) simple_cg_closure_validity by blast
qed
qed
lemma simple_cg_merge_invar :
assumes "observable M1" and "observable M2"
shows "convergence_graph_merge_invar M1 M2 simple_cg_lookup simple_cg_merge"
proof -
have "\<And> G \<gamma> \<gamma>' \<alpha> \<beta>.
converge M1 \<gamma> \<gamma>' \<Longrightarrow>
converge M2 \<gamma> \<gamma>' \<Longrightarrow>
(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>) \<Longrightarrow>
\<beta> \<in> list.set (simple_cg_lookup (simple_cg_merge G \<gamma> \<gamma>') \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof -
fix G \<gamma> \<gamma>' \<alpha> \<beta>
assume "converge M1 \<gamma> \<gamma>'"
"converge M2 \<gamma> \<gamma>'"
"(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
"\<beta> \<in> list.set (simple_cg_lookup (simple_cg_merge G \<gamma> \<gamma>') \<alpha>)"
"\<alpha> \<in> L M1"
"\<alpha> \<in> L M2"
show "converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof (cases "\<beta> = \<alpha>")
case True
then show ?thesis using \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close> by auto
next
case False
then obtain x where "x \<in> list.set (simple_cg_merge G \<gamma> \<gamma>')" and "\<alpha> |\<in>| x" and "\<beta> |\<in>| x"
using \<open>\<beta> \<in> list.set (simple_cg_lookup (simple_cg_merge G \<gamma> \<gamma>') \<alpha>)\<close> unfolding simple_cg_lookup_iff
by blast
have "(\<And>x2 u v. x2 \<in> list.set G \<Longrightarrow> u |\<in>| x2 \<Longrightarrow> v |\<in>| x2 \<Longrightarrow> u \<in> L M1 \<Longrightarrow> u \<in> L M2 \<Longrightarrow> converge M1 u v \<and> converge M2 u v)"
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
unfolding simple_cg_lookup_iff by blast
then show ?thesis
using simple_cg_merge_validity[OF assms(1,2) _ _ \<open>x \<in> list.set (simple_cg_merge G \<gamma> \<gamma>')\<close> \<open>\<alpha> |\<in>| x\<close> \<open>\<beta> |\<in>| x\<close> \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close>]
\<open>converge M1 \<gamma> \<gamma>'\<close> \<open>converge M2 \<gamma> \<gamma>'\<close>
by blast
qed
qed
then show ?thesis
unfolding convergence_graph_merge_invar_def convergence_graph_lookup_invar_def
unfolding simple_cg_lookup_iff
by metis
qed
lemma simple_cg_empty_invar :
"convergence_graph_lookup_invar M1 M2 simple_cg_lookup simple_cg_empty"
unfolding convergence_graph_lookup_invar_def simple_cg_empty_def
by auto
lemma simple_cg_initial_invar :
assumes "observable M1"
shows "convergence_graph_initial_invar M1 M2 simple_cg_lookup simple_cg_initial"
proof -
have "\<And> T . (L M1 \<inter> set T = (L M2 \<inter> set T)) \<Longrightarrow> finite_tree T \<Longrightarrow> (\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (simple_cg_initial M1 T) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix T assume "(L M1 \<inter> set T = (L M2 \<inter> set T))" and "finite_tree T"
then have "list.set (filter (is_in_language M1 (initial M1)) (sorted_list_of_sequences_in_tree T)) \<subseteq> L M1 \<inter> L M2"
unfolding is_in_language_iff[OF assms fsm_initial]
using sorted_list_of_sequences_in_tree_set[OF \<open>finite_tree T\<close>]
by auto
moreover have "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup simple_cg_empty \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using simple_cg_empty_invar
unfolding convergence_graph_lookup_invar_def
by blast
ultimately show "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (simple_cg_initial M1 T) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using simple_cg_insert'_foldl_helper[of "(filter (is_in_language M1 (initial M1)) (sorted_list_of_sequences_in_tree T))" M1 M2]
unfolding simple_cg_initial.simps
by blast
qed
then show ?thesis
unfolding convergence_graph_initial_invar_def convergence_graph_lookup_invar_def
using simple_cg_lookup_iff by blast
qed
lemma simple_cg_insert_with_conv_invar :
assumes "observable M1"
assumes "observable M2"
shows "convergence_graph_insert_invar M1 M2 simple_cg_lookup simple_cg_insert_with_conv"
proof -
have "\<And> G \<gamma> \<alpha> \<beta> . \<gamma> \<in> L M1 \<Longrightarrow>
\<gamma> \<in> L M2 \<Longrightarrow>
(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)) \<Longrightarrow>
\<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G \<gamma>) \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G \<gamma>) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof
fix G ys \<alpha>
assume "ys \<in> L M1"
and "ys \<in> L M2"
and *:"(\<And>\<alpha> . \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> \<alpha> \<in> list.set (simple_cg_lookup G \<alpha>) \<and> (\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>))"
and "\<alpha> \<in> L M1"
and "\<alpha> \<in> L M2"
show "\<alpha> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G ys) \<alpha>)"
using simple_cg_lookup_iff by blast
have "\<And> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G ys) \<alpha>) \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>"
proof -
fix \<beta>
assume "\<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G ys) \<alpha>)"
define insert_for_prefix where insert_for_prefix:
"insert_for_prefix = (\<lambda> g i . let
pref = take i ys;
suff = drop i ys;
pref_conv = simple_cg_lookup g pref
in foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) g pref_conv)"
define g' where g': "g' = simple_cg_insert G ys"
define g'' where g'': "g'' = foldl insert_for_prefix g' [0..<length ys]"
have "simple_cg_insert_with_conv G ys = simple_cg_closure g''"
unfolding simple_cg_insert_with_conv.simps g'' g' insert_for_prefix Let_def by force
have g'_invar: "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup g' \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using g' *
using simple_cg_insert_invar \<open>ys \<in> L M1\<close> \<open>ys \<in> L M2\<close>
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
by blast
have insert_for_prefix_invar: "\<And> i g . (\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup g \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>) \<Longrightarrow> (\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (insert_for_prefix g i) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix i g assume "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup g \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
define pref where pref: "pref = take i ys"
define suff where suff: "suff = drop i ys"
let ?pref_conv = "simple_cg_lookup g pref"
have "insert_for_prefix g i = foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) g ?pref_conv"
unfolding insert_for_prefix pref suff Let_def by force
have "ys = pref @ suff"
unfolding pref suff by auto
then have "pref \<in> L M1" and "pref \<in> L M2"
using \<open>ys \<in> L M1\<close> \<open>ys \<in> L M2\<close> language_prefix by metis+
have insert_step_invar: "\<And> ys' pc G . list.set pc \<subseteq> list.set (simple_cg_lookup g pref) \<Longrightarrow> ys' \<in> list.set pc \<Longrightarrow>
(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>) \<Longrightarrow>
(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G (ys'@suff)) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix ys' pc G
assume "list.set pc \<subseteq> list.set (simple_cg_lookup g pref)"
and "ys' \<in> list.set pc"
and "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
then have "converge M1 pref ys'" and "converge M2 pref ys'"
using \<open>\<And>\<beta> \<alpha>. \<beta> \<in> list.set (simple_cg_lookup g \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>\<close>
using \<open>pref \<in> L M1\<close> \<open>pref \<in> L M2\<close>
by blast+
have "(ys'@suff) \<in> L M1"
using \<open>converge M1 pref ys'\<close>
using \<open>ys = pref @ suff\<close> \<open>ys \<in> L M1\<close> assms(1) converge_append_language_iff by blast
moreover have "(ys'@suff) \<in> L M2"
using \<open>converge M2 pref ys'\<close>
using \<open>ys = pref @ suff\<close> \<open>ys \<in> L M2\<close> assms(2) converge_append_language_iff by blast
ultimately show "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert' G (ys'@suff)) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>
using simple_cg_insert'_invar[of M1 M2]
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
using simple_cg_lookup_iff by blast
qed
have insert_foldl_invar: "\<And> pc G . list.set pc \<subseteq> list.set (simple_cg_lookup g pref) \<Longrightarrow>
(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>) \<Longrightarrow>
(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) G pc) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix pc G assume "list.set pc \<subseteq> list.set (simple_cg_lookup g pref)"
and "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
then show "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) G pc) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof (induction pc rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a pc)
have **:"(foldl (\<lambda>g' ys'. simple_cg_insert' g' (ys' @ suff)) G (pc @ [a]))
= simple_cg_insert' (foldl (\<lambda>g' ys'. simple_cg_insert' g' (ys' @ suff)) G pc) (a@suff)"
unfolding foldl_append by auto
have "list.set pc \<subseteq> list.set (simple_cg_lookup g pref)"
using snoc.prems(4) by auto
then have *: "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) G pc) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using snoc.IH
using snoc.prems(5) by blast
have "a \<in> list.set (pc @ [a])" by auto
then show ?case
using snoc.prems(1,2,3)
unfolding **
using insert_step_invar[OF snoc.prems(4), of a "(foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) G pc)", OF _ *]
by blast
qed
qed
show "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (insert_for_prefix g i) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
using insert_foldl_invar[of ?pref_conv g, OF _ \<open>(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup g \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)\<close>]
unfolding \<open>insert_for_prefix g i = foldl (\<lambda> g' ys' . simple_cg_insert' g' (ys'@suff)) g ?pref_conv\<close>
by blast
qed
have insert_for_prefix_foldl_invar: "\<And> ns . (\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl insert_for_prefix g' ns) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix ns show "(\<And>\<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup (foldl insert_for_prefix g' ns) \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof (induction ns rule: rev_induct)
case Nil
then show ?case using g'_invar by auto
next
case (snoc a ns)
show ?case
using snoc.prems
using insert_for_prefix_invar [OF snoc.IH]
by auto
qed
qed
show \<open>converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>\<close>
using \<open>\<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G ys) \<alpha>)\<close>
unfolding \<open>simple_cg_insert_with_conv G ys = simple_cg_closure g''\<close> g''
using insert_for_prefix_foldl_invar[of _ "[0..<length ys]" _]
using simple_cg_closure_invar_helper[OF assms, of "(foldl insert_for_prefix g' [0..<length ys])", OF insert_for_prefix_foldl_invar[of _ "[0..<length ys]" _]]
using \<open>\<alpha> \<in> L M1\<close> \<open>\<alpha> \<in> L M2\<close> by blast
qed
then show "(\<forall> \<beta> . \<beta> \<in> list.set (simple_cg_lookup (simple_cg_insert_with_conv G ys) \<alpha>) \<longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
by blast
qed
then show ?thesis
unfolding convergence_graph_insert_invar_def convergence_graph_lookup_invar_def
by blast
qed
lemma simple_cg_lookup_with_conv_from_lookup_invar:
assumes "observable M1" and "observable M2"
and "convergence_graph_lookup_invar M1 M2 simple_cg_lookup G"
shows "convergence_graph_lookup_invar M1 M2 simple_cg_lookup_with_conv G"
proof -
have "(\<And> \<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup_with_conv G \<alpha>) \<Longrightarrow> \<alpha> \<in> L M1 \<Longrightarrow> \<alpha> \<in> L M2 \<Longrightarrow> converge M1 \<alpha> \<beta> \<and> converge M2 \<alpha> \<beta>)"
proof -
fix ys \<beta> assume "\<beta> \<in> list.set (simple_cg_lookup_with_conv G ys)" and "ys \<in> L M1" and "ys \<in> L M2"
define lookup_for_prefix where lookup_for_prefix:
"lookup_for_prefix = (\<lambda>i . let
pref = take i ys;
suff = drop i ys;
pref_conv = (foldl (|\<union>|) fempty (filter (\<lambda>x . pref |\<in>| x) G))
in fimage (\<lambda> pref' . pref'@suff) pref_conv)"
have "\<And> ns . \<beta> \<in> list.set (sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty ns))) \<Longrightarrow> converge M1 ys \<beta> \<and> converge M2 ys \<beta>"
proof -
fix ns assume "\<beta> \<in> list.set (sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty ns)))"
then show "converge M1 ys \<beta> \<and> converge M2 ys \<beta>"
proof (induction ns rule: rev_induct)
case Nil
then show ?case using \<open>ys \<in> L M1\<close> \<open>ys \<in> L M2\<close> by auto
next
case (snoc a ns)
have "list.set (sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty (ns@[a])))) =
(fset (lookup_for_prefix a) \<union> list.set (sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty ns))))"
by auto
then consider "\<beta> \<in> fset (lookup_for_prefix a)" | "\<beta> \<in> list.set (sorted_list_of_fset (finsert ys (foldl (\<lambda> cs i . lookup_for_prefix i |\<union>| cs) fempty ns)))"
using snoc.prems by auto
then show ?case proof cases
case 1
define pref where pref: "pref = take a ys"
define suff where suff: "suff = drop a ys"
define pref_conv where pref_conv: "pref_conv = (foldl (|\<union>|) fempty (filter (\<lambda>x . pref |\<in>| x) G))"
have "lookup_for_prefix a = fimage (\<lambda> pref' . pref'@suff) pref_conv"
unfolding lookup_for_prefix pref suff pref_conv
by metis
then have "\<beta> \<in> list.set (map (\<lambda> pref' . pref'@suff) (sorted_list_of_fset (finsert pref (foldl (|\<union>|) {||} (filter ((|\<in>|) pref) G)))))"
using 1 unfolding pref_conv by auto
then obtain \<gamma> where "\<gamma> \<in> list.set (simple_cg_lookup G pref)"
and "\<beta> = \<gamma>@suff"
unfolding simple_cg_lookup.simps
by (meson set_map_elem)
then have "converge M1 \<gamma> pref" and "converge M2 \<gamma> pref"
using \<open>convergence_graph_lookup_invar M1 M2 simple_cg_lookup G\<close>
unfolding convergence_graph_lookup_invar_def
by (metis \<open>ys \<in> L M1\<close> \<open>ys \<in> L M2\<close> append_take_drop_id converge_sym language_prefix pref)+
then show ?thesis
by (metis \<open>\<And>thesis. (\<And>\<gamma>. \<lbrakk>\<gamma> \<in> list.set (simple_cg_lookup G pref); \<beta> = \<gamma> @ suff\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> \<open>ys \<in> L M1\<close> \<open>ys \<in> L M2\<close> append_take_drop_id assms(1) assms(2) assms(3) converge_append converge_append_language_iff convergence_graph_lookup_invar_def language_prefix pref suff)
next
case 2
then show ?thesis using snoc.IH by blast
qed
qed
qed
then show "converge M1 ys \<beta> \<and> converge M2 ys \<beta>"
using \<open>\<beta> \<in> list.set (simple_cg_lookup_with_conv G ys)\<close>
unfolding simple_cg_lookup_with_conv.simps Let_def lookup_for_prefix sorted_list_of_set_set
by blast
qed
moreover have "\<And> \<alpha> . \<alpha> \<in> list.set (simple_cg_lookup_with_conv G \<alpha>)"
unfolding simple_cg_lookup_with_conv.simps by auto
ultimately show ?thesis
unfolding convergence_graph_lookup_invar_def
by blast
qed
lemma simple_cg_lookup_from_lookup_invar_with_conv:
assumes "convergence_graph_lookup_invar M1 M2 simple_cg_lookup_with_conv G"
shows "convergence_graph_lookup_invar M1 M2 simple_cg_lookup G"
proof -
have "\<And> \<alpha> \<beta>. \<beta> \<in> list.set (simple_cg_lookup G \<alpha>) \<Longrightarrow> \<beta> \<in> list.set (simple_cg_lookup_with_conv G \<alpha>)"
proof -
fix \<alpha> \<beta> assume "\<beta> \<in> list.set (simple_cg_lookup G \<alpha>)"
define lookup_for_prefix where lookup_for_prefix:
"lookup_for_prefix = (\<lambda>i . let
pref = take i \<alpha>;
suff = drop i \<alpha>;
pref_conv = simple_cg_lookup G pref
in map (\<lambda> pref' . pref'@suff) pref_conv)"
have "lookup_for_prefix (length \<alpha>) = simple_cg_lookup G \<alpha>"
unfolding lookup_for_prefix by auto
moreover have "list.set (lookup_for_prefix (length \<alpha>)) \<subseteq> list.set (simple_cg_lookup_with_conv G \<alpha>)"
unfolding simple_cg_lookup_with_conv.simps lookup_for_prefix Let_def sorted_list_of_set_set by auto
ultimately show "\<beta> \<in> list.set (simple_cg_lookup_with_conv G \<alpha>)"
using \<open>\<beta> \<in> list.set (simple_cg_lookup G \<alpha>)\<close>
by (metis subsetD)
qed
then show ?thesis
using assms
unfolding convergence_graph_lookup_invar_def
using simple_cg_lookup_iff by blast
qed
lemma simple_cg_lookup_invar_with_conv_eq :
assumes "observable M1" and "observable M2"
shows "convergence_graph_lookup_invar M1 M2 simple_cg_lookup_with_conv G = convergence_graph_lookup_invar M1 M2 simple_cg_lookup G"
using simple_cg_lookup_with_conv_from_lookup_invar[OF assms] simple_cg_lookup_from_lookup_invar_with_conv[of M1 M2]
by blast
lemma simple_cg_insert_invar_with_conv :
assumes "observable M1" and "observable M2"
shows "convergence_graph_insert_invar M1 M2 simple_cg_lookup_with_conv simple_cg_insert"
using simple_cg_insert_invar[of M1 M2]
unfolding convergence_graph_insert_invar_def
unfolding simple_cg_lookup_invar_with_conv_eq[OF assms]
.
lemma simple_cg_merge_invar_with_conv :
assumes "observable M1" and "observable M2"
shows "convergence_graph_merge_invar M1 M2 simple_cg_lookup_with_conv simple_cg_merge"
using simple_cg_merge_invar[OF assms]
unfolding convergence_graph_merge_invar_def
unfolding simple_cg_lookup_invar_with_conv_eq[OF assms]
.
lemma simple_cg_initial_invar_with_conv :
assumes "observable M1" and "observable M2"
shows "convergence_graph_initial_invar M1 M2 simple_cg_lookup_with_conv simple_cg_initial"
using simple_cg_initial_invar[OF assms(1), of M2]
unfolding convergence_graph_initial_invar_def
unfolding simple_cg_lookup_invar_with_conv_eq[OF assms]
.
end
diff --git a/thys/FSM_Tests/FSM.thy b/thys/FSM_Tests/FSM.thy
--- a/thys/FSM_Tests/FSM.thy
+++ b/thys/FSM_Tests/FSM.thy
@@ -1,6428 +1,6428 @@
section \<open>Finite State Machines\<close>
text \<open>This theory defines well-formed finite state machines and introduces various closely related
notions, as well as a selection of basic properties and definitions.\<close>
theory FSM
imports FSM_Impl "HOL-Library.Quotient_Type" "HOL-Library.Product_Lexorder"
begin
subsection \<open>Well-formed Finite State Machines\<close>
text \<open>A value of type @{text "fsm_impl"} constitutes a well-formed FSM if its contained sets are
finite and the initial state and the components of each transition are contained in their
respective sets.\<close>
abbreviation(input) "well_formed_fsm (M :: ('state, 'input, 'output) fsm_impl)
\<equiv> (initial M \<in> states M
\<and> finite (states M)
\<and> finite (inputs M)
\<and> finite (outputs M)
\<and> finite (transitions M)
\<and> (\<forall> t \<in> transitions M . t_source t \<in> states M \<and>
t_input t \<in> inputs M \<and>
t_target t \<in> states M \<and>
t_output t \<in> outputs M)) "
typedef ('state, 'input, 'output) fsm =
"{ M :: ('state, 'input, 'output) fsm_impl . well_formed_fsm M}"
morphisms fsm_impl_of_fsm Abs_fsm
proof -
obtain q :: 'state where "True" by blast
have "well_formed_fsm (FSMI q {q} {} {} {})" by auto
then show ?thesis by blast
qed
setup_lifting type_definition_fsm
lift_definition initial :: "('state, 'input, 'output) fsm \<Rightarrow> 'state" is FSM_Impl.initial done
lift_definition states :: "('state, 'input, 'output) fsm \<Rightarrow> 'state set" is FSM_Impl.states done
lift_definition inputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'input set" is FSM_Impl.inputs done
lift_definition outputs :: "('state, 'input, 'output) fsm \<Rightarrow> 'output set" is FSM_Impl.outputs done
lift_definition transitions ::
"('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input \<times> 'output \<times> 'state) set"
is FSM_Impl.transitions done
lift_definition fsm_from_list :: "'a \<Rightarrow> ('a,'b,'c) transition list \<Rightarrow> ('a, 'b, 'c) fsm"
is FSM_Impl.fsm_impl_from_list
proof -
fix q :: 'a
fix ts :: "('a,'b,'c) transition list"
show "well_formed_fsm (fsm_impl_from_list q ts)"
by (induction ts; auto)
qed
lemma fsm_initial[intro]: "initial M \<in> states M"
by (transfer; blast)
lemma fsm_states_finite: "finite (states M)"
by (transfer; blast)
lemma fsm_inputs_finite: "finite (inputs M)"
by (transfer; blast)
lemma fsm_outputs_finite: "finite (outputs M)"
by (transfer; blast)
lemma fsm_transitions_finite: "finite (transitions M)"
by (transfer; blast)
lemma fsm_transition_source[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_source t \<in> states M"
by (transfer; blast)
lemma fsm_transition_target[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_target t \<in> states M"
by (transfer; blast)
lemma fsm_transition_input[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_input t \<in> inputs M"
by (transfer; blast)
lemma fsm_transition_output[intro]: "\<And> t . t \<in> (transitions M) \<Longrightarrow> t_output t \<in> outputs M"
by (transfer; blast)
instantiation fsm :: (type,type,type) equal
begin
definition equal_fsm :: "('a, 'b, 'c) fsm \<Rightarrow> ('a, 'b, 'c) fsm \<Rightarrow> bool" where
"equal_fsm x y = (initial x = initial y \<and> states x = states y \<and> inputs x = inputs y \<and> outputs x = outputs y \<and> transitions x = transitions y)"
instance
apply (intro_classes)
unfolding equal_fsm_def
apply transfer
using fsm_impl.expand by auto
end
subsubsection \<open>Example FSMs\<close>
definition m_ex_H :: "(integer,integer,integer) fsm" where
"m_ex_H = fsm_from_list 1 [ (1,0,0,2),
(1,0,1,4),
(1,1,1,4),
(2,0,0,2),
(2,1,1,4),
(3,0,1,4),
(3,1,0,1),
(3,1,1,3),
(4,0,0,3),
(4,1,0,1)]"
definition m_ex_9 :: "(integer,integer,integer) fsm" where
"m_ex_9 = fsm_from_list 0 [ (0,0,2,2),
(0,0,3,2),
(0,1,0,3),
(0,1,1,3),
(1,0,3,2),
(1,1,1,3),
(2,0,2,2),
(2,1,3,3),
(3,0,2,2),
(3,1,0,2),
(3,1,1,1)]"
definition m_ex_DR :: "(integer,integer,integer) fsm" where
"m_ex_DR = fsm_from_list 0 [(0,0,0,100),
(100,0,0,101),
(100,0,1,101),
(101,0,0,102),
(101,0,1,102),
(102,0,0,103),
(102,0,1,103),
(103,0,0,104),
(103,0,1,104),
(104,0,0,100),
(104,0,1,100),
(104,1,0,400),
(0,0,2,200),
(200,0,2,201),
(201,0,2,202),
(202,0,2,203),
(203,0,2,200),
(203,1,0,400),
(0,1,0,300),
(100,1,0,300),
(101,1,0,300),
(102,1,0,300),
(103,1,0,300),
(200,1,0,300),
(201,1,0,300),
(202,1,0,300),
(300,0,0,300),
(300,1,0,300),
(400,0,0,300),
(400,1,0,300)]"
subsection \<open>Transition Function h and related functions\<close>
lift_definition h :: "('state, 'input, 'output) fsm \<Rightarrow> ('state \<times> 'input) \<Rightarrow> ('output \<times> 'state) set"
is FSM_Impl.h .
lemma h_simps[simp]: "FSM.h M (q,x) = { (y,q') . (q,x,y,q') \<in> transitions M }"
by (transfer; auto)
lift_definition h_obs :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input \<Rightarrow> 'output \<Rightarrow> 'state option"
is FSM_Impl.h_obs .
lemma h_obs_simps[simp]: "FSM.h_obs M q x y = (let
tgts = snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))
in if card tgts = 1
then Some (the_elem tgts)
else None)"
by (transfer; auto)
fun defined_inputs' :: "(('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> 'b set" where
"defined_inputs' hM iM q = {x \<in> iM . hM (q,x) \<noteq> {}}"
fun defined_inputs :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b set" where
"defined_inputs M q = defined_inputs' (h M) (inputs M) q"
lemma defined_inputs_set : "defined_inputs M q = {x \<in> inputs M . h M (q,x) \<noteq> {} }"
by auto
fun transitions_from' :: "(('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) transition set" where
"transitions_from' hM iM q = \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . (q,x,y,q')) (hM (q,x))) iM)"
fun transitions_from :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) transition set" where
"transitions_from M q = transitions_from' (h M) (inputs M) q"
lemma transitions_from_set :
assumes "q \<in> states M"
shows "transitions_from M q = {t \<in> transitions M . t_source t = q}"
proof -
have "\<And> t . t \<in> transitions_from M q \<Longrightarrow> t \<in> transitions M \<and> t_source t = q" by auto
moreover have "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t = q \<Longrightarrow> t \<in> transitions_from M q"
proof -
fix t assume "t \<in> transitions M" and "t_source t = q"
then have "(t_output t, t_target t) \<in> h M (q,t_input t)" and "t_input t \<in> inputs M" by auto
then have "t_input t \<in> defined_inputs' (h M) (inputs M) q"
unfolding defined_inputs'.simps \<open>t_source t = q\<close> by blast
have "(q, t_input t, t_output t, t_target t) \<in> transitions M"
using \<open>t_source t = q\<close> \<open>t \<in> transitions M\<close> by auto
then have "(q, t_input t, t_output t, t_target t) \<in> (\<lambda>(y, q'). (q, t_input t, y, q')) ` h M (q, t_input t)"
using \<open>(t_output t, t_target t) \<in> h M (q,t_input t)\<close>
unfolding h.simps
by (metis (no_types, lifting) image_iff prod.case_eq_if surjective_pairing)
then have "t \<in> (\<lambda>(y, q'). (q, t_input t, y, q')) ` h M (q, t_input t)"
using \<open>t_source t = q\<close> by (metis prod.collapse)
then show "t \<in> transitions_from M q"
unfolding transitions_from.simps transitions_from'.simps
using \<open>t_input t \<in> defined_inputs' (h M) (inputs M) q\<close>
using \<open>t_input t \<in> FSM.inputs M\<close> by blast
qed
ultimately show ?thesis by blast
qed
fun h_from :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> ('input \<times> 'output \<times> 'state) set" where
"h_from M q = { (x,y,q') . (q,x,y,q') \<in> transitions M }"
lemma h_from[code] : "h_from M q = (let m = set_as_map (transitions M)
in (case m q of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
unfolding set_as_map_def by force
fun h_out :: "('a,'b,'c) fsm \<Rightarrow> ('a \<times> 'b) \<Rightarrow> 'c set" where
"h_out M (q,x) = {y . \<exists> q' . (q,x,y,q') \<in> transitions M}"
lemma h_out_code[code]:
"h_out M = (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of
Some yqs \<Rightarrow> yqs |
None \<Rightarrow> {}))"
proof -
let ?f = "(\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
have "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (transitions M))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` (transitions M)}) qx"
unfolding set_as_map_def by auto
moreover have "\<And> qx . (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` (transitions M)}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> (transitions M)}) qx"
by force
ultimately have "?f = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> (transitions M)})"
by blast
then have "?f = (\<lambda> (q,x) . {y | y . \<exists> q' . (q, x, y, q') \<in> (transitions M)})" by force
then show ?thesis by force
qed
lemma h_out_alt_def :
"h_out M (q,x) = {t_output t | t . t \<in> transitions M \<and> t_source t = q \<and> t_input t = x}"
unfolding h_out.simps
by auto
subsection \<open>Size\<close>
instantiation fsm :: (type,type,type) size
begin
definition size where [simp, code]: "size (m::('a, 'b, 'c) fsm) = card (states m)"
instance ..
end
lemma fsm_size_Suc :
"size M > 0"
unfolding FSM.size_def
using fsm_states_finite[of M] fsm_initial[of M]
using card_gt_0_iff by blast
subsection \<open>Paths\<close>
inductive path :: "('state, 'input, 'output) fsm \<Rightarrow> 'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> bool"
where
nil[intro!] : "q \<in> states M \<Longrightarrow> path M q []" |
cons[intro!] : "t \<in> transitions M \<Longrightarrow> path M (t_target t) ts \<Longrightarrow> path M (t_source t) (t#ts)"
inductive_cases path_nil_elim[elim!]: "path M q []"
inductive_cases path_cons_elim[elim!]: "path M q (t#ts)"
fun visited_states :: "'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> 'state list" where
"visited_states q p = (q # map t_target p)"
fun target :: "'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> 'state" where
"target q p = last (visited_states q p)"
lemma target_nil [simp] : "target q [] = q" by auto
lemma target_snoc [simp] : "target q (p@[t]) = t_target t" by auto
lemma path_begin_state :
assumes "path M q p"
shows "q \<in> states M"
using assms by (cases; auto)
lemma path_append[intro!] :
assumes "path M q p1"
and "path M (target q p1) p2"
shows "path M q (p1@p2)"
using assms by (induct p1 arbitrary: p2; auto)
lemma path_target_is_state :
assumes "path M q p"
shows "target q p \<in> states M"
using assms by (induct p; auto)
lemma path_suffix :
assumes "path M q (p1@p2)"
shows "path M (target q p1) p2"
using assms by (induction p1 arbitrary: q; auto)
lemma path_prefix :
assumes "path M q (p1@p2)"
shows "path M q p1"
using assms by (induction p1 arbitrary: q; auto; (metis path_begin_state))
lemma path_append_elim[elim!] :
assumes "path M q (p1@p2)"
obtains "path M q p1"
and "path M (target q p1) p2"
by (meson assms path_prefix path_suffix)
lemma path_append_target:
"target q (p1@p2) = target (target q p1) p2"
by (induction p1) (simp+)
lemma path_append_target_hd :
assumes "length p > 0"
shows "target q p = target (t_target (hd p)) (tl p)"
using assms by (induction p) (simp+)
lemma path_transitions :
assumes "path M q p"
shows "set p \<subseteq> transitions M"
using assms by (induct p arbitrary: q; fastforce)
lemma path_append_transition[intro!] :
assumes "path M q p"
and "t \<in> transitions M"
and "t_source t = target q p"
shows "path M q (p@[t])"
by (metis assms(1) assms(2) assms(3) cons fsm_transition_target nil path_append)
lemma path_append_transition_elim[elim!] :
assumes "path M q (p@[t])"
shows "path M q p"
and "t \<in> transitions M"
and "t_source t = target q p"
using assms by auto
lemma path_prepend_t : "path M q' p \<Longrightarrow> (q,x,y,q') \<in> transitions M \<Longrightarrow> path M q ((q,x,y,q')#p)"
by (metis (mono_tags, lifting) fst_conv path.intros(2) prod.sel(2))
lemma path_target_append : "target q1 p1 = q2 \<Longrightarrow> target q2 p2 = q3 \<Longrightarrow> target q1 (p1@p2) = q3"
by auto
lemma single_transition_path : "t \<in> transitions M \<Longrightarrow> path M (t_source t) [t]" by auto
lemma path_source_target_index :
assumes "Suc i < length p"
and "path M q p"
shows "t_target (p ! i) = t_source (p ! (Suc i))"
using assms proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc t ps)
then have "path M q ps" and "t_source t = target q ps" and "t \<in> transitions M" by auto
show ?case proof (cases "Suc i < length ps")
case True
then have "t_target (ps ! i) = t_source (ps ! Suc i)"
using snoc.IH \<open>path M q ps\<close> by auto
then show ?thesis
by (simp add: Suc_lessD True nth_append)
next
case False
then have "Suc i = length ps"
using snoc.prems(1) by auto
then have "(ps @ [t]) ! Suc i = t"
by auto
show ?thesis proof (cases "ps = []")
case True
then show ?thesis using \<open>Suc i = length ps\<close> by auto
next
case False
then have "target q ps = t_target (last ps)"
unfolding target.simps visited_states.simps
by (simp add: last_map)
then have "target q ps = t_target (ps ! i)"
using \<open>Suc i = length ps\<close>
by (metis False diff_Suc_1 last_conv_nth)
then show ?thesis
using \<open>t_source t = target q ps\<close>
by (metis \<open>(ps @ [t]) ! Suc i = t\<close> \<open>Suc i = length ps\<close> lessI nth_append)
qed
qed
qed
lemma paths_finite : "finite { p . path M q p \<and> length p \<le> k }"
proof -
have "{ p . path M q p \<and> length p \<le> k } \<subseteq> {xs . set xs \<subseteq> transitions M \<and> length xs \<le> k}"
by (metis (no_types, lifting) Collect_mono path_transitions)
then show "finite { p . path M q p \<and> length p \<le> k }"
using finite_lists_length_le[OF fsm_transitions_finite[of M], of k]
by (metis (mono_tags) finite_subset)
qed
lemma visited_states_prefix :
assumes "q' \<in> set (visited_states q p)"
shows "\<exists> p1 p2 . p = p1@p2 \<and> target q p1 = q'"
using assms proof (induction p arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons a p)
then show ?case
proof (cases "q' \<in> set (visited_states (t_target a) p)")
case True
then obtain p1 p2 where "p = p1 @ p2 \<and> target (t_target a) p1 = q'"
using Cons.IH by blast
then have "(a#p) = (a#p1)@p2 \<and> target q (a#p1) = q'"
by auto
then show ?thesis by blast
next
case False
then have "q' = q"
using Cons.prems by auto
then show ?thesis
by auto
qed
qed
lemma visited_states_are_states :
assumes "path M q1 p"
shows "set (visited_states q1 p) \<subseteq> states M"
by (metis assms path_prefix path_target_is_state subsetI visited_states_prefix)
lemma transition_subset_path :
assumes "transitions A \<subseteq> transitions B"
and "path A q p"
and "q \<in> states B"
shows "path B q p"
using assms(2) proof (induction p rule: rev_induct)
case Nil
show ?case using assms(3) by auto
next
case (snoc t p)
then show ?case using assms(1) path_suffix
by fastforce
qed
subsubsection \<open>Paths of fixed length\<close>
fun paths_of_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> (('a \<times>'b) \<Rightarrow> ('c\<times>'a) set) \<Rightarrow> 'b set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set"
where
"paths_of_length' prev q hM iM 0 = {prev}" |
"paths_of_length' prev q hM iM (Suc k) =
(let hF = transitions_from' hM iM q
in \<Union> (image (\<lambda> t . paths_of_length' (prev@[t]) (t_target t) hM iM k) hF))"
fun paths_of_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
"paths_of_length M q k = paths_of_length' [] q (h M) (inputs M) k"
subsubsection \<open>Paths up to fixed length\<close>
fun paths_up_to_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> (('a \<times>'b) \<Rightarrow> (('c\<times>'a) set)) \<Rightarrow> 'b set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set"
where
"paths_up_to_length' prev q hM iM 0 = {prev}" |
"paths_up_to_length' prev q hM iM (Suc k) =
(let hF = transitions_from' hM iM q
in insert prev (\<Union> (image (\<lambda> t . paths_up_to_length' (prev@[t]) (t_target t) hM iM k) hF)))"
fun paths_up_to_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
"paths_up_to_length M q k = paths_up_to_length' [] q (h M) (inputs M) k"
lemma paths_up_to_length'_set :
assumes "q \<in> states M"
and "path M q prev"
shows "paths_up_to_length' prev (target q prev) (h M) (inputs M) k
= {(prev@p) | p . path M (target q prev) p \<and> length p \<le> k}"
using assms(2) proof (induction k arbitrary: prev)
case 0
show ?case unfolding paths_up_to_length'.simps using path_target_is_state[OF "0.prems"(1)] by auto
next
case (Suc k)
have "\<And> p . p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)
\<Longrightarrow> p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}"
proof -
fix p assume "p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
then show "p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}"
proof (cases "p = prev")
case True
show ?thesis using path_target_is_state[OF Suc.prems(1)] unfolding True by (simp add: nil)
next
case False
then have "p \<in> (\<Union> (image (\<lambda>t. paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k)
(transitions_from' (h M) (inputs M) (target q prev))))"
using \<open>p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)\<close>
unfolding paths_up_to_length'.simps Let_def by blast
then obtain t where "t \<in> \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . ((target q prev),x,y,q'))
(h M ((target q prev),x))) (inputs M))"
and "p \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k"
unfolding transitions_from'.simps by blast
have "t \<in> transitions M" and "t_source t = (target q prev)"
using \<open>t \<in> \<Union>(image (\<lambda>x . image (\<lambda>(y,q') . ((target q prev),x,y,q'))
(h M ((target q prev),x))) (inputs M))\<close> by auto
then have "path M q (prev@[t])"
using Suc.prems(1) using path_append_transition by simp
have "(target q (prev @ [t])) = t_target t" by auto
show ?thesis
using \<open>p \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (inputs M) k\<close>
using Suc.IH[OF \<open>path M q (prev@[t])\<close>]
unfolding \<open>(target q (prev @ [t])) = t_target t\<close>
using \<open>path M q (prev @ [t])\<close> by auto
qed
qed
moreover have "\<And> p . p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}
\<Longrightarrow> p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
proof -
fix p assume "p \<in> {(prev@p) | p . path M (target q prev) p \<and> length p \<le> Suc k}"
then obtain p' where "p = prev@p'"
and "path M (target q prev) p'"
and "length p' \<le> Suc k"
by blast
have "prev@p' \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
proof (cases p')
case Nil
then show ?thesis by auto
next
case (Cons t p'')
then have "t \<in> transitions M" and "t_source t = (target q prev)"
using \<open>path M (target q prev) p'\<close> by auto
then have "path M q (prev@[t])"
using Suc.prems(1) using path_append_transition by simp
have "(target q (prev @ [t])) = t_target t" by auto
have "length p'' \<le> k" using \<open>length p' \<le> Suc k\<close> Cons by auto
moreover have "path M (target q (prev@[t])) p''"
using \<open>path M (target q prev) p'\<close> unfolding Cons
by auto
ultimately have "p \<in> paths_up_to_length' (prev @ [t]) (t_target t) (h M) (FSM.inputs M) k"
using Suc.IH[OF \<open>path M q (prev@[t])\<close>]
unfolding \<open>(target q (prev @ [t])) = t_target t\<close> \<open>p = prev@p'\<close> Cons by simp
then have "prev@t#p'' \<in> paths_up_to_length' (prev @ [t]) (t_target t) (h M) (FSM.inputs M) k"
unfolding \<open>p = prev@p'\<close> Cons by auto
have "t \<in> (\<lambda>(y, q'). (t_source t, t_input t, y, q')) `
{(y, q'). (t_source t, t_input t, y, q') \<in> FSM.transitions M}"
using \<open>t \<in> transitions M\<close>
by (metis (no_types, lifting) case_prodI mem_Collect_eq pair_imageI surjective_pairing)
then have "t \<in> transitions_from' (h M) (inputs M) (target q prev)"
unfolding transitions_from'.simps
using fsm_transition_input[OF \<open>t \<in> transitions M\<close>]
unfolding \<open>t_source t = (target q prev)\<close>[symmetric] h_simps
by blast
then show ?thesis
using \<open>prev @ t # p'' \<in> paths_up_to_length' (prev@[t]) (t_target t) (h M) (FSM.inputs M) k\<close>
unfolding \<open>p = prev@p'\<close> Cons paths_up_to_length'.simps Let_def by blast
qed
then show "p \<in> paths_up_to_length' prev (target q prev) (h M) (inputs M) (Suc k)"
unfolding \<open>p = prev@p'\<close> by assumption
qed
ultimately show ?case by blast
qed
lemma paths_up_to_length_set :
assumes "q \<in> states M"
shows "paths_up_to_length M q k = {p . path M q p \<and> length p \<le> k}"
unfolding paths_up_to_length.simps
using paths_up_to_length'_set[OF assms nil[OF assms], of k] by auto
subsubsection \<open>Calculating Acyclic Paths\<close>
fun acyclic_paths_up_to_length' :: "('a,'b,'c) path \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> (('b\<times>'c\<times>'a) set)) \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set"
where
"acyclic_paths_up_to_length' prev q hF visitedStates 0 = {prev}" |
"acyclic_paths_up_to_length' prev q hF visitedStates (Suc k) =
(let tF = Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF q)
in (insert prev (\<Union> (image (\<lambda> (x,y,q') . acyclic_paths_up_to_length' (prev@[(q,x,y,q')]) q' hF (insert q' visitedStates) k) tF))))"
fun p_source :: "'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> 'a"
where "p_source q p = hd (visited_states q p)"
lemma acyclic_paths_up_to_length'_prev :
"p' \<in> acyclic_paths_up_to_length' (prev@prev') q hF visitedStates k \<Longrightarrow> \<exists> p'' . p' = prev@p''"
by (induction k arbitrary: p' q visitedStates prev'; auto)
lemma acyclic_paths_up_to_length'_set :
assumes "path M (p_source q prev) prev"
and "\<And> q' . hF q' = {(x,y,q'') | x y q'' . (q',x,y,q'') \<in> transitions M}"
and "distinct (visited_states (p_source q prev) prev)"
and "visitedStates = set (visited_states (p_source q prev) prev)"
shows "acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates k
= { prev@p | p . path M (p_source q prev) (prev@p)
\<and> length p \<le> k
\<and> distinct (visited_states (p_source q prev) (prev@p)) }"
using assms proof (induction k arbitrary: q hF prev visitedStates)
case 0
then show ?case by auto
next
case (Suc k)
let ?tgt = "(target (p_source q prev) prev)"
have "\<And> p . (prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)
\<Longrightarrow> path M (p_source q prev) (prev@p)
\<and> length p \<le> Suc k
\<and> distinct (visited_states (p_source q prev) (prev@p))"
proof -
fix p assume "(prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
then consider (a) "(prev@p) = prev" |
(b) "(prev@p) \<in> (\<Union> (image (\<lambda> (x,y,q') . acyclic_paths_up_to_length' (prev@[(?tgt,x,y,q')]) q' hF (insert q' visitedStates) k)
(Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (target (p_source q prev) prev)))))"
by auto
then show "path M (p_source q prev) (prev@p) \<and> length p \<le> Suc k \<and> distinct (visited_states (p_source q prev) (prev@p))"
proof (cases)
case a
then show ?thesis using Suc.prems(1,3) by auto
next
case b
then obtain x y q' where *: "(x,y,q') \<in> Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF ?tgt)"
and **:"(prev@p) \<in> acyclic_paths_up_to_length' (prev@[(?tgt,x,y,q')]) q' hF (insert q' visitedStates) k"
by auto
let ?t = "(?tgt,x,y,q')"
from * have "?t \<in> transitions M" and "q' \<notin> visitedStates"
using Suc.prems(2)[of ?tgt] by simp+
moreover have "t_source ?t = target (p_source q prev) prev"
by simp
moreover have "p_source (p_source q prev) (prev@[?t]) = p_source q prev"
by auto
ultimately have p1: "path M (p_source (p_source q prev) (prev@[?t])) (prev@[?t])"
using Suc.prems(1)
by (simp add: path_append_transition)
have "q' \<notin> set (visited_states (p_source q prev) prev)"
using \<open>q' \<notin> visitedStates\<close> Suc.prems(4) by auto
then have p2: "distinct (visited_states (p_source (p_source q prev) (prev@[?t])) (prev@[?t]))"
using Suc.prems(3) by auto
have p3: "(insert q' visitedStates)
= set (visited_states (p_source (p_source q prev) (prev@[?t])) (prev@[?t]))"
using Suc.prems(4) by auto
have ***: "(target (p_source (p_source q prev) (prev @ [(target (p_source q prev) prev, x, y, q')]))
(prev @ [(target (p_source q prev) prev, x, y, q')]))
= q'"
by auto
show ?thesis
using Suc.IH[OF p1 Suc.prems(2) p2 p3] **
unfolding ***
unfolding \<open>p_source (p_source q prev) (prev@[?t]) = p_source q prev\<close>
proof -
assume "acyclic_paths_up_to_length' (prev @ [(target (p_source q prev) prev, x, y, q')]) q' hF (insert q' visitedStates) k
= {(prev @ [(target (p_source q prev) prev, x, y, q')]) @ p |p.
path M (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ p)
\<and> length p \<le> k
\<and> distinct (visited_states (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ p))}"
then have "\<exists>ps. prev @ p = (prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps
\<and> path M (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps)
\<and> length ps \<le> k
\<and> distinct (visited_states (p_source q prev) ((prev @ [(target (p_source q prev) prev, x, y, q')]) @ ps))"
using \<open>prev @ p \<in> acyclic_paths_up_to_length' (prev @ [(target (p_source q prev) prev, x, y, q')]) q' hF (insert q' visitedStates) k\<close>
by blast
then show ?thesis
by (metis (no_types) Suc_le_mono append.assoc append.right_neutral append_Cons length_Cons same_append_eq)
qed
qed
qed
moreover have "\<And> p' . p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)
\<Longrightarrow> \<exists> p'' . p' = prev@p''"
using acyclic_paths_up_to_length'_prev[of _ prev "[]" "target (p_source q prev) prev" hF visitedStates "Suc k"]
by force
ultimately have fwd: "\<And> p' . p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)
\<Longrightarrow> p' \<in> { prev@p | p . path M (p_source q prev) (prev@p)
\<and> length p \<le> Suc k
\<and> distinct (visited_states (p_source q prev) (prev@p)) }"
by blast
have "\<And> p . path M (p_source q prev) (prev@p)
\<Longrightarrow> length p \<le> Suc k
\<Longrightarrow> distinct (visited_states (p_source q prev) (prev@p))
\<Longrightarrow> (prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
proof -
fix p assume "path M (p_source q prev) (prev@p)"
and "length p \<le> Suc k"
and "distinct (visited_states (p_source q prev) (prev@p))"
show "(prev@p) \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
proof (cases p)
case Nil
then show ?thesis by auto
next
case (Cons t p')
then have "t_source t = target (p_source q (prev)) (prev)" and "t \<in> transitions M"
using \<open>path M (p_source q prev) (prev@p)\<close> by auto
have "path M (p_source q (prev@[t])) ((prev@[t])@p')"
and "path M (p_source q (prev@[t])) ((prev@[t]))"
using Cons \<open>path M (p_source q prev) (prev@p)\<close> by auto
have "length p' \<le> k"
using Cons \<open>length p \<le> Suc k\<close> by auto
have "distinct (visited_states (p_source q (prev@[t])) ((prev@[t])@p'))"
and "distinct (visited_states (p_source q (prev@[t])) ((prev@[t])))"
using Cons \<open>distinct (visited_states (p_source q prev) (prev@p))\<close> by auto
then have "t_target t \<notin> visitedStates"
using Suc.prems(4) by auto
let ?vN = "insert (t_target t) visitedStates"
have "?vN = set (visited_states (p_source q (prev @ [t])) (prev @ [t]))"
using Suc.prems(4) by auto
have "prev@p = prev@([t]@p')"
using Cons by auto
have "(prev@[t])@p' \<in> acyclic_paths_up_to_length' (prev @ [t]) (target (p_source q (prev @ [t])) (prev @ [t])) hF (insert (t_target t) visitedStates) k"
using Suc.IH[of q "prev@[t]", OF \<open>path M (p_source q (prev@[t])) ((prev@[t]))\<close> Suc.prems(2)
\<open>distinct (visited_states (p_source q (prev@[t])) ((prev@[t])))\<close>
\<open>?vN = set (visited_states (p_source q (prev @ [t])) (prev @ [t]))\<close> ]
using \<open>path M (p_source q (prev@[t])) ((prev@[t])@p')\<close>
\<open>length p' \<le> k\<close>
\<open>distinct (visited_states (p_source q (prev@[t])) ((prev@[t])@p'))\<close>
by force
then have "(prev@[t])@p' \<in> acyclic_paths_up_to_length' (prev@[t]) (t_target t) hF ?vN k"
by auto
moreover have "(t_input t,t_output t, t_target t) \<in> Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (t_source t))"
using Suc.prems(2)[of "t_source t"] \<open>t \<in> transitions M\<close> \<open>t_target t \<notin> visitedStates\<close>
proof -
have "\<exists>b c a. snd t = (b, c, a) \<and> (t_source t, b, c, a) \<in> FSM.transitions M"
by (metis (no_types) \<open>t \<in> FSM.transitions M\<close> prod.collapse)
then show ?thesis
using \<open>hF (t_source t) = {(x, y, q'') |x y q''. (t_source t, x, y, q'') \<in> FSM.transitions M}\<close>
\<open>t_target t \<notin> visitedStates\<close>
by fastforce
qed
ultimately have "\<exists> (x,y,q') \<in> (Set.filter (\<lambda> (x,y,q') . q' \<notin> visitedStates) (hF (target (p_source q prev) prev))) .
(prev@[t])@p' \<in> (acyclic_paths_up_to_length' (prev@[((target (p_source q prev) prev),x,y,q')]) q' hF (insert q' visitedStates) k)"
unfolding \<open>t_source t = target (p_source q (prev)) (prev)\<close>
by (metis (no_types, lifting) \<open>t_source t = target (p_source q prev) prev\<close> case_prodI prod.collapse)
then show ?thesis unfolding \<open>prev@p = prev@[t]@p'\<close>
unfolding acyclic_paths_up_to_length'.simps Let_def by force
qed
qed
then have rev: "\<And> p' . p' \<in> {prev@p | p . path M (p_source q prev) (prev@p)
\<and> length p \<le> Suc k
\<and> distinct (visited_states (p_source q prev) (prev@p))}
\<Longrightarrow> p' \<in> acyclic_paths_up_to_length' prev (target (p_source q prev) prev) hF visitedStates (Suc k)"
by blast
show ?case
using fwd rev by blast
qed
fun acyclic_paths_up_to_length :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> ('a,'b,'c) path set" where
"acyclic_paths_up_to_length M q k = {p. path M q p \<and> length p \<le> k \<and> distinct (visited_states q p)}"
lemma acyclic_paths_up_to_length_code[code] :
"acyclic_paths_up_to_length M q k = (if q \<in> states M
then acyclic_paths_up_to_length' [] q (m2f (set_as_map (transitions M))) {q} k
else {})"
proof (cases "q \<in> states M")
case False
then have "acyclic_paths_up_to_length M q k = {}"
using path_begin_state by fastforce
then show ?thesis using False by auto
next
case True
then have *: "path M (p_source q []) []" by auto
have **: "(\<And>q'. (m2f (set_as_map (transitions M))) q' = {(x, y, q'') |x y q''. (q', x, y, q'') \<in> FSM.transitions M})"
unfolding set_as_map_def by auto
have ***: "distinct (visited_states (p_source q []) [])"
by auto
have ****: "{q} = set (visited_states (p_source q []) [])"
by auto
show ?thesis
using acyclic_paths_up_to_length'_set[OF * ** *** ****, of k ]
using True by auto
qed
lemma path_map_target : "target (f4 q) (map (\<lambda> t . (f1 (t_source t), f2 (t_input t), f3 (t_output t), f4 (t_target t))) p) = f4 (target q p)"
by (induction p; auto)
lemma path_length_sum :
assumes "path M q p"
shows "length p = (\<Sum> q \<in> states M . length (filter (\<lambda>t. t_target t = q) p))"
using assms
proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
then have "length xs = (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))"
by auto
have *: "t_target x \<in> states M"
using \<open>path M q (xs @ [x])\<close> by auto
then have **: "length (filter (\<lambda>t. t_target t = t_target x) (xs @ [x]))
= Suc (length (filter (\<lambda>t. t_target t = t_target x) xs))"
by auto
have "\<And> q . q \<in> states M \<Longrightarrow> q \<noteq> t_target x
\<Longrightarrow> length (filter (\<lambda>t. t_target t = q) (xs @ [x])) = length (filter (\<lambda>t. t_target t = q) xs)"
by simp
then have ***: "(\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) (xs @ [x])))
= (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) xs))"
using fsm_states_finite[of M]
by (metis (no_types, lifting) DiffE insertCI sum.cong)
have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (xs @ [x])))
= (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) (xs @ [x])))
+ (length (filter (\<lambda>t. t_target t = t_target x) (xs @ [x])))"
using * fsm_states_finite[of M]
proof -
have "(\<Sum>a\<in>insert (t_target x) (states M). length (filter (\<lambda>p. t_target p = a) (xs @ [x])))
= (\<Sum>a\<in>states M. length (filter (\<lambda>p. t_target p = a) (xs @ [x])))"
by (simp add: \<open>t_target x \<in> states M\<close> insert_absorb)
then show ?thesis
by (simp add: \<open>finite (states M)\<close> sum.insert_remove)
qed
moreover have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))
= (\<Sum>q\<in>states M - {t_target x}. length (filter (\<lambda>t. t_target t = q) xs))
+ (length (filter (\<lambda>t. t_target t = t_target x) xs))"
using * fsm_states_finite[of M]
proof -
have "(\<Sum>a\<in>insert (t_target x) (states M). length (filter (\<lambda>p. t_target p = a) xs))
= (\<Sum>a\<in>states M. length (filter (\<lambda>p. t_target p = a) xs))"
by (simp add: \<open>t_target x \<in> states M\<close> insert_absorb)
then show ?thesis
by (simp add: \<open>finite (states M)\<close> sum.insert_remove)
qed
ultimately have "(\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) (xs @ [x])))
= Suc (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))"
using ** *** by auto
then show ?case
by (simp add: \<open>length xs = (\<Sum>q\<in>states M. length (filter (\<lambda>t. t_target t = q) xs))\<close>)
qed
lemma path_loop_cut :
assumes "path M q p"
and "t_target (p ! i) = t_target (p ! j)"
and "i < j"
and "j < length p"
shows "path M q ((take (Suc i) p) @ (drop (Suc j) p))"
and "target q ((take (Suc i) p) @ (drop (Suc j) p)) = target q p"
and "length ((take (Suc i) p) @ (drop (Suc j) p)) < length p"
and "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p))"
and "target (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p)) = (target q (take (Suc i) p))"
proof -
have "p = (take (Suc j) p) @ (drop (Suc j) p)"
by auto
also have "\<dots> = ((take (Suc i) (take (Suc j) p)) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p)"
by (metis append_take_drop_id)
also have "\<dots> = ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p)"
using \<open>i < j\<close> by simp
finally have "p = (take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p)"
by simp
then have "path M q ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p))"
and "path M q (((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p))"
using \<open>path M q p\<close> by auto
have "path M q (take (Suc i) p)" and "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p) @ drop (Suc j) p)"
using path_append_elim[OF \<open>path M q ((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p)) @ (drop (Suc j) p))\<close>]
by blast+
have *: "(take (Suc i) p @ drop (Suc i) (take (Suc j) p)) = (take (Suc j) p)"
using \<open>i < j\<close> append_take_drop_id
by (metis \<open>(take (Suc i) (take (Suc j) p) @ drop (Suc i) (take (Suc j) p)) @ drop (Suc j) p = (take (Suc i) p @ drop (Suc i) (take (Suc j) p)) @ drop (Suc j) p\<close> append_same_eq)
have "path M q (take (Suc j) p)" and "path M (target q (take (Suc j) p)) (drop (Suc j) p)"
using path_append_elim[OF \<open>path M q (((take (Suc i) p) @ (drop (Suc i) (take (Suc j) p))) @ (drop (Suc j) p))\<close>]
unfolding *
by blast+
have **: "(target q (take (Suc j) p)) = (target q (take (Suc i) p))"
proof -
have "p ! i = last (take (Suc i) p)"
by (metis Suc_lessD assms(3) assms(4) less_trans_Suc take_last_index)
moreover have "p ! j = last (take (Suc j) p)"
by (simp add: assms(4) take_last_index)
ultimately show ?thesis
using assms(2) unfolding * target.simps visited_states.simps
by (simp add: last_map)
qed
show "path M q ((take (Suc i) p) @ (drop (Suc j) p))"
using \<open>path M q (take (Suc i) p)\<close> \<open>path M (target q (take (Suc j) p)) (drop (Suc j) p)\<close> unfolding ** by auto
show "target q ((take (Suc i) p) @ (drop (Suc j) p)) = target q p"
by (metis "**" append_take_drop_id path_append_target)
show "length ((take (Suc i) p) @ (drop (Suc j) p)) < length p"
proof -
have ***: "length p = length ((take (Suc j) p) @ (drop (Suc j) p))"
by auto
have "length (take (Suc i) p) < length (take (Suc j) p)"
using assms(3,4)
by (simp add: min_absorb2)
have scheme: "\<And> a b c . length a < length b \<Longrightarrow> length (a@c) < length (b@c)"
by auto
show ?thesis
unfolding *** using scheme[OF \<open>length (take (Suc i) p) < length (take (Suc j) p)\<close>, of "(drop (Suc j) p)"]
by assumption
qed
show "path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p))"
using \<open>path M (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p) @ drop (Suc j) p)\<close> by blast
show "target (target q (take (Suc i) p)) (drop (Suc i) (take (Suc j) p)) = (target q (take (Suc i) p))"
by (metis "*" "**" path_append_target)
qed
lemma path_prefix_take :
assumes "path M q p"
shows "path M q (take i p)"
proof -
have "p = (take i p)@(drop i p)" by auto
then have "path M q ((take i p)@(drop i p))" using assms by auto
then show ?thesis
by blast
qed
subsection \<open>Acyclic Paths\<close>
lemma cyclic_path_loop :
assumes "path M q p"
and "\<not> distinct (visited_states q p)"
shows "\<exists> p1 p2 p3 . p = p1@p2@p3 \<and> p2 \<noteq> [] \<and> target q p1 = target q (p1@p2)"
using assms proof (induction p arbitrary: q)
case (nil M q)
then show ?case by auto
next
case (cons t M ts)
then show ?case
proof (cases "distinct (visited_states (t_target t) ts)")
case True
then have "q \<in> set (visited_states (t_target t) ts)"
using cons.prems by simp
then obtain p2 p3 where "ts = p2@p3" and "target (t_target t) p2 = q"
using visited_states_prefix[of q "t_target t" ts] by blast
then have "(t#ts) = []@(t#p2)@p3 \<and> (t#p2) \<noteq> [] \<and> target q [] = target q ([]@(t#p2))"
using cons.hyps by auto
then show ?thesis by blast
next
case False
then obtain p1 p2 p3 where "ts = p1@p2@p3" and "p2 \<noteq> []"
and "target (t_target t) p1 = target (t_target t) (p1@p2)"
using cons.IH by blast
then have "t#ts = (t#p1)@p2@p3 \<and> p2 \<noteq> [] \<and> target q (t#p1) = target q ((t#p1)@p2)"
by simp
then show ?thesis by blast
qed
qed
lemma cyclic_path_pumping :
assumes "path M (initial M) p"
and "\<not> distinct (visited_states (initial M) p)"
shows "\<exists> p . path M (initial M) p \<and> length p \<ge> n"
proof -
from assms obtain p1 p2 p3 where "p = p1 @ p2 @ p3" and "p2 \<noteq> []"
and "target (initial M) p1 = target (initial M) (p1 @ p2)"
using cyclic_path_loop[of M "initial M" p] by blast
then have "path M (target (initial M) p1) p3"
using path_suffix[of M "initial M" "p1@p2" p3] \<open>path M (initial M) p\<close> by auto
have "path M (initial M) p1"
using path_prefix[of M "initial M" p1 "p2@p3"] \<open>path M (initial M) p\<close> \<open>p = p1 @ p2 @ p3\<close>
by auto
have "path M (initial M) ((p1@p2)@p3)"
using \<open>path M (initial M) p\<close> \<open>p = p1 @ p2 @ p3\<close>
by auto
have "path M (target (initial M) p1) p2"
using path_suffix[of M "initial M" p1 p2, OF path_prefix[of M "initial M" "p1@p2" p3, OF \<open>path M (initial M) ((p1@p2)@p3)\<close>]]
by assumption
have "target (target (initial M) p1) p2 = (target (initial M) p1)"
using path_append_target \<open>target (initial M) p1 = target (initial M) (p1 @ p2)\<close>
by auto
have "path M (initial M) (p1 @ (concat (replicate n p2)) @ p3)"
proof (induction n)
case 0
then show ?case
using path_append[OF \<open>path M (initial M) p1\<close> \<open>path M (target (initial M) p1) p3\<close>]
by auto
next
case (Suc n)
then show ?case
using \<open>path M (target (initial M) p1) p2\<close> \<open>target (target (initial M) p1) p2 = target (initial M) p1\<close>
by auto
qed
moreover have "length (p1 @ (concat (replicate n p2)) @ p3) \<ge> n"
proof -
have "length (concat (replicate n p2)) = n * (length p2)"
using concat_replicate_length by metis
moreover have "length p2 > 0"
using \<open>p2 \<noteq> []\<close> by auto
ultimately have "length (concat (replicate n p2)) \<ge> n"
by (simp add: Suc_leI)
then show ?thesis by auto
qed
ultimately show "\<exists> p . path M (initial M) p \<and> length p \<ge> n" by blast
qed
lemma cyclic_path_shortening :
assumes "path M q p"
and "\<not> distinct (visited_states q p)"
shows "\<exists> p' . path M q p' \<and> target q p' = target q p \<and> length p' < length p"
proof -
obtain p1 p2 p3 where *: "p = p1@p2@p3 \<and> p2 \<noteq> [] \<and> target q p1 = target q (p1@p2)"
using cyclic_path_loop[OF assms] by blast
then have "path M q (p1@p3)"
using assms(1) by force
moreover have "target q (p1@p3) = target q p"
by (metis (full_types) * path_append_target)
moreover have "length (p1@p3) < length p"
using * by auto
ultimately show ?thesis by blast
qed
lemma acyclic_path_from_cyclic_path :
assumes "path M q p"
and "\<not> distinct (visited_states q p)"
obtains p' where "path M q p'" and "target q p = target q p'" and "distinct (visited_states q p')"
proof -
let ?paths = "{p' . (path M q p' \<and> target q p' = target q p \<and> length p' \<le> length p)}"
let ?minPath = "arg_min length (\<lambda> io . io \<in> ?paths)"
have "?paths \<noteq> empty"
using assms(1) by auto
moreover have "finite ?paths"
using paths_finite[of M q "length p"]
by (metis (no_types, lifting) Collect_mono rev_finite_subset)
ultimately have minPath_def : "?minPath \<in> ?paths \<and> (\<forall> p' \<in> ?paths . length ?minPath \<le> length p')"
by (meson arg_min_nat_lemma equals0I)
then have "path M q ?minPath" and "target q ?minPath = target q p"
by auto
moreover have "distinct (visited_states q ?minPath)"
proof (rule ccontr)
assume "\<not> distinct (visited_states q ?minPath)"
have "\<exists> p' . path M q p' \<and> target q p' = target q p \<and> length p' < length ?minPath"
using cyclic_path_shortening[OF \<open>path M q ?minPath\<close> \<open>\<not> distinct (visited_states q ?minPath)\<close>] minPath_def
\<open>target q ?minPath= target q p\<close> by auto
then show "False"
using minPath_def using arg_min_nat_le dual_order.strict_trans1 by auto
qed
ultimately show ?thesis
by (simp add: that)
qed
lemma acyclic_path_length_limit :
assumes "path M q p"
and "distinct (visited_states q p)"
shows "length p < size M"
proof (rule ccontr)
assume *: "\<not> length p < size M"
then have "length p \<ge> card (states M)"
using size_def by auto
then have "length (visited_states q p) > card (states M)"
by auto
moreover have "set (visited_states q p) \<subseteq> states M"
by (metis assms(1) path_prefix path_target_is_state subsetI visited_states_prefix)
ultimately have "\<not> distinct (visited_states q p)"
using distinct_card[OF assms(2)]
using List.finite_set[of "visited_states q p"]
by (metis card_mono fsm_states_finite leD)
then show "False" using assms(2) by blast
qed
subsection \<open>Reachable States\<close>
definition reachable :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where
"reachable M q = (\<exists> p . path M (initial M) p \<and> target (initial M) p = q)"
definition reachable_states :: "('a,'b,'c) fsm \<Rightarrow> 'a set" where
"reachable_states M = {target (initial M) p | p . path M (initial M) p }"
abbreviation "size_r M \<equiv> card (reachable_states M)"
lemma acyclic_paths_set :
"acyclic_paths_up_to_length M q (size M - 1) = {p . path M q p \<and> distinct (visited_states q p)}"
unfolding acyclic_paths_up_to_length.simps using acyclic_path_length_limit[of M q]
by (metis (no_types, lifting) One_nat_def Suc_pred cyclic_path_shortening leD list.size(3)
not_less_eq_eq not_less_zero path.intros(1) path_begin_state)
(* inefficient calculation, as a state may be target of a large number of acyclic paths *)
lemma reachable_states_code[code] :
"reachable_states M = image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
proof -
have "\<And> q' . q' \<in> reachable_states M
\<Longrightarrow> q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
proof -
fix q' assume "q' \<in> reachable_states M"
then obtain p where "path M (initial M) p" and "target (initial M) p = q'"
unfolding reachable_states_def by blast
obtain p' where "path M (initial M) p'" and "target (initial M) p' = q'"
and "distinct (visited_states (initial M) p')"
proof (cases "distinct (visited_states (initial M) p)")
case True
then show ?thesis using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q'\<close> that by auto
next
case False
then show ?thesis
using acyclic_path_from_cyclic_path[OF \<open>path M (initial M) p\<close>]
unfolding \<open>target (initial M) p = q'\<close> using that by blast
qed
then show "q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))"
unfolding acyclic_paths_set by force
qed
moreover have "\<And> q' . q' \<in> image (target (initial M)) (acyclic_paths_up_to_length M (initial M) (size M - 1))
\<Longrightarrow> q' \<in> reachable_states M"
unfolding reachable_states_def acyclic_paths_set by blast
ultimately show ?thesis by blast
qed
lemma reachable_states_intro[intro!] :
assumes "path M (initial M) p"
shows "target (initial M) p \<in> reachable_states M"
using assms unfolding reachable_states_def by auto
lemma reachable_states_initial :
"initial M \<in> reachable_states M"
unfolding reachable_states_def by auto
lemma reachable_states_next :
assumes "q \<in> reachable_states M" and "t \<in> transitions M" and "t_source t = q"
shows "t_target t \<in> reachable_states M"
proof -
from \<open>q \<in> reachable_states M\<close> obtain p where * :"path M (initial M) p"
and **:"target (initial M) p = q"
unfolding reachable_states_def by auto
then have "path M (initial M) (p@[t])" using assms(2,3) path_append_transition by metis
moreover have "target (initial M) (p@[t]) = t_target t" by auto
ultimately show ?thesis
unfolding reachable_states_def
by (metis (mono_tags, lifting) mem_Collect_eq)
qed
lemma reachable_states_path :
assumes "q \<in> reachable_states M"
and "path M q p"
and "t \<in> set p"
shows "t_source t \<in> reachable_states M"
using assms unfolding reachable_states_def proof (induction p arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons t' p')
then show ?case proof (cases "t = t'")
case True
then show ?thesis using Cons.prems(1,2) by force
next
case False then show ?thesis using Cons
by (metis (mono_tags, lifting) path_cons_elim reachable_states_def reachable_states_next
set_ConsD)
qed
qed
lemma reachable_states_initial_or_target :
assumes "q \<in> reachable_states M"
shows "q = initial M \<or> (\<exists> t \<in> transitions M . t_source t \<in> reachable_states M \<and> t_target t = q)"
proof -
obtain p where "path M (initial M) p" and "target (initial M) p = q"
using assms unfolding reachable_states_def by auto
show ?thesis proof (cases p rule: rev_cases)
case Nil
then show ?thesis using \<open>path M (initial M) p\<close> \<open>target (initial M) p = q\<close> by auto
next
case (snoc p' t)
have "t \<in> transitions M"
using \<open>path M (initial M) p\<close> unfolding snoc by auto
moreover have "t_target t = q"
using \<open>target (initial M) p = q\<close> unfolding snoc by auto
moreover have "t_source t \<in> reachable_states M"
using \<open>path M (initial M) p\<close> unfolding snoc
by (metis append_is_Nil_conv last_in_set last_snoc not_Cons_self2 reachable_states_initial reachable_states_path)
ultimately show ?thesis
by blast
qed
qed
lemma reachable_state_is_state :
"q \<in> reachable_states M \<Longrightarrow> q \<in> states M"
unfolding reachable_states_def using path_target_is_state by fastforce
lemma reachable_states_finite : "finite (reachable_states M)"
using fsm_states_finite[of M] reachable_state_is_state[of _ M]
by (meson finite_subset subset_eq)
subsection \<open>Language\<close>
abbreviation "p_io (p :: ('state,'input,'output) path) \<equiv> map (\<lambda> t . (t_input t, t_output t)) p"
fun language_state_for_input :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input list \<Rightarrow> ('input \<times> 'output) list set" where
"language_state_for_input M q xs = {p_io p | p . path M q p \<and> map fst (p_io p) = xs}"
fun LS\<^sub>i\<^sub>n :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> 'input list set \<Rightarrow> ('input \<times> 'output) list set" where
"LS\<^sub>i\<^sub>n M q xss = {p_io p | p . path M q p \<and> map fst (p_io p) \<in> xss}"
abbreviation(input) "L\<^sub>i\<^sub>n M \<equiv> LS\<^sub>i\<^sub>n M (initial M)"
lemma language_state_for_input_inputs :
assumes "io \<in> language_state_for_input M q xs"
shows "map fst io = xs"
using assms by auto
lemma language_state_for_inputs_inputs :
assumes "io \<in> LS\<^sub>i\<^sub>n M q xss"
shows "map fst io \<in> xss" using assms by auto
fun LS :: "('state,'input,'output) fsm \<Rightarrow> 'state \<Rightarrow> ('input \<times> 'output) list set" where
"LS M q = { p_io p | p . path M q p }"
abbreviation "L M \<equiv> LS M (initial M)"
lemma language_state_containment :
assumes "path M q p"
and "p_io p = io"
shows "io \<in> LS M q"
using assms by auto
lemma language_prefix :
assumes "io1@io2 \<in> LS M q"
shows "io1 \<in> LS M q"
proof -
obtain p where "path M q p" and "p_io p = io1@io2"
using assms by auto
let ?tp = "take (length io1) p"
have "path M q ?tp"
by (metis (no_types) \<open>path M q p\<close> append_take_drop_id path_prefix)
moreover have "p_io ?tp = io1"
using \<open>p_io p = io1@io2\<close> by (metis append_eq_conv_conj take_map)
ultimately show ?thesis
by force
qed
lemma language_contains_empty_sequence : "[] \<in> L M"
by auto
lemma language_state_split :
assumes "io1 @ io2 \<in> LS M q1"
obtains p1 p2 where "path M q1 p1"
and "path M (target q1 p1) p2"
and "p_io p1 = io1"
and "p_io p2 = io2"
proof -
obtain p12 where "path M q1 p12" and "p_io p12 = io1 @ io2"
using assms unfolding LS.simps by auto
let ?p1 = "take (length io1) p12"
let ?p2 = "drop (length io1) p12"
have "p12 = ?p1 @ ?p2"
by auto
then have "path M q1 (?p1 @ ?p2)"
using \<open>path M q1 p12\<close> by auto
have "path M q1 ?p1" and "path M (target q1 ?p1) ?p2"
using path_append_elim[OF \<open>path M q1 (?p1 @ ?p2)\<close>] by blast+
moreover have "p_io ?p1 = io1"
using \<open>p12 = ?p1 @ ?p2\<close> \<open>p_io p12 = io1 @ io2\<close>
by (metis append_eq_conv_conj take_map)
moreover have "p_io ?p2 = io2"
using \<open>p12 = ?p1 @ ?p2\<close> \<open>p_io p12 = io1 @ io2\<close>
by (metis (no_types) \<open>p_io p12 = io1 @ io2\<close> append_eq_conv_conj drop_map)
ultimately show ?thesis using that by blast
qed
lemma language_initial_path_append_transition :
assumes "ios @ [io] \<in> L M"
obtains p t where "path M (initial M) (p@[t])" and "p_io (p@[t]) = ios @ [io]"
proof -
obtain pt where "path M (initial M) pt" and "p_io pt = ios @ [io]"
using assms unfolding LS.simps by auto
then have "pt \<noteq> []"
by auto
then obtain p t where "pt = p @ [t]"
using rev_exhaust by blast
then have "path M (initial M) (p@[t])" and "p_io (p@[t]) = ios @ [io]"
using \<open>path M (initial M) pt\<close> \<open>p_io pt = ios @ [io]\<close> by auto
then show ?thesis using that by simp
qed
lemma language_path_append_transition :
assumes "ios @ [io] \<in> LS M q"
obtains p t where "path M q (p@[t])" and "p_io (p@[t]) = ios @ [io]"
proof -
obtain pt where "path M q pt" and "p_io pt = ios @ [io]"
using assms unfolding LS.simps by auto
then have "pt \<noteq> []"
by auto
then obtain p t where "pt = p @ [t]"
using rev_exhaust by blast
then have "path M q (p@[t])" and "p_io (p@[t]) = ios @ [io]"
using \<open>path M q pt\<close> \<open>p_io pt = ios @ [io]\<close> by auto
then show ?thesis using that by simp
qed
lemma language_split :
assumes "io1@io2 \<in> L M"
obtains p1 p2 where "path M (initial M) (p1@p2)" and "p_io p1 = io1" and "p_io p2 = io2"
proof -
from assms obtain p where "path M (initial M) p" and "p_io p = io1 @ io2"
by auto
let ?p1 = "take (length io1) p"
let ?p2 = "drop (length io1) p"
have "path M (initial M) (?p1@?p2)"
using \<open>path M (initial M) p\<close> by simp
moreover have "p_io ?p1 = io1"
using \<open>p_io p = io1 @ io2\<close>
by (metis append_eq_conv_conj take_map)
moreover have "p_io ?p2 = io2"
using \<open>p_io p = io1 @ io2\<close>
by (metis append_eq_conv_conj drop_map)
ultimately show ?thesis using that by blast
qed
lemma language_io :
assumes "io \<in> LS M q"
and "(x,y) \<in> set io"
shows "x \<in> (inputs M)"
and "y \<in> outputs M"
proof -
obtain p where "path M q p" and "p_io p = io"
using \<open>io \<in> LS M q\<close> by auto
then obtain t where "t \<in> set p" and "t_input t = x" and "t_output t = y"
using \<open>(x,y) \<in> set io\<close> by auto
have "t \<in> transitions M"
using \<open>path M q p\<close> \<open>t \<in> set p\<close>
by (induction p; auto)
show "x \<in> (inputs M)"
using \<open>t \<in> transitions M\<close> \<open>t_input t = x\<close> by auto
show "y \<in> outputs M"
using \<open>t \<in> transitions M\<close> \<open>t_output t = y\<close> by auto
qed
lemma path_io_split :
assumes "path M q p"
and "p_io p = io1@io2"
shows "path M q (take (length io1) p)"
and "p_io (take (length io1) p) = io1"
and "path M (target q (take (length io1) p)) (drop (length io1) p)"
and "p_io (drop (length io1) p) = io2"
proof -
have "length io1 \<le> length p"
using \<open>p_io p = io1@io2\<close>
unfolding length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric]
by auto
have "p = (take (length io1) p)@(drop (length io1) p)"
by simp
then have *: "path M q ((take (length io1) p)@(drop (length io1) p))"
using \<open>path M q p\<close> by auto
show "path M q (take (length io1) p)"
and "path M (target q (take (length io1) p)) (drop (length io1) p)"
using path_append_elim[OF *] by blast+
show "p_io (take (length io1) p) = io1"
using \<open>p = (take (length io1) p)@(drop (length io1) p)\<close> \<open>p_io p = io1@io2\<close>
by (metis append_eq_conv_conj take_map)
show "p_io (drop (length io1) p) = io2"
using \<open>p = (take (length io1) p)@(drop (length io1) p)\<close> \<open>p_io p = io1@io2\<close>
by (metis append_eq_conv_conj drop_map)
qed
lemma language_intro :
assumes "path M q p"
shows "p_io p \<in> LS M q"
using assms unfolding LS.simps by auto
lemma language_prefix_append :
assumes "io1 @ (p_io p) \<in> L M"
shows "io1 @ p_io (take i p) \<in> L M"
proof -
fix i
have "p_io p = (p_io (take i p)) @ (p_io (drop i p))"
by (metis append_take_drop_id map_append)
then have "(io1 @ (p_io (take i p))) @ (p_io (drop i p)) \<in> L M"
using \<open>io1 @ p_io p \<in> L M\<close> by auto
show "io1 @ p_io (take i p) \<in> L M"
using language_prefix[OF \<open>(io1 @ (p_io (take i p))) @ (p_io (drop i p)) \<in> L M\<close>]
by assumption
qed
lemma language_finite: "finite {io . io \<in> L M \<and> length io \<le> k}"
proof -
have "{io . io \<in> L M \<and> length io \<le> k} \<subseteq> p_io ` {p. path M (FSM.initial M) p \<and> length p \<le> k}"
by auto
then show ?thesis
using paths_finite[of M "initial M" k]
using finite_surj by auto
qed
lemma LS_prepend_transition :
assumes "t \<in> transitions M"
and "io \<in> LS M (t_target t)"
shows "(t_input t, t_output t) # io \<in> LS M (t_source t)"
proof -
obtain p where "path M (t_target t) p" and "p_io p = io"
using assms(2) by auto
then have "path M (t_source t) (t#p)" and "p_io (t#p) = (t_input t, t_output t) # io"
using assms(1) by auto
then show ?thesis
unfolding LS.simps
by (metis (mono_tags, lifting) mem_Collect_eq)
qed
lemma language_empty_IO :
assumes "inputs M = {} \<or> outputs M = {}"
shows "L M = {[]}"
proof -
consider "inputs M = {}" | "outputs M = {}" using assms by blast
then show ?thesis proof cases
case 1
show "L M = {[]}"
using language_io(1)[of _ M "initial M"] unfolding 1
by (metis (no_types, opaque_lifting) ex_in_conv is_singletonI' is_singleton_the_elem language_contains_empty_sequence set_empty2 singleton_iff surj_pair)
next
case 2
show "L M = {[]}"
using language_io(2)[of _ M "initial M"] unfolding 2
by (metis (no_types, opaque_lifting) ex_in_conv is_singletonI' is_singleton_the_elem language_contains_empty_sequence set_empty2 singleton_iff surj_pair)
qed
qed
lemma language_equivalence_from_isomorphism_helper :
assumes "bij_betw f (states M1) (states M2)"
and "f (initial M1) = initial M2"
and "\<And> q x y q' . q \<in> states M1 \<Longrightarrow> q' \<in> states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
and "q \<in> states M1"
shows "LS M1 q \<subseteq> LS M2 (f q)"
proof
fix io assume "io \<in> LS M1 q"
then obtain p where "path M1 q p" and "p_io p = io"
by auto
let ?f = "\<lambda>(q,x,y,q') . (f q,x,y,f q')"
let ?p = "map ?f p"
have "f q \<in> states M2"
using assms(1,4)
using bij_betwE by auto
have "path M2 (f q) ?p"
using \<open>path M1 q p\<close> proof (induction p rule: rev_induct)
case Nil
show ?case using \<open>f q \<in> states M2\<close> by auto
next
case (snoc a p)
then have "path M2 (f q) (map ?f p)"
by auto
have "target (f q) (map ?f p) = f (target q p)"
using \<open>f (initial M1) = initial M2\<close> assms(2)
by (induction p; auto)
then have "t_source (?f a) = target (f q) (map ?f p)"
by (metis (no_types, lifting) case_prod_beta' fst_conv path_append_transition_elim(3) snoc.prems)
have "a \<in> transitions M1"
using snoc.prems by auto
then have "?f a \<in> transitions M2"
by (metis (mono_tags, lifting) assms(3) case_prod_beta fsm_transition_source fsm_transition_target surjective_pairing)
have "map ?f (p@[a]) = (map ?f p)@[?f a]"
by auto
show ?case
unfolding \<open>map ?f (p@[a]) = (map ?f p)@[?f a]\<close>
using path_append_transition[OF \<open>path M2 (f q) (map ?f p)\<close> \<open>?f a \<in> transitions M2\<close> \<open>t_source (?f a) = target (f q) (map ?f p)\<close>]
by assumption
qed
moreover have "p_io ?p = io"
using \<open>p_io p = io\<close>
by (induction p; auto)
ultimately show "io \<in> LS M2 (f q)"
using language_state_containment by fastforce
qed
lemma language_equivalence_from_isomorphism :
assumes "bij_betw f (states M1) (states M2)"
and "f (initial M1) = initial M2"
and "\<And> q x y q' . q \<in> states M1 \<Longrightarrow> q' \<in> states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
and "q \<in> states M1"
shows "LS M1 q = LS M2 (f q)"
proof
show "LS M1 q \<subseteq> LS M2 (f q)"
using language_equivalence_from_isomorphism_helper[OF assms] .
have "f q \<in> states M2"
using assms(1,4)
using bij_betwE by auto
have "(inv_into (FSM.states M1) f (f q)) = q"
by (meson assms(1) assms(4) bij_betw_imp_inj_on inv_into_f_f)
have "bij_betw (inv_into (states M1) f) (states M2) (states M1)"
using bij_betw_inv_into[OF assms(1)] .
moreover have "(inv_into (states M1) f) (initial M2) = (initial M1)"
using assms(1,2)
by (metis bij_betw_inv_into_left fsm_initial)
moreover have "\<And> q x y q' . q \<in> states M2 \<Longrightarrow> q' \<in> states M2 \<Longrightarrow> (q,x,y,q') \<in> transitions M2 \<longleftrightarrow> ((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1"
proof
fix q x y q' assume "q \<in> states M2" and "q' \<in> states M2"
show "(q,x,y,q') \<in> transitions M2 \<Longrightarrow> ((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1"
proof -
assume a1: "(q, x, y, q') \<in> FSM.transitions M2"
have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
using bij_betwE by blast
then have f3: "inv_into (states M1) f q \<in> states M1"
using \<open>q \<in> states M2\<close> calculation(1) by blast
have "inv_into (states M1) f q' \<in> states M1"
using f2 \<open>q' \<in> states M2\<close> calculation(1) by blast
then show ?thesis
using f3 a1 \<open>q \<in> states M2\<close> \<open>q' \<in> states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
qed
show "((inv_into (states M1) f) q,x,y,(inv_into (states M1) f) q') \<in> transitions M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M2"
proof -
assume a1: "(inv_into (states M1) f q, x, y, inv_into (states M1) f q') \<in> FSM.transitions M1"
have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
by (metis (full_types) bij_betwE)
then have f3: "inv_into (states M1) f q' \<in> states M1"
using \<open>q' \<in> states M2\<close> calculation(1) by blast
have "inv_into (states M1) f q \<in> states M1"
using f2 \<open>q \<in> states M2\<close> calculation(1) by blast
then show ?thesis
using f3 a1 \<open>q \<in> states M2\<close> \<open>q' \<in> states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
qed
qed
ultimately show "LS M2 (f q) \<subseteq> LS M1 q"
using language_equivalence_from_isomorphism_helper[of "(inv_into (states M1) f)" M2 M1, OF _ _ _ \<open>f q \<in> states M2\<close>]
unfolding \<open>(inv_into (FSM.states M1) f (f q)) = q\<close>
by blast
qed
lemma language_equivalence_from_isomorphism_helper_reachable :
assumes "bij_betw f (reachable_states M1) (reachable_states M2)"
and "f (initial M1) = initial M2"
and "\<And> q x y q' . q \<in> reachable_states M1 \<Longrightarrow> q' \<in> reachable_states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
shows "L M1 \<subseteq> L M2"
proof
fix io assume "io \<in> L M1"
then obtain p where "path M1 (initial M1) p" and "p_io p = io"
by auto
let ?f = "\<lambda>(q,x,y,q') . (f q,x,y,f q')"
let ?p = "map ?f p"
have "path M2 (initial M2) ?p"
using \<open>path M1 (initial M1) p\<close> proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a p)
then have "path M2 (initial M2) (map ?f p)"
by auto
have "target (initial M2) (map ?f p) = f (target (initial M1) p)"
using \<open>f (initial M1) = initial M2\<close> assms(2)
by (induction p; auto)
then have "t_source (?f a) = target (initial M2) (map ?f p)"
by (metis (no_types, lifting) case_prod_beta' fst_conv path_append_transition_elim(3) snoc.prems)
have "t_source a \<in> reachable_states M1"
using \<open>path M1 (FSM.initial M1) (p @ [a])\<close>
by (metis path_append_transition_elim(3) path_prefix reachable_states_intro)
have "t_target a \<in> reachable_states M1"
using \<open>path M1 (FSM.initial M1) (p @ [a])\<close>
by (meson \<open>t_source a \<in> reachable_states M1\<close> path_append_transition_elim(2) reachable_states_next)
have "a \<in> transitions M1"
using snoc.prems by auto
then have "?f a \<in> transitions M2"
using assms(3)[OF \<open>t_source a \<in> reachable_states M1\<close> \<open>t_target a \<in> reachable_states M1\<close>]
by (metis (mono_tags, lifting) prod.case_eq_if prod.collapse)
have "map ?f (p@[a]) = (map ?f p)@[?f a]"
by auto
show ?case
unfolding \<open>map ?f (p@[a]) = (map ?f p)@[?f a]\<close>
using path_append_transition[OF \<open>path M2 (initial M2) (map ?f p)\<close> \<open>?f a \<in> transitions M2\<close> \<open>t_source (?f a) = target (initial M2) (map ?f p)\<close>]
by assumption
qed
moreover have "p_io ?p = io"
using \<open>p_io p = io\<close>
by (induction p; auto)
ultimately show "io \<in> L M2"
using language_state_containment by fastforce
qed
lemma language_equivalence_from_isomorphism_reachable :
assumes "bij_betw f (reachable_states M1) (reachable_states M2)"
and "f (initial M1) = initial M2"
and "\<And> q x y q' . q \<in> reachable_states M1 \<Longrightarrow> q' \<in> reachable_states M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M1 \<longleftrightarrow> (f q,x,y,f q') \<in> transitions M2"
shows "L M1 = L M2"
proof
show "L M1 \<subseteq> L M2"
using language_equivalence_from_isomorphism_helper_reachable[OF assms] .
have "bij_betw (inv_into (reachable_states M1) f) (reachable_states M2) (reachable_states M1)"
using bij_betw_inv_into[OF assms(1)] .
moreover have "(inv_into (reachable_states M1) f) (initial M2) = (initial M1)"
using assms(1,2) reachable_states_initial
by (metis bij_betw_inv_into_left)
moreover have "\<And> q x y q' . q \<in> reachable_states M2 \<Longrightarrow> q' \<in> reachable_states M2 \<Longrightarrow> (q,x,y,q') \<in> transitions M2 \<longleftrightarrow> ((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1"
proof
fix q x y q' assume "q \<in> reachable_states M2" and "q' \<in> reachable_states M2"
show "(q,x,y,q') \<in> transitions M2 \<Longrightarrow> ((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1"
proof -
assume a1: "(q, x, y, q') \<in> FSM.transitions M2"
have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
using bij_betwE by blast
then have f3: "inv_into (FSM.reachable_states M1) f q \<in> FSM.reachable_states M1"
using \<open>q \<in> FSM.reachable_states M2\<close> calculation(1) by blast
have "inv_into (FSM.reachable_states M1) f q' \<in> FSM.reachable_states M1"
using f2 \<open>q' \<in> FSM.reachable_states M2\<close> calculation(1) by blast
then show ?thesis
using f3 a1 \<open>q \<in> FSM.reachable_states M2\<close> \<open>q' \<in> FSM.reachable_states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
qed
show "((inv_into (reachable_states M1) f) q,x,y,(inv_into (reachable_states M1) f) q') \<in> transitions M1 \<Longrightarrow> (q,x,y,q') \<in> transitions M2"
proof -
assume a1: "(inv_into (FSM.reachable_states M1) f q, x, y, inv_into (FSM.reachable_states M1) f q') \<in> FSM.transitions M1"
have f2: "\<forall>f B A. \<not> bij_betw f B A \<or> (\<forall>b. (b::'b) \<notin> B \<or> (f b::'a) \<in> A)"
by (metis (full_types) bij_betwE)
then have f3: "inv_into (FSM.reachable_states M1) f q' \<in> FSM.reachable_states M1"
using \<open>q' \<in> FSM.reachable_states M2\<close> calculation(1) by blast
have "inv_into (FSM.reachable_states M1) f q \<in> FSM.reachable_states M1"
using f2 \<open>q \<in> FSM.reachable_states M2\<close> calculation(1) by blast
then show ?thesis
using f3 a1 \<open>q \<in> FSM.reachable_states M2\<close> \<open>q' \<in> FSM.reachable_states M2\<close> assms(1) assms(3) bij_betw_inv_into_right by fastforce
qed
qed
ultimately show "L M2 \<subseteq> L M1"
using language_equivalence_from_isomorphism_helper_reachable[of "(inv_into (reachable_states M1) f)" M2 M1]
by blast
qed
lemma language_empty_io :
assumes "inputs M = {} \<or> outputs M = {}"
shows "L M = {[]}"
proof -
have "transitions M = {}"
using assms fsm_transition_input fsm_transition_output
by auto
then have "\<And> p . path M (initial M) p \<Longrightarrow> p = []"
by (metis empty_iff path.cases)
then show ?thesis
unfolding LS.simps
by blast
qed
subsection \<open>Basic FSM Properties\<close>
subsubsection \<open>Completely Specified\<close>
fun completely_specified :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x)"
lemma completely_specified_alt_def :
"completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . \<exists> q' y . (q,x,y,q') \<in> transitions M)"
by force
lemma completely_specified_alt_def_h :
"completely_specified M = (\<forall> q \<in> states M . \<forall> x \<in> inputs M . h M (q,x) \<noteq> {})"
by force
fun completely_specified_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where
"completely_specified_state M q = (\<forall> x \<in> inputs M . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x)"
lemma completely_specified_states :
"completely_specified M = (\<forall> q \<in> states M . completely_specified_state M q)"
unfolding completely_specified.simps completely_specified_state.simps by force
lemma completely_specified_state_alt_def_h :
"completely_specified_state M q = (\<forall> x \<in> inputs M . h M (q,x) \<noteq> {})"
by force
lemma completely_specified_path_extension :
assumes "completely_specified M"
and "q \<in> states M"
and "path M q p"
and "x \<in> (inputs M)"
obtains t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
proof -
have "target q p \<in> states M"
using path_target_is_state \<open>path M q p\<close> by metis
then obtain t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
using \<open>completely_specified M\<close> \<open>x \<in> (inputs M)\<close>
unfolding completely_specified.simps by blast
then show ?thesis using that by blast
qed
lemma completely_specified_language_extension :
assumes "completely_specified M"
and "q \<in> states M"
and "io \<in> LS M q"
and "x \<in> (inputs M)"
obtains y where "io@[(x,y)] \<in> LS M q"
proof -
obtain p where "path M q p" and "p_io p = io"
using \<open>io \<in> LS M q\<close> by auto
moreover obtain t where "t \<in> transitions M" and "t_input t = x" and "t_source t = target q p"
using completely_specified_path_extension[OF assms(1,2) \<open>path M q p\<close> assms(4)] by blast
ultimately have "path M q (p@[t])" and "p_io (p@[t]) = io@[(x,t_output t)]"
by (simp add: path_append_transition)+
then have "io@[(x,t_output t)] \<in> LS M q"
using language_state_containment[of M q "p@[t]" "io@[(x,t_output t)]"] by auto
then show ?thesis using that by blast
qed
lemma path_of_length_ex :
assumes "completely_specified M"
and "q \<in> states M"
and "inputs M \<noteq> {}"
shows "\<exists> p . path M q p \<and> length p = k"
using assms(2) proof (induction k arbitrary: q)
case 0
then show ?case by auto
next
case (Suc k)
obtain t where "t_source t = q" and "t \<in> transitions M"
by (meson Suc.prems assms(1) assms(3) completely_specified.simps equals0I)
then have "t_target t \<in> states M"
using fsm_transition_target by blast
then obtain p where "path M (t_target t) p \<and> length p = k"
using Suc.IH by blast
then show ?case
using \<open>t_source t = q\<close> \<open>t \<in> transitions M\<close>
by auto
qed
subsubsection \<open>Deterministic\<close>
fun deterministic :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"deterministic M = (\<forall> t1 \<in> transitions M .
\<forall> t2 \<in> transitions M .
(t_source t1 = t_source t2 \<and> t_input t1 = t_input t2)
\<longrightarrow> (t_output t1 = t_output t2 \<and> t_target t1 = t_target t2))"
lemma deterministic_alt_def :
"deterministic M = (\<forall> q1 x y' y'' q1' q1'' . (q1,x,y',q1') \<in> transitions M \<and> (q1,x,y'',q1'') \<in> transitions M \<longrightarrow> y' = y'' \<and> q1' = q1'')"
by auto
lemma deterministic_alt_def_h :
"deterministic M = (\<forall> q1 x yq yq' . (yq \<in> h M (q1,x) \<and> yq' \<in> h M (q1,x)) \<longrightarrow> yq = yq')"
by auto
subsubsection \<open>Observable\<close>
fun observable :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"observable M = (\<forall> t1 \<in> transitions M .
\<forall> t2 \<in> transitions M .
(t_source t1 = t_source t2 \<and> t_input t1 = t_input t2 \<and> t_output t1 = t_output t2)
\<longrightarrow> t_target t1 = t_target t2)"
lemma observable_alt_def :
"observable M = (\<forall> q1 x y q1' q1'' . (q1,x,y,q1') \<in> transitions M \<and> (q1,x,y,q1'') \<in> transitions M \<longrightarrow> q1' = q1'')"
by auto
lemma observable_alt_def_h :
"observable M = (\<forall> q1 x yq yq' . (yq \<in> h M (q1,x) \<and> yq' \<in> h M (q1,x)) \<longrightarrow> fst yq = fst yq' \<longrightarrow> snd yq = snd yq')"
by auto
lemma language_append_path_ob :
assumes "io@[(x,y)] \<in> L M"
obtains p t where "path M (initial M) (p@[t])" and "p_io p = io" and "t_input t = x" and "t_output t = y"
proof -
obtain p p2 where "path M (initial M) p" and "path M (target (initial M) p) p2" and "p_io p = io" and "p_io p2 = [(x,y)]"
using language_state_split[OF assms] by blast
obtain t where "p2 = [t]" and "t_input t = x" and "t_output t = y"
using \<open>p_io p2 = [(x,y)]\<close> by auto
have "path M (initial M) (p@[t])"
using \<open>path M (initial M) p\<close> \<open>path M (target (initial M) p) p2\<close> unfolding \<open>p2 = [t]\<close> by auto
then show ?thesis using that[OF _ \<open>p_io p = io\<close> \<open>t_input t = x\<close> \<open>t_output t = y\<close>]
by simp
qed
subsubsection \<open>Single Input\<close>
(* each state has at most one input, but may have none *)
fun single_input :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"single_input M = (\<forall> t1 \<in> transitions M .
\<forall> t2 \<in> transitions M .
t_source t1 = t_source t2 \<longrightarrow> t_input t1 = t_input t2)"
lemma single_input_alt_def :
"single_input M = (\<forall> q1 x x' y y' q1' q1'' . (q1,x,y,q1') \<in> transitions M \<and> (q1,x',y',q1'') \<in> transitions M \<longrightarrow> x = x')"
by fastforce
lemma single_input_alt_def_h :
"single_input M = (\<forall> q x x' . (h M (q,x) \<noteq> {} \<and> h M (q,x') \<noteq> {}) \<longrightarrow> x = x')"
by force
subsubsection \<open>Output Complete\<close>
fun output_complete :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"output_complete M = (\<forall> t \<in> transitions M .
\<forall> y \<in> outputs M .
\<exists> t' \<in> transitions M . t_source t = t_source t' \<and>
t_input t = t_input t' \<and>
t_output t' = y)"
lemma output_complete_alt_def :
"output_complete M = (\<forall> q x . (\<exists> y q' . (q,x,y,q') \<in> transitions M) \<longrightarrow> (\<forall> y \<in> (outputs M) . \<exists> q' . (q,x,y,q') \<in> transitions M))"
by force
lemma output_complete_alt_def_h :
"output_complete M = (\<forall> q x . h M (q,x) \<noteq> {} \<longrightarrow> (\<forall> y \<in> outputs M . \<exists> q' . (y,q') \<in> h M (q,x)))"
by force
subsubsection \<open>Acyclic\<close>
fun acyclic :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"acyclic M = (\<forall> p . path M (initial M) p \<longrightarrow> distinct (visited_states (initial M) p))"
lemma visited_states_length : "length (visited_states q p) = Suc (length p)" by auto
lemma visited_states_take :
"(take (Suc n) (visited_states q p)) = (visited_states q (take n p))"
proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc x xs)
then show ?case by (cases "n \<le> length xs"; auto)
qed
(* very inefficient calculation *)
lemma acyclic_code[code] :
"acyclic M = (\<not>(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) .
\<exists> t \<in> transitions M . t_source t = target (initial M) p \<and>
t_target t \<in> set (visited_states (initial M) p)))"
proof -
have "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) .
\<exists> t \<in> transitions M . t_source t = target (initial M) p \<and>
t_target t \<in> set (visited_states (initial M) p))
\<Longrightarrow> \<not> FSM.acyclic M"
proof -
assume "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) .
\<exists> t \<in> transitions M . t_source t = target (initial M) p \<and>
t_target t \<in> set (visited_states (initial M) p))"
then obtain p t where "path M (initial M) p"
and "distinct (visited_states (initial M) p)"
and "t \<in> transitions M"
and "t_source t = target (initial M) p"
and "t_target t \<in> set (visited_states (initial M) p)"
unfolding acyclic_paths_set by blast
then have "path M (initial M) (p@[t])"
by (simp add: path_append_transition)
moreover have "\<not> (distinct (visited_states (initial M) (p@[t])))"
using \<open>t_target t \<in> set (visited_states (initial M) p)\<close> by auto
ultimately show "\<not> FSM.acyclic M"
by (meson acyclic.elims(2))
qed
moreover have "\<not> FSM.acyclic M \<Longrightarrow>
(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) .
\<exists> t \<in> transitions M . t_source t = target (initial M) p \<and>
t_target t \<in> set (visited_states (initial M) p))"
proof -
assume "\<not> FSM.acyclic M"
then obtain p where "path M (initial M) p"
and "\<not> distinct (visited_states (initial M) p)"
by auto
then obtain n where "distinct (take (Suc n) (visited_states (initial M) p))"
and "\<not> distinct (take (Suc (Suc n)) (visited_states (initial M) p))"
using maximal_distinct_prefix by blast
then have "distinct (visited_states (initial M) (take n p))"
and "\<not> distinct (visited_states (initial M)(take (Suc n) p))"
unfolding visited_states_take by simp+
then obtain p' t' where *: "take n p = p'"
and **: "take (Suc n) p = p' @ [t']"
by (metis Suc_less_eq \<open>\<not> distinct (visited_states (FSM.initial M) p)\<close>
le_imp_less_Suc not_less_eq_eq take_all take_hd_drop)
have ***: "visited_states (FSM.initial M) (p' @ [t']) = (visited_states (FSM.initial M) p')@[t_target t']"
by auto
have "path M (initial M) p'"
using * \<open>path M (initial M) p\<close>
by (metis append_take_drop_id path_prefix)
then have "p' \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
using \<open>distinct (visited_states (initial M) (take n p))\<close>
unfolding * acyclic_paths_set by blast
moreover have "t' \<in> transitions M \<and> t_source t' = target (initial M) p'"
using * ** \<open>path M (initial M) p\<close>
by (metis append_take_drop_id path_append_elim path_cons_elim)
moreover have "t_target t' \<in> set (visited_states (initial M) p')"
using \<open>distinct (visited_states (initial M) (take n p))\<close>
\<open>\<not> distinct (visited_states (initial M)(take (Suc n) p))\<close>
unfolding * ** *** by auto
ultimately show "(\<exists> p \<in> (acyclic_paths_up_to_length M (initial M) (size M - 1)) .
\<exists> t \<in> transitions M . t_source t = target (initial M) p \<and>
t_target t \<in> set (visited_states (initial M) p))"
by blast
qed
ultimately show ?thesis by blast
qed
lemma acyclic_alt_def : "acyclic M = finite (L M)"
proof
show "acyclic M \<Longrightarrow> finite (L M)"
proof -
assume "acyclic M"
then have "{ p . path M (initial M) p} \<subseteq> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
unfolding acyclic_paths_set by auto
moreover have "finite (acyclic_paths_up_to_length M (initial M) (size M - 1))"
unfolding acyclic_paths_up_to_length.simps using paths_finite[of M "initial M" "size M - 1"]
by (metis (mono_tags, lifting) Collect_cong \<open>FSM.acyclic M\<close> acyclic.elims(2))
ultimately have "finite { p . path M (initial M) p}"
using finite_subset by blast
then show "finite (L M)"
unfolding LS.simps by auto
qed
show "finite (L M) \<Longrightarrow> acyclic M"
proof (rule ccontr)
assume "finite (L M)"
assume "\<not> acyclic M"
obtain max_io_len where "\<forall>io \<in> L M . length io < max_io_len"
using finite_maxlen[OF \<open>finite (L M)\<close>] by blast
then have "\<And> p . path M (initial M) p \<Longrightarrow> length p < max_io_len"
proof -
fix p assume "path M (initial M) p"
show "length p < max_io_len"
proof (rule ccontr)
assume "\<not> length p < max_io_len"
then have "\<not> length (p_io p) < max_io_len" by auto
moreover have "p_io p \<in> L M"
unfolding LS.simps using \<open>path M (initial M) p\<close> by blast
ultimately show "False"
using \<open>\<forall>io \<in> L M . length io < max_io_len\<close> by blast
qed
qed
obtain p where "path M (initial M) p" and "\<not> distinct (visited_states (initial M) p)"
using \<open>\<not> acyclic M\<close> unfolding acyclic.simps by blast
then obtain pL where "path M (initial M) pL" and "max_io_len \<le> length pL"
using cyclic_path_pumping[of M p max_io_len] by blast
then show "False"
using \<open>\<And> p . path M (initial M) p \<Longrightarrow> length p < max_io_len\<close>
using not_le by blast
qed
qed
lemma acyclic_finite_paths_from_reachable_state :
assumes "acyclic M"
and "path M (initial M) p"
and "target (initial M) p = q"
shows "finite {p . path M q p}"
proof -
from assms have "{ p . path M (initial M) p} \<subseteq> (acyclic_paths_up_to_length M (initial M) (size M - 1))"
unfolding acyclic_paths_set by auto
moreover have "finite (acyclic_paths_up_to_length M (initial M) (size M - 1))"
unfolding acyclic_paths_up_to_length.simps using paths_finite[of M "initial M" "size M - 1"]
by (metis (mono_tags, lifting) Collect_cong \<open>FSM.acyclic M\<close> acyclic.elims(2))
ultimately have "finite { p . path M (initial M) p}"
using finite_subset by blast
show "finite {p . path M q p}"
proof (cases "q \<in> states M")
case True
have "image (\<lambda>p' . p@p') {p' . path M q p'} \<subseteq> {p' . path M (initial M) p'}"
proof
fix x assume "x \<in> image (\<lambda>p' . p@p') {p' . path M q p'}"
then obtain p' where "x = p@p'" and "p' \<in> {p' . path M q p'}"
by blast
then have "path M q p'" by auto
then have "path M (initial M) (p@p')"
using path_append[OF \<open>path M (initial M) p\<close>] \<open>target (initial M) p = q\<close> by auto
then show "x \<in> {p' . path M (initial M) p'}" using \<open>x = p@p'\<close> by blast
qed
then have "finite (image (\<lambda>p' . p@p') {p' . path M q p'})"
using \<open>finite { p . path M (initial M) p}\<close> finite_subset by auto
show ?thesis using finite_imageD[OF \<open>finite (image (\<lambda>p' . p@p') {p' . path M q p'})\<close>]
by (meson inj_onI same_append_eq)
next
case False
then show ?thesis
by (meson not_finite_existsD path_begin_state)
qed
qed
lemma acyclic_paths_from_reachable_states :
assumes "acyclic M"
and "path M (initial M) p'"
and "target (initial M) p' = q"
and "path M q p"
shows "distinct (visited_states q p)"
proof -
have "path M (initial M) (p'@p)"
using assms(2,3,4) path_append by metis
then have "distinct (visited_states (initial M) (p'@p))"
using assms(1) unfolding acyclic.simps by blast
then have "distinct (initial M # (map t_target p') @ map t_target p)"
by auto
moreover have "initial M # (map t_target p') @ map t_target p
= (butlast (initial M # map t_target p')) @ ((last (initial M # map t_target p')) # map t_target p)"
by auto
ultimately have "distinct ((last (initial M # map t_target p')) # map t_target p)"
by auto
then show ?thesis
using \<open>target (initial M) p' = q\<close> unfolding visited_states.simps target.simps by simp
qed
definition LS_acyclic :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list set" where
"LS_acyclic M q = {p_io p | p . path M q p \<and> distinct (visited_states q p)}"
lemma LS_acyclic_code[code] :
"LS_acyclic M q = image p_io (acyclic_paths_up_to_length M q (size M - 1))"
unfolding acyclic_paths_set LS_acyclic_def by blast
lemma LS_from_LS_acyclic :
assumes "acyclic M"
shows "L M = LS_acyclic M (initial M)"
proof -
obtain pps :: "(('b \<times> 'c) list \<Rightarrow> bool) \<Rightarrow> (('b \<times> 'c) list \<Rightarrow> bool) \<Rightarrow> ('b \<times> 'c) list" where
f1: "\<forall>p pa. (\<not> p (pps pa p)) = pa (pps pa p) \<or> Collect p = Collect pa"
by (metis (no_types) Collect_cong)
have "\<forall>ps. \<not> path M (FSM.initial M) ps \<or> distinct (visited_states (FSM.initial M) ps)"
using acyclic.simps assms by blast
then have "(\<nexists>ps. pps (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa)
(\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa
\<and> distinct (visited_states (FSM.initial M) psa))
= p_io ps \<and> path M (FSM.initial M) ps \<and> distinct (visited_states (FSM.initial M) ps))
\<noteq> (\<exists>ps. pps (\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa)
(\<lambda>ps. \<exists>psa. ps = p_io psa \<and> path M (FSM.initial M) psa
\<and> distinct (visited_states (FSM.initial M) psa))
= p_io ps \<and> path M (FSM.initial M) ps)"
by blast
then have "{p_io ps |ps. path M (FSM.initial M) ps \<and> distinct (visited_states (FSM.initial M) ps)}
= {p_io ps |ps. path M (FSM.initial M) ps}"
using f1
by (meson \<open>\<forall>ps. \<not> path M (FSM.initial M) ps \<or> distinct (visited_states (FSM.initial M) ps)\<close>)
then show ?thesis
by (simp add: LS_acyclic_def)
qed
lemma cyclic_cycle :
assumes "\<not> acyclic M"
shows "\<exists> q p . path M q p \<and> p \<noteq> [] \<and> target q p = q"
proof -
from \<open>\<not> acyclic M\<close> obtain p t where "path M (initial M) (p@[t])"
and "\<not>distinct (visited_states (initial M) (p@[t]))"
by (metis (no_types, opaque_lifting) Nil_is_append_conv acyclic.simps append_take_drop_id
maximal_distinct_prefix rev_exhaust visited_states_take)
show ?thesis
proof (cases "initial M \<in> set (map t_target (p@[t]))")
case True
then obtain i where "last (take i (map t_target (p@[t]))) = initial M"
and "i \<le> length (map t_target (p@[t]))" and "0 < i"
using list_contains_last_take by metis
let ?p = "take i (p@[t])"
have "path M (initial M) (?p@(drop i (p@[t])))"
using \<open>path M (initial M) (p@[t])\<close>
by (metis append_take_drop_id)
then have "path M (initial M) ?p" by auto
moreover have "?p \<noteq> []" using \<open>0 < i\<close> by auto
moreover have "target (initial M) ?p = initial M"
using \<open>last (take i (map t_target (p@[t]))) = initial M\<close>
unfolding target.simps visited_states.simps
by (metis (no_types, lifting) calculation(2) last_ConsR list.map_disc_iff take_map)
ultimately show ?thesis by blast
next
case False
then have "\<not> distinct (map t_target (p@[t]))"
using \<open>\<not>distinct (visited_states (initial M) (p@[t]))\<close>
unfolding visited_states.simps
by auto
then obtain i j where "i < j" and "j < length (map t_target (p@[t]))"
and "(map t_target (p@[t])) ! i = (map t_target (p@[t])) ! j"
using non_distinct_repetition_indices by blast
let ?pre_i = "take (Suc i) (p@[t])"
let ?p = "take ((Suc j)-(Suc i)) (drop (Suc i) (p@[t]))"
let ?post_j = "drop ((Suc j)-(Suc i)) (drop (Suc i) (p@[t]))"
have "p@[t] = ?pre_i @ ?p @ ?post_j"
using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close>
by (metis append_take_drop_id)
then have "path M (target (initial M) ?pre_i) ?p"
using \<open>path M (initial M) (p@[t])\<close>
by (metis path_prefix path_suffix)
have "?p \<noteq> []"
using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close> by auto
have "i < length (map t_target (p@[t]))"
using \<open>i < j\<close> \<open>j < length (map t_target (p@[t]))\<close> by auto
have "(target (initial M) ?pre_i) = (map t_target (p@[t])) ! i"
unfolding target.simps visited_states.simps
using take_last_index[OF \<open>i < length (map t_target (p@[t]))\<close>]
by (metis (no_types, lifting) \<open>i < length (map t_target (p @ [t]))\<close>
last_ConsR snoc_eq_iff_butlast take_Suc_conv_app_nth take_map)
have "?pre_i@?p = take (Suc j) (p@[t])"
by (metis (no_types) \<open>i < j\<close> add_Suc add_diff_cancel_left' less_SucI less_imp_Suc_add take_add)
moreover have "(target (initial M) (take (Suc j) (p@[t]))) = (map t_target (p@[t])) ! j"
unfolding target.simps visited_states.simps
using take_last_index[OF \<open>j < length (map t_target (p@[t]))\<close>]
by (metis (no_types, lifting) \<open>j < length (map t_target (p @ [t]))\<close>
last_ConsR snoc_eq_iff_butlast take_Suc_conv_app_nth take_map)
ultimately have "(target (initial M) (?pre_i@?p)) = (map t_target (p@[t])) ! j"
by auto
then have "(target (initial M) (?pre_i@?p)) = (map t_target (p@[t])) ! i"
using \<open>(map t_target (p@[t])) ! i = (map t_target (p@[t])) ! j\<close> by simp
moreover have "(target (initial M) (?pre_i@?p)) = (target (target (initial M) ?pre_i) ?p)"
unfolding target.simps visited_states.simps last.simps by auto
ultimately have "(target (target (initial M) ?pre_i) ?p) = (map t_target (p@[t])) ! i"
by auto
then have "(target (target (initial M) ?pre_i) ?p) = (target (initial M) ?pre_i)"
using \<open>(target (initial M) ?pre_i) = (map t_target (p@[t])) ! i\<close> by auto
show ?thesis
using \<open>path M (target (initial M) ?pre_i) ?p\<close> \<open>?p \<noteq> []\<close>
\<open>(target (target (initial M) ?pre_i) ?p) = (target (initial M) ?pre_i)\<close>
by blast
qed
qed
lemma cyclic_cycle_rev :
fixes M :: "('a,'b,'c) fsm"
assumes "path M (initial M) p'"
and "target (initial M) p' = q"
and "path M q p"
and "p \<noteq> []"
and "target q p = q"
shows "\<not> acyclic M"
using assms unfolding acyclic.simps target.simps visited_states.simps
using distinct.simps(2) by fastforce
lemma acyclic_initial :
assumes "acyclic M"
shows "\<not> (\<exists> t \<in> transitions M . t_target t = initial M \<and>
(\<exists> p . path M (initial M) p \<and> target (initial M) p = t_source t))"
by (metis append_Cons assms cyclic_cycle_rev list.distinct(1) path.simps
path_append path_append_transition_elim(3) single_transition_path)
lemma cyclic_path_shift :
assumes "path M q p"
and "target q p = q"
shows "path M (target q (take i p)) ((drop i p) @ (take i p))"
and "target (target q (take i p)) ((drop i p) @ (take i p)) = (target q (take i p))"
proof -
show "path M (target q (take i p)) ((drop i p) @ (take i p))"
by (metis append_take_drop_id assms(1) assms(2) path_append path_append_elim path_append_target)
show "target (target q (take i p)) ((drop i p) @ (take i p)) = (target q (take i p))"
by (metis append_take_drop_id assms(2) path_append_target)
qed
lemma cyclic_path_transition_states_property :
assumes "\<exists> t \<in> set p . P (t_source t)"
and "\<forall> t \<in> set p . P (t_source t) \<longrightarrow> P (t_target t)"
and "path M q p"
and "target q p = q"
shows "\<forall> t \<in> set p . P (t_source t)"
and "\<forall> t \<in> set p . P (t_target t)"
proof -
obtain t0 where "t0 \<in> set p" and "P (t_source t0)"
using assms(1) by blast
then obtain i where "i < length p" and "p ! i = t0"
by (meson in_set_conv_nth)
let ?p = "(drop i p @ take i p)"
have "path M (target q (take i p)) ?p"
using cyclic_path_shift(1)[OF assms(3,4), of i] by assumption
have "set ?p = set p"
proof -
have "set ?p = set (take i p @ drop i p)"
using list_set_sym by metis
then show ?thesis by auto
qed
then have "\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)"
using assms(2) by blast
have "\<And> j . j < length ?p \<Longrightarrow> P (t_source (?p ! j))"
proof -
fix j assume "j < length ?p"
then show "P (t_source (?p ! j))"
proof (induction j)
case 0
then show ?case
using \<open>p ! i = t0\<close> \<open>P (t_source t0)\<close>
by (metis \<open>i < length p\<close> drop_eq_Nil hd_append2 hd_conv_nth hd_drop_conv_nth leD
length_greater_0_conv)
next
case (Suc j)
then have "P (t_source (?p ! j))"
by auto
then have "P (t_target (?p ! j))"
using Suc.prems \<open>\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)\<close>[of "?p ! j"]
using Suc_lessD nth_mem by blast
moreover have "t_target (?p ! j) = t_source (?p ! (Suc j))"
using path_source_target_index[OF Suc.prems \<open>path M (target q (take i p)) ?p\<close>]
by assumption
ultimately show ?case
using \<open>\<And> t . t \<in> set ?p \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)\<close>[of "?p ! j"]
by simp
qed
qed
then have "\<forall> t \<in> set ?p . P (t_source t)"
by (metis in_set_conv_nth)
then show "\<forall> t \<in> set p . P (t_source t)"
using \<open>set ?p = set p\<close> by blast
then show "\<forall> t \<in> set p . P (t_target t)"
using assms(2) by blast
qed
lemma cycle_incoming_transition_ex :
assumes "path M q p"
and "p \<noteq> []"
and "target q p = q"
and "t \<in> set p"
shows "\<exists> tI \<in> set p . t_target tI = t_source t"
proof -
obtain i where "i < length p" and "p ! i = t"
using assms(4) by (meson in_set_conv_nth)
let ?p = "(drop i p @ take i p)"
have "path M (target q (take i p)) ?p"
and "target (target q (take i p)) ?p = target q (take i p)"
using cyclic_path_shift[OF assms(1,3), of i] by linarith+
have "p = (take i p @ drop i p)" by auto
then have "path M (target q (take i p)) (drop i p)"
using path_suffix assms(1) by metis
moreover have "t = hd (drop i p)"
using \<open>i < length p\<close> \<open>p ! i = t\<close>
by (simp add: hd_drop_conv_nth)
ultimately have "path M (target q (take i p)) [t]"
by (metis \<open>i < length p\<close> append_take_drop_id assms(1) path_append_elim take_hd_drop)
then have "t_source t = (target q (take i p))"
by auto
moreover have "t_target (last ?p) = (target q (take i p))"
using \<open>path M (target q (take i p)) ?p\<close> \<open>target (target q (take i p)) ?p = target q (take i p)\<close>
assms(2)
unfolding target.simps visited_states.simps last.simps
by (metis (no_types, lifting) \<open>p = take i p @ drop i p\<close> append_is_Nil_conv last_map
list.map_disc_iff)
moreover have "set ?p = set p"
proof -
have "set ?p = set (take i p @ drop i p)"
using list_set_sym by metis
then show ?thesis by auto
qed
ultimately show ?thesis
by (metis \<open>i < length p\<close> append_is_Nil_conv drop_eq_Nil last_in_set leD)
qed
lemma acyclic_paths_finite :
"finite {p . path M q p \<and> distinct (visited_states q p) }"
proof -
have "\<And> p . path M q p \<Longrightarrow> distinct (visited_states q p) \<Longrightarrow> distinct p"
proof -
fix p assume "path M q p" and "distinct (visited_states q p)"
then have "distinct (map t_target p)" by auto
then show "distinct p" by (simp add: distinct_map)
qed
then show ?thesis
using distinct_lists_finite[OF fsm_transitions_finite, of M] path_transitions[of M q]
by (metis (no_types, lifting) infinite_super mem_Collect_eq path_transitions subsetI)
qed
lemma acyclic_no_self_loop :
assumes "acyclic M"
and "q \<in> reachable_states M"
shows "\<not> (\<exists> x y . (q,x,y,q) \<in> transitions M)"
proof
assume "\<exists>x y. (q, x, y, q) \<in> FSM.transitions M"
then obtain x y where "(q, x, y, q) \<in> FSM.transitions M" by blast
moreover obtain p where "path M (initial M) p" and "target (initial M) p = q"
using assms(2) unfolding reachable_states_def by blast
ultimately have "path M (initial M) (p@[(q,x,y,q)])"
by (simp add: path_append_transition)
moreover have "\<not> (distinct (visited_states (initial M) (p@[(q,x,y,q)])))"
using \<open>target (initial M) p = q\<close> unfolding visited_states.simps target.simps by (cases p rule: rev_cases; auto)
ultimately show "False"
using assms(1) unfolding acyclic.simps
by meson
qed
subsubsection \<open>Deadlock States\<close>
fun deadlock_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> bool" where
"deadlock_state M q = (\<not>(\<exists> t \<in> transitions M . t_source t = q))"
lemma deadlock_state_alt_def : "deadlock_state M q = (LS M q \<subseteq> {[]})"
proof
show "deadlock_state M q \<Longrightarrow> LS M q \<subseteq> {[]}"
proof -
assume "deadlock_state M q"
moreover have "\<And> p . deadlock_state M q \<Longrightarrow> path M q p \<Longrightarrow> p = []"
unfolding deadlock_state.simps by (metis path.cases)
ultimately show "LS M q \<subseteq> {[]}"
unfolding LS.simps by blast
qed
show "LS M q \<subseteq> {[]} \<Longrightarrow> deadlock_state M q"
unfolding LS.simps deadlock_state.simps using path.cases[of M q] by blast
qed
lemma deadlock_state_alt_def_h : "deadlock_state M q = (\<forall> x \<in> inputs M . h M (q,x) = {})"
unfolding deadlock_state.simps h.simps
using fsm_transition_input by force
lemma acyclic_deadlock_reachable :
assumes "acyclic M"
shows "\<exists> q \<in> reachable_states M . deadlock_state M q"
proof (rule ccontr)
assume "\<not> (\<exists>q\<in>reachable_states M. deadlock_state M q)"
then have *: "\<And> q . q \<in> reachable_states M \<Longrightarrow> (\<exists> t \<in> transitions M . t_source t = q)"
unfolding deadlock_state.simps by blast
let ?p = "arg_max_on length {p. path M (initial M) p}"
have "finite {p. path M (initial M) p}"
by (metis Collect_cong acyclic_finite_paths_from_reachable_state assms eq_Nil_appendI fsm_initial
nil path_append path_append_elim)
moreover have "{p. path M (initial M) p} \<noteq> {}"
by auto
ultimately obtain p where "path M (initial M) p"
and "\<And> p' . path M (initial M) p' \<Longrightarrow> length p' \<le> length p"
using max_length_elem
by (metis mem_Collect_eq not_le_imp_less)
then obtain t where "t \<in> transitions M" and "t_source t = target (initial M) p"
using *[of "target (initial M) p"] unfolding reachable_states_def
by blast
then have "path M (initial M) (p@[t])"
using \<open>path M (initial M) p\<close>
by (simp add: path_append_transition)
then show "False"
using \<open>\<And> p' . path M (initial M) p' \<Longrightarrow> length p' \<le> length p\<close>
by (metis impossible_Cons length_rotate1 rotate1.simps(2))
qed
lemma deadlock_prefix :
assumes "path M q p"
and "t \<in> set (butlast p)"
shows "\<not> (deadlock_state M (t_target t))"
using assms proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc t' p')
show ?case proof (cases "t \<in> set (butlast p')")
case True
show ?thesis
using snoc.IH[OF _ True] snoc.prems(1)
by blast
next
case False
then have "p' = (butlast p')@[t]"
using snoc.prems(2) by (metis append_butlast_last_id append_self_conv2 butlast_snoc
in_set_butlast_appendI list_prefix_elem set_ConsD)
then have "path M q ((butlast p'@[t])@[t'])"
using snoc.prems(1)
by auto
have "t' \<in> transitions M" and "t_source t' = target q (butlast p'@[t])"
using path_suffix[OF \<open>path M q ((butlast p'@[t])@[t'])\<close>]
by auto
then have "t' \<in> transitions M \<and> t_source t' = t_target t"
unfolding target.simps visited_states.simps by auto
then show ?thesis
unfolding deadlock_state.simps using \<open>t' \<in> transitions M\<close> by blast
qed
qed
lemma states_initial_deadlock :
assumes "deadlock_state M (initial M)"
shows "reachable_states M = {initial M}"
proof -
have "\<And> q . q \<in> reachable_states M \<Longrightarrow> q = initial M"
proof -
fix q assume "q \<in> reachable_states M"
then obtain p where "path M (initial M) p" and "target (initial M) p = q"
unfolding reachable_states_def by auto
show "q = initial M" proof (cases p)
case Nil
then show ?thesis using \<open>target (initial M) p = q\<close> by auto
next
case (Cons t p')
then have "False" using assms \<open>path M (initial M) p\<close> unfolding deadlock_state.simps
by auto
then show ?thesis by simp
qed
qed
then show ?thesis
using reachable_states_initial[of M] by blast
qed
subsubsection \<open>Other\<close>
fun completed_path :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> bool" where
"completed_path M q p = deadlock_state M (target q p)"
fun minimal :: "('a,'b,'c) fsm \<Rightarrow> bool" where
"minimal M = (\<forall> q \<in> states M . \<forall> q' \<in> states M . q \<noteq> q' \<longrightarrow> LS M q \<noteq> LS M q')"
lemma minimal_alt_def : "minimal M = (\<forall> q q' . q \<in> states M \<longrightarrow> q' \<in> states M \<longrightarrow> LS M q = LS M q' \<longrightarrow> q = q')"
by auto
definition retains_outputs_for_states_and_inputs :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where
"retains_outputs_for_states_and_inputs M S
= (\<forall> tS \<in> transitions S .
\<forall> tM \<in> transitions M .
(t_source tS = t_source tM \<and> t_input tS = t_input tM) \<longrightarrow> tM \<in> transitions S)"
subsection \<open>IO Targets and Observability\<close>
fun paths_for_io' :: "(('a \<times> 'b) \<Rightarrow> ('c \<times> 'a) set) \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> ('a,'b,'c) path set" where
"paths_for_io' f [] q prev = {prev}" |
"paths_for_io' f ((x,y)#io) q prev = \<Union>(image (\<lambda>yq' . paths_for_io' f io (snd yq') (prev@[(q,x,y,(snd yq'))])) (Set.filter (\<lambda>yq' . fst yq' = y) (f (q,x))))"
lemma paths_for_io'_set :
assumes "q \<in> states M"
shows "paths_for_io' (h M) io q prev = {prev@p | p . path M q p \<and> p_io p = io}"
using assms proof (induction io arbitrary: q prev)
case Nil
then show ?case by auto
next
case (Cons xy io)
obtain x y where "xy = (x,y)"
by (meson surj_pair)
let ?UN = "\<Union>(image (\<lambda>yq' . paths_for_io' (h M) io (snd yq') (prev@[(q,x,y,(snd yq'))]))
(Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x))))"
have "?UN = {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
proof
have "\<And> p . p \<in> ?UN \<Longrightarrow> p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
proof -
fix p assume "p \<in> ?UN"
then obtain q' where "(y,q') \<in> (Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x)))"
and "p \<in> paths_for_io' (h M) io q' (prev@[(q,x,y,q')])"
by auto
from \<open>(y,q') \<in> (Set.filter (\<lambda>yq' . fst yq' = y) (h M (q,x)))\<close> have "q' \<in> states M"
and "(q,x,y,q') \<in> transitions M"
using fsm_transition_target unfolding h.simps by auto
have "p \<in> {(prev @ [(q, x, y, q')]) @ p |p. path M q' p \<and> p_io p = io}"
using \<open>p \<in> paths_for_io' (h M) io q' (prev@[(q,x,y,q')])\<close>
unfolding Cons.IH[OF \<open>q' \<in> states M\<close>] by assumption
moreover have "{(prev @ [(q, x, y, q')]) @ p |p. path M q' p \<and> p_io p = io}
\<subseteq> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
using \<open>(q,x,y,q') \<in> transitions M\<close>
using cons by force
ultimately show "p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
by blast
qed
then show "?UN \<subseteq> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
by blast
have "\<And> p . p \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io} \<Longrightarrow> p \<in> ?UN"
proof -
fix pp assume "pp \<in> {prev@p | p . path M q p \<and> p_io p = (x,y)#io}"
then obtain p where "pp = prev@p" and "path M q p" and "p_io p = (x,y)#io"
by fastforce
then obtain t p' where "p = t#p'" and "path M q (t#p')" and "p_io (t#p') = (x,y)#io"
and "p_io p' = io"
by (metis (no_types, lifting) map_eq_Cons_D)
then have "path M (t_target t) p'" and "t_source t = q" and "t_input t = x"
and "t_output t = y" and "t_target t \<in> states M"
and "t \<in> transitions M"
by auto
have "(y,t_target t) \<in> Set.filter (\<lambda>yq'. fst yq' = y) (h M (q, x))"
using \<open>t \<in> transitions M\<close> \<open>t_output t = y\<close> \<open>t_input t = x\<close> \<open>t_source t = q\<close>
unfolding h.simps
by auto
moreover have "(prev@p) \<in> paths_for_io' (h M) io (snd (y,t_target t)) (prev @ [(q, x, y, snd (y,t_target t))])"
using Cons.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[(q, x, y, t_target t)]"]
using \<open>p = t # p'\<close> \<open>p_io p' = io\<close> \<open>path M (t_target t) p'\<close> \<open>t_input t = x\<close>
\<open>t_output t = y\<close> \<open>t_source t = q\<close>
by auto
ultimately show "pp \<in> ?UN" unfolding \<open>pp = prev@p\<close>
by blast
qed
then show "{prev@p | p . path M q p \<and> p_io p = (x,y)#io} \<subseteq> ?UN"
by (meson subsetI)
qed
then show ?case
by (simp add: \<open>xy = (x, y)\<close>)
qed
definition paths_for_io :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> ('a,'b,'c) path set" where
"paths_for_io M q io = {p . path M q p \<and> p_io p = io}"
lemma paths_for_io_set_code[code] :
"paths_for_io M q io = (if q \<in> states M then paths_for_io' (h M) io q [] else {})"
using paths_for_io'_set[of q M io "[]"]
unfolding paths_for_io_def
proof -
have "{[] @ ps |ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})
\<longrightarrow> {ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
by auto
moreover
{ assume "{[] @ ps |ps. path M q ps \<and> p_io ps = io} \<noteq> (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
then have "q \<notin> FSM.states M"
using \<open>q \<in> FSM.states M \<Longrightarrow> paths_for_io' (h M) io q [] = {[] @ p |p. path M q p \<and> p_io p = io}\<close> by force
then have "{ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
using path_begin_state by force }
ultimately show "{ps. path M q ps \<and> p_io ps = io} = (if q \<in> FSM.states M then paths_for_io' (h M) io q [] else {})"
by linarith
qed
fun io_targets :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a \<Rightarrow> 'a set" where
"io_targets M io q = {target q p | p . path M q p \<and> p_io p = io}"
lemma io_targets_code[code] : "io_targets M io q = image (target q) (paths_for_io M q io)"
unfolding io_targets.simps paths_for_io_def by blast
lemma io_targets_states :
"io_targets M io q \<subseteq> states M"
using path_target_is_state by fastforce
lemma observable_transition_unique :
assumes "observable M"
and "t \<in> transitions M"
shows "\<exists>! t' \<in> transitions M . t_source t' = t_source t \<and>
t_input t' = t_input t \<and>
t_output t' = t_output t"
by (metis assms observable.elims(2) prod.expand)
lemma observable_path_unique :
assumes "observable M"
and "path M q p"
and "path M q p'"
and "p_io p = p_io p'"
shows "p = p'"
proof -
have "length p = length p'"
using assms(4) map_eq_imp_length_eq by blast
then show ?thesis
using \<open>p_io p = p_io p'\<close> \<open>path M q p\<close> \<open>path M q p'\<close>
proof (induction p p' arbitrary: q rule: list_induct2)
case Nil
then show ?case by auto
next
case (Cons x xs y ys)
then have *: "x \<in> transitions M \<and> y \<in> transitions M \<and> t_source x = t_source y
\<and> t_input x = t_input y \<and> t_output x = t_output y"
by auto
then have "t_target x = t_target y"
using assms(1) observable.elims(2) by blast
then have "x = y"
by (simp add: "*" prod.expand)
have "p_io xs = p_io ys"
using Cons by auto
moreover have "path M (t_target x) xs"
using Cons by auto
moreover have "path M (t_target x) ys"
using Cons \<open>t_target x = t_target y\<close> by auto
ultimately have "xs = ys"
using Cons by auto
then show ?case
using \<open>x = y\<close> by simp
qed
qed
lemma observable_io_targets :
assumes "observable M"
and "io \<in> LS M q"
obtains q'
where "io_targets M io q = {q'}"
proof -
obtain p where "path M q p" and "p_io p = io"
using assms(2) by auto
then have "target q p \<in> io_targets M io q"
by auto
have "\<exists> q' . io_targets M io q = {q'}"
proof (rule ccontr)
assume "\<not>(\<exists>q'. io_targets M io q = {q'})"
then have "\<exists> q' . q' \<noteq> target q p \<and> q' \<in> io_targets M io q"
proof -
have "\<not> io_targets M io q \<subseteq> {target q p}"
using \<open>\<not>(\<exists>q'. io_targets M io q = {q'})\<close> \<open>target q p \<in> io_targets M io q\<close> by blast
then show ?thesis
by blast
qed
then obtain q' where "q' \<noteq> target q p" and "q' \<in> io_targets M io q"
by blast
then obtain p' where "path M q p'" and "target q p' = q'" and "p_io p' = io"
by auto
then have "p_io p = p_io p'"
using \<open>p_io p = io\<close> by simp
then have "p = p'"
using observable_path_unique[OF assms(1) \<open>path M q p\<close> \<open>path M q p'\<close>] by simp
then show "False"
using \<open>q' \<noteq> target q p\<close> \<open>target q p' = q'\<close> by auto
qed
then show ?thesis using that by blast
qed
lemma observable_path_io_target :
assumes "observable M"
and "path M q p"
shows "io_targets M (p_io p) q = {target q p}"
using observable_io_targets[OF assms(1) language_state_containment[OF assms(2)], of "p_io p"]
singletonD[of "target q p"]
unfolding io_targets.simps
proof -
assume a1: "\<And>a. target q p \<in> {a} \<Longrightarrow> target q p = a"
assume "\<And>thesis. \<lbrakk>p_io p = p_io p; \<And>q'. {target q pa |pa. path M q pa \<and> p_io pa = p_io p} = {q'} \<Longrightarrow> thesis\<rbrakk> \<Longrightarrow> thesis"
then obtain aa :: 'a where "\<And>b. {target q ps |ps. path M q ps \<and> p_io ps = p_io p} = {aa} \<or> b"
by meson
then show "{target q ps |ps. path M q ps \<and> p_io ps = p_io p} = {target q p}"
using a1 assms(2) by blast
qed
lemma completely_specified_io_targets :
assumes "completely_specified M"
shows "\<forall> q \<in> io_targets M io (initial M) . \<forall> x \<in> (inputs M) . \<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x"
by (meson assms completely_specified.elims(2) io_targets_states subsetD)
lemma observable_path_language_step :
assumes "observable M"
and "path M q p"
and "\<not> (\<exists>t\<in>transitions M.
t_source t = target q p \<and>
t_input t = x \<and> t_output t = y)"
shows "(p_io p)@[(x,y)] \<notin> LS M q"
using assms proof (induction p rule: rev_induct)
case Nil
show ?case proof
assume "p_io [] @ [(x, y)] \<in> LS M q"
then obtain p' where "path M q p'" and "p_io p' = [(x,y)]" unfolding LS.simps
by force
then obtain t where "p' = [t]" by blast
have "t\<in>transitions M" and "t_source t = target q []"
using \<open>path M q p'\<close> \<open>p' = [t]\<close> by auto
moreover have "t_input t = x \<and> t_output t = y"
using \<open>p_io p' = [(x,y)]\<close> \<open>p' = [t]\<close> by auto
ultimately show "False"
using Nil.prems(3) by blast
qed
next
case (snoc t p)
from \<open>path M q (p @ [t])\<close> have "path M q p" and "t_source t = target q p"
and "t \<in> transitions M"
by auto
show ?case proof
assume "p_io (p @ [t]) @ [(x, y)] \<in> LS M q"
then obtain p' where "path M q p'" and "p_io p' = p_io (p @ [t]) @ [(x, y)]"
by auto
then obtain p'' t' t'' where "p' = p''@[t']@[t'']"
by (metis (no_types, lifting) append.assoc map_butlast map_is_Nil_conv snoc_eq_iff_butlast)
then have "path M q p''"
using \<open>path M q p'\<close> by blast
have "p_io p'' = p_io p"
using \<open>p' = p''@[t']@[t'']\<close> \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> by auto
then have "p'' = p"
using observable_path_unique[OF assms(1) \<open>path M q p''\<close> \<open>path M q p\<close>] by blast
have "t_source t' = target q p''" and "t' \<in> transitions M"
using \<open>path M q p'\<close> \<open>p' = p''@[t']@[t'']\<close> by auto
then have "t_source t' = t_source t"
using \<open>p'' = p\<close> \<open>t_source t = target q p\<close> by auto
moreover have "t_input t' = t_input t \<and> t_output t' = t_output t"
using \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> \<open>p' = p''@[t']@[t'']\<close> \<open>p'' = p\<close> by auto
ultimately have "t' = t"
using \<open>t \<in> transitions M\<close> \<open>t' \<in> transitions M\<close> assms(1) unfolding observable.simps
by (meson prod.expand)
have "t'' \<in> transitions M" and "t_source t'' = target q (p@[t])"
using \<open>path M q p'\<close> \<open>p' = p''@[t']@[t'']\<close> \<open>p'' = p\<close> \<open>t' = t\<close> by auto
moreover have "t_input t'' = x \<and> t_output t'' = y"
using \<open>p_io p' = p_io (p @ [t]) @ [(x, y)]\<close> \<open>p' = p''@[t']@[t'']\<close> by auto
ultimately show "False"
using snoc.prems(3) by blast
qed
qed
lemma observable_io_targets_language :
assumes "io1 @ io2 \<in> LS M q1"
and "observable M"
and "q2 \<in> io_targets M io1 q1"
shows "io2 \<in> LS M q2"
proof -
obtain p1 p2 where "path M q1 p1" and "path M (target q1 p1) p2"
and "p_io p1 = io1" and "p_io p2 = io2"
using language_state_split[OF assms(1)] by blast
then have "io1 \<in> LS M q1" and "io2 \<in> LS M (target q1 p1)"
by auto
have "target q1 p1 \<in> io_targets M io1 q1"
using \<open>path M q1 p1\<close> \<open>p_io p1 = io1\<close>
unfolding io_targets.simps by blast
then have "target q1 p1 = q2"
using observable_io_targets[OF assms(2) \<open>io1 \<in> LS M q1\<close>]
by (metis assms(3) singletonD)
then show ?thesis
using \<open>io2 \<in> LS M (target q1 p1)\<close> by auto
qed
lemma io_targets_language_append :
assumes "q1 \<in> io_targets M io1 q"
and "io2 \<in> LS M q1"
shows "io1@io2 \<in> LS M q"
proof -
obtain p1 where "path M q p1" and "p_io p1 = io1" and "target q p1 = q1"
using assms(1) by auto
moreover obtain p2 where "path M q1 p2" and "p_io p2 = io2"
using assms(2) by auto
ultimately have "path M q (p1@p2)" and "p_io (p1@p2) = io1@io2"
by auto
then show ?thesis
using language_state_containment[of M q "p1@p2" "io1@io2"] by simp
qed
lemma io_targets_next :
assumes "t \<in> transitions M"
shows "io_targets M io (t_target t) \<subseteq> io_targets M (p_io [t] @ io) (t_source t)"
unfolding io_targets.simps
proof
fix q assume "q \<in> {target (t_target t) p |p. path M (t_target t) p \<and> p_io p = io}"
then obtain p where "path M (t_target t) p \<and> p_io p = io \<and> target (t_target t) p = q"
by auto
then have "path M (t_source t) (t#p) \<and> p_io (t#p) = p_io [t] @ io \<and> target (t_source t) (t#p) = q"
using FSM.path.cons[OF assms] by auto
then show "q \<in> {target (t_source t) p |p. path M (t_source t) p \<and> p_io p = p_io [t] @ io}"
by blast
qed
lemma observable_io_targets_next :
assumes "observable M"
and "t \<in> transitions M"
shows "io_targets M (p_io [t] @ io) (t_source t) = io_targets M io (t_target t)"
proof
show "io_targets M (p_io [t] @ io) (t_source t) \<subseteq> io_targets M io (t_target t)"
proof
fix q assume "q \<in> io_targets M (p_io [t] @ io) (t_source t)"
then obtain p where "q = target (t_source t) p"
and "path M (t_source t) p"
and "p_io p = p_io [t] @ io"
unfolding io_targets.simps by blast
then have "q = t_target (last p)" unfolding target.simps visited_states.simps
using last_map by auto
obtain t' p' where "p = t' # p'"
using \<open>p_io p = p_io [t] @ io\<close> by auto
then have "t' \<in> transitions M" and "t_source t' = t_source t"
using \<open>path M (t_source t) p\<close> by auto
moreover have "t_input t' = t_input t" and "t_output t' = t_output t"
using \<open>p = t' # p'\<close> \<open>p_io p = p_io [t] @ io\<close> by auto
ultimately have "t' = t"
using \<open>t \<in> transitions M\<close> \<open>observable M\<close> unfolding observable.simps
by (meson prod.expand)
then have "path M (t_target t) p'"
using \<open>path M (t_source t) p\<close> \<open>p = t' # p'\<close> by auto
moreover have "p_io p' = io"
using \<open>p_io p = p_io [t] @ io\<close> \<open>p = t' # p'\<close> by auto
moreover have "q = target (t_target t) p'"
using \<open>q = target (t_source t) p\<close> \<open>p = t' # p'\<close> \<open>t' = t\<close> by auto
ultimately show "q \<in> io_targets M io (t_target t)"
by auto
qed
show "io_targets M io (t_target t) \<subseteq> io_targets M (p_io [t] @ io) (t_source t)"
using io_targets_next[OF assms(2)] by assumption
qed
lemma observable_language_target :
assumes "observable M"
and "q \<in> io_targets M io1 (initial M)"
and "t \<in> io_targets T io1 (initial T)"
and "L T \<subseteq> L M"
shows "LS T t \<subseteq> LS M q"
proof
fix io2 assume "io2 \<in> LS T t"
then obtain pT2 where "path T t pT2" and "p_io pT2 = io2"
by auto
obtain pT1 where "path T (initial T) pT1" and "p_io pT1 = io1" and "target (initial T) pT1 = t"
using \<open>t \<in> io_targets T io1 (initial T)\<close> by auto
then have "path T (initial T) (pT1@pT2)"
using \<open>path T t pT2\<close> using path_append by metis
moreover have "p_io (pT1@pT2) = io1@io2"
using \<open>p_io pT1 = io1\<close> \<open>p_io pT2 = io2\<close> by auto
ultimately have "io1@io2 \<in> L T"
using language_state_containment[of T] by auto
then have "io1@io2 \<in> L M"
using \<open>L T \<subseteq> L M\<close> by blast
then obtain pM where "path M (initial M) pM" and "p_io pM = io1@io2"
by auto
let ?pM1 = "take (length io1) pM"
let ?pM2 = "drop (length io1) pM"
have "path M (initial M) (?pM1@?pM2)"
using \<open>path M (initial M) pM\<close> by auto
then have "path M (initial M) ?pM1" and "path M (target (initial M) ?pM1) ?pM2"
by blast+
have "p_io ?pM1 = io1"
using \<open>p_io pM = io1@io2\<close>
by (metis append_eq_conv_conj take_map)
have "p_io ?pM2 = io2"
using \<open>p_io pM = io1@io2\<close>
by (metis append_eq_conv_conj drop_map)
obtain pM1 where "path M (initial M) pM1" and "p_io pM1 = io1" and "target (initial M) pM1 = q"
using \<open>q \<in> io_targets M io1 (initial M)\<close> by auto
have "pM1 = ?pM1"
using observable_path_unique[OF \<open>observable M\<close> \<open>path M (initial M) pM1\<close> \<open>path M (initial M) ?pM1\<close>]
unfolding \<open>p_io pM1 = io1\<close> \<open>p_io ?pM1 = io1\<close> by simp
then have "path M q ?pM2"
using \<open>path M (target (initial M) ?pM1) ?pM2\<close> \<open>target (initial M) pM1 = q\<close> by auto
then show "io2 \<in> LS M q"
using language_state_containment[OF _ \<open>p_io ?pM2 = io2\<close>, of M] by auto
qed
lemma observable_language_target_failure :
assumes "observable M"
and "q \<in> io_targets M io1 (initial M)"
and "t \<in> io_targets T io1 (initial T)"
and "\<not> LS T t \<subseteq> LS M q"
shows "\<not> L T \<subseteq> L M"
using observable_language_target[OF assms(1,2,3)] assms(4) by blast
lemma language_path_append_transition_observable :
assumes "(p_io p) @ [(x,y)] \<in> LS M q"
and "path M q p"
and "observable M"
obtains t where "path M q (p@[t])" and "t_input t = x" and "t_output t = y"
proof -
obtain p' t where "path M q (p'@[t])" and "p_io (p'@[t]) = (p_io p) @ [(x,y)]"
using language_path_append_transition[OF assms(1)] by blast
then have "path M q p'" and "p_io p' = p_io p" and "t_input t = x" and "t_output t = y"
by auto
have "p' = p"
using observable_path_unique[OF assms(3) \<open>path M q p'\<close> \<open>path M q p\<close> \<open>p_io p' = p_io p\<close>] by assumption
then have "path M q (p@[t])"
using \<open>path M q (p'@[t])\<close> by auto
then show ?thesis using that \<open>t_input t = x\<close> \<open>t_output t = y\<close> by metis
qed
lemma language_io_target_append :
assumes "q' \<in> io_targets M io1 q"
and "io2 \<in> LS M q'"
shows "(io1@io2) \<in> LS M q"
proof -
obtain p2 where "path M q' p2" and "p_io p2 = io2"
using assms(2) by auto
moreover obtain p1 where "q' = target q p1" and "path M q p1" and "p_io p1 = io1"
using assms(1) by auto
ultimately show ?thesis unfolding LS.simps
by (metis (mono_tags, lifting) map_append mem_Collect_eq path_append)
qed
lemma observable_path_suffix :
assumes "(p_io p)@io \<in> LS M q"
and "path M q p"
and "observable M"
obtains p' where "path M (target q p) p'" and "p_io p' = io"
proof -
obtain p1 p2 where "path M q p1" and "path M (target q p1) p2" and "p_io p1 = p_io p" and "p_io p2 = io"
using language_state_split[OF assms(1)] by blast
have "p1 = p"
using observable_path_unique[OF assms(3,2) \<open>path M q p1\<close> \<open>p_io p1 = p_io p\<close>[symmetric]]
by simp
show ?thesis using that[of p2] \<open>path M (target q p1) p2\<close> \<open>p_io p2 = io\<close> unfolding \<open>p1 = p\<close>
by blast
qed
lemma io_targets_finite :
"finite (io_targets M io q)"
proof -
have "(io_targets M io q) \<subseteq> {target q p | p . path M q p \<and> length p \<le> length io}"
unfolding io_targets.simps length_map[of "(\<lambda> t . (t_input t, t_output t))", symmetric] by force
moreover have "finite {target q p | p . path M q p \<and> length p \<le> length io}"
using paths_finite[of M q "length io"]
by simp
ultimately show ?thesis
using rev_finite_subset by blast
qed
lemma language_next_transition_ob :
assumes "(x,y)#ios \<in> LS M q"
obtains t where "t_source t = q"
and "t \<in> transitions M"
and "t_input t = x"
and "t_output t = y"
and "ios \<in> LS M (t_target t)"
proof -
obtain p where "path M q p" and "p_io p = (x,y)#ios"
using assms unfolding LS.simps mem_Collect_eq
by (metis (no_types, lifting))
then obtain t p' where "p = t#p'"
by blast
have "t_source t = q"
and "t \<in> transitions M"
and "path M (t_target t) p'"
using \<open>path M q p\<close> unfolding \<open>p = t#p'\<close> by auto
moreover have "t_input t = x"
and "t_output t = y"
and "p_io p' = ios"
using \<open>p_io p = (x,y)#ios\<close> unfolding \<open>p = t#p'\<close> by auto
ultimately show ?thesis using that[of t] by auto
qed
lemma h_observable_card :
assumes "observable M"
shows "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
and "finite (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)))"
proof -
have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q' . (q,x,y,q') \<in> transitions M}"
unfolding h.simps by force
moreover have "{q' . (q,x,y,q') \<in> transitions M} = {} \<or> (\<exists> q' . {q' . (q,x,y,q') \<in> transitions M} = {q'})"
using assms unfolding observable_alt_def by blast
ultimately show "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
and "finite (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)))"
by auto
qed
lemma h_obs_None :
assumes "observable M"
shows "(h_obs M q x y = None) = (\<nexists>q' . (q,x,y,q') \<in> transitions M)"
proof
show "(h_obs M q x y = None) \<Longrightarrow> (\<nexists>q' . (q,x,y,q') \<in> transitions M)"
proof -
assume "h_obs M q x y = None"
then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<noteq> 1"
by auto
then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 0"
using h_observable_card(1)[OF assms, of y q x] by presburger
then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {}"
using h_observable_card(2)[OF assms, of y q x] card_0_eq[of "(snd ` Set.filter (\<lambda>(y', q'). y' = y) (h M (q, x)))"] by blast
then show ?thesis
unfolding h.simps by force
qed
show "(\<nexists>q' . (q,x,y,q') \<in> transitions M) \<Longrightarrow> (h_obs M q x y = None)"
proof -
assume "(\<nexists>q' . (q,x,y,q') \<in> transitions M)"
then have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {}"
unfolding h.simps by force
then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 0"
by simp
then show ?thesis
unfolding h_obs_simps Let_def \<open>snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {}\<close>
by auto
qed
qed
lemma h_obs_Some :
assumes "observable M"
shows "(h_obs M q x y = Some q') = ({q' . (q,x,y,q') \<in> transitions M} = {q'})"
proof
have *: "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q' . (q,x,y,q') \<in> transitions M}"
unfolding h.simps by force
show "h_obs M q x y = Some q' \<Longrightarrow> ({q' . (q,x,y,q') \<in> transitions M} = {q'})"
proof -
assume "h_obs M q x y = Some q'"
then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<noteq> {}"
by force
then have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) > 0"
unfolding h_simps using fsm_transitions_finite[of M]
by (metis assms card_0_eq h_observable_card(2) h_simps neq0_conv)
moreover have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) \<le> 1"
using assms unfolding observable_alt_def h_simps
by (metis assms h_observable_card(1) h_simps)
ultimately have "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 1"
by auto
then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {q'}"
using \<open>h_obs M q x y = Some q'\<close> unfolding h_obs_simps Let_def
by (metis card_1_singletonE option.inject the_elem_eq)
then show ?thesis
using * unfolding h.simps by blast
qed
show "({q' . (q,x,y,q') \<in> transitions M} = {q'}) \<Longrightarrow> (h_obs M q x y = Some q')"
proof -
assume "({q' . (q,x,y,q') \<in> transitions M} = {q'})"
then have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) = {q'}"
unfolding h.simps by force
then show ?thesis
unfolding Let_def
by simp
qed
qed
lemma h_obs_state :
assumes "h_obs M q x y = Some q'"
shows "q' \<in> states M"
proof (cases "card (snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = 1")
case True
then have "(snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x))) = {q'}"
using \<open>h_obs M q x y = Some q'\<close> unfolding h_obs_simps Let_def
by (metis card_1_singletonE option.inject the_elem_eq)
then have "(q,x,y,q') \<in> transitions M"
unfolding h_simps by auto
then show ?thesis
by (metis fsm_transition_target snd_conv)
next
case False
then have "h_obs M q x y = None"
using False unfolding h_obs_simps Let_def by auto
then show ?thesis using assms by auto
qed
fun after :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> 'a" where
"after M q [] = q" |
"after M q ((x,y)#io) = after M (the (h_obs M q x y)) io"
(*abbreviation(input) "after_initial M io \<equiv> after M (initial M) io" *)
abbreviation "after_initial M io \<equiv> after M (initial M) io"
lemma after_path :
assumes "observable M"
and "path M q p"
shows "after M q (p_io p) = target q p"
using assms(2) proof (induction p arbitrary: q rule: list.induct)
case Nil
then show ?case by auto
next
case (Cons t p)
then have "t \<in> transitions M" and "path M (t_target t) p" and "t_source t = q"
by auto
have "\<And> q' . (q, t_input t, t_output t, q') \<in> FSM.transitions M \<Longrightarrow> q' = t_target t"
using observable_transition_unique[OF assms(1) \<open>t \<in> transitions M\<close>] \<open>t \<in> transitions M\<close>
using \<open>t_source t = q\<close> assms(1) by auto
then have "({q'. (q, t_input t, t_output t, q') \<in> FSM.transitions M} = {t_target t})"
using \<open>t \<in> transitions M\<close> \<open>t_source t = q\<close> by auto
then have "(h_obs M q (t_input t) (t_output t)) = Some (t_target t)"
using h_obs_Some[OF assms(1), of q "t_input t" "t_output t" "t_target t"]
by blast
then have "after M q (p_io (t#p)) = after M (t_target t) (p_io p)"
by auto
moreover have "target (t_target t) p = target q (t#p)"
using \<open>t_source t = q\<close> by auto
ultimately show ?case
using Cons.IH[OF \<open>path M (t_target t) p\<close>]
by simp
qed
lemma observable_after_path :
assumes "observable M"
and "io \<in> LS M q"
obtains p where "path M q p"
and "p_io p = io"
and "target q p = after M q io"
using after_path[OF assms(1)]
using assms(2) by auto
lemma h_obs_from_LS :
assumes "observable M"
and "[(x,y)] \<in> LS M q"
obtains q' where "h_obs M q x y = Some q'"
using assms(2) h_obs_None[OF assms(1), of q x y] by force
lemma after_h_obs :
assumes "observable M"
and "h_obs M q x y = Some q'"
shows "after M q [(x,y)] = q'"
proof -
have "path M q [(q,x,y,q')]"
using assms(2) unfolding h_obs_Some[OF assms(1)]
using single_transition_path by fastforce
then show ?thesis
using assms(2) after_path[OF assms(1), of q "[(q,x,y,q')]"] by auto
qed
lemma after_h_obs_prepend :
assumes "observable M"
and "h_obs M q x y = Some q'"
and "io \<in> LS M q'"
shows "after M q ((x,y)#io) = after M q' io"
proof -
obtain p where "path M q' p" and "p_io p = io"
using assms(3) by auto
then have "after M q' io = target q' p"
using after_path[OF assms(1)]
by blast
have "path M q ((q,x,y,q')#p)"
using assms(2) path_prepend_t[OF \<open>path M q' p\<close>, of q x y] unfolding h_obs_Some[OF assms(1)] by auto
moreover have "p_io ((q,x,y,q')#p) = (x,y)#io"
using \<open>p_io p = io\<close> by auto
ultimately have "after M q ((x,y)#io) = target q ((q,x,y,q')#p)"
using after_path[OF assms(1), of q "(q,x,y,q')#p"] by simp
moreover have "target q ((q,x,y,q')#p) = target q' p"
by auto
ultimately show ?thesis
using \<open>after M q' io = target q' p\<close> by simp
qed
lemma after_split :
assumes "observable M"
and "\<alpha>@\<gamma> \<in> LS M q"
shows "after M (after M q \<alpha>) \<gamma> = after M q (\<alpha> @ \<gamma>)"
proof -
obtain p1 p2 where "path M q p1" and "path M (target q p1) p2" and "p_io p1 = \<alpha>" and "p_io p2 = \<gamma>"
using language_state_split[OF assms(2)]
by blast
then have "path M q (p1@p2)" and "p_io (p1@p2) = (\<alpha> @ \<gamma>)"
by auto
then have "after M q (\<alpha> @ \<gamma>) = target q (p1@p2)"
using assms(1)
by (metis (mono_tags, lifting) after_path)
moreover have "after M q \<alpha> = target q p1"
using \<open>path M q p1\<close> \<open>p_io p1 = \<alpha>\<close> assms(1)
by (metis (mono_tags, lifting) after_path)
moreover have "after M (target q p1) \<gamma> = target (target q p1) p2"
using \<open>path M (target q p1) p2\<close> \<open>p_io p2 = \<gamma>\<close> assms(1)
by (metis (mono_tags, lifting) after_path)
moreover have "target (target q p1) p2 = target q (p1@p2)"
by auto
ultimately show ?thesis
by auto
qed
lemma after_io_targets :
assumes "observable M"
and "io \<in> LS M q"
shows "after M q io = the_elem (io_targets M io q)"
proof -
have "after M q io \<in> io_targets M io q"
using after_path[OF assms(1)] assms(2)
unfolding io_targets.simps LS.simps
by blast
then show ?thesis
using observable_io_targets[OF assms]
by (metis singletonD the_elem_eq)
qed
lemma after_language_subset :
assumes "observable M"
and "\<alpha>@\<gamma> \<in> L M"
and "\<beta> \<in> LS M (after_initial M (\<alpha>@\<gamma>))"
shows "\<gamma>@\<beta> \<in> LS M (after_initial M \<alpha>)"
by (metis after_io_targets after_split assms(1) assms(2) assms(3) language_io_target_append language_prefix observable_io_targets observable_io_targets_language singletonI the_elem_eq)
lemma after_language_append_iff :
assumes "observable M"
and "\<alpha>@\<gamma> \<in> L M"
shows "\<beta> \<in> LS M (after_initial M (\<alpha>@\<gamma>)) = (\<gamma>@\<beta> \<in> LS M (after_initial M \<alpha>))"
by (metis after_io_targets after_language_subset after_split assms(1) assms(2) language_prefix observable_io_targets observable_io_targets_language singletonI the_elem_eq)
lemma h_obs_language_iff :
assumes "observable M"
shows "(x,y)#io \<in> LS M q = (\<exists> q' . h_obs M q x y = Some q' \<and> io \<in> LS M q')"
(is "?P1 = ?P2")
proof
show "?P1 \<Longrightarrow> ?P2"
proof -
assume ?P1
then obtain t p where "t \<in> transitions M"
and "path M (t_target t) p"
and "t_input t = x"
and "t_output t = y"
and "t_source t = q"
and "p_io p = io"
by auto
then have "(q,x,y,t_target t) \<in> transitions M"
by auto
then have "h_obs M q x y = Some (t_target t)"
unfolding h_obs_Some[OF assms]
using assms by auto
moreover have "io \<in> LS M (t_target t)"
using \<open>path M (t_target t) p\<close> \<open>p_io p = io\<close>
by auto
ultimately show ?P2
by blast
qed
show "?P2 \<Longrightarrow> ?P1"
unfolding h_obs_Some[OF assms] using LS_prepend_transition[where io=io and M=M]
by (metis fst_conv mem_Collect_eq singletonI snd_conv)
qed
lemma after_language_iff :
assumes "observable M"
and "\<alpha> \<in> LS M q"
shows "(\<gamma> \<in> LS M (after M q \<alpha>)) = (\<alpha>@\<gamma> \<in> LS M q)"
by (metis after_io_targets assms(1) assms(2) language_io_target_append observable_io_targets observable_io_targets_language singletonI the_elem_eq)
(* TODO: generalise to non-observable FSMs *)
lemma language_maximal_contained_prefix_ob :
assumes "io \<notin> LS M q"
and "q \<in> states M"
and "observable M"
obtains io' x y io'' where "io = io'@[(x,y)]@io''"
and "io' \<in> LS M q"
and "io'@[(x,y)] \<notin> LS M q"
proof -
have "\<exists> io' x y io'' . io = io'@[(x,y)]@io'' \<and> io' \<in> LS M q \<and> io'@[(x,y)] \<notin> LS M q"
using assms(1,2) proof (induction io arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons xy io)
obtain x y where "xy = (x,y)"
by fastforce
show ?case proof (cases "h_obs M q x y")
case None
then have "[]@[(x,y)] \<notin> LS M q"
unfolding h_obs_None[OF assms(3)] by auto
moreover have "[] \<in> LS M q"
using Cons.prems by auto
moreover have "(x,y)#io = []@[(x,y)]@io"
using Cons.prems
unfolding \<open>xy = (x,y)\<close> by auto
ultimately show ?thesis
unfolding \<open>xy = (x,y)\<close> by blast
next
case (Some q')
then have "io \<notin> LS M q'"
using h_obs_language_iff[OF assms(3), of x y io q] Cons.prems(1)
unfolding \<open>xy = (x,y)\<close>
by auto
then obtain io' x' y' io'' where "io = io'@[(x',y')]@io''"
and "io' \<in> LS M q'"
and "io'@[(x',y')] \<notin> LS M q'"
using Cons.IH[OF _ h_obs_state[OF Some]]
by blast
have "xy#io = (xy#io')@[(x',y')]@io''"
using \<open>io = io'@[(x',y')]@io''\<close> by auto
moreover have "(xy#io') \<in> LS M q"
using \<open>io' \<in> LS M q'\<close> Some
unfolding \<open>xy = (x,y)\<close> h_obs_language_iff[OF assms(3)]
by blast
moreover have "(xy#io')@[(x',y')] \<notin> LS M q"
using \<open>io'@[(x',y')] \<notin> LS M q'\<close> Some h_obs_language_iff[OF assms(3), of x y "io'@[(x',y')]" q]
unfolding \<open>xy = (x,y)\<close>
by auto
ultimately show ?thesis
by blast
qed
qed
then show ?thesis
using that by blast
qed
lemma after_is_state :
assumes "observable M"
assumes "io \<in> LS M q"
shows "FSM.after M q io \<in> states M"
using assms
by (metis observable_after_path path_target_is_state)
lemma after_reachable_initial :
assumes "observable M"
and "io \<in> L M"
shows "after_initial M io \<in> reachable_states M"
proof -
obtain p where "path M (initial M) p" and "p_io p = io"
using assms(2) by auto
then have "after_initial M io = target (initial M) p"
using after_path[OF assms(1)]
by blast
then show ?thesis
unfolding reachable_states_def using \<open>path M (initial M) p\<close> by blast
qed
lemma after_transition :
assumes "observable M"
and "(q,x,y,q') \<in> transitions M"
shows "after M q [(x,y)] = q'"
using after_path[OF assms(1) single_transition_path[OF assms(2)]]
by auto
lemma after_transition_exhaust :
assumes "observable M"
and "t \<in> transitions M"
shows "t_target t = after M (t_source t) [(t_input t, t_output t)]"
using after_transition[OF assms(1)] assms(2)
by (metis surjective_pairing)
lemma after_reachable :
assumes "observable M"
and "io \<in> LS M q"
and "q \<in> reachable_states M"
shows "after M q io \<in> reachable_states M"
proof -
obtain p where "path M q p" and "p_io p = io"
using assms(2) by auto
then have "after M q io = target q p"
using after_path[OF assms(1)] by force
obtain p' where "path M (initial M) p'" and "target (initial M) p' = q"
using assms(3) unfolding reachable_states_def by blast
then have "path M (initial M) (p'@p)"
using \<open>path M q p\<close> by auto
moreover have "after M q io = target (initial M) (p'@p)"
using \<open>target (initial M) p' = q\<close>
unfolding \<open>after M q io = target q p\<close>
by auto
ultimately show ?thesis
unfolding reachable_states_def by blast
qed
lemma observable_after_language_append :
assumes "observable M"
and "io1 \<in> LS M q"
and "io2 \<in> LS M (after M q io1)"
shows "io1@io2 \<in> LS M q"
using observable_after_path[OF assms(1,2)] assms(3)
proof -
assume a1: "\<And>thesis. (\<And>p. \<lbrakk>path M q p; p_io p = io1; target q p = after M q io1\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis"
have "\<exists>ps. io2 = p_io ps \<and> path M (after M q io1) ps"
using \<open>io2 \<in> LS M (after M q io1)\<close> by auto
moreover
{ assume "(\<exists>ps. io2 = p_io ps \<and> path M (after M q io1) ps) \<and> (\<forall>ps. io1 @ io2 \<noteq> p_io ps \<or> \<not> path M q ps)"
then have "io1 @ io2 \<in> {p_io ps |ps. path M q ps}"
using a1 by (metis (lifting) map_append path_append) }
ultimately show ?thesis
by auto
qed
lemma observable_after_language_none :
assumes "observable M"
and "io1 \<in> LS M q"
and "io2 \<notin> LS M (after M q io1)"
shows "io1@io2 \<notin> LS M q"
using after_path[OF assms(1)] language_state_split[of io1 io2 M q]
by (metis (mono_tags, lifting) assms(3) language_intro)
lemma observable_after_eq :
assumes "observable M"
and "after M q io1 = after M q io2"
and "io1 \<in> LS M q"
and "io2 \<in> LS M q"
shows "io1@io \<in> LS M q \<longleftrightarrow> io2@io \<in> LS M q"
using observable_after_language_append[OF assms(1,3), of io]
observable_after_language_append[OF assms(1,4), of io]
assms(2)
by (metis assms(1) language_prefix observable_after_language_none)
lemma observable_after_target :
assumes "observable M"
and "io @ io' \<in> LS M q"
and "path M (FSM.after M q io) p"
and "p_io p = io'"
shows "target (FSM.after M q io) p = (FSM.after M q (io @ io'))"
proof -
obtain p' where "path M q p'" and "p_io p' = io @ io'"
using \<open>io @ io' \<in> LS M q\<close> by auto
then have "path M q (take (length io) p')"
and "p_io (take (length io) p') = io"
and "path M (target q (take (length io) p')) (drop (length io) p')"
and "p_io (drop (length io) p') = io'"
using path_io_split[of M q p' io io']
by auto
then have "FSM.after M q io = target q (take (length io) p')"
using after_path assms(1) by fastforce
then have "p = (drop (length io) p')"
using \<open>path M (target q (take (length io) p')) (drop (length io) p')\<close> \<open>p_io (drop (length io) p') = io'\<close>
assms(3,4)
observable_path_unique[OF \<open>observable M\<close>]
by force
have "(FSM.after M q (io @ io')) = target q p'"
using after_path[OF \<open>observable M\<close> \<open>path M q p'\<close>] unfolding \<open>p_io p' = io @ io'\<close> .
moreover have "target (FSM.after M q io) p = target q p'"
using \<open>FSM.after M q io = target q (take (length io) p')\<close>
by (metis \<open>p = drop (length io) p'\<close> append_take_drop_id path_append_target)
ultimately show ?thesis
by simp
qed
fun is_in_language :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
"is_in_language M q [] = True" |
"is_in_language M q ((x,y)#io) = (case h_obs M q x y of
None \<Rightarrow> False |
Some q' \<Rightarrow> is_in_language M q' io)"
lemma is_in_language_iff :
assumes "observable M"
and "q \<in> states M"
shows "is_in_language M q io \<longleftrightarrow> io \<in> LS M q"
using assms(2) proof (induction io arbitrary: q)
case Nil
then show ?case
by auto
next
case (Cons xy io)
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
show ?case
unfolding \<open>xy = (x,y)\<close>
unfolding h_obs_language_iff[OF assms(1), of x y io q]
unfolding is_in_language.simps
apply (cases "h_obs M q x y")
apply auto[1]
by (metis Cons.IH h_obs_state option.simps(5))
qed
lemma observable_paths_for_io :
assumes "observable M"
and "io \<in> LS M q"
obtains p where "paths_for_io M q io = {p}"
proof -
obtain p where "path M q p" and "p_io p = io"
using assms(2) by auto
then have "p \<in> paths_for_io M q io"
unfolding paths_for_io_def
by blast
then show ?thesis
using that[of p]
using observable_path_unique[OF assms(1) \<open>path M q p\<close>] \<open>p_io p = io\<close>
unfolding paths_for_io_def
by force
qed
lemma io_targets_language :
assumes "q' \<in> io_targets M io q"
shows "io \<in> LS M q"
using assms by auto
lemma observable_after_reachable_surj :
assumes "observable M"
shows "(after_initial M) ` (L M) = reachable_states M"
proof
show "after_initial M ` L M \<subseteq> reachable_states M"
using after_reachable[OF assms _ reachable_states_initial]
by blast
show "reachable_states M \<subseteq> after_initial M ` L M"
unfolding reachable_states_def
using after_path[OF assms]
using image_iff by fastforce
qed
lemma observable_minimal_size_r_language_distinct :
assumes "minimal M1"
and "minimal M2"
and "observable M1"
and "observable M2"
and "size_r M1 < size_r M2"
shows "L M1 \<noteq> L M2"
proof
assume "L M1 = L M2"
define V where "V = (\<lambda> q . SOME io . io \<in> L M1 \<and> after_initial M2 io = q)"
have "\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q"
proof -
fix q assume "q \<in> reachable_states M2"
then have "\<exists> io . io \<in> L M1 \<and> after_initial M2 io = q"
unfolding \<open>L M1 = L M2\<close>
by (metis assms(4) imageE observable_after_reachable_surj)
then show "V q \<in> L M1 \<and> after_initial M2 (V q) = q"
unfolding V_def
using someI_ex[of "\<lambda> io . io \<in> L M1 \<and> after_initial M2 io = q"] by blast
qed
then have "(after_initial M1) ` V ` reachable_states M2 \<subseteq> reachable_states M1"
by (metis assms(3) image_mono image_subsetI observable_after_reachable_surj)
then have "card (after_initial M1 ` V ` reachable_states M2) \<le> size_r M1"
using reachable_states_finite[of M1]
by (meson card_mono)
have "(after_initial M2) ` V ` reachable_states M2 = reachable_states M2"
proof
show "after_initial M2 ` V ` reachable_states M2 \<subseteq> reachable_states M2"
using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> by auto
show "reachable_states M2 \<subseteq> after_initial M2 ` V ` reachable_states M2"
using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> observable_after_reachable_surj[OF assms(4)] unfolding \<open>L M1 = L M2\<close>
using image_iff by fastforce
qed
then have "card ((after_initial M2) ` V ` reachable_states M2) = size_r M2"
by auto
have *: "finite (V ` reachable_states M2)"
by (simp add: reachable_states_finite)
have **: "card ((after_initial M1) ` V ` reachable_states M2) < card ((after_initial M2) ` V ` reachable_states M2)"
using assms(5) \<open>card (after_initial M1 ` V ` reachable_states M2) \<le> size_r M1\<close>
unfolding \<open>card ((after_initial M2) ` V ` reachable_states M2) = size_r M2\<close>
by linarith
obtain io1 io2 where "io1 \<in> V ` reachable_states M2"
"io2 \<in> V ` reachable_states M2"
"after_initial M2 io1 \<noteq> after_initial M2 io2"
"after_initial M1 io1 = after_initial M1 io2"
using finite_card_less_witnesses[OF * **]
by blast
then have "io1 \<in> L M1" and "io2 \<in> L M1" and "io1 \<in> L M2" and "io2 \<in> L M2"
using \<open>\<And> q . q \<in> reachable_states M2 \<Longrightarrow> V q \<in> L M1 \<and> after_initial M2 (V q) = q\<close> unfolding \<open>L M1 = L M2\<close>
by auto
then have "after_initial M1 io1 \<in> reachable_states M1"
"after_initial M1 io2 \<in> reachable_states M1"
"after_initial M2 io1 \<in> reachable_states M2"
"after_initial M2 io2 \<in> reachable_states M2"
using after_reachable[OF assms(3) _ reachable_states_initial] after_reachable[OF assms(4) _ reachable_states_initial]
by blast+
obtain io3 where "io3 \<in> LS M2 (after_initial M2 io1) = (io3 \<notin> LS M2 (after_initial M2 io2))"
using reachable_state_is_state[OF \<open>after_initial M2 io1 \<in> reachable_states M2\<close>]
reachable_state_is_state[OF \<open>after_initial M2 io2 \<in> reachable_states M2\<close>]
\<open>after_initial M2 io1 \<noteq> after_initial M2 io2\<close> assms(2)
unfolding minimal.simps by blast
then have "io1@io3 \<in> L M2 = (io2@io3 \<notin> L M2)"
using observable_after_language_append[OF assms(4) \<open>io1 \<in> L M2\<close>]
observable_after_language_append[OF assms(4) \<open>io2 \<in> L M2\<close>]
observable_after_language_none[OF assms(4) \<open>io1 \<in> L M2\<close>]
observable_after_language_none[OF assms(4) \<open>io2 \<in> L M2\<close>]
by blast
moreover have "io1@io3 \<in> L M1 = (io2@io3 \<in> L M1)"
by (meson \<open>after_initial M1 io1 = after_initial M1 io2\<close> \<open>io1 \<in> L M1\<close> \<open>io2 \<in> L M1\<close> assms(3) observable_after_eq)
ultimately show False
using \<open>L M1 = L M2\<close> by blast
qed
(* language equivalent minimal FSMs have the same number of reachable states *)
lemma minimal_equivalence_size_r :
assumes "minimal M1"
and "minimal M2"
and "observable M1"
and "observable M2"
and "L M1 = L M2"
shows "size_r M1 = size_r M2"
using observable_minimal_size_r_language_distinct[OF assms(1-4)]
observable_minimal_size_r_language_distinct[OF assms(2,1,4,3)]
assms(5)
using nat_neq_iff by auto
subsection \<open>Conformity Relations\<close>
fun is_io_reduction_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> 'd \<Rightarrow> bool" where
"is_io_reduction_state A a B b = (LS A a \<subseteq> LS B b)"
abbreviation(input) "is_io_reduction A B \<equiv> is_io_reduction_state A (initial A) B (initial B)"
notation
is_io_reduction ("_ \<preceq> _")
fun is_io_reduction_state_on_inputs :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b list set \<Rightarrow> ('d,'b,'c) fsm \<Rightarrow> 'd \<Rightarrow> bool" where
"is_io_reduction_state_on_inputs A a U B b = (LS\<^sub>i\<^sub>n A a U \<subseteq> LS\<^sub>i\<^sub>n B b U)"
abbreviation(input) "is_io_reduction_on_inputs A U B \<equiv> is_io_reduction_state_on_inputs A (initial A) U B (initial B)"
notation
is_io_reduction_on_inputs ("_ \<preceq>\<lbrakk>_\<rbrakk> _")
subsection \<open>A Pass Relation for Reduction and Test Represented as Sets of Input-Output Sequences\<close>
definition pass_io_set :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
"pass_io_set M ios = (\<forall> io x y . io@[(x,y)] \<in> ios \<longrightarrow> (\<forall> y' . io@[(x,y')] \<in> L M \<longrightarrow> io@[(x,y')] \<in> ios))"
definition pass_io_set_maximal :: "('a,'b,'c) fsm \<Rightarrow> ('b \<times> 'c) list set \<Rightarrow> bool" where
"pass_io_set_maximal M ios = (\<forall> io x y io' . io@[(x,y)]@io' \<in> ios \<longrightarrow> (\<forall> y' . io@[(x,y')] \<in> L M \<longrightarrow> (\<exists> io''. io@[(x,y')]@io'' \<in> ios)))"
lemma pass_io_set_from_pass_io_set_maximal :
"pass_io_set_maximal M ios = pass_io_set M {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios}"
proof -
have "\<And> io x y io' . io@[(x,y)]@io' \<in> ios \<Longrightarrow> io@[(x,y)] \<in> {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios}"
by auto
moreover have "\<And> io x y . io@[(x,y)] \<in> {io' . \<exists> io io'' . io = io'@io'' \<and> io \<in> ios} \<Longrightarrow> \<exists> io' . io@[(x,y)]@io' \<in> ios"
by auto
ultimately show ?thesis
unfolding pass_io_set_def pass_io_set_maximal_def
by meson
qed
lemma pass_io_set_maximal_from_pass_io_set :
assumes "finite ios"
and "\<And> io' io'' . io'@io'' \<in> ios \<Longrightarrow> io' \<in> ios"
shows "pass_io_set M ios = pass_io_set_maximal M {io' \<in> ios . \<not> (\<exists> io'' . io'' \<noteq> [] \<and> io'@io'' \<in> ios)}"
proof -
have "\<And> io x y . io@[(x,y)] \<in> ios \<Longrightarrow> \<exists> io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)}"
proof -
fix io x y assume "io@[(x,y)] \<in> ios"
show "\<exists> io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)}"
using finite_set_elem_maximal_extension_ex[OF \<open>io@[(x,y)] \<in> ios\<close> assms(1)] by force
qed
moreover have "\<And> io x y io' . io@[(x,y)]@io' \<in> {io'' \<in> ios . \<not> (\<exists> io''' . io''' \<noteq> [] \<and> io''@io''' \<in> ios)} \<Longrightarrow> io@[(x,y)] \<in> ios"
using \<open>\<And> io' io'' . io'@io'' \<in> ios \<Longrightarrow> io' \<in> ios\<close> by force
ultimately show ?thesis
unfolding pass_io_set_def pass_io_set_maximal_def
by meson
qed
subsection \<open>Relaxation of IO based test suites to sets of input sequences\<close>
abbreviation(input) "input_portion xs \<equiv> map fst xs"
lemma equivalence_io_relaxation :
assumes "(L M1 = L M2) \<longleftrightarrow> (L M1 \<inter> T = L M2 \<inter> T)"
shows "(L M1 = L M2) \<longleftrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
proof
show "(L M1 = L M2) \<Longrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
by blast
show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 = L M2"
proof -
have *:"\<And> M . {io . io \<in> L M \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = L M \<inter> {io . \<exists> io' \<in> T . input_portion io = input_portion io'}"
by blast
have "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> (L M1 \<inter> T = L M2 \<inter> T)"
unfolding * by blast
then show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} = {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 = L M2"
using assms by blast
qed
qed
lemma reduction_io_relaxation :
assumes "(L M1 \<subseteq> L M2) \<longleftrightarrow> (L M1 \<inter> T \<subseteq> L M2 \<inter> T)"
shows "(L M1 \<subseteq> L M2) \<longleftrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
proof
show "(L M1 \<subseteq> L M2) \<Longrightarrow> ({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')})"
by blast
show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 \<subseteq> L M2"
proof -
have *:"\<And> M . {io . io \<in> L M \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> L M \<inter> {io . \<exists> io' \<in> T . input_portion io = input_portion io'}"
by blast
have "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> (L M1 \<inter> T \<subseteq> L M2 \<inter> T)"
unfolding * by blast
then show "({io . io \<in> L M1 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')} \<subseteq> {io . io \<in> L M2 \<and> (\<exists> io' \<in> T . input_portion io = input_portion io')}) \<Longrightarrow> L M1 \<subseteq> L M2"
using assms by blast
qed
qed
subsection \<open>Submachines\<close>
fun is_submachine :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm \<Rightarrow> bool" where
"is_submachine A B = (initial A = initial B \<and> transitions A \<subseteq> transitions B \<and> inputs A = inputs B \<and> outputs A = outputs B \<and> states A \<subseteq> states B)"
lemma submachine_path_initial :
assumes "is_submachine A B"
and "path A (initial A) p"
shows "path B (initial B) p"
using assms proof (induction p rule: rev_induct)
case Nil
then show ?case by auto
next
case (snoc a p)
then show ?case
by fastforce
qed
lemma submachine_path :
assumes "is_submachine A B"
and "path A q p"
shows "path B q p"
by (meson assms(1) assms(2) is_submachine.elims(2) path_begin_state subsetD transition_subset_path)
lemma submachine_reduction :
assumes "is_submachine A B"
shows "is_io_reduction A B"
using submachine_path[OF assms] assms by auto
lemma complete_submachine_initial :
assumes "is_submachine A B"
and "completely_specified A"
shows "completely_specified_state B (initial B)"
using assms(1) assms(2) fsm_initial subset_iff by fastforce
lemma submachine_language :
assumes "is_submachine S M"
shows "L S \<subseteq> L M"
by (meson assms is_io_reduction_state.elims(2) submachine_reduction)
lemma submachine_observable :
assumes "is_submachine S M"
and "observable M"
shows "observable S"
using assms unfolding is_submachine.simps observable.simps by blast
lemma submachine_transitive :
assumes "is_submachine S M"
and "is_submachine S' S"
shows "is_submachine S' M"
using assms unfolding is_submachine.simps by force
lemma transitions_subset_path :
assumes "set p \<subseteq> transitions M"
and "p \<noteq> []"
and "path S q p"
shows "path M q p"
using assms by (induction p arbitrary: q; auto)
lemma transition_subset_paths :
assumes "transitions S \<subseteq> transitions M"
and "initial S \<in> states M"
and "inputs S = inputs M"
and "outputs S = outputs M"
and "path S (initial S) p"
shows "path M (initial S) p"
using assms(5) proof (induction p rule: rev_induct)
case Nil
then show ?case using assms(2) by auto
next
case (snoc t p)
then have "path S (initial S) p"
and "t \<in> transitions S"
and "t_source t = target (initial S) p"
and "path M (initial S) p"
by auto
have "t \<in> transitions M"
using assms(1) \<open>t \<in> transitions S\<close> by auto
moreover have "t_source t \<in> states M"
using \<open>t_source t = target (initial S) p\<close> \<open>path M (initial S) p\<close>
using path_target_is_state by fastforce
ultimately have "t \<in> transitions M"
using \<open>t \<in> transitions S\<close> assms(3,4) by auto
then show ?case
using \<open>path M (initial S) p\<close>
using snoc.prems by auto
qed
lemma submachine_reachable_subset :
assumes "is_submachine A B"
shows "reachable_states A \<subseteq> reachable_states B"
using assms submachine_path_initial[OF assms]
unfolding is_submachine.simps reachable_states_def by force
lemma submachine_simps :
assumes "is_submachine A B"
shows "initial A = initial B"
and "states A \<subseteq> states B"
and "inputs A = inputs B"
and "outputs A = outputs B"
and "transitions A \<subseteq> transitions B"
using assms unfolding is_submachine.simps by blast+
lemma submachine_deadlock :
assumes "is_submachine A B"
and "deadlock_state B q"
shows "deadlock_state A q"
using assms(1) assms(2) in_mono by auto
subsection \<open>Changing Initial States\<close>
lift_definition from_FSM :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.from_FSMI
by simp
lemma from_FSM_simps[simp]:
assumes "q \<in> states M"
shows
"initial (from_FSM M q) = q"
"inputs (from_FSM M q) = inputs M"
"outputs (from_FSM M q) = outputs M"
"transitions (from_FSM M q) = transitions M"
"states (from_FSM M q) = states M" using assms by (transfer; simp)+
lemma from_FSM_path_initial :
assumes "q \<in> states M"
shows "path M q p = path (from_FSM M q) (initial (from_FSM M q)) p"
by (metis assms from_FSM_simps(1) from_FSM_simps(4) from_FSM_simps(5) order_refl
transition_subset_path)
lemma from_FSM_path :
assumes "q \<in> states M"
and "path (from_FSM M q) q' p"
shows "path M q' p"
using assms(1) assms(2) path_transitions transitions_subset_path by fastforce
lemma from_FSM_reachable_states :
assumes "q \<in> reachable_states M"
shows "reachable_states (from_FSM M q) \<subseteq> reachable_states M"
proof
from assms obtain p where "path M (initial M) p" and "target (initial M) p = q"
unfolding reachable_states_def by blast
then have "q \<in> states M"
by (meson path_target_is_state)
fix q' assume "q' \<in> reachable_states (from_FSM M q)"
then obtain p' where "path (from_FSM M q) q p'" and "target q p' = q'"
unfolding reachable_states_def from_FSM_simps[OF \<open>q \<in> states M\<close>] by blast
then have "path M (initial M) (p@p')" and "target (initial M) (p@p') = q'"
using from_FSM_path[OF \<open>q \<in> states M\<close> ] \<open>path M (initial M) p\<close>
using \<open>target (FSM.initial M) p = q\<close> by auto
then show "q' \<in> reachable_states M"
unfolding reachable_states_def by blast
qed
lemma submachine_from :
assumes "is_submachine S M"
and "q \<in> states S"
shows "is_submachine (from_FSM S q) (from_FSM M q)"
proof -
have "path S q []"
using assms(2) by blast
then have "path M q []"
by (meson assms(1) submachine_path)
then show ?thesis
using assms(1) assms(2) by force
qed
lemma from_FSM_path_rev_initial :
assumes "path M q p"
shows "path (from_FSM M q) q p"
by (metis (no_types) assms from_FSM_path_initial from_FSM_simps(1) path_begin_state)
lemma from_from[simp] :
assumes "q1 \<in> states M"
and "q1' \<in> states M"
shows "from_FSM (from_FSM M q1) q1' = from_FSM M q1'" (is "?M = ?M'")
proof -
have *: "q1' \<in> states (from_FSM M q1)"
using assms(2) unfolding from_FSM_simps(5)[OF assms(1)] by assumption
have "initial ?M = initial ?M'"
and "states ?M = states ?M'"
and "inputs ?M = inputs ?M'"
and "outputs ?M = outputs ?M'"
and "transitions ?M = transitions ?M'"
unfolding from_FSM_simps[OF *] from_FSM_simps[OF assms(1)] from_FSM_simps[OF assms(2)] by simp+
then show ?thesis by (transfer; force)
qed
lemma from_FSM_completely_specified :
assumes "completely_specified M"
shows "completely_specified (from_FSM M q)" proof (cases "q \<in> states M")
case True
then show ?thesis
using assms by auto
next
case False
then have "from_FSM M q = M" by (transfer; auto)
then show ?thesis using assms by auto
qed
lemma from_FSM_single_input :
assumes "single_input M"
shows "single_input (from_FSM M q)" proof (cases "q \<in> states M")
case True
then show ?thesis
using assms
by (metis from_FSM_simps(4) single_input.elims(1))
next
case False
then have "from_FSM M q = M" by (transfer; auto)
then show ?thesis using assms
by presburger
qed
lemma from_FSM_acyclic :
assumes "q \<in> reachable_states M"
and "acyclic M"
shows "acyclic (from_FSM M q)"
using assms(1)
acyclic_paths_from_reachable_states[OF assms(2), of _ q]
from_FSM_path[of q M q]
path_target_is_state
reachable_state_is_state[OF assms(1)]
from_FSM_simps(1)
unfolding acyclic.simps
reachable_states_def
by force
lemma from_FSM_observable :
assumes "observable M"
shows "observable (from_FSM M q)"
proof (cases "q \<in> states M")
case True
then show ?thesis
using assms
proof -
have f1: "\<forall>f. observable f = (\<forall>a b c aa ab. ((a::'a, b::'b, c::'c, aa) \<notin> FSM.transitions f \<or> (a, b, c, ab) \<notin> FSM.transitions f) \<or> aa = ab)"
by force
have "\<forall>a f. a \<notin> FSM.states (f::('a, 'b, 'c) fsm) \<or> FSM.transitions (FSM.from_FSM f a) = FSM.transitions f"
by (meson from_FSM_simps(4))
then show ?thesis
using f1 True assms by presburger
qed
next
case False
then have "from_FSM M q = M" by (transfer; auto)
then show ?thesis using assms by presburger
qed
lemma observable_language_next :
assumes "io#ios \<in> LS M (t_source t)"
and "observable M"
and "t \<in> transitions M"
and "t_input t = fst io"
and "t_output t = snd io"
shows "ios \<in> L (from_FSM M (t_target t))"
proof -
obtain p where "path M (t_source t) p" and "p_io p = io#ios"
using assms(1)
proof -
assume a1: "\<And>p. \<lbrakk>path M (t_source t) p; p_io p = io # ios\<rbrakk> \<Longrightarrow> thesis"
obtain pps :: "('a \<times> 'b) list \<Rightarrow> 'c \<Rightarrow> ('c, 'a, 'b) fsm \<Rightarrow> ('c \<times> 'a \<times> 'b \<times> 'c) list" where
"\<forall>x0 x1 x2. (\<exists>v3. x0 = p_io v3 \<and> path x2 x1 v3) = (x0 = p_io (pps x0 x1 x2) \<and> path x2 x1 (pps x0 x1 x2))"
by moura
then have "\<exists>ps. path M (t_source t) ps \<and> p_io ps = io # ios"
using assms(1) by auto
then show ?thesis
using a1 by meson
qed
then obtain t' p' where "p = t' # p'"
by auto
then have "t' \<in> transitions M" and "t_source t' = t_source t" and "t_input t' = fst io" and "t_output t' = snd io"
using \<open>path M (t_source t) p\<close> \<open>p_io p = io#ios\<close> by auto
then have "t = t'"
using assms(2,3,4,5) unfolding observable.simps
by (metis (no_types, opaque_lifting) prod.expand)
then have "path M (t_target t) p'" and "p_io p' = ios"
using \<open>p = t' # p'\<close> \<open>path M (t_source t) p\<close> \<open>p_io p = io#ios\<close> by auto
then have "path (from_FSM M (t_target t)) (initial (from_FSM M (t_target t))) p'"
by (meson assms(3) from_FSM_path_initial fsm_transition_target)
then show ?thesis using \<open>p_io p' = ios\<close> by auto
qed
lemma from_FSM_language :
assumes "q \<in> states M"
shows "L (from_FSM M q) = LS M q"
using assms unfolding LS.simps by (meson from_FSM_path_initial)
lemma observable_transition_target_language_subset :
assumes "LS M (t_source t1) \<subseteq> LS M (t_source t2)"
and "t1 \<in> transitions M"
and "t2 \<in> transitions M"
and "t_input t1 = t_input t2"
and "t_output t1 = t_output t2"
and "observable M"
shows "LS M (t_target t1) \<subseteq> LS M (t_target t2)"
proof (rule ccontr)
assume "\<not> LS M (t_target t1) \<subseteq> LS M (t_target t2)"
then obtain ioF where "ioF \<in> LS M (t_target t1)" and "ioF \<notin> LS M (t_target t2)"
by blast
then have "(t_input t1, t_output t1)#ioF \<in> LS M (t_source t1)"
using LS_prepend_transition assms(2) by blast
then have *: "(t_input t1, t_output t1)#ioF \<in> LS M (t_source t2)"
using assms(1) by blast
have "ioF \<in> LS M (t_target t2)"
using observable_language_next[OF * \<open>observable M\<close> \<open>t2 \<in> transitions M\<close> ] unfolding assms(4,5) fst_conv snd_conv
by (metis assms(3) from_FSM_language fsm_transition_target)
then show False
using \<open>ioF \<notin> LS M (t_target t2)\<close> by blast
qed
lemma observable_transition_target_language_eq :
assumes "LS M (t_source t1) = LS M (t_source t2)"
and "t1 \<in> transitions M"
and "t2 \<in> transitions M"
and "t_input t1 = t_input t2"
and "t_output t1 = t_output t2"
and "observable M"
shows "LS M (t_target t1) = LS M (t_target t2)"
using observable_transition_target_language_subset[OF _ assms(2,3,4,5,6)]
observable_transition_target_language_subset[OF _ assms(3,2) assms(4,5)[symmetric] assms(6)]
assms(1)
by blast
lemma language_state_prepend_transition :
assumes "io \<in> LS (from_FSM A (t_target t)) (initial (from_FSM A (t_target t)))"
and "t \<in> transitions A"
shows "p_io [t] @ io \<in> LS A (t_source t)"
proof -
obtain p where "path (from_FSM A (t_target t)) (initial (from_FSM A (t_target t))) p"
and "p_io p = io"
using assms(1) unfolding LS.simps by blast
then have "path A (t_target t) p"
by (meson assms(2) from_FSM_path_initial fsm_transition_target)
then have "path A (t_source t) (t # p)"
using assms(2) by auto
then show ?thesis
using \<open>p_io p = io\<close> unfolding LS.simps
by force
qed
lemma observable_language_transition_target :
assumes "observable M"
and "t \<in> transitions M"
and "(t_input t, t_output t) # io \<in> LS M (t_source t)"
shows "io \<in> LS M (t_target t)"
by (metis (no_types) assms(1) assms(2) assms(3) from_FSM_language fsm_transition_target fst_conv observable_language_next snd_conv)
lemma LS_single_transition :
"[(x,y)] \<in> LS M q \<longleftrightarrow> (\<exists> t \<in> transitions M . t_source t = q \<and> t_input t = x \<and> t_output t = y)"
proof
show "[(x, y)] \<in> LS M q \<Longrightarrow> \<exists>t\<in>FSM.transitions M. t_source t = q \<and> t_input t = x \<and> t_output t = y"
by auto
show "\<exists>t\<in>FSM.transitions M. t_source t = q \<and> t_input t = x \<and> t_output t = y \<Longrightarrow> [(x, y)] \<in> LS M q"
by (metis LS_prepend_transition from_FSM_language fsm_transition_target language_contains_empty_sequence)
qed
lemma h_obs_language_append :
assumes "observable M"
and "u \<in> L M"
and "h_obs M (after_initial M u) x y \<noteq> None"
shows "u@[(x,y)] \<in> L M"
using after_language_iff[OF assms(1,2), of "[(x,y)]"]
using h_obs_None[OF assms(1)] assms(3)
unfolding LS_single_transition
by (metis old.prod.inject prod.collapse)
lemma h_obs_language_single_transition_iff :
assumes "observable M"
shows "[(x,y)] \<in> LS M q \<longleftrightarrow> h_obs M q x y \<noteq> None"
using h_obs_None[OF assms(1), of q x y]
unfolding LS_single_transition
by (metis fst_conv prod.exhaust_sel snd_conv)
(* TODO: generalise to non-observable FSMs *)
lemma minimal_failure_prefix_ob :
assumes "observable M"
and "observable I"
and "qM \<in> states M"
and "qI \<in> states I"
and "io \<in> LS I qI - LS M qM"
obtains io' xy io'' where "io = io'@[xy]@io''"
and "io' \<in> LS I qI \<inter> LS M qM"
and "io'@[xy] \<in> LS I qI - LS M qM"
proof -
have "\<exists> io' xy io'' . io = io'@[xy]@io'' \<and> io' \<in> LS I qI \<inter> LS M qM \<and> io'@[xy] \<in> LS I qI - LS M qM"
using assms(3,4,5) proof (induction io arbitrary: qM qI)
case Nil
then show ?case by auto
next
case (Cons xy io)
show ?case proof (cases "[xy] \<in> LS I qI - LS M qM")
case True
have "xy # io = []@[xy]@io"
by auto
moreover have "[] \<in> LS I qI \<inter> LS M qM"
using \<open>qM \<in> states M\<close> \<open>qI \<in> states I\<close> by auto
moreover have "[]@[xy] \<in> LS I qI - LS M qM"
using True by auto
ultimately show ?thesis
by blast
next
case False
obtain x y where "xy = (x,y)"
by (meson surj_pair)
have "[(x,y)] \<in> LS M qM"
using \<open>xy = (x,y)\<close> False \<open>xy # io \<in> LS I qI - LS M qM\<close>
by (metis DiffD1 DiffI append_Cons append_Nil language_prefix)
then obtain qM' where "(qM,x,y,qM') \<in> transitions M"
by auto
then have "io \<notin> LS M qM'"
using observable_language_transition_target[OF \<open>observable M\<close>]
\<open>xy = (x,y)\<close> \<open>xy # io \<in> LS I qI - LS M qM\<close>
by (metis DiffD2 LS_prepend_transition fst_conv snd_conv)
have "[(x,y)] \<in> LS I qI"
using \<open>xy = (x,y)\<close> \<open>xy # io \<in> LS I qI - LS M qM\<close>
by (metis DiffD1 append_Cons append_Nil language_prefix)
then obtain qI' where "(qI,x,y,qI') \<in> transitions I"
by auto
then have "io \<in> LS I qI'"
using observable_language_next[of xy io I "(qI,x,y,qI')", OF _ \<open>observable I\<close>]
\<open>xy # io \<in> LS I qI - LS M qM\<close> fsm_transition_target[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>]
unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv
by (metis DiffD1 from_FSM_language)
obtain io' xy' io'' where "io = io'@[xy']@io''" and "io' \<in> LS I qI' \<inter> LS M qM'" and "io'@[xy'] \<in> LS I qI' - LS M qM'"
using \<open>io \<in> LS I qI'\<close> \<open>io \<notin> LS M qM'\<close>
Cons.IH[OF fsm_transition_target[OF \<open>(qM,x,y,qM') \<in> transitions M\<close>]
fsm_transition_target[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>] ]
unfolding fst_conv snd_conv
by blast
have "xy#io = (xy#io')@[xy']@io''"
using \<open>io = io'@[xy']@io''\<close> \<open>xy = (x,y)\<close> by auto
moreover have "xy#io' \<in> LS I qI \<inter> LS M qM"
using LS_prepend_transition[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>, of io']
using LS_prepend_transition[OF \<open>(qM,x,y,qM') \<in> transitions M\<close>, of io']
using \<open>io' \<in> LS I qI' \<inter> LS M qM'\<close>
unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv
by auto
moreover have "(xy#io')@[xy'] \<in> LS I qI - LS M qM"
using LS_prepend_transition[OF \<open>(qI,x,y,qI') \<in> transitions I\<close>, of "io'@[xy']"]
using observable_language_transition_target[OF \<open>observable M\<close> \<open>(qM,x,y,qM') \<in> transitions M\<close>, of "io'@[xy']"]
using \<open>io'@[xy'] \<in> LS I qI' - LS M qM'\<close>
unfolding \<open>xy = (x,y)\<close> fst_conv snd_conv
by fastforce
ultimately show ?thesis
by blast
qed
qed
then show ?thesis
using that by blast
qed
subsection \<open>Language and Defined Inputs\<close>
lemma defined_inputs_code : "defined_inputs M q = t_input ` Set.filter (\<lambda>t . t_source t = q) (transitions M)"
unfolding defined_inputs_set by force
lemma defined_inputs_alt_def : "defined_inputs M q = {t_input t | t . t \<in> transitions M \<and> t_source t = q}"
unfolding defined_inputs_code by force
lemma defined_inputs_language_diff :
assumes "x \<in> defined_inputs M1 q1"
and "x \<notin> defined_inputs M2 q2"
obtains y where "[(x,y)] \<in> LS M1 q1 - LS M2 q2"
using assms unfolding defined_inputs_alt_def
proof -
assume a1: "x \<notin> {t_input t |t. t \<in> FSM.transitions M2 \<and> t_source t = q2}"
assume a2: "x \<in> {t_input t |t. t \<in> FSM.transitions M1 \<and> t_source t = q1}"
assume a3: "\<And>y. [(x, y)] \<in> LS M1 q1 - LS M2 q2 \<Longrightarrow> thesis"
have f4: "\<nexists>p. x = t_input p \<and> p \<in> FSM.transitions M2 \<and> t_source p = q2"
using a1 by blast
obtain pp :: "'a \<Rightarrow> 'b \<times> 'a \<times> 'c \<times> 'b" where
"\<forall>a. ((\<nexists>p. a = t_input p \<and> p \<in> FSM.transitions M1 \<and> t_source p = q1) \<or> a = t_input (pp a) \<and> pp a \<in> FSM.transitions M1 \<and> t_source (pp a) = q1) \<and> ((\<exists>p. a = t_input p \<and> p \<in> FSM.transitions M1 \<and> t_source p = q1) \<or> (\<forall>p. a \<noteq> t_input p \<or> p \<notin> FSM.transitions M1 \<or> t_source p \<noteq> q1))"
by moura
then have "x = t_input (pp x) \<and> pp x \<in> FSM.transitions M1 \<and> t_source (pp x) = q1"
using a2 by blast
then show ?thesis
using f4 a3 by (metis (no_types) DiffI LS_single_transition)
qed
lemma language_path_append :
assumes "path M1 q1 p1"
and "io \<in> LS M1 (target q1 p1)"
shows "(p_io p1 @ io) \<in> LS M1 q1"
proof -
obtain p2 where "path M1 (target q1 p1) p2" and "p_io p2 = io"
using assms(2) by auto
then have "path M1 q1 (p1@p2)"
using assms(1) by auto
moreover have "p_io (p1@p2) = (p_io p1 @ io)"
using \<open>p_io p2 = io\<close> by auto
ultimately show ?thesis
by (metis (mono_tags, lifting) language_intro)
qed
lemma observable_defined_inputs_diff_ob :
assumes "observable M1"
and "observable M2"
and "path M1 q1 p1"
and "path M2 q2 p2"
and "p_io p1 = p_io p2"
and "x \<in> defined_inputs M1 (target q1 p1)"
and "x \<notin> defined_inputs M2 (target q2 p2)"
obtains y where "(p_io p1)@[(x,y)] \<in> LS M1 q1 - LS M2 q2"
proof -
obtain y where "[(x,y)] \<in> LS M1 (target q1 p1) - LS M2 (target q2 p2)"
using defined_inputs_language_diff[OF assms(6,7)] by blast
then have "(p_io p1)@[(x,y)] \<in> LS M1 q1"
using language_path_append[OF assms(3)]
by blast
moreover have "(p_io p1)@[(x,y)] \<notin> LS M2 q2"
by (metis (mono_tags, lifting) DiffD2 \<open>[(x, y)] \<in> LS M1 (target q1 p1) - LS M2 (target q2 p2)\<close> assms(2) assms(4) assms(5) language_state_containment observable_path_suffix)
ultimately show ?thesis
using that[of y] by blast
qed
lemma observable_defined_inputs_diff_language :
assumes "observable M1"
and "observable M2"
and "path M1 q1 p1"
and "path M2 q2 p2"
and "p_io p1 = p_io p2"
and "defined_inputs M1 (target q1 p1) \<noteq> defined_inputs M2 (target q2 p2)"
shows "LS M1 q1 \<noteq> LS M2 q2"
proof -
obtain x where "(x \<in> defined_inputs M1 (target q1 p1) - defined_inputs M2 (target q2 p2))
\<or> (x \<in> defined_inputs M2 (target q2 p2) - defined_inputs M1 (target q1 p1))"
using assms by blast
then consider "(x \<in> defined_inputs M1 (target q1 p1) - defined_inputs M2 (target q2 p2))" |
"(x \<in> defined_inputs M2 (target q2 p2) - defined_inputs M1 (target q1 p1))"
by blast
then show ?thesis
proof cases
case 1
then show ?thesis
using observable_defined_inputs_diff_ob[OF assms(1-5), of x] by blast
next
case 2
then show ?thesis
using observable_defined_inputs_diff_ob[OF assms(2,1,4,3) assms(5)[symmetric], of x] by blast
qed
qed
fun maximal_prefix_in_language :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> ('b \<times>'c) list" where
"maximal_prefix_in_language M q [] = []" |
"maximal_prefix_in_language M q ((x,y)#io) = (case h_obs M q x y of
None \<Rightarrow> [] |
Some q' \<Rightarrow> (x,y)#maximal_prefix_in_language M q' io)"
lemma maximal_prefix_in_language_properties :
assumes "observable M"
and "q \<in> states M"
shows "maximal_prefix_in_language M q io \<in> LS M q"
and "maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
proof -
have "maximal_prefix_in_language M q io \<in> LS M q \<and> maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
using assms(2) proof (induction io arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons xy io)
obtain x y where "xy = (x,y)"
using prod.exhaust by metis
show ?case proof (cases "h_obs M q x y")
case None
then have "maximal_prefix_in_language M q (xy#io) = []"
unfolding \<open>xy = (x,y)\<close>
by auto
then show ?thesis
by (metis (mono_tags, lifting) Cons.prems append_self_conv2 from_FSM_language language_contains_empty_sequence mem_Collect_eq prefixes_set)
next
case (Some q')
then have *: "maximal_prefix_in_language M q (xy#io) = (x,y)#maximal_prefix_in_language M q' io"
unfolding \<open>xy = (x,y)\<close>
by auto
have "q' \<in> states M"
using h_obs_state[OF Some] by auto
then have "maximal_prefix_in_language M q' io \<in> LS M q'"
and "maximal_prefix_in_language M q' io \<in> list.set (prefixes io)"
using Cons.IH by auto
have "maximal_prefix_in_language M q (xy # io) \<in> LS M q"
unfolding *
using Some \<open>maximal_prefix_in_language M q' io \<in> LS M q'\<close>
by (meson assms(1) h_obs_language_iff)
moreover have "maximal_prefix_in_language M q (xy # io) \<in> list.set (prefixes (xy # io))"
unfolding *
unfolding \<open>xy = (x,y)\<close>
using \<open>maximal_prefix_in_language M q' io \<in> list.set (prefixes io)\<close> append_Cons
unfolding prefixes_set
by auto
ultimately show ?thesis
by blast
qed
qed
then show "maximal_prefix_in_language M q io \<in> LS M q"
and "maximal_prefix_in_language M q io \<in> list.set (prefixes io)"
by auto
qed
subsection \<open>Further Reachability Formalisations\<close>
(* states that are reachable in at most k transitions *)
fun reachable_k :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a set" where
"reachable_k M q n = {target q p | p . path M q p \<and> length p \<le> n}"
lemma reachable_k_0_initial : "reachable_k M (initial M) 0 = {initial M}"
by auto
lemma reachable_k_states : "reachable_states M = reachable_k M (initial M) ( size M - 1)"
proof -
have "\<And>q. q \<in> reachable_states M \<Longrightarrow> q \<in> reachable_k M (initial M) ( size M - 1)"
proof -
fix q assume "q \<in> reachable_states M"
then obtain p where "path M (initial M) p" and "target (initial M) p = q"
unfolding reachable_states_def by blast
then obtain p' where "path M (initial M) p'"
and "target (initial M) p' = target (initial M) p"
and "length p' < size M"
by (metis acyclic_path_from_cyclic_path acyclic_path_length_limit)
then show "q \<in> reachable_k M (initial M) ( size M - 1)"
using \<open>target (FSM.initial M) p = q\<close> less_trans by auto
qed
moreover have "\<And>x. x \<in> reachable_k M (initial M) ( size M - 1) \<Longrightarrow> x \<in> reachable_states M"
unfolding reachable_states_def reachable_k.simps by blast
ultimately show ?thesis by blast
qed
subsubsection \<open>Induction Schemes\<close>
lemma acyclic_induction [consumes 1, case_names reachable_state]:
assumes "acyclic M"
and "\<And> q . q \<in> reachable_states M \<Longrightarrow> (\<And> t . t \<in> transitions M \<Longrightarrow> ((t_source t = q) \<Longrightarrow> P (t_target t))) \<Longrightarrow> P q"
shows "\<forall> q \<in> reachable_states M . P q"
proof
fix q assume "q \<in> reachable_states M"
let ?k = "Max (image length {p . path M q p})"
have "finite {p . path M q p}" using acyclic_finite_paths_from_reachable_state[OF assms(1)]
using \<open>q \<in> reachable_states M\<close> unfolding reachable_states_def by force
then have k_prop: "(\<forall> p . path M q p \<longrightarrow> length p \<le> ?k)" by auto
moreover have "\<And> q k . q \<in> reachable_states M \<Longrightarrow> (\<forall> p . path M q p \<longrightarrow> length p \<le> k) \<Longrightarrow> P q"
proof -
fix q k assume "q \<in> reachable_states M" and "(\<forall> p . path M q p \<longrightarrow> length p \<le> k)"
then show "P q"
proof (induction k arbitrary: q)
case 0
then have "{p . path M q p} = {[]}" using reachable_state_is_state[OF \<open>q \<in> reachable_states M\<close>]
by blast
then have "LS M q \<subseteq> {[]}" unfolding LS.simps by blast
then have "deadlock_state M q" using deadlock_state_alt_def by metis
then show ?case using assms(2)[OF \<open>q \<in> reachable_states M\<close>] unfolding deadlock_state.simps by blast
next
case (Suc k)
have "\<And> t . t \<in> transitions M \<Longrightarrow> (t_source t = q) \<Longrightarrow> P (t_target t)"
proof -
fix t assume "t \<in> transitions M" and "t_source t = q"
then have "t_target t \<in> reachable_states M"
using \<open>q \<in> reachable_states M\<close> using reachable_states_next by metis
moreover have "\<forall>p. path M (t_target t) p \<longrightarrow> length p \<le> k"
using Suc.prems(2) \<open>t \<in> transitions M\<close> \<open>t_source t = q\<close> by auto
ultimately show "P (t_target t)"
using Suc.IH unfolding reachable_states_def by blast
qed
then show ?case using assms(2)[OF Suc.prems(1)] by blast
qed
qed
ultimately show "P q" using \<open>q \<in> reachable_states M\<close> by blast
qed
lemma reachable_states_induct [consumes 1, case_names init transition] :
assumes "q \<in> reachable_states M"
and "P (initial M)"
and "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t \<in> reachable_states M \<Longrightarrow> P (t_source t) \<Longrightarrow> P (t_target t)"
shows "P q"
proof -
from assms(1) obtain p where "path M (initial M) p" and "target (initial M) p = q"
unfolding reachable_states_def by auto
then show "P q"
proof (induction p arbitrary: q rule: rev_induct)
case Nil
then show ?case using assms(2) by auto
next
case (snoc t p)
then have "target (initial M) p = t_source t"
by auto
then have "P (t_source t)"
using snoc.IH snoc.prems by auto
moreover have "t \<in> transitions M"
using snoc.prems by auto
moreover have "t_source t \<in> reachable_states M"
by (metis \<open>target (FSM.initial M) p = t_source t\<close> path_prefix reachable_states_intro snoc.prems(1))
moreover have "t_target t = q"
using snoc.prems by auto
ultimately show ?case
using assms(3) by blast
qed
qed
lemma reachable_states_cases [consumes 1, case_names init transition] :
assumes "q \<in> reachable_states M"
and "P (initial M)"
and "\<And> t . t \<in> transitions M \<Longrightarrow> t_source t \<in> reachable_states M \<Longrightarrow> P (t_target t)"
shows "P q"
by (metis assms(1) assms(2) assms(3) reachable_states_induct)
subsection \<open>Further Path Enumeration Algorithms\<close>
fun paths_for_input' :: "('a \<Rightarrow> ('b \<times> 'c \<times> 'a) set) \<Rightarrow> 'b list \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) path \<Rightarrow> ('a,'b,'c) path set" where
"paths_for_input' f [] q prev = {prev}" |
"paths_for_input' f (x#xs) q prev = \<Union>(image (\<lambda>(x',y',q') . paths_for_input' f xs q' (prev@[(q,x,y',q')])) (Set.filter (\<lambda>(x',y',q') . x' = x) (f q)))"
lemma paths_for_input'_set :
assumes "q \<in> states M"
shows "paths_for_input' (h_from M) xs q prev = {prev@p | p . path M q p \<and> map fst (p_io p) = xs}"
using assms proof (induction xs arbitrary: q prev)
case Nil
then show ?case by auto
next
case (Cons x xs)
let ?UN = "\<Union>(image (\<lambda>(x',y',q') . paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])) (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q)))"
have "?UN = {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
proof
have "\<And> p . p \<in> ?UN \<Longrightarrow> p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
proof -
fix p assume "p \<in> ?UN"
then obtain y' q' where "(x,y',q') \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))"
and "p \<in> paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])"
by auto
from \<open>(x,y',q') \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))\<close> have "q' \<in> states M" and "(q,x,y',q') \<in> transitions M"
using fsm_transition_target unfolding h.simps by auto
have "p \<in> {(prev @ [(q, x, y', q')]) @ p |p. path M q' p \<and> map fst (p_io p) = xs}"
using \<open>p \<in> paths_for_input' (h_from M) xs q' (prev@[(q,x,y',q')])\<close>
unfolding Cons.IH[OF \<open>q' \<in> states M\<close>] by assumption
moreover have "{(prev @ [(q, x, y', q')]) @ p |p. path M q' p \<and> map fst (p_io p) = xs}
\<subseteq> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
using \<open>(q,x,y',q') \<in> transitions M\<close>
using cons by force
ultimately show "p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
by blast
qed
then show "?UN \<subseteq> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
by blast
have "\<And> p . p \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs} \<Longrightarrow> p \<in> ?UN"
proof -
fix pp assume "pp \<in> {prev@p | p . path M q p \<and> map fst (p_io p) = x#xs}"
then obtain p where "pp = prev@p" and "path M q p" and "map fst (p_io p) = x#xs"
by fastforce
then obtain t p' where "p = t#p'" and "path M q (t#p')" and "map fst (p_io (t#p')) = x#xs" and "map fst (p_io p') = xs"
by (metis (no_types, lifting) map_eq_Cons_D)
then have "path M (t_target t) p'" and "t_source t = q" and "t_input t = x" and "t_target t \<in> states M" and "t \<in> transitions M"
by auto
have "(x,t_output t,t_target t) \<in> (Set.filter (\<lambda>(x',y',q') . x' = x) (h_from M q))"
using \<open>t \<in> transitions M\<close> \<open>t_input t = x\<close> \<open>t_source t = q\<close>
unfolding h.simps by auto
moreover have "(prev@p) \<in> paths_for_input' (h_from M) xs (t_target t) (prev@[(q,x,t_output t,t_target t)])"
using Cons.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[(q, x, t_output t, t_target t)]"]
using \<open>\<And>thesis. (\<And>t p'. \<lbrakk>p = t # p'; path M q (t # p'); map fst (p_io (t # p')) = x # xs; map fst (p_io p') = xs\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
\<open>p = t # p'\<close>
\<open>paths_for_input' (h_from M) xs (t_target t) (prev @ [(q, x, t_output t, t_target t)])
= {(prev @ [(q, x, t_output t, t_target t)]) @ p |p. path M (t_target t) p \<and> map fst (p_io p) = xs}\<close>
\<open>t_input t = x\<close>
\<open>t_source t = q\<close>
by fastforce
ultimately show "pp \<in> ?UN" unfolding \<open>pp = prev@p\<close>
by blast
qed
then show "{prev@p | p . path M q p \<and> map fst (p_io p) = x#xs} \<subseteq> ?UN"
by (meson subsetI)
qed
then show ?case
by (metis paths_for_input'.simps(2))
qed
definition paths_for_input :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('a,'b,'c) path set" where
"paths_for_input M q xs = {p . path M q p \<and> map fst (p_io p) = xs}"
lemma paths_for_input_set_code[code] :
"paths_for_input M q xs = (if q \<in> states M then paths_for_input' (h_from M) xs q [] else {})"
using paths_for_input'_set[of q M xs "[]"]
unfolding paths_for_input_def
by (cases "q \<in> states M"; auto; simp add: path_begin_state)
fun paths_up_to_length_or_condition_with_witness' ::
"('a \<Rightarrow> ('b \<times> 'c \<times> 'a) set) \<Rightarrow> (('a,'b,'c) path \<Rightarrow> 'd option) \<Rightarrow> ('a,'b,'c) path \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> (('a,'b,'c) path \<times> 'd) set"
where
"paths_up_to_length_or_condition_with_witness' f P prev 0 q = (case P prev of Some w \<Rightarrow> {(prev,w)} | None \<Rightarrow> {})" |
"paths_up_to_length_or_condition_with_witness' f P prev (Suc k) q = (case P prev of
Some w \<Rightarrow> {(prev,w)} |
None \<Rightarrow> (\<Union>(image (\<lambda>(x,y,q') . paths_up_to_length_or_condition_with_witness' f P (prev@[(q,x,y,q')]) k q') (f q))))"
lemma paths_up_to_length_or_condition_with_witness'_set :
assumes "q \<in> states M"
shows "paths_up_to_length_or_condition_with_witness' (h_from M) P prev k q
= {(prev@p,x) | p x . path M q p
\<and> length p \<le> k
\<and> P (prev@p) = Some x
\<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
using assms proof (induction k arbitrary: q prev)
case 0
then show ?case proof (cases "P prev")
case None then show ?thesis by auto
next
case (Some w)
then show ?thesis by (simp add: "0.prems" nil)
qed
next
case (Suc k)
then show ?case proof (cases "P prev")
case (Some w)
then have "(prev,w) \<in> {(prev@p,x) | p x . path M q p
\<and> length p \<le> Suc k
\<and> P (prev@p) = Some x
\<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
by (simp add: Suc.prems nil)
then have "{(prev@p,x) | p x . path M q p
\<and> length p \<le> Suc k
\<and> P (prev@p) = Some x
\<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}
= {(prev,w)}"
using Some by fastforce
then show ?thesis using Some by auto
next
case None
have "(\<Union>(image (\<lambda>(x,y,q') . paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q') (h_from M q)))
= {(prev@p,x) | p x . path M q p
\<and> length p \<le> Suc k
\<and> P (prev@p) = Some x
\<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P (prev@p') = None)}"
(is "?UN = ?PX")
proof -
have *: "\<And> pp . pp \<in> ?UN \<Longrightarrow> pp \<in> ?PX"
proof -
fix pp assume "pp \<in> ?UN"
then obtain x y q' where "(x,y,q') \<in> h_from M q"
and "pp \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q'"
by blast
then have "(q,x,y,q') \<in> transitions M" by auto
then have "q' \<in> states M" using fsm_transition_target by auto
obtain p w where "pp = ((prev@[(q,x,y,q')])@p,w)"
and "path M q' p"
and "length p \<le> k"
and "P ((prev @ [(q, x, y, q')]) @ p) = Some w"
and "\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev @ [(q, x, y, q')]) @ p') = None"
using \<open>pp \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[(q,x,y,q')]) k q'\<close>
unfolding Suc.IH[OF \<open>q' \<in> states M\<close>, of "prev@[(q,x,y,q')]"]
by blast
have "path M q ((q,x,y,q')#p)"
using \<open>path M q' p\<close> \<open>(q,x,y,q') \<in> transitions M\<close> by (simp add: path_prepend_t)
moreover have "length ((q,x,y,q')#p) \<le> Suc k"
using \<open>length p \<le> k\<close> by auto
moreover have "P (prev @ ([(q, x, y, q')] @ p)) = Some w"
using \<open>P ((prev @ [(q, x, y, q')]) @ p) = Some w\<close> by auto
moreover have "\<And> p' p''. ((q,x,y,q')#p) = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None"
using \<open>\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev @ [(q, x, y, q')]) @ p') = None\<close>
using None
by (metis (no_types, opaque_lifting) append.simps(1) append_Cons append_Nil2 append_assoc
list.inject neq_Nil_conv)
ultimately show "pp \<in> ?PX"
unfolding \<open>pp = ((prev@[(q,x,y,q')])@p,w)\<close> by auto
qed
have **: "\<And> pp . pp \<in> ?PX \<Longrightarrow> pp \<in> ?UN"
proof -
fix pp assume "pp \<in> ?PX"
then obtain p' w where "pp = (prev @ p', w)"
and "path M q p'"
and "length p' \<le> Suc k"
and "P (prev @ p') = Some w"
and "\<And> p' p''. p' = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None"
by blast
moreover obtain t p where "p' = t#p" using \<open>P (prev @ p') = Some w\<close> using None
by (metis append_Nil2 list.exhaust option.distinct(1))
have "pp = ((prev @ [t])@p, w)"
using \<open>pp = (prev @ p', w)\<close> unfolding \<open>p' = t#p\<close> by auto
have "path M q (t#p)"
using \<open>path M q p'\<close> unfolding \<open>p' = t#p\<close> by auto
have p2: "length (t#p) \<le> Suc k"
using \<open>length p' \<le> Suc k\<close> unfolding \<open>p' = t#p\<close> by auto
have p3: "P ((prev @ [t])@p) = Some w"
using \<open>P (prev @ p') = Some w\<close> unfolding \<open>p' = t#p\<close> by auto
have p4: "\<And> p' p''. p = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P ((prev@[t]) @ p') = None"
using \<open>\<And> p' p''. p' = p' @ p'' \<Longrightarrow> p'' \<noteq> [] \<Longrightarrow> P (prev @ p') = None\<close> \<open>pp \<in> ?PX\<close>
unfolding \<open>pp = ((prev @ [t]) @ p, w)\<close> \<open>p' = t#p\<close>
by auto
have "t \<in> transitions M" and p1: "path M (t_target t) p" and "t_source t = q"
using \<open>path M q (t#p)\<close> by auto
then have "t_target t \<in> states M"
and "(t_input t, t_output t, t_target t) \<in> h_from M q"
and "t_source t = q"
using fsm_transition_target by auto
then have "t = (q,t_input t, t_output t, t_target t)"
by auto
have "((prev @ [t])@p, w) \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev@[t]) k (t_target t)"
unfolding Suc.IH[OF \<open>t_target t \<in> states M\<close>, of "prev@[t]"]
using p1 p2 p3 p4 by auto
then show "pp \<in> ?UN"
unfolding \<open>pp = ((prev @ [t])@p, w)\<close>
proof -
have "paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [t]) k (t_target t)
= paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [(q, t_input t, t_output t, t_target t)]) k (t_target t)"
using \<open>t = (q, t_input t, t_output t, t_target t)\<close> by presburger
then show "((prev @ [t]) @ p, w) \<in> (\<Union>(b, c, a)\<in>h_from M q. paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [(q, b, c, a)]) k a)"
using \<open>((prev @ [t]) @ p, w) \<in> paths_up_to_length_or_condition_with_witness' (h_from M) P (prev @ [t]) k (t_target t)\<close>
\<open>(t_input t, t_output t, t_target t) \<in> h_from M q\<close>
by blast
qed
qed
show ?thesis
using subsetI[of ?UN ?PX, OF *] subsetI[of ?PX ?UN, OF **] subset_antisym by blast
qed
then show ?thesis
using None unfolding paths_up_to_length_or_condition_with_witness'.simps by simp
qed
qed
definition paths_up_to_length_or_condition_with_witness ::
"('a,'b,'c) fsm \<Rightarrow> (('a,'b,'c) path \<Rightarrow> 'd option) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> (('a,'b,'c) path \<times> 'd) set"
where
"paths_up_to_length_or_condition_with_witness M P k q
= {(p,x) | p x . path M q p
\<and> length p \<le> k
\<and> P p = Some x
\<and> (\<forall> p' p'' . (p = p'@p'' \<and> p'' \<noteq> []) \<longrightarrow> P p' = None)}"
lemma paths_up_to_length_or_condition_with_witness_code[code] :
"paths_up_to_length_or_condition_with_witness M P k q
= (if q \<in> states M then paths_up_to_length_or_condition_with_witness' (h_from M) P [] k q
else {})"
proof (cases "q \<in> states M")
case True
then show ?thesis
unfolding paths_up_to_length_or_condition_with_witness_def
paths_up_to_length_or_condition_with_witness'_set[OF True]
by auto
next
case False
then show ?thesis
unfolding paths_up_to_length_or_condition_with_witness_def
using path_begin_state by fastforce
qed
lemma paths_up_to_length_or_condition_with_witness_finite :
"finite (paths_up_to_length_or_condition_with_witness M P k q)"
proof -
have "paths_up_to_length_or_condition_with_witness M P k q
\<subseteq> {(p, the (P p)) | p . path M q p \<and> length p \<le> k}"
unfolding paths_up_to_length_or_condition_with_witness_def
by auto
moreover have "finite {(p, the (P p)) | p . path M q p \<and> length p \<le> k}"
using paths_finite[of M q k]
by simp
ultimately show ?thesis
using rev_finite_subset by auto
qed
subsection \<open>More Acyclicity Properties\<close>
lemma maximal_path_target_deadlock :
assumes "path M (initial M) p"
and "\<not>(\<exists> p' . path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p')"
shows "deadlock_state M (target (initial M) p)"
proof -
have "\<not>(\<exists> t \<in> transitions M . t_source t = target (initial M) p)"
using assms(2) unfolding is_prefix_prefix
by (metis append_Nil2 assms(1) not_Cons_self2 path_append_transition same_append_eq)
then show ?thesis by auto
qed
lemma path_to_deadlock_is_maximal :
assumes "path M (initial M) p"
and "deadlock_state M (target (initial M) p)"
shows "\<not>(\<exists> p' . path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p')"
proof
assume "\<exists>p'. path M (initial M) p' \<and> is_prefix p p' \<and> p \<noteq> p'"
then obtain p' where "path M (initial M) p'" and "is_prefix p p'" and "p \<noteq> p'" by blast
then have "length p' > length p"
unfolding is_prefix_prefix by auto
then obtain t p2 where "p' = p @ [t] @ p2"
using \<open>is_prefix p p'\<close> unfolding is_prefix_prefix
by (metis \<open>p \<noteq> p'\<close> append.left_neutral append_Cons append_Nil2 non_sym_dist_pairs'.cases)
then have "path M (initial M) (p@[t])"
using \<open>path M (initial M) p'\<close> by auto
then have "t \<in> transitions M" and "t_source t = target (initial M) p"
by auto
then show "False"
using \<open>deadlock_state M (target (initial M) p)\<close> unfolding deadlock_state.simps by blast
qed
definition maximal_acyclic_paths :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) path set" where
"maximal_acyclic_paths M = {p . path M (initial M) p
\<and> distinct (visited_states (initial M) p)
\<and> \<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p')
\<and> distinct (visited_states (initial M) (p@p')))}"
(* very inefficient construction *)
lemma maximal_acyclic_paths_code[code] :
"maximal_acyclic_paths M = (let ps = acyclic_paths_up_to_length M (initial M) (size M - 1)
in Set.filter (\<lambda>p . \<not> (\<exists> p' \<in> ps . p' \<noteq> p \<and> is_prefix p p')) ps)"
proof -
have scheme1: "\<And> P p . (\<exists> p' . p' \<noteq> [] \<and> P (p@p')) = (\<exists> p' \<in> {p . P p} . p' \<noteq> p \<and> is_prefix p p')"
unfolding is_prefix_prefix by blast
have scheme2: "\<And> p . (path M (FSM.initial M) p
\<and> length p \<le> FSM.size M - 1
\<and> distinct (visited_states (FSM.initial M) p))
= (path M (FSM.initial M) p \<and> distinct (visited_states (FSM.initial M) p))"
using acyclic_path_length_limit by fastforce
show ?thesis
unfolding maximal_acyclic_paths_def acyclic_paths_up_to_length.simps Let_def
unfolding scheme1[of "\<lambda>p . path M (initial M) p \<and> distinct (visited_states (initial M) p)"]
unfolding scheme2 by fastforce
qed
lemma maximal_acyclic_path_deadlock :
assumes "acyclic M"
and "path M (initial M) p"
shows "\<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p') \<and> distinct (visited_states (initial M) (p@p')))
= deadlock_state M (target (initial M) p)"
proof -
have "deadlock_state M (target (initial M) p) \<Longrightarrow> \<not>(\<exists> p' . p' \<noteq> [] \<and> path M (initial M) (p@p')
\<and> distinct (visited_states (initial M) (p@p')))"
unfolding deadlock_state.simps
using assms(2) by (metis path.cases path_suffix)
then show ?thesis
by (metis acyclic.elims(2) assms(1) assms(2) is_prefix_prefix maximal_path_target_deadlock
self_append_conv)
qed
lemma maximal_acyclic_paths_deadlock_targets :
assumes "acyclic M"
shows "maximal_acyclic_paths M
= { p . path M (initial M) p \<and> deadlock_state M (target (initial M) p)}"
using maximal_acyclic_path_deadlock[OF assms]
unfolding maximal_acyclic_paths_def
by (metis (no_types, lifting) acyclic.elims(2) assms)
lemma cycle_from_cyclic_path :
assumes "path M q p"
and "\<not> distinct (visited_states q p)"
obtains i j where
"take j (drop i p) \<noteq> []"
"target (target q (take i p)) (take j (drop i p)) = (target q (take i p))"
"path M (target q (take i p)) (take j (drop i p))"
proof -
obtain i j where "i < j" and "j < length (visited_states q p)"
and "(visited_states q p) ! i = (visited_states q p) ! j"
using assms(2) non_distinct_repetition_indices by blast
have "(target q (take i p)) = (visited_states q p) ! i"
using \<open>i < j\<close> \<open>j < length (visited_states q p)\<close>
by (metis less_trans take_last_index target.simps visited_states_take)
then have "(target q (take i p)) = (visited_states q p) ! j"
using \<open>(visited_states q p) ! i = (visited_states q p) ! j\<close> by auto
have p1: "take (j-i) (drop i p) \<noteq> []"
using \<open>i < j\<close> \<open>j < length (visited_states q p)\<close> by auto
have "target (target q (take i p)) (take (j-i) (drop i p)) = (target q (take j p))"
using \<open>i < j\<close> by (metis add_diff_inverse_nat less_asym' path_append_target take_add)
then have p2: "target (target q (take i p)) (take (j-i) (drop i p)) = (target q (take i p))"
using \<open>(target q (take i p)) = (visited_states q p) ! i\<close>
using \<open>(target q (take i p)) = (visited_states q p) ! j\<close>
by (metis \<open>j < length (visited_states q p)\<close> take_last_index target.simps visited_states_take)
have p3: "path M (target q (take i p)) (take (j-i) (drop i p))"
by (metis append_take_drop_id assms(1) path_append_elim)
show ?thesis using p1 p2 p3 that by blast
qed
lemma acyclic_single_deadlock_reachable :
assumes "acyclic M"
and "\<And> q' . q' \<in> reachable_states M \<Longrightarrow> q' = qd \<or> \<not> deadlock_state M q'"
shows "qd \<in> reachable_states M"
using acyclic_deadlock_reachable[OF assms(1)]
using assms(2) by auto
lemma acyclic_paths_to_single_deadlock :
assumes "acyclic M"
and "\<And> q' . q' \<in> reachable_states M \<Longrightarrow> q' = qd \<or> \<not> deadlock_state M q'"
and "q \<in> reachable_states M"
obtains p where "path M q p" and "target q p = qd"
proof -
have "q \<in> states M" using assms(3) reachable_state_is_state by metis
have "acyclic (from_FSM M q)"
using from_FSM_acyclic[OF assms(3,1)] by assumption
have *: "(\<And>q'. q' \<in> reachable_states (FSM.from_FSM M q)
\<Longrightarrow> q' = qd \<or> \<not> deadlock_state (FSM.from_FSM M q) q')"
using assms(2) from_FSM_reachable_states[OF assms(3)]
unfolding deadlock_state.simps from_FSM_simps[OF \<open>q \<in> states M\<close>] by blast
obtain p where "path (from_FSM M q) q p" and "target q p = qd"
using acyclic_single_deadlock_reachable[OF \<open>acyclic (from_FSM M q)\<close> *]
unfolding reachable_states_def from_FSM_simps[OF \<open>q \<in> states M\<close>]
by blast
then show ?thesis
using that by (metis \<open>q \<in> FSM.states M\<close> from_FSM_path)
qed
subsection \<open>Elements as Lists\<close>
fun states_as_list :: "('a :: linorder, 'b, 'c) fsm \<Rightarrow> 'a list" where
"states_as_list M = sorted_list_of_set (states M)"
lemma states_as_list_distinct : "distinct (states_as_list M)" by auto
lemma states_as_list_set : "set (states_as_list M) = states M"
by (simp add: fsm_states_finite)
fun reachable_states_as_list :: "('a :: linorder, 'b, 'c) fsm \<Rightarrow> 'a list" where
"reachable_states_as_list M = sorted_list_of_set (reachable_states M)"
lemma reachable_states_as_list_distinct : "distinct (reachable_states_as_list M)" by auto
lemma reachable_states_as_list_set : "set (reachable_states_as_list M) = reachable_states M"
by (metis fsm_states_finite infinite_super reachable_state_is_state reachable_states_as_list.simps
set_sorted_list_of_set subsetI)
fun inputs_as_list :: "('a, 'b :: linorder, 'c) fsm \<Rightarrow> 'b list" where
"inputs_as_list M = sorted_list_of_set (inputs M)"
lemma inputs_as_list_set : "set (inputs_as_list M) = inputs M"
by (simp add: fsm_inputs_finite)
lemma inputs_as_list_distinct : "distinct (inputs_as_list M)" by auto
fun transitions_as_list :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a,'b,'c) transition list" where
"transitions_as_list M = sorted_list_of_set (transitions M)"
lemma transitions_as_list_set : "set (transitions_as_list M) = transitions M"
by (simp add: fsm_transitions_finite)
fun outputs_as_list :: "('a,'b,'c :: linorder) fsm \<Rightarrow> 'c list" where
"outputs_as_list M = sorted_list_of_set (outputs M)"
lemma outputs_as_list_set : "set (outputs_as_list M) = outputs M"
by (simp add: fsm_outputs_finite)
fun ftransitions :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a,'b,'c) transition fset" where
"ftransitions M = fset_of_list (transitions_as_list M)"
fun fstates :: "('a :: linorder,'b,'c) fsm \<Rightarrow> 'a fset" where
"fstates M = fset_of_list (states_as_list M)"
fun finputs :: "('a,'b :: linorder,'c) fsm \<Rightarrow> 'b fset" where
"finputs M = fset_of_list (inputs_as_list M)"
fun foutputs :: "('a,'b,'c :: linorder) fsm \<Rightarrow> 'c fset" where
"foutputs M = fset_of_list (outputs_as_list M)"
lemma fstates_set : "fset (fstates M) = states M"
using fsm_states_finite[of M] by (simp add: fset_of_list.rep_eq)
lemma finputs_set : "fset (finputs M) = inputs M"
using fsm_inputs_finite[of M] by (simp add: fset_of_list.rep_eq)
lemma foutputs_set : "fset (foutputs M) = outputs M"
using fsm_outputs_finite[of M] by (simp add: fset_of_list.rep_eq)
lemma ftransitions_set: "fset (ftransitions M) = transitions M"
by (metis (no_types) fset_of_list.rep_eq ftransitions.simps transitions_as_list_set)
lemma ftransitions_source:
"q |\<in>| (t_source |`| ftransitions M) \<Longrightarrow> q \<in> states M"
using ftransitions_set[of M] fsm_transition_source[of _ M]
- by (metis (no_types, lifting) fimageE fmember.rep_eq)
+ by (metis (no_types, lifting) fimageE fmember_iff_member_fset)
lemma ftransitions_target:
"q |\<in>| (t_target |`| ftransitions M) \<Longrightarrow> q \<in> states M"
using ftransitions_set[of M] fsm_transition_target[of _ M]
- by (metis (no_types, lifting) fimageE fmember.rep_eq)
+ by (metis (no_types, lifting) fimageE fmember_iff_member_fset)
subsection \<open>Responses to Input Sequences\<close>
fun language_for_input :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> 'a \<Rightarrow> 'b list \<Rightarrow> ('b\<times>'c) list list" where
"language_for_input M q [] = [[]]" |
"language_for_input M q (x#xs) =
(let outs = outputs_as_list M
in concat (map (\<lambda>y . case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs)) outs))"
lemma language_for_input_set :
assumes "observable M"
and "q \<in> states M"
shows "list.set (language_for_input M q xs) = {io . io \<in> LS M q \<and> map fst io = xs}"
using assms(2) proof (induction xs arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons x xs)
have "list.set (language_for_input M q (x#xs)) \<subseteq> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
proof
fix io assume "io \<in> list.set (language_for_input M q (x#xs))"
then obtain y where "y \<in> outputs M"
and "io \<in> list.set (case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs))"
unfolding outputs_as_list_set[symmetric]
by auto
then obtain q' where "h_obs M q x y = Some q'" and "io \<in> list.set (map ((#) (x,y)) (language_for_input M q' xs))"
by (cases "h_obs M q x y"; auto)
then obtain io' where "io = (x,y)#io'"
and "io' \<in> list.set (language_for_input M q' xs)"
by auto
then have "io' \<in> LS M q'" and "map fst io' = xs"
using Cons.IH[OF h_obs_state[OF \<open>h_obs M q x y = Some q'\<close>]]
by blast+
then have "(x,y)#io' \<in> LS M q"
using \<open>h_obs M q x y = Some q'\<close>
unfolding h_obs_language_iff[OF assms(1), of x y io' q]
by blast
then show "io \<in> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
unfolding \<open>io = (x,y)#io'\<close>
using \<open>map fst io' = xs\<close>
by auto
qed
moreover have "{io . io \<in> LS M q \<and> map fst io = (x#xs)} \<subseteq> list.set (language_for_input M q (x#xs))"
proof
have scheme : "\<And> x y f xs . y \<in> list.set (f x) \<Longrightarrow> x \<in> list.set xs \<Longrightarrow> y \<in> list.set (concat (map f xs))"
by auto
fix io assume "io \<in> {io . io \<in> LS M q \<and> map fst io = (x#xs)}"
then have "io \<in> LS M q" and "map fst io = (x#xs)"
by auto
then obtain y io' where "io = (x,y)#io'"
by fastforce
then have "(x,y)#io' \<in> LS M q"
using \<open>io \<in> LS M q\<close>
by auto
then obtain q' where "h_obs M q x y = Some q'" and "io' \<in> LS M q'"
unfolding h_obs_language_iff[OF assms(1), of x y io' q]
by blast
moreover have "io' \<in> list.set (language_for_input M q' xs)"
using Cons.IH[OF h_obs_state[OF \<open>h_obs M q x y = Some q'\<close>]] \<open>io' \<in> LS M q'\<close> \<open>map fst io = (x#xs)\<close>
unfolding \<open>io = (x,y)#io'\<close> by auto
ultimately have "io \<in> list.set ((\<lambda> y .(case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs))) y)"
unfolding \<open>io = (x,y)#io'\<close>
by force
moreover have "y \<in> list.set (outputs_as_list M)"
unfolding outputs_as_list_set
using language_io(2)[OF \<open>(x,y)#io' \<in> LS M q\<close>] by auto
ultimately show "io \<in> list.set (language_for_input M q (x#xs))"
unfolding language_for_input.simps Let_def
using scheme[of io "(\<lambda> y .(case h_obs M q x y of None \<Rightarrow> [] | Some q' \<Rightarrow> map ((#) (x,y)) (language_for_input M q' xs)))" y]
by blast
qed
ultimately show ?case
by blast
qed
subsection \<open>Filtering Transitions\<close>
lift_definition filter_transitions ::
"('a,'b,'c) fsm \<Rightarrow> (('a,'b,'c) transition \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.filter_transitions
proof -
fix M :: "('a,'b,'c) fsm_impl"
fix P :: "('a,'b,'c) transition \<Rightarrow> bool"
assume "well_formed_fsm M"
then show "well_formed_fsm (FSM_Impl.filter_transitions M P)"
unfolding FSM_Impl.filter_transitions.simps by force
qed
lemma filter_transitions_simps[simp] :
"initial (filter_transitions M P) = initial M"
"states (filter_transitions M P) = states M"
"inputs (filter_transitions M P) = inputs M"
"outputs (filter_transitions M P) = outputs M"
"transitions (filter_transitions M P) = {t \<in> transitions M . P t}"
by (transfer;auto)+
lemma filter_transitions_submachine :
"is_submachine (filter_transitions M P) M"
unfolding filter_transitions_simps by fastforce
lemma filter_transitions_path :
assumes "path (filter_transitions M P) q p"
shows "path M q p"
using path_begin_state[OF assms]
transition_subset_path[of "filter_transitions M P" M, OF _ assms]
unfolding filter_transitions_simps by blast
lemma filter_transitions_reachable_states :
assumes "q \<in> reachable_states (filter_transitions M P)"
shows "q \<in> reachable_states M"
using assms unfolding reachable_states_def filter_transitions_simps
using filter_transitions_path[of M P "initial M"]
by blast
subsection \<open>Filtering States\<close>
lift_definition filter_states :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.filter_states
proof -
fix M :: "('a,'b,'c) fsm_impl"
fix P :: "'a \<Rightarrow> bool"
assume *: "well_formed_fsm M"
then show "well_formed_fsm (FSM_Impl.filter_states M P)"
by (cases "P (FSM_Impl.initial M)"; auto)
qed
lemma filter_states_simps[simp] :
assumes "P (initial M)"
shows "initial (filter_states M P) = initial M"
"states (filter_states M P) = Set.filter P (states M)"
"inputs (filter_states M P) = inputs M"
"outputs (filter_states M P) = outputs M"
"transitions (filter_states M P) = {t \<in> transitions M . P (t_source t) \<and> P (t_target t)}"
using assms by (transfer;auto)+
lemma filter_states_submachine :
assumes "P (initial M)"
shows "is_submachine (filter_states M P) M"
using filter_states_simps[of P M, OF assms] by fastforce
fun restrict_to_reachable_states :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) fsm" where
"restrict_to_reachable_states M = filter_states M (\<lambda> q . q \<in> reachable_states M)"
lemma restrict_to_reachable_states_simps[simp] :
shows "initial (restrict_to_reachable_states M) = initial M"
"states (restrict_to_reachable_states M) = reachable_states M"
"inputs (restrict_to_reachable_states M) = inputs M"
"outputs (restrict_to_reachable_states M) = outputs M"
"transitions (restrict_to_reachable_states M)
= {t \<in> transitions M . (t_source t) \<in> reachable_states M}"
proof -
show "initial (restrict_to_reachable_states M) = initial M"
"states (restrict_to_reachable_states M) = reachable_states M"
"inputs (restrict_to_reachable_states M) = inputs M"
"outputs (restrict_to_reachable_states M) = outputs M"
using filter_states_simps[of "(\<lambda> q . q \<in> reachable_states M)", OF reachable_states_initial]
using reachable_state_is_state[of _ M] by auto
have "transitions (restrict_to_reachable_states M)
= {t \<in> transitions M. (t_source t) \<in> reachable_states M \<and> (t_target t) \<in> reachable_states M}"
using filter_states_simps[of "(\<lambda> q . q \<in> reachable_states M)", OF reachable_states_initial]
by auto
then show "transitions (restrict_to_reachable_states M)
= {t \<in> transitions M . (t_source t) \<in> reachable_states M}"
using reachable_states_next[of _ M] by auto
qed
lemma restrict_to_reachable_states_path :
assumes "q \<in> reachable_states M"
shows "path M q p = path (restrict_to_reachable_states M) q p"
proof
show "path M q p \<Longrightarrow> path (restrict_to_reachable_states M) q p"
proof -
assume "path M q p"
then show "path (restrict_to_reachable_states M) q p"
using assms proof (induction p arbitrary: q rule: list.induct)
case Nil
then show ?case
using restrict_to_reachable_states_simps(2) by fastforce
next
case (Cons t' p')
then have "path M (t_target t') p'" by auto
moreover have "t_target t' \<in> reachable_states M" using Cons.prems
by (metis path_cons_elim reachable_states_next)
ultimately show ?case using Cons.IH
by (metis (no_types, lifting) Cons.prems(1) Cons.prems(2) mem_Collect_eq path.simps
path_cons_elim restrict_to_reachable_states_simps(5))
qed
qed
show "path (restrict_to_reachable_states M) q p \<Longrightarrow> path M q p"
by (metis (no_types, lifting) assms mem_Collect_eq reachable_state_is_state
restrict_to_reachable_states_simps(5) subsetI transition_subset_path)
qed
lemma restrict_to_reachable_states_language :
"L (restrict_to_reachable_states M) = L M"
unfolding LS.simps
unfolding restrict_to_reachable_states_simps
unfolding restrict_to_reachable_states_path[OF reachable_states_initial, of M]
by blast
lemma restrict_to_reachable_states_observable :
assumes "observable M"
shows "observable (restrict_to_reachable_states M)"
using assms unfolding observable.simps
unfolding restrict_to_reachable_states_simps
by blast
lemma restrict_to_reachable_states_minimal :
assumes "minimal M"
shows "minimal (restrict_to_reachable_states M)"
proof -
have "\<And> q1 q2 . q1 \<in> reachable_states M \<Longrightarrow>
q2 \<in> reachable_states M \<Longrightarrow>
q1 \<noteq> q2 \<Longrightarrow>
LS (restrict_to_reachable_states M) q1 \<noteq> LS (restrict_to_reachable_states M) q2"
proof -
fix q1 q2 assume "q1 \<in> reachable_states M" and "q2 \<in> reachable_states M" and "q1 \<noteq> q2"
then have "q1 \<in> states M" and "q2 \<in> states M"
by (simp add: reachable_state_is_state)+
then have "LS M q1 \<noteq> LS M q2"
using \<open>q1 \<noteq> q2\<close> assms by auto
then show "LS (restrict_to_reachable_states M) q1 \<noteq> LS (restrict_to_reachable_states M) q2"
unfolding LS.simps
unfolding restrict_to_reachable_states_path[OF \<open>q1 \<in> reachable_states M\<close>]
unfolding restrict_to_reachable_states_path[OF \<open>q2 \<in> reachable_states M\<close>] .
qed
then show ?thesis
unfolding minimal.simps restrict_to_reachable_states_simps
by blast
qed
lemma restrict_to_reachable_states_reachable_states :
"reachable_states (restrict_to_reachable_states M) = states (restrict_to_reachable_states M)"
proof
show "reachable_states (restrict_to_reachable_states M) \<subseteq> states (restrict_to_reachable_states M)"
by (simp add: reachable_state_is_state subsetI)
show "states (restrict_to_reachable_states M) \<subseteq> reachable_states (restrict_to_reachable_states M)"
proof
fix q assume "q \<in> states (restrict_to_reachable_states M)"
then have "q \<in> reachable_states M"
unfolding restrict_to_reachable_states_simps .
then show "q \<in> reachable_states (restrict_to_reachable_states M)"
unfolding reachable_states_def
unfolding restrict_to_reachable_states_simps
unfolding restrict_to_reachable_states_path[OF reachable_states_initial, symmetric] .
qed
qed
subsection \<open>Adding Transitions\<close>
lift_definition create_unconnected_fsm :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.create_unconnected_FSMI by (transfer; simp)
lemma create_unconnected_fsm_simps :
assumes "finite ns" and "finite ins" and "finite outs" and "q \<in> ns"
shows "initial (create_unconnected_fsm q ns ins outs) = q"
"states (create_unconnected_fsm q ns ins outs) = ns"
"inputs (create_unconnected_fsm q ns ins outs) = ins"
"outputs (create_unconnected_fsm q ns ins outs) = outs"
"transitions (create_unconnected_fsm q ns ins outs) = {}"
using assms by (transfer; auto)+
lift_definition create_unconnected_fsm_from_lists :: "'a \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'c list \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.create_unconnected_fsm_from_lists by (transfer; simp)
lemma create_unconnected_fsm_from_lists_simps :
assumes "q \<in> set ns"
shows "initial (create_unconnected_fsm_from_lists q ns ins outs) = q"
"states (create_unconnected_fsm_from_lists q ns ins outs) = set ns"
"inputs (create_unconnected_fsm_from_lists q ns ins outs) = set ins"
"outputs (create_unconnected_fsm_from_lists q ns ins outs) = set outs"
"transitions (create_unconnected_fsm_from_lists q ns ins outs) = {}"
using assms by (transfer; auto)+
lift_definition create_unconnected_fsm_from_fsets :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'b fset \<Rightarrow> 'c fset \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.create_unconnected_fsm_from_fsets by (transfer; simp)
lemma create_unconnected_fsm_from_fsets_simps :
assumes "q |\<in>| ns"
shows "initial (create_unconnected_fsm_from_fsets q ns ins outs) = q"
"states (create_unconnected_fsm_from_fsets q ns ins outs) = fset ns"
"inputs (create_unconnected_fsm_from_fsets q ns ins outs) = fset ins"
"outputs (create_unconnected_fsm_from_fsets q ns ins outs) = fset outs"
"transitions (create_unconnected_fsm_from_fsets q ns ins outs) = {}"
using assms unfolding fmember_def by (transfer; auto)+
lift_definition add_transitions :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.add_transitions
proof -
fix M :: "('a,'b,'c) fsm_impl"
fix ts :: "('a,'b,'c) transition set"
assume *: "well_formed_fsm M"
then show "well_formed_fsm (FSM_Impl.add_transitions M ts)"
proof (cases "\<forall> t \<in> ts . t_source t \<in> FSM_Impl.states M \<and> t_input t \<in> FSM_Impl.inputs M
\<and> t_output t \<in> FSM_Impl.outputs M \<and> t_target t \<in> FSM_Impl.states M")
case True
then have "ts \<subseteq> FSM_Impl.states M \<times> FSM_Impl.inputs M \<times> FSM_Impl.outputs M \<times> FSM_Impl.states M"
by fastforce
moreover have "finite (FSM_Impl.states M \<times> FSM_Impl.inputs M \<times> FSM_Impl.outputs M \<times> FSM_Impl.states M)"
using * by blast
ultimately have "finite ts"
using rev_finite_subset by auto
then show ?thesis using * by auto
next
case False
then show ?thesis using * by auto
qed
qed
lemma add_transitions_simps :
assumes "\<And> t . t \<in> ts \<Longrightarrow> t_source t \<in> states M \<and> t_input t \<in> inputs M \<and> t_output t \<in> outputs M \<and> t_target t \<in> states M"
shows "initial (add_transitions M ts) = initial M"
"states (add_transitions M ts) = states M"
"inputs (add_transitions M ts) = inputs M"
"outputs (add_transitions M ts) = outputs M"
"transitions (add_transitions M ts) = transitions M \<union> ts"
using assms by (transfer; auto)+
lift_definition create_fsm_from_sets :: "'a \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> 'c set \<Rightarrow> ('a,'b,'c) transition set \<Rightarrow> ('a,'b,'c) fsm"
is FSM_Impl.create_fsm_from_sets
proof -
fix q :: 'a
fix qs :: "'a set"
fix ins :: "'b set"
fix outs :: "'c set"
fix ts :: "('a,'b,'c) transition set"
show "well_formed_fsm (FSM_Impl.create_fsm_from_sets q qs ins outs ts)"
proof (cases "q \<in> qs \<and> finite qs \<and> finite ins \<and> finite outs")
case True
let ?M = "(FSMI q qs ins outs {})"
show ?thesis proof (cases "\<forall> t \<in> ts . t_source t \<in> FSM_Impl.states ?M \<and> t_input t \<in> FSM_Impl.inputs ?M
\<and> t_output t \<in> FSM_Impl.outputs ?M \<and> t_target t \<in> FSM_Impl.states ?M")
case True
then have "ts \<subseteq> FSM_Impl.states ?M \<times> FSM_Impl.inputs ?M \<times> FSM_Impl.outputs ?M \<times> FSM_Impl.states ?M"
by fastforce
moreover have "finite (FSM_Impl.states ?M \<times> FSM_Impl.inputs ?M \<times> FSM_Impl.outputs ?M \<times> FSM_Impl.states ?M)"
using \<open>q \<in> qs \<and> finite qs \<and> finite ins \<and> finite outs\<close> by force
ultimately have "finite ts"
using rev_finite_subset by auto
then show ?thesis by auto
next
case False
then show ?thesis by auto
qed
next
case False
then show ?thesis by auto
qed
qed
lemma create_fsm_from_sets_simps :
assumes "q \<in> qs" and "finite qs" and "finite ins" and "finite outs"
assumes "\<And> t . t \<in> ts \<Longrightarrow> t_source t \<in> qs \<and> t_input t \<in> ins \<and> t_output t \<in> outs \<and> t_target t \<in> qs"
shows "initial (create_fsm_from_sets q qs ins outs ts) = q"
"states (create_fsm_from_sets q qs ins outs ts) = qs"
"inputs (create_fsm_from_sets q qs ins outs ts) = ins"
"outputs (create_fsm_from_sets q qs ins outs ts) = outs"
"transitions (create_fsm_from_sets q qs ins outs ts) = ts"
using assms by (transfer; auto)+
lemma create_fsm_from_self :
"m = create_fsm_from_sets (initial m) (states m) (inputs m) (outputs m) (transitions m)"
proof -
have *: "\<And> t . t \<in> transitions m \<Longrightarrow> t_source t \<in> states m \<and> t_input t \<in> inputs m \<and> t_output t \<in> outputs m \<and> t_target t \<in> states m"
by auto
show ?thesis
using create_fsm_from_sets_simps[OF fsm_initial fsm_states_finite fsm_inputs_finite fsm_outputs_finite *, of "transitions m"]
apply transfer
by force
qed
lemma create_fsm_from_sets_surj :
assumes "finite (UNIV :: 'a set)"
and "finite (UNIV :: 'b set)"
and "finite (UNIV :: 'c set)"
shows "surj (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)"
proof
show "range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T) \<subseteq> UNIV"
by simp
show "UNIV \<subseteq> range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)"
proof
fix m assume "m \<in> (UNIV :: ('a,'b,'c) fsm set)"
then have "m = create_fsm_from_sets (initial m) (states m) (inputs m) (outputs m) (transitions m)"
using create_fsm_from_self by blast
then have "m = (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T) (initial m,states m,inputs m,outputs m,transitions m)"
by auto
then show "m \<in> range (\<lambda>(q::'a,Q,X::'b set,Y::'c set,T) . create_fsm_from_sets q Q X Y T)"
by blast
qed
qed
subsection \<open>Distinguishability\<close>
definition distinguishes :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
"distinguishes M q1 q2 io = (io \<in> LS M q1 \<union> LS M q2 \<and> io \<notin> LS M q1 \<inter> LS M q2)"
definition minimally_distinguishes :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times>'c) list \<Rightarrow> bool" where
"minimally_distinguishes M q1 q2 io = (distinguishes M q1 q2 io
\<and> (\<forall> io' . distinguishes M q1 q2 io' \<longrightarrow> length io \<le> length io'))"
lemma minimally_distinguishes_ex :
assumes "q1 \<in> states M"
and "q2 \<in> states M"
and "LS M q1 \<noteq> LS M q2"
obtains v where "minimally_distinguishes M q1 q2 v"
proof -
let ?vs = "{v . distinguishes M q1 q2 v}"
define vMin where vMin: "vMin = arg_min length (\<lambda>v . v \<in> ?vs)"
obtain v' where "distinguishes M q1 q2 v'"
using assms unfolding distinguishes_def by blast
then have "vMin \<in> ?vs \<and> (\<forall> v'' . distinguishes M q1 q2 v'' \<longrightarrow> length vMin \<le> length v'')"
unfolding vMin using arg_min_nat_lemma[of "\<lambda>v . distinguishes M q1 q2 v" v' length]
by simp
then show ?thesis
using that[of vMin] unfolding minimally_distinguishes_def by blast
qed
lemma distinguish_prepend :
assumes "observable M"
and "distinguishes M (FSM.after M q1 io) (FSM.after M q2 io) w"
and "q1 \<in> states M"
and "q2 \<in> states M"
and "io \<in> LS M q1"
and "io \<in> LS M q2"
shows "distinguishes M q1 q2 (io@w)"
proof -
have "(io@w \<in> LS M q1) = (w \<in> LS M (after M q1 io))"
using assms(1,3,5)
by (metis after_language_iff)
moreover have "(io@w \<in> LS M q2) = (w \<in> LS M (after M q2 io))"
using assms(1,4,6)
by (metis after_language_iff)
ultimately show ?thesis
using assms(2) unfolding distinguishes_def by blast
qed
lemma distinguish_prepend_initial :
assumes "observable M"
and "distinguishes M (after_initial M (io1@io)) (after_initial M (io2@io)) w"
and "io1@io \<in> L M"
and "io2@io \<in> L M"
shows "distinguishes M (after_initial M io1) (after_initial M io2) (io@w)"
proof -
have f1: "\<forall>ps psa f a. (ps::('b \<times> 'c) list) @ psa \<notin> LS f (a::'a) \<or> ps \<in> LS f a"
by (meson language_prefix)
then have f2: "io1 \<in> L M"
by (meson assms(3))
have f3: "io2 \<in> L M"
using f1 by (metis assms(4))
have "io1 \<in> L M"
using f1 by (metis assms(3))
then show ?thesis
by (metis after_is_state after_language_iff after_split assms(1) assms(2) assms(3) assms(4) distinguish_prepend f3)
qed
lemma minimally_distinguishes_no_prefix :
assumes "observable M"
and "u@w \<in> L M"
and "v@w \<in> L M"
and "minimally_distinguishes M (after_initial M u) (after_initial M v) (w@w'@w'')"
and "w' \<noteq> []"
shows "\<not>distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w''"
proof
assume "distinguishes M (after_initial M (u @ w)) (after_initial M (v @ w)) w''"
then have "distinguishes M (after_initial M u) (after_initial M v) (w@w'')"
using assms(1-3) distinguish_prepend_initial by blast
moreover have "length (w@w'') < length (w@w'@w'')"
using assms(5) by auto
ultimately show False
using assms(4) unfolding minimally_distinguishes_def
using leD by blast
qed
lemma minimally_distinguishes_after_append :
assumes "observable M"
and "minimal M"
and "q1 \<in> states M"
and "q2 \<in> states M"
and "minimally_distinguishes M q1 q2 (w@w')"
and "w' \<noteq> []"
shows "minimally_distinguishes M (after M q1 w) (after M q2 w) w'"
proof -
have "\<not> distinguishes M q1 q2 w"
using assms(5,6)
by (metis add.right_neutral add_le_cancel_left length_append length_greater_0_conv linorder_not_le minimally_distinguishes_def)
then have "w \<in> LS M q1 = (w \<in> LS M q2)"
unfolding distinguishes_def
by blast
moreover have "(w@w') \<in> LS M q1 \<union> LS M q2"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
ultimately have "w \<in> LS M q1" and "w \<in> LS M q2"
by (meson Un_iff language_prefix)+
have "(w@w') \<in> LS M q1 = (w' \<in> LS M (after M q1 w))"
by (meson \<open>w \<in> LS M q1\<close> after_language_iff assms(1))
moreover have "(w@w') \<in> LS M q2 = (w' \<in> LS M (after M q2 w))"
by (meson \<open>w \<in> LS M q2\<close> after_language_iff assms(1))
ultimately have "distinguishes M (after M q1 w) (after M q2 w) w'"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
moreover have "\<And> w'' . distinguishes M (after M q1 w) (after M q2 w) w'' \<Longrightarrow> length w' \<le> length w''"
proof -
fix w'' assume "distinguishes M (after M q1 w) (after M q2 w) w''"
then have "distinguishes M q1 q2 (w@w'')"
by (metis \<open>w \<in> LS M q1\<close> \<open>w \<in> LS M q2\<close> assms(1) assms(3) assms(4) distinguish_prepend)
then have "length (w@w') \<le> length (w@w'')"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
then show "length w' \<le> length w''"
by auto
qed
ultimately show ?thesis
unfolding minimally_distinguishes_def distinguishes_def
by blast
qed
lemma minimally_distinguishes_after_append_initial :
assumes "observable M"
and "minimal M"
and "u \<in> L M"
and "v \<in> L M"
and "minimally_distinguishes M (after_initial M u) (after_initial M v) (w@w')"
and "w' \<noteq> []"
shows "minimally_distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'"
proof -
have "\<not> distinguishes M (after_initial M u) (after_initial M v) w"
using assms(5,6)
by (metis add.right_neutral add_le_cancel_left length_append length_greater_0_conv linorder_not_le minimally_distinguishes_def)
then have "w \<in> LS M (after_initial M u) = (w \<in> LS M (after_initial M v))"
unfolding distinguishes_def
by blast
moreover have "(w@w') \<in> LS M (after_initial M u) \<union> LS M (after_initial M v)"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
ultimately have "w \<in> LS M (after_initial M u)" and "w \<in> LS M (after_initial M v)"
by (meson Un_iff language_prefix)+
have "(w@w') \<in> LS M (after_initial M u) = (w' \<in> LS M (after_initial M (u@w)))"
by (meson \<open>w \<in> LS M (after_initial M u)\<close> after_language_append_iff after_language_iff assms(1) assms(3))
moreover have "(w@w') \<in> LS M (after_initial M v) = (w' \<in> LS M (after_initial M (v@w)))"
by (meson \<open>w \<in> LS M (after_initial M v)\<close> after_language_append_iff after_language_iff assms(1) assms(4))
ultimately have "distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
moreover have "\<And> w'' . distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w'' \<Longrightarrow> length w' \<le> length w''"
proof -
fix w'' assume "distinguishes M (after_initial M (u@w)) (after_initial M (v@w)) w''"
then have "distinguishes M (after_initial M u) (after_initial M v) (w@w'')"
by (meson \<open>w \<in> LS M (after_initial M u)\<close> \<open>w \<in> LS M (after_initial M v)\<close> after_language_iff assms(1) assms(3) assms(4) distinguish_prepend_initial)
then have "length (w@w') \<le> length (w@w'')"
using assms(5) unfolding minimally_distinguishes_def distinguishes_def
by blast
then show "length w' \<le> length w''"
by auto
qed
ultimately show ?thesis
unfolding minimally_distinguishes_def distinguishes_def
by blast
qed
lemma minimally_distinguishes_proper_prefixes_card :
assumes "observable M"
and "minimal M"
and "q1 \<in> states M"
and "q2 \<in> states M"
and "minimally_distinguishes M q1 q2 w"
and "S \<subseteq> states M"
shows "card {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<le> card S - 1"
(is "?P S")
proof -
define k where "k = card S"
then show ?thesis
using assms(6)
proof (induction k arbitrary: S rule: less_induct)
case (less k)
then have "finite S"
by (metis fsm_states_finite rev_finite_subset)
show ?case proof (cases k)
case 0
then have "S = {}"
using less.prems \<open>finite S\<close> by auto
then show ?thesis
by fastforce
next
case (Suc k')
show ?thesis proof (cases "{w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} = {}")
case True
then show ?thesis
by (metis bot.extremum dual_order.eq_iff obtain_subset_with_card_n)
next
case False
define wk where wk: "wk = arg_max length (\<lambda>wk . wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S})"
obtain wk' where *:"wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
using False by blast
have "finite {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
by (metis (no_types) Collect_mem_eq List.finite_set finite_Collect_conjI)
then have "wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}"
and "\<And> wk' . wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<Longrightarrow> length wk' \<le> length wk"
using False unfolding wk
using arg_max_nat_lemma[of "(\<lambda>wk . wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S})", OF *]
by (meson finite_maxlen)+
then have "wk \<in> set (prefixes w)" and "wk \<noteq> w" and "after M q1 wk \<in> S" and "after M q2 wk \<in> S"
by blast+
obtain wk_suffix where "w = wk@wk_suffix" and "wk_suffix \<noteq> []"
using \<open>wk \<in> set (prefixes w)\<close>
using prefixes_set_ob \<open>wk \<noteq> w\<close>
by blast
have "distinguishes M (after M q1 []) (after M q2 []) w"
using \<open>minimally_distinguishes M q1 q2 w\<close>
by (metis after.simps(1) minimally_distinguishes_def)
have "minimally_distinguishes M (after M q1 wk) (after M q2 wk) wk_suffix"
using \<open>minimally_distinguishes M q1 q2 w\<close> \<open>wk_suffix \<noteq> []\<close>
unfolding \<open>w = wk@wk_suffix\<close>
using minimally_distinguishes_after_append[OF assms(1,2,3,4), of wk wk_suffix]
by blast
then have "distinguishes M (after M q1 wk) (after M q2 wk) wk_suffix"
unfolding minimally_distinguishes_def
by auto
then have "wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))"
unfolding distinguishes_def by blast
define S1 where S1: "S1 = Set.filter (\<lambda>q . wk_suffix \<in> LS M q) S"
define S2 where S2: "S2 = Set.filter (\<lambda>q . wk_suffix \<notin> LS M q) S"
have "S = S1 \<union> S2"
unfolding S1 S2 by auto
moreover have "S1 \<inter> S2 = {}"
unfolding S1 S2 by auto
ultimately have "card S = card S1 + card S2"
using \<open>finite S\<close> card_Un_disjoint by blast
have "S1 \<subseteq> states M" and "S2 \<subseteq> states M"
using \<open>S = S1 \<union> S2\<close> less.prems(2) by blast+
have "S1 \<noteq> {}" and "S2 \<noteq> {}"
using \<open>wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))\<close> \<open>after M q1 wk \<in> S\<close> \<open>after M q2 wk \<in> S\<close>
unfolding S1 S2
by (metis empty_iff member_filter)+
then have "card S1 > 0" and "card S2 > 0"
using \<open>S = S1 \<union> S2\<close> \<open>finite S\<close>
by (meson card_0_eq finite_Un neq0_conv)+
then have "card S1 < k" and "card S2 < k"
using \<open>card S = card S1 + card S2\<close> unfolding less.prems
by auto
define W where W: "W = (\<lambda> S1 S2 . {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S1 \<and> after M q2 w' \<in> S2})"
then have "\<And> S' S'' . W S' S'' \<subseteq> set (prefixes w)"
by auto
then have W_finite: "\<And> S' S'' . finite (W S' S'')"
using List.finite_set[of "prefixes w"]
by (meson finite_subset)
have "\<And> w' . w' \<in> W S S \<Longrightarrow> w' \<noteq> wk \<Longrightarrow> after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)"
proof -
fix w' assume *:"w' \<in> W S S" and "w' \<noteq> wk"
then have "w' \<in> set (prefixes w)" and "w' \<noteq> w" and "after M q1 w' \<in> S" and "after M q2 w' \<in> S"
unfolding W
by blast+
then have "w' \<in> LS M q1"
by (metis IntE UnCI UnE append_self_conv assms(5) distinguishes_def language_prefix leD length_append length_greater_0_conv less_add_same_cancel1 minimally_distinguishes_def prefixes_set_ob)
have "w' \<in> LS M q2"
by (metis IntE UnCI \<open>w' \<in> LS M q1\<close> \<open>w' \<in> set (prefixes w)\<close> \<open>w' \<noteq> w\<close> append_Nil2 assms(5) distinguishes_def leD length_append length_greater_0_conv less_add_same_cancel1 minimally_distinguishes_def prefixes_set_ob)
have "length w' < length wk"
using \<open>w' \<noteq> wk\<close> *
\<open>\<And> wk' . wk' \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S} \<Longrightarrow> length wk' \<le> length wk\<close>
unfolding W
by (metis (no_types, lifting) \<open>w = wk @ wk_suffix\<close> \<open>w' \<in> set (prefixes w)\<close> append_eq_append_conv le_neq_implies_less prefixes_set_ob)
show "after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)"
proof (rule ccontr)
assume "(after M q1 w' \<in> S1) \<noteq> (after M q2 w' \<in> S1)"
then have "(after M q1 w' \<in> S1 \<and> (after M q2 w' \<in> S2)) \<or> (after M q1 w' \<in> S2 \<and> (after M q2 w' \<in> S1))"
using \<open>after M q1 w' \<in> S\<close> \<open>after M q2 w' \<in> S\<close>
unfolding \<open>S = S1 \<union> S2\<close>
by blast
then have "wk_suffix \<in> LS M (after M q1 w') = (wk_suffix \<notin> LS M (after M q2 w'))"
unfolding S1 S2
by (metis member_filter)
then have "distinguishes M (after M q1 w') (after M q2 w') wk_suffix"
unfolding distinguishes_def by blast
then have "distinguishes M q1 q2 (w'@wk_suffix)"
using distinguish_prepend[OF assms(1) _ \<open>q1 \<in> states M\<close> \<open>q2 \<in> states M\<close> \<open>w' \<in> LS M q1\<close> \<open>w' \<in> LS M q2\<close>]
by blast
moreover have "length (w'@wk_suffix) < length (wk@wk_suffix)"
using \<open>length w' < length wk\<close>
by auto
ultimately show False
using \<open>minimally_distinguishes M q1 q2 w\<close>
unfolding \<open>w = wk@wk_suffix\<close> minimally_distinguishes_def
by auto
qed
qed
have "\<And> x . x \<in> W S1 S2 \<union> W S2 S1 \<Longrightarrow> x = wk"
proof -
fix x assume "x \<in> W S1 S2 \<union> W S2 S1"
then have "x \<in> W S S"
unfolding W \<open>S = S1 \<union> S2\<close> by blast
show "x = wk"
using \<open>x \<in> W S1 S2 \<union> W S2 S1\<close>
using \<open>\<And> w' . w' \<in> W S S \<Longrightarrow> w' \<noteq> wk \<Longrightarrow> after M q1 w' \<in> S1 = (after M q2 w' \<in> S1)\<close>[OF \<open>x \<in> W S S\<close>]
unfolding W
using \<open>S1 \<inter> S2 = {}\<close>
by blast
qed
moreover have "wk \<in> W S1 S2 \<union> W S2 S1"
unfolding W
using \<open>wk \<in> {w' . w' \<in> set (prefixes w) \<and> w' \<noteq> w \<and> after M q1 w' \<in> S \<and> after M q2 w' \<in> S}\<close>
\<open>wk_suffix \<in> LS M (after M q1 wk) = (wk_suffix \<notin> LS M (after M q2 wk))\<close>
by (metis (no_types, lifting) S1 Un_iff \<open>S = S1 \<union> S2\<close> mem_Collect_eq member_filter)
ultimately have "W S1 S2 \<union> W S2 S1 = {wk}"
by blast
have "W S S = (W S1 S1 \<union> W S2 S2 \<union> (W S1 S2 \<union> W S2 S1))"
unfolding W \<open>S = S1 \<union> S2\<close> by blast
moreover have "W S1 S1 \<inter> W S2 S2 = {}"
using \<open>S1 \<inter> S2 = {}\<close> unfolding W
by blast
moreover have "W S1 S1 \<inter> (W S1 S2 \<union> W S2 S1) = {}"
unfolding W
using \<open>S1 \<inter> S2 = {}\<close>
by blast
moreover have "W S2 S2 \<inter> (W S1 S2 \<union> W S2 S1) = {}"
unfolding W
using \<open>S1 \<inter> S2 = {}\<close>
by blast
moreover have "finite (W S1 S1)" and "finite (W S2 S2)" and "finite {wk}"
using W_finite by auto
ultimately have "card (W S S) = card (W S1 S1) + card (W S2 S2) + 1"
unfolding \<open>W S1 S2 \<union> W S2 S1 = {wk}\<close>
by (metis card_Un_disjoint finite_UnI inf_sup_distrib2 is_singletonI is_singleton_altdef sup_idem)
moreover have "card (W S1 S1) \<le> card S1 - 1"
using less.IH[OF \<open>card S1 < k\<close> _ \<open>S1 \<subseteq> states M\<close>]
unfolding W by blast
moreover have "card (W S2 S2) \<le> card S2 - 1"
using less.IH[OF \<open>card S2 < k\<close> _ \<open>S2 \<subseteq> states M\<close>]
unfolding W by blast
ultimately have "card (W S S) \<le> card S - 1"
using \<open>card S = card S1 + card S2\<close>
using \<open>card S1 < k\<close> \<open>card S2 < k\<close> less.prems(1) by linarith
then show ?thesis
unfolding W .
qed
qed
qed
qed
lemma minimally_distinguishes_proper_prefix_in_language :
assumes "minimally_distinguishes M q1 q2 io"
and "io' \<in> set (prefixes io)"
and "io' \<noteq> io"
shows "io' \<in> LS M q1 \<inter> LS M q2"
proof -
have "io \<in> LS M q1 \<or> io \<in> LS M q2"
using assms(1) unfolding minimally_distinguishes_def distinguishes_def by blast
then have "io' \<in> LS M q1 \<or> io' \<in> LS M q2"
by (metis assms(2) prefixes_set_ob language_prefix)
have "length io' < length io"
using assms(2,3) unfolding prefixes_set by auto
then have "io' \<in> LS M q1 \<longleftrightarrow> io' \<in> LS M q2"
using assms(1) unfolding minimally_distinguishes_def distinguishes_def
by (metis Int_iff Un_Int_eq(1) Un_Int_eq(2) leD)
then show ?thesis
using \<open>io' \<in> LS M q1 \<or> io' \<in> LS M q2\<close>
by blast
qed
lemma distinguishes_not_Nil:
assumes "distinguishes M q1 q2 io"
and "q1 \<in> states M"
and "q2 \<in> states M"
shows "io \<noteq> []"
using assms unfolding distinguishes_def by auto
fun does_distinguish :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('b \<times> 'c) list \<Rightarrow> bool" where
"does_distinguish M q1 q2 io = (is_in_language M q1 io \<noteq> is_in_language M q2 io)"
lemma does_distinguish_correctness :
assumes "observable M"
and "q1 \<in> states M"
and "q2 \<in> states M"
shows "does_distinguish M q1 q2 io = distinguishes M q1 q2 io"
unfolding does_distinguish.simps
is_in_language_iff[OF assms(1,2)]
is_in_language_iff[OF assms(1,3)]
distinguishes_def
by blast
lemma h_obs_distinguishes :
assumes "observable M"
and "h_obs M q1 x y = Some q1'"
and "h_obs M q2 x y = None"
shows "distinguishes M q1 q2 [(x,y)]"
using assms(2,3) LS_single_transition[of x y M] unfolding distinguishes_def h_obs_Some[OF assms(1)] h_obs_None[OF assms(1)]
by (metis Int_iff UnI1 \<open>\<And>y x q. (h_obs M q x y = None) = (\<nexists>q'. (q, x, y, q') \<in> FSM.transitions M)\<close> assms(1) assms(2) fst_conv h_obs_language_iff option.distinct(1) snd_conv)
lemma distinguishes_sym :
assumes "distinguishes M q1 q2 io"
shows "distinguishes M q2 q1 io"
using assms unfolding distinguishes_def by blast
lemma distinguishes_after_prepend :
assumes "observable M"
and "h_obs M q1 x y \<noteq> None"
and "h_obs M q2 x y \<noteq> None"
and "distinguishes M (FSM.after M q1 [(x,y)]) (FSM.after M q2 [(x,y)]) \<gamma>"
shows "distinguishes M q1 q2 ((x,y)#\<gamma>)"
proof -
have "[(x,y)] \<in> LS M q1"
using assms(2) h_obs_language_single_transition_iff[OF assms(1)] by auto
have "[(x,y)] \<in> LS M q2"
using assms(3) h_obs_language_single_transition_iff[OF assms(1)] by auto
show ?thesis
using after_language_iff[OF assms(1) \<open>[(x,y)] \<in> LS M q1\<close>, of \<gamma>]
using after_language_iff[OF assms(1) \<open>[(x,y)] \<in> LS M q2\<close>, of \<gamma>]
using assms(4)
unfolding distinguishes_def
by simp
qed
lemma distinguishes_after_initial_prepend :
assumes "observable M"
and "io1 \<in> L M"
and "io2 \<in> L M"
and "h_obs M (after_initial M io1) x y \<noteq> None"
and "h_obs M (after_initial M io2) x y \<noteq> None"
and "distinguishes M (after_initial M (io1@[(x,y)])) (after_initial M (io2@[(x,y)])) \<gamma>"
shows "distinguishes M (after_initial M io1) (after_initial M io2) ((x,y)#\<gamma>)"
by (metis after_split assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) distinguishes_after_prepend h_obs_language_append)
subsection \<open>Extending FSMs by single elements\<close>
lemma fsm_from_list_simps[simp] :
"initial (fsm_from_list q ts) = (case ts of [] \<Rightarrow> q | (t#ts) \<Rightarrow> t_source t)"
"states (fsm_from_list q ts) = (case ts of [] \<Rightarrow> {q} | (t#ts') \<Rightarrow> ((image t_source (set ts)) \<union> (image t_target (set ts))))"
"inputs (fsm_from_list q ts) = image t_input (set ts)"
"outputs (fsm_from_list q ts) = image t_output (set ts)"
"transitions (fsm_from_list q ts) = set ts"
by (cases ts; transfer; simp)+
lift_definition add_transition :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_transition
by simp
lemma add_transition_simps[simp]:
assumes "t_source t \<in> states M" and "t_input t \<in> inputs M" and "t_output t \<in> outputs M" and "t_target t \<in> states M"
shows
"initial (add_transition M t) = initial M"
"inputs (add_transition M t) = inputs M"
"outputs (add_transition M t) = outputs M"
"transitions (add_transition M t) = insert t (transitions M)"
"states (add_transition M t) = states M" using assms by (transfer; simp)+
lift_definition add_state :: "('a,'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_state
by simp
lemma add_state_simps[simp]:
"initial (add_state M q) = initial M"
"inputs (add_state M q) = inputs M"
"outputs (add_state M q) = outputs M"
"transitions (add_state M q) = transitions M"
"states (add_state M q) = insert q (states M)" by (transfer; simp)+
lift_definition add_input :: "('a,'b,'c) fsm \<Rightarrow> 'b \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_input
by simp
lemma add_input_simps[simp]:
"initial (add_input M x) = initial M"
"inputs (add_input M x) = insert x (inputs M)"
"outputs (add_input M x) = outputs M"
"transitions (add_input M x) = transitions M"
"states (add_input M x) = states M" by (transfer; simp)+
lift_definition add_output :: "('a,'b,'c) fsm \<Rightarrow> 'c \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_output
by simp
lemma add_output_simps[simp]:
"initial (add_output M y) = initial M"
"inputs (add_output M y) = inputs M"
"outputs (add_output M y) = insert y (outputs M)"
"transitions (add_output M y) = transitions M"
"states (add_output M y) = states M" by (transfer; simp)+
lift_definition add_transition_with_components :: "('a,'b,'c) fsm \<Rightarrow> ('a,'b,'c) transition \<Rightarrow> ('a,'b,'c) fsm" is FSM_Impl.add_transition_with_components
by simp
lemma add_transition_with_components_simps[simp]:
"initial (add_transition_with_components M t) = initial M"
"inputs (add_transition_with_components M t) = insert (t_input t) (inputs M)"
"outputs (add_transition_with_components M t) = insert (t_output t) (outputs M)"
"transitions (add_transition_with_components M t) = insert t (transitions M)"
"states (add_transition_with_components M t) = insert (t_target t) (insert (t_source t) (states M))"
by (transfer; simp)+
subsection \<open>Renaming Elements\<close>
lift_definition rename_states :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> 'd) \<Rightarrow> ('d,'b,'c) fsm" is FSM_Impl.rename_states
by simp
lemma rename_states_simps[simp]:
"initial (rename_states M f) = f (initial M)"
"states (rename_states M f) = f ` (states M)"
"inputs (rename_states M f) = inputs M"
"outputs (rename_states M f) = outputs M"
"transitions (rename_states M f) = (\<lambda>t . (f (t_source t), t_input t, t_output t, f (t_target t))) ` transitions M"
by (transfer; simp)+
lemma rename_states_isomorphism_language_state :
assumes "bij_betw f (states M) (f ` states M)"
and "q \<in> states M"
shows "LS (rename_states M f) (f q) = LS M q"
proof -
have *: "bij_betw f (FSM.states M) (FSM.states (FSM.rename_states M f))"
using assms rename_states_simps by auto
have **: "f (initial M) = initial (rename_states M f)"
using rename_states_simps by auto
have ***: "(\<And>q x y q'.
q \<in> states M \<Longrightarrow>
q' \<in> states M \<Longrightarrow> ((q, x, y, q') \<in> transitions M) = ((f q, x, y, f q') \<in> transitions (rename_states M f)))"
proof
fix q x y q' assume "q \<in> states M" and "q' \<in> states M"
show "(q, x, y, q') \<in> transitions M \<Longrightarrow> (f q, x, y, f q') \<in> transitions (rename_states M f)"
unfolding assms rename_states_simps by force
show "(f q, x, y, f q') \<in> transitions (rename_states M f) \<Longrightarrow> (q, x, y, q') \<in> transitions M"
proof -
assume "(f q, x, y, f q') \<in> transitions (rename_states M f)"
then obtain t where "(f q, x, y, f q') = (f (t_source t), t_input t, t_output t, f (t_target t))"
and "t \<in> transitions M"
unfolding assms rename_states_simps
by blast
then have "t_source t \<in> states M" and "t_target t \<in> states M" and "f (t_source t) = f q" and "f (t_target t) = f q'" and "t_input t = x" and "t_output t = y"
by auto
have "f q \<in> states (rename_states M f)" and "f q' \<in> states (rename_states M f)"
using \<open>(f q, x, y, f q') \<in> transitions (rename_states M f)\<close>
by auto
have "t_source t = q"
using \<open>f (t_source t) = f q\<close> \<open>q \<in> states M\<close> \<open>t_source t \<in> states M\<close>
using assms unfolding bij_betw_def inj_on_def
by blast
moreover have "t_target t = q'"
using \<open>f (t_target t) = f q'\<close> \<open>q' \<in> states M\<close> \<open>t_target t \<in> states M\<close>
using assms unfolding bij_betw_def inj_on_def
by blast
ultimately show "(q, x, y, q') \<in> transitions M"
using \<open>t_input t = x\<close> \<open>t_output t = y\<close> \<open>t \<in> transitions M\<close>
by auto
qed
qed
show ?thesis
using language_equivalence_from_isomorphism[OF * ** *** assms(2)]
by blast
qed
lemma rename_states_isomorphism_language :
assumes "bij_betw f (states M) (f ` states M)"
shows "L (rename_states M f) = L M"
using rename_states_isomorphism_language_state[OF assms fsm_initial]
unfolding rename_states_simps .
lemma rename_states_observable :
assumes "bij_betw f (states M) (f ` states M)"
and "observable M"
shows "observable (rename_states M f)"
proof -
have "\<And> q1 x y q1' q1'' . (q1,x,y,q1') \<in> transitions (rename_states M f) \<Longrightarrow> (q1,x,y,q1'') \<in> transitions (rename_states M f) \<Longrightarrow> q1' = q1''"
proof -
fix q1 x y q1' q1''
assume "(q1,x,y,q1') \<in> transitions (rename_states M f)" and "(q1,x,y,q1'') \<in> transitions (rename_states M f)"
then obtain t' t'' where "t' \<in> transitions M"
and "t'' \<in> transitions M"
and "(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1,x,y,q1')"
and "(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1,x,y,q1'')"
unfolding rename_states_simps
by force
then have "f (t_source t') = f (t_source t'')"
by auto
moreover have "t_source t' \<in> states M" and "t_source t'' \<in> states M"
using \<open>t' \<in> transitions M\<close> \<open>t'' \<in> transitions M\<close>
by auto
ultimately have "t_source t' = t_source t''"
using assms(1)
unfolding bij_betw_def inj_on_def by blast
then have "t_target t' = t_target t''"
using assms(2) unfolding observable.simps
by (metis Pair_inject \<open>(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1, x, y, q1'')\<close> \<open>(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1, x, y, q1')\<close> \<open>t' \<in> FSM.transitions M\<close> \<open>t'' \<in> FSM.transitions M\<close>)
then show "q1' = q1''"
using \<open>(f (t_source t''), t_input t'', t_output t'', f (t_target t'')) = (q1, x, y, q1'')\<close> \<open>(f (t_source t'), t_input t', t_output t', f (t_target t')) = (q1, x, y, q1')\<close> by auto
qed
then show ?thesis
unfolding observable_alt_def by blast
qed
lemma rename_states_minimal :
assumes "bij_betw f (states M) (f ` states M)"
and "minimal M"
shows "minimal (rename_states M f)"
proof -
have "\<And> q q' . q \<in> f ` FSM.states M \<Longrightarrow> q' \<in> f ` FSM.states M \<Longrightarrow> q \<noteq> q' \<Longrightarrow> LS (rename_states M f) q \<noteq> LS (rename_states M f) q'"
proof -
fix q q' assume "q \<in> f ` FSM.states M" and "q' \<in> f ` FSM.states M" and "q \<noteq> q'"
then obtain fq fq' where "fq \<in> states M" and "fq' \<in> states M" and "q = f fq" and "q' = f fq'"
by auto
then have "fq \<noteq> fq'"
using \<open>q \<noteq> q'\<close> by auto
then have "LS M fq \<noteq> LS M fq'"
by (meson \<open>fq \<in> FSM.states M\<close> \<open>fq' \<in> FSM.states M\<close> assms(2) minimal.elims(2))
then show "LS (rename_states M f) q \<noteq> LS (rename_states M f) q'"
using rename_states_isomorphism_language_state[OF assms(1)]
by (simp add: \<open>fq \<in> FSM.states M\<close> \<open>fq' \<in> FSM.states M\<close> \<open>q = f fq\<close> \<open>q' = f fq'\<close>)
qed
then show ?thesis
by auto
qed
fun index_states :: "('a::linorder,'b,'c) fsm \<Rightarrow> (nat,'b,'c) fsm" where
"index_states M = rename_states M (assign_indices (states M))"
lemma assign_indices_bij_betw: "bij_betw (assign_indices (FSM.states M)) (FSM.states M) (assign_indices (FSM.states M) ` FSM.states M)"
using assign_indices_bij[OF fsm_states_finite[of M]]
by (simp add: bij_betw_def)
lemma index_states_language :
"L (index_states M) = L M"
using rename_states_isomorphism_language[of "assign_indices (states M)" M, OF assign_indices_bij_betw]
by auto
lemma index_states_observable :
assumes "observable M"
shows "observable (index_states M)"
using rename_states_observable[of "assign_indices (states M)", OF assign_indices_bij_betw assms]
unfolding index_states.simps .
lemma index_states_minimal :
assumes "minimal M"
shows "minimal (index_states M)"
using rename_states_minimal[of "assign_indices (states M)", OF assign_indices_bij_betw assms]
unfolding index_states.simps .
fun index_states_integer :: "('a::linorder,'b,'c) fsm \<Rightarrow> (integer,'b,'c) fsm" where
"index_states_integer M = rename_states M (integer_of_nat \<circ> assign_indices (states M))"
lemma assign_indices_integer_bij_betw: "bij_betw (integer_of_nat \<circ> assign_indices (states M)) (FSM.states M) ((integer_of_nat \<circ> assign_indices (states M)) ` FSM.states M)"
proof -
have *: "inj_on (assign_indices (FSM.states M)) (FSM.states M)"
using assign_indices_bij[OF fsm_states_finite[of M]]
unfolding bij_betw_def
by auto
then have "inj_on (integer_of_nat \<circ> assign_indices (states M)) (FSM.states M)"
unfolding inj_on_def
by (metis comp_apply nat_of_integer_integer_of_nat)
then show ?thesis
unfolding bij_betw_def
by auto
qed
lemma index_states_integer_language :
"L (index_states_integer M) = L M"
using rename_states_isomorphism_language[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw]
by auto
lemma index_states_integer_observable :
assumes "observable M"
shows "observable (index_states_integer M)"
using rename_states_observable[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw assms]
unfolding index_states_integer.simps .
lemma index_states_integer_minimal :
assumes "minimal M"
shows "minimal (index_states_integer M)"
using rename_states_minimal[of "integer_of_nat \<circ> assign_indices (states M)" M, OF assign_indices_integer_bij_betw assms]
unfolding index_states_integer.simps .
subsection \<open>Canonical Separators\<close>
lift_definition canonical_separator' :: "('a,'b,'c) fsm \<Rightarrow> (('a \<times> 'a),'b,'c) fsm \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> (('a \<times> 'a) + 'a,'b,'c) fsm" is FSM_Impl.canonical_separator'
proof -
fix A :: "('a,'b,'c) fsm_impl"
fix B :: "('a \<times> 'a,'b,'c) fsm_impl"
fix q1 :: 'a
fix q2 :: 'a
assume "well_formed_fsm A" and "well_formed_fsm B"
then have p1a: "fsm_impl.initial A \<in> fsm_impl.states A"
and p2a: "finite (fsm_impl.states A)"
and p3a: "finite (fsm_impl.inputs A)"
and p4a: "finite (fsm_impl.outputs A)"
and p5a: "finite (fsm_impl.transitions A)"
and p6a: "(\<forall>t\<in>fsm_impl.transitions A.
t_source t \<in> fsm_impl.states A \<and>
t_input t \<in> fsm_impl.inputs A \<and> t_target t \<in> fsm_impl.states A \<and>
t_output t \<in> fsm_impl.outputs A)"
and p1b: "fsm_impl.initial B \<in> fsm_impl.states B"
and p2b: "finite (fsm_impl.states B)"
and p3b: "finite (fsm_impl.inputs B)"
and p4b: "finite (fsm_impl.outputs B)"
and p5b: "finite (fsm_impl.transitions B)"
and p6b: "(\<forall>t\<in>fsm_impl.transitions B.
t_source t \<in> fsm_impl.states B \<and>
t_input t \<in> fsm_impl.inputs B \<and> t_target t \<in> fsm_impl.states B \<and>
t_output t \<in> fsm_impl.outputs B)"
by simp+
let ?P = "FSM_Impl.canonical_separator' A B q1 q2"
show "well_formed_fsm ?P" proof (cases "fsm_impl.initial B = (q1,q2)")
case False
then show ?thesis by auto
next
case True
let ?f = "(\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {}))"
have "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx"
proof -
fix qx
show "\<And> qx . (\<lambda>qx . (case (set_as_map (image (\<lambda>(q,x,y,q') . ((q,x),y)) (fsm_impl.transitions A))) qx of Some yqs \<Rightarrow> yqs | None \<Rightarrow> {})) qx = (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx"
unfolding set_as_map_def by (cases "\<exists>z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A"; auto)
qed
moreover have "\<And> qx . (\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A}) qx"
proof -
fix qx
show "(\<lambda> qx . {z. (qx, z) \<in> (\<lambda>(q, x, y, q'). ((q, x), y)) ` fsm_impl.transitions A}) qx = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A}) qx"
by force
qed
ultimately have *:" ?f = (\<lambda> qx . {y | y . \<exists> q' . (fst qx, snd qx, y, q') \<in> fsm_impl.transitions A})"
by blast
let ?shifted_transitions' = "shifted_transitions (fsm_impl.transitions B)"
let ?distinguishing_transitions_lr = "distinguishing_transitions ?f q1 q2 (fsm_impl.states B) (fsm_impl.inputs B)"
let ?ts = "?shifted_transitions' \<union> ?distinguishing_transitions_lr"
have "FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}"
and "FSM_Impl.transitions ?P = ?ts"
unfolding FSM_Impl.canonical_separator'.simps Let_def True by simp+
have p2: "finite (fsm_impl.states ?P)"
unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> using p2b by blast
have "fsm_impl.initial ?P = Inl (q1,q2)" by auto
then have p1: "fsm_impl.initial ?P \<in> fsm_impl.states ?P"
using p1a p1b unfolding canonical_separator'.simps True by auto
have p3: "finite (fsm_impl.inputs ?P)"
using p3a p3b by auto
have p4: "finite (fsm_impl.outputs ?P)"
using p4a p4b by auto
have "finite (fsm_impl.states B \<times> fsm_impl.inputs B)"
using p2b p3b by blast
moreover have **: "\<And> x q1 . finite ({y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A})"
proof -
fix x q1
have "{y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A} = {t_output t | t . t \<in> fsm_impl.transitions A \<and> t_source t = q1 \<and> t_input t = x}"
by auto
then have "{y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A} \<subseteq> image t_output (fsm_impl.transitions A)"
unfolding fst_conv snd_conv by blast
moreover have "finite (image t_output (fsm_impl.transitions A))"
using p5a by auto
ultimately show "finite ({y |y. \<exists>q'. (fst (q1, x), snd (q1, x), y, q') \<in> fsm_impl.transitions A})"
by (simp add: finite_subset)
qed
ultimately have "finite ?distinguishing_transitions_lr"
unfolding * distinguishing_transitions_def by force
moreover have "finite ?shifted_transitions'"
unfolding shifted_transitions_def using p5b by auto
ultimately have "finite ?ts" by blast
then have p5: "finite (fsm_impl.transitions ?P)"
by simp
have "fsm_impl.inputs ?P = fsm_impl.inputs A \<union> fsm_impl.inputs B"
using True by auto
have "fsm_impl.outputs ?P = fsm_impl.outputs A \<union> fsm_impl.outputs B"
using True by auto
have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> shifted_transitions_def
using p6b by force
moreover have "\<And> t . t \<in> ?distinguishing_transitions_lr \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
unfolding \<open>FSM_Impl.states ?P = (image Inl (FSM_Impl.states B)) \<union> {Inr q1, Inr q2}\<close> distinguishing_transitions_def * by force
ultimately have "\<And> t . t \<in> ?ts \<Longrightarrow> t_source t \<in> fsm_impl.states ?P \<and> t_target t \<in> fsm_impl.states ?P"
by blast
moreover have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
proof -
have "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs B \<and> t_output t \<in> fsm_impl.outputs B"
unfolding shifted_transitions_def using p6b by auto
then show "\<And> t . t \<in> ?shifted_transitions' \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
unfolding \<open>fsm_impl.inputs ?P = fsm_impl.inputs A \<union> fsm_impl.inputs B\<close>
\<open>fsm_impl.outputs ?P = fsm_impl.outputs A \<union> fsm_impl.outputs B\<close> by blast
qed
moreover have "\<And> t . t \<in> ?distinguishing_transitions_lr \<Longrightarrow> t_input t \<in> fsm_impl.inputs ?P \<and> t_output t \<in> fsm_impl.outputs ?P"
unfolding * distinguishing_transitions_def using p6a p6b True by auto
ultimately have p6: "(\<forall>t\<in>fsm_impl.transitions ?P.
t_source t \<in> fsm_impl.states ?P \<and>
t_input t \<in> fsm_impl.inputs ?P \<and> t_target t \<in> fsm_impl.states ?P \<and>
t_output t \<in> fsm_impl.outputs ?P)"
unfolding \<open>FSM_Impl.transitions ?P = ?ts\<close> by blast
show "well_formed_fsm ?P"
using p1 p2 p3 p4 p5 p6 by linarith
qed
qed
lemma canonical_separator'_simps :
assumes "initial P = (q1,q2)"
shows "initial (canonical_separator' M P q1 q2) = Inl (q1,q2)"
"states (canonical_separator' M P q1 q2) = (image Inl (states P)) \<union> {Inr q1, Inr q2}"
"inputs (canonical_separator' M P q1 q2) = inputs M \<union> inputs P"
"outputs (canonical_separator' M P q1 q2) = outputs M \<union> outputs P"
"transitions (canonical_separator' M P q1 q2)
= shifted_transitions (transitions P)
\<union> distinguishing_transitions (h_out M) q1 q2 (states P) (inputs P)"
using assms unfolding h_out_code by (transfer; auto)+
lemma canonical_separator'_simps_without_assm :
"initial (canonical_separator' M P q1 q2) = Inl (q1,q2)"
"states (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then (image Inl (states P)) \<union> {Inr q1, Inr q2} else {Inl (q1,q2)})"
"inputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then inputs M \<union> inputs P else {})"
"outputs (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then outputs M \<union> outputs P else {})"
"transitions (canonical_separator' M P q1 q2) = (if initial P = (q1,q2) then shifted_transitions (transitions P) \<union> distinguishing_transitions (h_out M) q1 q2 (states P) (inputs P) else {})"
unfolding h_out_code by (transfer; simp add: Let_def)+
end
\ No newline at end of file
diff --git a/thys/FSM_Tests/Minimisation.thy b/thys/FSM_Tests/Minimisation.thy
--- a/thys/FSM_Tests/Minimisation.thy
+++ b/thys/FSM_Tests/Minimisation.thy
@@ -1,1846 +1,1846 @@
section \<open>Minimisation by OFSM Tables\<close>
text \<open>This theory presents the classical algorithm for transforming observable FSMs into
language-equivalent observable and minimal FSMs in analogy to the minimisation of
finite automata.\<close>
theory Minimisation
imports FSM
begin
subsection \<open>OFSM Tables\<close>
text \<open>OFSM tables partition the states of an FSM based on an initial partition and an iteration
counter.
States are in the same element of the 0th table iff they are in the same element of the
initial partition.
States q1, q2 are in the same element of the (k+1)-th table if they are in the same element of
the k-th table and furthermore for each IO pair (x,y) either (x,y) is not in the language of
both q1 and q2 or it is in the language of both states and the states q1', q2' reached via
(x,y) from q1 and q2, respectively, are in the same element of the k-th table.\<close>
fun ofsm_table :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a set" where
"ofsm_table M f 0 q = (if q \<in> states M then f q else {})" |
"ofsm_table M f (Suc k) q = (let
prev_table = ofsm_table M f k
in {q' \<in> prev_table q . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> prev_table qT = prev_table qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None) })"
lemma ofsm_table_non_state :
assumes "q \<notin> states M"
shows "ofsm_table M f k q = {}"
using assms by (induction k; auto)
lemma ofsm_table_subset:
assumes "i \<le> j"
shows "ofsm_table M f j q \<subseteq> ofsm_table M f i q"
proof -
have *: "\<And> k . ofsm_table M f (Suc k) q \<subseteq> ofsm_table M f k q"
proof -
fix k show "ofsm_table M f (Suc k) q \<subseteq> ofsm_table M f k q"
proof (cases k)
case 0
show ?thesis unfolding 0 ofsm_table.simps Let_def by blast
next
case (Suc k')
show ?thesis
unfolding Suc ofsm_table.simps Let_def by force
qed
qed
show ?thesis
using assms
proof (induction j)
case 0
then show ?case by auto
next
case (Suc x)
then show ?case using *[of x]
using le_SucE by blast
qed
qed
lemma ofsm_table_case_helper :
"(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)
= ((\<exists> qT qT' . h_obs M q x y = Some qT \<and> h_obs M q' x y = Some qT' \<and> ofsm_table M f k qT = ofsm_table M f k qT') \<or> (h_obs M q x y = None \<and> h_obs M q' x y = None))"
proof -
have *: "\<And> a b P . (case a of Some a' \<Rightarrow> (case b of Some b' \<Rightarrow> P a' b' | None \<Rightarrow> False) | None \<Rightarrow> b = None)
= ((\<exists> a' b' . a = Some a' \<and> b = Some b' \<and> P a' b') \<or> (a = None \<and> b = None))"
(is "\<And> a b P . ?P1 a b P = ?P2 a b P")
proof
fix a b P
show "?P1 a b P \<Longrightarrow> ?P2 a b P" using case_optionE[of "b = None" "\<lambda>a' . (case b of Some b' \<Rightarrow> P a' b' | None \<Rightarrow> False)" a]
by (metis case_optionE)
show "?P2 a b P \<Longrightarrow> ?P1 a b P" by auto
qed
show ?thesis
using *[of "h_obs M q' x y" "\<lambda>qT qT' . ofsm_table M f k qT = ofsm_table M f k qT'" "h_obs M q x y"] .
qed
lemma ofsm_table_case_helper_neg :
"(\<not> (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None))
= ((\<exists> qT qT' . h_obs M q x y = Some qT \<and> h_obs M q' x y = Some qT' \<and> ofsm_table M f k qT \<noteq> ofsm_table M f k qT') \<or> (h_obs M q x y = None \<longleftrightarrow> h_obs M q' x y \<noteq> None))"
unfolding ofsm_table_case_helper by force
lemma ofsm_table_fixpoint :
assumes "i \<le> j"
and "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f (Suc i) q = ofsm_table M f i q"
and "q \<in> states M"
shows "ofsm_table M f j q = ofsm_table M f i q"
proof -
have *: "\<And> k . k \<ge> i \<Longrightarrow> (\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f (Suc k) q = ofsm_table M f k q)"
proof -
fix k :: nat assume "k \<ge> i"
then show "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f (Suc k) q = ofsm_table M f k q"
proof (induction k)
case 0
then show ?case using assms(2) by auto
next
case (Suc k)
show "ofsm_table M f (Suc (Suc k)) q = ofsm_table M f (Suc k) q"
proof (cases "i = Suc k")
case True
then show ?thesis using assms(2)[OF \<open>q \<in> states M\<close>] by simp
next
case False
then have "i \<le> k"
using \<open>i \<le> Suc k\<close> by auto
have h_obs_state: "\<And> q x y qT . h_obs M q x y = Some qT \<Longrightarrow> qT \<in> states M"
using h_obs_state by fastforce
show ?thesis
proof (rule ccontr)
assume "ofsm_table M f (Suc (Suc k)) q \<noteq> ofsm_table M f (Suc k) q"
moreover have "ofsm_table M f (Suc (Suc k)) q \<subseteq> ofsm_table M f (Suc k) q"
using ofsm_table_subset
by (metis (full_types) Suc_n_not_le_n nat_le_linear)
ultimately obtain q' where "q' \<notin> {q' \<in> ofsm_table M f (Suc k) q . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f (Suc k) qT = ofsm_table M f (Suc k) qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None) }"
and "q' \<in> ofsm_table M f (Suc k) q"
using ofsm_table.simps(2)[of M f "Suc k" q] unfolding Let_def by blast
then have "\<not>(\<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f (Suc k) qT = ofsm_table M f (Suc k) qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None))"
by blast
then obtain x y where "x \<in> inputs M" and "y \<in> outputs M" and "\<not> (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f (Suc k) qT = ofsm_table M f (Suc k) qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
by blast
then consider "\<exists> qT qT' . h_obs M q x y = Some qT \<and> h_obs M q' x y = Some qT' \<and> ofsm_table M f (Suc k) qT \<noteq> ofsm_table M f (Suc k) qT'" |
"(h_obs M q x y = None \<longleftrightarrow> h_obs M q' x y \<noteq> None)"
unfolding ofsm_table_case_helper_neg by blast
then show False proof cases
case 1
then obtain qT qT' where "h_obs M q x y = Some qT" and "h_obs M q' x y = Some qT'" and "ofsm_table M f (Suc k) qT \<noteq> ofsm_table M f (Suc k) qT'"
by blast
then have "ofsm_table M f k qT \<noteq> ofsm_table M f k qT'"
using Suc.IH[OF h_obs_state[OF \<open>h_obs M q x y = Some qT\<close>] \<open>i \<le> k\<close>]
Suc.IH[OF h_obs_state[OF \<open>h_obs M q' x y = Some qT'\<close>] \<open>i \<le> k\<close>]
by fast
moreover have "q' \<in> ofsm_table M f k q"
using ofsm_table_subset[of k "Suc k"] \<open>q' \<in> ofsm_table M f (Suc k) q\<close> by force
ultimately have "ofsm_table M f (Suc k) q \<noteq> ofsm_table M f k q"
using \<open>x \<in> inputs M\<close> \<open>y \<in> outputs M\<close> \<open>h_obs M q x y = Some qT\<close> \<open>h_obs M q' x y = Some qT'\<close>
unfolding ofsm_table.simps(2) Let_def by force
then show ?thesis
using Suc.IH[OF Suc.prems(1) \<open>i \<le> k\<close>] by simp
next
case 2
then have "\<not> (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
unfolding ofsm_table_case_helper_neg by blast
moreover have "q' \<in> ofsm_table M f k q"
using ofsm_table_subset[of k "Suc k"] \<open>q' \<in> ofsm_table M f (Suc k) q\<close> by force
ultimately have "ofsm_table M f (Suc k) q \<noteq> ofsm_table M f k q"
using \<open>x \<in> inputs M\<close> \<open>y \<in> outputs M\<close>
unfolding ofsm_table.simps(2) Let_def by force
then show ?thesis
using Suc.IH[OF Suc.prems(1) \<open>i \<le> k\<close>] by simp
qed
qed
qed
qed
qed
show ?thesis
using assms(1) proof (induction "j")
case 0
then show ?case by auto
next
case (Suc j)
show ?case proof (cases "i = Suc j")
case True
then show ?thesis by simp
next
case False
then have "i \<le> j"
using Suc.prems(1) by auto
then have "ofsm_table M f j q = ofsm_table M f i q"
using Suc.IH by auto
moreover have "ofsm_table M f (Suc j) q = ofsm_table M f j q"
using *[OF \<open>i\<le>j\<close> \<open>q\<in>states M\<close>] by assumption
ultimately show ?thesis
by blast
qed
qed
qed
(* restricts the range of the supplied function to the states of the FSM - required for (easy) termination *)
function ofsm_table_fix :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a set" where
"ofsm_table_fix M f k = (let
cur_table = ofsm_table M (\<lambda>q. f q \<inter> states M) k;
next_table = ofsm_table M (\<lambda>q. f q \<inter> states M) (Suc k)
in if (\<forall> q \<in> states M . cur_table q = next_table q)
then cur_table
else ofsm_table_fix M f (Suc k))"
by pat_completeness auto
termination
proof -
{
fix M :: "('a,'b,'c) fsm"
and f :: "('a \<Rightarrow> 'a set)"
and k :: nat
define f' where f': "f' = (\<lambda>q. f q \<inter> states M)"
assume "\<exists>q\<in>FSM.states M. ofsm_table M (\<lambda>q. f q \<inter> states M) k q \<noteq> ofsm_table M (\<lambda>q. f q \<inter> states M) (Suc k) q"
then obtain q where "q \<in> states M"
and "ofsm_table M f' k q \<noteq> ofsm_table M f' (Suc k) q"
unfolding f' by blast
have *: "\<And> k . (\<Sum>q\<in>FSM.states M. card (ofsm_table M f' k q)) = card (ofsm_table M f' k q) + (\<Sum>q\<in>FSM.states M - {q}. card (ofsm_table M f' k q))"
using \<open>q \<in> states M\<close> by (meson fsm_states_finite sum.remove)
have "\<And> q . ofsm_table M f' (Suc k) q \<subseteq> ofsm_table M f' k q"
using ofsm_table_subset[of k "Suc k" M ] by auto
moreover have "\<And> q . finite (ofsm_table M f' k q)"
proof -
fix q
have "ofsm_table M (\<lambda>q. f q \<inter> states M) k q \<subseteq> ofsm_table M (\<lambda>q. f q \<inter> states M) 0 q"
using ofsm_table_subset[of 0 k M "(\<lambda>q. f q \<inter> FSM.states M)" q] by auto
then have "ofsm_table M f' k q \<subseteq> states M"
unfolding f'
using ofsm_table_non_state[of q M "(\<lambda>q. f q \<inter> FSM.states M)" k]
by force
then show "finite (ofsm_table M f' k q)"
using fsm_states_finite finite_subset by auto
qed
ultimately have "\<And> q . card (ofsm_table M f' (Suc k) q) \<le> card (ofsm_table M f' k q)"
by (simp add: card_mono)
then have "(\<Sum>q\<in>FSM.states M - {q}. card (ofsm_table M f' (Suc k) q)) \<le> (\<Sum>q\<in>FSM.states M - {q}. card (ofsm_table M f' k q))"
by (simp add: sum_mono)
moreover have "card (ofsm_table M f' (Suc k) q) < card (ofsm_table M f' k q)"
using \<open>ofsm_table M f' k q \<noteq> ofsm_table M f' (Suc k) q\<close> \<open>ofsm_table M f' (Suc k) q \<subseteq> ofsm_table M f' k q\<close> \<open>finite (ofsm_table M f' k q)\<close>
by (metis psubsetI psubset_card_mono)
ultimately have "(\<Sum>q\<in>FSM.states M. card (ofsm_table M (\<lambda>q. f q \<inter> states M) (Suc k) q)) < (\<Sum>q\<in>FSM.states M. card (ofsm_table M (\<lambda>q. f q \<inter> states M) k q))"
unfolding f'[symmetric] *
by linarith
} note t = this
show ?thesis
apply (relation "measure (\<lambda> (M, f, k) . \<Sum> q \<in> states M . card (ofsm_table M (\<lambda>q. f q \<inter> states M) k q))")
apply (simp del: h_obs.simps ofsm_table.simps)+
by (erule t)
qed
lemma ofsm_table_restriction_to_states :
assumes "\<And> q . q \<in> states M \<Longrightarrow> f q \<subseteq> states M"
and "q \<in> states M"
shows "ofsm_table M f k q = ofsm_table M (\<lambda>q . f q \<inter> states M) k q"
using assms(2) proof (induction k arbitrary: q)
case 0
then show ?case using assms(1) by auto
next
case (Suc k)
have "\<And> x y q q' . (case h_obs M q x y of None \<Rightarrow> h_obs M q' x y = None | Some qT \<Rightarrow> (case h_obs M q' x y of None \<Rightarrow> False | Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT'))
= (case h_obs M q x y of None \<Rightarrow> h_obs M q' x y = None | Some qT \<Rightarrow> (case h_obs M q' x y of None \<Rightarrow> False | Some qT' \<Rightarrow> ofsm_table M (\<lambda>q . f q \<inter> states M) k qT = ofsm_table M (\<lambda>q . f q \<inter> states M) k qT'))"
(is "\<And> x y q q' . ?C1 x y q q' = ?C2 x y q q' ")
proof -
fix x y q q'
show "?C1 x y q q' = ?C2 x y q q'"
using Suc.IH[OF h_obs_state, of q x y]
using Suc.IH[OF h_obs_state, of q' x y]
by (cases "h_obs M q x y"; cases "h_obs M q' x y"; auto)
qed
then show ?case
unfolding ofsm_table.simps Let_def Suc.IH[OF Suc.prems]
by blast
qed
lemma ofsm_table_fix_length :
assumes "\<And> q . q \<in> states M \<Longrightarrow> f q \<subseteq> states M"
obtains k where "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M f 0 q = ofsm_table M f k q" and "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
proof -
have "\<exists> k . \<forall> q \<in> states M . \<forall> k' \<ge> k . ofsm_table M f k' q = ofsm_table M f k q"
proof -
have "\<exists> fp . \<forall> q k' . q \<in> states M \<longrightarrow> k' \<ge> (fp q) \<longrightarrow> ofsm_table M f k' q = ofsm_table M f (fp q) q"
proof
fix q
let ?assignK = "\<lambda> q . SOME k . \<forall> k' \<ge> k . ofsm_table M f k' q = ofsm_table M f k q"
have "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> ?assignK q \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (?assignK q) q"
proof -
fix q k' assume "q \<in> states M" and "k' \<ge> ?assignK q"
then have p1: "finite (ofsm_table M f 0 q)"
using fsm_states_finite assms(1)
using infinite_super by fastforce
have "\<exists> k . \<forall> k' \<ge> k . ofsm_table M f k' q = ofsm_table M f k q"
using finite_subset_mapping_limit[of "\<lambda> k . ofsm_table M f k q", OF p1 ofsm_table_subset] by metis
have "\<forall> k' \<ge> (?assignK q) . ofsm_table M f k' q = ofsm_table M f (?assignK q) q"
using someI_ex[of "\<lambda> k . \<forall> k' \<ge> k . ofsm_table M f k' q = ofsm_table M f k q", OF \<open>\<exists> k . \<forall> k' \<ge> k . ofsm_table M f k' q = ofsm_table M f k q\<close>] by assumption
then show "ofsm_table M f k' q = ofsm_table M f (?assignK q) q"
using \<open>k' \<ge> ?assignK q\<close> by blast
qed
then show "\<forall>q k'. q \<in> states M \<longrightarrow> ?assignK q \<le> k' \<longrightarrow> ofsm_table M f k' q = ofsm_table M f (?assignK q) q"
by blast
qed
then obtain assignK where assignK_prop: "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> assignK q \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (assignK q) q"
by blast
have "finite (assignK ` states M)"
by (simp add: fsm_states_finite)
moreover have "assignK ` FSM.states M \<noteq> {}"
using fsm_initial by auto
ultimately obtain k where "k \<in> (assignK ` states M)" and "\<And> k' . k' \<in> (assignK ` states M) \<Longrightarrow> k' \<le> k"
using Max_elem[OF \<open>finite (assignK ` states M)\<close> \<open>assignK ` FSM.states M \<noteq> {}\<close>] by (meson eq_Max_iff)
have "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
proof -
fix q k' assume "k' \<ge> k" and "q \<in> states M"
then have "k' \<ge> assignK q"
using \<open>\<And> k' . k' \<in> (assignK ` states M) \<Longrightarrow> k' \<le> k\<close>
using dual_order.trans by auto
then show "ofsm_table M f k' q = ofsm_table M f k q"
using assignK_prop \<open>\<And>k'. k' \<in> assignK ` FSM.states M \<Longrightarrow> k' \<le> k\<close> \<open>q \<in> FSM.states M\<close> by blast
qed
then show ?thesis
by blast
qed
then obtain k where k_prop: "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
by blast
then have "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f k q = ofsm_table M f (Suc k) q"
by (metis (full_types) le_SucI order_refl)
let ?ks = "(Set.filter (\<lambda> k . \<forall> q \<in> states M . ofsm_table M f k q = ofsm_table M f (Suc k) q) {..k})"
have f1: "finite ?ks"
by simp
moreover have f2: "?ks \<noteq> {}"
using \<open>\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f k q = ofsm_table M f (Suc k) q\<close> unfolding Set.filter_def by blast
ultimately obtain kMin where "kMin \<in> ?ks" and "\<And> k' . k' \<in> ?ks \<Longrightarrow> k' \<ge> kMin"
using Min_elem[OF f1 f2] by (meson eq_Min_iff)
have k1: "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f (Suc kMin) q = ofsm_table M f kMin q"
using \<open>kMin \<in> ?ks\<close>
by (metis (mono_tags, lifting) member_filter)
have k2: "\<And> k' . (\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (Suc k') q) \<Longrightarrow> k' \<ge> kMin"
proof -
fix k' assume "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (Suc k') q"
show "k' \<ge> kMin" proof (cases "k' \<in> ?ks")
case True
then show ?thesis using \<open>\<And> k' . k' \<in> ?ks \<Longrightarrow> k' \<ge> kMin\<close> by blast
next
case False
then have "k' > k"
using \<open>\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (Suc k') q\<close>
unfolding member_filter atMost_iff
by (meson not_less)
moreover have "kMin \<le> k"
using \<open>kMin \<in> ?ks\<close> by auto
ultimately show ?thesis
by auto
qed
qed
have "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M f 0 q = ofsm_table M (\<lambda> q . f q \<inter> states M) kMin q"
proof -
fix q assume "q \<in> states M"
show "ofsm_table_fix M f 0 q = ofsm_table M (\<lambda> q . f q \<inter> states M) kMin q"
proof (cases kMin)
case 0
have "\<forall>q\<in>FSM.states M. ofsm_table M (\<lambda>q. f q \<inter> FSM.states M) 0 q = ofsm_table M (\<lambda>q. f q \<inter> FSM.states M) (Suc 0) q"
using k1
using ofsm_table_restriction_to_states[of M f _, OF assms(1) _ ]
using "0" by blast
then show ?thesis
apply (subst ofsm_table_fix.simps)
unfolding "0" Let_def by force
next
case (Suc kMin')
have *: "\<And> i . i < kMin \<Longrightarrow> \<not>(\<forall> q \<in> states M . ofsm_table M f i q = ofsm_table M f (Suc i) q)"
using k2
by (meson leD)
have "\<And> i . i < kMin \<Longrightarrow> ofsm_table_fix M f 0 = ofsm_table_fix M f (Suc i)"
proof -
fix i assume "i < kMin"
then show "ofsm_table_fix M f 0 = ofsm_table_fix M f (Suc i)"
proof (induction i)
case 0
show ?case
using *[OF 0] ofsm_table_restriction_to_states[of _ f, OF assms(1) _ ] unfolding ofsm_table_fix.simps[of M f 0] Let_def
by (metis (no_types, lifting))
next
case (Suc i)
then have "i < kMin" by auto
have "ofsm_table_fix M f (Suc i) = ofsm_table_fix M f (Suc (Suc i))"
using *[OF \<open>Suc i < kMin\<close>] ofsm_table_restriction_to_states[of _ f, OF assms(1) _ ] unfolding ofsm_table_fix.simps[of M f "Suc i"] Let_def by metis
then show ?case using Suc.IH[OF \<open>i < kMin\<close>]
by presburger
qed
qed
then have "ofsm_table_fix M f 0 = ofsm_table_fix M f kMin"
using Suc by blast
moreover have "ofsm_table_fix M f kMin q = ofsm_table M f kMin q"
proof -
have "\<forall>q\<in>FSM.states M. ofsm_table M (\<lambda>q. f q \<inter> FSM.states M) kMin q = ofsm_table M (\<lambda>q. f q \<inter> FSM.states M) (Suc kMin) q"
using ofsm_table_restriction_to_states[of _ f, OF assms(1) _ ]
using k1 by blast
then show ?thesis
using ofsm_table_restriction_to_states[of _ f, OF assms(1) _ ] \<open>q \<in> states M\<close>
unfolding ofsm_table_fix.simps[of M f kMin] Let_def
by presburger
qed
ultimately show ?thesis
using ofsm_table_restriction_to_states[of _ f, OF assms(1) \<open>q \<in> states M\<close>]
by presburger
qed
qed
moreover have "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> kMin \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f kMin q"
using ofsm_table_fixpoint[OF _ k1 ] by blast
ultimately show ?thesis
using that[of kMin]
using ofsm_table_restriction_to_states[of M f, OF assms(1) _ ]
by blast
qed
lemma ofsm_table_containment :
assumes "q \<in> states M"
and "\<And> q . q \<in> states M \<Longrightarrow> q \<in> f q"
shows "q \<in> ofsm_table M f k q"
proof (induction k)
case 0
then show ?case using assms by auto
next
case (Suc k)
then show ?case
unfolding ofsm_table.simps Let_def option.case_eq_if
by auto
qed
lemma ofsm_table_states :
assumes "\<And> q . q \<in> states M \<Longrightarrow> f q \<subseteq> states M"
and "q \<in> states M"
shows "ofsm_table M f k q \<subseteq> states M"
proof -
have "ofsm_table M f k q \<subseteq> ofsm_table M f 0 q"
using ofsm_table_subset[OF le0] by metis
moreover have "ofsm_table M f 0 q \<subseteq> states M"
using assms
unfolding ofsm_table.simps(1) by (metis (full_types))
ultimately show ?thesis
by blast
qed
subsubsection \<open>Properties of Initial Partitions\<close>
definition equivalence_relation_on_states :: "('a,'b,'c) fsm \<Rightarrow> ('a \<Rightarrow> 'a set) \<Rightarrow> bool" where
"equivalence_relation_on_states M f =
(equiv (states M) {(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> f q1}
\<and> (\<forall> q \<in> states M . f q \<subseteq> states M))"
lemma equivalence_relation_on_states_refl :
assumes "equivalence_relation_on_states M f"
and "q \<in> states M"
shows "q \<in> f q"
using assms unfolding equivalence_relation_on_states_def equiv_def refl_on_def by blast
lemma equivalence_relation_on_states_sym :
assumes "equivalence_relation_on_states M f"
and "q1 \<in> states M"
and "q2 \<in> f q1"
shows "q1 \<in> f q2"
using assms unfolding equivalence_relation_on_states_def equiv_def sym_def by blast
lemma equivalence_relation_on_states_trans :
assumes "equivalence_relation_on_states M f"
and "q1 \<in> states M"
and "q2 \<in> f q1"
and "q3 \<in> f q2"
shows "q3 \<in> f q1"
proof -
have "(q1,q2) \<in> {(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> f q1}"
using assms(2,3) by blast
then have "q2 \<in> states M"
using assms(1) unfolding equivalence_relation_on_states_def
by auto
then have "(q2,q3) \<in> {(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> f q1}"
using assms(4) by blast
moreover have "trans {(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> f q1}"
using assms(1) unfolding equivalence_relation_on_states_def equiv_def by auto
ultimately show ?thesis
using \<open>(q1,q2) \<in> {(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> f q1}\<close>
unfolding trans_def by blast
qed
lemma equivalence_relation_on_states_ran :
assumes "equivalence_relation_on_states M f"
and "q \<in> states M"
shows "f q \<subseteq> states M"
using assms unfolding equivalence_relation_on_states_def by blast
subsubsection \<open>Properties of OFSM tables for initial partitions based on equivalence relations\<close>
lemma h_obs_io :
assumes "h_obs M q x y = Some q'"
shows "x \<in> inputs M" and "y \<in> outputs M"
proof -
have "snd ` Set.filter (\<lambda> (y',q') . y' = y) (h M (q,x)) \<noteq> {}"
using assms unfolding h_obs_simps Let_def by auto
then show "x \<in> inputs M" and "y \<in> outputs M"
unfolding h_simps
using fsm_transition_input fsm_transition_output
by fastforce+
qed
lemma ofsm_table_language :
assumes "q' \<in> ofsm_table M f k q"
and "length io \<le> k"
and "q \<in> states M"
and "equivalence_relation_on_states M f"
shows "is_in_language M q io \<longleftrightarrow> is_in_language M q' io"
and "is_in_language M q io \<Longrightarrow> (after M q' io) \<in> f (after M q io)"
proof -
have "(is_in_language M q io \<longleftrightarrow> is_in_language M q' io) \<and> (is_in_language M q io \<longrightarrow> (after M q' io) \<in> f (after M q io))"
using assms(1,2,3)
proof (induction k arbitrary: q q' io)
case 0
then have "io = []" by auto
then show ?case
using "0.prems"(1,3) by auto
next
case (Suc k)
show ?case proof (cases "length io \<le> k")
case True
have *: "q' \<in> ofsm_table M f k q"
using \<open>q' \<in> ofsm_table M f (Suc k) q\<close> ofsm_table_subset
by (metis (full_types) le_SucI order_refl subsetD)
show ?thesis using Suc.IH[OF * True \<open>q \<in> states M\<close>] by assumption
next
case False
then have "length io = Suc k"
using \<open>length io \<le> Suc k\<close> by auto
then obtain ioT ioP where "io = ioT#ioP"
by (meson length_Suc_conv)
then have "length ioP \<le> k"
using \<open>length io \<le> Suc k\<close> by auto
obtain x y where "io = (x,y)#ioP"
using \<open>io = ioT#ioP\<close> prod.exhaust_sel
by fastforce
have "ofsm_table M f (Suc k) q = {q' \<in> ofsm_table M f k q . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None) }"
unfolding ofsm_table.simps Let_def by blast
then have "q' \<in> ofsm_table M f k q"
and *: "\<And> x y . x \<in> inputs M \<Longrightarrow> y \<in> outputs M \<Longrightarrow> (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
using \<open>q' \<in> ofsm_table M f (Suc k) q\<close> by blast+
show ?thesis
unfolding \<open>io = (x,y)#ioP\<close>
proof -
have "is_in_language M q ((x,y)#ioP) \<Longrightarrow> is_in_language M q' ((x,y)#ioP) \<and> after M q' ((x,y)#ioP) \<in> f (after M q ((x,y)#ioP))"
proof -
assume "is_in_language M q ((x,y)#ioP)"
then obtain qT where "h_obs M q x y = Some qT" and "is_in_language M qT ioP"
by (metis case_optionE is_in_language.simps(2))
moreover have "(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
using *[of x y, OF h_obs_io[OF \<open>h_obs M q x y = Some qT\<close>]] .
ultimately obtain qT' where "h_obs M q' x y = Some qT'" and "ofsm_table M f k qT = ofsm_table M f k qT'"
using ofsm_table_case_helper[of M q' x y f k q]
unfolding ofsm_table.simps by force
then have "qT' \<in> ofsm_table M f k qT"
using ofsm_table_containment[OF h_obs_state equivalence_relation_on_states_refl[OF \<open>equivalence_relation_on_states M f\<close>]]
by metis
have "(is_in_language M qT ioP) = (is_in_language M qT' ioP)"
"(is_in_language M qT ioP \<longrightarrow> after M qT' ioP \<in> f (after M qT ioP))"
using Suc.IH[OF \<open>qT' \<in> ofsm_table M f k qT\<close> \<open>length ioP \<le> k\<close> h_obs_state[OF \<open>h_obs M q x y = Some qT\<close>]]
by blast+
have "(is_in_language M qT' ioP)"
using \<open>(is_in_language M qT ioP) = (is_in_language M qT' ioP)\<close> \<open>is_in_language M qT ioP\<close>
by auto
then have "is_in_language M q' ((x,y)#ioP)"
unfolding is_in_language.simps \<open>h_obs M q' x y = Some qT'\<close> by auto
moreover have "after M q' ((x,y)#ioP) \<in> f (after M q ((x,y)#ioP))"
unfolding after.simps \<open>h_obs M q' x y = Some qT'\<close> \<open>h_obs M q x y = Some qT\<close>
using \<open>(is_in_language M qT ioP \<longrightarrow> after M qT' ioP \<in> f (after M qT ioP))\<close> \<open>is_in_language M qT ioP\<close>
by auto
ultimately show "is_in_language M q' ((x,y)#ioP) \<and> after M q' ((x,y)#ioP) \<in> f (after M q ((x,y)#ioP))"
by blast
qed
moreover have "is_in_language M q' ((x,y)#ioP) \<Longrightarrow> is_in_language M q ((x,y)#ioP)"
proof -
assume "is_in_language M q' ((x,y)#ioP)"
then obtain qT' where "h_obs M q' x y = Some qT'" and "is_in_language M qT' ioP"
by (metis case_optionE is_in_language.simps(2))
moreover have "(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
using *[of x y, OF h_obs_io[OF \<open>h_obs M q' x y = Some qT'\<close>]] .
ultimately obtain qT where "h_obs M q x y = Some qT" and "ofsm_table M f k qT = ofsm_table M f k qT'"
using ofsm_table_case_helper[of M q' x y f k q]
unfolding ofsm_table.simps by force
then have "qT \<in> ofsm_table M f k qT'"
using ofsm_table_containment[OF h_obs_state equivalence_relation_on_states_refl[OF \<open>equivalence_relation_on_states M f\<close>]]
by metis
have "(is_in_language M qT ioP) = (is_in_language M qT' ioP)"
using Suc.IH[OF \<open>qT \<in> ofsm_table M f k qT'\<close> \<open>length ioP \<le> k\<close> h_obs_state[OF \<open>h_obs M q' x y = Some qT'\<close>]]
by blast
then have "is_in_language M qT ioP"
using \<open>is_in_language M qT' ioP\<close>
by auto
then show "is_in_language M q ((x,y)#ioP)"
unfolding is_in_language.simps \<open>h_obs M q x y = Some qT\<close> by auto
qed
ultimately show "is_in_language M q ((x, y) # ioP) = is_in_language M q' ((x, y) # ioP) \<and> (is_in_language M q ((x, y) # ioP) \<longrightarrow> after M q' ((x, y) # ioP) \<in> f (after M q ((x, y) # ioP)))"
by blast
qed
qed
qed
then show "is_in_language M q io = is_in_language M q' io" and "(is_in_language M q io \<Longrightarrow> after M q' io \<in> f (after M q io))"
by blast+
qed
lemma after_is_state_is_in_language :
assumes "q \<in> states M"
and "is_in_language M q io"
shows "FSM.after M q io \<in> states M"
using assms
proof (induction io arbitrary: q)
case Nil
then show ?case by auto
next
case (Cons a io)
then obtain x y where "a = (x,y)" using prod.exhaust by metis
show ?case
using \<open>is_in_language M q (a # io)\<close> Cons.IH[OF h_obs_state[of M q x y]]
unfolding \<open>a = (x,y)\<close>
unfolding after.simps is_in_language.simps
by (metis option.case_eq_if option.exhaust_sel)
qed
lemma ofsm_table_elem :
assumes "q \<in> states M"
and "q' \<in> states M"
and "equivalence_relation_on_states M f"
and "\<And> io . length io \<le> k \<Longrightarrow> is_in_language M q io \<longleftrightarrow> is_in_language M q' io"
and "\<And> io . length io \<le> k \<Longrightarrow> is_in_language M q io \<Longrightarrow> (after M q' io) \<in> f (after M q io)"
shows "q' \<in> ofsm_table M f k q"
using assms(1,2,4,5) proof (induction k arbitrary: q q')
case 0
then show ?case by auto
next
case (Suc k)
have "q' \<in> ofsm_table M f k q"
using Suc.IH[OF Suc.prems(1,2)] Suc.prems(3,4) by auto
moreover have "\<And> x y . x \<in> inputs M \<Longrightarrow> y \<in> outputs M \<Longrightarrow> (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
proof -
fix x y assume "x \<in> inputs M" and "y \<in> outputs M"
show "(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
proof (cases "\<exists> qT qT' . h_obs M q x y = Some qT \<and> h_obs M q' x y = Some qT'")
case True
then obtain qT qT' where "h_obs M q x y = Some qT" and "h_obs M q' x y = Some qT'"
by blast
have *: "\<And> io . length io \<le> k \<Longrightarrow> is_in_language M qT io = is_in_language M qT' io"
proof -
fix io :: "('b \<times> 'c) list "
assume "length io \<le> k"
have "is_in_language M qT io = is_in_language M q ([(x,y)]@io)"
using \<open>h_obs M q x y = Some qT\<close> by auto
moreover have "is_in_language M qT' io = is_in_language M q' ([(x,y)]@io)"
using \<open>h_obs M q' x y = Some qT'\<close> by auto
ultimately show "is_in_language M qT io = is_in_language M qT' io"
using Suc.prems(3) \<open>length io \<le> k\<close>
by (metis append.left_neutral append_Cons length_Cons not_less_eq_eq)
qed
have "ofsm_table M f k qT = ofsm_table M f k qT'"
proof
have "qT \<in> states M"
using h_obs_state[OF \<open>h_obs M q x y = Some qT\<close>] .
have "qT' \<in> states M"
using h_obs_state[OF \<open>h_obs M q' x y = Some qT'\<close>] .
show "ofsm_table M f k qT \<subseteq> ofsm_table M f k qT'"
proof
fix s assume "s \<in> ofsm_table M f k qT"
then have "s \<in> states M"
using ofsm_table_subset[of 0 k M f qT] equivalence_relation_on_states_ran[OF assms(3) \<open>qT \<in> states M\<close>] \<open>qT \<in> states M\<close> by auto
have **: "(\<And>io. length io \<le> k \<Longrightarrow> is_in_language M qT' io = is_in_language M s io)"
using ofsm_table_language(1)[OF \<open>s \<in> ofsm_table M f k qT\<close> _ \<open>qT\<in> states M\<close> assms(3)] * by blast
have ***: "(\<And>io. length io \<le> k \<Longrightarrow> is_in_language M qT' io \<Longrightarrow> after M s io \<in> f (after M qT' io))"
proof -
fix io assume "length io \<le> k" and "is_in_language M qT' io"
then have "is_in_language M qT io"
using * by blast
then have "after M s io \<in> f (after M qT io)"
using ofsm_table_language(2)[OF \<open>s \<in> ofsm_table M f k qT\<close> \<open>length io \<le> k\<close> \<open>qT\<in> states M\<close> assms(3)]
by blast
have "after M qT io = after M q ((x,y)#io)"
using \<open>h_obs M q x y = Some qT\<close> by auto
moreover have "after M qT' io = after M q' ((x,y)#io)"
using \<open>h_obs M q' x y = Some qT'\<close> by auto
moreover have "is_in_language M q ((x,y)#io)"
using \<open>h_obs M q x y = Some qT\<close> \<open>is_in_language M qT io\<close> by auto
ultimately have "after M qT' io \<in> f (after M qT io)"
using Suc.prems(4) \<open>length io \<le> k\<close>
by (metis Suc_le_mono length_Cons)
show "after M s io \<in> f (after M qT' io)"
using equivalence_relation_on_states_trans[OF \<open>equivalence_relation_on_states M f\<close> after_is_state_is_in_language[OF \<open>qT' \<in> states M\<close> \<open>is_in_language M qT' io\<close>]
equivalence_relation_on_states_sym[OF \<open>equivalence_relation_on_states M f\<close> after_is_state_is_in_language[OF \<open>qT \<in> states M\<close> \<open>is_in_language M qT io\<close>]
\<open>after M qT' io \<in> f (after M qT io)\<close>] \<open>after M s io \<in> f (after M qT io)\<close>] .
qed
show "s \<in> ofsm_table M f k qT'"
using Suc.IH[OF \<open>qT' \<in> states M\<close> \<open>s \<in> states M\<close> ** ***] by blast
qed
show "ofsm_table M f k qT' \<subseteq> ofsm_table M f k qT"
proof
fix s assume "s \<in> ofsm_table M f k qT'"
then have "s \<in> states M"
using ofsm_table_subset[of 0 k M f qT'] equivalence_relation_on_states_ran[OF assms(3) \<open>qT' \<in> states M\<close>] \<open>qT' \<in> states M\<close> by auto
have **: "(\<And>io. length io \<le> k \<Longrightarrow> is_in_language M qT io = is_in_language M s io)"
using ofsm_table_language(1)[OF \<open>s \<in> ofsm_table M f k qT'\<close> _ \<open>qT'\<in> states M\<close> assms(3)] * by blast
have ***: "(\<And>io. length io \<le> k \<Longrightarrow> is_in_language M qT io \<Longrightarrow> after M s io \<in> f (after M qT io))"
proof -
fix io assume "length io \<le> k" and "is_in_language M qT io"
then have "is_in_language M qT' io"
using * by blast
then have "after M s io \<in> f (after M qT' io)"
using ofsm_table_language(2)[OF \<open>s \<in> ofsm_table M f k qT'\<close> \<open>length io \<le> k\<close> \<open>qT'\<in> states M\<close> assms(3)]
by blast
have "after M qT' io = after M q' ((x,y)#io)"
using \<open>h_obs M q' x y = Some qT'\<close> by auto
moreover have "after M qT io = after M q ((x,y)#io)"
using \<open>h_obs M q x y = Some qT\<close> by auto
moreover have "is_in_language M q' ((x,y)#io)"
using \<open>h_obs M q' x y = Some qT'\<close> \<open>is_in_language M qT' io\<close> by auto
ultimately have "after M qT io \<in> f (after M qT' io)"
using Suc.prems(4) \<open>length io \<le> k\<close>
by (metis Suc.prems(3) Suc_le_mono \<open>is_in_language M qT io\<close> \<open>qT \<in> FSM.states M\<close> after_is_state_is_in_language assms(3) equivalence_relation_on_states_sym length_Cons)
show "after M s io \<in> f (after M qT io)"
using equivalence_relation_on_states_trans[OF \<open>equivalence_relation_on_states M f\<close> after_is_state_is_in_language[OF \<open>qT \<in> states M\<close> \<open>is_in_language M qT io\<close>]
equivalence_relation_on_states_sym[OF \<open>equivalence_relation_on_states M f\<close> after_is_state_is_in_language[OF \<open>qT' \<in> states M\<close> \<open>is_in_language M qT' io\<close>]
\<open>after M qT io \<in> f (after M qT' io)\<close>] \<open>after M s io \<in> f (after M qT' io)\<close>] .
qed
show "s \<in> ofsm_table M f k qT"
using Suc.IH[OF \<open>qT \<in> states M\<close> \<open>s \<in> states M\<close> ** ***] by blast
qed
qed
then show ?thesis
unfolding \<open>h_obs M q x y = Some qT\<close> \<open>h_obs M q' x y = Some qT'\<close>
by auto
next
case False
have "h_obs M q x y = None \<and> h_obs M q' x y = None"
proof (rule ccontr)
assume "\<not> (h_obs M q x y = None \<and> h_obs M q' x y = None)"
then have "is_in_language M q [(x,y)] \<or> is_in_language M q' [(x,y)]"
unfolding is_in_language.simps
using option.disc_eq_case(2) by blast
moreover have "is_in_language M q [(x,y)] \<noteq> is_in_language M q' [(x,y)]"
using False
by (metis calculation case_optionE is_in_language.simps(2))
moreover have "length [(x,y)] \<le> Suc k"
by auto
ultimately show False
using Suc.prems(3) by blast
qed
then show ?thesis
unfolding ofsm_table_case_helper
by blast
qed
qed
ultimately show ?case
unfolding Suc ofsm_table.simps Let_def by force
qed
lemma ofsm_table_set :
assumes "q \<in> states M"
and "equivalence_relation_on_states M f"
shows "ofsm_table M f k q = {q' . q' \<in> states M \<and> (\<forall> io . length io \<le> k \<longrightarrow> (is_in_language M q io \<longleftrightarrow> is_in_language M q' io) \<and> (is_in_language M q io \<longrightarrow> after M q' io \<in> f (after M q io)))}"
using ofsm_table_language[OF _ _ assms(1,2) ]
ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(2)] assms(1)]
ofsm_table_elem[OF assms(1) _ assms(2)]
by blast
lemma ofsm_table_set_observable :
assumes "observable M" and "q \<in> states M"
and "equivalence_relation_on_states M f"
shows "ofsm_table M f k q = {q' . q' \<in> states M \<and> (\<forall> io . length io \<le> k \<longrightarrow> (io \<in> LS M q \<longleftrightarrow> io \<in> LS M q') \<and> (io \<in> LS M q \<longrightarrow> after M q' io \<in> f (after M q io)))}"
unfolding ofsm_table_set[OF assms(2,3)]
unfolding is_in_language_iff[OF assms(1,2)]
using is_in_language_iff[OF assms(1)]
by blast
lemma ofsm_table_eq_if_elem :
assumes "q1 \<in> states M" and "q2 \<in> states M" and "equivalence_relation_on_states M f"
shows "(ofsm_table M f k q1 = ofsm_table M f k q2) = (q2 \<in> ofsm_table M f k q1)"
proof
show "ofsm_table M f k q1 = ofsm_table M f k q2 \<Longrightarrow> q2 \<in> ofsm_table M f k q1"
using ofsm_table_containment[OF assms(2) equivalence_relation_on_states_refl[OF \<open>equivalence_relation_on_states M f\<close>]]
by blast
show "q2 \<in> ofsm_table M f k q1 \<Longrightarrow> ofsm_table M f k q1 = ofsm_table M f k q2"
proof -
assume *: "q2 \<in> ofsm_table M f k q1"
have "ofsm_table M f k q1 = {q' \<in> FSM.states M. \<forall>io. length io \<le> k \<longrightarrow> (is_in_language M q1 io) = (is_in_language M q' io) \<and> (is_in_language M q1 io \<longrightarrow> after M q' io \<in> f (after M q1 io))}"
using ofsm_table_set[OF assms(1,3)] by auto
moreover have "ofsm_table M f k q2 = {q' \<in> FSM.states M. \<forall>io. length io \<le> k \<longrightarrow> (is_in_language M q1 io) = (is_in_language M q' io) \<and> (is_in_language M q1 io \<longrightarrow> after M q' io \<in> f (after M q1 io))}"
proof -
have "ofsm_table M f k q2 = {q' \<in> FSM.states M. \<forall>io. length io \<le> k \<longrightarrow> (is_in_language M q2 io) = (is_in_language M q' io) \<and> (is_in_language M q2 io \<longrightarrow> after M q' io \<in> f (after M q2 io))}"
using ofsm_table_set[OF assms(2,3)] by auto
moreover have "\<And> io . length io \<le> k \<Longrightarrow> (is_in_language M q1 io) = (is_in_language M q2 io)"
using ofsm_table_language(1)[OF * _ assms(1,3)] by blast
moreover have "\<And> io q' . q' \<in> states M \<Longrightarrow> length io \<le> k \<Longrightarrow> (is_in_language M q2 io \<longrightarrow> after M q' io \<in> f (after M q2 io)) = (is_in_language M q1 io \<longrightarrow> after M q' io \<in> f (after M q1 io))"
using ofsm_table_language(2)[OF * _ assms(1,3)]
by (meson after_is_state_is_in_language assms(1) assms(2) assms(3) calculation(2) equivalence_relation_on_states_sym equivalence_relation_on_states_trans)
ultimately show ?thesis
by blast
qed
ultimately show ?thesis
by blast
qed
qed
lemma ofsm_table_fix_language :
fixes M :: "('a,'b,'c) fsm"
assumes "q' \<in> ofsm_table_fix M f 0 q"
and "q \<in> states M"
and "observable M"
and "equivalence_relation_on_states M f"
shows "LS M q = LS M q'"
and "io \<in> LS M q \<Longrightarrow> after M q' io \<in> f (after M q io)"
proof -
obtain k where *:"\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M f 0 q = ofsm_table M f k q"
and **: "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
using ofsm_table_fix_length[of M f,OF equivalence_relation_on_states_ran[OF assms(4)]]
by blast
have "q' \<in> ofsm_table M f k q"
using * assms(1,2) by blast
then have "q' \<in> states M"
by (metis assms(2) assms(4) equivalence_relation_on_states_ran le0 ofsm_table.simps(1) ofsm_table_subset subset_iff)
have "\<And> k' . q' \<in> ofsm_table M f k' q"
proof -
fix k' show "q' \<in> ofsm_table M f k' q"
proof (cases "k' \<le> k")
case True
show ?thesis using ofsm_table_subset[OF True, of M f q] \<open>q' \<in> ofsm_table M f k q\<close> by blast
next
case False
then have "k \<le> k'"
by auto
show ?thesis
unfolding **[OF assms(2) \<open>k \<le> k'\<close>]
using \<open>q' \<in> ofsm_table M f k q\<close> by assumption
qed
qed
have "\<And> io . io \<in> LS M q \<longleftrightarrow> io \<in> LS M q'"
proof -
fix io :: "('b \<times> 'c) list"
show "io \<in> LS M q \<longleftrightarrow> io \<in> LS M q'"
using ofsm_table_language(1)[OF \<open>q' \<in> ofsm_table M f (length io) q\<close> _ assms(2,4), of io]
using is_in_language_iff[OF assms(3,2)] is_in_language_iff[OF assms(3) \<open>q' \<in> states M\<close>]
by blast
qed
then show "LS M q = LS M q'"
by blast
show "io \<in> LS M q \<Longrightarrow> after M q' io \<in> f (after M q io)"
using ofsm_table_language(2)[OF \<open>q' \<in> ofsm_table M f (length io) q\<close> _ assms(2,4), of io]
using is_in_language_iff[OF assms(3,2)] is_in_language_iff[OF assms(3) \<open>q' \<in> states M\<close>]
by blast
qed
lemma ofsm_table_same_language :
assumes "LS M q = LS M q'"
and "\<And> io . io \<in> LS M q \<Longrightarrow> after M q' io \<in> f (after M q io)"
and "observable M"
and "q' \<in> states M"
and "q \<in> states M"
and "equivalence_relation_on_states M f"
shows "ofsm_table M f k q = ofsm_table M f k q'"
using assms(1,2,4,5)
proof (induction k arbitrary: q q')
case 0
then show ?case
by (metis after.simps(1) assms(6) from_FSM_language language_contains_empty_sequence ofsm_table.simps(1) ofsm_table_eq_if_elem)
next
case (Suc k)
have "ofsm_table M f (Suc k) q = {q'' \<in> ofsm_table M f k q' . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None) }"
using Suc.IH[OF Suc.prems] unfolding ofsm_table.simps Suc Let_def Suc by simp
moreover have "ofsm_table M f (Suc k) q' = {q'' \<in> ofsm_table M f k q' . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q' x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None) }"
unfolding ofsm_table.simps Suc Let_def
by auto
moreover have "{q'' \<in> ofsm_table M f k q' . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None) }
= {q'' \<in> ofsm_table M f k q' . \<forall> x \<in> inputs M . \<forall> y \<in> outputs M . (case h_obs M q' x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None) }"
proof -
have "\<And> q'' x y . q'' \<in> ofsm_table M f k q' \<Longrightarrow> x \<in> inputs M \<Longrightarrow> y \<in> outputs M \<Longrightarrow>
(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None)
= (case h_obs M q' x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None)"
proof -
fix q'' x y assume "q'' \<in> ofsm_table M f k q'" and "x \<in> inputs M" and "y \<in> outputs M"
have *:"(\<exists> qT . h_obs M q x y = Some qT) = (\<exists> qT' . h_obs M q' x y = Some qT')"
proof -
have "([(x,y)] \<in> LS M q) = ([(x,y)] \<in> LS M q')"
using \<open>LS M q = LS M q'\<close> by auto
then have "(\<exists> qT . (q, x, y, qT) \<in> FSM.transitions M) = (\<exists> qT' . (q', x, y, qT') \<in> FSM.transitions M)"
unfolding LS_single_transition by force
then show "(\<exists> qT . h_obs M q x y = Some qT) = (\<exists> qT' . h_obs M q' x y = Some qT')"
unfolding h_obs_Some[OF \<open>observable M\<close>] using \<open>observable M\<close> unfolding observable_alt_def by blast
qed
have **: "(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q' x y = None)"
proof (cases "h_obs M q x y")
case None
then show ?thesis using * by auto
next
case (Some qT)
show ?thesis proof (cases "h_obs M q' x y")
case None
then show ?thesis using * by auto
next
case (Some qT')
have "(q,x,y,qT) \<in> transitions M"
using \<open>h_obs M q x y = Some qT\<close> unfolding h_obs_Some[OF \<open>observable M\<close>] by blast
have "(q',x,y,qT') \<in> transitions M"
using \<open>h_obs M q' x y = Some qT'\<close> unfolding h_obs_Some[OF \<open>observable M\<close>] by blast
have "LS M qT = LS M qT'"
using observable_transition_target_language_eq[OF _ \<open>(q,x,y,qT) \<in> transitions M\<close> \<open>(q',x,y,qT') \<in> transitions M\<close> _ _ \<open>observable M\<close>]
\<open>LS M q = LS M q'\<close>
by auto
moreover have "(\<And>io. io \<in> LS M qT \<Longrightarrow> after M qT' io \<in> f (after M qT io))"
proof -
fix io assume "io \<in> LS M qT"
have "io \<in> LS M qT'"
using \<open>io \<in> LS M qT\<close> calculation by auto
have "after M qT io = after M q ((x,y)#io)"
using after_h_obs_prepend[OF \<open>observable M\<close> \<open>h_obs M q x y = Some qT\<close> \<open>io \<in> LS M qT\<close>]
by simp
moreover have "after M qT' io = after M q' ((x,y)#io)"
using after_h_obs_prepend[OF \<open>observable M\<close> \<open>h_obs M q' x y = Some qT'\<close> \<open>io \<in> LS M qT'\<close>]
by simp
moreover have "(x,y)#io \<in> LS M q"
using \<open>h_obs M q x y = Some qT\<close> \<open>io \<in> LS M qT\<close> unfolding h_obs_language_iff[OF \<open>observable M\<close>]
by blast
ultimately show "after M qT' io \<in> f (after M qT io)"
using Suc.prems(2) by presburger
qed
ultimately have "ofsm_table M f k qT = ofsm_table M f k qT'"
using Suc.IH[OF _ _ fsm_transition_target[OF \<open>(q',x,y,qT') \<in> transitions M\<close>] fsm_transition_target[OF \<open>(q,x,y,qT) \<in> transitions M\<close>]]
unfolding snd_conv
by blast
then show ?thesis
using \<open>h_obs M q x y = Some qT\<close> \<open>h_obs M q' x y = Some qT'\<close> by auto
qed
qed
show "(case h_obs M q x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None)
= (case h_obs M q' x y of Some qT \<Rightarrow> (case h_obs M q'' x y of Some qT' \<Rightarrow> ofsm_table M f k qT = ofsm_table M f k qT' | None \<Rightarrow> False) | None \<Rightarrow> h_obs M q'' x y = None)" (is "?P")
proof (cases "h_obs M q x y")
case None
then have "h_obs M q' x y = None"
using * by auto
show ?thesis unfolding None \<open>h_obs M q' x y = None\<close> by auto
next
case (Some qT)
then obtain qT' where "h_obs M q' x y = Some qT'"
using \<open>(\<exists> qT . h_obs M q x y = Some qT) = (\<exists> qT' . h_obs M q' x y = Some qT')\<close> by auto
show ?thesis
proof (cases "h_obs M q'' x y")
case None
then show ?thesis using *
by (metis Some option.case_eq_if option.simps(5))
next
case (Some qT'')
show ?thesis
using **
unfolding Some \<open>h_obs M q x y = Some qT\<close> \<open>h_obs M q' x y = Some qT'\<close> by auto
qed
qed
qed
then show ?thesis
by blast
qed
ultimately show ?case by blast
qed
lemma ofsm_table_fix_set :
assumes "q \<in> states M"
and "observable M"
and "equivalence_relation_on_states M f"
shows "ofsm_table_fix M f 0 q = {q' \<in> states M . LS M q' = LS M q \<and> (\<forall> io \<in> LS M q . after M q' io \<in> f (after M q io))}"
proof
have "ofsm_table_fix M f 0 q \<subseteq> ofsm_table M f 0 q"
using ofsm_table_fix_length[of M f]
ofsm_table_subset[OF zero_le, of M f _ q]
by (metis assms(1) assms(3) equivalence_relation_on_states_ran)
then have "ofsm_table_fix M f 0 q \<subseteq> states M"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(3)] assms(1)] by blast
then show "ofsm_table_fix M f 0 q \<subseteq> {q' \<in> states M . LS M q' = LS M q \<and> (\<forall> io \<in> LS M q . after M q' io \<in> f (after M q io))}"
using ofsm_table_fix_language[OF _ assms] by blast
show "{q' \<in> states M . LS M q' = LS M q \<and> (\<forall> io \<in> LS M q . after M q' io \<in> f (after M q io))} \<subseteq> ofsm_table_fix M f 0 q"
proof
fix q' assume "q' \<in> {q' \<in> states M . LS M q' = LS M q \<and> (\<forall> io \<in> LS M q . after M q' io \<in> f (after M q io))}"
then have "q' \<in> states M" and "LS M q' = LS M q" and "\<And> io . io \<in> LS M q \<Longrightarrow> after M q' io \<in> f (after M q io)"
by blast+
then have "\<And> io . io \<in> LS M q' \<Longrightarrow> after M q io \<in> f (after M q' io)"
by (metis after_is_state assms(2) assms(3) equivalence_relation_on_states_sym)
obtain k where "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M f 0 q = ofsm_table M f k q"
and "\<And> q k' . q \<in> states M \<Longrightarrow> k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
using ofsm_table_fix_length[of M f, OF equivalence_relation_on_states_ran[OF assms(3)]] by blast
have "ofsm_table M f k q' = ofsm_table M f k q"
using ofsm_table_same_language[OF \<open>LS M q' = LS M q\<close> \<open>\<And> io . io \<in> LS M q' \<Longrightarrow> after M q io \<in> f (after M q' io)\<close> assms(2,1) \<open>q' \<in> states M\<close> assms(3)]
by blast
then show "q' \<in> ofsm_table_fix M f 0 q"
using ofsm_table_containment[OF \<open>q' \<in> states M\<close>, of f k]
using \<open>\<And> q . q \<in> states M \<Longrightarrow> ofsm_table_fix M f 0 q = ofsm_table M f k q\<close>
by (metis assms(1) assms(3) equivalence_relation_on_states_refl)
qed
qed
lemma ofsm_table_fix_eq_if_elem :
assumes "q1 \<in> states M" and "q2 \<in> states M"
and "equivalence_relation_on_states M f"
shows "(ofsm_table_fix M f 0 q1 = ofsm_table_fix M f 0 q2) = (q2 \<in> ofsm_table_fix M f 0 q1)"
proof
have "(\<And>q. q \<in> FSM.states M \<Longrightarrow> q \<in> f q)"
using assms(3)
by (meson equivalence_relation_on_states_refl)
show "ofsm_table_fix M f 0 q1 = ofsm_table_fix M f 0 q2 \<Longrightarrow> q2 \<in> ofsm_table_fix M f 0 q1"
using ofsm_table_containment[of _ M f, OF assms(2) \<open>(\<And>q. q \<in> FSM.states M \<Longrightarrow> q \<in> f q)\<close>]
using ofsm_table_fix_length[of M f]
by (metis assms(2) assms(3) equivalence_relation_on_states_ran)
show "q2 \<in> ofsm_table_fix M f 0 q1 \<Longrightarrow> ofsm_table_fix M f 0 q1 = ofsm_table_fix M f 0 q2"
using ofsm_table_eq_if_elem[OF assms(1,2,3)]
using ofsm_table_fix_length[of M f]
by (metis assms(1) assms(2) assms(3) equivalence_relation_on_states_ran)
qed
lemma ofsm_table_refinement_disjoint :
assumes "q1 \<in> states M" and "q2 \<in> states M"
and "equivalence_relation_on_states M f"
and "ofsm_table M f k q1 \<noteq> ofsm_table M f k q2"
shows "ofsm_table M f (Suc k) q1 \<noteq> ofsm_table M f (Suc k) q2"
proof -
have "ofsm_table M f (Suc k) q1 \<subseteq> ofsm_table M f k q1"
and "ofsm_table M f (Suc k) q2 \<subseteq> ofsm_table M f k q2"
using ofsm_table_subset[of k "Suc k" M f]
by fastforce+
moreover have "ofsm_table M f k q1 \<inter> ofsm_table M f k q2 = {}"
proof (rule ccontr)
assume "ofsm_table M f k q1 \<inter> ofsm_table M f k q2 \<noteq> {}"
then obtain q where "q \<in> ofsm_table M f k q1"
and "q \<in> ofsm_table M f k q2"
by blast
then have "q \<in> states M"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(3)] assms(1)]
by blast
have "ofsm_table M f k q1 = ofsm_table M f k q2"
using \<open>q \<in> ofsm_table M f k q1\<close> \<open>q \<in> ofsm_table M f k q2\<close>
unfolding ofsm_table_eq_if_elem[OF assms(1) \<open>q \<in> states M\<close> assms(3), symmetric]
unfolding ofsm_table_eq_if_elem[OF assms(2) \<open>q \<in> states M\<close> assms(3), symmetric]
by blast
then show False
using assms(4) by simp
qed
ultimately show ?thesis
by (metis Int_subset_iff all_not_in_conv assms(2) assms(3) ofsm_table_eq_if_elem subset_empty)
qed
lemma ofsm_table_partition_finite :
assumes "equivalence_relation_on_states M f"
shows "finite (ofsm_table M f k ` states M)"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms]]
fsm_states_finite[of M]
unfolding finite_Pow_iff[of "states M", symmetric]
by simp
lemma ofsm_table_refinement_card :
assumes "equivalence_relation_on_states M f"
and "A \<subseteq> states M"
and "i \<le> j"
shows "card (ofsm_table M f j ` A) \<ge> card (ofsm_table M f i ` A)"
proof -
have "\<And> k . card (ofsm_table M f (Suc k) ` A) \<ge> card (ofsm_table M f k ` A)"
proof -
fix k show "card (ofsm_table M f (Suc k) ` A) \<ge> card (ofsm_table M f k ` A)"
proof (rule ccontr)
have "finite A"
using fsm_states_finite[of M] assms(2)
using finite_subset by blast
assume "\<not> card (ofsm_table M f k ` A) \<le> card (ofsm_table M f (Suc k) ` A)"
then have "card (ofsm_table M f (Suc k) ` A) < card (ofsm_table M f k ` A)"
by simp
then obtain q1 q2 where "q1 \<in> A"
and "q2 \<in> A"
and "ofsm_table M f k q1 \<noteq> ofsm_table M f k q2"
and "ofsm_table M f (Suc k) q1 = ofsm_table M f (Suc k) q2"
using finite_card_less_witnesses[OF \<open>finite A\<close>] by blast
then show False
using ofsm_table_refinement_disjoint[OF _ _ assms(1), of q1 q2 k]
using assms(2)
by blast
qed
qed
then show ?thesis
using lift_Suc_mono_le[OF _ assms(3), where f="\<lambda> k . card (ofsm_table M f k ` A)"]
by blast
qed
lemma ofsm_table_refinement_card_fix_Suc :
assumes "equivalence_relation_on_states M f"
and "card (ofsm_table M f (Suc k) ` states M) = card (ofsm_table M f k ` states M)"
and "q \<in> states M"
shows "ofsm_table M f (Suc k) q = ofsm_table M f k q"
proof (rule ccontr)
assume "ofsm_table M f (Suc k) q \<noteq> ofsm_table M f k q"
then have "ofsm_table M f (Suc k) q \<subset> ofsm_table M f k q"
using ofsm_table_subset
by (metis Suc_leD order_refl psubsetI)
then obtain q' where "q' \<in> ofsm_table M f k q"
and "q' \<notin> ofsm_table M f (Suc k) q"
by blast
then have "q' \<in> states M"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)] assms(3)] by blast
have card_qq: "\<And> k . card (ofsm_table M f k ` states M)
= card (ofsm_table M f k ` (states M - \<Union>(ofsm_table M f k ` {q,q'}))) + card (ofsm_table M f k ` (\<Union>(ofsm_table M f k ` {q,q'})))"
proof -
fix k
have "states M = (states M - \<Union>(ofsm_table M f k ` {q,q'})) \<union> \<Union>(ofsm_table M f k ` {q,q'})"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)] \<open>q \<in> states M\<close>]
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)] \<open>q' \<in> states M\<close>]
by blast
then have "finite (states M - \<Union>(ofsm_table M f k ` {q,q'}))"
and "finite (\<Union>(ofsm_table M f k ` {q,q'}))"
using fsm_states_finite[of M] finite_Un[of "(states M - \<Union>(ofsm_table M f k ` {q,q'}))" "\<Union>(ofsm_table M f k ` {q,q'})"]
by force+
then have *:"finite (ofsm_table M f k ` (states M - \<Union>(ofsm_table M f k ` {q,q'})))"
and **:"finite (ofsm_table M f k ` \<Union>(ofsm_table M f k ` {q,q'}))"
by blast+
have ***:"(ofsm_table M f k ` (states M - \<Union>(ofsm_table M f k ` {q,q'}))) \<inter> (ofsm_table M f k ` \<Union>(ofsm_table M f k ` {q,q'})) = {}"
proof (rule ccontr)
assume "ofsm_table M f k ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'})) \<inter> ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'}) \<noteq> {}"
then obtain Q where "Q \<in> ofsm_table M f k ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))"
and "Q \<in> ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'})"
by blast
obtain q1 where "q1 \<in> (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))"
and "Q = ofsm_table M f k q1"
using \<open>Q \<in> ofsm_table M f k ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))\<close> by blast
moreover obtain q2 where "q2 \<in> \<Union> (ofsm_table M f k ` {q, q'})"
and "Q = ofsm_table M f k q2"
using \<open>Q \<in> ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'})\<close> by blast
ultimately have "ofsm_table M f k q1 = ofsm_table M f k q2"
by auto
have "q1 \<in> states M" and "q1 \<notin> \<Union> (ofsm_table M f k ` {q, q'})"
using \<open>q1 \<in> (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))\<close>
by blast+
have "q2 \<in> states M"
using \<open>q2 \<in> \<Union> (ofsm_table M f k ` {q, q'})\<close> \<open>states M = (states M - \<Union>(ofsm_table M f k ` {q,q'})) \<union> \<Union>(ofsm_table M f k ` {q,q'})\<close>
by blast
have "q1 \<in> ofsm_table M f k q2"
using \<open>ofsm_table M f k q1 = ofsm_table M f k q2\<close>
using ofsm_table_eq_if_elem[OF \<open>q2 \<in> states M\<close> \<open>q1 \<in> states M\<close> assms(1)]
by blast
moreover have "q2 \<in> ofsm_table M f k q \<or> q2 \<in> ofsm_table M f k q'"
using \<open>q2 \<in> \<Union> (ofsm_table M f k ` {q, q'})\<close>
by blast
ultimately have "q1 \<in> \<Union> (ofsm_table M f k ` {q, q'})"
unfolding ofsm_table_eq_if_elem[OF \<open>q \<in> states M\<close> \<open>q2 \<in> states M\<close> assms(1), symmetric]
unfolding ofsm_table_eq_if_elem[OF \<open>q' \<in> states M\<close> \<open>q2 \<in> states M\<close> assms(1), symmetric]
by blast
then show False
using \<open>q1 \<notin> \<Union> (ofsm_table M f k ` {q, q'})\<close>
by blast
qed
show "card (ofsm_table M f k ` states M)
= card (ofsm_table M f k ` (states M - \<Union>(ofsm_table M f k ` {q,q'}))) + card (ofsm_table M f k ` (\<Union>(ofsm_table M f k ` {q,q'})))"
using card_Un_disjoint[OF * ** ***]
using \<open>states M = (states M - \<Union>(ofsm_table M f k ` {q,q'})) \<union> \<Union>(ofsm_table M f k ` {q,q'})\<close>
by (metis image_Un)
qed
have s1: "\<And> k . (states M - \<Union>(ofsm_table M f k ` {q,q'})) \<subseteq> states M"
and s2: "\<And> k . (\<Union>(ofsm_table M f k ` {q,q'})) \<subseteq> states M"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)] \<open>q \<in> states M\<close>]
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)] \<open>q' \<in> states M\<close>]
by blast+
have "card (ofsm_table M f (Suc k) ` states M) > card (ofsm_table M f k ` states M)"
proof -
have *: "\<Union> (ofsm_table M f (Suc k) ` {q, q'}) \<subseteq> \<Union> (ofsm_table M f k ` {q, q'})"
using ofsm_table_subset
by (metis SUP_mono' lessI less_imp_le_nat)
have "card (ofsm_table M f k ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))) \<le> card (ofsm_table M f (Suc k) ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'})))"
using ofsm_table_refinement_card[OF assms(1), where i=k and j="Suc k", OF s1]
using le_SucI by blast
moreover have "card (ofsm_table M f (Suc k) ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))) \<le> card (ofsm_table M f (Suc k) ` (FSM.states M - \<Union> (ofsm_table M f (Suc k) ` {q, q'})))"
using *
using fsm_states_finite[of M]
by (meson Diff_mono card_mono finite_Diff finite_imageI image_mono subset_refl)
ultimately have "card (ofsm_table M f k ` (FSM.states M - \<Union> (ofsm_table M f k ` {q, q'}))) \<le> card (ofsm_table M f (Suc k) ` (FSM.states M - \<Union> (ofsm_table M f (Suc k) ` {q, q'})))"
by presburger
moreover have "card (ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'})) < card (ofsm_table M f (Suc k) ` \<Union> (ofsm_table M f (Suc k) ` {q, q'}))"
proof -
have *: "\<And> k . ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'}) = {ofsm_table M f k q, ofsm_table M f k q'}"
proof -
fix k show "ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'}) = {ofsm_table M f k q, ofsm_table M f k q'}"
proof
show "ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'}) \<subseteq> {ofsm_table M f k q, ofsm_table M f k q'}"
proof
fix Q assume "Q \<in> ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'})"
then obtain qq where "Q = ofsm_table M f k qq"
and "qq \<in> \<Union> (ofsm_table M f k ` {q, q'})"
by blast
then have "qq \<in> ofsm_table M f k q \<or> qq \<in> ofsm_table M f k q'"
by blast
then have "qq \<in> states M"
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)]] \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close>
by blast
have "ofsm_table M f k qq = ofsm_table M f k q \<or> ofsm_table M f k qq = ofsm_table M f k q'"
using \<open>qq \<in> ofsm_table M f k q \<or> qq \<in> ofsm_table M f k q'\<close>
using ofsm_table_eq_if_elem[OF _ \<open>qq \<in> states M\<close> assms(1)] \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close>
by blast
then show "Q \<in> {ofsm_table M f k q, ofsm_table M f k q'}"
using \<open>Q = ofsm_table M f k qq\<close>
by blast
qed
show "{ofsm_table M f k q, ofsm_table M f k q'} \<subseteq> ofsm_table M f k ` \<Union> (ofsm_table M f k ` {q, q'})"
using ofsm_table_containment[of _ M f, OF _ equivalence_relation_on_states_refl[OF assms(1)]] \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close>
by blast
qed
qed
have "ofsm_table M f k q = ofsm_table M f k q'"
using \<open>q' \<in> ofsm_table M f k q\<close>
using ofsm_table_eq_if_elem[OF \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close> assms(1)]
by blast
moreover have "ofsm_table M f (Suc k) q \<noteq> ofsm_table M f (Suc k) q'"
using \<open>q' \<notin> ofsm_table M f (Suc k) q\<close>
using ofsm_table_eq_if_elem[OF \<open>q \<in> states M\<close> \<open>q' \<in> states M\<close> assms(1)]
by blast
ultimately show ?thesis
unfolding *
by (metis card_insert_if finite.emptyI finite.insertI insert_absorb insert_absorb2 insert_not_empty lessI singleton_insert_inj_eq)
qed
ultimately show ?thesis
unfolding card_qq by presburger
qed
then show False
using assms(2) by linarith
qed
lemma ofsm_table_refinement_card_fix :
assumes "equivalence_relation_on_states M f"
and "card (ofsm_table M f j ` states M) = card (ofsm_table M f i ` states M)"
and "q \<in> states M"
and "i \<le> j"
shows "ofsm_table M f j q = ofsm_table M f i q"
using assms (2,4) proof (induction "j-i" arbitrary: i j)
case 0
then have "i = j" by auto
then show ?case by auto
next
case (Suc k)
then have "j \<ge> Suc i" and "k = j - Suc i"
by auto
have *:"card (ofsm_table M f j ` FSM.states M) = card (ofsm_table M f (Suc i) ` FSM.states M)"
and **:"card (ofsm_table M f (Suc i) ` FSM.states M) = card (ofsm_table M f i ` FSM.states M)"
using ofsm_table_refinement_card[OF assms(1), where A="states M"]
by (metis Suc.prems(1) \<open>Suc i \<le> j\<close> eq_iff le_SucI)+
show ?case
using Suc.hyps(1)[OF \<open>k = j - Suc i\<close> * \<open>Suc i \<le> j\<close>]
using ofsm_table_refinement_card_fix_Suc[OF assms(1) ** assms(3)]
by blast
qed
lemma ofsm_table_partition_fixpoint_Suc :
assumes "equivalence_relation_on_states M f"
and "q \<in> states M"
shows "ofsm_table M f (size M - card (f ` states M)) q = ofsm_table M f (Suc (size M - card (f ` states M))) q"
proof -
have "\<And> q . q \<in> states M \<Longrightarrow> f q = ofsm_table M f 0 q"
unfolding ofsm_table.simps by auto
define n where n: "n = (\<lambda> i . card (ofsm_table M f i ` states M))"
have "\<And> i j . i \<le> j \<Longrightarrow> n i \<le> n j"
unfolding n
using ofsm_table_refinement_card[OF assms(1), where A="states M"]
by blast
moreover have "\<And> i j m . i < j \<Longrightarrow> n i = n j \<Longrightarrow> j \<le> m \<Longrightarrow> n i = n m"
proof -
fix i j m assume "i < j" and "n i = n j" and "j \<le> m"
then have "Suc i \<le> j" and "i \<le> Suc i" and "i \<le> m"
by auto
have "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f j q = ofsm_table M f i q"
using \<open>i < j\<close> \<open>n i = n j\<close> ofsm_table_refinement_card_fix[OF assms(1) _]
unfolding n
using less_imp_le_nat by presburger
then have "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f (Suc i) q = ofsm_table M f i q"
using ofsm_table_subset[OF \<open>Suc i \<le> j\<close>, of M f]
using ofsm_table_subset[OF \<open>i \<le> Suc i\<close>, of M f]
by blast
then have "\<And> q . q \<in> states M \<Longrightarrow> ofsm_table M f m q = ofsm_table M f i q"
using ofsm_table_fixpoint[OF \<open>i \<le> m\<close>]
by metis
then show "n i = n m"
unfolding n
by auto
qed
moreover have "\<And> i . n i \<le> size M"
unfolding n
using ofsm_table_states[of M f, OF equivalence_relation_on_states_ran[OF assms(1)]]
using fsm_states_finite[of M]
by (simp add: card_image_le)
ultimately obtain k where "n (Suc k) = n k"
and "k \<le> size M - n 0"
using monotone_function_with_limit_witness_helper[where f=n and k="size M"]
by blast
then show ?thesis
unfolding n
using \<open>\<And> q . q \<in> states M \<Longrightarrow> f q = ofsm_table M f 0 q\<close>[symmetric]
using ofsm_table_refinement_card_fix_Suc[OF assms(1) _ ]
using ofsm_table_fixpoint[OF _ _ assms(2)]
by (metis (mono_tags, lifting) image_cong nat_le_linear not_less_eq_eq)
qed
lemma ofsm_table_partition_fixpoint :
assumes "equivalence_relation_on_states M f"
and "size M \<le> m"
and "q \<in> states M"
shows "ofsm_table M f (m - card (f ` states M)) q = ofsm_table M f (Suc (m - card (f ` states M))) q"
proof -
have *: "size M - card (f ` states M) \<le> m - card (f ` states M)"
using assms(2) by simp
have **: "(size M - card (f ` states M)) \<le> Suc (m - card (f ` states M))"
using assms(2) by simp
have ***: "\<And> q . q \<in> FSM.states M \<Longrightarrow> ofsm_table M f (FSM.size M - card (f ` FSM.states M)) q = ofsm_table M f (Suc (FSM.size M - card (f ` FSM.states M))) q"
using ofsm_table_partition_fixpoint_Suc[OF assms(1)] .
have "ofsm_table M f (m - card (f ` states M)) q = ofsm_table M f (FSM.size M - card (f ` FSM.states M)) q"
using ofsm_table_fixpoint[OF * _ assms(3)] ***
by blast
moreover have "ofsm_table M f (Suc (m - card (f ` states M))) q = ofsm_table M f (FSM.size M - card (f ` FSM.states M)) q"
using ofsm_table_fixpoint[OF ** _ assms(3), of f] ***
by blast
ultimately show ?thesis
by simp
qed
lemma ofsm_table_fix_partition_fixpoint :
assumes "equivalence_relation_on_states M f"
and "size M \<le> m"
and "q \<in> states M"
shows "ofsm_table M f (m - card (f ` states M)) q = ofsm_table_fix M f 0 q"
proof -
obtain k where k1: "ofsm_table_fix M f 0 q = ofsm_table M f k q"
and k2: "\<And> k' . k' \<ge> k \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f k q"
using ofsm_table_fix_length[of M f, OF equivalence_relation_on_states_ran[OF assms(1)]]
assms(3)
by metis
have m1: "\<And> k' . k' \<ge> m - card (f ` states M) \<Longrightarrow> ofsm_table M f k' q = ofsm_table M f (m - card (f ` states M)) q"
using ofsm_table_partition_fixpoint[OF assms(1,2)]
using ofsm_table_fixpoint[OF _ _ assms(3)]
by presburger
show ?thesis proof (cases "k \<le> m - card (f ` states M)")
case True
show ?thesis
using k1 k2[OF True] by simp
next
case False
then have "k \<ge> m - card (f ` states M)"
by auto
then have "ofsm_table M f k q = ofsm_table M f (m - card (f ` states M)) q"
using ofsm_table_partition_fixpoint[OF assms(1,2)]
using ofsm_table_fixpoint[OF _ _ assms(3)]
by presburger
then show ?thesis
using k1 by simp
qed
qed
subsection \<open>A minimisation function based on OFSM-tables\<close>
lemma language_equivalence_classes_preserve_observability:
assumes "transitions M' = (\<lambda> t . ({q \<in> states M . LS M q = LS M (t_source t)} , t_input t, t_output t, {q \<in> states M . LS M q = LS M (t_target t)})) ` transitions M"
and "observable M"
shows "observable M'"
proof -
have "\<And> t1 t2 . t1 \<in> transitions M' \<Longrightarrow>
t2 \<in> transitions M' \<Longrightarrow>
t_source t1 = t_source t2 \<Longrightarrow>
t_input t1 = t_input t2 \<Longrightarrow>
t_output t1 = t_output t2 \<Longrightarrow>
t_target t1 = t_target t2"
proof -
fix t1 t2 assume "t1 \<in> transitions M'" and "t2 \<in> transitions M'" and "t_source t1 = t_source t2" and "t_input t1 = t_input t2" and "t_output t1 = t_output t2"
obtain t1' where t1'_def: "t1 = ({q \<in> states M . LS M q = LS M (t_source t1')} , t_input t1', t_output t1', {q \<in> states M . LS M q = LS M (t_target t1')})"
and "t1' \<in> transitions M"
using \<open>t1 \<in> transitions M'\<close> assms(1) by auto
obtain t2' where t2'_def: "t2 = ({q \<in> states M . LS M q = LS M (t_source t2')} , t_input t2', t_output t2', {q \<in> states M . LS M q = LS M (t_target t2')})"
and "t2' \<in> transitions M"
using \<open>t2 \<in> transitions M'\<close> assms(1) \<open>t_input t1 = t_input t2\<close> \<open>t_output t1 = t_output t2\<close> by auto
have "{q \<in> FSM.states M. LS M q = LS M (t_source t1')} = {q \<in> FSM.states M. LS M q = LS M (t_source t2')}"
using t1'_def t2'_def \<open>t_source t1 = t_source t2\<close>
by (metis (no_types, lifting) fst_eqD)
then have "LS M (t_source t1') = LS M (t_source t2')"
using fsm_transition_source[OF \<open>t1' \<in> transitions M\<close>] fsm_transition_source[OF \<open>t2' \<in> transitions M\<close>] by blast
then have "LS M (t_target t1') = LS M (t_target t2')"
using observable_transition_target_language_eq[OF _ \<open>t1' \<in> transitions M\<close> \<open>t2' \<in> transitions M\<close> _ _ \<open>observable M\<close>]
using \<open>t_input t1 = t_input t2\<close> \<open>t_output t1 = t_output t2\<close>
unfolding t1'_def t2'_def fst_conv snd_conv by blast
then show "t_target t1 = t_target t2"
unfolding t1'_def t2'_def snd_conv by blast
qed
then show ?thesis
unfolding observable.simps by blast
qed
lemma language_equivalence_classes_retain_language_and_induce_minimality :
assumes "transitions M' = (\<lambda> t . ({q \<in> states M . LS M q = LS M (t_source t)} , t_input t, t_output t, {q \<in> states M . LS M q = LS M (t_target t)})) ` transitions M"
and "states M' = (\<lambda>q . {q' \<in> states M . LS M q = LS M q'}) ` states M"
and "initial M' = {q' \<in> states M . LS M q' = LS M (initial M)}"
and "observable M"
shows "L M = L M'"
and "minimal M'"
proof -
have "observable M'"
using assms(1,4) language_equivalence_classes_preserve_observability by blast
have ls_prop: "\<And> io q . q \<in> states M \<Longrightarrow> (io \<in> LS M q) \<longleftrightarrow> (io \<in> LS M' {q' \<in> states M . LS M q = LS M q'})"
proof -
fix io q assume "q \<in> states M"
then show "(io \<in> LS M q) \<longleftrightarrow> (io \<in> LS M' {q' \<in> states M . LS M q = LS M q'})"
proof (induction io arbitrary: q)
case Nil
then show ?case using assms(2) by auto
next
case (Cons xy io)
obtain x y where "xy = (x,y)"
using surjective_pairing by blast
have "xy#io \<in> LS M q \<Longrightarrow> xy#io \<in> LS M' {q' \<in> states M . LS M q = LS M q'}"
proof -
assume "xy#io \<in> LS M q"
then obtain p where "path M q p" and "p_io p = xy#io"
unfolding LS.simps mem_Collect_eq by (metis (no_types, lifting))
let ?t = "hd p"
let ?p = "tl p"
let ?q' = "{q' \<in> states M . LS M (t_target ?t) = LS M q'}"
have "p = ?t # ?p" and "p_io ?p = io" and "t_input ?t = x" and "t_output ?t = y"
using \<open>p_io p = xy#io\<close> unfolding \<open>xy = (x,y)\<close> by auto
moreover have "?t \<in> transitions M" and "path M (t_target ?t) ?p" and "t_source ?t = q"
using \<open>path M q p\<close> path_cons_elim[of M q ?t ?p] calculation by auto
ultimately have "[(x,y)] \<in> LS M q"
unfolding LS_single_transition[of x y M q] by auto
then have "io \<in> LS M (t_target ?t)"
using observable_language_next[OF _ \<open>observable M\<close>, of "(x,y)" io, OF _ \<open>?t \<in> transitions M\<close>]
\<open>xy#io \<in> LS M q\<close>
unfolding \<open>xy = (x,y)\<close> \<open>t_source ?t = q\<close> \<open>t_input ?t = x\<close> \<open>t_output ?t = y\<close>
by (metis \<open>?t \<in> FSM.transitions M\<close> from_FSM_language fsm_transition_target fst_conv snd_conv)
then have "io \<in> LS M' ?q'"
using Cons.IH[OF fsm_transition_target[OF \<open>?t \<in> transitions M\<close>]] by blast
then obtain p' where "path M' ?q' p'" and "p_io p' = io"
by auto
have *: "({q' \<in> states M . LS M q = LS M q'},x,y,{q' \<in> states M . LS M (t_target ?t) = LS M q'}) \<in> transitions M'"
using \<open>?t \<in> transitions M\<close> \<open>t_source ?t = q\<close> \<open>t_input ?t = x\<close> \<open>t_output ?t = y\<close>
unfolding assms(1) by auto
show "xy#io \<in> LS M' {q' \<in> states M . LS M q = LS M q'}"
using LS_prepend_transition[OF * ] unfolding snd_conv fst_conv \<open>xy = (x,y)\<close>
using \<open>io \<in> LS M' ?q'\<close> by blast
qed
moreover have "xy#io \<in> LS M' {q' \<in> states M . LS M q = LS M q'} \<Longrightarrow> xy#io \<in> LS M q"
proof -
let ?q = "{q' \<in> states M . LS M q = LS M q'}"
assume "xy#io \<in> LS M' ?q"
then obtain p where "path M' ?q p" and "p_io p = xy#io"
unfolding LS.simps mem_Collect_eq by (metis (no_types, lifting))
let ?t = "hd p"
let ?p = "tl p"
have "p = ?t # ?p" and "p_io ?p = io" and "t_input ?t = x" and "t_output ?t = y"
using \<open>p_io p = xy#io\<close> unfolding \<open>xy = (x,y)\<close> by auto
then have "path M' ?q (?t#?p)"
using \<open>path M' ?q p\<close> by auto
then have "?t \<in> transitions M'" and "path M' (t_target ?t) ?p" and "t_source ?t = ?q"
by force+
then have "io \<in> LS M' (t_target ?t)"
using \<open>p_io ?p = io\<close> by auto
obtain t0 where t0_def: "?t = (\<lambda> t . ({q \<in> states M . LS M q = LS M (t_source t)} , t_input t, t_output t, {q \<in> states M . LS M q = LS M (t_target t)})) t0"
and "t0 \<in> transitions M"
using \<open>?t \<in> transitions M'\<close>
unfolding assms(1)
by auto
then have "t_source t0 \<in> ?q"
using \<open>t_source ?t = ?q\<close>
by (metis (mono_tags, lifting) fsm_transition_source fst_eqD mem_Collect_eq)
then have "LS M q = LS M (t_source t0)"
by auto
moreover have "[(x,y)] \<in> LS M (t_source t0)"
using t0_def \<open>t_input ?t = x\<close> \<open>t0 \<in> transitions M\<close> \<open>t_output ?t = y\<close> \<open>t_source t0 \<in> ?q\<close> unfolding LS_single_transition by auto
ultimately obtain t where "t \<in> transitions M" and "t_source t = q" and "t_input t = x" and "t_output t = y"
by (metis LS_single_transition)
have "LS M (t_target t) = LS M (t_target t0)"
using observable_transition_target_language_eq[OF _\<open>t \<in> transitions M\<close> \<open>t0 \<in> transitions M\<close> _ _ \<open>observable M\<close>]
using \<open>LS M q = LS M (t_source t0)\<close>
unfolding \<open>t_source t = q\<close> \<open>t_input t = x\<close> \<open>t_output t = y\<close>
using t0_def \<open>t_input ?t = x\<close> \<open>t_output ?t = y\<close>
by auto
moreover have "t_target ?t = {q' \<in> FSM.states M. LS M (t_target t) = LS M q'}"
using calculation t0_def by fastforce
ultimately have "io \<in> LS M (t_target t)"
using Cons.IH[OF fsm_transition_target[OF \<open>t \<in> transitions M\<close>]]
\<open>io \<in> LS M' (t_target ?t)\<close>
by auto
then show "xy#io \<in> LS M q"
unfolding \<open>t_source t = q\<close>[symmetric] \<open>xy = (x,y)\<close>
using \<open>t_input t = x\<close> \<open>t_output t = y\<close>
using LS_prepend_transition \<open>t \<in> FSM.transitions M\<close>
by blast
qed
ultimately show ?case
by blast
qed
qed
have "L M' = LS M' {q' \<in> states M . LS M (initial M) = LS M q'}"
using assms(3)
by (metis (mono_tags, lifting) Collect_cong)
then show "L M = L M'"
using ls_prop[OF fsm_initial] by blast
show "minimal M'"
proof -
have"\<And> q q' . q \<in> states M' \<Longrightarrow> q' \<in> states M' \<Longrightarrow> LS M' q = LS M' q' \<Longrightarrow> q = q'"
proof -
fix q q' assume "q \<in> states M'" and "q' \<in> states M'" and "LS M' q = LS M' q'"
obtain qM where "q = {q \<in> states M . LS M qM = LS M q}" and "qM \<in> states M"
using \<open>q \<in> states M'\<close> assms(2) by auto
obtain qM' where "q' = {q \<in> states M . LS M qM' = LS M q}" and "qM' \<in> states M"
using \<open>q' \<in> states M'\<close> assms(2) by auto
have "LS M qM = LS M' q"
using ls_prop[OF \<open>qM \<in> states M\<close>] unfolding \<open>q = {q \<in> states M . LS M qM = LS M q}\<close> by blast
moreover have "LS M qM' = LS M' q'"
using ls_prop[OF \<open>qM' \<in> states M\<close>] unfolding \<open>q' = {q \<in> states M . LS M qM' = LS M q}\<close> by blast
ultimately have "LS M qM = LS M qM'"
using \<open>LS M' q = LS M' q'\<close> by blast
then show "q = q'"
unfolding \<open>q = {q \<in> states M . LS M qM = LS M q}\<close> \<open>q' = {q \<in> states M . LS M qM' = LS M q}\<close> by blast
qed
then show ?thesis
unfolding minimal_alt_def by blast
qed
qed
fun minimise :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a set,'b,'c) fsm" where
"minimise M = (let
eq_class = ofsm_table_fix M (\<lambda>q . states M) 0;
ts = (\<lambda> t . (eq_class (t_source t), t_input t, t_output t, eq_class (t_target t))) ` (transitions M);
q0 = eq_class (initial M);
eq_states = eq_class |`| fstates M;
M' = create_unconnected_fsm_from_fsets q0 eq_states (finputs M) (foutputs M)
in add_transitions M' ts)"
lemma minimise_initial_partition :
"equivalence_relation_on_states M (\<lambda>q . states M)"
proof -
let ?r = "{(q1,q2) | q1 q2 . q1 \<in> states M \<and> q2 \<in> (\<lambda>q . states M) q1}"
have "refl_on (FSM.states M) ?r"
unfolding refl_on_def by blast
moreover have "sym ?r"
unfolding sym_def by blast
moreover have "trans ?r"
unfolding trans_def by blast
ultimately show ?thesis
unfolding equivalence_relation_on_states_def equiv_def by auto
qed
lemma minimise_props:
assumes "observable M"
shows "initial (minimise M) = {q' \<in> states M . LS M q' = LS M (initial M)}"
and "states (minimise M) = (\<lambda>q . {q' \<in> states M . LS M q = LS M q'}) ` states M"
and "inputs (minimise M) = inputs M"
and "outputs (minimise M) = outputs M"
and "transitions (minimise M) = (\<lambda> t . ({q \<in> states M . LS M q = LS M (t_source t)} , t_input t, t_output t, {q \<in> states M . LS M q = LS M (t_target t)})) ` transitions M"
proof -
let ?f = "\<lambda>q . states M"
define eq_class where "eq_class = ofsm_table_fix M (\<lambda>q . states M) 0"
moreover define M' where M'_def: "M' = create_unconnected_fsm_from_fsets (eq_class (initial M)) (eq_class |`| fstates M) (finputs M) (foutputs M)"
ultimately have *: "minimise M = add_transitions M' ((\<lambda> t . (eq_class (t_source t), t_input t, t_output t, eq_class (t_target t))) ` (transitions M))"
by auto
have **: "\<And> q . q \<in> states M \<Longrightarrow> eq_class q = {q' \<in> FSM.states M. LS M q = LS M q'}"
using ofsm_table_fix_set[OF _ assms minimise_initial_partition] \<open>eq_class = ofsm_table_fix M ?f 0\<close> after_is_state[OF \<open>observable M\<close>] by blast
then have ****: "\<And> q . q \<in> states M \<Longrightarrow> eq_class q = {q' \<in> FSM.states M. LS M q' = LS M q}"
using ofsm_table_fix_set[OF _ assms] \<open>eq_class = ofsm_table_fix M ?f 0\<close> by blast
have ***: "(eq_class (initial M)) |\<in>| (eq_class |`| fstates M)"
- using fsm_initial[of M] fstates_set fmember.rep_eq by fastforce
+ using fsm_initial[of M] fstates_set fmember_iff_member_fset by fastforce
have m1:"initial M' = {q' \<in> states M . LS M q' = LS M (initial M)}"
by (metis (mono_tags) "***" "****" M'_def create_unconnected_fsm_from_fsets_simps(1) fsm_initial)
have m2: "states M' = (\<lambda>q . {q' \<in> states M . LS M q = LS M q'}) ` states M"
unfolding M'_def
proof -
have "FSM.states (FSM.create_unconnected_fsm_from_fsets (eq_class (FSM.initial M)) (eq_class |`| fstates M) (finputs M) (foutputs M)) = eq_class ` FSM.states M"
by (metis (no_types) "***" create_unconnected_fsm_from_fsets_simps(2) fset.set_map fstates_set)
then show "FSM.states (FSM.create_unconnected_fsm_from_fsets (eq_class (FSM.initial M)) (eq_class |`| fstates M) (finputs M) (foutputs M)) = (\<lambda>a. {aa \<in> FSM.states M. LS M a = LS M aa}) ` FSM.states M"
using "**" by force
qed
have m3: "inputs M' = inputs M"
using create_unconnected_fsm_from_fsets_simps(3)[OF ***] finputs_set unfolding M'_def by force
have m4: "outputs M' = outputs M"
using create_unconnected_fsm_from_fsets_simps(4)[OF ***] foutputs_set unfolding M'_def by force
have m5: "transitions M' = {}"
using create_unconnected_fsm_from_fsets_simps(5)[OF ***] unfolding M'_def by force
let ?ts = "((\<lambda> t . (eq_class (t_source t), t_input t, t_output t, eq_class (t_target t))) ` (transitions M))"
have wf: "\<And> t . t \<in>?ts \<Longrightarrow> t_source t \<in> states M' \<and> t_input t \<in> inputs M' \<and> t_output t \<in> outputs M' \<and> t_target t \<in> states M'"
proof -
fix t assume "t \<in> ?ts"
then obtain tM where "tM \<in> transitions M"
and *: "t = (\<lambda> t . (eq_class (t_source t), t_input t, t_output t, eq_class (t_target t))) tM"
by blast
have "t_source t \<in> states M'"
using fsm_transition_source[OF \<open>tM \<in> transitions M\<close>]
unfolding m2 * **[OF fsm_transition_source[OF \<open>tM \<in> transitions M\<close>]] by auto
moreover have "t_input t \<in> inputs M'"
unfolding m3 * using fsm_transition_input[OF \<open>tM \<in> transitions M\<close>] by auto
moreover have "t_output t \<in> outputs M'"
unfolding m4 * using fsm_transition_output[OF \<open>tM \<in> transitions M\<close>] by auto
moreover have "t_target t \<in> states M'"
using fsm_transition_target[OF \<open>tM \<in> transitions M\<close>]
unfolding m2 * **[OF fsm_transition_target[OF \<open>tM \<in> transitions M\<close>]] by auto
ultimately show "t_source t \<in> states M' \<and> t_input t \<in> inputs M' \<and> t_output t \<in> outputs M' \<and> t_target t \<in> states M'"
by simp
qed
show "initial (minimise M) = {q' \<in> states M . LS M q' = LS M (initial M)}"
using add_transitions_simps(1)[OF wf] unfolding * m1 .
show "states (minimise M) = (\<lambda>q . {q' \<in> states M . LS M q = LS M q'}) ` states M"
using add_transitions_simps(2)[OF wf] unfolding * m2 .
show "inputs (minimise M) = inputs M"
using add_transitions_simps(3)[OF wf] unfolding * m3 .
show "outputs (minimise M) = outputs M"
using add_transitions_simps(4)[OF wf] unfolding * m4 .
show "transitions (minimise M) = (\<lambda> t . ({q \<in> states M . LS M q = LS M (t_source t)} , t_input t, t_output t, {q \<in> states M . LS M q = LS M (t_target t)})) ` transitions M"
using add_transitions_simps(5)[OF wf] ****[OF fsm_transition_source] ****[OF fsm_transition_target] unfolding * m5 by auto
qed
lemma minimise_observable:
assumes "observable M"
shows "observable (minimise M)"
using language_equivalence_classes_preserve_observability[OF minimise_props(5)[OF assms] assms]
by assumption
lemma minimise_minimal:
assumes "observable M"
shows "minimal (minimise M)"
using language_equivalence_classes_retain_language_and_induce_minimality(2)[OF minimise_props(5,2,1)[OF assms] assms]
by assumption
lemma minimise_language:
assumes "observable M"
shows "L (minimise M) = L M"
using language_equivalence_classes_retain_language_and_induce_minimality(1)[OF minimise_props(5,2,1)[OF assms] assms]
by blast
lemma minimal_observable_code :
assumes "observable M"
shows "minimal M = (\<forall> q \<in> states M . ofsm_table_fix M (\<lambda>q . states M) 0 q = {q})"
proof
show "minimal M \<Longrightarrow> (\<forall> q \<in> states M . ofsm_table_fix M (\<lambda>q . states M) 0 q = {q})"
proof
fix q assume "minimal M" and "q \<in> states M"
then show "ofsm_table_fix M (\<lambda>q . states M) 0 q = {q}"
unfolding ofsm_table_fix_set[OF \<open>q \<in> states M\<close> \<open>observable M\<close> minimise_initial_partition]
minimal_alt_def
using after_is_state[OF \<open>observable M\<close>]
by blast
qed
show "\<forall>q\<in>FSM.states M. ofsm_table_fix M (\<lambda>q . states M) 0 q = {q} \<Longrightarrow> minimal M"
using ofsm_table_fix_set[OF _ \<open>observable M\<close> minimise_initial_partition] after_is_state[OF \<open>observable M\<close>]
unfolding minimal_alt_def
by blast
qed
lemma minimise_states_subset :
assumes "observable M"
and "q \<in> states (minimise M)"
shows "q \<subseteq> states M"
using assms(2)
unfolding minimise_props[OF assms(1)]
by auto
lemma minimise_states_finite :
assumes "observable M"
and "q \<in> states (minimise M)"
shows "finite q"
using minimise_states_subset[OF assms] fsm_states_finite[of M]
using finite_subset by auto
end
\ No newline at end of file
diff --git a/thys/FSM_Tests/Observability.thy b/thys/FSM_Tests/Observability.thy
--- a/thys/FSM_Tests/Observability.thy
+++ b/thys/FSM_Tests/Observability.thy
@@ -1,1288 +1,1288 @@
section \<open>Observability\<close>
text \<open>This theory presents the classical algorithm for transforming FSMs into
language-equivalent observable FSMs in analogy to the determinisation of nondeterministic
finite automata.\<close>
theory Observability
imports FSM
begin
lemma fPow_Pow : "Pow (fset A) = fset (fset |`| fPow A)"
proof (induction A)
case empty
then show ?case by auto
next
case (insert x A)
have "Pow (fset (finsert x A)) = Pow (fset A) \<union> (insert x) ` Pow (fset A)"
by (simp add: Pow_insert)
moreover have "fset (fset |`| fPow (finsert x A)) = fset (fset |`| fPow A) \<union> (insert x) ` fset (fset |`| fPow A)"
proof -
have "fset |`| ((fPow A) |\<union>| (finsert x) |`| (fPow A)) = (fset |`| fPow A) |\<union>| (insert x) |`| (fset |`| fPow A)"
unfolding fimage_funion
by fastforce
moreover have "(fPow (finsert x A)) = (fPow A) |\<union>| (finsert x) |`| (fPow A)"
by (simp add: fPow_finsert)
ultimately show ?thesis
by auto
qed
ultimately show ?case
using insert.IH by simp
qed
lemma fcard_fsubset: "\<not> fcard (A |-| (B |\<union>| C)) < fcard (A |-| B) \<Longrightarrow> C |\<subseteq>| A \<Longrightarrow> C |\<subseteq>| B"
proof (induction C)
case empty
then show ?case by auto
next
case (insert x C)
then show ?case
unfolding finsert_fsubset funion_finsert_right not_less
proof -
assume a1: "fcard (A |-| B) \<le> fcard (A |-| finsert x (B |\<union>| C))"
assume "\<lbrakk>fcard (A |-| B) \<le> fcard (A |-| (B |\<union>| C)); C |\<subseteq>| A\<rbrakk> \<Longrightarrow> C |\<subseteq>| B"
assume a2: "x |\<in>| A \<and> C |\<subseteq>| A"
have "A |-| (C |\<union>| finsert x B) = A |-| B \<or> \<not> A |-| (C |\<union>| finsert x B) |\<subseteq>| A |-| B"
using a1 by (metis (no_types) fcard_seteq funion_commute funion_finsert_right)
then show "x |\<in>| B \<and> C |\<subseteq>| B"
using a2 by blast
qed
qed
lemma make_observable_transitions_qtrans_helper:
assumes "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) A;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) nexts)"
shows "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
proof -
have "fset qtrans = { (q,x,y,q') | q x y q' . q |\<in>| nexts \<and> q' \<noteq> {||} \<and> fset q' = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y}}"
proof -
have "\<And> q . fset (ffilter (\<lambda>t . t_source t |\<in>| q) A) = Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)"
using ffilter.rep_eq assms(1) by auto
then have "\<And> q . fset (fimage (\<lambda> t . (t_input t, t_output t)) (ffilter (\<lambda>t . t_source t |\<in>| q) A)) = image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A))"
by simp
then have *:"\<And> q . fset (fimage (\<lambda>(x,y) . (q,x,y, (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))))) (fimage (\<lambda> t . (t_input t, t_output t)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))
= image (\<lambda>(x,y) . (q,x,y, (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))))) (image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)))"
by (metis (no_types, lifting) ffilter.rep_eq fset.set_map)
have **: "\<And> f1 f2 xs ys ys' . (\<And> x . fset (f1 x ys) = (f2 x ys')) \<Longrightarrow>
fset (ffUnion (fimage (\<lambda> x . (f1 x ys)) xs)) = (\<Union> x \<in> fset xs . (f2 x ys'))"
unfolding ffUnion.rep_eq fimage.rep_eq by force
have "fset (ffUnion (fimage (\<lambda> q . (fimage (\<lambda>(x,y) . (q,x,y, (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))))) (fimage (\<lambda> t . (t_input t, t_output t)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))) nexts))
= (\<Union> q \<in> fset nexts . image (\<lambda>(x,y) . (q,x,y, (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))))) (image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A))))"
unfolding ffUnion.rep_eq fimage.rep_eq
using "*" by force
also have "\<dots> = { (q,x,y,q') | q x y q' . q |\<in>| nexts \<and> q' \<noteq> {||} \<and> fset q' = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y}}"
(is "?A = ?B") proof -
have "\<And> t . t \<in> ?A \<Longrightarrow> t \<in> ?B"
proof -
fix t assume "t \<in> ?A"
then obtain q where "q \<in> fset nexts"
and "t \<in> image (\<lambda>(x,y) . (q,x,y, (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))))) (image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)))"
by blast
then obtain x y q' where *: "(x,y) \<in> (image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)))"
and "t = (q,x,y,q')"
and **:"q' = (t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A)))))"
by force
have "q |\<in>| nexts"
using \<open>q \<in> fset nexts\<close>
by (meson notin_fset)
moreover have "q' \<noteq> {||}"
proof -
have ***:"(Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)) = fset (ffilter (\<lambda>t . t_source t |\<in>| q) (A))"
by auto
have "\<exists> t . t |\<in>| (ffilter (\<lambda>t. t_source t |\<in>| q) A) \<and> (t_input t, t_output t) = (x,y)"
using *
by (metis (no_types, lifting) "***" image_iff notin_fset)
then show ?thesis unfolding **
by force
qed
moreover have "fset q' = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y}"
proof -
have "{t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y} = ((Set.filter (\<lambda>t . (t_input t, t_output t) = (x,y)) (fset (ffilter (\<lambda>t . t_source t |\<in>| q) (A)))))"
using notin_fset by fastforce
also have "\<dots> = fset ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))"
by fastforce
finally have "{t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y} = fset ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))" .
then show ?thesis
unfolding **
by simp
qed
ultimately show "t \<in> ?B"
unfolding \<open>t = (q,x,y,q')\<close>
by blast
qed
moreover have "\<And> t . t \<in> ?B \<Longrightarrow> t \<in> ?A"
proof -
fix t assume "t \<in> ?B"
then obtain q x y q' where "t = (q,x,y,q')" and "(q,x,y,q') \<in> ?B" by force
then have "q |\<in>| nexts"
and "q' \<noteq> {||}"
and *: "fset q' = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y}"
by force+
then have "fset q' \<noteq> {}"
by (metis bot_fset.rep_eq fset_inject)
have "(x,y) \<in> (image (\<lambda> t . (t_input t, t_output t)) (Set.filter (\<lambda>t . t_source t |\<in>| q) (fset A)))"
proof -
have **:"\<And> t . t |\<in>| A = (t \<in> fset A)"
by (meson notin_fset)
show ?thesis
using \<open>fset q' \<noteq> {}\<close> unfolding * Set.filter_def ** by blast
qed
moreover have "q' = t_target |`| ffilter (\<lambda>t. (t_input t, t_output t) = (x, y)) (ffilter (\<lambda>t. t_source t |\<in>| q) A)"
proof -
have "{t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y} = ((Set.filter (\<lambda>t . (t_input t, t_output t) = (x,y)) (fset (ffilter (\<lambda>t . t_source t |\<in>| q) (A)))))"
using notin_fset by fastforce
also have "\<dots> = fset ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))"
by fastforce
finally have ***:"{t' . t' |\<in>| A \<and> t_source t' |\<in>| q \<and> t_input t' = x \<and> t_output t' = y} = fset ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) (ffilter (\<lambda>t . t_source t |\<in>| q) (A))))" .
show ?thesis
using *
unfolding ***
by (metis (no_types, lifting) fimage.rep_eq fset_inject)
qed
moreover have "q \<in> fset nexts"
using \<open>q |\<in>| nexts\<close>
by (meson notin_fset)
ultimately show "t \<in> ?A"
unfolding \<open>t = (q,x,y,q')\<close>
by force
qed
ultimately show ?thesis
by (metis (no_types, lifting) Collect_cong Sup_set_def mem_Collect_eq)
qed
finally show ?thesis
unfolding assms Let_def by blast
qed
then show "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| A \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
- unfolding fmember.rep_eq by force
+ unfolding fmember_iff_member_fset by force
qed
function make_observable_transitions :: "('a,'b,'c) transition fset \<Rightarrow> 'a fset fset \<Rightarrow> 'a fset fset \<Rightarrow> ('a fset \<times> 'b \<times> 'c \<times> 'a fset) fset \<Rightarrow> ('a fset \<times> 'b \<times> 'c \<times> 'a fset) fset" where
"make_observable_transitions base_trans nexts dones ts = (let
qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| (ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts))) ios)) nexts);
dones' = dones |\<union>| nexts;
ts' = ts |\<union>| qtrans;
nexts' = (fimage t_target qtrans) |-| dones'
in if nexts' = {||}
then ts'
else make_observable_transitions base_trans nexts' dones' ts')"
by auto
termination
proof -
{
fix base_trans :: "('a,'b,'c) transition fset"
fix nexts :: "'a fset fset"
fix dones :: "'a fset fset"
fix ts :: "('a fset \<times> 'b \<times> 'c \<times> 'a fset) fset"
fix q x y q'
assume assm1: "\<not> fcard
(fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans) |-|
(dones |\<union>| nexts |\<union>|
t_target |`|
ffUnion
((\<lambda>q. let qts = ffilter (\<lambda>t. t_source t |\<in>| q) base_trans
in ((\<lambda>(x, y). (q, x, y, t_target |`| ffilter (\<lambda>t. t_input t = x \<and> t_output t = y) qts)) \<circ> (\<lambda>t. (t_input t, t_output t))) |`|
qts) |`|
nexts)))
< fcard (fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans) |-| (dones |\<union>| nexts))"
and assm2: "(q, x, y, q') |\<in>|
ffUnion
((\<lambda>q. let qts = ffilter (\<lambda>t. t_source t |\<in>| q) base_trans
in ((\<lambda>(x, y). (q, x, y, t_target |`| ffilter (\<lambda>t. t_input t = x \<and> t_output t = y) qts)) \<circ> (\<lambda>t. (t_input t, t_output t))) |`| qts) |`|
nexts)"
and assm3: "q' |\<notin>| nexts"
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' | t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
have "\<And> t . t |\<in>| qtrans \<Longrightarrow> t_target t |\<in>| fPow (t_target |`| base_trans)"
proof -
fix t assume "t |\<in>| qtrans"
then have *: "fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using qtrans_prop by blast
then have "fset (t_target t) \<subseteq> t_target ` (fset base_trans)"
by (metis (mono_tags, lifting) imageI image_Collect_subsetI notin_fset)
then show "t_target t |\<in>| fPow (t_target |`| base_trans)"
by (simp add: less_eq_fset.rep_eq)
qed
then have "t_target |`| qtrans |\<subseteq>| (fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans))"
by fastforce
moreover have " \<not> fcard (fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans) |-| (dones |\<union>| nexts |\<union>| t_target |`| qtrans))
< fcard (fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans) |-| (dones |\<union>| nexts))"
using assm1 unfolding qtrans_def by force
ultimately have "t_target |`| qtrans |\<subseteq>| dones |\<union>| nexts"
using fcard_fsubset by fastforce
moreover have "q' |\<in>| t_target |`| qtrans"
using assm2 unfolding qtrans_def by force
ultimately have "q' |\<in>| dones"
using \<open>q' |\<notin>| nexts\<close> by blast
} note t = this
show ?thesis
apply (relation "measure (\<lambda> (base_trans, nexts, dones, ts) . fcard ((fPow (t_source |`| base_trans |\<union>| t_target |`| base_trans)) |-| (dones |\<union>| nexts)))")
apply auto
by (erule t)
qed
lemma make_observable_transitions_mono: "ts |\<subseteq>| (make_observable_transitions base_trans nexts dones ts)"
proof (induction rule: make_observable_transitions.induct[of "\<lambda> base_trans nexts dones ts . ts |\<subseteq>| (make_observable_transitions base_trans nexts dones ts)"])
case (1 base_trans nexts dones ts)
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' | t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
let ?dones' = "dones |\<union>| nexts"
let ?ts' = "ts |\<union>| qtrans"
let ?nexts' = "(fimage t_target qtrans) |-| ?dones'"
have res_cases: "make_observable_transitions base_trans nexts dones ts = (if ?nexts' = {||}
then ?ts'
else make_observable_transitions base_trans ?nexts' ?dones' ?ts')"
unfolding make_observable_transitions.simps[of base_trans nexts dones ts] qtrans_def Let_def by simp
show ?case proof (cases "?nexts' = {||}")
case True
then show ?thesis using res_cases by simp
next
case False
then have "make_observable_transitions base_trans nexts dones ts = make_observable_transitions base_trans ?nexts' ?dones' ?ts'"
using res_cases by simp
moreover have "ts |\<union>| qtrans |\<subseteq>| make_observable_transitions base_trans ?nexts' ?dones' ?ts'"
using "1"[OF qtrans_def _ _ _ False, of ?dones' ?ts'] by blast
ultimately show ?thesis
by blast
qed
qed
inductive pathlike :: "('state, 'input, 'output) transition fset \<Rightarrow> 'state \<Rightarrow> ('state, 'input, 'output) path \<Rightarrow> bool"
where
nil[intro!] : "pathlike ts q []" |
cons[intro!] : "t |\<in>| ts \<Longrightarrow> pathlike ts (t_target t) p \<Longrightarrow> pathlike ts (t_source t) (t#p)"
inductive_cases pathlike_nil_elim[elim!]: "pathlike ts q []"
inductive_cases pathlike_cons_elim[elim!]: "pathlike ts q (t#p)"
lemma make_observable_transitions_t_source :
assumes "\<And> t . t |\<in>| ts \<Longrightarrow> t_source t |\<in>| dones \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
and "\<And> q t' . q |\<in>| dones \<Longrightarrow> t' |\<in>| base_trans \<Longrightarrow> t_source t' |\<in>| q \<Longrightarrow> \<exists> t . t |\<in>| ts \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t'"
and "t |\<in>| make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts"
and "t_source t |\<in>| dones"
shows "t |\<in>| ts"
using assms proof (induction base_trans "(fimage t_target ts) |-| dones" dones ts rule: make_observable_transitions.induct)
case (1 base_trans dones ts)
let ?nexts = "(fimage t_target ts) |-| dones"
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) ?nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| ?nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
let ?dones' = "dones |\<union>| ?nexts"
let ?ts' = "ts |\<union>| qtrans"
let ?nexts' = "(fimage t_target qtrans) |-| ?dones'"
have res_cases: "make_observable_transitions base_trans ?nexts dones ts = (if ?nexts' = {||}
then ?ts'
else make_observable_transitions base_trans ?nexts' ?dones' ?ts')"
unfolding make_observable_transitions.simps[of base_trans ?nexts dones ts] qtrans_def Let_def by simp
show ?case proof (cases "?nexts' = {||}")
case True
then have "make_observable_transitions base_trans ?nexts dones ts = ?ts'"
using res_cases by auto
then have "t |\<in>| ts |\<union>| qtrans"
using \<open>t |\<in>| make_observable_transitions base_trans ?nexts dones ts\<close> \<open>t_source t |\<in>| dones\<close> by blast
then show ?thesis
using qtrans_prop "1.prems"(3,4) by blast
next
case False
then have "make_observable_transitions base_trans ?nexts dones ts = make_observable_transitions base_trans ?nexts' ?dones' ?ts'"
using res_cases by simp
have i1: "(\<And>t. t |\<in>| ts |\<union>| qtrans \<Longrightarrow>
t_source t |\<in>| dones |\<union>| ?nexts \<and>
t_target t \<noteq> {||} \<and>
fset (t_target t) =
t_target `
{t' . t' |\<in>| base_trans \<and>
t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t})"
using "1.prems"(1) qtrans_prop by blast
have i3: "t_target |`| qtrans |-| (dones |\<union>| ?nexts) = t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| ?nexts)"
unfolding "1.prems"(3) by blast
have i2: "(\<And>q t'.
q |\<in>| dones |\<union>| ?nexts \<Longrightarrow>
t' |\<in>| base_trans \<Longrightarrow>
t_source t' |\<in>| q \<Longrightarrow>
\<exists>t. t |\<in>| ts |\<union>| qtrans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t')"
proof -
fix q t' assume "q |\<in>| dones |\<union>| ?nexts"
and *:"t' |\<in>| base_trans"
and **:"t_source t' |\<in>| q"
then consider (a) "q |\<in>| dones" | (b) "q |\<in>| ?nexts" by blast
then show "\<exists>t. t |\<in>| ts |\<union>| qtrans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t'"
proof cases
case a
then show ?thesis using * **
using "1.prems"(2) by blast
next
case b
let ?tgts = "{t'' . t'' |\<in>| base_trans \<and> t_source t'' |\<in>| q \<and> t_input t'' = t_input t' \<and> t_output t'' = t_output t'}"
define tgts where tgts: "tgts = Abs_fset (t_target ` ?tgts)"
have "?tgts \<subseteq> fset base_trans"
using notin_fset by fastforce
then have "finite (t_target ` ?tgts)"
by (meson finite_fset finite_imageI finite_subset)
then have "fset tgts = (t_target ` ?tgts)"
unfolding tgts
using Abs_fset_inverse
by blast
have "?tgts \<noteq> {}"
using * ** by blast
then have "t_target ` ?tgts \<noteq> {}"
by blast
then have "tgts \<noteq> {||}"
using \<open>fset tgts = (t_target ` ?tgts)\<close>
by force
then have "(q, t_input t', t_output t', tgts) |\<in>| qtrans"
using b
unfolding qtrans_prop[of "(q,t_input t',t_output t',tgts)"]
unfolding fst_conv snd_conv
unfolding \<open>fset tgts = (t_target ` ?tgts)\<close>[symmetric]
by blast
then show ?thesis
by auto
qed
qed
have "t |\<in>| make_observable_transitions base_trans ?nexts dones ts \<Longrightarrow> t_source t |\<in>| dones |\<union>| ?nexts \<Longrightarrow> t |\<in>| ts |\<union>| qtrans"
unfolding \<open>make_observable_transitions base_trans ?nexts dones ts = make_observable_transitions base_trans ?nexts' ?dones' ?ts'\<close>
using "1.hyps"[OF qtrans_def _ _ _ _ i1 i2] False i3 by force
then have "t |\<in>| ts |\<union>| qtrans"
using \<open>t |\<in>| make_observable_transitions base_trans ?nexts dones ts\<close> \<open>t_source t |\<in>| dones\<close> by blast
then show ?thesis
using qtrans_prop "1.prems"(3,4) by blast
qed
qed
lemma make_observable_transitions_path :
assumes "\<And> t . t |\<in>| ts \<Longrightarrow> t_source t |\<in>| dones \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' \<in> transitions M . t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
and "\<And> q t' . q |\<in>| dones \<Longrightarrow> t' \<in> transitions M \<Longrightarrow> t_source t' |\<in>| q \<Longrightarrow> \<exists> t . t |\<in>| ts \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t'"
and "\<And> q . q |\<in>| (fimage t_target ts) |-| dones \<Longrightarrow> q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M)"
and "\<And> q . q |\<in>| dones \<Longrightarrow> q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M |\<union>| {|initial M|})"
and "{||} |\<notin>| dones"
and "q |\<in>| dones"
shows "(\<exists> q' p . q' |\<in>| q \<and> path M q' p \<and> p_io p = io) \<longleftrightarrow> (\<exists> p'. pathlike (make_observable_transitions (ftransitions M) ((fimage t_target ts) |-| dones) dones ts) q p' \<and> p_io p' = io)"
using assms proof (induction "ftransitions M" "(fimage t_target ts) |-| dones" dones ts arbitrary: q io rule: make_observable_transitions.induct)
case (1 dones ts q)
let ?obs = "(make_observable_transitions (ftransitions M) ((fimage t_target ts) |-| dones) dones ts)"
let ?nexts = "(fimage t_target ts) |-| dones"
show ?case proof (cases io)
case Nil
have scheme: "\<And> q q' X . q' |\<in>| q \<Longrightarrow> q |\<in>| fPow X \<Longrightarrow> q' |\<in>| X"
by (simp add: fsubsetD)
obtain q' where "q' |\<in>| q"
using \<open>{||} |\<notin>| dones\<close> \<open>q |\<in>| dones\<close> by fastforce
have "q' |\<in>| t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M |\<union>| {|FSM.initial M|}"
using scheme[OF \<open>q' |\<in>| q\<close> "1.prems"(4)[OF \<open>q |\<in>| dones\<close>]] .
then have "q' \<in> states M"
using ftransitions_source[of q' M]
using ftransitions_target[of q' M]
by force
then have "\<exists> q' p . q' |\<in>| q \<and> path M q' p \<and> p_io p = io"
using \<open>q' |\<in>| q\<close> Nil by auto
moreover have "(\<exists> p'. pathlike ?obs q p' \<and> p_io p' = io)"
using Nil by auto
ultimately show ?thesis
by simp
next
case (Cons ioT ioP)
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) (ftransitions M);
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) ?nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| ?nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| (ftransitions M) \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
let ?dones' = "dones |\<union>| ?nexts"
let ?ts' = "ts |\<union>| qtrans"
let ?nexts' = "(fimage t_target qtrans) |-| ?dones'"
have res_cases: "make_observable_transitions (ftransitions M) ?nexts dones ts = (if ?nexts' = {||}
then ?ts'
else make_observable_transitions (ftransitions M) ?nexts' ?dones' ?ts')"
unfolding make_observable_transitions.simps[of "ftransitions M" ?nexts dones ts] qtrans_def Let_def by simp
have i1: "(\<And>t. t |\<in>| ts |\<union>| qtrans \<Longrightarrow>
t_source t |\<in>| dones |\<union>| ?nexts \<and>
t_target t \<noteq> {||} \<and>
fset (t_target t) =
t_target `
{t' \<in> FSM.transitions M .
t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t})"
using "1.prems"(1) qtrans_prop
using ftransitions_set[of M]
- by (metis (mono_tags, lifting) Collect_cong fmember.rep_eq funion_iff)
+ by (metis (mono_tags, lifting) Collect_cong fmember_iff_member_fset funion_iff)
have i2: "(\<And>q t'.
q |\<in>| dones |\<union>| ?nexts \<Longrightarrow>
t' \<in> FSM.transitions M \<Longrightarrow>
t_source t' |\<in>| q \<Longrightarrow>
\<exists>t. t |\<in>| ts |\<union>| qtrans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t')"
proof -
fix q t' assume "q |\<in>| dones |\<union>| ?nexts"
and *:"t' \<in> FSM.transitions M"
and **:"t_source t' |\<in>| q"
then consider (a) "q |\<in>| dones" | (b) "q |\<in>| ?nexts" by blast
then show "\<exists>t. t |\<in>| ts |\<union>| qtrans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t'"
proof cases
case a
then show ?thesis using "1.prems"(2) * ** by blast
next
case b
let ?tgts = "{t'' \<in> FSM.transitions M. t_source t'' |\<in>| q \<and> t_input t'' = t_input t' \<and> t_output t'' = t_output t'}"
have "?tgts \<noteq> {}"
using * ** by blast
let ?tgts = "{t'' . t'' |\<in>| ftransitions M \<and> t_source t'' |\<in>| q \<and> t_input t'' = t_input t' \<and> t_output t'' = t_output t'}"
define tgts where tgts: "tgts = Abs_fset (t_target ` ?tgts)"
have "?tgts \<subseteq> transitions M"
using ftransitions_set[of M]
by (metis (no_types, lifting) mem_Collect_eq notin_fset subsetI)
then have "finite (t_target ` ?tgts)"
by (meson finite_imageI finite_subset fsm_transitions_finite)
then have "fset tgts = (t_target ` ?tgts)"
unfolding tgts
using Abs_fset_inverse
by blast
have "?tgts \<noteq> {}"
using * **
by (metis (mono_tags, lifting) empty_iff ftransitions_set mem_Collect_eq notin_fset)
then have "t_target ` ?tgts \<noteq> {}"
by blast
then have "tgts \<noteq> {||}"
using \<open>fset tgts = (t_target ` ?tgts)\<close>
by force
then have "(q, t_input t', t_output t', tgts) |\<in>| qtrans"
using b
unfolding qtrans_prop[of "(q,t_input t',t_output t',tgts)"]
unfolding fst_conv snd_conv
unfolding \<open>fset tgts = (t_target ` ?tgts)\<close>[symmetric]
by blast
then show ?thesis
by auto
qed
qed
have i3: "t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) = t_target |`| qtrans |-| (dones |\<union>| (t_target |`| ts |-| dones))"
by blast
have i4: "(\<And>q. q |\<in>| t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) \<Longrightarrow>
q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M))"
proof -
fix q assume "q |\<in>| t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones))"
then have "q |\<in>| t_target |`| qtrans"
by auto
then obtain t where "t |\<in>| qtrans" and "t_target t = q"
by auto
then have "fset q = t_target ` {t'. t' |\<in>| ftransitions M \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
unfolding qtrans_prop by auto
then have "fset q \<subseteq> t_target ` transitions M"
by (metis (no_types, lifting) ftransitions_set image_Collect_subsetI image_eqI notin_fset)
then show "q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M)"
by (metis (no_types, lifting) fPowI fset.set_map fset_inject ftransitions_set le_supI2 sup.orderE sup.orderI sup_fset.rep_eq)
qed
have i5: "(\<And>q. q |\<in>| dones |\<union>| ?nexts \<Longrightarrow> q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M |\<union>| {|initial M|}))"
using "1.prems"(4,3) qtrans_prop
by auto
have i7: "{||} |\<notin>| dones |\<union>| ?nexts"
using "1.prems" by fastforce
show ?thesis
proof (cases "?nexts' \<noteq> {||}")
case False
then have "?obs = ?ts'"
using res_cases by auto
have "\<And> q io . q |\<in>| ?dones' \<Longrightarrow> q \<noteq> {||} \<Longrightarrow> (\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = io) \<longleftrightarrow> (\<exists>p'. pathlike ?obs q p' \<and> p_io p' = io)"
proof -
fix q io assume "q |\<in>| ?dones'" and "q \<noteq> {||}"
then show "(\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = io) \<longleftrightarrow> (\<exists>p'. pathlike ?obs q p' \<and> p_io p' = io)"
proof (induction io arbitrary: q)
case Nil
have scheme: "\<And> q q' X . q' |\<in>| q \<Longrightarrow> q |\<in>| fPow X \<Longrightarrow> q' |\<in>| X"
by (simp add: fsubsetD)
obtain q' where "q' |\<in>| q"
using \<open>q \<noteq> {||}\<close> by fastforce
have "q' |\<in>| t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M |\<union>| {|FSM.initial M|}"
using scheme[OF \<open>q' |\<in>| q\<close> i5[OF \<open>q |\<in>| ?dones'\<close>]] .
then have "q' \<in> states M"
using ftransitions_source[of q' M]
using ftransitions_target[of q' M]
by force
then have "\<exists> q' p . q' |\<in>| q \<and> path M q' p \<and> p_io p = []"
using \<open>q' |\<in>| q\<close> by auto
moreover have "(\<exists> p'. pathlike ?obs q p' \<and> p_io p' = [])"
by auto
ultimately show ?case
by simp
next
case (Cons ioT ioP)
have "(\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP) \<Longrightarrow> (\<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP)"
proof -
assume "\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP"
then obtain q' p where "q' |\<in>| q" and "path M q' p" and "p_io p = ioT # ioP"
by meson
then obtain tM pM where "p = tM # pM"
by auto
then have "tM \<in> transitions M" and "t_source tM |\<in>| q"
using \<open>path M q' p\<close> \<open>q' |\<in>| q\<close> by blast+
then obtain tP where "tP |\<in>| ts |\<union>| qtrans"
and "t_source tP = q"
and "t_input tP = t_input tM"
and "t_output tP = t_output tM"
using Cons.prems i2 by blast
have "path M (t_target tM) pM" and "p_io pM = ioP"
using \<open>path M q' p\<close> \<open>p_io p = ioT # ioP\<close> unfolding \<open>p = tM # pM\<close> by auto
moreover have "t_target tM |\<in>| t_target tP"
using i1[OF \<open>tP |\<in>| ts |\<union>| qtrans\<close>]
using \<open>p = tM # pM\<close> \<open>path M q' p\<close> \<open>q' |\<in>| q\<close>
unfolding \<open>t_input tP = t_input tM\<close> \<open>t_output tP = t_output tM\<close> \<open>t_source tP = q\<close>
- using fmember.rep_eq by fastforce
+ using fmember_iff_member_fset by fastforce
ultimately have "\<exists>q' p. q' |\<in>| t_target tP \<and> path M q' p \<and> p_io p = ioP"
using \<open>p_io pM = ioP\<close> \<open>path M (t_target tM) pM\<close> by blast
have "t_target tP |\<in>| dones |\<union>| (t_target |`| ts |-| dones)"
using False \<open>tP |\<in>| ts |\<union>| qtrans\<close> by blast
moreover have "t_target tP \<noteq> {||}"
using i1[OF \<open>tP |\<in>| ts |\<union>| qtrans\<close>] by blast
ultimately obtain pP where "pathlike ?obs (t_target tP) pP" and "p_io pP = ioP"
using Cons.IH \<open>\<exists>q' p. q' |\<in>| t_target tP \<and> path M q' p \<and> p_io p = ioP\<close> by blast
then have "pathlike ?obs q (tP#pP)"
using \<open>t_source tP = q\<close> \<open>tP |\<in>| ts |\<union>| qtrans\<close> \<open>?obs = ?ts'\<close> by auto
moreover have "p_io (tP#pP) = ioT # ioP"
using \<open>t_input tP = t_input tM\<close> \<open>t_output tP = t_output tM\<close> \<open>p_io p = ioT # ioP\<close> \<open>p = tM # pM\<close> \<open>p_io pP = ioP\<close> by simp
ultimately show ?thesis
by auto
qed
moreover have "(\<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP) \<Longrightarrow> (\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP)"
proof -
assume "\<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP"
then obtain p' where "pathlike ?ts' q p'" and "p_io p' = ioT # ioP"
unfolding \<open>?obs = ?ts'\<close> by meson
then obtain tP pP where "p' = tP#pP"
by auto
then have "t_source tP = q" and "tP |\<in>| ?ts'"
using \<open>pathlike ?ts' q p'\<close> by auto
have "pathlike ?ts' (t_target tP) pP" and "p_io pP = ioP"
using \<open>pathlike ?ts' q p'\<close> \<open>p_io p' = ioT # ioP\<close> \<open>p' = tP#pP\<close> by auto
then have "\<exists>p'. pathlike ?ts' (t_target tP) p' \<and> p_io p' = ioP"
by auto
moreover have "t_target tP |\<in>| dones |\<union>| (t_target |`| ts |-| dones)"
using False \<open>tP |\<in>| ts |\<union>| qtrans\<close> by blast
moreover have "t_target tP \<noteq> {||}"
using i1[OF \<open>tP |\<in>| ts |\<union>| qtrans\<close>] by blast
ultimately obtain q'' pM where "q'' |\<in>| t_target tP" and "path M q'' pM" and "p_io pM = ioP"
using Cons.IH unfolding \<open>?obs = ?ts'\<close> by blast
have "q'' \<in> fset (t_target tP)"
using \<open>q'' |\<in>| t_target tP\<close>
by (meson notin_fset)
then obtain tM where "t_source tM |\<in>| q" and "tM \<in> transitions M" and "t_input tM = t_input tP" and "t_output tM = t_output tP" and "t_target tM = q''"
using i1[OF \<open>tP |\<in>| ts |\<union>| qtrans\<close>]
unfolding \<open>t_source tP = q\<close> by force
have "path M (t_source tM) (tM#pM)"
using \<open>tM \<in> transitions M\<close> \<open>t_target tM = q''\<close> \<open>path M q'' pM\<close> by auto
moreover have "p_io (tM#pM) = ioT # ioP"
using \<open>p_io pM = ioP\<close> \<open>t_input tM = t_input tP\<close> \<open>t_output tM = t_output tP\<close> \<open>p_io p' = ioT # ioP\<close> \<open>p' = tP#pP\<close> by auto
ultimately show ?thesis
using \<open>t_source tM |\<in>| q\<close> by meson
qed
ultimately show ?case
by meson
qed
qed
then show ?thesis
using \<open>q |\<in>| dones\<close> \<open>{||} |\<notin>| dones\<close> by blast
next
case True
have "make_observable_transitions (ftransitions M) ?nexts' ?dones' ?ts' = make_observable_transitions (ftransitions M) ?nexts dones ts"
proof (cases "?nexts' = {||}")
case True
then have "?obs = ?ts'"
using qtrans_def by auto
moreover have "make_observable_transitions (ftransitions M) ?nexts' ?dones' ?ts' = ?ts'"
unfolding make_observable_transitions.simps[of "ftransitions M" ?nexts' ?dones' ?ts']
unfolding True Let_def by auto
ultimately show ?thesis
by blast
next
case False
then show ?thesis
unfolding make_observable_transitions.simps[of "ftransitions M" ?nexts dones ts] qtrans_def Let_def by auto
qed
then have IStep: "\<And> q io . q |\<in>| ?dones' \<Longrightarrow>
(\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = io) =
(\<exists>p'. pathlike (make_observable_transitions (ftransitions M) ?nexts dones ts) q p' \<and> p_io p' = io)"
using "1.hyps"[OF qtrans_def _ _ _ _ i1 i2 i4 i5 i7] True
unfolding i3
by presburger
show ?thesis
unfolding \<open>io = ioT # ioP\<close>
proof
show "\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP \<Longrightarrow> \<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP"
proof -
assume "\<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP"
then obtain q' p where "q' |\<in>| q" and "path M q' p" and "p_io p = ioT # ioP"
by meson
then obtain tM pM where "p = tM # pM"
by auto
then have "tM \<in> transitions M" and "t_source tM |\<in>| q"
using \<open>path M q' p\<close> \<open>q' |\<in>| q\<close> by blast+
then obtain tP where "tP |\<in>| ts"
and "t_source tP = q"
and "t_input tP = t_input tM"
and "t_output tP = t_output tM"
using "1.prems"(2,6) by blast
then have i9: "t_target tP |\<in>| dones |\<union>| ?nexts"
by simp
have "path M (t_target tM) pM" and "p_io pM = ioP"
using \<open>path M q' p\<close> \<open>p_io p = ioT # ioP\<close> unfolding \<open>p = tM # pM\<close> by auto
moreover have "t_target tM |\<in>| t_target tP"
using "1.prems"(1)[OF \<open>tP |\<in>| ts\<close>] \<open>p = tM # pM\<close> \<open>path M q' p\<close> \<open>q' |\<in>| q\<close>
unfolding \<open>t_input tP = t_input tM\<close> \<open>t_output tP = t_output tM\<close> \<open>t_source tP = q\<close>
- using fmember.rep_eq by fastforce
+ using fmember_iff_member_fset by fastforce
ultimately have "\<exists>q' p. q' |\<in>| t_target tP \<and> path M q' p \<and> p_io p = ioP"
using \<open>p_io pM = ioP\<close> \<open>path M (t_target tM) pM\<close> by blast
obtain pP where "pathlike ?obs (t_target tP) pP" and "p_io pP = ioP"
using \<open>\<exists>q' p. q' |\<in>| t_target tP \<and> path M q' p \<and> p_io p = ioP\<close> unfolding IStep[OF i9]
using that by blast
then have "pathlike ?obs q (tP#pP)"
using \<open>t_source tP = q\<close> \<open>tP |\<in>| ts\<close> make_observable_transitions_mono by blast
moreover have "p_io (tP#pP) = ioT # ioP"
using \<open>t_input tP = t_input tM\<close> \<open>t_output tP = t_output tM\<close> \<open>p_io p = ioT # ioP\<close> \<open>p = tM # pM\<close> \<open>p_io pP = ioP\<close> by simp
ultimately show ?thesis
by auto
qed
show "\<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP \<Longrightarrow> \<exists>q' p. q' |\<in>| q \<and> path M q' p \<and> p_io p = ioT # ioP"
proof -
assume "\<exists>p'. pathlike ?obs q p' \<and> p_io p' = ioT # ioP"
then obtain p' where "pathlike ?obs q p'" and "p_io p' = ioT # ioP"
by meson
then obtain tP pP where "p' = tP#pP"
by auto
have "\<And> t' . t' |\<in>| ftransitions M = (t' \<in> transitions M)"
using ftransitions_set
by (metis notin_fset)
from \<open>p' = tP#pP\<close> have "t_source tP = q" and "tP |\<in>| ?obs"
using \<open>pathlike ?obs q p'\<close> by auto
then have "tP |\<in>| ts"
using "1.prems"(6) make_observable_transitions_t_source[of ts dones "ftransitions M"] "1.prems"(1,2)
unfolding \<open>\<And> t' . t' |\<in>| ftransitions M = (t' \<in> transitions M)\<close>
by blast
then have i9: "t_target tP |\<in>| dones |\<union>| ?nexts"
by simp
have "pathlike ?obs (t_target tP) pP" and "p_io pP = ioP"
using \<open>pathlike ?obs q p'\<close> \<open>p_io p' = ioT # ioP\<close> \<open>p' = tP#pP\<close> by auto
then have "\<exists>p'. pathlike ?obs (t_target tP) p' \<and> p_io p' = ioP"
by auto
then obtain q'' pM where "q'' |\<in>| t_target tP" and "path M q'' pM" and "p_io pM = ioP"
using IStep[OF i9] by blast
obtain tM where "t_source tM |\<in>| q" and "tM \<in> transitions M" and "t_input tM = t_input tP" and "t_output tM = t_output tP" and "t_target tM = q''"
using "1.prems"(1)[OF \<open>tP |\<in>| ts\<close>] \<open>q'' |\<in>| t_target tP\<close>
unfolding \<open>t_source tP = q\<close>
- unfolding fmember.rep_eq by force
+ unfolding fmember_iff_member_fset by force
have "path M (t_source tM) (tM#pM)"
using \<open>tM \<in> transitions M\<close> \<open>t_target tM = q''\<close> \<open>path M q'' pM\<close> by auto
moreover have "p_io (tM#pM) = ioT # ioP"
using \<open>p_io pM = ioP\<close> \<open>t_input tM = t_input tP\<close> \<open>t_output tM = t_output tP\<close> \<open>p_io p' = ioT # ioP\<close> \<open>p' = tP#pP\<close> by auto
ultimately show ?thesis
using \<open>t_source tM |\<in>| q\<close> by meson
qed
qed
qed
qed
qed
fun observable_fset :: "('a,'b,'c) transition fset \<Rightarrow> bool" where
"observable_fset ts = (\<forall> t1 t2 . t1 |\<in>| ts \<longrightarrow> t2 |\<in>| ts \<longrightarrow>
t_source t1 = t_source t2 \<longrightarrow> t_input t1 = t_input t2 \<longrightarrow> t_output t1 = t_output t2
\<longrightarrow> t_target t1 = t_target t2)"
lemma make_observable_transitions_observable :
assumes "\<And> t . t |\<in>| ts \<Longrightarrow> t_source t |\<in>| dones \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
and "observable_fset ts"
shows "observable_fset (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts)"
using assms proof (induction base_trans "(fimage t_target ts) |-| dones" dones ts rule: make_observable_transitions.induct)
case (1 base_trans dones ts)
let ?nexts = "(fimage t_target ts) |-| dones"
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) ?nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| ?nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
let ?dones' = "dones |\<union>| ?nexts"
let ?ts' = "ts |\<union>| qtrans"
let ?nexts' = "(fimage t_target qtrans) |-| ?dones'"
have "observable_fset qtrans"
using qtrans_prop
unfolding observable_fset.simps
by (metis (mono_tags, lifting) Collect_cong fset_inject)
moreover have "t_source |`| qtrans |\<inter>| t_source |`| ts = {||}"
using "1.prems"(1) qtrans_prop by force
ultimately have "observable_fset ?ts'"
using "1.prems"(2) unfolding observable_fset.simps
by blast
have res_cases: "make_observable_transitions base_trans ?nexts dones ts = (if ?nexts' = {||}
then ?ts'
else make_observable_transitions base_trans ?nexts' ?dones' ?ts')"
unfolding make_observable_transitions.simps[of base_trans ?nexts dones ts] qtrans_def Let_def by simp
show ?case proof (cases "?nexts' = {||}")
case True
then have "make_observable_transitions base_trans ?nexts dones ts = ?ts'"
using res_cases by simp
then show ?thesis
using \<open>observable_fset ?ts'\<close> by simp
next
case False
then have *: "make_observable_transitions base_trans ?nexts dones ts = make_observable_transitions base_trans ?nexts' ?dones' ?ts'"
using res_cases by simp
have i1: "(\<And>t. t |\<in>| ts |\<union>| qtrans \<Longrightarrow>
t_source t |\<in>| dones |\<union>| ?nexts \<and>
t_target t \<noteq> {||} \<and>
fset (t_target t) =
t_target `
{t' . t' |\<in>| base_trans \<and>
t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t})"
using "1.prems"(1) qtrans_prop by blast
have i3: "t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) = t_target |`| qtrans |-| (dones |\<union>| (t_target |`| ts |-| dones))"
by auto
have i4: "t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) \<noteq> {||}"
using False by auto
show ?thesis
using "1.hyps"[OF qtrans_def _ _ i3 i4 i1 \<open>observable_fset ?ts'\<close>] unfolding * i3 by metis
qed
qed
lemma make_observable_transitions_transition_props :
assumes "\<And> t . t |\<in>| ts \<Longrightarrow> t_source t |\<in>| dones \<and> t_target t |\<in>| dones |\<union>| ((fimage t_target ts) |-| dones) \<and> t_input t |\<in>| t_input |`| base_trans \<and> t_output t |\<in>| t_output |`| base_trans"
assumes "t |\<in>| make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts"
shows "t_source t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))"
and "t_target t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))"
and "t_input t |\<in>| t_input |`| base_trans"
and "t_output t |\<in>| t_output |`| base_trans"
proof -
have "t_source t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))
\<and> t_target t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))
\<and> t_input t |\<in>| t_input |`| base_trans
\<and> t_output t |\<in>| t_output |`| base_trans"
using assms(1,2)
proof (induction base_trans "((fimage t_target ts) |-| dones)" dones ts rule: make_observable_transitions.induct)
case (1 base_trans dones ts)
let ?nexts = "((fimage t_target ts) |-| dones)"
define qtrans where qtrans_def: "qtrans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) base_trans;
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)) ?nexts)"
have qtrans_prop: "\<And> t . t |\<in>| qtrans \<longleftrightarrow> t_source t |\<in>| ?nexts \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' . t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using make_observable_transitions_qtrans_helper[OF qtrans_def]
by presburger
let ?dones' = "dones |\<union>| ?nexts"
let ?ts' = "ts |\<union>| qtrans"
let ?nexts' = "(fimage t_target qtrans) |-| ?dones'"
have res_cases: "make_observable_transitions base_trans ?nexts dones ts = (if ?nexts' = {||}
then ?ts'
else make_observable_transitions base_trans ?nexts' ?dones' ?ts')"
unfolding make_observable_transitions.simps[of base_trans ?nexts dones ts] qtrans_def Let_def by simp
have qtrans_trans_prop: "(\<And>t. t |\<in>| qtrans \<Longrightarrow>
t_source t |\<in>| dones |\<union>| (t_target |`| ts |-| dones) \<and>
t_target t |\<in>| dones |\<union>| (t_target |`| ts |-| dones) |\<union>| (t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones))) \<and>
t_input t |\<in>| t_input |`| base_trans \<and> t_output t |\<in>| t_output |`| base_trans)" (is "\<And> t . t |\<in>| qtrans \<Longrightarrow> ?P t")
proof -
fix t assume "t |\<in>| qtrans"
then have "t_source t |\<in>| dones |\<union>| (t_target |`| ts |-| dones)"
using \<open>t |\<in>| qtrans\<close> unfolding qtrans_prop[of t] by blast
moreover have "t_target t |\<in>| dones |\<union>| (t_target |`| ts |-| dones) |\<union>| (t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)))"
using \<open>t |\<in>| qtrans\<close> "1.prems"(1) by blast
moreover have "t_input t |\<in>| t_input |`| base_trans \<and> t_output t |\<in>| t_output |`| base_trans"
proof -
obtain t' where "t' \<in> {t'. t' |\<in>| base_trans \<and> t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using \<open>t |\<in>| qtrans\<close> unfolding qtrans_prop[of t]
by (metis (mono_tags, lifting) Collect_empty_eq bot_fset.rep_eq empty_is_image fset_inject mem_Collect_eq)
then show ?thesis
by force
qed
ultimately show "?P t"
by blast
qed
show ?case proof (cases "?nexts' = {||}")
case True
then have "t |\<in>| ?ts'"
using "1.prems"(2) res_cases by force
then show ?thesis
using "1.prems"(1) qtrans_trans_prop
by (metis True fimage_funion funion_fminus_cancel funion_iff res_cases)
next
case False
then have *: "make_observable_transitions base_trans ?nexts dones ts = make_observable_transitions base_trans ?nexts' ?dones' ?ts'"
using res_cases by simp
have i1: "t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) = t_target |`| qtrans |-| (dones |\<union>| (t_target |`| ts |-| dones))"
by blast
have i2: "t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones)) \<noteq> {||}"
using False by blast
have i3: "(\<And>t. t |\<in>| ts |\<union>| qtrans \<Longrightarrow>
t_source t |\<in>| dones |\<union>| (t_target |`| ts |-| dones) \<and>
t_target t |\<in>| dones |\<union>| (t_target |`| ts |-| dones) |\<union>| (t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones))) \<and>
t_input t |\<in>| t_input |`| base_trans \<and> t_output t |\<in>| t_output |`| base_trans)"
using "1.prems"(1) qtrans_trans_prop by blast
have i4: "t |\<in>| make_observable_transitions base_trans (t_target |`| (ts |\<union>| qtrans) |-| (dones |\<union>| (t_target |`| ts |-| dones))) (dones |\<union>| (t_target |`| ts |-| dones)) (ts |\<union>| qtrans)"
using "1.prems"(2) unfolding * i1 by assumption
show ?thesis
using "1.hyps"[OF qtrans_def _ _ i1 i2 i3 i4] unfolding i1 unfolding *[symmetric]
using make_observable_transitions_mono[of ts base_trans ?nexts dones] by blast
qed
qed
then show "t_source t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))"
and "t_target t |\<in>| dones |\<union>| (t_target |`| (make_observable_transitions base_trans ((fimage t_target ts) |-| dones) dones ts))"
and "t_input t |\<in>| t_input |`| base_trans"
and "t_output t |\<in>| t_output |`| base_trans"
by blast+
qed
fun make_observable :: "('a :: linorder,'b :: linorder,'c :: linorder) fsm \<Rightarrow> ('a fset,'b,'c) fsm" where
"make_observable M = (let
initial_trans = (let qts = ffilter (\<lambda>t . t_source t = initial M) (ftransitions M);
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . ({|initial M|},x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios);
nexts = fimage t_target initial_trans |-| {|{|initial M|}|};
ptransitions = make_observable_transitions (ftransitions M) nexts {|{|initial M|}|} initial_trans;
pstates = finsert {|initial M|} (t_target |`| ptransitions);
M' = create_unconnected_fsm_from_fsets {|initial M|} pstates (finputs M) (foutputs M)
in add_transitions M' (fset ptransitions))"
lemma make_observable_language_observable :
shows "L (make_observable M) = L M"
and "observable (make_observable M)"
and "initial (make_observable M) = {|initial M|}"
and "inputs (make_observable M) = inputs M"
and "outputs (make_observable M) = outputs M"
proof -
define initial_trans where "initial_trans = (let qts = ffilter (\<lambda>t . t_source t = initial M) (ftransitions M);
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . ({|initial M|},x,y, t_target |`| ((ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts)))) ios)"
moreover define ptransitions where "ptransitions = make_observable_transitions (ftransitions M) (fimage t_target initial_trans |-| {|{|initial M|}|}) {|{|initial M|}|} initial_trans"
moreover define pstates where "pstates = finsert {|initial M|} (t_target |`| ptransitions)"
moreover define M' where "M' = create_unconnected_fsm_from_fsets {|initial M|} pstates (finputs M) (foutputs M)"
ultimately have "make_observable M = add_transitions M' (fset ptransitions)"
unfolding make_observable.simps Let_def by blast
have "{|initial M|} |\<in>| pstates"
unfolding pstates_def by blast
have "inputs M' = inputs M"
unfolding M'_def create_unconnected_fsm_from_fsets_simps(3)[OF \<open>{|initial M|} |\<in>| pstates\<close>, of "finputs M" "foutputs M"]
using fset_of_list.rep_eq inputs_as_list_set by fastforce
have "outputs M' = outputs M"
unfolding M'_def create_unconnected_fsm_from_fsets_simps(4)[OF \<open>{|initial M|} |\<in>| pstates\<close>, of "finputs M" "foutputs M"]
using fset_of_list.rep_eq outputs_as_list_set by fastforce
have "states M' = fset pstates" and "transitions M' = {}" and "initial M' = {|initial M|}"
unfolding M'_def create_unconnected_fsm_from_fsets_simps(1,2,5)[OF \<open>{|initial M|} |\<in>| pstates\<close>] by simp+
have initial_trans_prop: "\<And> t . t |\<in>| initial_trans \<longleftrightarrow> t_source t |\<in>| {|{|FSM.initial M|}|} \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' \<in> transitions M . t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
proof -
have *:"\<And> t' . t' |\<in>| ftransitions M = (t' \<in> transitions M)"
using ftransitions_set
by (metis notin_fset)
have **: "initial_trans = ffUnion (fimage (\<lambda> q . (let qts = ffilter (\<lambda>t . t_source t |\<in>| q) (ftransitions M);
ios = fimage (\<lambda> t . (t_input t, t_output t)) qts
in fimage (\<lambda>(x,y) . (q,x,y, t_target |`| (ffilter (\<lambda>t . (t_input t, t_output t) = (x,y)) qts))) ios)) {|{|initial M|}|})"
unfolding initial_trans_def by auto
show "\<And> t . t |\<in>| initial_trans \<longleftrightarrow> t_source t |\<in>| {|{|FSM.initial M|}|} \<and> t_target t \<noteq> {||} \<and> fset (t_target t) = t_target ` {t' \<in> transitions M . t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
unfolding make_observable_transitions_qtrans_helper[OF **] *
by presburger
qed
have well_formed_transitions: "\<And> t . t \<in> (fset ptransitions) \<Longrightarrow> t_source t \<in> states M' \<and> t_input t \<in> inputs M' \<and> t_output t \<in> outputs M' \<and> t_target t \<in> states M'"
(is "\<And> t . t \<in> (fset ptransitions) \<Longrightarrow> ?P1 t \<and> ?P2 t \<and> ?P3 t \<and> ?P4 t")
proof -
fix t assume "t \<in> (fset ptransitions)"
then have i2: "t |\<in>| make_observable_transitions (ftransitions M) (fimage t_target initial_trans |-| {|{|initial M|}|}) {|{|initial M|}|} initial_trans"
using ptransitions_def
by (meson notin_fset)
have i1: "(\<And>t. t |\<in>| initial_trans \<Longrightarrow>
t_source t |\<in>| {|{|FSM.initial M|}|} \<and>
t_target t |\<in>| {|{|FSM.initial M|}|} |\<union>| (t_target |`| initial_trans |-| {|{|FSM.initial M|}|}) \<and>
t_input t |\<in>| t_input |`| ftransitions M \<and> t_output t |\<in>| t_output |`| ftransitions M)" (is "\<And> t . t |\<in>| initial_trans \<Longrightarrow> ?P t")
proof -
fix t assume *: "t |\<in>| initial_trans"
then have "t_source t |\<in>| {|{|FSM.initial M|}|}"
and "t_target t \<noteq> {||}"
and "fset (t_target t) = t_target ` {t' \<in> FSM.transitions M. t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}"
using initial_trans_prop by blast+
have "t_target t |\<in>| {|{|FSM.initial M|}|} |\<union>| (t_target |`| initial_trans |-| {|{|FSM.initial M|}|})"
using "*" by blast
moreover have "t_input t |\<in>| t_input |`| ftransitions M \<and> t_output t |\<in>| t_output |`| ftransitions M"
proof -
obtain t' where "t' \<in> transitions M" and "t_input t = t_input t'" and "t_output t = t_output t'"
using \<open>t_target t \<noteq> {||}\<close> \<open>fset (t_target t) = t_target ` {t' \<in> FSM.transitions M. t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t}\<close>
by (metis (mono_tags, lifting) bot_fset.rep_eq empty_Collect_eq fset_inject image_empty)
have "fset (ftransitions M) = transitions M"
by (simp add: fset_of_list.rep_eq fsm_transitions_finite)
then have "t' |\<in>| ftransitions M"
using \<open>t' \<in> transitions M\<close> notin_fset by fastforce
then show ?thesis
unfolding \<open>t_input t = t_input t'\<close> \<open>t_output t = t_output t'\<close> by auto
qed
ultimately show "?P t"
using \<open>t_source t |\<in>| {|{|FSM.initial M|}|}\<close> by blast
qed
have "?P1 t"
using make_observable_transitions_transition_props(1)[OF i1 i2] unfolding pstates_def ptransitions_def \<open>states M' = fset pstates\<close>
- by (metis finsert_is_funion fmember.rep_eq)
+ by (metis finsert_is_funion fmember_iff_member_fset)
moreover have "?P2 t"
proof-
have "t_input t |\<in>| t_input |`| ftransitions M"
using make_observable_transitions_transition_props(3)[OF i1 i2] by blast
then have "t_input t \<in> t_input ` transitions M"
- using ftransitions_set by (metis (mono_tags, lifting) fmember.rep_eq fset.set_map)
+ using ftransitions_set by (metis (mono_tags, lifting) fmember_iff_member_fset fset.set_map)
then show ?thesis
using finputs_set fsm_transition_input \<open>inputs M' = inputs M\<close> by fastforce
qed
moreover have "?P3 t"
proof-
have "t_output t |\<in>| t_output |`| ftransitions M"
using make_observable_transitions_transition_props(4)[OF i1 i2] by blast
then have "t_output t \<in> t_output ` transitions M"
- using ftransitions_set by (metis (mono_tags, lifting) fmember.rep_eq fset.set_map)
+ using ftransitions_set by (metis (mono_tags, lifting) fmember_iff_member_fset fset.set_map)
then show ?thesis
using foutputs_set fsm_transition_output \<open>outputs M' = outputs M\<close> by fastforce
qed
moreover have "?P4 t"
using make_observable_transitions_transition_props(2)[OF i1 i2] unfolding pstates_def ptransitions_def \<open>states M' = fset pstates\<close>
- by (metis finsert_is_funion fmember.rep_eq)
+ by (metis finsert_is_funion fmember_iff_member_fset)
ultimately show "?P1 t \<and> ?P2 t \<and> ?P3 t \<and> ?P4 t"
by blast
qed
have "initial (make_observable M) = {|initial M|}"
and "states (make_observable M) = fset pstates"
and "inputs (make_observable M) = inputs M"
and "outputs (make_observable M) = outputs M"
and "transitions (make_observable M) = fset ptransitions"
using add_transitions_simps[OF well_formed_transitions, of "fset ptransitions"]
unfolding \<open>make_observable M = add_transitions M' (fset ptransitions)\<close>[symmetric]
\<open>inputs M' = inputs M\<close> \<open>outputs M' = outputs M\<close> \<open>initial M' = {|initial M|}\<close> \<open>states M' = fset pstates\<close> \<open>transitions M' = {}\<close>
by blast+
then show "initial (make_observable M) = {|initial M|}" and "inputs (make_observable M) = inputs M" and "outputs (make_observable M) = outputs M"
by presburger+
have i1: "(\<And>t. t |\<in>| initial_trans \<Longrightarrow>
t_source t |\<in>| {|{|FSM.initial M|}|} \<and>
t_target t \<noteq> {||} \<and>
fset (t_target t) = t_target ` {t' \<in> FSM.transitions M. t_source t' |\<in>| t_source t \<and> t_input t' = t_input t \<and> t_output t' = t_output t})"
using initial_trans_prop by blast
have i2: "(\<And>q t'.
q |\<in>| {|{|FSM.initial M|}|} \<Longrightarrow>
t' \<in> FSM.transitions M \<Longrightarrow> t_source t' |\<in>| q \<Longrightarrow> \<exists>t. t |\<in>| initial_trans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t')"
proof -
fix q t' assume "q |\<in>| {|{|FSM.initial M|}|}" and "t' \<in> FSM.transitions M" and "t_source t' |\<in>| q"
then have "q = {|FSM.initial M|}" and "t_source t' = initial M"
by auto
define tgt where "tgt = t_target ` {t'' \<in> FSM.transitions M. t_source t'' |\<in>| {|FSM.initial M|} \<and> t_input t'' = t_input t' \<and> t_output t'' = t_output t'}"
have "t_target t' \<in> tgt"
unfolding tgt_def using \<open>t' \<in> FSM.transitions M\<close> \<open>t_source t' = initial M\<close> by auto
then have "tgt \<noteq> {}"
by auto
have "finite tgt"
using fsm_transitions_finite[of M] unfolding tgt_def by auto
then have "fset (Abs_fset tgt) = tgt"
by (simp add: Abs_fset_inverse)
then have "Abs_fset tgt \<noteq> {||}"
using \<open>tgt \<noteq> {}\<close> by auto
let ?t = "({|FSM.initial M|}, t_input t', t_output t', Abs_fset tgt)"
have "?t |\<in>| initial_trans"
unfolding initial_trans_prop fst_conv snd_conv \<open>fset (Abs_fset tgt) = tgt\<close>
unfolding \<open>tgt = t_target ` {t'' \<in> FSM.transitions M. t_source t'' |\<in>| {|FSM.initial M|} \<and> t_input t'' = t_input t' \<and> t_output t'' = t_output t'}\<close>[symmetric]
using \<open>Abs_fset tgt \<noteq> {||}\<close>
by blast
then show "\<exists>t. t |\<in>| initial_trans \<and> t_source t = q \<and> t_input t = t_input t' \<and> t_output t = t_output t'"
using \<open>q = {|FSM.initial M|}\<close> by auto
qed
have i3: "(\<And>q. q |\<in>| t_target |`| initial_trans |-| {|{|FSM.initial M|}|} \<Longrightarrow> q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M))"
proof -
fix q assume "q |\<in>| t_target |`| initial_trans |-| {|{|FSM.initial M|}|}"
then obtain t where "t |\<in>| initial_trans" and "t_target t = q"
by auto
have "fset q \<subseteq> t_target ` (transitions M)"
using \<open>t |\<in>| initial_trans\<close>
unfolding initial_trans_prop \<open>t_target t = q\<close>
by auto
then have "q |\<subseteq>| (t_target |`| ftransitions M)"
using ftransitions_set[of M]
by (simp add: less_eq_fset.rep_eq)
then show "q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M)"
by auto
qed
have i4: "(\<And>q. q |\<in>| {|{|FSM.initial M|}|} \<Longrightarrow> q |\<in>| fPow (t_source |`| ftransitions M |\<union>| t_target |`| ftransitions M |\<union>| {|FSM.initial M|}))"
and i5: "{||} |\<notin>| {|{|FSM.initial M|}|}"
and i6: "{|FSM.initial M|} |\<in>| {|{|FSM.initial M|}|}"
by blast+
show "L (make_observable M) = L M"
proof -
have *: "\<And> p . pathlike ptransitions {|initial M|} p = path (make_observable M) {|initial M|} p"
proof
have "\<And> q p . p \<noteq> [] \<Longrightarrow> pathlike ptransitions q p \<Longrightarrow> path (make_observable M) q p"
proof -
fix q p assume "p \<noteq> []" and "pathlike ptransitions q p"
then show "path (make_observable M) q p"
proof (induction p arbitrary: q)
case Nil
then show ?case by blast
next
case (Cons t p)
then have "t |\<in>| ptransitions" and "pathlike ptransitions (t_target t) p" and "t_source t = q"
by blast+
have "t \<in> transitions (make_observable M)"
using \<open>t |\<in>| ptransitions\<close> \<open>transitions (make_observable M) = fset ptransitions\<close>
by (metis notin_fset)
moreover have "path (make_observable M) (t_target t) p"
using Cons.IH[OF _ \<open>pathlike ptransitions (t_target t) p\<close>] calculation by blast
ultimately show ?case
using \<open>t_source t = q\<close> by blast
qed
qed
then show "\<And> p . pathlike ptransitions {|initial M|} p \<Longrightarrow> path (make_observable M) {|initial M|} p"
by (metis \<open>FSM.initial (make_observable M) = {|FSM.initial M|}\<close> fsm_initial path.nil)
show "\<And> q p . path (make_observable M) q p \<Longrightarrow> pathlike ptransitions q p"
proof -
fix q p assume "path (make_observable M) q p"
then show "pathlike ptransitions q p"
proof (induction p arbitrary: q rule: list.induct)
case Nil
then show ?case by blast
next
case (Cons t p)
then have "t \<in> transitions (make_observable M)" and "path (make_observable M) (t_target t) p" and "t_source t = q"
by blast+
have "t |\<in>| ptransitions"
using \<open>t \<in> transitions (make_observable M)\<close> \<open>transitions (make_observable M) = fset ptransitions\<close>
by (metis notin_fset)
then show ?case
using Cons.IH[OF \<open>path (make_observable M) (t_target t) p\<close>] \<open>t_source t = q\<close> by blast
qed
qed
qed
have "\<And> io . (\<exists>q' p. q' |\<in>| {|FSM.initial M|} \<and> path M q' p \<and> p_io p = io) = (\<exists>p'. pathlike ptransitions {|FSM.initial M|} p' \<and> p_io p' = io)"
using make_observable_transitions_path[OF i1 i2 i3 i4 i5 i6] unfolding ptransitions_def[symmetric] by blast
then have "\<And> io . (\<exists>p. path M (FSM.initial M) p \<and> p_io p = io) = (\<exists>p' . path (make_observable M) {|initial M|} p' \<and> p_io p' = io)"
unfolding *
by (metis (no_types, lifting) fempty_iff finsert_iff)
then show ?thesis
unfolding LS.simps \<open>initial (make_observable M) = {|initial M|}\<close> by (metis (no_types, lifting))
qed
show "observable (make_observable M)"
proof -
have i2: "observable_fset initial_trans"
unfolding observable_fset.simps
unfolding initial_trans_prop
using fset_inject
by metis
have "\<And> t' . t' |\<in>| ftransitions M = (t' \<in> transitions M)"
using ftransitions_set
by (metis notin_fset)
have "observable_fset ptransitions"
using make_observable_transitions_observable[OF _ i2, of "{| {|initial M|} |}" "ftransitions M"] i1
unfolding ptransitions_def \<open>\<And> t' . t' |\<in>| ftransitions M = (t' \<in> transitions M)\<close>
by blast
then show ?thesis
unfolding observable.simps observable_fset.simps \<open>transitions (make_observable M) = fset ptransitions\<close>
by (meson notin_fset)
qed
qed
end
\ No newline at end of file
diff --git a/thys/Factored_Transition_System_Bounding/FactoredSystem.thy b/thys/Factored_Transition_System_Bounding/FactoredSystem.thy
--- a/thys/Factored_Transition_System_Bounding/FactoredSystem.thy
+++ b/thys/Factored_Transition_System_Bounding/FactoredSystem.thy
@@ -1,3595 +1,3595 @@
theory FactoredSystem
imports Main "HOL-Library.Finite_Map" "HOL-Library.Sublist" FSSublist
FactoredSystemLib ListUtils HoArithUtils FmapUtils
begin
section "Factored System"
\<comment> \<open>NOTE hide the '++' operator from 'Map' to prevent warnings.\<close>
hide_const (open) Map.map_add
no_notation Map.map_add (infixl "++" 100)
subsection "Semantics of Plan Execution"
text \<open> This section aims at characterizing the semantics of executing plans---i.e. sequences
of actions---on a given initial state.
The semantics of action execution were previously introduced
via the notion of succeding state (`state\_succ`). Plan execution (`exec\_plan`) extends this notion
to sequences of actions by calculating the succeding state from the given state and action pair and
then recursively executing the remaining actions on the succeding state. [Abdulaziz et al., HOL4
Definition 3, p.9] \<close>
lemma state_succ_pair: "state_succ s (p, e) = (if (p \<subseteq>\<^sub>f s) then (e ++ s) else s)"
by (simp add: state_succ_def)
\<comment> \<open>NOTE shortened to 'exec\_plan'\<close>
\<comment> \<open>NOTE using 'fun' because of multiple definining equations.\<close>
\<comment> \<open>NOTE first argument was curried.\<close>
fun exec_plan where
"exec_plan s [] = s"
| "exec_plan s (a # as) = exec_plan (state_succ s a) as"
lemma exec_plan_Append:
fixes as_a as_b s
shows "exec_plan s (as_a @ as_b) = exec_plan (exec_plan s as_a) as_b"
by (induction as_a arbitrary: s as_b) auto
text \<open> Plan execution effectively eliminates cycles: i.e., if a given plan `as` may be partitioned
into plans `as1`, `as2` and `as3`, s.t. the sequential execution of `as1` and `as2` yields the same
state, `as2` may be skipped during plan execution. \<close>
lemma cycle_removal_lemma:
fixes as1 as2 as3
assumes "(exec_plan s (as1 @ as2) = exec_plan s as1)"
shows "(exec_plan s (as1 @ as2 @ as3) = exec_plan s (as1 @ as3))"
using assms exec_plan_Append
by metis
subsubsection "Characterization of the Set of Possible States"
text \<open> To show the construction principle of the set of possible states---in lemma
`construction\_of\_all\_possible\_states\_lemma`---the following ancillary proves of finite map
properties are required.
Most importantly, in lemma `fmupd\_fmrestrict\_subset` we show how finite mappings `s` with domain
@{term "{v} \<union> X"} and `s v = (Some x)` are constructed from their restrictions to `X` via update, i.e.
s = fmupd v x (fmrestrict\_set X s)
This is used in lemma `construction\_of\_all\_possible\_states\_lemma` to show that the set of possible
states for variables @{term "{v} \<union> X"} is constructed inductively from the set of all possible states for
variables `X` via update on point @{term "v \<notin> X"}.
\<close>
\<comment> \<open>NOTE added lemma.\<close>
lemma empty_domain_fmap_set: "{s. fmdom' s = {}} = {fmempty}"
proof -
let ?A = "{s. fmdom' s = {}}"
let ?B = "{fmempty}"
fix s
show ?thesis proof(rule ccontr)
assume C: "?A \<noteq> ?B"
then show False proof -
{
assume C1: "?A \<subset> ?B"
have "?A = {}" using C1 by force
then have False using fmdom'_empty by blast
}
moreover
{
assume C2: "\<not>(?A \<subset> ?B)"
then have "fmdom' fmempty = {}"
by auto
moreover have "fmempty \<in> ?A"
by auto
moreover have "?A \<noteq> {}"
using calculation(2) by blast
moreover have "\<forall>a\<in>?A.a\<notin>?B"
by (metis (mono_tags, lifting)
C Collect_cong calculation(1) fmrestrict_set_dom fmrestrict_set_null singleton_conv)
moreover have "fmempty \<in> ?B" by auto
moreover have "\<exists>a\<in>?A.a\<in>?B"
by simp
moreover have "\<not>(\<forall>a\<in>?A.a\<notin>?B)"
by simp
ultimately have False
by blast
}
ultimately show False
by fastforce
qed
qed
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma possible_states_set_ii_a:
fixes s x v
assumes "(v \<in> fmdom' s)"
shows "(fmdom' ((\<lambda>s. fmupd v x s) s) = fmdom' s)"
using assms insert_absorb
by auto
\<comment> \<open>NOTE added lemma.\<close>
lemma possible_states_set_ii_b:
fixes s x v
assumes "(v \<notin> fmdom' s)"
shows "(fmdom' ((\<lambda>s. fmupd v x s) s) = fmdom' s \<union> {v})"
by auto
\<comment> \<open>NOTE added lemma.\<close>
lemma fmap_neq:
fixes s :: "('a, bool) fmap" and s' :: "('a, bool) fmap"
assumes "(fmdom' s = fmdom' s')"
shows "((s \<noteq> s') \<longleftrightarrow> (\<exists>v\<in>(fmdom' s). fmlookup s v \<noteq> fmlookup s' v))"
using assms fmap_ext fmdom'_notD
by metis
\<comment> \<open>NOTE added lemma.\<close>
lemma fmdom'_fmsubset_restrict_set:
fixes X1 X2 and s :: "('a, bool) fmap"
assumes "X1 \<subseteq> X2" "fmdom' s = X2"
shows "fmdom' (fmrestrict_set X1 s) = X1"
using assms
by (metis (no_types, lifting)
antisym_conv fmdom'_notD fmdom'_notI fmlookup_restrict_set rev_subsetD subsetI)
\<comment> \<open>NOTE added lemma.\<close>
lemma fmsubset_restrict_set:
fixes X1 X2 and s :: "'a state"
assumes "X1 \<subseteq> X2" "s \<in> {s. fmdom' s = X2}"
shows "fmrestrict_set X1 s \<in> {s. fmdom' s = X1}"
using assms fmdom'_fmsubset_restrict_set
by blast
\<comment> \<open>NOTE added lemma.\<close>
lemma fmupd_fmsubset_restrict_set:
fixes X v x and s :: "'a state"
assumes "s \<in> {s. fmdom' s = insert v X}" "fmlookup s v = Some x"
shows "s = fmupd v x (fmrestrict_set X s)"
proof -
\<comment> \<open>Show that domains of 's' and 'fmupd v x (fmrestrict\_set X s)' are identical.\<close>
have 1: "fmdom' s = insert v X"
using assms(1)
by simp
{
have "X \<subseteq> insert v X"
by auto
then have "fmdom' (fmrestrict_set X s) = X"
using 1 fmdom'_fmsubset_restrict_set
by metis
then have "fmdom' (fmupd v x (fmrestrict_set X s)) = insert v X"
using assms(1) fmdom'_fmupd
by auto
}
note 2 = this
moreover
{
fix w
\<comment> \<open>Show case for undefined variables (where lookup yields 'None').\<close>
{
assume "w \<notin> insert v X"
then have "w \<notin> fmdom' s" "w \<notin> fmdom' (fmupd v x (fmrestrict_set X s))"
using 1 2
by argo+
then have "fmlookup s w = fmlookup (fmupd v x (fmrestrict_set X s)) w"
using fmdom'_notD
by metis
}
\<comment> \<open>Show case for defined variables (where lookup yields 'Some y').\<close>
moreover {
assume "w \<in> insert v X"
then have "w \<in> fmdom' s" "w \<in> fmdom' (fmupd v x (fmrestrict_set X s))"
using 1 2
by argo+
then have "fmlookup s w = fmlookup (fmupd v x (fmrestrict_set X s)) w"
by (cases "w = v")
(auto simp add: assms calculation)
}
ultimately have "fmlookup s w = fmlookup (fmupd v x (fmrestrict_set X s)) w"
by blast
}
then show ?thesis
using fmap_ext
by blast
qed
lemma construction_of_all_possible_states_lemma:
fixes v X
assumes "(v \<notin> X)"
shows "({s. fmdom' s = insert v X}
= ((\<lambda>s. fmupd v True s) ` {s. fmdom' s = X})
\<union> ((\<lambda>s. fmupd v False s) ` {s. fmdom' s = X})
)"
proof -
fix v X
let ?A = "{s :: 'a state. fmdom' s = insert v X}"
let ?B = "
((\<lambda>s. fmupd v True s) ` {s :: 'a state. fmdom' s = X})
\<union> ((\<lambda>s. fmupd v False s) ` {s :: 'a state. fmdom' s = X})
"
text \<open>Show the goal by mutual inclusion. The inclusion @{term "?B \<subseteq> ?A"} is trivial and can be solved by
automation. For the complimentary proof @{term "?A \<subseteq> ?B"} however we need to do more work.
In our case we choose a proof by contradiction and show that an @{term "s \<in> ?A"} which is not also in
'?B' cannot exist.\<close>
{
have "?A \<subseteq> ?B" proof(rule ccontr)
assume C: "\<not>(?A \<subseteq> ?B)"
moreover have "\<exists>s\<in>?A. s\<notin>?B"
using C
by auto
moreover obtain s where obtain_s: "s\<in>?A \<and> s\<notin>?B"
using calculation
by auto
moreover have "s\<notin>?B"
using obtain_s
by auto
moreover have "fmdom' s = X \<union> {v}"
using obtain_s
by auto
moreover have "\<forall>s'\<in>?B. fmdom' s' = X \<union> {v}"
by auto
moreover have
"(s \<notin> ((\<lambda>s. fmupd v True s) ` {s. fmdom' s = X}))"
"(s \<notin> ((\<lambda>s. fmupd v False s) ` {s. fmdom' s = X}))"
using obtain_s
by blast+
text \<open> Show that every state @{term "s \<in> ?A"} has been constructed from another state with domain
'X'. \<close>
moreover
{
fix s :: "'a state"
assume 1: "s \<in> {s :: 'a state. fmdom' s = insert v X}"
then have "fmrestrict_set X s \<in> {s :: 'a state. fmdom' s = X}"
using subset_insertI fmsubset_restrict_set
by metis
moreover
{
assume "fmlookup s v = Some True"
then have "s = fmupd v True (fmrestrict_set X s)"
using 1 fmupd_fmsubset_restrict_set
by metis
}
moreover {
assume "fmlookup s v = Some False"
then have "s = fmupd v False (fmrestrict_set X s)"
using 1 fmupd_fmsubset_restrict_set
by fastforce
}
moreover have "fmlookup s v \<noteq> None"
using 1 fmdom'_notI
by fastforce
ultimately have "
(s \<in> ((\<lambda>s. fmupd v True s) ` {s. fmdom' s = X}))
\<or> (s \<in> ((\<lambda>s. fmupd v False s) ` {s. fmdom' s = X}))
"
by force
}
ultimately show False
by meson
qed
}
moreover have "?B \<subseteq> ?A"
by force
ultimately show "?A = ?B" by blast
qed
text \<open> Another important property of the state set is cardinality, i.e. the number of distinct
states which can be modelled using a given finite variable set.
As lemma `card\_of\_set\_of\_all\_possible\_states` shows, for a finite variable set `X`, the number of
possible states is `2 \^ card X`, i.e. the number of assigning two discrete values to `card X` slots
as known from combinatorics.
Again, some additional properties of finite maps had to be proven. Pivotally, in lemma
`updates\_disjoint`, it is shown that the image of updating a set of states with domain `X` on a
point @{term "x \<notin> X"} with either `True` or `False` yields two distinct sets of states with domain
@{term "{x} \<union> X"}. \<close>
\<comment> \<open>NOTE goal has to stay implication otherwise induction rule won't watch.\<close>
lemma FINITE_states:
fixes X :: "'a set"
shows "finite X \<Longrightarrow> finite {(s :: 'a state). fmdom' s = X}"
proof (induction rule: finite.induct)
case emptyI
then have "{s. fmdom' s = {}} = {fmempty}"
by (simp add: empty_domain_fmap_set)
then show ?case
by (simp add: \<open>{s. fmdom' s = {}} = {fmempty}\<close>)
next
case (insertI A a)
assume P1: "finite A"
and P2: "finite {s. fmdom' s = A}"
then show ?case
proof (cases "a \<in> A")
case True
then show ?thesis
using insertI.IH insert_Diff
by fastforce
next
case False
then show ?thesis
proof -
have "finite (
((\<lambda>s. fmupd a True s) ` {s. fmdom' s = A})
\<union> ((\<lambda>s. fmupd a False s) ` {s. fmdom' s = A}))"
using False construction_of_all_possible_states_lemma insertI.IH
by blast
then show ?thesis
using False construction_of_all_possible_states_lemma
by fastforce
qed
qed
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma bool_update_effect:
fixes s X x v b
assumes "finite X" "s \<in> {s :: 'a state. fmdom' s = X}" "x \<in> X" "x \<noteq> v"
shows "fmlookup ((\<lambda>s :: 'a state. fmupd v b s) s) x = fmlookup s x"
using assms fmupd_lookup
by auto
\<comment> \<open>NOTE added lemma.\<close>
lemma bool_update_inj:
fixes X :: "'a set" and v b
assumes "finite X" "v \<notin> X"
shows "inj_on (\<lambda>s. fmupd v b s) {s :: 'a state. fmdom' s = X}"
proof -
let ?f = "\<lambda>s :: 'a state. fmupd v b s"
{
fix s1 s2 :: "'a state"
assume "s1 \<in> {s :: 'a state. fmdom' s = X}" "s2 \<in> {s :: 'a state. fmdom' s = X}"
"?f s1 = ?f s2"
moreover
{
have
"\<forall>x\<in>X. x \<noteq> v \<longrightarrow> fmlookup (?f s1) x = fmlookup s1 x"
"\<forall>x\<in>X. x \<noteq> v \<longrightarrow> fmlookup (?f s2) x = fmlookup s2 x"
by simp+
then have
"\<forall>x\<in>X. x \<noteq> v \<longrightarrow> fmlookup s1 x = fmlookup s2 x"
using calculation(3)
by auto
}
moreover have "fmlookup s1 v = fmlookup s2 v"
using calculation \<open>v \<notin> X\<close>
by force
ultimately have "s1 = s2"
using fmap_neq
by fastforce
}
then show "inj_on (\<lambda>s. fmupd v b s) {s :: 'a state. fmdom' s = X}"
using inj_onI
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma card_update:
fixes X v b
assumes "finite (X :: 'a set)" "v \<notin> X"
shows "
card ((\<lambda>s. fmupd v b s) ` {s :: 'a state. fmdom' s = X})
= card {s :: 'a state. fmdom' s = X}
"
proof -
have "inj_on (\<lambda>s. fmupd v b s) {s :: 'a state. fmdom' s = X}"
using assms bool_update_inj
by fast
then show
"card ((\<lambda>s. fmupd v b s) ` {s :: 'a state. fmdom' s = X}) = card {s :: 'a state. fmdom' s = X}"
using card_image by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma updates_disjoint:
fixes X x
assumes "finite X" "x \<notin> X"
shows "
((\<lambda>s. fmupd x True s) ` {s. fmdom' s = X})
\<inter> ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = X}) = {}
"
proof -
let ?A = "((\<lambda>s. fmupd x True s) ` {s. fmdom' s = X})"
let ?B = "((\<lambda>s. fmupd x False s) ` {s. fmdom' s = X})"
{
assume C: "\<not>(\<forall>a\<in>?A. \<forall>b\<in>?B. a \<noteq> b)"
then have
"\<forall>a\<in>?A. \<forall>b\<in>?B. fmlookup a x \<noteq> fmlookup b x"
by simp
then have "\<forall>a\<in>?A. \<forall>b\<in>?B. a \<noteq> b"
by blast
then have False
using C
by blast
}
then show "?A \<inter> ?B = {}"
using disjoint_iff_not_equal
by blast
qed
lemma card_of_set_of_all_possible_states:
fixes X :: "'a set"
assumes "finite X"
shows "card {(s :: 'a state). fmdom' s = X} = 2 ^ (card X)"
using assms
proof (induction X)
case empty
then have 1: "{s :: 'a state. fmdom' s = {}} = {fmempty}"
using empty_domain_fmap_set
by simp
then have "card {fmempty} = 1"
using is_singleton_altdef
by blast
then have "2^(card {}) = 1"
by auto
then show ?case
using 1
by auto
next
case (insert x F)
then show ?case
\<comment> \<open>TODO refactor and simplify proof further.\<close>
proof (cases "x \<in> F")
case True
then show ?thesis
using insert.hyps(2)
by blast
next
case False
then have "
{s :: 'a state. fmdom' s = insert x F}
= (\<lambda>s. fmupd x True s) ` {s. fmdom' s = F} \<union> (\<lambda>s. fmupd x False s) ` {s. fmdom' s = F}
"
using False construction_of_all_possible_states_lemma
by metis
then have 2: "
card ({s :: 'a state. fmdom' s = insert x F})
= card ((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F} \<union> (\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
"
by argo
then have 3: "2^(card (insert x F)) = 2 * 2^(card F)"
using False insert.hyps(1)
by simp
then have
"card ((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F}) = 2^(card F)"
"card ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F}) = 2^(card F)"
using False card_update insert.IH insert.hyps(1)
by metis+
moreover have "
((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F})
\<inter> ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
= {}
"
using False insert.hyps(1) updates_disjoint
by metis
moreover have "card (
((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F})
\<union> ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
)
= card (((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F}))
+ card ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
"
using calculation card_Un_disjoint card.infinite
power_eq_0_iff rel_simps(76)
by metis
then have "card (
((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F})
\<union> ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
)
= 2 * (2^(card F))"
using calculation(1, 2)
by presburger
then have "card (
((\<lambda>s. fmupd x True s) ` {s. fmdom' s = F})
\<union> ((\<lambda>s. fmupd x False s) ` {s. fmdom' s = F})
)
= 2^(card (insert x F))"
using insert.IH 3
by metis
then show ?thesis
using "2"
by argo
qed
qed
subsubsection "State Lists and State Sets"
\<comment> \<open>NOTE using fun because of two defining equations.\<close>
\<comment> \<open>NOTE paired argument replaced by currying.\<close>
fun state_list where
"state_list s [] = [s]"
| "state_list s (a # as) = s # state_list (state_succ s a) as"
lemma empty_state_list_lemma:
fixes as s
shows "\<not>([] = state_list s as)"
proof (induction as)
qed auto
lemma state_list_length_non_zero:
fixes as s
shows "\<not>(0 = length (state_list s as))"
proof (induction as)
qed auto
lemma state_list_length_lemma:
fixes as s
shows "length as = length (state_list s as) - 1"
proof (induction as arbitrary: s)
next case (Cons a as)
have "length (state_list s (Cons a as)) - 1 = length (state_list (state_succ s a) as)"
by auto
\<comment> \<open>TODO unwrap metis proof.\<close>
then show "length (Cons a as) = length (state_list s (Cons a as)) - 1"
by (metis Cons.IH Suc_diff_1 empty_state_list_lemma length_Cons length_greater_0_conv)
qed simp
lemma state_list_length_lemma_2:
fixes as s
shows "(length (state_list s as)) = (length as + 1)"
proof (induction as arbitrary: s)
qed auto
\<comment> \<open>NOTE using fun because of multiple defining equations.\<close>
\<comment> \<open>NOTE name shortened to 'state\_def'\<close>
fun state_set where
"state_set [] = {}"
| "state_set (s # ss) = insert [s] (Cons s ` (state_set ss))"
lemma state_set_thm:
fixes s1
shows "s1 \<in> state_set s2 \<longleftrightarrow> prefix s1 s2 \<and> s1 \<noteq> []"
proof -
\<comment> \<open>NOTE Show equivalence by proving both directions. Left-to-right is trivial. Right-to-Left
primarily involves exploiting the prefix premise, induction hypothesis and `state\_set`
definition.\<close>
have "s1 \<in> state_set s2 \<Longrightarrow> prefix s1 s2 \<and> s1 \<noteq> []"
by (induction s2 arbitrary: s1) auto
moreover {
assume P: "prefix s1 s2" "s1 \<noteq> []"
then have "s1 \<in> state_set s2"
proof (induction s2 arbitrary: s1)
case (Cons a s2)
obtain s1' where 1: "s1 = a # s1'" "prefix s1' s2"
using Cons.prems(1, 2) prefix_Cons
by metis
then show ?case proof (cases "s1' = []")
case True
then show ?thesis
using 1
by force
next
case False
then have "s1' \<in> state_set s2"
using 1 False Cons.IH
by blast
then show ?thesis
using 1
by fastforce
qed
qed simp
}
ultimately show "s1 \<in> state_set s2 \<longleftrightarrow> prefix s1 s2 \<and> s1 \<noteq> []"
by blast
qed
lemma state_set_finite:
fixes X
shows "finite (state_set X)"
by (induction X) auto
lemma LENGTH_state_set:
fixes X e
assumes "e \<in> state_set X"
shows "length e \<le> length X"
using assms
by (induction X arbitrary: e) auto
lemma lemma_temp:
fixes x s as h
assumes "x \<in> state_set (state_list s as)"
shows "length (h # state_list s as) > length x"
using assms LENGTH_state_set le_imp_less_Suc
by force
lemma NIL_NOTIN_stateset:
fixes X
shows "[] \<notin> state_set X"
by (induction X) auto
\<comment> \<open>NOTE added lemma.\<close>
lemma state_set_card_i:
fixes X a
shows "[a] \<notin> (Cons a ` state_set X)"
by (induction X) auto
\<comment> \<open>NOTE added lemma.\<close>
lemma state_set_card_ii:
fixes X a
shows "card (Cons a ` state_set X) = card (state_set X)"
proof -
have "inj_on (Cons a) (state_set X)"
by simp
then show ?thesis
using card_image
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma state_set_card_iii:
fixes X a
shows "card (state_set (a # X)) = 1 + card (state_set X)"
proof -
have "card (state_set (a # X)) = card (insert [a] (Cons a ` state_set X))"
by auto
\<comment> \<open>TODO unwrap this metis step.\<close>
also have "\<dots> = 1 + card (Cons a ` state_set X)"
using state_set_card_i
by (metis Suc_eq_plus1_left card_insert_disjoint finite_imageI state_set_finite)
also have"\<dots> = 1 + card (state_set X)"
using state_set_card_ii
by metis
finally show "card (state_set (a # X)) = 1 + card (state_set X)"
by blast
qed
lemma state_set_card:
fixes X
shows "card (state_set X) = length X"
proof (induction X)
case (Cons a X)
then have "card (state_set (a # X)) = 1 + card (state_set X)"
using state_set_card_iii
by fast
then show ?case
using Cons
by fastforce
qed auto
subsubsection "Properties of Domain Changes During Plan Execution"
lemma FDOM_state_succ:
assumes "fmdom' (snd a) \<subseteq> fmdom' s"
shows "(fmdom' (state_succ s a) = fmdom' s)"
unfolding state_succ_def fmap_add_ltr_def
using assms
by force
lemma FDOM_state_succ_subset:
"fmdom' (state_succ s a) \<subseteq> (fmdom' s \<union> fmdom' (snd a))"
unfolding state_succ_def fmap_add_ltr_def
by simp
\<comment> \<open>NOTE definition `qispl\_then` removed (was not being used).\<close>
lemma FDOM_eff_subset_FDOM_valid_states:
fixes p e s
assumes "(p, e) \<in> PROB" "(s \<in> valid_states PROB)"
shows "(fmdom' e \<subseteq> fmdom' s)"
proof -
{
have "fmdom' e \<subseteq> action_dom p e"
unfolding action_dom_def
by blast
also have "\<dots> \<subseteq> prob_dom PROB"
unfolding action_dom_def prob_dom_def
using assms(1)
by blast
finally have "fmdom' e \<subseteq> fmdom' s"
using assms
by (auto simp: valid_states_def)
}
then show "fmdom' e \<subseteq> fmdom' s"
by simp
qed
lemma FDOM_eff_subset_FDOM_valid_states_pair:
fixes a s
assumes "a \<in> PROB" "s \<in> valid_states PROB"
shows "fmdom' (snd a) \<subseteq> fmdom' s"
proof -
{
have "fmdom' (snd a) \<subseteq> (\<lambda>(s1, s2). action_dom s1 s2) a"
unfolding action_dom_def
using case_prod_beta
by fastforce
also have "\<dots> \<subseteq> prob_dom PROB"
using assms(1) prob_dom_def Sup_upper
by fast
finally have "fmdom' (snd a) \<subseteq> fmdom' s"
using assms(2) valid_states_def
by fast
}
then show ?thesis
by simp
qed
lemma FDOM_pre_subset_FDOM_valid_states:
fixes p e s
assumes "(p, e) \<in> PROB" "s \<in> valid_states PROB"
shows "fmdom' p \<subseteq> fmdom' s"
proof -
{
have "fmdom' p \<subseteq> (\<lambda>(s1, s2). action_dom s1 s2) (p, e)"
using action_dom_def
by fast
also have "\<dots> \<subseteq> prob_dom PROB"
using assms(1)
by (simp add: Sup_upper pair_imageI prob_dom_def)
finally have "fmdom' p \<subseteq> fmdom' s"
using assms(2) valid_states_def
by fast
}
then show ?thesis
by simp
qed
lemma FDOM_pre_subset_FDOM_valid_states_pair:
fixes a s
assumes "a \<in> PROB" "s \<in> valid_states PROB"
shows "fmdom' (fst a) \<subseteq> fmdom' s"
proof -
{
have "fmdom' (fst a) \<subseteq> (\<lambda>(s1, s2). action_dom s1 s2) a"
using action_dom_def
by force
also have "\<dots> \<subseteq> prob_dom PROB"
using assms(1)
by (simp add: Sup_upper pair_imageI prob_dom_def)
finally have "fmdom' (fst a) \<subseteq> fmdom' s"
using assms(2) valid_states_def
by fast
}
then show ?thesis
by simp
qed
\<comment> \<open>TODO unwrap the simp proof.\<close>
lemma action_dom_subset_valid_states_FDOM:
fixes p e s
assumes "(p, e) \<in> PROB" "s \<in> valid_states PROB"
shows "action_dom p e \<subseteq> fmdom' s"
using assms
by (simp add: Sup_upper pair_imageI prob_dom_def valid_states_def)
\<comment> \<open>TODO unwrap the metis proof.\<close>
lemma FDOM_eff_subset_prob_dom:
fixes p e
assumes "(p, e) \<in> PROB"
shows "fmdom' e \<subseteq> prob_dom PROB"
using assms
by (metis Sup_upper Un_subset_iff action_dom_def pair_imageI prob_dom_def)
lemma FDOM_eff_subset_prob_dom_pair:
fixes a
assumes "a \<in> PROB"
shows "fmdom' (snd a) \<subseteq> prob_dom PROB"
using assms(1) FDOM_eff_subset_prob_dom surjective_pairing
by metis
\<comment> \<open>TODO unwrap metis proof.\<close>
lemma FDOM_pre_subset_prob_dom:
fixes p e
assumes "(p, e) \<in> PROB"
shows "fmdom' p \<subseteq> prob_dom PROB"
using assms
by (metis (no_types) Sup_upper Un_subset_iff action_dom_def pair_imageI prob_dom_def)
lemma FDOM_pre_subset_prob_dom_pair:
fixes a
assumes "a \<in> PROB"
shows "fmdom' (fst a) \<subseteq> prob_dom PROB"
using assms FDOM_pre_subset_prob_dom surjective_pairing
by metis
subsubsection "Properties of Valid Plans"
lemma valid_plan_valid_head:
assumes "(h # as \<in> valid_plans PROB)"
shows "h \<in> PROB"
using assms valid_plans_def
by force
lemma valid_plan_valid_tail:
assumes "(h # as \<in> valid_plans PROB)"
shows "(as \<in> valid_plans PROB)"
using assms
by (simp add: valid_plans_def)
\<comment> \<open>TODO unwrap simp proof.\<close>
lemma valid_plan_pre_subset_prob_dom_pair:
assumes "as \<in> valid_plans PROB"
shows "(\<forall>a. ListMem a as \<longrightarrow> fmdom' (fst a) \<subseteq> (prob_dom PROB))"
unfolding valid_plans_def
using assms
by (simp add: FDOM_pre_subset_prob_dom_pair ListMem_iff rev_subsetD valid_plans_def)
lemma valid_append_valid_suff:
assumes "as1 @ as2 \<in> (valid_plans PROB)"
shows "as2 \<in> (valid_plans PROB)"
using assms
by (simp add: valid_plans_def)
lemma valid_append_valid_pref:
assumes "as1 @ as2 \<in> (valid_plans PROB)"
shows "as1 \<in> (valid_plans PROB)"
using assms
by (simp add: valid_plans_def)
lemma valid_pref_suff_valid_append:
assumes "as1 \<in> (valid_plans PROB)" "as2 \<in> (valid_plans PROB)"
shows "(as1 @ as2) \<in> (valid_plans PROB)"
using assms
by (simp add: valid_plans_def)
\<comment> \<open>NOTE showcase (case split seems necessary for MP of IH but the original proof does not need it).\<close>
lemma MEM_statelist_FDOM:
fixes PROB h as s0
assumes "s0 \<in> (valid_states PROB)" "as \<in> (valid_plans PROB)" "ListMem h (state_list s0 as)"
shows "(fmdom' h = fmdom' s0)"
using assms
proof (induction as arbitrary: PROB h s0)
case Nil
have "h = s0"
using Nil.prems(3) ListMem_iff
by force
then show ?case
by simp
next
case (Cons a as)
then show ?case
\<comment> \<open>NOTE This case split seems necessary to be able to infer
'ListMem h (state\_list (state\_succ s0 a) as)'
which is required in order to apply MP to the induction hypothesis.\<close>
proof (cases "h = s0")
case False
\<comment> \<open>TODO proof steps could be refactored into auxillary lemmas.\<close>
{
have "a \<in> PROB"
using Cons.prems(2) valid_plan_valid_head
by fast
then have "fmdom' (snd a) \<subseteq> fmdom' s0"
using Cons.prems(1) FDOM_eff_subset_FDOM_valid_states_pair
by blast
then have "fmdom' (state_succ s0 a) = fmdom' s0"
using FDOM_state_succ[of _ s0] Cons.prems(1) valid_states_def
by presburger
}
note 1 = this
{
have "fmdom' s0 = prob_dom PROB"
using Cons.prems(1) valid_states_def
by fast
then have "state_succ s0 a \<in> valid_states PROB"
unfolding valid_states_def
using 1
by force
}
note 2 = this
{
have "ListMem h (state_list (state_succ s0 a) as)"
using Cons.prems(3) False
by (simp add: ListMem_iff)
}
note 3 = this
{
have "as \<in> valid_plans PROB"
using Cons.prems(2) valid_plan_valid_tail
by fast
then have "fmdom' h = fmdom' (state_succ s0 a)"
using 1 2 3 Cons.IH[of "state_succ s0 a"]
by blast
}
then show ?thesis
using 1
by argo
qed simp
qed
\<comment> \<open>TODO unwrap metis proof.\<close>
lemma MEM_statelist_valid_state:
fixes PROB h as s0
assumes "s0 \<in> valid_states PROB" "as \<in> valid_plans PROB" "ListMem h (state_list s0 as)"
shows "(h \<in> valid_states PROB)"
using assms
by (metis MEM_statelist_FDOM mem_Collect_eq valid_states_def)
\<comment> \<open>TODO refactor (characterization lemma for 'state\_succ').\<close>
\<comment> \<open>TODO unwrap metis proof.\<close>
\<comment> \<open>NOTE added lemma.\<close>
lemma lemma_1_i:
fixes s a PROB
assumes "s \<in> valid_states PROB" "a \<in> PROB"
shows "state_succ s a \<in> valid_states PROB"
using assms
by (metis FDOM_eff_subset_FDOM_valid_states_pair FDOM_state_succ mem_Collect_eq valid_states_def)
\<comment> \<open>TODO unwrap smt proof.\<close>
\<comment> \<open>NOTE added lemma.\<close>
lemma lemma_1_ii:
"last ` ((#) s ` state_set (state_list (state_succ s a) as))
= last ` state_set (state_list (state_succ s a) as)"
by (smt NIL_NOTIN_stateset image_cong image_image last_ConsR)
lemma lemma_1:
fixes as :: "(('a, 'b) fmap \<times> ('a, 'b) fmap) list" and PPROB
assumes "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "((last ` (state_set (state_list s as))) \<subseteq> valid_states PROB)"
using assms
proof (induction as arbitrary: s PROB)
\<comment> \<open>NOTE Base case simplifies to @{term "{s} \<subseteq> valid_states PROB"} which itself follows directly from
1st assumption.\<close>
case (Cons a as)
text \<open> Split the 'insert' term produced by @{term "state_set (state_list s (a # as))"} and proof
inclusion in 'valid\_states PROB' for both parts. \<close>
{
\<comment> \<open>NOTE Inclusion of the first subset follows from the induction premise by simplification.
The inclusion of the second subset is shown by applying the induction hypothesis to
`state\_succ s a` and some elementary set simplifications.\<close>
have "last [s] \<in> valid_states PROB"
using Cons.prems(1)
by simp
moreover {
{
have "a \<in> PROB"
using Cons.prems(2) valid_plan_valid_head
by fast
then have "state_succ s a \<in> valid_states PROB"
using Cons.prems(1) lemma_1_i
by blast
}
moreover have "as \<in> valid_plans PROB"
using Cons.prems(2) valid_plan_valid_tail
by fast
then have "(last ` state_set (state_list (state_succ s a) as)) \<subseteq> valid_states PROB"
using calculation Cons.IH[of "state_succ s a"]
by presburger
then have "(last ` ((#) s ` state_set (state_list (state_succ s a) as))) \<subseteq> valid_states PROB"
using lemma_1_ii
by metis
}
ultimately have
"(last ` insert [s] ((#) s ` state_set (state_list (state_succ s a) as))) \<subseteq> valid_states PROB"
by simp
}
then show ?case
by fastforce
qed auto
\<comment> \<open>TODO unwrap metis proof.\<close>
lemma len_in_state_set_le_max_len:
fixes as x PROB
assumes "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)" "\<not>(as = [])"
"(x \<in> state_set (state_list s as))"
shows "(length x \<le> (Suc (length as)))"
using assms
by (metis LENGTH_state_set Suc_eq_plus1_left add.commute state_list_length_lemma_2)
lemma card_state_set_cons:
fixes as s h
shows "
(card (state_set (state_list s (h # as)))
= Suc (card (state_set (state_list (state_succ s h) as))))
"
by (metis length_Cons state_list.simps(2) state_set_card)
lemma card_state_set:
fixes as s
shows "(Suc (length as)) = card (state_set (state_list s as))"
by (simp add: state_list_length_lemma_2 state_set_card)
lemma neq_mems_state_set_neq_len:
fixes as x y s
assumes "x \<in> state_set (state_list s as)" "(y \<in> state_set (state_list s as))" "\<not>(x = y)"
shows "\<not>(length x = length y)"
proof -
have "x \<noteq> []" "prefix x (state_list s as)"
using assms(1) state_set_thm
by blast+
moreover have "y \<noteq> []" "prefix y (state_list s as)"
using assms(2) state_set_thm
by blast+
ultimately show ?thesis
using assms(3) append_eq_append_conv prefixE
by metis
qed
\<comment> \<open>NOTE added definition (imported from pred\_setScript.sml:1562).\<close>
definition inj :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a set \<Rightarrow> 'b set \<Rightarrow> bool" where
"inj f A B \<equiv> (\<forall>x \<in> A. f x \<in> B) \<and> inj_on f A"
\<comment> \<open>NOTE added lemma; refactored from `not\_eq\_last\_diff\_paths`.\<close>
lemma not_eq_last_diff_paths_i:
fixes s as PROB
assumes "s \<in> valid_states PROB" "as \<in> valid_plans PROB" "x \<in> state_set (state_list s as)"
shows "last x \<in> valid_states PROB"
proof -
have "last x \<in> last ` (state_set (state_list s as))"
using assms(3)
by simp
then show ?thesis
using assms(1, 2) lemma_1
by blast
qed
lemma not_eq_last_diff_paths_ii:
assumes "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"\<not>(inj (last) (state_set (state_list s as)) (valid_states PROB))"
shows "\<exists>l1. \<exists>l2.
l1 \<in> state_set (state_list s as)
\<and> l2 \<in> state_set (state_list s as)
\<and> last l1 = last l2
\<and> l1 \<noteq> l2
"
proof -
let ?S="state_set (state_list s as)"
have 1: "\<not>(\<forall>x\<in>?S. last x \<in> valid_states PROB) = False"
using assms(1, 2) not_eq_last_diff_paths_i
by blast
{
have
"(\<not>(inj (last) ?S (valid_states PROB))) = (\<not>((\<forall>x\<in>?S. \<forall>y\<in>?S. last x = last y \<longrightarrow> x = y)))"
unfolding inj_def inj_on_def
using 1
by blast
then have "
(\<not>(inj (last) ?S (valid_states PROB)))
= (\<exists>x. \<exists>y. x\<in>?S \<and> y\<in>?S \<and> last x = last y \<and> x \<noteq> y)
"
using assms(3)
by blast
}
then show ?thesis
using assms(3) by blast
qed
lemma not_eq_last_diff_paths:
fixes as PROB s
assumes "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"\<not>(inj (last) (state_set (state_list s as)) (valid_states PROB))"
shows "(\<exists>slist_1 slist_2.
(slist_1 \<in> state_set (state_list s as))
\<and> (slist_2 \<in> state_set (state_list s as))
\<and> ((last slist_1) = (last slist_2))
\<and> \<not>(length slist_1 = length slist_2))
"
proof -
obtain l1 l2 where "
l1 \<in> state_set (state_list s as)
\<and> l2 \<in> state_set (state_list s as)
\<and> last l1 = last l2
\<and> l1 \<noteq> l2
"
using assms(1, 2, 3) not_eq_last_diff_paths_ii
by blast
then show ?thesis
using neq_mems_state_set_neq_len
by blast
qed
\<comment> \<open>NOTE this lemma was removed due to being redundant and being shadowed later on:
lemma empty\_list\_nin\_state\_set\<close>
lemma nempty_sl_in_state_set:
fixes sl
assumes "sl \<noteq> []"
shows "sl \<in> state_set sl"
using assms state_set_thm
by auto
lemma empty_list_nin_state_set:
fixes h slist as
assumes "(h # slist) \<in> state_set (state_list s as)"
shows "(h = s)"
using assms
by (induction as) auto
lemma cons_in_state_set_2:
fixes s slist h t
assumes "(slist \<noteq> [])" "((s # slist) \<in> state_set (state_list s (h # t)))"
shows "(slist \<in> state_set (state_list (state_succ s h) t))"
using assms
by (induction slist) auto
\<comment> \<open>TODO move up and replace 'FactoredSystem.lemma\_1\_i'?\<close>
lemma valid_action_valid_succ:
assumes "h \<in> PROB" "s \<in> valid_states PROB"
shows "(state_succ s h) \<in> valid_states PROB"
using assms lemma_1_i
by blast
lemma in_state_set_imp_eq_exec_prefix:
fixes slist as PROB s
assumes "(as \<noteq> [])" "(slist \<noteq> [])" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"(slist \<in> state_set (state_list s as))"
shows
"(\<exists>as'. (prefix as' as) \<and> (exec_plan s as' = last slist) \<and> (length slist = Suc (length as')))"
using assms
proof (induction slist arbitrary: as s PROB)
case cons_1: (Cons a slist)
have 1: "s # slist \<in> state_set (state_list s as)"
using cons_1.prems(5) empty_list_nin_state_set
by auto
then show ?case
using cons_1
proof (cases as)
case cons_2: (Cons a' R\<^sub>a\<^sub>s)
then have a: "state_succ s a' \<in> valid_states PROB"
using cons_1.prems(3, 4) valid_action_valid_succ valid_plan_valid_head
by metis
then have b: "R\<^sub>a\<^sub>s \<in> valid_plans PROB"
using cons_1.prems(4) cons_2 valid_plan_valid_tail
by fast
then show ?thesis
proof (cases slist)
case Nil
then show ?thesis
using cons_1.prems(5) empty_list_nin_state_set
by auto
next
case cons_3: (Cons a'' R\<^sub>s\<^sub>l\<^sub>i\<^sub>s\<^sub>t)
then have i: "a'' # R\<^sub>s\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<in> state_set (state_list (state_succ s a') R\<^sub>a\<^sub>s)"
using 1 cons_2 cons_in_state_set_2
by blast
then show ?thesis
proof (cases R\<^sub>a\<^sub>s)
case Nil
then show ?thesis
using i cons_2 cons_3
by auto
next
case (Cons a''' R\<^sub>a\<^sub>s')
then obtain as' where
"prefix as' (a''' # R\<^sub>a\<^sub>s')" "exec_plan (state_succ s a') as' = last slist"
"length slist = Suc (length as')"
using cons_1.IH[of "a''' # R\<^sub>a\<^sub>s'" "state_succ s a'" PROB]
using i a b cons_3
by blast
then show ?thesis
using Cons_prefix_Cons cons_2 cons_3 exec_plan.simps(2) last.simps length_Cons
list.distinct(1) local.Cons
by metis
qed
qed
qed auto
qed auto
lemma eq_last_state_imp_append_nempty_as:
fixes as PROB slist_1 slist_2
assumes "(as \<noteq> [])" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)" "(slist_1 \<noteq> [])"
"(slist_2 \<noteq> [])" "(slist_1 \<in> state_set (state_list s as))"
"(slist_2 \<in> state_set (state_list s as))" "\<not>(length slist_1 = length slist_2)"
"(last slist_1 = last slist_2)"
shows "(\<exists>as1 as2 as3.
(as1 @ as2 @ as3 = as)
\<and> (exec_plan s (as1 @ as2) = exec_plan s as1)
\<and> \<not>(as2 = [])
)"
proof -
obtain as_1 where 1: "(prefix as_1 as)" "(exec_plan s as_1 = last slist_1)"
"length slist_1 = Suc (length as_1)"
using assms(1, 2, 3, 4, 6) in_state_set_imp_eq_exec_prefix
by blast
obtain as_2 where 2: "(prefix as_2 as)" "(exec_plan s as_2 = last slist_2)"
"(length slist_2) = Suc (length as_2)"
using assms(1, 2, 3, 5, 7) in_state_set_imp_eq_exec_prefix
by blast
then have "length as_1 \<noteq> length as_2"
using assms(8) 1(3) 2(3)
by fastforce
then consider (i) "length as_1 < length as_2" | (ii) "length as_1 > length as_2"
by force
then show ?thesis
proof (cases)
case i
then have "prefix as_1 as_2"
using 1(1) 2(1) len_gt_pref_is_pref
by blast
then obtain a where a1: "as_2 = as_1 @ a"
using prefixE
by blast
then obtain b where b1: "as = as_2 @ b"
using prefixE 2(1)
by blast
let ?as1="as_1"
let ?as2="a"
let ?as3="b"
have "as = ?as1 @ ?as2 @ ?as3"
using a1 b1
by simp
moreover have "exec_plan s (?as1 @ ?as2) = exec_plan s ?as1"
using 1(2) 2(2) a1 assms(9)
by auto
moreover have "?as2 \<noteq> []"
using i a1
by simp
ultimately show ?thesis
by blast
next
case ii
then have "prefix as_2 as_1"
using 1(1) 2(1) len_gt_pref_is_pref
by blast
then obtain a where a2: "as_1 = as_2 @ a"
using prefixE
by blast
then obtain b where b2: "as = as_1 @ b"
using prefixE 1(1)
by blast
let ?as1="as_2"
let ?as2="a"
let ?as3="b"
have "as = ?as1 @ ?as2 @ ?as3"
using a2 b2
by simp
moreover have "exec_plan s (?as1 @ ?as2) = exec_plan s ?as1"
using 1(2) 2(2) a2 assms(9)
by auto
moreover have "?as2 \<noteq> []"
using ii a2
by simp
ultimately show ?thesis
by blast
qed
qed
lemma FINITE_prob_dom:
assumes "finite PROB"
shows "finite (prob_dom PROB)"
proof -
{
fix x
assume P2: "x \<in> PROB"
then have 1: "(\<lambda>(s1, s2). action_dom s1 s2) x = fmdom' (fst x) \<union> fmdom' (snd x)"
by (simp add: action_dom_def case_prod_beta')
then have 2: "finite (fset (fmdom (fst x)))" "finite (fset (fmdom (snd x)))"
by auto
then have 3: "fset (fmdom (fst x)) = fmdom' (fst x)" "fset (fmdom (snd x)) = fmdom' (snd x)"
by (auto simp add: fmdom'_alt_def)
then have "finite (fmdom' (fst x))"
using 2 by auto
then have "finite (fmdom' (snd x))"
using 2 3 by auto
then have "finite ((\<lambda>(s1, s2). action_dom s1 s2) x)"
using 1 2 3
by simp
}
then show "finite (prob_dom PROB)"
unfolding prob_dom_def
using assms
by blast
qed
lemma CARD_valid_states:
assumes "finite (PROB :: 'a problem)"
shows "(card (valid_states PROB :: 'a state set) = 2 ^ card (prob_dom PROB))"
proof -
have 1: "finite (prob_dom PROB)"
using assms FINITE_prob_dom
by blast
have"(card (valid_states PROB :: 'a state set)) = card {s :: 'a state. fmdom' s = prob_dom PROB}"
unfolding valid_states_def
by simp
also have "... = 2 ^ (card (prob_dom PROB))"
using 1 card_of_set_of_all_possible_states
by blast
finally show ?thesis
by blast
qed
\<comment> \<open>NOTE type of 'valid\_states PROB' has to be asserted to match 'FINITE\_states' in the proof.\<close>
lemma FINITE_valid_states:
fixes PROB :: "'a problem"
shows "finite PROB \<Longrightarrow> finite ((valid_states PROB) :: 'a state set)"
proof (induction PROB rule: finite.induct)
case emptyI
then have "valid_states {} = {fmempty}"
unfolding valid_states_def prob_dom_def
using empty_domain_fmap_set
by force
then show ?case
by(subst \<open>valid_states {} = {fmempty}\<close>) auto
next
case (insertI A a)
{
then have "finite (insert a A)"
by blast
then have "finite (prob_dom (insert a A))"
using FINITE_prob_dom
by blast
then have "finite {s :: 'a state. fmdom' s = prob_dom (insert a A)}"
using FINITE_states
by blast
}
then show ?case
unfolding valid_states_def
by simp
qed
\<comment> \<open>NOTE type of 'PROB' had to be fixed for use of 'FINITE\_valid\_states'.\<close>
lemma lemma_2:
fixes PROB :: "'a problem" and as :: "('a action) list" and s :: "'a state"
assumes "finite PROB" "s \<in> (valid_states PROB)" "(as \<in> valid_plans PROB)"
"((length as) > (2 ^ (card (fmdom' s)) - 1))"
shows "(\<exists>as1 as2 as3.
(as1 @ as2 @ as3 = as)
\<and> (exec_plan s (as1 @ as2) = exec_plan s as1)
\<and> \<not>(as2 = [])
)"
proof -
have "Suc (length as) > 2^(card (fmdom' s))"
using assms(4)
by linarith
then have 1: "card (state_set (state_list s as)) > 2^card (fmdom' s)"
using card_state_set[symmetric]
by metis
{
\<comment> \<open>NOTE type of 'valid\_states PROB' had to be asserted to match 'FINITE\_valid\_states'.\<close>
have 2: "finite (prob_dom PROB)" "finite ((valid_states PROB) :: 'a state set)"
using assms(1) FINITE_prob_dom FINITE_valid_states
by blast+
have 3: "fmdom' s = prob_dom PROB"
using assms(2) valid_states_def
by fast
then have "card ((valid_states PROB) :: 'a state set) = 2^card (fmdom' s)"
using assms(1) CARD_valid_states
by auto
then have 4: "card (state_set (state_list (s :: 'a state) as)) > card ((valid_states PROB) :: 'a state set)"
unfolding valid_states_def
using 1 2(1) 3 card_of_set_of_all_possible_states[of "prob_dom PROB"]
by argo
\<comment> \<open>TODO refactor into lemma.\<close>
{
let ?S="state_set (state_list (s :: 'a state) as)"
let ?T="valid_states PROB :: 'a state set"
assume C2: "inj_on last ?S"
\<comment> \<open>TODO unwrap the metis step or refactor into lemma.\<close>
have a: "?T \<subseteq> last ` ?S"
using C2
by (metis "2"(2) "4" assms(2) assms(3) card_image card_mono lemma_1 not_less)
have "finite (state_set (state_list s as))"
using state_set_finite
by auto
then have "card (last ` ?S) = card ?S"
using C2 inj_on_iff_eq_card
by blast
also have "\<dots> > card ?T"
using 4
by blast
then have "\<exists>x. x \<in> (last ` ?S) \<and> x \<notin> ?T"
using C2 a assms(2) assms(3) calculation lemma_1
by fastforce
}
note 5 = this
moreover
{
assume C: "inj last (state_set (state_list (s :: 'a state) as)) (valid_states PROB)"
then have "inj_on last (state_set (state_list (s :: 'a state) as))"
using C inj_def
by blast
then obtain x where "x \<in> last ` (state_set (state_list s as)) \<and> x \<notin> valid_states PROB"
using 5
by presburger
then have "\<not>(\<forall>x\<in>state_set (state_list s as). last x \<in> valid_states PROB)"
by blast
then have "\<not>inj last (state_set (state_list (s :: 'a state) as)) (valid_states PROB)"
using inj_def
by metis
then have False
using C
by simp
}
ultimately have "\<not>inj last (state_set (state_list (s :: 'a state) as)) (valid_states PROB)"
unfolding inj_def
by blast
}
then obtain slist_1 slist_2 where 6:
"slist_1 \<in> state_set (state_list s as)"
"slist_2 \<in> state_set (state_list s as)"
"(last slist_1 = last slist_2)"
"length slist_1 \<noteq> length slist_2"
using assms(2, 3) not_eq_last_diff_paths
by blast
then show ?thesis
proof (cases as)
case Nil
text \<open> 4th assumption is violated in the 'Nil' case. \<close>
then have "\<not>(2 ^ card (fmdom' s) - 1 < length as)"
using Nil
by simp
then show ?thesis
using assms(4)
by blast
next
case (Cons a list)
then have "as \<noteq> []"
by simp
moreover have "slist_1 \<noteq> []" "slist_2 \<noteq> []"
using 6(1, 2) NIL_NOTIN_stateset
by blast+
ultimately show ?thesis
using assms(2, 3) 6(1, 2, 3, 4) eq_last_state_imp_append_nempty_as
by fastforce
qed
qed
lemma lemma_2_prob_dom:
fixes PROB and as :: "('a action) list" and s :: "'a state"
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"(length as > (2 ^ (card (prob_dom PROB))) - 1)"
shows "(\<exists>as1 as2 as3.
(as1 @ as2 @ as3 = as)
\<and> (exec_plan s (as1 @ as2) = exec_plan s as1)
\<and> \<not>(as2 = [])
)"
proof -
have "prob_dom PROB = fmdom' s"
using assms(2) valid_states_def
by fast
then have "2 ^ card (fmdom' s) - 1 < length as"
using assms(4)
by argo
then show ?thesis
using assms(1, 2, 3) lemma_2
by blast
qed
\<comment> \<open>NOTE type for `s` had to be fixed (type mismatch in obtain statement).\<close>
\<comment> \<open>NOTE type for `as1`, `as2` and `as3` had to be fixed (due type mismatch on `as1` in
`cycle\_removal\_lemma`)\<close>
lemma lemma_3:
fixes PROB :: "'a problem" and s :: "'a state"
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"(length as > (2 ^ (card (prob_dom PROB)) - 1))"
shows "(\<exists>as'.
(exec_plan s as = exec_plan s as')
\<and> (length as' < length as)
\<and> (subseq as' as)
)"
proof -
have "prob_dom PROB = fmdom' s"
using assms(2) valid_states_def
by fast
then have "2 ^ card (fmdom' s) - 1 < length as"
using assms(4)
by argo
then obtain as1 as2 as3 :: "'a action list" where 1:
"as1 @ as2 @ as3 = as" "exec_plan s (as1 @ as2) = exec_plan s as1" "as2 \<noteq> []"
using assms(1, 2, 3) lemma_2
by metis
have 2: "exec_plan s (as1 @ as3) = exec_plan s (as1 @ as2 @ as3)"
using 1 cycle_removal_lemma
by fastforce
let ?as' = "as1 @ as3"
have "exec_plan s as = exec_plan s ?as'"
using 1 2
by auto
moreover have "length ?as' < length as"
using 1 nempty_list_append_length_add
by blast
moreover have "subseq ?as' as"
using 1 subseq_append'
by blast
ultimately show "(\<exists>as'.
(exec_plan s as = exec_plan s as') \<and> (length as' < length as) \<and> (subseq as' as))"
by blast
qed
\<comment> \<open>TODO unwrap meson step.\<close>
lemma sublist_valid_is_valid:
fixes as' as PROB
assumes "(as \<in> valid_plans PROB)" "(subseq as' as)"
shows "as' \<in> valid_plans PROB"
using assms
by (simp add: valid_plans_def) (meson dual_order.trans fset_of_list_subset sublist_subset)
\<comment> \<open>NOTE type of 's' had to be fixed (type mismatch in goal).\<close>
theorem main_lemma:
fixes PROB :: "'a problem" and as s
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "(\<exists>as'.
(exec_plan s as = exec_plan s as')
\<and> (subseq as' as)
\<and> (length as' \<le> (2 ^ (card (prob_dom PROB))) - 1)
)"
proof (cases "length as \<le> (2 ^ (card (prob_dom PROB))) - 1")
case True
then have "exec_plan s as = exec_plan s as"
by simp
then have "subseq as as"
by auto
then have "length as \<le> (2^(card (prob_dom PROB)) - 1)"
using True
by auto
then show ?thesis
by blast
next
case False
then have "length as > (2 ^ (card (prob_dom PROB))) - 1"
using False
by auto
then obtain as' where 1:
"exec_plan s as = exec_plan s as'" "length as' < length as" "subseq as' as"
using assms lemma_3
by blast
{
fix p
assume "exec_plan s as = exec_plan s p" "subseq p as"
"2 ^ card (prob_dom PROB) - 1 < length p"
then have "(\<exists>p'. (exec_plan s as = exec_plan s p' \<and> subseq p' as) \<and> length p' < length p)"
using assms(1, 2, 3) lemma_3 sublist_valid_is_valid
by fastforce
}
then have "\<forall>p. exec_plan s as = exec_plan s p \<and> subseq p as \<longrightarrow>
(\<exists>p'. (exec_plan s as = exec_plan s p' \<and> subseq p' as)
\<and> length p' \<le> 2 ^ card (prob_dom PROB) - 1)"
using general_theorem[where
P = "\<lambda>(as'' :: 'a action list). (exec_plan s as = exec_plan s as'') \<and> subseq as'' as"
and l = "(2 ^ (card (prob_dom (PROB ::'a problem)))) - 1" and f = length]
by blast
then obtain p' where
"exec_plan s as = exec_plan s p'" "subseq p' as" "length p' \<le> 2 ^ card (prob_dom PROB) - 1"
by blast
then show ?thesis
using sublist_refl
by blast
qed
subsection "Reachable States"
\<comment> \<open>NOTE shortened to 'reachable\_s'\<close>
definition reachable_s where
"reachable_s PROB s \<equiv> {exec_plan s as | as. as \<in> valid_plans PROB}"
\<comment> \<open>NOTE types for `s` and `PROB` had to be fixed (type mismatch in goal).\<close>
lemma valid_as_valid_exec:
fixes as and s :: "'a state" and PROB :: "'a problem"
assumes "(as \<in> valid_plans PROB)" "(s \<in> valid_states PROB)"
shows "(exec_plan s as \<in> valid_states PROB)"
using assms
proof (induction as arbitrary: s PROB)
case (Cons a as)
then have "a \<in> PROB"
using valid_plan_valid_head
by metis
then have "state_succ s a \<in> valid_states PROB"
using Cons.prems(2) valid_action_valid_succ
by blast
moreover have "as \<in> valid_plans PROB"
using Cons.prems(1) valid_plan_valid_tail
by fast
ultimately show ?case
using Cons.IH
by force
qed simp
lemma exec_plan_fdom_subset:
fixes as s PROB
assumes "(as \<in> valid_plans PROB)"
shows "(fmdom' (exec_plan s as) \<subseteq> (fmdom' s \<union> prob_dom PROB))"
using assms
proof (induction as arbitrary: s PROB)
case (Cons a as)
have "as \<in> valid_plans PROB"
using Cons.prems valid_plan_valid_tail
by fast
then have "fmdom' (exec_plan (state_succ s a) as) \<subseteq> fmdom' (state_succ s a) \<union> prob_dom PROB"
using Cons.IH[of _ "state_succ s a"]
by simp
\<comment> \<open>TODO unwrap metis proofs.\<close>
moreover have "fmdom' s \<union> fmdom' (snd a) \<union> prob_dom PROB = fmdom' s \<union> prob_dom PROB"
by (metis
Cons.prems FDOM_eff_subset_prob_dom_pair sup_absorb2 sup_assoc valid_plan_valid_head)
ultimately show ?case
by (metis (no_types, lifting)
FDOM_state_succ_subset exec_plan.simps(2) order_refl subset_trans sup.mono)
qed simp
\<comment> \<open>NOTE added lemma.\<close>
lemma reachable_s_finite_thm_1_a:
fixes s and PROB :: "'a problem"
assumes "(s :: 'a state) \<in> valid_states PROB"
shows "(\<forall>l\<in>reachable_s PROB s. l\<in>valid_states PROB)"
proof -
have 1: "\<forall>l\<in>reachable_s PROB s. \<exists>as. l = exec_plan s as \<and> as \<in> valid_plans PROB"
using reachable_s_def
by fastforce
{
fix l
assume P1: "l \<in> reachable_s PROB s"
\<comment> \<open>NOTE type for 's' and 'as' had to be fixed due to type mismatch in obtain statement.\<close>
then obtain as :: "'a action list" where a: "l = exec_plan s as \<and> as \<in> valid_plans PROB"
using 1
by blast
then have "exec_plan s as \<in> valid_states PROB"
using assms a valid_as_valid_exec
by blast
then have "l \<in> valid_states PROB"
using a
by simp
}
then show "\<forall>l \<in> reachable_s PROB s. l \<in> valid_states PROB"
by blast
qed
lemma reachable_s_finite_thm_1:
assumes "((s :: 'a state) \<in> valid_states PROB)"
shows "(reachable_s PROB s \<subseteq> valid_states PROB)"
using assms reachable_s_finite_thm_1_a
by blast
\<comment> \<open>NOTE second declaration skipped (this is declared twice in the source; see above)\<close>
\<comment> \<open>NOTE type for `s` had to be fixed (type mismatch in goal).\<close>
lemma reachable_s_finite_thm:
fixes s :: "'a state"
assumes "finite (PROB :: 'a problem)" "(s \<in> valid_states PROB)"
shows "finite (reachable_s PROB s)"
using assms
by (meson FINITE_valid_states reachable_s_finite_thm_1 rev_finite_subset)
lemma empty_plan_is_valid: "[] \<in> (valid_plans PROB)"
by (simp add: valid_plans_def)
lemma valid_head_and_tail_valid_plan:
assumes "(h \<in> PROB)" "(as \<in> valid_plans PROB)"
shows "((h # as) \<in> valid_plans PROB)"
using assms
by (auto simp: valid_plans_def)
\<comment> \<open>TODO refactor\<close>
\<comment> \<open>NOTE added lemma\<close>
lemma lemma_1_reachability_s_i:
fixes PROB s
assumes "s \<in> valid_states PROB"
shows "s \<in> reachable_s PROB s"
proof -
have "[] \<in> valid_plans PROB"
using empty_plan_is_valid
by blast
then show ?thesis
unfolding reachable_s_def
by force
qed
\<comment> \<open>NOTE types for 'PROB' and 's' had to be fixed (type mismatch in goal).\<close>
lemma lemma_1_reachability_s:
fixes PROB :: "'a problem" and s :: "'a state" and as
assumes "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "((last ` state_set (state_list s as)) \<subseteq> (reachable_s PROB s))"
using assms
proof(induction as arbitrary: PROB s)
case Nil
then have "(last ` state_set (state_list s [])) = {s}"
by force
then show ?case
unfolding reachable_s_def
using empty_plan_is_valid
by force
next
case cons: (Cons a as)
let ?S="last ` state_set (state_list s (a # as))"
{
let ?as="[]"
have "last [s] = exec_plan s ?as"
by simp
moreover have "?as \<in> valid_plans PROB"
using empty_plan_is_valid
by auto
ultimately have "\<exists>as. (last [s] = exec_plan s as) \<and> as \<in> valid_plans PROB"
by blast
}
note 1 = this
{
fix x
assume P: "x \<in> ?S"
then consider
(a) "x = last [s]"
| (b) "x \<in> last ` ((#) s ` state_set (state_list (state_succ s a) as))"
by auto
then have "x \<in> reachable_s PROB s"
proof (cases)
case a
then have "x = s"
by simp
then show ?thesis
using cons.prems(1) P lemma_1_reachability_s_i
by blast
next
case b
then obtain x'' where i:
"x'' \<in> state_set (state_list (state_succ s a) as)"
"x = last (s # x'')"
by blast
then show ?thesis
proof (cases "x''")
case Nil
then have "x = s"
using i
by fastforce
then show ?thesis
using cons.prems(1) lemma_1_reachability_s_i
by blast
next
case (Cons a' list)
then obtain x' where a:
"last (a' # list) = last x'" "x' \<in> state_set (state_list (state_succ s a) as)"
using i(1)
by blast
{
have "state_succ s a \<in> valid_states PROB"
using cons.prems(1, 2) valid_action_valid_succ valid_plan_valid_head
by metis
moreover have "as \<in> valid_plans PROB"
using cons.prems(2) valid_plan_valid_tail
by fast
ultimately have
"last ` state_set (state_list (state_succ s a) as) \<subseteq> reachable_s PROB (state_succ s a)"
using cons.IH[of "state_succ s a"]
by auto
then have "\<exists>as'.
last (a' # list) = exec_plan (state_succ s a) as' \<and> (as' \<in> (valid_plans PROB))"
unfolding state_set.simps state_list.simps reachable_s_def
using i(1) Cons
by blast
}
then obtain as' where b:
"last (a' # list) = exec_plan (state_succ s a) as'" "(as' \<in> (valid_plans PROB))"
by blast
then have "x = exec_plan (state_succ s a) as'"
using i(2) Cons a(1)
by auto
then show ?thesis unfolding reachable_s_def
using cons.prems(2) b(2)
by (metis (mono_tags, lifting) exec_plan.simps(2) mem_Collect_eq
valid_head_and_tail_valid_plan valid_plan_valid_head)
qed
qed
}
then show ?case
by blast
qed
\<comment> \<open>NOTE types for `PROB` and `s` had to be fixed for use of `lemma\_1\_reachability\_s`.\<close>
lemma not_eq_last_diff_paths_reachability_s:
fixes PROB :: "'a problem" and s :: "'a state" and as
assumes "s \<in> valid_states PROB" "as \<in> valid_plans PROB"
"\<not>(inj last (state_set (state_list s as)) (reachable_s PROB s))"
shows "(\<exists>slist_1 slist_2.
slist_1 \<in> state_set (state_list s as)
\<and> slist_2 \<in> state_set (state_list s as)
\<and> (last slist_1 = last slist_2)
\<and> \<not>(length slist_1 = length slist_2)
)"
proof -
{
fix x
assume P1: "x \<in> state_set (state_list s as)"
have a: "last ` state_set (state_list s as) \<subseteq> reachable_s PROB s"
using assms(1, 2) lemma_1_reachability_s
by fast
then have "\<forall>as PROB. s \<in> (valid_states PROB) \<and> as \<in> (valid_plans PROB) \<longrightarrow> (last ` (state_set (state_list s as)) \<subseteq> reachable_s PROB s)"
using lemma_1_reachability_s
by fast
then have "last x \<in> valid_states PROB"
using assms(1, 2) P1 lemma_1
by fast
then have "last x \<in> reachable_s PROB s"
using P1 a
by fast
}
note 1 = this
text \<open> Show the goal by disproving the contradiction. \<close>
{
assume C: "(\<forall>slist_1 slist_2. (slist_1 \<in> state_set (state_list s as)
\<and> slist_2 \<in> state_set (state_list s as)
\<and> (last slist_1 = last slist_2)) \<longrightarrow> (length slist_1 = length slist_2))"
moreover {
fix slist_1 slist_2
assume C1: "slist_1 \<in> state_set (state_list s as)" "slist_2 \<in> state_set (state_list s as)"
"(last slist_1 = last slist_2)"
moreover have i: "(length slist_1 = length slist_2)"
using C1 C
by blast
moreover have "slist_1 = slist_2"
using C1(1, 2) i neq_mems_state_set_neq_len
by auto
ultimately have "inj_on last (state_set (state_list s as))"
unfolding inj_on_def
using C neq_mems_state_set_neq_len
by blast
then have False
using 1 inj_def assms(3)
by blast
}
ultimately have False
by (metis empty_state_list_lemma nempty_sl_in_state_set)
}
then show ?thesis
by blast
qed
\<comment> \<open>NOTE added lemma ( translation of `PHP` in pred\_setScript.sml:3155).\<close>
lemma lemma_2_reachability_s_i:
fixes f :: "'a \<Rightarrow> 'b" and s t
assumes "finite t" "card t < card s"
shows "\<not>(inj f s t)"
proof -
{
assume C: "inj f s t"
then have 1: "(\<forall>x\<in>s. f x \<in> t)" "inj_on f s"
unfolding inj_def
by blast+
moreover {
have "f ` s \<subseteq> t"
using 1
by fast
then have "card (f ` s) \<le> card t"
using assms(1) card_mono
by auto
}
moreover have "card (f ` s) = card s"
using 1 card_image
by fast
ultimately have False
using assms(2)
by linarith
}
then show ?thesis
by blast
qed
lemma lemma_2_reachability_s:
fixes PROB :: "'a problem" and as s
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"(length as > card (reachable_s PROB s) - 1)"
shows "(\<exists>as1 as2 as3.
(as1 @ as2 @ as3 = as) \<and> (exec_plan s (as1 @ as2) = exec_plan s as1) \<and> \<not>(as2 = []))"
proof -
{
have "Suc (length as) > card (reachable_s PROB s)"
using assms(4)
by fastforce
then have "card (state_set (state_list s as)) > card (reachable_s PROB s)"
using card_state_set
by metis
}
note 1 = this
{
have "finite (reachable_s PROB s)"
using assms(1, 2) reachable_s_finite_thm
by blast
then have "\<not>(inj last (state_set (state_list s as)) (reachable_s PROB s))"
using assms(4) 1 lemma_2_reachability_s_i
by blast
}
note 2 = this
obtain slist_1 slist_2 where 3:
"slist_1 \<in> state_set (state_list s as)" "slist_2 \<in> state_set (state_list s as)"
"(last slist_1 = last slist_2)" "length slist_1 \<noteq> length slist_2"
using assms(2, 3) 2 not_eq_last_diff_paths_reachability_s
by blast
then show ?thesis using assms
proof(cases as)
case (Cons a list)
then show ?thesis
using assms(2, 3) 3 eq_last_state_imp_append_nempty_as state_set_thm list.distinct(1)
by metis
qed force
qed
lemma lemma_3_reachability_s:
fixes as and PROB :: "'a problem" and s
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
"(length as > (card (reachable_s PROB s) - 1))"
shows "(\<exists>as'.
(exec_plan s as = exec_plan s as')
\<and> (length as' < length as)
\<and> (subseq as' as)
)"
proof -
obtain as1 as2 as3 :: "'a action list" where 1:
"(as1 @ as2 @ as3 = as)" "(exec_plan s (as1 @ as2) = exec_plan s as1)" "~(as2=[])"
using assms lemma_2_reachability_s
by metis
then have "(exec_plan s (as1 @ as2) = exec_plan s as1)"
using 1
by blast
then have 2: "exec_plan s (as1 @ as3) = exec_plan s (as1 @ as2 @ as3)"
using 1 cycle_removal_lemma
by fastforce
let ?as' = "as1 @ as3"
have 3: "exec_plan s as = exec_plan s ?as'"
using 1 2
by argo
then have "as2 \<noteq> []"
using 1
by blast
then have 4: "length ?as' < length as"
using nempty_list_append_length_add 1
by blast
then have "subseq ?as' as"
using 1 subseq_append'
by blast
then show ?thesis
using 3 4
by blast
qed
\<comment> \<open>NOTE type for `as` had to be fixed (type mismatch in goal).\<close>
lemma main_lemma_reachability_s:
fixes PROB :: "'a problem" and as and s :: "'a state"
assumes "finite PROB" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "(\<exists>as'.
(exec_plan s as = exec_plan s as') \<and> subseq as' as
\<and> (length as' \<le> (card (reachable_s PROB s) - 1)))"
proof (cases "length as \<le> card (reachable_s PROB s) - 1")
case False
let ?as' = "as"
have "length as > card (reachable_s PROB s) - 1"
using False
by simp
{
fix p
assume P: "exec_plan s as = exec_plan s p" "subseq p as"
"card (reachable_s PROB s) - 1 < length p"
moreover have "p \<in> valid_plans PROB"
using assms(3) P(2) sublist_valid_is_valid
by blast
ultimately obtain as' where 1:
"exec_plan s p = exec_plan s as'" "length as' < length p" "subseq as' p"
using assms lemma_3_reachability_s
by blast
then have "exec_plan s as = exec_plan s as'"
using P
by presburger
moreover have "subseq as' as"
using P 1 sublist_trans
by blast
ultimately have "(\<exists>p'. (exec_plan s as = exec_plan s p' \<and> subseq p' as) \<and> length p' < length p)"
using 1
by blast
}
then have "\<forall>p.
exec_plan s as = exec_plan s p \<and> subseq p as
\<longrightarrow> (\<exists>p'.
(exec_plan s as = exec_plan s p' \<and> subseq p' as)
\<and> length p' \<le> card (reachable_s PROB s) - 1)"
using general_theorem[of "\<lambda>as''. (exec_plan s as = exec_plan s as'') \<and> subseq as'' as"
"(card (reachable_s (PROB :: 'a problem) (s :: 'a state)) - 1)" length]
by blast
then show ?thesis
by blast
qed blast
lemma reachable_s_non_empty: "\<not>(reachable_s PROB s = {})"
using empty_plan_is_valid reachable_s_def
by blast
lemma card_reachable_s_non_zero:
fixes s
assumes "finite (PROB :: 'a problem)" "(s \<in> valid_states PROB)"
shows "(0 < card (reachable_s PROB s))"
using assms
by (simp add: card_gt_0_iff reachable_s_finite_thm reachable_s_non_empty)
lemma exec_fdom_empty_prob:
fixes s
assumes "(prob_dom PROB = {})" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "(exec_plan s as = fmempty)"
proof -
have "fmdom' s = {}"
using assms(1, 2)
by (simp add: valid_states_def)
then show "exec_plan s as = fmempty"
using assms(1, 3)
by (metis
exec_plan_fdom_subset fmrestrict_set_dom fmrestrict_set_null subset_empty
sup_bot.left_neutral)
qed
\<comment> \<open>NOTE types for `PROB` and `s` had to be fixed (type mismatch in goal).\<close>
lemma reachable_s_empty_prob:
fixes PROB :: "'a problem" and s :: "'a state"
assumes "(prob_dom PROB = {})" "(s \<in> valid_states PROB)"
shows "((reachable_s PROB s) \<subseteq> {fmempty})"
proof -
{
fix x
assume P1: "x \<in> reachable_s PROB s"
then obtain as :: "'a action list" where a:
"as \<in> valid_plans PROB" "x = exec_plan s as"
using reachable_s_def
by blast
then have "as \<in> valid_plans PROB" "x = exec_plan s as"
using a
by auto
then have "x = fmempty" using assms(1, 2) exec_fdom_empty_prob
by blast
}
then show "((reachable_s PROB s) \<subseteq> {fmempty})"
by blast
qed
\<comment> \<open>NOTE this is semantically equivalent to `sublist\_valid\_is\_valid`.\<close>
\<comment> \<open>NOTE Renamed to 'sublist\_valid\_plan\_alt' because another lemma by the same name is declared
later.\<close>
lemma sublist_valid_plan__alt:
assumes "(as1 \<in> valid_plans PROB)" "(subseq as2 as1)"
shows "(as2 \<in> valid_plans PROB)"
using assms
by (auto simp add: sublist_valid_is_valid)
lemma fmsubset_eq:
assumes "s1 \<subseteq>\<^sub>f s2"
shows "(\<forall>a. a |\<in>| fmdom s1 \<longrightarrow> fmlookup s1 a = fmlookup s2 a)"
using assms
by (metis (mono_tags, lifting) domIff fmdom_notI fmsubset.rep_eq map_le_def)
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor/move into 'FmapUtils.thy'.\<close>
lemma submap_imp_state_succ_submap_a:
assumes "s1 \<subseteq>\<^sub>f s2" "s2 \<subseteq>\<^sub>f s3"
shows "s1 \<subseteq>\<^sub>f s3"
using assms fmsubset.rep_eq map_le_trans
by blast
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor into FmapUtils?\<close>
lemma submap_imp_state_succ_submap_b:
assumes "s1 \<subseteq>\<^sub>f s2"
shows "(s0 ++ s1) \<subseteq>\<^sub>f (s0 ++ s2)"
proof -
{
assume C: "\<not>((s0 ++ s1) \<subseteq>\<^sub>f (s0 ++ s2))"
then have 1: "(s0 ++ s1) = (s1 ++\<^sub>f s0)"
using fmap_add_ltr_def
by blast
then have 2: "(s0 ++ s2) = (s2 ++\<^sub>f s0)"
using fmap_add_ltr_def
by auto
then obtain a where 3:
"a |\<in>| fmdom (s1 ++\<^sub>f s0) \<and> fmlookup (s1 ++\<^sub>f s0) \<noteq> fmlookup (s2 ++\<^sub>f s0)"
using C 1 2 fmsubset.rep_eq domIff fmdom_notD map_le_def
by (metis (no_types, lifting))
then have False
using assms(1) C proof (cases "a |\<in>| fmdom s1")
case True
moreover have "fmlookup s1 a = fmlookup s2 a"
by (meson assms(1) calculation fmsubset_eq)
moreover have "fmlookup (s0 ++\<^sub>f s1) a = fmlookup s1 a"
by (simp add: True)
moreover have "a |\<in>| fmdom s2"
using True calculation(2) fmdom_notD by fastforce
moreover have "fmlookup (s0 ++\<^sub>f s2) a = fmlookup s2 a"
by (simp add: calculation(4))
moreover have "fmlookup (s0 ++\<^sub>f s1) a = fmlookup (s0 ++\<^sub>f s2) a"
using calculation(2, 3, 5)
by auto
ultimately show ?thesis
by (smt "1" "2" C assms domIff fmlookup_add fmsubset.rep_eq map_le_def)
next
case False
moreover have "fmlookup (s0 ++\<^sub>f s1) a = fmlookup s0 a"
by (auto simp add: False)
ultimately show ?thesis proof (cases "a |\<in>| fmdom s0")
case True
have "a |\<notin>| fmdom (s1 ++\<^sub>f s0)"
by (smt "1" "2" C UnE assms dom_map_add fmadd.rep_eq fmsubset.rep_eq map_add_def
map_add_dom_app_simps(1) map_le_def)
then show ?thesis
using 3 by blast
next
case False
then have "a |\<notin>| fmdom (s1 ++\<^sub>f s0)"
using \<open>fmlookup (s0 ++\<^sub>f s1) a = fmlookup s0 a\<close>
by force
then show ?thesis
using 3
by blast
qed
qed
}
then show ?thesis
by blast
qed
\<comment> \<open>NOTE type for `a` had to be fixed (type mismatch in goal).\<close>
lemma submap_imp_state_succ_submap:
fixes a :: "'a action" and s1 s2
assumes "(fst a \<subseteq>\<^sub>f s1)" "(s1 \<subseteq>\<^sub>f s2)"
shows "(state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a)"
proof -
have 1: "state_succ s1 a = (snd a ++ s1)"
using assms(1)
by (simp add: state_succ_def)
then have "fst a \<subseteq>\<^sub>f s2"
using assms(1, 2) submap_imp_state_succ_submap_a
by auto
then have 2: "state_succ s2 a = (snd a ++ s2)"
using 1 state_succ_def
by metis
then have "snd a ++ s1 \<subseteq>\<^sub>f snd a ++ s2"
using assms(2) submap_imp_state_succ_submap_b
by fast
then show ?thesis
using 1 2
by argo
qed
\<comment> \<open>NOTE types for `a`, `s1` and `s2` had to be fixed (type mismatch in goal).\<close>
lemma pred_dom_subset_succ_submap:
fixes a :: "'a action" and s1 s2 :: "'a state"
assumes "(fmdom' (fst a) \<subseteq> fmdom' s1)" "(s1 \<subseteq>\<^sub>f s2)"
shows "(state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a)"
using assms
unfolding state_succ_def
proof (auto)
assume P1: "fmdom' (fst a) \<subseteq> fmdom' s1" "s1 \<subseteq>\<^sub>f s2" "fst a \<subseteq>\<^sub>f s1" "fst a \<subseteq>\<^sub>f s2"
then show "snd a ++ s1 \<subseteq>\<^sub>f snd a ++ s2"
using submap_imp_state_succ_submap_b
by fast
next
assume P2: "fmdom' (fst a) \<subseteq> fmdom' s1" "s1 \<subseteq>\<^sub>f s2" "fst a \<subseteq>\<^sub>f s1" "\<not> fst a \<subseteq>\<^sub>f s2"
then show "snd a ++ s1 \<subseteq>\<^sub>f s2"
using submap_imp_state_succ_submap_a
by blast
next
assume P3: "fmdom' (fst a) \<subseteq> fmdom' s1" "s1 \<subseteq>\<^sub>f s2" "\<not> fst a \<subseteq>\<^sub>f s1" "fst a \<subseteq>\<^sub>f s2"
{
have a: "fmlookup s1 \<subseteq>\<^sub>m fmlookup s2"
using P3(2) fmsubset.rep_eq
by blast
{
have "\<not>(fmlookup (fst a) \<subseteq>\<^sub>m fmlookup s1)"
using P3(3) fmsubset.rep_eq
by blast
then have "\<exists>v \<in> dom (fmlookup (fst a)). fmlookup (fst a) v \<noteq> fmlookup s1 v"
using map_le_def
by fast
}
then obtain v where b: "v \<in> dom (fmlookup (fst a))" "fmlookup (fst a) v \<noteq> fmlookup s1 v"
by blast
then have "fmlookup (fst a) v \<noteq> fmlookup s2 v"
using assms(1) a contra_subsetD fmdom'.rep_eq map_le_def
by metis
then have "\<not>(fst a \<subseteq>\<^sub>f s2)"
using b fmsubset.rep_eq map_le_def
by metis
}
then show "s1 \<subseteq>\<^sub>f snd a ++ s2"
using P3(4)
by simp
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma valid_as_submap_init_submap_exec_i:
fixes s a
shows "fmdom' s \<subseteq> fmdom' (state_succ s a)"
proof (cases "fst a \<subseteq>\<^sub>f s")
case True
then have "state_succ s a = s ++\<^sub>f (snd a)"
unfolding state_succ_def
using fmap_add_ltr_def
by auto
then have "fmdom' (state_succ s a) = fmdom' s \<union> fmdom' (snd a)"
using fmdom'_add
by simp
then show ?thesis
by simp
next
case False
then show ?thesis
unfolding state_succ_def
by simp
qed
\<comment> \<open>NOTE types for `s1` and `s2` had to be fixed in order to apply `pred\_dom\_subset\_succ\_submap`.\<close>
lemma valid_as_submap_init_submap_exec:
fixes s1 s2 :: "'a state"
assumes "(s1 \<subseteq>\<^sub>f s2) " "(\<forall>a. ListMem a as \<longrightarrow> (fmdom' (fst a) \<subseteq> fmdom' s1))"
shows "(exec_plan s1 as \<subseteq>\<^sub>f exec_plan s2 as)"
using assms
proof (induction as arbitrary: s1 s2)
case (Cons a as)
{
have "ListMem a (a # as)"
using elem
by fast
then have "fmdom' (fst a) \<subseteq> fmdom' s1"
using Cons.prems(2)
by blast
then have "state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a"
using Cons.prems(1) pred_dom_subset_succ_submap
by fast
}
note 1 = this
{
fix b
assume "ListMem b as"
then have "ListMem b (a # as)"
using insert
by fast
then have a: "fmdom' (fst b) \<subseteq> fmdom' s1"
using Cons.prems(2)
by blast
then have "fmdom' s1 \<subseteq> fmdom' (state_succ s1 a)"
using valid_as_submap_init_submap_exec_i
by metis
then have "fmdom' (fst b) \<subseteq> fmdom' (state_succ s1 a)"
using a
by simp
}
then show ?case
using 1 Cons.IH[of "(state_succ s1 a)" "(state_succ s2 a)"]
by fastforce
qed auto
lemma valid_plan_mems:
assumes "(as \<in> valid_plans PROB)" "(ListMem a as)"
shows "a \<in> PROB"
using assms ListMem_iff in_set_conv_decomp valid_append_valid_suff valid_plan_valid_head
by (metis)
\<comment> \<open>NOTE typing moved into 'fixes' due to type mismatches when using lemma.\<close>
\<comment> \<open>NOTE showcase (this can't be used due to type problems when the type is specified within
proposition.\<close>
lemma valid_states_nempty:
fixes PROB :: "(('a, 'b) fmap \<times> ('a, 'b) fmap) set"
assumes "finite PROB"
shows "\<exists>s. s \<in> (valid_states PROB)"
unfolding valid_states_def
using fmchoice'[OF FINITE_prob_dom[OF assms], where Q = "\<lambda>_ _. True"]
by auto
lemma empty_prob_dom_single_val_state:
assumes "(prob_dom PROB = {})"
shows "(\<exists>s. valid_states PROB = {s})"
proof -
{
assume C: "\<not>(\<exists>s. valid_states PROB = {s})"
then have "valid_states PROB = {s. fmdom' s = {}}"
using assms
by (simp add: valid_states_def)
then have "\<exists>s. valid_states PROB = {s}"
using empty_domain_fmap_set
by blast
then have False
using C
by blast
}
then show ?thesis
by blast
qed
lemma empty_prob_dom_imp_empty_plan_always_good:
fixes PROB s
assumes "(prob_dom PROB = {})" "(s \<in> valid_states PROB)" "(as \<in> valid_plans PROB)"
shows "(exec_plan s [] = exec_plan s as)"
using assms empty_plan_is_valid exec_fdom_empty_prob
by fastforce
lemma empty_prob_dom:
fixes PROB
assumes "(prob_dom PROB = {})"
shows "(PROB = {(fmempty, fmempty)} \<or> PROB = {})"
using assms
proof (cases "PROB = {}")
case False
have "\<Union>((\<lambda>(s1, s2). fmdom' s1 \<union> fmdom' s2) ` PROB) = {}"
using assms
by (simp add: prob_dom_def action_dom_def)
then have 1:"\<forall>a\<in>PROB. (\<lambda>(s1, s2). fmdom' s1 \<union> fmdom' s2) a = {}"
using Union_empty_conv
by auto
{
fix a
assume P1: "a\<in>PROB"
then have "(\<lambda>(s1, s2). fmdom' s1 \<union> fmdom' s2) a = {}"
using 1
by simp
then have a: "fmdom' (fst a) = {}" "fmdom' (snd a) = {}"
by auto+
then have b: "fst a = fmempty"
using fmrestrict_set_dom fmrestrict_set_null
by metis
then have "snd a = fmempty"
using a(2) fmrestrict_set_dom fmrestrict_set_null
by metis
then have "a = (fmempty, fmempty)"
using b surjective_pairing
by metis
}
then have "PROB = {(fmempty, fmempty)}"
using False
by blast
then show ?thesis
by blast
qed simp
lemma empty_prob_dom_finite:
fixes PROB :: "'a problem"
assumes "prob_dom PROB = {}"
shows "finite PROB"
proof -
consider (i) "PROB = {(fmempty, fmempty)}" | (ii) "PROB = {}"
using assms empty_prob_dom
by auto
then show ?thesis by (cases) auto
qed
\<comment> \<open>NOTE type for `a` had to be fixed (type mismatch in goal).\<close>
lemma disj_imp_eq_proj_exec:
fixes a :: "('a, 'b) fmap \<times> ('a, 'b) fmap" and vs s
assumes "(fmdom' (snd a) \<inter> vs) = {}"
shows "(fmrestrict_set vs s = fmrestrict_set vs (state_succ s a))"
proof -
have "disjnt (fmdom' (snd a)) vs"
using assms disjnt_def
by fast
then show ?thesis
using disj_dom_drest_fupdate_eq state_succ_pair surjective_pairing
by metis
qed
lemma no_change_vs_eff_submap:
fixes a vs s
assumes "(fmrestrict_set vs s = fmrestrict_set vs (state_succ s a))" "(fst a \<subseteq>\<^sub>f s)"
shows "(fmrestrict_set vs (snd a) \<subseteq>\<^sub>f (fmrestrict_set vs s))"
proof -
{
fix x
assume P3: "x \<in> dom (fmlookup (fmrestrict_set vs (snd a)))"
then have "(fmlookup (fmrestrict_set vs (snd a))) x = (fmlookup (fmrestrict_set vs s)) x"
proof (cases "fmlookup (fmrestrict_set vs (snd a)) x")
case None
then show ?thesis using P3 by blast
next
case (Some y)
then have "fmrestrict_set vs s = fmrestrict_set vs (s ++\<^sub>f snd a)"
using assms
by (simp add: state_succ_def fmap_add_ltr_def)
then have "fmlookup (fmrestrict_set vs s) = fmlookup (fmrestrict_set vs (s ++\<^sub>f snd a))"
by auto
then have 1: "
fmlookup (fmrestrict_set vs s) x
= (if x \<in> vs then fmlookup (s ++\<^sub>f snd a) x else None)
"
using fmlookup_restrict_set
by metis
then show ?thesis
proof (cases "x \<in> vs")
case True
then have "fmlookup (fmrestrict_set vs s) x = fmlookup (s ++\<^sub>f snd a) x"
using True 1
by auto
then show ?thesis
using Some fmadd.rep_eq fmlookup_restrict_set map_add_Some_iff
by (metis (mono_tags, lifting))
next
case False
then have 1: "fmlookup (fmrestrict_set vs s) x = None"
using False "1"
by auto
then show ?thesis
using 1 False
by auto
qed
qed
}
then have "(fmlookup (fmrestrict_set vs (snd a)) \<subseteq>\<^sub>m fmlookup (fmrestrict_set vs s))"
using map_le_def
by blast
then show ?thesis
using fmsubset.rep_eq
by blast
qed
\<comment> \<open>NOTE type of `a` had to be fixed.\<close>
lemma sat_precond_as_proj_3:
fixes s and a :: "('a, 'b) fmap \<times> ('a, 'b) fmap" and vs
assumes "(fmdom' (fmrestrict_set vs (snd a)) = {})"
shows "((fmrestrict_set vs (state_succ s a)) = (fmrestrict_set vs s))"
proof -
have "fmdom' (fmrestrict_set vs (fmrestrict_set vs (snd a))) = {}"
using assms fmrestrict_set_dom fmrestrict_set_empty fmrestrict_set_null
by metis
{
fix x
assume C: "x \<in> fmdom' (snd a) \<and> x \<in> vs"
then have a: "x \<in> fmdom' (snd a)" "x \<in> vs"
using C
by blast+
then have "fmlookup (snd a) x \<noteq> None"
using fmdom'_notI
by metis
then have "fmlookup (fmrestrict_set vs (snd a)) x \<noteq> None"
using a(2)
by force
then have "x \<in> fmdom' (fmrestrict_set vs (snd a))"
using fmdom'_notD
by metis
then have "fmdom' (fmrestrict_set vs (snd a)) \<noteq> {}"
by blast
then have False
using assms
by blast
}
then have "\<forall>x. \<not>(x \<in> fmdom' (snd a) \<and> x \<in> vs)"
by blast
then have 1: "fmdom' (snd a) \<inter> vs = {}"
by blast
have "disjnt (fmdom' (snd a)) vs"
using 1 disjnt_def
by blast
then show ?thesis
using 1 disj_imp_eq_proj_exec
by metis
qed
\<comment> \<open>NOTE type for `a` had to be fixed (type mismatch in goal).\<close>
\<comment> \<open>TODO showcase (quick win with simp).\<close>
lemma proj_eq_proj_exec_eq:
fixes s s' vs and a :: "('a, 'b) fmap \<times> ('a, 'b) fmap" and a'
assumes "((fmrestrict_set vs s) = (fmrestrict_set vs s'))" "((fst a \<subseteq>\<^sub>f s) = (fst a' \<subseteq>\<^sub>f s'))"
"(fmrestrict_set vs (snd a) = fmrestrict_set vs (snd a'))"
shows "(fmrestrict_set vs (state_succ s a) = fmrestrict_set vs (state_succ s' a'))"
using assms
by (simp add: fmap_add_ltr_def state_succ_def)
lemma empty_eff_exec_eq:
fixes s a
assumes "(fmdom' (snd a) = {})"
shows "(state_succ s a = s)"
using assms
unfolding state_succ_def fmap_add_ltr_def
by (metis fmadd_empty(2) fmrestrict_set_dom fmrestrict_set_null)
lemma exec_as_proj_valid_2:
fixes a
assumes "a \<in> PROB"
shows "(action_dom (fst a) (snd a) \<subseteq> prob_dom PROB)"
using assms
by (simp add: FDOM_eff_subset_prob_dom_pair FDOM_pre_subset_prob_dom_pair action_dom_def)
lemma valid_filter_valid_as:
assumes "(as \<in> valid_plans PROB)"
shows "(filter P as \<in> valid_plans PROB)"
using assms
by(auto simp: valid_plans_def)
lemma sublist_valid_plan:
assumes "(subseq as' as)" "(as \<in> valid_plans PROB)"
shows "(as' \<in> valid_plans PROB)"
using assms
by (auto simp: valid_plans_def) (meson fset_mp fset_of_list_elem sublist_subset subsetCE)
lemma prob_subset_dom_subset:
assumes "PROB1 \<subseteq> PROB2"
shows "(prob_dom PROB1 \<subseteq> prob_dom PROB2)"
using assms
by (auto simp add: prob_dom_def)
lemma state_succ_valid_act_disjoint:
assumes "(a \<in> PROB)" "(vs \<inter> (prob_dom PROB) = {})"
shows "(fmrestrict_set vs (state_succ s a) = fmrestrict_set vs s)"
using assms
by (smt
FDOM_eff_subset_prob_dom_pair disj_imp_eq_proj_exec inf.absorb1
inf_bot_right inf_commute inf_left_commute
)
lemma exec_valid_as_disjoint:
fixes s
assumes "(vs \<inter> (prob_dom PROB) = {})" "(as \<in> valid_plans PROB)"
shows "(fmrestrict_set vs (exec_plan s as) = fmrestrict_set vs s)"
using assms
proof (induction as arbitrary: s vs PROB)
case (Cons a as)
then show ?case
by (metis exec_plan.simps(2) state_succ_valid_act_disjoint valid_plan_valid_head
valid_plan_valid_tail)
qed simp
definition state_successors where
"state_successors PROB s \<equiv> ((state_succ s ` PROB) - {s})"
subsection "State Spaces"
definition stateSpace where
"stateSpace ss vs \<equiv> (\<forall>s. s \<in> ss \<longrightarrow> (fmdom' s = vs))"
lemma EQ_SS_DOM:
assumes "\<not>(ss = {})" "(stateSpace ss vs1)" "(stateSpace ss vs2)"
shows "(vs1 = vs2)"
using assms
by (auto simp: stateSpace_def)
\<comment> \<open>NOTE Name 'dom' changed to 'domain' because of name clash with 'Map.dom'.\<close>
lemma FINITE_SS:
fixes ss :: "('a, bool) fmap set"
assumes "\<not>(ss = {})" "(stateSpace ss domain)"
shows "finite ss"
proof -
have 1: "stateSpace ss domain = (\<forall>s. s \<in> ss \<longrightarrow> (fmdom' s = domain))"
by (simp add: stateSpace_def)
{
fix s
assume P1: "s \<in> ss"
have "fmdom' s = domain"
using assms 1 P1
by blast
then have "s \<in> {s. fmdom' s = domain}"
by auto
}
then have 2: "ss \<subseteq> {s. fmdom' s = domain}"
by blast
\<comment> \<open>TODO add lemma (finite (fmdom' s))\<close>
then have "finite domain"
using 1 assms
by fastforce
then have "finite {s :: 'a state. fmdom' s = domain}"
using FINITE_states
by blast
then show ?thesis
using 2 finite_subset
by auto
qed
lemma disjoint_effects_no_effects:
fixes s
assumes "(\<forall>a. ListMem a as \<longrightarrow> (fmdom' (fmrestrict_set vs (snd a)) = {}))"
shows "(fmrestrict_set vs (exec_plan s as) = (fmrestrict_set vs s))"
using assms
proof (induction as arbitrary: s vs)
case (Cons a as)
then have "ListMem a (a # as)"
using elem
by fast
then have "fmdom' (fmrestrict_set vs (snd a)) = {}"
using Cons.prems(1)
by blast
then have "fmrestrict_set vs (state_succ s a) = fmrestrict_set vs s"
using sat_precond_as_proj_3
by blast
then show ?case
by (simp add: Cons.IH Cons.prems insert)
qed auto
subsection "Needed Asses"
\<comment> \<open>NOTE name shortened.\<close>
definition action_needed_vars where
"action_needed_vars a s \<equiv> {v. (v \<in> fmdom' s) \<and> (v \<in> fmdom' (fst a))
\<and> (fmlookup (fst a) v = fmlookup s v)}"
\<comment> \<open>NOTE name shortened to 'action\_needed\_asses'.\<close>
definition action_needed_asses where
"action_needed_asses a s \<equiv> fmrestrict_set (action_needed_vars a s) s"
\<comment> \<open>NOTE type for 'a' had to be fixed (type mismatch in goal).\<close>
lemma act_needed_asses_submap_succ_submap:
fixes a s1 s2
assumes "(action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1)" "(s1 \<subseteq>\<^sub>f s2)"
shows "(state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a)"
using assms
unfolding state_succ_def
proof (auto)
assume P1: "action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1" "s1 \<subseteq>\<^sub>f s2" "fst a \<subseteq>\<^sub>f s1"
"fst a \<subseteq>\<^sub>f s2"
then show "snd a ++ s1 \<subseteq>\<^sub>f snd a ++ s2"
using submap_imp_state_succ_submap_b
by blast
next
assume P2: "action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1" "s1 \<subseteq>\<^sub>f s2" "fst a \<subseteq>\<^sub>f s1"
"\<not> fst a \<subseteq>\<^sub>f s2"
then show "snd a ++ s1 \<subseteq>\<^sub>f s2"
using submap_imp_state_succ_submap_a
by blast
next
assume P3: "action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1" "s1 \<subseteq>\<^sub>f s2" "\<not> fst a \<subseteq>\<^sub>f s1"
"fst a \<subseteq>\<^sub>f s2"
let ?vs1="{v \<in> fmdom' s1. v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup s1 v}"
let ?vs2="{v \<in> fmdom' s2. v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup s2 v}"
let ?f="fmrestrict_set ?vs1 s1"
let ?g="fmrestrict_set ?vs2 s2"
have 1: "fmdom' ?f = ?vs1" "fmdom' ?g = ?vs2"
unfolding action_needed_asses_def action_needed_vars_def fmdom'_restrict_set_precise
by blast+
have 2: "fmlookup ?g \<subseteq>\<^sub>m fmlookup ?f"
using P3(1)
unfolding action_needed_asses_def action_needed_vars_def
using fmsubset.rep_eq
by blast
{
{
fix v
assume P3_1: "v \<in> fmdom' ?g"
then have "v \<in> fmdom' s2" "v \<in> fmdom' (fst a)" "fmlookup (fst a) v = fmlookup s2 v"
using 1
by simp+
then have "fmlookup (fst a) v = fmlookup ?g v"
by simp
then have "fmlookup (fst a) v = fmlookup ?f v"
using 2
by (metis (mono_tags, lifting) P3_1 domIff fmdom'_notI map_le_def)
}
then have i: "fmlookup (fst a) \<subseteq>\<^sub>m fmlookup ?f"
using P3(4) 1(2)
by (smt domIff fmdom'_notD fmsubset.rep_eq map_le_def mem_Collect_eq)
{
fix v
assume P3_2: "v \<in> dom (fmlookup (fst a))"
then have "fmlookup (fst a) v = fmlookup ?f v"
using i
by (meson domIff fmdom'_notI map_le_def)
then have "v \<in> ?vs1"
using P3_2 1(1)
by (metis (no_types, lifting) domIff fmdom'_notD)
then have "fmlookup (fst a) v = fmlookup s1 v"
by blast
}
then have "fst a \<subseteq>\<^sub>f s1"
by (simp add: map_le_def fmsubset.rep_eq)
}
then show "s1 \<subseteq>\<^sub>f snd a ++ s2"
using P3(3)
by simp
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_i:
fixes a s
assumes "v \<in> fmdom' (action_needed_asses a s)"
shows "
fmlookup (action_needed_asses a s) v = fmlookup s v
\<and> fmlookup (action_needed_asses a s) v = fmlookup (fst a) v"
using assms
unfolding action_needed_asses_def action_needed_vars_def
using fmdom'_notI fmlookup_restrict_set
by (smt mem_Collect_eq)
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_ii:
fixes f g v
assumes "v \<in> fmdom' f" "f \<subseteq>\<^sub>f g"
shows "fmlookup f v = fmlookup g v"
using assms
by (meson fmdom'_notI fmdom_notD fmsubset_eq)
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_iii:
fixes f g v
shows "
fmdom' (action_needed_asses a s)
= {v \<in> fmdom' s. v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup s v}"
unfolding action_needed_asses_def action_needed_vars_def
by (simp add: Set.filter_def fmfilter_alt_defs(4))
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_iv:
fixes f a v
assumes "v \<in> fmdom' (action_needed_asses a s)"
shows "
fmlookup (action_needed_asses a s) v = fmlookup s v
\<and> fmlookup (action_needed_asses a s) v = fmlookup (fst a) v
\<and> fmlookup (fst a) v = fmlookup s v"
using assms
proof -
have 1: "v \<in> {v \<in> fmdom' s. v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup s v}"
using assms as_needed_asses_submap_exec_iii
by metis
then have 2: "fmlookup (action_needed_asses a s) v = fmlookup s v"
unfolding action_needed_asses_def action_needed_vars_def
by force
moreover have 3: "fmlookup (action_needed_asses a s) v = fmlookup (fst a) v"
using 1 2
by simp
moreover have "fmlookup (fst a) v = fmlookup s v"
using 2 3
by argo
ultimately show ?thesis
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor (into Fmap\_Utils.thy).\<close>
lemma as_needed_asses_submap_exec_v:
fixes f g v
assumes "v \<in> fmdom' f" "f \<subseteq>\<^sub>f g"
shows "v \<in> fmdom' g"
proof -
obtain b where 1: "fmlookup f v = b" "b \<noteq> None"
using assms(1)
by (meson fmdom'_notI)
then have "fmlookup g v = b"
using as_needed_asses_submap_exec_ii[OF assms]
by argo
then show ?thesis
using 1 fmdom'_notD
by fastforce
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_vi:
fixes a s1 s2 v
assumes "v \<in> fmdom' (action_needed_asses a s1)"
"(action_needed_asses a s1) \<subseteq>\<^sub>f (action_needed_asses a s2)"
shows
"(fmlookup (action_needed_asses a s1) v) = fmlookup (fst a) v
\<and> (fmlookup (action_needed_asses a s2) v) = fmlookup (fst a) v \<and>
fmlookup s1 v = fmlookup (fst a) v \<and> fmlookup s2 v = fmlookup (fst a) v"
using assms
proof -
have 1:
"fmlookup (action_needed_asses a s1) v = fmlookup s1 v"
"fmlookup (action_needed_asses a s1) v = fmlookup (fst a) v"
"fmlookup (fst a) v = fmlookup s1 v"
using as_needed_asses_submap_exec_iv[OF assms(1)]
by blast+
moreover {
have "fmlookup (action_needed_asses a s1) v = fmlookup (action_needed_asses a s2) v"
using as_needed_asses_submap_exec_ii[OF assms]
by simp
then have "fmlookup (action_needed_asses a s2) v = fmlookup (fst a) v"
using 1(2)
by argo
}
note 2 = this
moreover {
have "v \<in> fmdom' (action_needed_asses a s2)"
using as_needed_asses_submap_exec_v[OF assms]
by simp
then have "fmlookup s2 v = fmlookup (action_needed_asses a s2) v"
using as_needed_asses_submap_exec_i
by metis
also have "\<dots> = fmlookup (fst a) v"
using 2
by simp
finally have "fmlookup s2 v = fmlookup (fst a) v"
by simp
}
ultimately show ?thesis
by argo
qed
\<comment> \<open>TODO refactor.\<close>
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_vii:
fixes f g v
assumes "\<forall>v \<in> fmdom' f. fmlookup f v = fmlookup g v"
shows "f \<subseteq>\<^sub>f g"
proof -
{
fix v
assume a: "v \<in> fmdom' f"
then have "v \<in> dom (fmlookup f)"
by simp
moreover have "fmlookup f v = fmlookup g v"
using assms a
by blast
ultimately have "v \<in> dom (fmlookup f) \<longrightarrow> fmlookup f v = fmlookup g v"
by blast
}
then have "fmlookup f \<subseteq>\<^sub>m fmlookup g"
by (simp add: map_le_def)
then show ?thesis
by (simp add: fmsubset.rep_eq)
qed
\<comment> \<open>TODO refactor.\<close>
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_viii:
fixes f g v
assumes "f \<subseteq>\<^sub>f g"
shows "\<forall>v \<in> fmdom' f. fmlookup f v = fmlookup g v"
proof -
have 1: "fmlookup f \<subseteq>\<^sub>m fmlookup g"
using assms
by (simp add: fmsubset.rep_eq)
{
fix v
assume "v \<in> fmdom' f"
then have "v \<in> dom (fmlookup f)"
by simp
then have "fmlookup f v = fmlookup g v"
using 1 map_le_def
by metis
}
then show ?thesis
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_viii':
fixes f g v
assumes "f \<subseteq>\<^sub>f g"
shows "fmdom' f \<subseteq> fmdom' g"
using assms as_needed_asses_submap_exec_v subsetI
by metis
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_ix:
fixes f g
shows "f \<subseteq>\<^sub>f g = (\<forall>v \<in> fmdom' f. fmlookup f v = fmlookup g v)"
using as_needed_asses_submap_exec_vii as_needed_asses_submap_exec_viii
by metis
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_x:
fixes f a v
assumes "v \<in> fmdom' (action_needed_asses a f)"
shows "v \<in> fmdom' (fst a) \<and> v \<in> fmdom' f \<and> fmlookup (fst a) v = fmlookup f v"
using assms
unfolding action_needed_asses_def action_needed_vars_def
using as_needed_asses_submap_exec_i assms
by (metis fmdom'_notD fmdom'_notI)
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor.\<close>
lemma as_needed_asses_submap_exec_xi:
fixes v a f g
assumes "v \<in> fmdom' (action_needed_asses a (f ++ g))" "v \<in> fmdom' f"
shows "
fmlookup (action_needed_asses a (f ++ g)) v = fmlookup f v
\<and> fmlookup (action_needed_asses a (f ++ g)) v = fmlookup (fst a) v"
proof -
have 1: "v \<in> {v \<in> fmdom' (f ++ g). v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup (f ++ g) v}"
using as_needed_asses_submap_exec_x[OF assms(1)]
by blast
{
have "v |\<in>| fmdom f"
using assms(2)
by (meson fmdom'_notI fmdom_notD)
then have "fmlookup (f ++ g) v = fmlookup f v"
unfolding fmap_add_ltr_def fmlookup_add
by simp
}
note 2 = this
{
have "fmlookup (action_needed_asses a (f ++ g)) v = fmlookup (f ++ g) v"
unfolding action_needed_asses_def action_needed_vars_def
using 1
by force
then have "fmlookup (action_needed_asses a (f ++ g)) v = fmlookup f v"
using 2
by simp
}
note 3 = this
moreover {
have "fmlookup (fst a) v = fmlookup (f ++ g) v"
using 1
by simp
also have "\<dots> = fmlookup f v"
using 2
by simp
also have "\<dots> = fmlookup (action_needed_asses a (f ++ g)) v"
using 3
by simp
finally have "fmlookup (action_needed_asses a (f ++ g)) v = fmlookup (fst a) v"
by simp
}
ultimately show ?thesis
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor (into Fmap\_Utils.thy).\<close>
lemma as_needed_asses_submap_exec_xii:
fixes f g v
assumes "v \<in> fmdom' f"
shows "fmlookup (f ++ g) v = fmlookup f v"
proof -
have "v |\<in>| fmdom f"
using assms(1) fmdom'_notI fmdom_notD
by metis
then show ?thesis
unfolding fmap_add_ltr_def
using fmlookup_add
by force
qed
\<comment> \<open>NOTE added lemma.\<close>
lemma as_needed_asses_submap_exec_xii':
fixes f g v
assumes "v \<notin> fmdom' f" "v \<in> fmdom' g"
shows "fmlookup (f ++ g) v = fmlookup g v"
proof -
have "\<not>(v |\<in>| fmdom f)"
using assms(1) fmdom'_notI fmdom_notD
by fastforce
moreover have "v |\<in>| fmdom g"
using assms(2) fmdom'_notI fmdom_notD
by metis
ultimately show ?thesis
unfolding fmap_add_ltr_def
using fmlookup_add
by simp
qed
\<comment> \<open>NOTE showcase.\<close>
lemma as_needed_asses_submap_exec:
fixes s1 s2
assumes "(s1 \<subseteq>\<^sub>f s2)"
"(\<forall>a. ListMem a as \<longrightarrow> (action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1))"
shows "(exec_plan s1 as \<subseteq>\<^sub>f exec_plan s2 as)"
using assms
proof (induction as arbitrary: s1 s2)
case (Cons a as)
\<comment> \<open>Proof the premises of the induction hypothesis for 'state\_succ s1 a' and 'state\_succ s2 a'.\<close>
{
then have "action_needed_asses a s2 \<subseteq>\<^sub>f action_needed_asses a s1"
using Cons.prems(2) elem
by metis
then have "state_succ s1 a \<subseteq>\<^sub>f state_succ s2 a"
using Cons.prems(1) act_needed_asses_submap_succ_submap
by blast
}
note 1 = this
moreover {
fix a'
assume P: "ListMem a' as"
\<comment> \<open>Show the goal by rule 'as\_needed\_asses\_submap\_exec\_ix'.\<close>
let ?f="action_needed_asses a' (state_succ s2 a)"
let ?g="action_needed_asses a' (state_succ s1 a)"
{
fix v
assume P_1: "v \<in> fmdom' ?f"
then have "fmlookup ?f v = fmlookup ?g v"
unfolding state_succ_def
text \<open> Split cases on the if-then branches introduced by the definition of 'state\_succ'.\<close>
proof (auto)
assume P_1_1: "v \<in> fmdom' (action_needed_asses a' (snd a ++ s2))" "fst a \<subseteq>\<^sub>f s2"
"fst a \<subseteq>\<^sub>f s1"
have i: "action_needed_asses a' s2 \<subseteq>\<^sub>f action_needed_asses a' s1"
using Cons.prems(2) P insert
by fast
then show "
fmlookup (action_needed_asses a' (snd a ++ s2)) v
= fmlookup (action_needed_asses a' (snd a ++ s1)) v"
proof (cases "v \<in> fmdom' ?g")
case true: True
then have A:
"v \<in> fmdom' (fst a') \<and> v \<in> fmdom' (snd a ++ s1)
\<and> fmlookup (fst a') v = fmlookup (snd a ++ s1) v"
using as_needed_asses_submap_exec_x[OF true]
unfolding state_succ_def
using P_1_1(3)
by simp
then have B:
"v \<in> fmdom' (fst a') \<and> v \<in> fmdom' (snd a ++ s2)
\<and> fmlookup (fst a') v = fmlookup (snd a ++ s2) v"
using as_needed_asses_submap_exec_x[OF P_1]
unfolding state_succ_def
using P_1_1(2)
by simp
then show ?thesis
proof (cases "v \<in> fmdom' (snd a)")
case True
then have I:
"fmlookup (snd a ++ s2) v = fmlookup (snd a) v"
"fmlookup (snd a ++ s1) v = fmlookup (snd a) v"
using as_needed_asses_submap_exec_xii
by fast+
moreover {
have "fmlookup ?f v = fmlookup (snd a ++ s2) v"
using as_needed_asses_submap_exec_iv[OF P_1]
unfolding state_succ_def
using P_1_1(2)
by presburger
then have "fmlookup ?f v = fmlookup (snd a) v"
using I(1)
by argo
}
moreover {
have "fmlookup ?g v = fmlookup (snd a ++ s1) v"
using as_needed_asses_submap_exec_iv[OF true]
unfolding state_succ_def
using P_1_1(3)
by presburger
then have "fmlookup ?g v = fmlookup (snd a) v"
using I(2)
by argo
}
ultimately show ?thesis
unfolding state_succ_def
using P_1_1(2, 3)
by presburger
next
case False
then have I: "v \<in> fmdom' s1" "v \<in> fmdom' s2"
using A B
unfolding fmap_add_ltr_def fmdom'_add
by blast+
{
have "fmlookup ?g v = fmlookup (snd a ++ s1) v"
using as_needed_asses_submap_exec_iv[OF true]
unfolding state_succ_def
using P_1_1(3)
by presburger
then have "fmlookup ?g v = fmlookup s1 v"
using as_needed_asses_submap_exec_xii'[OF False I(1)]
by simp
moreover {
have "fmlookup (snd a ++ s1) v = fmlookup s1 v"
using as_needed_asses_submap_exec_xii'[OF False I(1)]
by simp
moreover from \<open>fmlookup (snd a ++ s1) v = fmlookup s1 v\<close>
have "fmlookup (fst a') v = fmlookup s1 v"
using A(1)
by argo
ultimately have "fmlookup (action_needed_asses a' s1) v = fmlookup s1 v"
using A(1) I(1)
unfolding action_needed_asses_def action_needed_vars_def
fmlookup_restrict_set
by simp
}
ultimately have "fmlookup ?g v = fmlookup (action_needed_asses a' s1) v"
by argo
}
note II = this
{
have "fmlookup ?f v = fmlookup (snd a ++ s2) v"
using as_needed_asses_submap_exec_iv[OF P_1]
unfolding state_succ_def
using P_1_1(2)
by presburger
moreover from \<open>fmlookup ?f v = fmlookup (snd a ++ s2) v\<close>
have \<alpha>: "fmlookup ?f v = fmlookup s2 v"
using as_needed_asses_submap_exec_xii'[OF False I(2)]
by argo
ultimately have "fmlookup (snd a ++ s2) v = fmlookup s2 v"
by argo
moreover {
from \<open>fmlookup (snd a ++ s2) v = fmlookup s2 v\<close>
have "fmlookup (fst a') v = fmlookup s2 v"
using B(1)
by argo
then have "fmlookup (action_needed_asses a' s2) v = fmlookup s2 v"
using B(1) I(2)
unfolding action_needed_asses_def action_needed_vars_def
fmlookup_restrict_set
by simp
}
ultimately have "fmlookup ?f v = fmlookup (action_needed_asses a' s2) v"
using \<alpha>
by argo
}
note III = this
{
have "v \<in> fmdom' (action_needed_asses a' s2)"
proof -
have "fmlookup (fst a') v = fmlookup s1 v"
by (simp add: A False I(1) as_needed_asses_submap_exec_xii')
then show ?thesis
by (simp add: A Cons.prems(1) I(1, 2)
as_needed_asses_submap_exec_ii as_needed_asses_submap_exec_iii)
qed
then have "
fmlookup (action_needed_asses a' s2) v
= fmlookup (action_needed_asses a' s1) v"
using i as_needed_asses_submap_exec_ix[of "action_needed_asses a' s2"
"action_needed_asses a' s1"]
by blast
}
note IV = this
{
have "fmlookup ?f v = fmlookup (action_needed_asses a' s2) v"
using III
by simp
also have "\<dots> = fmlookup (action_needed_asses a' s1) v"
using IV
by simp
finally have "\<dots> = fmlookup ?g v"
using II
by simp
}
then show ?thesis
unfolding action_needed_asses_def action_needed_vars_def state_succ_def
using P_1_1 A B
by simp
qed
next
case false: False
have A:
"v \<in> fmdom' (fst a') \<and> v \<in> fmdom' (snd a ++ s2)
\<and> fmlookup (fst a') v = fmlookup (snd a ++ s2) v"
using as_needed_asses_submap_exec_x[OF P_1]
unfolding state_succ_def
using P_1_1(2)
by simp
from false have B:
"\<not>(v \<in> fmdom' (snd a ++ s1)) \<or> \<not>(fmlookup (fst a') v = fmlookup (snd a ++ s1) v)"
by (simp add: A P_1_1(3) as_needed_asses_submap_exec_iii state_succ_def)
then show ?thesis
proof (cases "v \<in> fmdom' (snd a)")
case True
then have I: "v \<in> fmdom' (snd a ++ s1)"
unfolding fmap_add_ltr_def fmdom'_add
by simp
{
from True have
"fmlookup (snd a ++ s2) v = fmlookup (snd a) v"
"fmlookup (snd a ++ s1) v = fmlookup (snd a) v"
using as_needed_asses_submap_exec_xii
by fast+
then have "fmlookup (snd a ++ s1) v = fmlookup (snd a ++ s2) v"
by auto
also have " \<dots> = fmlookup (fst a') v"
using A
by simp
finally have "fmlookup (snd a ++ s1) v = fmlookup (fst a') v"
by simp
}
then show ?thesis using B I
by presburger
next
case False
then have I: "v \<in> fmdom' s2"
using A unfolding fmap_add_ltr_def fmdom'_add
by blast
{
from P_1 have "fmlookup ?f v \<noteq> None"
by (meson fmdom'_notI)
moreover from false
have "fmlookup ?g v = None"
by (simp add: fmdom'_notD)
ultimately have "fmlookup ?f v \<noteq> fmlookup ?g v"
by simp
}
moreover
{
{
from P_1_1(2) have "state_succ s2 a = snd a ++ s2"
unfolding state_succ_def
by simp
moreover from \<open>state_succ s2 a = snd a ++ s2\<close> have
"fmlookup (state_succ s2 a) v = fmlookup s2 v"
using as_needed_asses_submap_exec_xii'[OF False I]
by simp
ultimately have "fmlookup ?f v = fmlookup (action_needed_asses a' s2) v"
unfolding action_needed_asses_def action_needed_vars_def
by (simp add: A I)
}
note I = this
moreover {
from P_1_1(3) have "state_succ s1 a = snd a ++ s1"
unfolding state_succ_def
by simp
moreover from \<open>state_succ s1 a = snd a ++ s1\<close> False
have "fmlookup (state_succ s1 a) v = fmlookup s1 v"
unfolding fmap_add_ltr_def
using fmlookup_add
- by (simp add: fmdom'_alt_def fmember.rep_eq)
+ by (simp add: fmdom'_alt_def fmember_iff_member_fset)
ultimately have "fmlookup ?g v = fmlookup (action_needed_asses a' s1) v"
unfolding action_needed_asses_def action_needed_vars_def
using FDOM_state_succ_subset
by auto
}
moreover {
have "v \<in> fmdom' (action_needed_asses a' s2)"
proof -
have "v \<in> fmdom' s2 \<union> fmdom' (snd a)"
by (metis (no_types) A FDOM_state_succ_subset P_1_1(2) state_succ_def subsetCE)
then show ?thesis
by (simp add: A False as_needed_asses_submap_exec_iii as_needed_asses_submap_exec_xii')
qed
then have "
fmlookup (action_needed_asses a' s2) v
= fmlookup (action_needed_asses a' s1) v"
using i as_needed_asses_submap_exec_ix[of "action_needed_asses a' s2"
"action_needed_asses a' s1"]
by blast
}
ultimately have "fmlookup ?f v = fmlookup ?g v"
by simp
}
ultimately show ?thesis
by simp
qed
qed
next
assume P2: "v \<in> fmdom' (action_needed_asses a' (snd a ++ s2))" "fst a \<subseteq>\<^sub>f s2"
"\<not> fst a \<subseteq>\<^sub>f s1"
then show "
fmlookup (action_needed_asses a' (snd a ++ s2)) v
= fmlookup (action_needed_asses a' s1) v"
proof -
obtain aa :: "('a, 'b) fmap \<Rightarrow> ('a, 'b) fmap \<Rightarrow> 'a" where
"\<forall>x0 x1. (\<exists>v2. v2 \<in> fmdom' x1
\<and> fmlookup x1 v2 \<noteq> fmlookup x0 v2) = (aa x0 x1 \<in> fmdom' x1
\<and> fmlookup x1 (aa x0 x1) \<noteq> fmlookup x0 (aa x0 x1))"
by moura
then have f1: "\<forall>f fa. aa fa f \<in> fmdom' f
\<and> fmlookup f (aa fa f) \<noteq> fmlookup fa (aa fa f) \<or> f \<subseteq>\<^sub>f fa"
by (meson as_needed_asses_submap_exec_vii)
then have f2: "aa s1 (fst a) \<in> fmdom' (fst a)
\<and> fmlookup (fst a) (aa s1 (fst a)) \<noteq> fmlookup s1 (aa s1 (fst a))"
using P2(3) by blast
then have "aa s1 (fst a) \<in> fmdom' s2"
by (metis (full_types) P2(2) as_needed_asses_submap_exec_v)
then have "aa s1 (fst a) \<in> fmdom' (action_needed_asses a s2)"
using f2 by (simp add: P2(2) as_needed_asses_submap_exec_iii
as_needed_asses_submap_exec_viii)
then show ?thesis
using f1 by (metis (no_types) Cons.prems(2) P2(3) as_needed_asses_submap_exec_vi elem)
qed
next
assume P3: "v \<in> fmdom' (action_needed_asses a' s2)" "\<not> fst a \<subseteq>\<^sub>f s2" "fst a \<subseteq>\<^sub>f s1"
then show "
fmlookup (action_needed_asses a' s2) v
= fmlookup (action_needed_asses a' (snd a ++ s1)) v"
using Cons.prems(1) submap_imp_state_succ_submap_a
by blast
next
assume P4: "v \<in> fmdom' (action_needed_asses a' s2)" "\<not> fst a \<subseteq>\<^sub>f s2" "\<not> fst a \<subseteq>\<^sub>f s1"
then show "
fmlookup (action_needed_asses a' s2) v
= fmlookup (action_needed_asses a' s1) v"
by (simp add: Cons.prems(2) P as_needed_asses_submap_exec_ii insert)
qed
}
then have a: "?f \<subseteq>\<^sub>f ?g"
using as_needed_asses_submap_exec_ix
by blast
}
note 2 = this
then show ?case
unfolding exec_plan.simps
using Cons.IH[of "state_succ s1 a" "state_succ s2 a", OF 1]
by blast
qed simp
\<comment> \<open>NOTE name shortened.\<close>
definition system_needed_vars where
"system_needed_vars PROB s \<equiv> (\<Union>{action_needed_vars a s | a. a \<in> PROB})"
\<comment> \<open>NOTE name shortened.\<close>
definition system_needed_asses where
"system_needed_asses PROB s \<equiv> (fmrestrict_set (system_needed_vars PROB s) s)"
lemma action_needed_vars_subset_sys_needed_vars_subset:
assumes "(a \<in> PROB)"
shows "(action_needed_vars a s \<subseteq> system_needed_vars PROB s)"
using assms
by (auto simp: system_needed_vars_def) (metis surjective_pairing)
lemma action_needed_asses_submap_sys_needed_asses:
assumes "(a \<in> PROB)"
shows "(action_needed_asses a s \<subseteq>\<^sub>f system_needed_asses PROB s)"
proof -
have "action_needed_asses a s = fmrestrict_set (action_needed_vars a s) s"
unfolding action_needed_asses_def
by simp
then have "system_needed_asses PROB s = (fmrestrict_set (system_needed_vars PROB s) s)"
unfolding system_needed_asses_def
by simp
then have 1: "action_needed_vars a s \<subseteq> system_needed_vars PROB s"
unfolding action_needed_vars_subset_sys_needed_vars_subset
using assms action_needed_vars_subset_sys_needed_vars_subset
by fast
{
fix x
assume P1: "x \<in> dom (fmlookup (fmrestrict_set (action_needed_vars a s) s))"
then have a: "fmlookup (fmrestrict_set (action_needed_vars a s) s) x = fmlookup s x"
by (auto simp: fmdom'_restrict_set_precise)
then have "fmlookup (fmrestrict_set (system_needed_vars PROB s) s) x = fmlookup s x"
using 1 contra_subsetD
by fastforce
then have "
fmlookup (fmrestrict_set (action_needed_vars a s) s) x
= fmlookup (fmrestrict_set (system_needed_vars PROB s) s) x
"
using a
by argo
}
then have "
fmlookup (fmrestrict_set (action_needed_vars a s) s)
\<subseteq>\<^sub>m fmlookup (fmrestrict_set (system_needed_vars PROB s) s)
"
using map_le_def
by blast
then show "(action_needed_asses a s \<subseteq>\<^sub>f system_needed_asses PROB s)"
by (simp add: fmsubset.rep_eq action_needed_asses_def system_needed_asses_def)
qed
lemma system_needed_asses_include_action_needed_asses_1:
assumes "(a \<in> PROB)"
shows "(action_needed_vars a (fmrestrict_set (system_needed_vars PROB s) s) = action_needed_vars a s)"
proof -
let ?A="{v \<in> fmdom' (fmrestrict_set (system_needed_vars PROB s) s).
v \<in> fmdom' (fst a)
\<and> fmlookup (fst a) v = fmlookup (fmrestrict_set (system_needed_vars PROB s) s) v}"
let ?B="{v \<in> fmdom' s. v \<in> fmdom' (fst a) \<and> fmlookup (fst a) v = fmlookup s v}"
{
fix v
assume "v \<in> ?A"
then have i: "v \<in> fmdom' (fmrestrict_set (system_needed_vars PROB s) s)" "v \<in> fmdom' (fst a)"
"fmlookup (fst a) v = fmlookup (fmrestrict_set (system_needed_vars PROB s) s) v"
by blast+
then have "v \<in> fmdom' s"
by (simp add: fmdom'_restrict_set_precise)
moreover have "fmlookup (fst a) v = fmlookup s v"
using i(2, 3) fmdom'_notI
by force
ultimately have "v \<in> ?B"
using i
by blast
}
then have 1: "?A \<subseteq> ?B"
by blast
{
fix v
assume P: "v \<in> ?B"
then have ii: "v \<in> fmdom' s" "v \<in> fmdom' (fst a)" "fmlookup (fst a) v = fmlookup s v"
by blast+
moreover {
have "\<exists>s'. v \<in> s' \<and> (\<exists>a. (s' = action_needed_vars a s) \<and> a \<in> PROB)"
unfolding action_needed_vars_def
using assms P action_needed_vars_def
by metis
then obtain s' where \<alpha>: "v \<in> s'" "(\<exists>a. (s' = action_needed_vars a s) \<and> a \<in> PROB)"
by blast
moreover obtain a' where "s' = action_needed_vars a' s" "a' \<in> PROB"
using \<alpha>
by blast
ultimately have "v \<in> fmdom' (fmrestrict_set (system_needed_vars PROB s) s)"
unfolding fmdom'_restrict_set_precise
using action_needed_vars_subset_sys_needed_vars_subset ii(1) by blast
}
note iii = this
moreover have "fmlookup (fst a) v = fmlookup (fmrestrict_set (system_needed_vars PROB s) s) v"
using ii(3) iii fmdom'_notI
by force
ultimately have "v \<in> ?A"
by blast
}
then have "?B \<subseteq> ?A"
by blast
then show ?thesis
unfolding action_needed_vars_def
using 1
by blast
qed
\<comment> \<open>NOTE added lemma.\<close>
\<comment> \<open>TODO refactor (proven elsewhere?).\<close>
lemma system_needed_asses_include_action_needed_asses_i:
fixes A B f
assumes "A \<subseteq> B"
shows "fmrestrict_set A (fmrestrict_set B f) = fmrestrict_set A f"
proof -
{
let ?f'="fmrestrict_set A f"
let ?f''="fmrestrict_set A (fmrestrict_set B f)"
assume C: "?f'' \<noteq> ?f'"
then obtain v where 1: "fmlookup ?f'' v \<noteq> fmlookup ?f' v"
by (meson fmap_ext)
then have False
proof (cases "v \<in> A")
case True
have "fmlookup ?f'' v = fmlookup (fmrestrict_set B f) v"
using True fmlookup_restrict_set
by simp
moreover have "fmlookup (fmrestrict_set B f) v = fmlookup ?f' v"
using True assms(1)
by auto
ultimately show ?thesis
using 1
by argo
next
case False
then have "fmlookup ?f' v = None" "fmlookup ?f'' v = None"
using fmlookup_restrict_set
by auto+
then show ?thesis
using 1
by argo
qed
}
then show ?thesis
by blast
qed
lemma system_needed_asses_include_action_needed_asses:
assumes "(a \<in> PROB)"
shows "(action_needed_asses a (system_needed_asses PROB s) = action_needed_asses a s)"
proof -
{
have " action_needed_vars a s \<subseteq> system_needed_vars PROB s"
using action_needed_vars_subset_sys_needed_vars_subset[OF assms]
by simp
then have "
fmrestrict_set (action_needed_vars a s) (fmrestrict_set (system_needed_vars PROB s) s) =
fmrestrict_set (action_needed_vars a s) s"
using system_needed_asses_include_action_needed_asses_i
by fast
}
moreover
{
have
"action_needed_vars a (fmrestrict_set (system_needed_vars PROB s) s) = action_needed_vars a s"
using system_needed_asses_include_action_needed_asses_1[OF assms]
by simp
then have "fmrestrict_set (action_needed_vars a (fmrestrict_set (system_needed_vars PROB s) s))
(fmrestrict_set (system_needed_vars PROB s) s) =
fmrestrict_set (action_needed_vars a s) s
\<longleftrightarrow> fmrestrict_set (action_needed_vars a s) (fmrestrict_set (system_needed_vars PROB s) s) =
fmrestrict_set (action_needed_vars a s) s"
by simp
}
ultimately show ?thesis
unfolding action_needed_asses_def system_needed_asses_def
by simp
qed
lemma system_needed_asses_submap:
"system_needed_asses PROB s \<subseteq>\<^sub>f s"
proof -
{
fix x
assume P: "x\<in> dom (fmlookup (system_needed_asses PROB s))"
then have "system_needed_asses PROB s = (fmrestrict_set (system_needed_vars PROB s) s)"
by (simp add: system_needed_asses_def)
then have "fmlookup (system_needed_asses PROB s) x = fmlookup s x"
using P
by (auto simp: fmdom'_restrict_set_precise)
}
then have "fmlookup (system_needed_asses PROB s) \<subseteq>\<^sub>m fmlookup s"
using map_le_def
by blast
then show ?thesis
using fmsubset.rep_eq
by fast
qed
lemma as_works_from_system_needed_asses:
assumes "(as \<in> valid_plans PROB)"
shows "(exec_plan (system_needed_asses PROB s) as \<subseteq>\<^sub>f exec_plan s as)"
using assms
by (metis
action_needed_asses_def
as_needed_asses_submap_exec
fmsubset_restrict_set_mono system_needed_asses_def
system_needed_asses_include_action_needed_asses
system_needed_asses_include_action_needed_asses_1
system_needed_asses_submap
valid_plan_mems
)
end
\ No newline at end of file
diff --git a/thys/Formula_Derivatives/WS1S_Alt_Formula.thy b/thys/Formula_Derivatives/WS1S_Alt_Formula.thy
--- a/thys/Formula_Derivatives/WS1S_Alt_Formula.thy
+++ b/thys/Formula_Derivatives/WS1S_Alt_Formula.thy
@@ -1,363 +1,363 @@
section \<open>Concrete Atomic WS1S Formulas (Singleton Semantics for FO Variables)\<close>
(*<*)
theory WS1S_Alt_Formula
imports
Abstract_Formula
WS1S_Prelim
begin
(*>*)
datatype (FOV0: 'fo, SOV0: 'so) atomic =
Fo 'fo |
Z 'fo |
Less 'fo 'fo |
In 'fo 'so
derive linorder atomic
type_synonym fo = nat
type_synonym so = nat
type_synonym ws1s = "(fo, so) atomic"
type_synonym formula = "(ws1s, order) aformula"
primrec wf0 where
"wf0 idx (Fo m) = LESS FO m idx"
| "wf0 idx (Z m) = LESS FO m idx"
| "wf0 idx (Less m1 m2) = (LESS FO m1 idx \<and> LESS FO m2 idx)"
| "wf0 idx (In m M) = (LESS FO m idx \<and> LESS SO M idx)"
inductive lformula0 where
"lformula0 (Fo m)"
| "lformula0 (Z m)"
| "lformula0 (Less m1 m2)"
| "lformula0 (In m M)"
code_pred lformula0 .
declare lformula0.intros[simp]
inductive_cases lformula0E[elim]: "lformula0 a"
abbreviation "FV0 \<equiv> case_order FOV0 SOV0"
fun find0 where
"find0 FO i (Fo m) = (i = m)"
| "find0 FO i (Z m) = (i = m)"
| "find0 FO i (Less m1 m2) = (i = m1 \<or> i = m2)"
| "find0 FO i (In m _) = (i = m)"
| "find0 SO i (In _ M) = (i = M)"
| "find0 _ _ _ = False"
abbreviation "decr0 ord k \<equiv> map_atomic (case_order (dec k) id ord) (case_order id (dec k) ord)"
primrec satisfies0 where
"satisfies0 \<AA> (Fo m) = (\<exists>x. m\<^bsup>\<AA>\<^esup>FO = {|x|})"
| "satisfies0 \<AA> (Z m) = (m\<^bsup>\<AA>\<^esup>FO = {||})"
| "satisfies0 \<AA> (Less m1 m2) =
(let P1 = m1\<^bsup>\<AA>\<^esup>FO; P2 = m2\<^bsup>\<AA>\<^esup>FO in if \<not>(\<exists>x. P1 = {|x|}) \<or> \<not>(\<exists>x. P2 = {|x|})
then False
else fthe_elem P1 < fthe_elem P2)"
| "satisfies0 \<AA> (In m M) =
(let P = m\<^bsup>\<AA>\<^esup>FO in if \<not>(\<exists>x. P = {|x|}) then False else fMin P |\<in>| M\<^bsup>\<AA>\<^esup>SO)"
fun lderiv0 where
"lderiv0 (bs1, bs2) (Fo m) = (if bs1 ! m then FBase (Z m) else FBase (Fo m))"
| "lderiv0 (bs1, bs2) (Z m) = (if bs1 ! m then FBool False else FBase (Z m))"
| "lderiv0 (bs1, bs2) (Less m1 m2) = (case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Less m1 m2)
| (True, False) \<Rightarrow> FAnd (FBase (Z m1)) (FBase (Fo m2))
| _ \<Rightarrow> FBool False)"
| "lderiv0 (bs1, bs2) (In m M) = (case (bs1 ! m, bs2 ! M) of
(False, _) \<Rightarrow> FBase (In m M)
| (True, True) \<Rightarrow> FBase (Z m)
| _ \<Rightarrow> FBool False)"
primrec rev where
"rev (Fo m) = Fo m"
| "rev (Z m) = Z m"
| "rev (Less m1 m2) = Less m2 m1"
| "rev (In m M) = In m M"
abbreviation "rderiv0 v \<equiv> map_aformula rev id o lderiv0 v o rev"
primrec nullable0 where
"nullable0 (Fo m) = False"
| "nullable0 (Z m) = True"
| "nullable0 (Less m1 m2) = False"
| "nullable0 (In m M) = False"
lemma fimage_Suc_fsubset0[simp]: "Suc |`| A |\<subseteq>| {|0|} \<longleftrightarrow> A = {||}"
by blast
lemma fsubset_singleton_iff: "A |\<subseteq>| {|x|} \<longleftrightarrow> A = {||} \<or> A = {|x|}"
by blast
definition "restrict ord P = (case ord of FO \<Rightarrow> \<exists>x. P = {|x|} | SO \<Rightarrow> True)"
definition "Restrict ord i = (case ord of FO \<Rightarrow> FBase (Fo i) | SO \<Rightarrow> FBool True)"
declare [[goals_limit = 50]]
global_interpretation WS1S_Alt: Formula SUC LESS assigns nvars Extend CONS SNOC Length
extend size_atom zero \<sigma> eval downshift upshift finsert cut len restrict Restrict
lformula0 FV0 find0 wf0 decr0 satisfies0 nullable0 lderiv0 rderiv0 undefined
defines norm = "Formula_Operations.norm find0 decr0"
and nFOr = "Formula_Operations.nFOr :: formula \<Rightarrow> _"
and nFAnd = "Formula_Operations.nFAnd :: formula \<Rightarrow> _"
and nFNot = "Formula_Operations.nFNot find0 decr0 :: formula \<Rightarrow> _"
and nFEx = "Formula_Operations.nFEx find0 decr0"
and nFAll = "Formula_Operations.nFAll find0 decr0"
and decr = "Formula_Operations.decr decr0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
and find = "Formula_Operations.find find0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
and FV = "Formula_Operations.FV FV0"
and RESTR = "Formula_Operations.RESTR Restrict :: _ \<Rightarrow> formula"
and RESTRICT = "Formula_Operations.RESTRICT Restrict FV0"
and deriv = "\<lambda>d0 (a :: atom) (\<phi> :: formula). Formula_Operations.deriv extend d0 a \<phi>"
and nullable = "\<lambda>\<phi> :: formula. Formula_Operations.nullable nullable0 \<phi>"
and fut_default = "Formula.fut_default extend zero rderiv0"
and fut = "Formula.fut extend zero find0 decr0 rderiv0"
and finalize = "Formula.finalize SUC extend zero find0 decr0 rderiv0"
and final = "Formula.final SUC extend zero find0 decr0
nullable0 rderiv0 :: idx \<Rightarrow> formula \<Rightarrow> _"
and ws1s_wf = "Formula_Operations.wf SUC (wf0 :: idx \<Rightarrow> ws1s \<Rightarrow> _)"
and ws1s_lformula = "Formula_Operations.lformula lformula0 :: formula \<Rightarrow> _"
and check_eqv = "\<lambda>idx. DAs.check_eqv
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
(final idx) (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
(final idx) (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>) (=)"
and bounded_check_eqv = "\<lambda>idx. DAs.check_eqv
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
nullable (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
nullable (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>) (=)"
and automaton = "DA.automaton
(\<lambda>a \<phi>. norm (deriv lderiv0 (a :: atom) \<phi> :: formula))"
proof
fix k idx and a :: ws1s and l assume "wf0 (SUC k idx) a" "LESS k l (SUC k idx)" "\<not> find0 k l a"
then show "wf0 idx (decr0 k l a)"
by (induct a) (unfold wf0.simps atomic.map find0.simps,
(transfer, force simp: dec_def split: if_splits order.splits)+) \<comment> \<open>slow\<close>
next
fix k and a :: ws1s and l assume "lformula0 a"
then show "lformula0 (decr0 k l a)" by (induct a) auto
next
fix i k and a :: ws1s and \<AA> :: interp and P assume *: "\<not> find0 k i a" "LESS k i (SUC k (#\<^sub>V \<AA>))"
and disj: "lformula0 a \<or> len P \<le> Length \<AA>"
from disj show "satisfies0 (Extend k i \<AA> P) a = satisfies0 \<AA> (decr0 k i a)"
proof
assume "lformula0 a"
then show ?thesis using *
by (induct a)
(auto simp: dec_def split: if_splits order.split option.splits bool.splits) \<comment> \<open>slow\<close>
next
assume "len P \<le> Length \<AA>"
with * show ?thesis
proof (induct a)
case Fo then show ?case by (cases k) (auto simp: dec_def)
next
case Z then show ?case by (cases k) (auto simp: dec_def)
next
case Less then show ?case by (cases k) (auto simp: dec_def)
next
case In then show ?case by (cases k) (auto simp: dec_def)
qed
qed
next
fix idx and a :: ws1s and x assume "lformula0 a" "wf0 idx a"
then show "Formula_Operations.wf SUC wf0 idx (lderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.wf.simps Let_def split: bool.splits order.splits)
next
fix a :: ws1s and x assume "lformula0 a"
then show "Formula_Operations.lformula lformula0 (lderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.lformula.simps split: bool.splits)
next
fix idx and a :: ws1s and x assume "wf0 idx a"
then show "Formula_Operations.wf SUC wf0 idx (rderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.wf.simps Let_def sorted_append
split: bool.splits order.splits nat.splits)
next
fix \<AA> :: interp and a :: ws1s
- note fmember.rep_eq[symmetric, simp]
+ note fmember_iff_member_fset[symmetric, simp]
assume "Length \<AA> = 0"
then show "nullable0 a = satisfies0 \<AA> a"
by (induct a, unfold wf0.simps nullable0.simps satisfies0.simps Let_def)
(transfer, (auto 0 3 dest: MSB_greater split: prod.splits if_splits option.splits bool.splits nat.splits) [])+ \<comment> \<open>slow\<close>
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp] upshift_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "lformula0 a" "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies Extend Length satisfies0 \<AA> (lderiv0 x a) =
satisfies0 (CONS x \<AA>) a"
proof (induct a)
qed (auto split: prod.splits bool.splits)
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp] upshift_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "lformula0 a" "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies_bounded Extend Length len satisfies0 \<AA> (lderiv0 x a) =
satisfies0 (CONS x \<AA>) a"
by (induct a) (auto split: prod.splits bool.splits)
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies_bounded Extend Length len satisfies0 \<AA> (rderiv0 x a) =
satisfies0 (SNOC x \<AA>) a"
proof (induct a)
case Less then show ?case
apply (auto 2 0 split: prod.splits option.splits bool.splits)
apply (auto simp add: fsubset_singleton_iff)
apply (metis assigns_less_Length finsertCI less_not_sym)
apply force
apply (metis assigns_less_Length finsertCI less_not_sym)
apply force
done
next
case In then show ?case by (force split: prod.splits)
qed (auto split: prod.splits)
next
fix a :: ws1s and \<AA> \<BB> :: interp
assume "wf0 (#\<^sub>V \<BB>) a" "#\<^sub>V \<AA> = #\<^sub>V \<BB>" "(\<And>m k. LESS k m (#\<^sub>V \<BB>) \<Longrightarrow> m\<^bsup>\<AA>\<^esup>k = m\<^bsup>\<BB>\<^esup>k)" "lformula0 a"
then show "satisfies0 \<AA> a \<longleftrightarrow> satisfies0 \<BB> a" by (induct a) auto
next
fix a :: ws1s
assume "lformula0 a"
moreover
define d where "d = Formula_Operations.deriv extend lderiv0"
define \<Phi> :: "_ \<Rightarrow> (ws1s, order) aformula set"
where "\<Phi> a =
(case a of
Fo m \<Rightarrow> {FBase (Fo m), FBase (Z m), FBool False}
| Z m \<Rightarrow> {FBase (Z m), FBool False}
| Less m1 m2 \<Rightarrow> {FBase (Less m1 m2),
FAnd (FBase (Z m1)) (FBase (Fo m2)),
FAnd (FBase (Z m1)) (FBase (Z m2)),
FAnd (FBase (Z m1)) (FBool False),
FAnd (FBool False) (FBase (Fo m2)),
FAnd (FBool False) (FBase (Z m2)),
FAnd (FBool False) (FBool False),
FBool False}
| In i I \<Rightarrow> {FBase (In i I), FBase (Z i), FBool False})" for a
{ fix xs
note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
from \<open>lformula0 a\<close> have "FBase a \<in> \<Phi> a" by (cases a) auto
moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
by (auto simp: d_def split: atomic.splits list.splits bool.splits if_splits option.splits)
then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
}
moreover have "finite (\<Phi> a)" using \<open>lformula0 a\<close> unfolding \<Phi>_def by (auto split: atomic.splits)
ultimately show "finite {fold d xs (FBase a) | xs. True}" by (blast intro: finite_subset)
next
fix a :: ws1s
define d where "d = Formula_Operations.deriv extend rderiv0"
define \<Phi> :: "_ \<Rightarrow> (ws1s, order) aformula set"
where "\<Phi> a =
(case a of
Fo m \<Rightarrow> {FBase (Fo m), FBase (Z m), FBool False}
| Z m \<Rightarrow> {FBase (Z m), FBool False}
| Less m1 m2 \<Rightarrow> {FBase (Less m1 m2),
FAnd (FBase (Z m2)) (FBase (Fo m1)) ,
FAnd (FBase (Z m2)) (FBase (Z m1)),
FAnd (FBase (Z m2)) (FBool False),
FAnd (FBool False) (FBase (Fo m1)),
FAnd (FBool False) (FBase (Z m1)),
FAnd (FBool False) (FBool False),
FBool False}
| In i I \<Rightarrow> {FBase (In i I), FBase (Z i), FBool False})" for a
{ fix xs
note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
then have "FBase a \<in> \<Phi> a" by (auto split: atomic.splits option.splits)
moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
by (auto simp add: d_def Let_def not_le gr0_conv_Suc
split: atomic.splits list.splits bool.splits if_splits option.splits nat.splits)
then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a"
by (induct xs) auto
ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
}
moreover have "finite (\<Phi> a)" unfolding \<Phi>_def using [[simproc add: finite_Collect]]
by (auto split: atomic.splits)
ultimately show "finite {fold d xs (FBase a) | xs. True}" by (blast intro: finite_subset)
next
fix k l and a :: ws1s
show "find0 k l a \<longleftrightarrow> l \<in> FV0 k a" by (induct a rule: find0.induct) auto
next
fix a :: ws1s and k :: order
show "finite (FV0 k a)" by (cases k) (induct a, auto)+
next
fix idx a k v
assume "wf0 idx a" "v \<in> FV0 k a"
then show "LESS k v idx" by (cases k) (induct a, auto)+
next
fix idx k i
assume "LESS k i idx"
then show "Formula_Operations.wf SUC wf0 idx (Restrict k i)"
unfolding Restrict_def by (cases k) (auto simp: Formula_Operations.wf.simps)
next
fix k and i :: nat
show "Formula_Operations.lformula lformula0 (Restrict k i)"
unfolding Restrict_def by (cases k) (auto simp: Formula_Operations.lformula.simps)
next
fix i \<AA> k P r
assume "i\<^bsup>\<AA>\<^esup>k = P"
then show "restrict k P \<longleftrightarrow>
Formula_Operations.satisfies_gen Extend Length satisfies0 r \<AA> (Restrict k i)"
unfolding restrict_def Restrict_def
by (cases k) (auto simp: Formula_Operations.satisfies_gen.simps)
qed (auto simp: Extend_commute_unsafe downshift_def upshift_def fimage_iff Suc_le_eq len_def
dec_def eval_def cut_def len_downshift_helper CONS_inj dest!: CONS_surj
dest: fMax_ge fMax_ffilter_less fMax_boundedD fsubset_fsingletonD
split: order.splits if_splits)
(*Workaround for code generation*)
lemma check_eqv_code[code]: "check_eqv idx r s =
((ws1s_wf idx r \<and> ws1s_lformula r) \<and> (ws1s_wf idx s \<and> ws1s_lformula s) \<and>
(case rtrancl_while (\<lambda>(p, q). final idx p = final idx q)
(\<lambda>(p, q). map (\<lambda>a. (norm (deriv lderiv0 a p), norm (deriv lderiv0 a q))) (\<sigma> idx))
(norm (RESTRICT r), norm (RESTRICT s)) of
None \<Rightarrow> False
| Some ([], x) \<Rightarrow> True
| Some (a # list, x) \<Rightarrow> False))"
unfolding check_eqv_def WS1S_Alt.check_eqv_def WS1S_Alt.step_alt ..
definition while where [code del, code_abbrev]: "while idx \<phi> = while_default (fut_default idx \<phi>)"
declare while_default_code[of "fut_default idx \<phi>" for idx \<phi>, folded while_def, code]
lemma check_eqv_sound:
"\<lbrakk>#\<^sub>V \<AA> = idx; check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (WS1S_Alt.sat \<AA> \<phi> \<longleftrightarrow> WS1S_Alt.sat \<AA> \<psi>)"
unfolding check_eqv_def by (rule WS1S_Alt.check_eqv_soundness)
lemma bounded_check_eqv_sound:
"\<lbrakk>#\<^sub>V \<AA> = idx; bounded_check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (WS1S_Alt.sat\<^sub>b \<AA> \<phi> \<longleftrightarrow> WS1S_Alt.sat\<^sub>b \<AA> \<psi>)"
unfolding bounded_check_eqv_def by (rule WS1S_Alt.bounded_check_eqv_soundness)
method_setup check_equiv = \<open>
let
fun tac ctxt =
let
val conv = @{computation_check terms: Trueprop
"0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
"plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
"times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
"0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
check_eqv datatypes: formula "int list" integer idx
"nat \<times> nat" "nat option" "bool option"} ctxt
in
CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
resolve_tac ctxt [TrueI]
end
in
Scan.succeed (SIMPLE_METHOD' o tac)
end
\<close>
end
diff --git a/thys/Formula_Derivatives/WS1S_Formula.thy b/thys/Formula_Derivatives/WS1S_Formula.thy
--- a/thys/Formula_Derivatives/WS1S_Formula.thy
+++ b/thys/Formula_Derivatives/WS1S_Formula.thy
@@ -1,798 +1,798 @@
section \<open>Concrete Atomic WS1S Formulas (Minimum Semantics for FO Variables)\<close>
(*<*)
theory WS1S_Formula
imports
Abstract_Formula
WS1S_Prelim
begin
(*>*)
datatype (FOV0: 'fo, SOV0: 'so) atomic =
Fo 'fo |
Eq_Const "nat option" 'fo nat |
Less "bool option" 'fo 'fo |
Plus_FO "nat option" 'fo 'fo nat |
Eq_FO bool 'fo 'fo |
Eq_SO 'so 'so |
Suc_SO bool bool 'so 'so |
Empty 'so |
Singleton 'so |
Subset 'so 'so |
In bool 'fo 'so |
Eq_Max bool 'fo 'so |
Eq_Min bool 'fo 'so |
Eq_Union 'so 'so 'so |
Eq_Inter 'so 'so 'so |
Eq_Diff 'so 'so 'so |
Disjoint 'so 'so |
Eq_Presb "nat option" 'so nat
derive linorder option
derive linorder atomic \<comment> \<open>very slow\<close>
type_synonym fo = nat
type_synonym so = nat
type_synonym ws1s = "(fo, so) atomic"
type_synonym formula = "(ws1s, order) aformula"
primrec wf0 where
"wf0 idx (Fo m) = LESS FO m idx"
| "wf0 idx (Eq_Const i m n) = (LESS FO m idx \<and> (case i of Some i \<Rightarrow> i \<le> n | _ \<Rightarrow> True))"
| "wf0 idx (Less _ m1 m2) = (LESS FO m1 idx \<and> LESS FO m2 idx)"
| "wf0 idx (Plus_FO i m1 m2 n) =
(LESS FO m1 idx \<and> LESS FO m2 idx \<and> (case i of Some i \<Rightarrow> i \<le> n | _ \<Rightarrow> True))"
| "wf0 idx (Eq_FO _ m1 m2) = (LESS FO m1 idx \<and> LESS FO m2 idx)"
| "wf0 idx (Eq_SO M1 M2) = (LESS SO M1 idx \<and> LESS SO M2 idx)"
| "wf0 idx (Suc_SO br bl M1 M2) = (LESS SO M1 idx \<and> LESS SO M2 idx)"
| "wf0 idx (Empty M) = LESS SO M idx"
| "wf0 idx (Singleton M) = LESS SO M idx"
| "wf0 idx (Subset M1 M2) = (LESS SO M1 idx \<and> LESS SO M2 idx)"
| "wf0 idx (In _ m M) = (LESS FO m idx \<and> LESS SO M idx)"
| "wf0 idx (Eq_Max _ m M) = (LESS FO m idx \<and> LESS SO M idx)"
| "wf0 idx (Eq_Min _ m M) = (LESS FO m idx \<and> LESS SO M idx)"
| "wf0 idx (Eq_Union M1 M2 M3) = (LESS SO M1 idx \<and> LESS SO M2 idx \<and> LESS SO M3 idx)"
| "wf0 idx (Eq_Inter M1 M2 M3) = (LESS SO M1 idx \<and> LESS SO M2 idx \<and> LESS SO M3 idx)"
| "wf0 idx (Eq_Diff M1 M2 M3) = (LESS SO M1 idx \<and> LESS SO M2 idx \<and> LESS SO M3 idx)"
| "wf0 idx (Disjoint M1 M2) = (LESS SO M1 idx \<and> LESS SO M2 idx)"
| "wf0 idx (Eq_Presb _ M n) = LESS SO M idx"
inductive lformula0 where
"lformula0 (Fo m)"
| "lformula0 (Eq_Const None m n)"
| "lformula0 (Less None m1 m2)"
| "lformula0 (Plus_FO None m1 m2 n)"
| "lformula0 (Eq_FO False m1 m2)"
| "lformula0 (Eq_SO M1 M2)"
| "lformula0 (Suc_SO False bl M1 M2)"
| "lformula0 (Empty M)"
| "lformula0 (Singleton M)"
| "lformula0 (Subset M1 M2)"
| "lformula0 (In False m M)"
| "lformula0 (Eq_Max False m M)"
| "lformula0 (Eq_Min False m M)"
| "lformula0 (Eq_Union M1 M2 M3)"
| "lformula0 (Eq_Inter M1 M2 M3)"
| "lformula0 (Eq_Diff M1 M2 M3)"
| "lformula0 (Disjoint M1 M2)"
| "lformula0 (Eq_Presb None M n)"
code_pred lformula0 .
declare lformula0.intros[simp]
inductive_cases lformula0E[elim]: "lformula0 a"
abbreviation "FV0 \<equiv> case_order FOV0 SOV0"
fun find0 where
"find0 FO i (Fo m) = (i = m)"
| "find0 FO i (Eq_Const _ m _) = (i = m)"
| "find0 FO i (Less _ m1 m2) = (i = m1 \<or> i = m2)"
| "find0 FO i (Plus_FO _ m1 m2 _) = (i = m1 \<or> i = m2)"
| "find0 FO i (Eq_FO _ m1 m2) = (i = m1 \<or> i = m2)"
| "find0 SO i (Eq_SO M1 M2) = (i = M1 \<or> i = M2)"
| "find0 SO i (Suc_SO _ _ M1 M2) = (i = M1 \<or> i = M2)"
| "find0 SO i (Empty M) = (i = M)"
| "find0 SO i (Singleton M) = (i = M)"
| "find0 SO i (Subset M1 M2) = (i = M1 \<or> i = M2)"
| "find0 FO i (In _ m _) = (i = m)"
| "find0 SO i (In _ _ M) = (i = M)"
| "find0 FO i (Eq_Max _ m _) = (i = m)"
| "find0 SO i (Eq_Max _ _ M) = (i = M)"
| "find0 FO i (Eq_Min _ m _) = (i = m)"
| "find0 SO i (Eq_Min _ _ M) = (i = M)"
| "find0 SO i (Eq_Union M1 M2 M3) = (i = M1 \<or> i = M2 \<or> i = M3)"
| "find0 SO i (Eq_Inter M1 M2 M3) = (i = M1 \<or> i = M2 \<or> i = M3)"
| "find0 SO i (Eq_Diff M1 M2 M3) = (i = M1 \<or> i = M2 \<or> i = M3)"
| "find0 SO i (Disjoint M1 M2) = (i = M1 \<or> i = M2)"
| "find0 SO i (Eq_Presb _ M _) = (i = M)"
| "find0 _ _ _ = False"
abbreviation "decr0 ord k \<equiv> map_atomic (case_order (dec k) id ord) (case_order id (dec k) ord)"
lemma sum_pow2_image_Suc:
"finite X \<Longrightarrow> sum ((^) (2 :: nat)) (Suc ` X) = 2 * sum ((^) 2) X"
by (induct X rule: finite_induct) (auto intro: trans[OF sum.insert])
lemma sum_pow2_insert0:
"\<lbrakk>finite X; 0 \<notin> X\<rbrakk> \<Longrightarrow> sum ((^) (2 :: nat)) (insert 0 X) = Suc (sum ((^) 2) X)"
by (induct X rule: finite_induct) (auto intro: trans[OF sum.insert])
lemma sum_pow2_upto: "sum ((^) (2 :: nat)) {0 ..< x} = 2 ^ x - 1"
by (induct x) (auto simp: algebra_simps)
lemma sum_pow2_inj:
"\<lbrakk>finite X; finite Y; (\<Sum>x\<in>X. 2 ^ x :: nat) = (\<Sum>x\<in>Y. 2 ^ x)\<rbrakk> \<Longrightarrow> X = Y"
(is "_ \<Longrightarrow> _ \<Longrightarrow> ?f X = ?f Y \<Longrightarrow> _")
proof (induct X arbitrary: Y rule: finite_linorder_max_induct)
case (insert x X)
from insert(2) have "?f X \<le> ?f {0 ..< x}" by (intro sum_mono2) auto
also have "\<dots> < 2 ^ x" by (induct x) simp_all
finally have "?f X < 2 ^ x" .
moreover from insert(1,2) have *: "?f X + 2 ^ x = ?f Y"
using trans[OF sym[OF insert(5)] sum.insert] by auto
ultimately have "?f Y < 2 ^ Suc x" by simp
have "\<forall>y \<in> Y. y \<le> x"
proof (rule ccontr)
assume "\<not> (\<forall>y\<in>Y. y \<le> x)"
then obtain y where "y \<in> Y" "Suc x \<le> y" by auto
from this(2) have "2 ^ Suc x \<le> (2 ^ y :: nat)" by (intro power_increasing) auto
also from \<open>y \<in> Y\<close> insert(4) have "\<dots> \<le> ?f Y" by (metis order.refl sum.remove trans_le_add1)
finally show False using \<open>?f Y < 2 ^ Suc x\<close> by simp
qed
{ assume "x \<notin> Y"
with \<open>\<forall>y \<in> Y. y \<le> x\<close> have "?f Y \<le> ?f {0 ..< x}" by (intro sum_mono2) (auto simp: le_less)
also have "\<dots> < 2 ^ x" by (induct x) simp_all
finally have "?f Y < 2 ^ x" .
with * have False by auto
}
then have "x \<in> Y" by blast
from insert(4) have "?f (Y - {x}) + 2 ^ x = ?f (insert x (Y - {x}))"by (subst sum.insert) auto
also have "\<dots> = ?f X + 2 ^ x" unfolding * using \<open>x \<in> Y\<close> by (simp add: insert_absorb)
finally have "?f X = ?f (Y - {x})" by simp
with insert(3,4) have "X = Y - {x}" by simp
with \<open>x \<in> Y\<close> show ?case by auto
qed simp
lemma finite_pow2_eq:
fixes n :: nat
shows "finite {i. 2 ^ i = n}"
proof -
have "((^) 2) ` {i. 2 ^ i = n} \<subseteq> {n}" by auto
then have "finite (((^) (2 :: nat)) ` {i. 2 ^ i = n})" by (rule finite_subset) blast
then show "finite {i. 2 ^ i = n}" by (rule finite_imageD) (auto simp: inj_on_def)
qed
lemma finite_pow2_le[simp]:
fixes n :: nat
shows "finite {i. 2 ^ i \<le> n}"
by (induct n) (auto simp: le_Suc_eq finite_pow2_eq)
lemma le_pow2[simp]: "x \<le> y \<Longrightarrow> x \<le> 2 ^ y"
by (induct x arbitrary: y) (force simp add: Suc_le_eq order.strict_iff_order)+
lemma ld_bounded: "Max {i. 2 ^ i \<le> Suc n} \<le> Suc n" (is "?m \<le> Suc n")
proof -
have "?m \<le> 2 ^ ?m" by (rule le_pow2) simp
moreover
have "?m \<in> {i. 2 ^ i \<le> Suc n}" by (rule Max_in) (auto intro: exI[of _ 0])
then have "2 ^ ?m \<le> Suc n" by simp
ultimately show ?thesis by linarith
qed
primrec satisfies0 where
"satisfies0 \<AA> (Fo m) = (m\<^bsup>\<AA>\<^esup>FO \<noteq> {||})"
| "satisfies0 \<AA> (Eq_Const i m n) =
(let P = m\<^bsup>\<AA>\<^esup>FO in if P = {||}
then (case i of Some i \<Rightarrow> Length \<AA> = i | _ \<Rightarrow> False)
else fMin P = n)"
| "satisfies0 \<AA> (Less b m1 m2) =
(let P1 = m1\<^bsup>\<AA>\<^esup>FO; P2 = m2\<^bsup>\<AA>\<^esup>FO in if P1 = {||} \<or> P2 = {||}
then (case b of None \<Rightarrow> False | Some True \<Rightarrow> P2 = {||} | Some False \<Rightarrow> P1 \<noteq> {||})
else fMin P1 < fMin P2)"
| "satisfies0 \<AA> (Plus_FO i m1 m2 n) =
(let P1 = m1\<^bsup>\<AA>\<^esup>FO; P2 = m2\<^bsup>\<AA>\<^esup>FO in if P1 = {||} \<or> P2 = {||}
then (case i of Some 0 \<Rightarrow> P1 = P2 | Some i \<Rightarrow> P2 \<noteq> {||} \<and> fMin P2 + i = Length \<AA> | _ \<Rightarrow> False)
else fMin P1 = fMin P2 + n)"
| "satisfies0 \<AA> (Eq_FO b m1 m2) =
(let P1 = m1\<^bsup>\<AA>\<^esup>FO; P2 = m2\<^bsup>\<AA>\<^esup>FO in if P1 = {||} \<or> P2 = {||}
then b \<and> P1 = P2
else fMin P1 = fMin P2)"
| "satisfies0 \<AA> (Eq_SO M1 M2) = (M1\<^bsup>\<AA>\<^esup>SO = M2\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (Suc_SO br bl M1 M2) =
((if br then finsert (Length \<AA>) else id) (M1\<^bsup>\<AA>\<^esup>SO) =
(if bl then finsert 0 else id) (Suc |`| M2\<^bsup>\<AA>\<^esup>SO))"
| "satisfies0 \<AA> (Empty M) = (M\<^bsup>\<AA>\<^esup>SO = {||})"
| "satisfies0 \<AA> (Singleton M) = (\<exists>x. M\<^bsup>\<AA>\<^esup>SO = {|x|})"
| "satisfies0 \<AA> (Subset M1 M2) = (M1\<^bsup>\<AA>\<^esup>SO |\<subseteq>| M2\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (In b m M) =
(let P = m\<^bsup>\<AA>\<^esup>FO in if P = {||} then b else fMin P |\<in>| M\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (Eq_Max b m M) =
(let P1 = m\<^bsup>\<AA>\<^esup>FO; P2 = M\<^bsup>\<AA>\<^esup>SO in if b then P1 = {||}
else if P1 = {||} \<or> P2 = {||} then False else fMin P1 = fMax P2)"
| "satisfies0 \<AA> (Eq_Min b m M) =
(let P1 = m\<^bsup>\<AA>\<^esup>FO; P2 = M\<^bsup>\<AA>\<^esup>SO in if P1 = {||} \<or> P2 = {||} then b \<and> P1 = P2 else fMin P1 = fMin P2)"
| "satisfies0 \<AA> (Eq_Union M1 M2 M3) = (M1\<^bsup>\<AA>\<^esup>SO = M2\<^bsup>\<AA>\<^esup>SO |\<union>| M3\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (Eq_Inter M1 M2 M3) = (M1\<^bsup>\<AA>\<^esup>SO = M2\<^bsup>\<AA>\<^esup>SO |\<inter>| M3\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (Eq_Diff M1 M2 M3) = (M1\<^bsup>\<AA>\<^esup>SO = M2\<^bsup>\<AA>\<^esup>SO |-| M3\<^bsup>\<AA>\<^esup>SO)"
| "satisfies0 \<AA> (Disjoint M1 M2) = (M1\<^bsup>\<AA>\<^esup>SO |\<inter>| M2\<^bsup>\<AA>\<^esup>SO = {||})"
| "satisfies0 \<AA> (Eq_Presb i M n) = (((\<Sum>x\<in>fset (M\<^bsup>\<AA>\<^esup>SO). 2 ^ x) = n) \<and>
(case i of None \<Rightarrow> True | Some l \<Rightarrow> Length \<AA> = l))"
fun lderiv0 where
"lderiv0 (bs1, bs2) (Fo m) = (if bs1 ! m then FBool True else FBase (Fo m))"
| "lderiv0 (bs1, bs2) (Eq_Const None m n) = (if n = 0 \<and> bs1 ! m then FBool True
else if n = 0 \<or> bs1 ! m then FBool False else FBase (Eq_Const None m (n - 1)))"
| "lderiv0 (bs1, bs2) (Less None m1 m2) = (case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Less None m1 m2)
| (True, False) \<Rightarrow> FBase (Fo m2)
| _ \<Rightarrow> FBool False)"|
"lderiv0 (bs1, bs2) (Eq_FO False m1 m2) = (case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Eq_FO False m1 m2)
| (True, True) \<Rightarrow> FBool True
| _ \<Rightarrow> FBool False)"
| "lderiv0 (bs1, bs2) (Plus_FO None m1 m2 n) = (if n = 0
then
(case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Plus_FO None m1 m2 n)
| (True, True) \<Rightarrow> FBool True
| _ \<Rightarrow> FBool False)
else
(case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Plus_FO None m1 m2 n)
| (False, True) \<Rightarrow> FBase (Eq_Const None m1 (n - 1))
| _ \<Rightarrow> FBool False))"
| "lderiv0 (bs1, bs2) (Eq_SO M1 M2) =
(if bs2 ! M1 = bs2 ! M2 then FBase (Eq_SO M1 M2) else FBool False)"
| "lderiv0 (bs1, bs2) (Suc_SO False bl M1 M2) = (if bl = bs2 ! M1
then FBase (Suc_SO False (bs2 ! M2) M1 M2) else FBool False)"
| "lderiv0 (bs1, bs2) (Empty M) = (case bs2 ! M of
True \<Rightarrow> FBool False
| False \<Rightarrow> FBase (Empty M))"
| "lderiv0 (bs1, bs2) (Singleton M) = (case bs2 ! M of
True \<Rightarrow> FBase (Empty M)
| False \<Rightarrow> FBase (Singleton M))"
| "lderiv0 (bs1, bs2) (Subset M1 M2) = (case (bs2 ! M1, bs2 ! M2) of
(True, False) \<Rightarrow> FBool False
| _ \<Rightarrow> FBase (Subset M1 M2))"
| "lderiv0 (bs1, bs2) (In False m M) = (case (bs1 ! m, bs2 ! M) of
(False, _) \<Rightarrow> FBase (In False m M)
| (True, True) \<Rightarrow> FBool True
| _ \<Rightarrow> FBool False)"
| "lderiv0 (bs1, bs2) (Eq_Max False m M) = (case (bs1 ! m, bs2 ! M) of
(False, _) \<Rightarrow> FBase (Eq_Max False m M)
| (True, True) \<Rightarrow> FBase (Empty M)
| _ \<Rightarrow> FBool False)"
| "lderiv0 (bs1, bs2) (Eq_Min False m M) = (case (bs1 ! m, bs2 ! M) of
(False, False) \<Rightarrow> FBase (Eq_Min False m M)
| (True, True) \<Rightarrow> FBool True
| _ \<Rightarrow> FBool False)"
| "lderiv0 (bs1, bs2) (Eq_Union M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<or> bs2 ! M3)
then FBase (Eq_Union M1 M2 M3) else FBool False)"
| "lderiv0 (bs1, bs2) (Eq_Inter M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<and> bs2 ! M3)
then FBase (Eq_Inter M1 M2 M3) else FBool False)"
| "lderiv0 (bs1, bs2) (Eq_Diff M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<and> \<not> bs2 ! M3)
then FBase (Eq_Diff M1 M2 M3) else FBool False)"
| "lderiv0 (bs1, bs2) (Disjoint M1 M2) =
(if bs2 ! M1 \<and> bs2 ! M2 then FBool False else FBase (Disjoint M1 M2))"
| "lderiv0 (bs1, bs2) (Eq_Presb None M n) = (if bs2 ! M = (n mod 2 = 0)
then FBool False else FBase (Eq_Presb None M (n div 2)))"
| "lderiv0 _ _ = undefined"
fun ld where
"ld 0 = 0"
| "ld (Suc 0) = 0"
| "ld n = Suc (ld (n div 2))"
lemma ld_alt[simp]: "n > 0 \<Longrightarrow> ld n = Max {i. 2 ^ i \<le> n}"
proof (safe intro!: Max_eqI[symmetric])
assume "n > 0" then show "2 ^ ld n \<le> n" by (induct n rule: ld.induct) auto
next
fix y
assume "2 ^ y \<le> n"
then show "y \<le> ld n"
proof (induct n arbitrary: y rule: ld.induct)
case (3 z)
then have "y - 1 \<le> ld (Suc (Suc z) div 2)"
by (cases y) simp_all
then show ?case by simp
qed (auto simp: le_eq_less_or_eq)
qed simp
fun rderiv0 where
"rderiv0 (bs1, bs2) (Fo m) = (if bs1 ! m then FBool True else FBase (Fo m))"
| "rderiv0 (bs1, bs2) (Eq_Const i m n) = (case bs1 ! m of
False \<Rightarrow> FBase (Eq_Const (case i of Some (Suc i) \<Rightarrow> Some i | _ \<Rightarrow> None) m n)
| True \<Rightarrow> FBase (Eq_Const (Some n) m n))"
| "rderiv0 (bs1, bs2) (Less b m1 m2) = (case bs1 ! m2 of
False \<Rightarrow> (case b of
Some False \<Rightarrow> (case bs1 ! m1 of
True \<Rightarrow> FBase (Less (Some True) m1 m2)
| False \<Rightarrow> FBase (Less (Some False) m1 m2))
| _ \<Rightarrow> FBase (Less b m1 m2))
| True \<Rightarrow> FBase (Less (Some False) m1 m2))"
| "rderiv0 (bs1, bs2) (Plus_FO i m1 m2 n) = (if n = 0
then
(case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Plus_FO i m1 m2 n)
| (True, True) \<Rightarrow> FBase (Plus_FO (Some 0) m1 m2 n)
| _ \<Rightarrow> FBase (Plus_FO None m1 m2 n))
else
(case bs1 ! m1 of
True \<Rightarrow> FBase (Plus_FO (Some n) m1 m2 n)
| False \<Rightarrow> (case bs1 ! m2 of
False \<Rightarrow> (case i of
Some (Suc (Suc i)) \<Rightarrow> FBase (Plus_FO (Some (Suc i)) m1 m2 n)
| Some (Suc 0) \<Rightarrow> FBase (Plus_FO None m1 m2 n)
| _ \<Rightarrow> FBase (Plus_FO i m1 m2 n))
| True \<Rightarrow> (case i of
Some (Suc i) \<Rightarrow> FBase (Plus_FO (Some i) m1 m2 n)
| _ \<Rightarrow> FBase (Plus_FO None m1 m2 n)))))"
| "rderiv0 (bs1, bs2) (Eq_FO b m1 m2) = (case (bs1 ! m1, bs1 ! m2) of
(False, False) \<Rightarrow> FBase (Eq_FO b m1 m2)
| (True, True) \<Rightarrow> FBase (Eq_FO True m1 m2)
| _ \<Rightarrow> FBase (Eq_FO False m1 m2))"
| "rderiv0 (bs1, bs2) (Eq_SO M1 M2) =
(if bs2 ! M1 = bs2 ! M2 then FBase (Eq_SO M1 M2) else FBool False)"
| "rderiv0 (bs1, bs2) (Suc_SO br bl M1 M2) = (if br = bs2 ! M2
then FBase (Suc_SO (bs2 ! M1) bl M1 M2) else FBool False)"
| "rderiv0 (bs1, bs2) (Empty M) = (case bs2 ! M of
True \<Rightarrow> FBool False
| False \<Rightarrow> FBase (Empty M))"
| "rderiv0 (bs1, bs2) (Singleton M) = (case bs2 ! M of
True \<Rightarrow> FBase (Empty M)
| False \<Rightarrow> FBase (Singleton M))"
| "rderiv0 (bs1, bs2) (Subset M1 M2) = (case (bs2 ! M1, bs2 ! M2) of
(True, False) \<Rightarrow> FBool False
| _ \<Rightarrow> FBase (Subset M1 M2))"
| "rderiv0 (bs1, bs2) (In b m M) = (case (bs1 ! m, bs2 ! M) of
(True, True) \<Rightarrow> FBase (In True m M)
| (True, False) \<Rightarrow> FBase (In False m M)
| _ \<Rightarrow> FBase (In b m M))"
| "rderiv0 (bs1, bs2) (Eq_Max b m M) = (case (bs1 ! m, bs2 ! M) of
(True, True) \<Rightarrow> if b then FBool False else FBase (Eq_Max True m M)
| (True, False) \<Rightarrow> if b then FBool False else FBase (Eq_Max False m M)
| (False, True) \<Rightarrow> if b then FBase (Eq_Max True m M) else FBool False
| (False, False) \<Rightarrow> FBase (Eq_Max b m M))"
| "rderiv0 (bs1, bs2) (Eq_Min b m M) = (case (bs1 ! m, bs2 ! M) of
(True, True) \<Rightarrow> FBase (Eq_Min True m M)
| (False, False) \<Rightarrow> FBase (Eq_Min b m M)
| _ \<Rightarrow> FBase (Eq_Min False m M))"
| "rderiv0 (bs1, bs2) (Eq_Union M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<or> bs2 ! M3)
then FBase (Eq_Union M1 M2 M3) else FBool False)"
| "rderiv0 (bs1, bs2) (Eq_Inter M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<and> bs2 ! M3)
then FBase (Eq_Inter M1 M2 M3) else FBool False)"
| "rderiv0 (bs1, bs2) (Eq_Diff M1 M2 M3) = (if bs2 ! M1 = (bs2 ! M2 \<and> \<not> bs2 ! M3)
then FBase (Eq_Diff M1 M2 M3) else FBool False)"
| "rderiv0 (bs1, bs2) (Disjoint M1 M2) =
(if bs2 ! M1 \<and> bs2 ! M2 then FBool False else FBase (Disjoint M1 M2))"
| "rderiv0 (bs1, bs2) (Eq_Presb l M n) = (case l of
None \<Rightarrow> if bs2 ! M then
if n = 0 then FBool False
else let l = ld n in FBase (Eq_Presb (Some l) M (n - 2 ^ l))
else FBase (Eq_Presb l M n)
| Some 0 \<Rightarrow> FBool False
| Some (Suc l) \<Rightarrow> if bs2 ! M \<and> n \<ge> 2 ^ l then FBase (Eq_Presb (Some l) M (n - 2 ^ l))
else if \<not> bs2 ! M \<and> n < 2 ^ l then FBase (Eq_Presb (Some l) M n)
else FBool False)"
primrec nullable0 where
"nullable0 (Fo m) = False"
| "nullable0 (Eq_Const i m n) = (i = Some 0)"
| "nullable0 (Less b m1 m2) = (case b of None \<Rightarrow> False | Some b \<Rightarrow> b)"
| "nullable0 (Plus_FO i m1 m2 n) = (i = Some 0)"
| "nullable0 (Eq_FO b m1 m2) = b"
| "nullable0 (Eq_SO M1 M2) = True"
| "nullable0 (Suc_SO br bl M1 M2) = (bl = br)"
| "nullable0 (Empty M) = True"
| "nullable0 (Singleton M) = False"
| "nullable0 (Subset M1 M2) = True"
| "nullable0 (In b m M) = b"
| "nullable0 (Eq_Max b m M) = b"
| "nullable0 (Eq_Min b m M) = b"
| "nullable0 (Eq_Union M1 M2 M3) = True"
| "nullable0 (Eq_Inter M1 M2 M3) = True"
| "nullable0 (Eq_Diff M1 M2 M3) = True"
| "nullable0 (Disjoint M1 M2) = True"
| "nullable0 (Eq_Presb l M n) = (n = 0 \<and> (l = Some 0 \<or> l = None))"
definition "restrict ord P = (case ord of FO \<Rightarrow> P \<noteq> {||} | SO \<Rightarrow> True)"
definition "Restrict ord i = (case ord of FO \<Rightarrow> FBase (Fo i) | SO \<Rightarrow> FBool True)"
declare [[goals_limit = 50]]
global_interpretation WS1S: Formula SUC LESS assigns nvars Extend CONS SNOC Length
extend size_atom zero \<sigma> eval downshift upshift finsert cut len restrict Restrict
lformula0 FV0 find0 wf0 decr0 satisfies0 nullable0 lderiv0 rderiv0 undefined
defines norm = "Formula_Operations.norm find0 decr0"
and nFOr = "Formula_Operations.nFOr :: formula \<Rightarrow> _"
and nFAnd = "Formula_Operations.nFAnd :: formula \<Rightarrow> _"
and nFNot = "Formula_Operations.nFNot find0 decr0 :: formula \<Rightarrow> _"
and nFEx = "Formula_Operations.nFEx find0 decr0"
and nFAll = "Formula_Operations.nFAll find0 decr0"
and decr = "Formula_Operations.decr decr0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
and find = "Formula_Operations.find find0 :: _ \<Rightarrow> _ \<Rightarrow> formula \<Rightarrow> _"
and FV = "Formula_Operations.FV FV0"
and RESTR = "Formula_Operations.RESTR Restrict :: _ \<Rightarrow> formula"
and RESTRICT = "Formula_Operations.RESTRICT Restrict FV0"
and deriv = "\<lambda>d0 (a :: atom) (\<phi> :: formula). Formula_Operations.deriv extend d0 a \<phi>"
and nullable = "\<lambda>\<phi> :: formula. Formula_Operations.nullable nullable0 \<phi>"
and fut_default = "Formula.fut_default extend zero rderiv0"
and fut = "Formula.fut extend zero find0 decr0 rderiv0"
and finalize = "Formula.finalize SUC extend zero find0 decr0 rderiv0"
and final = "Formula.final SUC extend zero find0 decr0
nullable0 rderiv0 :: idx \<Rightarrow> formula \<Rightarrow> _"
and ws1s_wf = "Formula_Operations.wf SUC (wf0 :: idx \<Rightarrow> ws1s \<Rightarrow> _)"
and ws1s_lformula = "Formula_Operations.lformula lformula0 :: formula \<Rightarrow> _"
and check_eqv = "\<lambda>idx. DAs.check_eqv
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
(final idx) (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
(final idx) (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>) (=)"
and bounded_check_eqv = "\<lambda>idx. DAs.check_eqv
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
nullable (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>)
(\<sigma> idx) (\<lambda>\<phi>. norm (RESTRICT \<phi>) :: (ws1s, order) aformula)
(\<lambda>a \<phi>. norm (deriv (lderiv0 :: _ \<Rightarrow> _ \<Rightarrow> formula) (a :: atom) \<phi>))
nullable (\<lambda>\<phi> :: formula. ws1s_wf idx \<phi> \<and> ws1s_lformula \<phi>) (=)"
and automaton = "DA.automaton
(\<lambda>a \<phi>. norm (deriv lderiv0 (a :: atom) \<phi> :: formula))"
proof
fix k idx and a :: ws1s and l assume "wf0 (SUC k idx) a" "LESS k l (SUC k idx)" "\<not> find0 k l a"
then show "wf0 idx (decr0 k l a)"
by (induct a) (unfold wf0.simps atomic.map find0.simps,
(transfer, force simp: dec_def split!: if_splits order.splits)+)
next
fix k and a :: ws1s and l assume "lformula0 a"
then show "lformula0 (decr0 k l a)" by (induct a) auto
next
fix i k and a :: ws1s and \<AA> :: interp and P assume *: "\<not> find0 k i a" "LESS k i (SUC k (#\<^sub>V \<AA>))"
and disj: "lformula0 a \<or> len P \<le> Length \<AA>"
from disj show "satisfies0 (Extend k i \<AA> P) a = satisfies0 \<AA> (decr0 k i a)"
proof
assume "lformula0 a"
then show ?thesis using *
by (induct a rule: lformula0.induct)
(auto simp: dec_def split: if_splits order.split option.splits bool.splits) \<comment> \<open>slow\<close>
next
note dec_def[simp]
assume "len P \<le> Length \<AA>"
with * show ?thesis
proof (induct a)
case Fo then show ?case by (cases k) auto
next
case Eq_Const then show ?case
by (cases k) (auto simp: Let_def len_def split: if_splits option.splits)
next
case Less then show ?case by (cases k) auto
next
case Plus_FO then show ?case
by (cases k) (auto simp: max_def len_def Let_def split: option.splits nat.splits)
next
case Eq_FO then show ?case by (cases k) auto
next
case Eq_SO then show ?case by (cases k) auto
next
case (Suc_SO br bl M1 M2) then show ?case
by (cases k) (auto simp: max_def len_def)
next
case Empty then show ?case by (cases k) auto
next
case Singleton then show ?case by (cases k) auto
next
case Subset then show ?case by (cases k) auto
next
case In then show ?case by (cases k) auto
qed (auto simp: len_def max_def split!: option.splits order.splits)
qed
next
fix idx and a :: ws1s and x assume "lformula0 a" "wf0 idx a"
then show "Formula_Operations.wf SUC wf0 idx (lderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.wf.simps Let_def split: bool.splits order.splits)
next
fix a :: ws1s and x assume "lformula0 a"
then show "Formula_Operations.lformula lformula0 (lderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.lformula.simps split: bool.splits)
next
fix idx and a :: ws1s and x assume "wf0 idx a"
then show "Formula_Operations.wf SUC wf0 idx (rderiv0 x a)"
by (induct a rule: lderiv0.induct)
(auto simp: Formula_Operations.wf.simps Let_def sorted_append
split: bool.splits order.splits nat.splits)
next
fix \<AA> :: interp and a :: ws1s
- note fmember.rep_eq[symmetric, simp]
+ note fmember_iff_member_fset[symmetric, simp]
assume "Length \<AA> = 0"
then show "nullable0 a = satisfies0 \<AA> a"
by (induct a, unfold wf0.simps nullable0.simps satisfies0.simps Let_def)
(transfer, (auto 0 3 dest: MSB_greater split: prod.splits if_splits option.splits bool.splits nat.splits) [])+ \<comment> \<open>slow\<close>
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp] upshift_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "lformula0 a" "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies Extend Length satisfies0 \<AA> (lderiv0 x a) =
satisfies0 (CONS x \<AA>) a"
proof (induct a)
case 18
then show ?case
apply (auto simp: sum_pow2_image_Suc sum_pow2_insert0 image_iff split: prod.splits)
apply presburger+
done
qed (auto split: prod.splits bool.splits)
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp] upshift_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "lformula0 a" "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies_bounded Extend Length len satisfies0 \<AA> (lderiv0 x a) =
satisfies0 (CONS x \<AA>) a"
proof (induct a)
case 18
then show ?case
apply (auto simp: sum_pow2_image_Suc sum_pow2_insert0 image_iff split: prod.splits)
apply presburger+
done
qed (auto split: prod.splits bool.splits)
next
note Formula_Operations.satisfies_gen.simps[simp] Let_def[simp]
fix x :: atom and a :: ws1s and \<AA> :: interp
assume "wf0 (#\<^sub>V \<AA>) a" "#\<^sub>V \<AA> = size_atom x"
then show "Formula_Operations.satisfies_bounded Extend Length len satisfies0 \<AA> (rderiv0 x a) =
satisfies0 (SNOC x \<AA>) a"
proof (induct a)
case Eq_Const then show ?case by (auto split: prod.splits option.splits nat.splits)
next
case Less then show ?case
by (auto split: prod.splits option.splits bool.splits) (metis fMin_less_Length less_not_sym)+
next
case (Plus_FO i m1 m2 n) then show ?case
by (auto simp: min.commute dest: fMin_less_Length
split: prod.splits option.splits nat.splits bool.splits)
next
case Eq_FO then show ?case
by (auto split: prod.splits option.splits bool.splits) (metis fMin_less_Length less_not_sym)+
next
case Eq_SO then show ?case
by (auto split: prod.splits option.splits bool.splits)
(metis assigns_less_Length finsertI1 less_not_refl)+
next
case Suc_SO then show ?case
apply (auto 2 1 split: prod.splits)
apply (metis finsert_iff gr0_implies_Suc in_fimage_Suc nat.distinct(2))
apply (metis finsert_iff in_fimage_Suc less_not_refl)
apply (metis (no_types, opaque_lifting) fimage_finsert finsertE finsertI1 finsert_commute in_fimage_Suc n_not_Suc_n)
apply (metis (no_types, opaque_lifting) assigns_less_Length order.strict_iff_order finsert_iff in_fimage_Suc not_less_eq_eq order_refl)
apply (metis assigns_less_Length fimageI finsert_iff less_irrefl_nat nat.inject)
apply (metis finsertE finsertI1 finsert_commute finsert_fminus_single in_fimage_Suc n_not_Suc_n)
apply (metis (no_types, opaque_lifting) assigns_less_Length finsertE fminus_finsert2 fminus_iff in_fimage_Suc lessI not_less_iff_gr_or_eq)
apply (metis assigns_less_Length finsert_iff lessI not_less_iff_gr_or_eq)
apply (metis assigns_less_Length fimage_finsert finsert_iff not_less_eq not_less_iff_gr_or_eq)
apply metis
apply (metis assigns_less_Length order.strict_iff_order finsert_iff in_fimage_Suc not_less_eq_eq order_refl)
apply (metis Suc_leI assigns_less_Length fimageI finsert_iff le_eq_less_or_eq lessI less_imp_not_less)
apply (metis assigns_less_Length fimageE finsertI1 finsert_fminus_if fminus_finsert_absorb lessI less_not_sym)
apply (metis assigns_less_Length order.strict_iff_order finsert_iff not_less_eq_eq order_refl)
apply (metis assigns_less_Length order.strict_iff_order finsert_iff not_less_eq_eq order_refl)
apply (metis assigns_less_Length fimage_Suc_inj fimage_finsert finsert_absorb finsert_iff less_not_refl nat.distinct(2))
apply (metis assigns_less_Length fimage_Suc_inj fimage_finsert finsertI1 finsert_absorb less_not_refl)
apply (metis assigns_less_Length fimage_Suc_inj fimage_finsert finsert_absorb finsert_iff less_not_refl nat.distinct(2))
apply (metis assigns_less_Length fimage_Suc_inj fimage_finsert finsertI1 finsert_absorb2 less_not_refl)
done
next
case In then show ?case by (auto split: prod.splits) (metis fMin_less_Length less_not_sym)+
next
case (Eq_Max b m M) then show ?case
by (auto split: prod.splits bool.splits)
(metis fMax_less_Length less_not_sym, (metis fMin_less_Length less_not_sym)+)
next
case Eq_Min then show ?case
by (auto split: prod.splits bool.splits) (metis fMin_less_Length less_not_sym)+
next
case Eq_Union then show ?case
by (auto 0 0 simp add: fset_eq_iff split: prod.splits) (metis assigns_less_Length less_not_refl)+
next
case Eq_Inter then show ?case
by (auto 0 0 simp add: fset_eq_iff split: prod.splits) (metis assigns_less_Length less_not_refl)+
next
case Eq_Diff then show ?case
by (auto 0 1 simp add: fset_eq_iff split: prod.splits) (metis assigns_less_Length less_not_refl)+
next
let ?f = "sum ((^) (2 :: nat))"
- note fmember.rep_eq[symmetric, simp]
+ note fmember_iff_member_fset[symmetric, simp]
case (Eq_Presb l M n)
moreover
let ?M = "fset (M\<^bsup>\<AA>\<^esup>SO)" and ?L = "Length \<AA>"
have "?f (insert ?L ?M) = 2 ^ ?L + ?f ?M"
by (subst sum.insert) auto
moreover have "n > 0 \<Longrightarrow> 2 ^ Max {i. 2 ^ i \<le> n} \<le> n"
using Max_in[of "{i. 2 ^ i \<le> n}", simplified, OF exI[of _ 0]] by auto
moreover
{ have "?f ?M \<le> ?f {0 ..< ?L}" by (rule sum_mono2) auto
also have "\<dots> = 2 ^ ?L - 1" by (rule sum_pow2_upto)
also have "\<dots> < 2 ^ ?L" by simp
finally have "?f ?M < 2 ^ ?L" .
}
moreover have "Max {i. 2 ^ i \<le> 2 ^ ?L + ?f ?M} = ?L"
proof (intro Max_eqI, safe)
fix y assume "2 ^ y \<le> 2 ^ ?L + ?f ?M"
{ assume "?L < y"
then have "(2 :: nat) ^ ?L + 2 ^ ?L \<le> 2 ^ y"
by (cases y) (auto simp: less_Suc_eq_le numeral_eq_Suc add_le_mono)
also note \<open>2 ^ y \<le> 2 ^ ?L + ?f ?M\<close>
finally have " 2 ^ ?L \<le> ?f ?M" by simp
with \<open>?f ?M < 2 ^ ?L\<close> have False by auto
} then show "y \<le> ?L" by (intro leI) blast
qed auto
ultimately show ?case by (auto split: prod.splits option.splits nat.splits)
qed (auto split: prod.splits)
next
fix a :: ws1s and \<AA> \<BB> :: interp
assume "wf0 (#\<^sub>V \<BB>) a" "#\<^sub>V \<AA> = #\<^sub>V \<BB>" "(\<And>m k. LESS k m (#\<^sub>V \<BB>) \<Longrightarrow> m\<^bsup>\<AA>\<^esup>k = m\<^bsup>\<BB>\<^esup>k)" "lformula0 a"
then show "satisfies0 \<AA> a \<longleftrightarrow> satisfies0 \<BB> a" by (induct a) auto
next
fix a :: ws1s
assume "lformula0 a"
moreover
define d where "d = Formula_Operations.deriv extend lderiv0"
define \<Phi> :: "_ \<Rightarrow> (ws1s, order) aformula set"
where "\<Phi> a =
(case a of
Fo m \<Rightarrow> {FBase (Fo m), FBool True}
| Eq_Const None m n \<Rightarrow> {FBase (Eq_Const None m i) | i . i \<le> n} \<union> {FBool True, FBool False}
| Less None m1 m2 \<Rightarrow> {FBase (Less None m1 m2), FBase (Fo m2), FBool True, FBool False}
| Plus_FO None m1 m2 n \<Rightarrow> {FBase (Eq_Const None m1 i) | i . i \<le> n} \<union>
{FBase (Plus_FO None m1 m2 n), FBool True, FBool False}
| Eq_FO False m1 m2 \<Rightarrow> {FBase (Eq_FO False m1 m2), FBool True, FBool False}
| Eq_SO M1 M2 \<Rightarrow> {FBase (Eq_SO M1 M2), FBool False}
| Suc_SO False bl M1 M2 \<Rightarrow> {FBase (Suc_SO False True M1 M2), FBase (Suc_SO False False M1 M2),
FBool False}
| Empty M \<Rightarrow> {FBase (Empty M), FBool False}
| Singleton M \<Rightarrow> {FBase (Singleton M), FBase (Empty M), FBool False}
| Subset M1 M2 \<Rightarrow> {FBase (Subset M1 M2), FBool False}
| In False i I \<Rightarrow> {FBase (In False i I), FBool True, FBool False}
| Eq_Max False m M \<Rightarrow> {FBase (Eq_Max False m M), FBase (Empty M), FBool False}
| Eq_Min False m M \<Rightarrow> {FBase (Eq_Min False m M), FBool True, FBool False}
| Eq_Union M1 M2 M3 \<Rightarrow> {FBase (Eq_Union M1 M2 M3), FBool False}
| Eq_Inter M1 M2 M3 \<Rightarrow> {FBase (Eq_Inter M1 M2 M3), FBool False}
| Eq_Diff M1 M2 M3 \<Rightarrow> {FBase (Eq_Diff M1 M2 M3), FBool False}
| Disjoint M1 M2 \<Rightarrow> {FBase (Disjoint M1 M2), FBool False}
| Eq_Presb None M n \<Rightarrow> {FBase (Eq_Presb None M i) | i . i \<le> n} \<union> {FBool False}
| _ \<Rightarrow> {})" for a
{ fix xs
note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
from \<open>lformula0 a\<close> have "FBase a \<in> \<Phi> a" by auto
moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
by (auto simp: d_def split: atomic.splits list.splits bool.splits if_splits option.splits)
then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a" by (induct xs) auto
ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
}
moreover have "finite (\<Phi> a)" using \<open>lformula0 a\<close> unfolding \<Phi>_def by (auto split: atomic.splits)
ultimately show "finite {fold d xs (FBase a) | xs. True}" by (blast intro: finite_subset)
next
fix a :: ws1s
define d where "d = Formula_Operations.deriv extend rderiv0"
define \<Phi> :: "_ \<Rightarrow> (ws1s, order) aformula set"
where "\<Phi> a =
(case a of
Fo m \<Rightarrow> {FBase (Fo m), FBool True}
| Eq_Const i m n \<Rightarrow>
{FBase (Eq_Const (Some j) m n) | j . j \<le> (case i of Some i \<Rightarrow> max i n | _ \<Rightarrow> n)} \<union>
{FBase (Eq_Const None m n)}
| Less b m1 m2 \<Rightarrow> {FBase (Less None m1 m2), FBase (Less (Some True) m1 m2),
FBase (Less (Some False) m1 m2)}
| Plus_FO i m1 m2 n \<Rightarrow>
{FBase (Plus_FO (Some j) m1 m2 n) | j . j \<le> (case i of Some i \<Rightarrow> max i n | _ \<Rightarrow> n)} \<union>
{FBase (Plus_FO None m1 m2 n)}
| Eq_FO b m1 m2 \<Rightarrow> {FBase (Eq_FO True m1 m2), FBase (Eq_FO False m1 m2)}
| Eq_SO M1 M2 \<Rightarrow> {FBase (Eq_SO M1 M2), FBool False}
| Suc_SO br bl M1 M2 \<Rightarrow> {FBase (Suc_SO False True M1 M2), FBase (Suc_SO False False M1 M2),
FBase (Suc_SO True True M1 M2), FBase (Suc_SO True False M1 M2), FBool False}
| Empty M \<Rightarrow> {FBase (Empty M), FBool False}
| Singleton M \<Rightarrow> {FBase (Singleton M), FBase (Empty M), FBool False}
| Subset M1 M2 \<Rightarrow> {FBase (Subset M1 M2), FBool False}
| In b i I \<Rightarrow> {FBase (In True i I), FBase (In False i I)}
| Eq_Max b m M \<Rightarrow> {FBase (Eq_Max False m M), FBase (Eq_Max True m M), FBool False}
| Eq_Min b m M \<Rightarrow> {FBase (Eq_Min False m M), FBase (Eq_Min True m M)}
| Eq_Union M1 M2 M3 \<Rightarrow> {FBase (Eq_Union M1 M2 M3), FBool False}
| Eq_Inter M1 M2 M3 \<Rightarrow> {FBase (Eq_Inter M1 M2 M3), FBool False}
| Eq_Diff M1 M2 M3 \<Rightarrow> {FBase (Eq_Diff M1 M2 M3), FBool False}
| Disjoint M1 M2 \<Rightarrow> {FBase (Disjoint M1 M2), FBool False}
| Eq_Presb i M n \<Rightarrow> {FBase (Eq_Presb (Some l) M j) | j l .
j \<le> (case i of Some i \<Rightarrow> max i n | _ \<Rightarrow> n) \<and> l \<le> (case i of Some i \<Rightarrow> max i n | _ \<Rightarrow> n)} \<union>
{FBase (Eq_Presb None M n), FBool False})" for a
{ fix xs
note Formula_Operations.fold_deriv_FBool[simp] Formula_Operations.deriv.simps[simp] \<Phi>_def[simp]
then have "FBase a \<in> \<Phi> a" by (auto split: atomic.splits option.splits)
moreover have "\<And>x \<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> d x \<phi> \<in> \<Phi> a"
by (auto simp add: d_def Let_def not_le gr0_conv_Suc leD[OF ld_bounded]
split: atomic.splits list.splits bool.splits if_splits option.splits nat.splits)
then have "\<And>\<phi>. \<phi> \<in> \<Phi> a \<Longrightarrow> fold d xs \<phi> \<in> \<Phi> a"
by (induct xs) auto
ultimately have "fold d xs (FBase a) \<in> \<Phi> a" by blast
}
moreover have "finite (\<Phi> a)" unfolding \<Phi>_def using [[simproc add: finite_Collect]]
by (auto split: atomic.splits)
ultimately show "finite {fold d xs (FBase a) | xs. True}" by (blast intro: finite_subset)
next
fix k l and a :: ws1s
show "find0 k l a \<longleftrightarrow> l \<in> FV0 k a" by (induct a rule: find0.induct) auto
next
fix a :: ws1s and k :: order
show "finite (FV0 k a)" by (cases k) (induct a, auto)+
next
fix idx a k v
assume "wf0 idx a" "v \<in> FV0 k a"
then show "LESS k v idx" by (cases k) (induct a, auto)+
next
fix idx k i
assume "LESS k i idx"
then show "Formula_Operations.wf SUC wf0 idx (Restrict k i)"
unfolding Restrict_def by (cases k) (auto simp: Formula_Operations.wf.simps)
next
fix k and i :: nat
show "Formula_Operations.lformula lformula0 (Restrict k i)"
unfolding Restrict_def by (cases k) (auto simp: Formula_Operations.lformula.simps)
next
fix i \<AA> k P r
assume "i\<^bsup>\<AA>\<^esup>k = P"
then show "restrict k P \<longleftrightarrow>
Formula_Operations.satisfies_gen Extend Length satisfies0 r \<AA> (Restrict k i)"
unfolding restrict_def Restrict_def
by (cases k) (auto simp: Formula_Operations.satisfies_gen.simps)
qed (auto simp: Extend_commute_unsafe downshift_def upshift_def fimage_iff Suc_le_eq len_def
dec_def eval_def cut_def len_downshift_helper dest!: CONS_surj
dest: fMax_ge fMax_ffilter_less fMax_boundedD fsubset_fsingletonD
split!: order.splits if_splits)
(*Workaround for code generation*)
lemma check_eqv_code[code]: "check_eqv idx r s =
((ws1s_wf idx r \<and> ws1s_lformula r) \<and> (ws1s_wf idx s \<and> ws1s_lformula s) \<and>
(case rtrancl_while (\<lambda>(p, q). final idx p = final idx q)
(\<lambda>(p, q). map (\<lambda>a. (norm (deriv lderiv0 a p), norm (deriv lderiv0 a q))) (\<sigma> idx))
(norm (RESTRICT r), norm (RESTRICT s)) of
None \<Rightarrow> False
| Some ([], x) \<Rightarrow> True
| Some (a # list, x) \<Rightarrow> False))"
unfolding check_eqv_def WS1S.check_eqv_def WS1S.step_alt ..
definition while where [code del, code_abbrev]: "while idx \<phi> = while_default (fut_default idx \<phi>)"
declare while_default_code[of "fut_default idx \<phi>" for idx \<phi>, folded while_def, code]
lemma check_eqv_sound:
"\<lbrakk>#\<^sub>V \<AA> = idx; check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (WS1S.sat \<AA> \<phi> \<longleftrightarrow> WS1S.sat \<AA> \<psi>)"
unfolding check_eqv_def by (rule WS1S.check_eqv_soundness)
lemma bounded_check_eqv_sound:
"\<lbrakk>#\<^sub>V \<AA> = idx; bounded_check_eqv idx \<phi> \<psi>\<rbrakk> \<Longrightarrow> (WS1S.sat\<^sub>b \<AA> \<phi> \<longleftrightarrow> WS1S.sat\<^sub>b \<AA> \<psi>)"
unfolding bounded_check_eqv_def by (rule WS1S.bounded_check_eqv_soundness)
method_setup check_equiv = \<open>
let
fun tac ctxt =
let
val conv = @{computation_check terms: Trueprop
"0 :: nat" "1 :: nat" "2 :: nat" "3 :: nat" Suc
"plus :: nat \<Rightarrow> _" "minus :: nat \<Rightarrow> _"
"times :: nat \<Rightarrow> _" "divide :: nat \<Rightarrow> _" "modulo :: nat \<Rightarrow> _"
"0 :: int" "1 :: int" "2 :: int" "3 :: int" "-1 :: int"
check_eqv datatypes: formula "int list" integer idx
"nat \<times> nat" "nat option" "bool option"} ctxt
in
CONVERSION (Conv.params_conv ~1 (K (Conv.concl_conv ~1 conv)) ctxt) THEN'
resolve_tac ctxt [TrueI]
end
in
Scan.succeed (SIMPLE_METHOD' o tac)
end
\<close>
end
diff --git a/thys/Incredible_Proof_Machine/Abstract_Rules_To_Incredible.thy b/thys/Incredible_Proof_Machine/Abstract_Rules_To_Incredible.thy
--- a/thys/Incredible_Proof_Machine/Abstract_Rules_To_Incredible.thy
+++ b/thys/Incredible_Proof_Machine/Abstract_Rules_To_Incredible.thy
@@ -1,126 +1,126 @@
theory Abstract_Rules_To_Incredible
imports
Main
"HOL-Library.FSet"
"HOL-Library.Stream"
Incredible_Deduction
Abstract_Rules
begin
text \<open>In this theory, the abstract rules given in @{theory Incredible_Proof_Machine.Abstract_Rules} are used to
create a proper signature.\<close>
text \<open>Besides the rules given there, we have nodes for assumptions, conclusions, and the helper
block.\<close>
datatype ('form, 'rule) graph_node = Assumption 'form | Conclusion 'form | Rule 'rule | Helper
type_synonym ('form, 'var) in_port = "('form, 'var) antecedent"
type_synonym 'form reg_out_port = "'form"
type_synonym 'form hyp = "'form"
datatype ('form, 'var) out_port = Reg "'form reg_out_port" | Hyp "'form hyp" "('form, 'var) in_port"
type_synonym ('v, 'form, 'var) edge' = "(('v \<times> ('form, 'var) out_port) \<times> ('v \<times> ('form, 'var) in_port))"
context Abstract_Task
begin
definition nodes :: "('form, 'rule) graph_node stream" where
"nodes = Helper ## shift (map Assumption assumptions) (shift (map Conclusion conclusions) (smap Rule rules))"
lemma Helper_in_nodes[simp]:
"Helper \<in> sset nodes" by (simp add: nodes_def)
lemma Assumption_in_nodes[simp]:
"Assumption a \<in> sset nodes \<longleftrightarrow> a \<in> set assumptions" by (auto simp add: nodes_def stream.set_map)
lemma Conclusion_in_nodes[simp]:
"Conclusion c \<in> sset nodes \<longleftrightarrow> c \<in> set conclusions" by (auto simp add: nodes_def stream.set_map)
lemma Rule_in_nodes[simp]:
"Rule r \<in> sset nodes \<longleftrightarrow> r \<in> sset rules" by (auto simp add: nodes_def stream.set_map)
fun inPorts' :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port list" where
"inPorts' (Rule r) = antecedent r"
|"inPorts' (Assumption r) = []"
|"inPorts' (Conclusion r) = [ plain_ant r ]"
|"inPorts' Helper = [ plain_ant anyP ]"
fun inPorts :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port fset" where
"inPorts (Rule r) = f_antecedent r"
|"inPorts (Assumption r) = {||}"
|"inPorts (Conclusion r) = {| plain_ant r |}"
|"inPorts Helper = {| plain_ant anyP |}"
lemma inPorts_fset_of:
"inPorts n = fset_from_list (inPorts' n)"
- by (cases n rule: inPorts.cases) (auto simp: fmember.rep_eq f_antecedent_def)
+ by (cases n rule: inPorts.cases) (auto simp: fmember_iff_member_fset f_antecedent_def)
definition outPortsRule where
"outPortsRule r = ffUnion ((\<lambda> a. (\<lambda> h. Hyp h a) |`| a_hyps a) |`| f_antecedent r) |\<union>| Reg |`| f_consequent r"
lemma Reg_in_outPortsRule[simp]: "Reg c |\<in>| outPortsRule r \<longleftrightarrow> c |\<in>| f_consequent r"
- by (auto simp add: outPortsRule_def fmember.rep_eq ffUnion.rep_eq)
+ by (auto simp add: outPortsRule_def fmember_iff_member_fset ffUnion.rep_eq)
lemma Hyp_in_outPortsRule[simp]: "Hyp h c |\<in>| outPortsRule r \<longleftrightarrow> c |\<in>| f_antecedent r \<and> h |\<in>| a_hyps c"
- by (auto simp add: outPortsRule_def fmember.rep_eq ffUnion.rep_eq)
+ by (auto simp add: outPortsRule_def fmember_iff_member_fset ffUnion.rep_eq)
fun outPorts where
"outPorts (Rule r) = outPortsRule r"
|"outPorts (Assumption r) = {|Reg r|}"
|"outPorts (Conclusion r) = {||}"
|"outPorts Helper = {| Reg anyP |}"
fun labelsIn where
"labelsIn _ p = a_conc p"
fun labelsOut where
"labelsOut _ (Reg p) = p"
| "labelsOut _ (Hyp h c) = h"
fun hyps where
"hyps (Rule r) (Hyp h a) = (if a |\<in>| f_antecedent r \<and> h |\<in>| a_hyps a then Some a else None)"
| "hyps _ _ = None"
fun local_vars :: "('form, 'rule) graph_node \<Rightarrow> ('form, 'var) in_port \<Rightarrow> 'var set" where
"local_vars _ a = a_fresh a"
sublocale Labeled_Signature nodes inPorts outPorts hyps labelsIn labelsOut
proof(standard,goal_cases)
case (1 n p1 p2)
thus ?case by(induction n p1 rule: hyps.induct) (auto split: if_splits)
qed
lemma hyps_for_conclusion[simp]: "hyps_for (Conclusion n) p = {||}"
using hyps_for_subset by auto
lemma hyps_for_Helper[simp]: "hyps_for Helper p = {||}"
using hyps_for_subset by auto
lemma hyps_for_Rule[simp]: "ip |\<in>| f_antecedent r \<Longrightarrow> hyps_for (Rule r) ip = (\<lambda> h. Hyp h ip) |`| a_hyps ip"
by (auto elim!: hyps.elims split: if_splits)
end
text \<open>Finally, a given proof graph solves the task at hand if all the given conclusions are present
as conclusion blocks in the graph.\<close>
locale Tasked_Proof_Graph =
Abstract_Task freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP antecedent consequent rules assumptions conclusions +
Scoped_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut vidx inst edges local_vars
for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
and lconsts :: "'form \<Rightarrow> 'var set"
and closed :: "'form \<Rightarrow> bool"
and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
and subst_lconsts :: "'subst \<Rightarrow> 'var set"
and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
and anyP :: "'form"
and antecedent :: "'rule \<Rightarrow> ('form, 'var) antecedent list"
and consequent :: "'rule \<Rightarrow> 'form list"
and rules :: "'rule stream"
and assumptions :: "'form list"
and conclusions :: "'form list"
and vertices :: "'vertex fset"
and nodeOf :: "'vertex \<Rightarrow> ('form, 'rule) graph_node"
and edges :: "('vertex, 'form, 'var) edge' set"
and vidx :: "'vertex \<Rightarrow> nat"
and inst :: "'vertex \<Rightarrow> 'subst" +
assumes conclusions_present: "set (map Conclusion conclusions) \<subseteq> nodeOf ` fset vertices"
end
diff --git a/thys/Incredible_Proof_Machine/Build_Incredible_Tree.thy b/thys/Incredible_Proof_Machine/Build_Incredible_Tree.thy
--- a/thys/Incredible_Proof_Machine/Build_Incredible_Tree.thy
+++ b/thys/Incredible_Proof_Machine/Build_Incredible_Tree.thy
@@ -1,153 +1,153 @@
theory Build_Incredible_Tree
imports Incredible_Trees Natural_Deduction
begin
text \<open>
This theory constructs an incredible tree (with freshness checked only locally) from a natural
deduction tree.
\<close>
lemma image_eq_to_f:
assumes "f1 ` S1 = f2 ` S2"
obtains f where "\<And> x. x \<in> S2 \<Longrightarrow> f x \<in> S1 \<and> f1 (f x) = f2 x"
proof (atomize_elim)
from assms
have "\<forall>x. x \<in> S2 \<longrightarrow> (\<exists> y. y \<in> S1 \<and> f1 y = f2 x)" by (metis image_iff)
thus "\<exists>f. \<forall>x. x \<in> S2 \<longrightarrow> f x \<in> S1 \<and> f1 (f x) = f2 x" by metis
qed
context includes fset.lifting
begin
lemma fimage_eq_to_f:
assumes "f1 |`| S1 = f2 |`| S2"
obtains f where "\<And> x. x |\<in>| S2 \<Longrightarrow> f x |\<in>| S1 \<and> f1 (f x) = f2 x"
using assms apply transfer using image_eq_to_f by metis
end
context Abstract_Task
begin
lemma build_local_iwf:
fixes t :: "('form entailment \<times> ('rule \<times> 'form) NatRule) tree"
assumes "tfinite t"
assumes "wf t"
shows "\<exists> it. local_iwf it (fst (root t))"
using assms
proof(induction)
case (tfinite t)
from \<open>wf t\<close>
have "snd (root t) \<in> R" using wf.simps by blast
from \<open>wf t\<close>
have "eff (snd (root t)) (fst (root t)) ((fst \<circ> root) |`| cont t)" using wf.simps by blast
from \<open>wf t\<close>
have "\<And> t'. t' |\<in>| cont t \<Longrightarrow> wf t'" using wf.simps by blast
hence IH: "\<And> \<Gamma>' t'. t' |\<in>| cont t \<Longrightarrow> (\<exists>it'. local_iwf it' (fst (root t')))" using tfinite(2) by blast
then obtain its where its: "\<And> t'. t' |\<in>| cont t \<Longrightarrow> local_iwf (its t') (fst (root t'))" by metis
from \<open>eff _ _ _\<close>
show ?case
proof(cases rule: eff.cases[case_names Axiom NatRule Cut])
case (Axiom c \<Gamma>)
show ?thesis
proof (cases "c |\<in>| ass_forms")
case True (* Global assumption *)
then have "c \<in> set assumptions" by (auto simp add: ass_forms_def)
let "?it" = "INode (Assumption c) c undefined undefined [] :: ('form, 'rule, 'subst, 'var) itree"
from \<open>c \<in> set assumptions\<close>
have "local_iwf ?it (\<Gamma> \<turnstile> c)"
by (auto intro!: iwf local_fresh_check.intros)
thus ?thesis unfolding Axiom..
next
case False
obtain s where "subst s anyP = c" by atomize_elim (rule anyP_is_any)
hence [simp]: "subst s (freshen undefined anyP) = c" by (simp add: lconsts_anyP freshen_closed)
let "?it" = "HNode undefined s [] :: ('form, 'rule, 'subst, 'var) itree"
from \<open>c |\<in>| \<Gamma>\<close> False
have "local_iwf ?it (\<Gamma> \<turnstile> c)" by (auto intro: iwfH)
thus ?thesis unfolding Axiom..
qed
next
case (NatRule rule c ants \<Gamma> i s)
from \<open>natEff_Inst rule c ants\<close>
have "snd rule = c" and [simp]: "ants = f_antecedent (fst rule)" and "c \<in> set (consequent (fst rule))"
by (auto simp add: natEff_Inst.simps)
from \<open>(fst \<circ> root) |`| cont t = (\<lambda>ant. (\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant))) |`| ants\<close>
obtain to_t where "\<And> ant. ant |\<in>| ants \<Longrightarrow> to_t ant |\<in>| cont t \<and> (fst \<circ> root) (to_t ant) = ((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
by (rule fimage_eq_to_f) (rule that)
hence to_t_in_cont: "\<And> ant. ant |\<in>| ants \<Longrightarrow> to_t ant |\<in>| cont t"
and to_t_root: "\<And> ant. ant |\<in>| ants \<Longrightarrow> fst (root (to_t ant)) = ((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
by auto
let ?ants' = "map (\<lambda> ant. its (to_t ant)) (antecedent (fst rule))"
let "?it" = "INode (Rule (fst rule)) c i s ?ants' :: ('form, 'rule, 'subst, 'var) itree"
from \<open>snd (root t) \<in> R\<close>
have "fst rule \<in> sset rules"
unfolding NatRule
by (auto simp add: stream.set_map n_rules_def no_empty_conclusions )
moreover
from \<open>c \<in> set (consequent (fst rule))\<close>
have "c |\<in>| f_consequent (fst rule)" by (simp add: f_consequent_def)
moreover
{ fix ant
assume "ant \<in> set (antecedent (fst rule))"
hence "ant |\<in>| ants" by (simp add: f_antecedent_def)
from its[OF to_t_in_cont[OF this]]
have "local_iwf (its (to_t ant)) (fst (root (to_t ant)))".
also have "fst (root (to_t ant)) =
((\<lambda>p. subst s (freshen i p)) |`| a_hyps ant |\<union>| \<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))"
by (rule to_t_root[OF \<open>ant |\<in>| ants\<close>])
also have "\<dots> =
((\<lambda>h. subst s (freshen i (labelsOut (Rule (fst rule)) h))) |`| hyps_for (Rule (fst rule)) ant |\<union>| \<Gamma>
\<turnstile> subst s (freshen i (a_conc ant)))"
using \<open>ant |\<in>| ants\<close>
by auto
finally
have "local_iwf (its (to_t ant))
((\<lambda>h. subst s (freshen i (labelsOut (Rule (fst rule)) h))) |`| hyps_for (Rule (fst rule)) ant |\<union>|
\<Gamma> \<turnstile> subst s (freshen i (a_conc ant)))".
}
moreover
from NatRule(5,6)
have "local_fresh_check (Rule (fst rule)) i s (\<Gamma> \<turnstile> subst s (freshen i c))"
- by (fastforce intro!: local_fresh_check.intros simp add: all_local_vars_def fmember.rep_eq)
+ by (fastforce intro!: local_fresh_check.intros simp add: all_local_vars_def fmember_iff_member_fset)
ultimately
have "local_iwf ?it ((\<Gamma> \<turnstile> subst s (freshen i c)))"
by (intro iwf ) (auto simp add: list_all2_map2 list_all2_same)
thus ?thesis unfolding NatRule..
next
case (Cut \<Gamma> con)
obtain s where "subst s anyP = con" by atomize_elim (rule anyP_is_any)
hence [simp]: "subst s (freshen undefined anyP) = con" by (simp add: lconsts_anyP freshen_closed)
from \<open>(fst \<circ> root) |`| cont t = {|\<Gamma> \<turnstile> con|}\<close>
obtain t' where "t' |\<in>| cont t" and [simp]: "fst (root t') = (\<Gamma> \<turnstile> con)"
by (cases "cont t") auto
from \<open>t' |\<in>| cont t\<close> obtain "it'" where "local_iwf it' (\<Gamma> \<turnstile> con)" using IH by force
let "?it" = "INode Helper anyP undefined s [it'] :: ('form, 'rule, 'subst, 'var) itree"
from \<open>local_iwf it' (\<Gamma> \<turnstile> con)\<close>
have "local_iwf ?it (\<Gamma> \<turnstile> con)" by (auto intro!: iwf local_fresh_check.intros)
thus ?thesis unfolding Cut..
qed
qed
definition to_it :: "('form entailment \<times> ('rule \<times> 'form) NatRule) tree \<Rightarrow> ('form,'rule,'subst,'var) itree" where
"to_it t = (SOME it. local_iwf it (fst (root t)))"
lemma iwf_to_it:
assumes "tfinite t" and "wf t"
shows "local_iwf (to_it t) (fst (root t))"
unfolding to_it_def using build_local_iwf[OF assms] by (rule someI2_ex)
end
end
diff --git a/thys/Incredible_Proof_Machine/Incredible_Completeness.thy b/thys/Incredible_Proof_Machine/Incredible_Completeness.thy
--- a/thys/Incredible_Proof_Machine/Incredible_Completeness.thy
+++ b/thys/Incredible_Proof_Machine/Incredible_Completeness.thy
@@ -1,689 +1,689 @@
theory Incredible_Completeness
imports Natural_Deduction Incredible_Deduction Build_Incredible_Tree
begin
text \<open>
This theory takes the tree produced in @{theory Incredible_Proof_Machine.Build_Incredible_Tree}, globalizes it using
@{term globalize}, and then builds the incredible proof graph out of it.
\<close>
type_synonym 'form vertex = "('form \<times> nat list)"
type_synonym ('form, 'var) edge'' = "('form vertex, 'form, 'var) edge'"
locale Solved_Task =
Abstract_Task freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP antecedent consequent rules assumptions conclusions
for freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
and lconsts :: "'form \<Rightarrow> 'var set"
and closed :: "'form \<Rightarrow> bool"
and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
and subst_lconsts :: "'subst \<Rightarrow> 'var set"
and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
and anyP :: "'form"
and antecedent :: "'rule \<Rightarrow> ('form, 'var) antecedent list"
and consequent :: "'rule \<Rightarrow> 'form list"
and rules :: "'rule stream"
and assumptions :: "'form list"
and conclusions :: "'form list" +
assumes solved: solved
begin
text \<open>Let us get our hand on concrete trees.\<close>
definition ts :: "'form \<Rightarrow> (('form entailment) \<times> ('rule \<times> 'form) NatRule) tree" where
"ts c = (SOME t. snd (fst (root t)) = c \<and> fst (fst (root t)) |\<subseteq>| ass_forms \<and> wf t \<and> tfinite t)"
lemma
assumes "c |\<in>| conc_forms"
shows ts_conc: "snd (fst (root (ts c))) = c"
and ts_context: "fst (fst (root (ts c))) |\<subseteq>| ass_forms"
and ts_wf: "wf (ts c)"
and ts_finite[simp]: "tfinite (ts c)"
unfolding atomize_conj conj_assoc ts_def
apply (rule someI_ex)
using solved assms
by (force simp add: solved_def)
abbreviation it' where
"it' c \<equiv> globalize [fidx conc_forms c, 0] (freshenLC v_away) (to_it (ts c))"
lemma iwf_it:
assumes "c \<in> set conclusions"
shows "plain_iwf (it' c) (fst (root (ts c)))"
using assms
apply (auto simp add: ts_conc conclusions_closed intro!: iwf_globalize' iwf_to_it ts_finite ts_wf)
by (meson assumptions_closed fset_mp mem_ass_forms mem_conc_forms ts_context)
definition vertices :: "'form vertex fset" where
"vertices = Abs_fset (Union ( set (map (\<lambda> c. insert (c, []) ((\<lambda> p. (c, 0 # p)) ` (it_paths (it' c)))) conclusions)))"
lemma mem_vertices: "v |\<in>| vertices \<longleftrightarrow> (fst v \<in> set conclusions \<and> (snd v = [] \<or> snd v \<in> ((#) 0) ` it_paths (it' (fst v))))"
- unfolding vertices_def fmember.rep_eq ffUnion.rep_eq
+ unfolding vertices_def fmember_iff_member_fset ffUnion.rep_eq
by (cases v)(auto simp add: Abs_fset_inverse Bex_def )
lemma prefixeq_vertices: "(c,is) |\<in>| vertices \<Longrightarrow> prefix is' is \<Longrightarrow> (c, is') |\<in>| vertices"
by (cases is') (auto simp add: mem_vertices intro!: imageI elim: it_paths_prefix)
lemma none_vertices[simp]: "(c, []) |\<in>| vertices \<longleftrightarrow> c \<in> set conclusions"
by (simp add: mem_vertices)
lemma some_vertices[simp]: "(c, i#is) |\<in>| vertices \<longleftrightarrow> c \<in> set conclusions \<and> i = 0 \<and> is \<in> it_paths (it' c)"
by (auto simp add: mem_vertices)
lemma vertices_cases[consumes 1, case_names None Some]:
assumes "v |\<in>| vertices"
obtains c where "c \<in> set conclusions" and "v = (c, [])"
| c "is" where "c \<in> set conclusions" and "is \<in> it_paths (it' c)" and "v = (c, 0#is)"
using assms by (cases v; rename_tac "is"; case_tac "is"; auto)
lemma vertices_induct[consumes 1, case_names None Some]:
assumes "v |\<in>| vertices"
assumes "\<And> c. c \<in> set conclusions \<Longrightarrow> P (c, [])"
assumes "\<And> c is . c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> P (c, 0#is)"
shows "P v"
using assms by (cases v; rename_tac "is"; case_tac "is"; auto)
fun nodeOf :: "'form vertex \<Rightarrow> ('form, 'rule) graph_node" where
"nodeOf (pf, []) = Conclusion pf"
| "nodeOf (pf, i#is) = iNodeOf (tree_at (it' pf) is)"
fun inst where
"inst (c,[]) = empty_subst"
|"inst (c, i#is) = iSubst (tree_at (it' c) is)"
lemma terminal_is_nil[simp]: "v |\<in>| vertices \<Longrightarrow> outPorts (nodeOf v) = {||} \<longleftrightarrow> snd v = []"
by (induction v rule: nodeOf.induct)
(auto elim: iNodeOf_outPorts[rotated] iwf_it)
sublocale Vertex_Graph nodes inPorts outPorts vertices nodeOf.
definition edge_from :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) out_port)" where
"edge_from c is = ((c, 0 # is), Reg (iOutPort (tree_at (it' c) is)))"
lemma fst_edge_from[simp]: "fst (edge_from c is) = (c, 0 # is)"
by (simp add: edge_from_def)
fun in_port_at :: "('form \<times> nat list) \<Rightarrow> nat \<Rightarrow> ('form,'var) in_port" where
"in_port_at (c, []) _ = plain_ant c"
| "in_port_at (c, _#is) i = inPorts' (iNodeOf (tree_at (it' c) is)) ! i"
definition edge_to :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) in_port)" where
"edge_to c is =
(case rev is of [] \<Rightarrow> ((c, []), in_port_at (c, []) 0)
| i#is \<Rightarrow> ((c, 0 # (rev is)), in_port_at (c, (0#rev is)) i))"
lemma edge_to_Nil[simp]: "edge_to c [] = ((c, []), plain_ant c)"
by (simp add: edge_to_def)
lemma edge_to_Snoc[simp]: "edge_to c (is@[i]) = ((c, 0 # is), in_port_at ((c, 0 # is)) i)"
by (simp add: edge_to_def)
definition edge_at :: "'form \<Rightarrow> nat list => ('form, 'var) edge''" where
"edge_at c is = (edge_from c is, edge_to c is)"
lemma fst_edge_at[simp]: "fst (edge_at c is) = edge_from c is" by (simp add: edge_at_def)
lemma snd_edge_at[simp]: "snd (edge_at c is) = edge_to c is" by (simp add: edge_at_def)
lemma hyps_exist':
assumes "c \<in> set conclusions"
assumes "is \<in> it_paths (it' c)"
assumes "tree_at (it' c) is = (HNode i s ants)"
shows "subst s (freshen i anyP) \<in> hyps_along (it' c) is"
proof-
from assms(1)
have "plain_iwf (it' c) (fst (root (ts c)))" by (rule iwf_it)
moreover
note assms(2,3)
moreover
have "fst (fst (root (ts c))) |\<subseteq>| ass_forms"
by (simp add: assms(1) ts_context)
ultimately
show ?thesis by (rule iwf_hyps_exist)
qed
definition hyp_edge_to :: "'form \<Rightarrow> nat list => ('form vertex \<times> ('form,'var) in_port)" where
"hyp_edge_to c is = ((c, 0 # is), plain_ant anyP)"
(* TODO: Replace n and s by "subst s (freshen n anyP)" *)
definition hyp_edge_from :: "'form \<Rightarrow> nat list => nat \<Rightarrow> 'subst \<Rightarrow> ('form vertex \<times> ('form,'var) out_port)" where
"hyp_edge_from c is n s =
((c, 0 # hyp_port_path_for (it' c) is (subst s (freshen n anyP))),
hyp_port_h_for (it' c) is (subst s (freshen n anyP)))"
definition hyp_edge_at :: "'form \<Rightarrow> nat list => nat \<Rightarrow> 'subst \<Rightarrow> ('form, 'var) edge''" where
"hyp_edge_at c is n s = (hyp_edge_from c is n s, hyp_edge_to c is)"
lemma fst_hyp_edge_at[simp]:
"fst (hyp_edge_at c is n s) = hyp_edge_from c is n s" by (simp add:hyp_edge_at_def)
lemma snd_hyp_edge_at[simp]:
"snd (hyp_edge_at c is n s) = hyp_edge_to c is" by (simp add:hyp_edge_at_def)
inductive_set edges where
regular_edge: "c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> edge_at c is \<in> edges"
| hyp_edge: "c \<in> set conclusions \<Longrightarrow> is \<in> it_paths (it' c) \<Longrightarrow> tree_at (it' c) is = HNode n s ants \<Longrightarrow> hyp_edge_at c is n s \<in> edges"
sublocale Pre_Port_Graph nodes inPorts outPorts vertices nodeOf edges.
lemma edge_from_valid_out_port:
assumes "p \<in> it_paths (it' c)"
assumes "c \<in> set conclusions"
shows "valid_out_port (edge_from c p)"
using assms
by (auto simp add: edge_from_def intro: iwf_outPort iwf_it)
lemma edge_to_valid_in_port:
assumes "p \<in> it_paths (it' c)"
assumes "c \<in> set conclusions"
shows "valid_in_port (edge_to c p)"
using assms
apply (auto simp add: edge_to_def inPorts_fset_of split: list.split elim!: it_paths_SnocE)
apply (rule nth_mem)
apply (drule (1) iwf_length_inPorts[OF iwf_it])
apply auto
done
lemma hyp_edge_from_valid_out_port:
assumes "is \<in> it_paths (it' c)"
assumes "c \<in> set conclusions"
assumes "tree_at (it' c) is = HNode n s ants"
shows "valid_out_port (hyp_edge_from c is n s)"
using assms
by(auto simp add: hyp_edge_from_def intro: hyp_port_outPort it_paths_strict_prefix hyp_port_strict_prefix hyps_exist')
lemma hyp_edge_to_valid_in_port:
assumes "is \<in> it_paths (it' c)"
assumes "c \<in> set conclusions"
assumes "tree_at (it' c) is = HNode n s ants"
shows "valid_in_port (hyp_edge_to c is)"
using assms by (auto simp add: hyp_edge_to_def)
inductive scope' :: "'form vertex \<Rightarrow> ('form,'var) in_port \<Rightarrow> 'form \<times> nat list \<Rightarrow> bool" where
"c \<in> set conclusions \<Longrightarrow>
is' \<in> ((#) 0) ` it_paths (it' c) \<Longrightarrow>
prefix (is@[i]) is' \<Longrightarrow>
ip = in_port_at (c,is) i \<Longrightarrow>
scope' (c, is) ip (c, is')"
inductive_simps scope_simp: "scope' v i v'"
inductive_cases scope_cases: "scope' v i v'"
lemma scope_valid:
"scope' v i v' \<Longrightarrow> v' |\<in>| vertices"
by (auto elim: scope_cases)
lemma scope_valid_inport:
"v' |\<in>| vertices \<Longrightarrow> scope' v ip v' \<longleftrightarrow> (\<exists> i. fst v = fst v' \<and> prefix (snd v@[i]) (snd v') \<and> ip = in_port_at v i)"
by (cases v; cases v') (auto simp add: scope'.simps mem_vertices)
definition terminal_path_from :: "'form \<Rightarrow> nat list => ('form, 'var) edge'' list" where
"terminal_path_from c is = map (edge_at c) (rev (prefixes is))"
lemma terminal_path_from_Nil[simp]:
"terminal_path_from c [] = [edge_at c []]"
by (simp add: terminal_path_from_def)
lemma terminal_path_from_Snoc[simp]:
"terminal_path_from c (is @ [i]) = edge_at c (is@[i]) # terminal_path_from c is"
by (simp add: terminal_path_from_def)
lemma path_terminal_path_from:
"c \<in> set conclusions \<Longrightarrow>
is \<in> it_paths (it' c) \<Longrightarrow>
path (c, 0 # is) (c, []) (terminal_path_from c is)"
by (induction "is" rule: rev_induct)
(auto simp add: path_cons_simp intro!: regular_edge elim: it_paths_SnocE)
lemma edge_step:
assumes "(((a, b), ba), ((aa, bb), bc)) \<in> edges"
obtains
i where "a = aa" and "b = bb@[i]" and "bc = in_port_at (aa,bb) i" and "hyps (nodeOf (a, b)) ba = None"
| i where "a = aa" and "prefix (b@[i]) bb" and "hyps (nodeOf (a, b)) ba = Some (in_port_at (a,b) i)"
using assms
proof(cases rule: edges.cases[consumes 1, case_names Reg Hyp])
case (Reg c "is")
then obtain i where "a = aa" and "b = bb@[i]" and "bc = in_port_at (aa,bb) i" and "hyps (nodeOf (a, b)) ba = None"
by (auto elim!: edges.cases simp add: edge_at_def edge_from_def edge_to_def split: list.split list.split_asm)
thus thesis by (rule that)
next
case (Hyp c "is" n s)
let ?i = "hyp_port_i_for (it' c) is (subst s (freshen n anyP))"
from Hyp have "a = aa" and "prefix (b@[?i]) bb" and
"hyps (nodeOf (a, b)) ba = Some (in_port_at (a,b) ?i)"
by (auto simp add: edge_at_def edge_from_def edge_to_def hyp_edge_at_def hyp_edge_to_def hyp_edge_from_def
intro: hyp_port_prefix hyps_exist' hyp_port_hyps)
thus thesis by (rule that)
qed
lemma path_has_prefixes:
assumes "path v v' pth"
assumes "snd v' = []"
assumes "prefix (is' @ [i]) (snd v)"
shows "((fst v, is'), (in_port_at (fst v, is') i)) \<in> snd ` set pth"
using assms
by (induction rule: path.induct)(auto elim!: edge_step dest: prefix_snocD)
lemma in_scope: "valid_in_port (v', p') \<Longrightarrow> v \<in> scope (v', p') \<longleftrightarrow> scope' v' p' v"
proof
assume "v \<in> scope (v', p')"
hence "v |\<in>| vertices" and "\<And> pth t. path v t pth \<Longrightarrow> terminal_vertex t \<Longrightarrow> (v', p') \<in> snd ` set pth"
by (auto simp add: scope.simps)
from this
show "scope' v' p' v"
proof (induction rule: vertices_induct)
case (None c)
from None(2)[of "(c, [])" "[]", simplified, OF None(1)]
have False.
thus "scope' v' p' (c, [])"..
next
case (Some c "is")
from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close>
have "path (c, 0#is) (c, []) (terminal_path_from c is)"
by (rule path_terminal_path_from)
moreover
from \<open>c \<in> set conclusions\<close>
have "terminal_vertex (c, [])" by simp
ultimately
have "(v', p') \<in> snd ` set (terminal_path_from c is)"
by (rule Some(3))
hence "(v',p') \<in> set (map (edge_to c) (prefixes is))"
unfolding terminal_path_from_def by auto
then obtain is' where "prefix is' is" and "(v',p') = edge_to c is'"
by auto
show "scope' v' p' (c, 0#is)"
proof(cases "is'" rule: rev_cases)
case Nil
with \<open>(v',p') = edge_to c is'\<close>
have "v' = (c, [])" and "p' = plain_ant c"
by (auto simp add: edge_to_def)
with \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close>
show ?thesis by (auto intro!: scope'.intros)
next
case (snoc is'' i)
with \<open>(v',p') = edge_to c is'\<close>
have "v' = (c, 0 # is'')" and "p' = in_port_at v' i"
by (auto simp add: edge_to_def)
with \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close> \<open>prefix is' is\<close>[unfolded snoc]
show ?thesis
by (auto intro!: scope'.intros)
qed
qed
next
assume "valid_in_port (v', p')"
assume "scope' v' p' v"
then obtain c is' i "is" where
"v' = (c, is')" and "v = (c, is)" and "c \<in> set conclusions" and
"p' = in_port_at v' i" and
"is \<in> (#) 0 ` it_paths (it' c)" and "prefix (is' @ [i]) is"
by (auto simp add: scope'.simps)
from \<open>scope' v' p' v\<close>
have "(c, is) |\<in>| vertices" unfolding \<open>v = _\<close> by (rule scope_valid)
hence "(c, is) \<in> scope ((c, is'), p')"
proof(rule scope.intros)
fix pth t
assume "path (c,is) t pth"
assume "terminal_vertex t"
hence "snd t = []" by auto
from path_has_prefixes[OF \<open>path (c,is) t pth\<close> \<open>snd t = []\<close>, simplified, OF \<open>prefix (is' @ [i]) is\<close>]
show "((c, is'), p') \<in> snd ` set pth" unfolding \<open>p' = _ \<close> \<open>v' = _ \<close>.
qed
thus "v \<in> scope (v', p')" using \<open>v =_\<close> \<open>v' = _\<close> by simp
qed
sublocale Port_Graph nodes inPorts outPorts vertices nodeOf edges
proof
show "nodeOf ` fset vertices \<subseteq> sset nodes"
- apply (auto simp add: fmember.rep_eq[symmetric] mem_vertices)
+ apply (auto simp add: fmember_iff_member_fset[symmetric] mem_vertices)
apply (auto simp add: stream.set_map dest: iNodeOf_tree_at[OF iwf_it])
done
next
have "\<forall> e \<in> edges. valid_out_port (fst e) \<and> valid_in_port (snd e)"
by (auto elim!: edges.cases simp add: edge_at_def
dest: edge_from_valid_out_port edge_to_valid_in_port
dest: hyp_edge_from_valid_out_port hyp_edge_to_valid_in_port)
thus "\<forall>(ps1, ps2)\<in>edges. valid_out_port ps1 \<and> valid_in_port ps2" by auto
qed
sublocale Scoped_Graph nodes inPorts outPorts vertices nodeOf edges hyps..
lemma hyps_free_path_length:
assumes "path v v' pth"
assumes "hyps_free pth"
shows "length pth + length (snd v') = length (snd v)"
using assms by induction (auto elim!: edge_step )
fun vidx :: "'form vertex \<Rightarrow> nat" where
"vidx (c, []) = isidx [fidx conc_forms c]"
|"vidx (c, _#is) = iAnnot (tree_at (it' c) is)"
lemma my_vidx_inj: "inj_on vidx (fset vertices)"
by (rule inj_onI)
- (auto simp add: mem_vertices[unfolded fmember.rep_eq] iAnnot_globalize simp del: iAnnot.simps)
+ (auto simp add: mem_vertices[unfolded fmember_iff_member_fset] iAnnot_globalize simp del: iAnnot.simps)
lemma vidx_not_v_away[simp]: "v |\<in>| vertices \<Longrightarrow> vidx v \<noteq> v_away"
by (cases v rule:vidx.cases) (auto simp add: iAnnot_globalize simp del: iAnnot.simps)
sublocale Instantiation inPorts outPorts nodeOf hyps nodes edges vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst
proof
show "inj_on vidx (fset vertices)" by (rule my_vidx_inj)
qed
sublocale Well_Scoped_Graph nodes inPorts outPorts vertices nodeOf edges hyps
proof
fix v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2 p'
assume assms: "((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> edges" "hyps (nodeOf v\<^sub>1) p\<^sub>1 = Some p'"
from assms(1) hyps_correct[OF assms(2)]
have "valid_out_port (v\<^sub>1, p\<^sub>1)" and "valid_in_port (v\<^sub>2, p\<^sub>2)" and "valid_in_port (v\<^sub>1, p')" and "v\<^sub>2 |\<in>| vertices"
using valid_edges by auto
from assms
have "\<exists> i. fst v\<^sub>1 = fst v\<^sub>2 \<and> prefix (snd v\<^sub>1@[i]) (snd v\<^sub>2) \<and> p' = in_port_at v\<^sub>1 i"
by (cases v\<^sub>1; cases v\<^sub>2; auto elim!: edge_step)
hence "scope' v\<^sub>1 p' v\<^sub>2"
unfolding scope_valid_inport[OF \<open>v\<^sub>2 |\<in>| vertices\<close>].
hence "v\<^sub>2 \<in> scope (v\<^sub>1, p')"
unfolding in_scope[OF \<open>valid_in_port (v\<^sub>1, p')\<close>].
thus "(v\<^sub>2, p\<^sub>2) = (v\<^sub>1, p') \<or> v\<^sub>2 \<in> scope (v\<^sub>1, p')" ..
qed
sublocale Acyclic_Graph nodes inPorts outPorts vertices nodeOf edges hyps
proof
fix v pth
assume "path v v pth" and "hyps_free pth"
from hyps_free_path_length[OF this]
show "pth = []" by simp
qed
sublocale Saturated_Graph nodes inPorts outPorts vertices nodeOf edges
proof
fix v p
assume "valid_in_port (v, p)"
thus "\<exists>e\<in>edges. snd e = (v, p)"
proof(induction v)
fix c cis
assume "valid_in_port ((c, cis), p)"
hence "c \<in> set conclusions" by (auto simp add: mem_vertices)
show "\<exists>e\<in>edges. snd e = ((c, cis), p)"
proof(cases cis)
case Nil
with \<open>valid_in_port ((c, cis), p)\<close>
have [simp]: "p = plain_ant c" by simp
have "[] \<in> it_paths (it' c)" by simp
with \<open>c \<in> set conclusions\<close>
have "edge_at c [] \<in> edges" by (rule regular_edge)
moreover
have "snd (edge_at c []) = ((c, []), plain_ant c)"
by (simp add: edge_to_def)
ultimately
show ?thesis by (auto simp add: Nil simp del: snd_edge_at)
next
case (Cons c' "is")
with \<open>valid_in_port ((c, cis), p)\<close>
have [simp]: "c' = 0" and "is \<in> it_paths (it' c)"
and "p |\<in>| inPorts (iNodeOf (tree_at (it' c) is))" by auto
from this(3) obtain i where
"i < length (inPorts' (iNodeOf (tree_at (it' c) is)))" and
"p = inPorts' (iNodeOf (tree_at (it' c) is)) ! i"
by (auto simp add: inPorts_fset_of in_set_conv_nth)
show ?thesis
proof (cases "tree_at (it' c) is")
case [simp]: (RNode r ants)
show ?thesis
proof(cases r)
case I
hence "\<not> isHNode (tree_at (it' c) is)" by simp
from iwf_length_inPorts_not_HNode[OF iwf_it[OF \<open>c \<in> set conclusions\<close>] \<open>is \<in> it_paths (it' c)\<close> this]
\<open>i < length (inPorts' (iNodeOf (tree_at (it' c) is)))\<close>
have "i < length (children (tree_at (it' c) is))" by simp
with \<open>is \<in> it_paths (it' c)\<close>
have "is@[i] \<in> it_paths (it' c)" by (rule it_path_SnocI)
from \<open>c \<in> set conclusions\<close> this
have "edge_at c (is@[i]) \<in> edges" by (rule regular_edge)
moreover
have "snd (edge_at c (is@[i])) = ((c, 0 # is), inPorts' (iNodeOf (tree_at (it' c) is)) ! i)"
by (simp add: edge_to_def)
ultimately
show ?thesis by (auto simp add: Cons \<open>p = _\<close> simp del: snd_edge_at)
next
case (H n s)
hence "tree_at (it' c) is = HNode n s ants" by simp
from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close> this
have "hyp_edge_at c is n s \<in> edges"..
moreover
from H \<open>p |\<in>| inPorts (iNodeOf (tree_at (it' c) is))\<close>
have [simp]: "p = plain_ant anyP" by simp
have "snd (hyp_edge_at c is n s) = ((c, 0 # is), p)"
by (simp add: hyp_edge_to_def)
ultimately
show ?thesis by (auto simp add: Cons simp del: snd_hyp_edge_at)
qed
qed
qed
qed
qed
sublocale Pruned_Port_Graph nodes inPorts outPorts vertices nodeOf edges
proof
fix v
assume "v |\<in>| vertices"
thus "\<exists>pth v'. path v v' pth \<and> terminal_vertex v'"
proof(induct rule: vertices_induct)
case (None c)
hence "terminal_vertex (c,[])" by simp
with path.intros(1)
show ?case by blast
next
case (Some c "is")
hence "path (c, 0 # is) (c, []) (terminal_path_from c is)"
by (rule path_terminal_path_from)
moreover
have "terminal_vertex (c,[])" using Some(1) by simp
ultimately
show ?case by blast
qed
qed
sublocale Well_Shaped_Graph nodes inPorts outPorts vertices nodeOf edges hyps..
sublocale sol:Solution inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP vidx inst edges
proof
fix v\<^sub>1 p\<^sub>1 v\<^sub>2 p\<^sub>2
assume "((v\<^sub>1, p\<^sub>1), (v\<^sub>2, p\<^sub>2)) \<in> edges"
thus "labelAtOut v\<^sub>1 p\<^sub>1 = labelAtIn v\<^sub>2 p\<^sub>2"
proof(cases rule:edges.cases)
case (regular_edge c "is")
from \<open>((v\<^sub>1, p\<^sub>1), v\<^sub>2, p\<^sub>2) = edge_at c is\<close>
have "(v\<^sub>1,p\<^sub>1) = edge_from c is" using fst_edge_at by (metis fst_conv)
hence [simp]: "v\<^sub>1 = (c, 0 # is)" by (simp add: edge_from_def)
show ?thesis
proof(cases "is" rule:rev_cases)
case Nil
let "?t'" = "it' c"
have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t') (freshen (vidx v\<^sub>1) (iOutPort ?t'))"
using regular_edge Nil by (simp add: labelAtOut_def edge_at_def edge_from_def)
also have "vidx v\<^sub>1 = iAnnot ?t'" by (simp add: Nil)
also have "subst (iSubst ?t') (freshen (iAnnot ?t') (iOutPort ?t')) = snd (fst (root (ts c)))"
unfolding iwf_subst_freshen_outPort[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]]..
also have "\<dots> = c" using \<open>c \<in> set conclusions\<close> by (simp add: ts_conc)
also have "\<dots> = labelAtIn v\<^sub>2 p\<^sub>2"
using \<open>c \<in> set conclusions\<close> regular_edge Nil
by (simp add: labelAtIn_def edge_at_def freshen_closed conclusions_closed closed_no_lconsts)
finally show ?thesis.
next
case (snoc is' i)
let "?t1" = "tree_at (it' c) (is'@[i])"
let "?t2" = "tree_at (it' c) is'"
have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t1) (freshen (vidx v\<^sub>1) (iOutPort ?t1))"
using regular_edge snoc by (simp add: labelAtOut_def edge_at_def edge_from_def)
also have "vidx v\<^sub>1 = iAnnot ?t1" using snoc regular_edge(3) by simp
also have "subst (iSubst ?t1) (freshen (iAnnot ?t1) (iOutPort ?t1))
= subst (iSubst ?t2) (freshen (iAnnot ?t2) (a_conc (inPorts' (iNodeOf ?t2) ! i)))"
by (rule iwf_edge_match[OF iwf_it[OF \<open>c \<in> set conclusions\<close>] \<open>is \<in> it_paths (it' c)\<close>[unfolded snoc]])
also have "iAnnot ?t2 = vidx (c, 0 # is')" by simp
also have "subst (iSubst ?t2) (freshen (vidx (c, 0 # is')) (a_conc (inPorts' (iNodeOf ?t2) ! i))) = labelAtIn v\<^sub>2 p\<^sub>2"
using regular_edge snoc by (simp add: labelAtIn_def edge_at_def)
finally show ?thesis.
qed
next
case (hyp_edge c "is" n s ants)
let ?f = "subst s (freshen n anyP)"
let ?h = "hyp_port_h_for (it' c) is ?f"
let ?his = "hyp_port_path_for (it' c) is ?f"
let "?t1" = "tree_at (it' c) ?his"
let "?t2" = "tree_at (it' c) is"
from \<open>c \<in> set conclusions\<close> \<open>is \<in> it_paths (it' c)\<close> \<open>tree_at (it' c) is = HNode n s ants\<close>
have "?f \<in> hyps_along (it' c) is"
by (rule hyps_exist')
from \<open>((v\<^sub>1, p\<^sub>1), v\<^sub>2, p\<^sub>2) = hyp_edge_at c is n s\<close>
have "(v\<^sub>1,p\<^sub>1) = hyp_edge_from c is n s" using fst_hyp_edge_at by (metis fst_conv)
hence [simp]: "v\<^sub>1 = (c, 0 # ?his)" by (simp add: hyp_edge_from_def)
have "labelAtOut v\<^sub>1 p\<^sub>1 = subst (iSubst ?t1) (freshen (vidx v\<^sub>1) (labelsOut (iNodeOf ?t1) ?h))"
using hyp_edge by (simp add: hyp_edge_at_def hyp_edge_from_def labelAtOut_def)
also have "vidx v\<^sub>1 = iAnnot ?t1" by simp
also have "subst (iSubst ?t1) (freshen (iAnnot ?t1) (labelsOut (iNodeOf ?t1) ?h)) = ?f" using \<open>?f \<in> hyps_along (it' c) is\<close> by (rule local.hyp_port_eq[symmetric])
also have "\<dots> = subst (iSubst ?t2) (freshen (iAnnot ?t2) anyP)" using hyp_edge by simp
also have "subst (iSubst ?t2) (freshen (iAnnot ?t2) anyP) = labelAtIn v\<^sub>2 p\<^sub>2"
using hyp_edge by (simp add: labelAtIn_def hyp_edge_at_def hyp_edge_to_def)
finally show ?thesis.
qed
qed
lemma node_disjoint_fresh_vars:
assumes "n \<in> sset nodes"
assumes "i < length (inPorts' n)"
assumes "i' < length (inPorts' n)"
shows "a_fresh (inPorts' n ! i) \<inter> a_fresh (inPorts' n ! i') = {} \<or> i = i'"
using assms no_multiple_local_consts
by (fastforce simp add: nodes_def stream.set_map)
sublocale Well_Scoped_Instantiation freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut vidx inst edges local_vars
proof
fix v p var v'
assume "valid_in_port (v, p)"
hence "v |\<in>| vertices" by simp
obtain c "is" where "v = (c,is)" by (cases v, auto)
from \<open>valid_in_port (v, p)\<close> \<open>v= _\<close>
have "(c,is) |\<in>| vertices" and "p |\<in>| inPorts (nodeOf (c, is))" by simp_all
hence "c \<in> set conclusions" by (simp add: mem_vertices)
from \<open>p |\<in>| _\<close> obtain i where
"i < length (inPorts' (nodeOf (c, is)))" and
"p = inPorts' (nodeOf (c, is)) ! i" by (auto simp add: inPorts_fset_of in_set_conv_nth)
hence "p = in_port_at (c, is) i" by (cases "is") auto
assume "v' |\<in>| vertices"
then obtain c' is' where "v' = (c',is')" by (cases v', auto)
assume "var \<in> local_vars (nodeOf v) p"
hence "var \<in> a_fresh p" by simp
assume "freshenLC (vidx v) var \<in> subst_lconsts (inst v')"
then obtain is'' where "is' = 0#is''" and "is'' \<in> it_paths (it' c')"
using \<open>v' |\<in>| vertices\<close>
by (cases is') (auto simp add: \<open>v'=_\<close>)
note \<open>freshenLC (vidx v) var \<in> subst_lconsts (inst v')\<close>
also
have "subst_lconsts (inst v') = subst_lconsts (iSubst (tree_at (it' c') is''))"
by (simp add: \<open>v'=_\<close> \<open>is'=_\<close>)
also
from \<open>is'' \<in> it_paths (it' c')\<close>
have "\<dots> \<subseteq> fresh_at_path (it' c') is'' \<union> range (freshenLC v_away)"
by (rule globalize_local_consts)
finally
have "freshenLC (vidx v) var \<in> fresh_at_path (it' c') is''"
using \<open>v |\<in>| vertices\<close> by auto
then obtain is''' where "prefix is''' is''" and "freshenLC (vidx v) var \<in> fresh_at (it' c') is'''"
unfolding fresh_at_path_def by auto
then obtain i' is'''' where "prefix (is''''@[i']) is''"
and "freshenLC (vidx v) var \<in> fresh_at (it' c') (is''''@[i'])"
using append_butlast_last_id[where xs = is''', symmetric]
apply (cases "is''' = []")
apply (auto simp del: fresh_at_snoc append_butlast_last_id)
apply metis
done
from \<open>is'' \<in> it_paths (it' c')\<close> \<open>prefix (is''''@[i']) is''\<close>
have "(is''''@[i']) \<in> it_paths (it' c')" by (rule it_paths_prefix)
hence "is'''' \<in> it_paths (it' c')" using append_prefixD it_paths_prefix by blast
from this \<open>freshenLC (vidx v) var \<in> fresh_at (it' c') (is''''@[i'])\<close>
have "c = c' \<and> is = 0 # is'''' \<and> var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')"
unfolding fresh_at_def' using \<open>v |\<in>| vertices\<close> \<open>v' |\<in>| vertices\<close>
apply (cases "is")
apply (auto split: if_splits simp add: iAnnot_globalize it_paths_butlast \<open>v=_\<close> \<open>v'=_\<close> \<open>is'=_\<close> simp del: iAnnot.simps)
done
hence "c' = c" and "is = 0 # is''''" and "var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')" by simp_all
from \<open>(is''''@[i']) \<in> it_paths (it' c')\<close>
have "i' < length (inPorts' (nodeOf (c, is)))"
using iwf_length_inPorts[OF iwf_it[OF \<open>c \<in> set conclusions\<close>]]
by (auto elim!: it_paths_SnocE simp add: \<open>is=_\<close> \<open>c' = _\<close> order.strict_trans2)
have "nodeOf (c, is) \<in> sset nodes"
unfolding \<open>is = _\<close> \<open>c' = _\<close> nodeOf.simps
by (rule iNodeOf_tree_at[OF iwf_it[OF \<open>c \<in> set conclusions\<close>] \<open>is'''' \<in> it_paths (it' c')\<close>[unfolded \<open>c' = _\<close>]])
from \<open>var \<in> a_fresh (inPorts' (iNodeOf (tree_at (it' c') is'''')) ! i')\<close>
\<open>var \<in> a_fresh p\<close> \<open>p = inPorts' (nodeOf (c, is)) ! i\<close>
node_disjoint_fresh_vars[OF
\<open>nodeOf (c, is) \<in> sset nodes\<close>
\<open>i < length (inPorts' (nodeOf (c, is)))\<close> \<open>i' < length (inPorts' (nodeOf (c, is)))\<close>]
have "i' = i" by (auto simp add: \<open>is=_\<close> \<open>c'=c\<close>)
from \<open>prefix (is''''@[i']) is''\<close>
have "prefix (is @ [i']) is'" by (simp add: \<open>is'=_\<close> \<open>is=_\<close>)
from \<open>c \<in> set conclusions\<close> \<open>is'' \<in> it_paths (it' c')\<close> \<open>prefix (is @ [i']) is'\<close>
\<open>p = in_port_at (c, is) i\<close>
have "scope' v p v'"
unfolding \<open>v=_\<close> \<open>v'=_\<close> \<open>c' = _\<close> \<open>is' = _\<close> \<open>i'=_\<close> by (auto intro: scope'.intros)
thus "v' \<in> scope (v, p)" using \<open>valid_in_port (v, p)\<close> by (simp add: in_scope)
qed
sublocale Scoped_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP inPorts outPorts nodeOf hyps nodes vertices labelsIn labelsOut vidx inst edges local_vars..
(* interpretation of @{term Tasked_Proof_Graph} has to be named to avoid name clashes in @{term Abstract_Task}. *)
sublocale tpg:Tasked_Proof_Graph freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP antecedent consequent rules assumptions conclusions
vertices nodeOf edges vidx inst
proof
show "set (map Conclusion conclusions) \<subseteq> nodeOf ` fset vertices"
proof-
{
fix c
assume "c \<in> set conclusions"
hence "(c, []) |\<in>| vertices" by simp
hence "nodeOf (c, []) \<in> nodeOf ` fset vertices"
- unfolding fmember.rep_eq by (rule imageI)
+ unfolding fmember_iff_member_fset by (rule imageI)
hence "Conclusion c \<in> nodeOf ` fset vertices" by simp
} thus ?thesis by auto
qed
qed
end
end
diff --git a/thys/Incredible_Proof_Machine/Incredible_Correctness.thy b/thys/Incredible_Proof_Machine/Incredible_Correctness.thy
--- a/thys/Incredible_Proof_Machine/Incredible_Correctness.thy
+++ b/thys/Incredible_Proof_Machine/Incredible_Correctness.thy
@@ -1,554 +1,554 @@
theory Incredible_Correctness
imports
Abstract_Rules_To_Incredible
Natural_Deduction
begin
text \<open>
In this theory, we prove that if we have a graph that proves a given abstract task (which is
represented as the context @{term Tasked_Proof_Graph}), then we can prove @{term solved}.
\<close>
context Tasked_Proof_Graph
begin
definition adjacentTo :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex \<times> ('form, 'var) out_port)" where
"adjacentTo v p = (SOME ps. (ps, (v,p)) \<in> edges)"
fun isReg where
"isReg v p = (case p of Hyp h c \<Rightarrow> False | Reg c \<Rightarrow>
(case nodeOf v of
Conclusion a \<Rightarrow> False
| Assumption a \<Rightarrow> False
| Rule r \<Rightarrow> True
| Helper \<Rightarrow> True
))"
fun toNatRule where
"toNatRule v p = (case p of Hyp h c \<Rightarrow> Axiom | Reg c \<Rightarrow>
(case nodeOf v of
Conclusion a \<Rightarrow> Axiom \<comment> \<open>a lie\<close>
| Assumption a \<Rightarrow> Axiom
| Rule r \<Rightarrow> NatRule (r,c)
| Helper \<Rightarrow> Cut
))"
inductive_set global_assms' :: "'var itself \<Rightarrow> 'form set" for i where
"v |\<in>| vertices \<Longrightarrow> nodeOf v = Assumption p \<Longrightarrow> labelAtOut v (Reg p) \<in> global_assms' i"
lemma finite_global_assms': "finite (global_assms' i)"
proof-
have "finite (fset vertices)" by (rule finite_fset)
moreover
have "global_assms' i \<subseteq> (\<lambda> v. case nodeOf v of Assumption p \<Rightarrow> labelAtOut v (Reg p)) ` fset vertices"
- by (force simp add: global_assms'.simps fmember.rep_eq image_iff )
+ by (force simp add: global_assms'.simps fmember_iff_member_fset image_iff )
ultimately
show ?thesis by (rule finite_surj)
qed
context includes fset.lifting
begin
lift_definition global_assms :: "'var itself \<Rightarrow> 'form fset" is global_assms' by (rule finite_global_assms')
lemmas global_assmsI = global_assms'.intros[Transfer.transferred]
lemmas global_assms_simps = global_assms'.simps[Transfer.transferred]
end
fun extra_assms :: "('vertex \<times> ('form, 'var) in_port) \<Rightarrow> 'form fset" where
"extra_assms (v, p) = (\<lambda> p. labelAtOut v p) |`| hyps_for (nodeOf v) p"
fun hyps_along :: "('vertex, 'form, 'var) edge' list \<Rightarrow> 'form fset" where
"hyps_along pth = ffUnion (extra_assms |`| snd |`| fset_from_list pth) |\<union>| global_assms TYPE('var)"
lemma hyps_alongE[consumes 1, case_names Hyp Assumption]:
assumes "f |\<in>| hyps_along pth"
obtains v p h where "(v,p) \<in> snd ` set pth" and "f = labelAtOut v h " and "h |\<in>| hyps_for (nodeOf v) p"
| v pf where "v |\<in>| vertices" and "nodeOf v = Assumption pf" "f = labelAtOut v (Reg pf)"
using assms
- apply (auto simp add: fmember.rep_eq ffUnion.rep_eq global_assms_simps[unfolded fmember.rep_eq])
+ apply (auto simp add: fmember_iff_member_fset ffUnion.rep_eq global_assms_simps[unfolded fmember_iff_member_fset])
apply (metis image_iff snd_conv)
done
text \<open>Here we build the natural deduction tree, by walking the graph.\<close>
primcorec tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' list \<Rightarrow> (('form entailment), ('rule \<times> 'form) NatRule) dtree" where
"root (tree v p pth) =
((hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p),
(case adjacentTo v p of (v', p') \<Rightarrow> toNatRule v' p'
))"
| "cont (tree v p pth) =
(case adjacentTo v p of (v', p') \<Rightarrow>
(if isReg v' p' then ((\<lambda> p''. tree v' p'' ((adjacentTo v p,(v,p))#pth)) |`| inPorts (nodeOf v')) else {||}
))"
lemma fst_root_tree[simp]: "fst (root (tree v p pth)) = (hyps_along ((adjacentTo v p,(v,p))#pth) \<turnstile> labelAtIn v p)" by simp
lemma out_port_cases[consumes 1, case_names Assumption Hyp Rule Helper]:
assumes "p |\<in>| outPorts n"
obtains
a where "n = Assumption a" and "p = Reg a"
| r h c where "n = Rule r" and "p = Hyp h c"
| r f where "n = Rule r" and "p = Reg f"
| "n = Helper" and "p = Reg anyP"
using assms by (atomize_elim, cases p; cases n) auto
lemma hyps_for_fimage: "hyps_for (Rule r) x = (if x |\<in>| f_antecedent r then (\<lambda> f. Hyp f x) |`| (a_hyps x) else {||})"
apply (rule fset_eqI)
apply (rename_tac p')
apply (case_tac p')
apply (auto simp add: split: if_splits out_port.splits)
done
text \<open>Now we prove that the thus produced tree is well-formed.\<close>
theorem wf_tree:
assumes "valid_in_port (v,p)"
assumes "terminal_path v t pth"
shows "wf (tree v p pth)"
using assms
proof (coinduction arbitrary: v p pth)
case (wf v p pth)
let ?t = "tree v p pth"
from saturated[OF wf(1)]
obtain v' p'
where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)
let ?e = "((v',p'),(v,p))"
let ?pth' = "?e#pth"
let ?\<Gamma> = "hyps_along ?pth'"
let ?l = "labelAtIn v p"
from e valid_edges have "v' |\<in>| vertices" and "p' |\<in>| outPorts (nodeOf v')" by auto
hence "nodeOf v' \<in> sset nodes" using valid_nodes by (meson image_eqI notin_fset subsetD)
from \<open>?e \<in> edges\<close>
have s: "labelAtOut v' p' = labelAtIn v p" by (rule solved)
from \<open>p' |\<in>| outPorts (nodeOf v')\<close>
show ?case
proof (cases rule: out_port_cases)
case (Hyp r h c)
from Hyp \<open>p' |\<in>| outPorts (nodeOf v')\<close>
have "h |\<in>| a_hyps c" and "c |\<in>| f_antecedent r" by auto
hence "hyps (nodeOf v') (Hyp h c) = Some c" using Hyp by simp
from well_scoped[OF \<open> _ \<in> edges\<close>[unfolded Hyp] this]
have "(v, p) = (v', c) \<or> v \<in> scope (v', c)".
hence "(v', c) \<in> insert (v, p) (snd ` set pth)"
proof
assume "(v, p) = (v', c)"
thus ?thesis by simp
next
assume "v \<in> scope (v', c)"
from this terminal_path_end_is_terminal[OF wf(2)] terminal_path_is_path[OF wf(2)]
have "(v', c) \<in> snd ` set pth" by (rule scope_find)
thus ?thesis by simp
qed
moreover
from \<open>hyps (nodeOf v') (Hyp h c) = Some c\<close>
have "Hyp h c |\<in>| hyps_for (nodeOf v') c" by simp
hence "labelAtOut v' (Hyp h c) |\<in>| extra_assms (v',c)" by auto
ultimately
have "labelAtOut v' (Hyp h c) |\<in>| ?\<Gamma>"
- by (fastforce simp add: fmember.rep_eq ffUnion.rep_eq)
+ by (fastforce simp add: fmember_iff_member_fset ffUnion.rep_eq)
- hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Hyp fmember.rep_eq)
+ hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Hyp fmember_iff_member_fset)
thus ?thesis
using Hyp
apply (auto intro: exI[where x = ?t] simp add: eff.simps simp del: hyps_along.simps)
done
next
case (Assumption f)
from \<open>v' |\<in>| vertices\<close> \<open>nodeOf v' = Assumption f\<close>
have "labelAtOut v' (Reg f) |\<in>| global_assms TYPE('var)"
by (rule global_assmsI)
hence "labelAtOut v' (Reg f) |\<in>| ?\<Gamma>" by auto
- hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Assumption fmember.rep_eq)
+ hence "labelAtIn v p |\<in>| ?\<Gamma>" by (simp add: s[symmetric] Assumption fmember_iff_member_fset)
thus ?thesis using Assumption
by (auto intro: exI[where x = ?t] simp add: eff.simps)
next
case (Rule r f)
with \<open>nodeOf v' \<in> sset nodes\<close>
have "r \<in> sset rules"
by (auto simp add: nodes_def stream.set_map)
from Rule
have "hyps (nodeOf v') p' = None" by simp
with e \<open>terminal_path v t pth\<close>
have "terminal_path v' t ?pth'"..
from Rule \<open>p' |\<in>| outPorts (nodeOf v')\<close>
have "f |\<in>| f_consequent r" by simp
hence "f \<in> set (consequent r)" by (simp add: f_consequent_def)
with \<open>r \<in> sset rules\<close>
have "NatRule (r, f) \<in> sset (smap NatRule n_rules)"
by (auto simp add: stream.set_map n_rules_def no_empty_conclusions)
moreover
{
from \<open>f |\<in>| f_consequent r\<close>
have "f \<in> set (consequent r)" by (simp add: f_consequent_def)
hence "natEff_Inst (r, f) f (f_antecedent r)"
by (rule natEff_Inst.intros)
hence "eff (NatRule (r, f)) (?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') f))
((\<lambda>ant. ((\<lambda>p. subst (inst v') (freshen (vidx v') p)) |`| a_hyps ant |\<union>| ?\<Gamma> \<turnstile> subst (inst v') (freshen (vidx v') (a_conc ant)))) |`| f_antecedent r)"
(is "eff _ _ ?ants")
proof (rule eff.intros)
fix ant f
assume "ant |\<in>| f_antecedent r"
from \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
have "valid_in_port (v',ant)" by (simp add: Rule)
assume "f |\<in>| ?\<Gamma>"
thus "freshenLC (vidx v') ` a_fresh ant \<inter> lconsts f = {}"
proof(induct rule: hyps_alongE)
case (Hyp v'' p'' h'')
from Hyp(1) snd_set_path_verties[OF terminal_path_is_path[OF \<open>terminal_path v' t ?pth'\<close>]]
- have "v'' |\<in>| vertices" by (force simp add: fmember.rep_eq)
+ have "v'' |\<in>| vertices" by (force simp add: fmember_iff_member_fset)
from \<open>terminal_path v' t ?pth'\<close> Hyp(1)
have "v'' \<notin> scope (v', ant)" by (rule hyps_free_path_not_in_scope)
with \<open>valid_in_port (v',ant)\<close> \<open>v'' |\<in>| vertices\<close>
have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v'') = {}"
by (rule out_of_scope)
moreover
from hyps_free_vertices_distinct'[OF \<open>terminal_path v' t ?pth'\<close>] Hyp.hyps(1)
have "v'' \<noteq> v'" by (metis distinct.simps(2) fst_conv image_eqI list.set_map)
hence "vidx v'' \<noteq> vidx v'" using \<open>v' |\<in>| vertices\<close> \<open>v'' |\<in>| vertices\<close> by (meson vidx_inj inj_onD notin_fset)
hence "freshenLC (vidx v') ` a_fresh ant \<inter> freshenLC (vidx v'') ` lconsts (labelsOut (nodeOf v'') h'') = {}"by auto
moreover
have "lconsts f \<subseteq> lconsts (freshen (vidx v'') (labelsOut (nodeOf v'') h'')) \<union> subst_lconsts (inst v'') " using \<open>f = _\<close>
by (simp add: labelAtOut_def fv_subst)
ultimately
show ?thesis
by (fastforce simp add: lconsts_freshen)
next
case (Assumption v pf)
hence "f = subst (inst v) (freshen (vidx v) pf)" by (simp add: labelAtOut_def)
moreover
- from Assumption have "Assumption pf \<in> sset nodes" using valid_nodes by (auto simp add: fmember.rep_eq)
+ from Assumption have "Assumption pf \<in> sset nodes" using valid_nodes by (auto simp add: fmember_iff_member_fset)
hence "pf \<in> set assumptions" unfolding nodes_def by (auto simp add: stream.set_map)
hence "closed pf" by (rule assumptions_closed)
ultimately
have "lconsts f = {}" by (simp add: closed_no_lconsts lconsts_freshen subst_closed freshen_closed)
thus ?thesis by simp
qed
next
fix ant
assume "ant |\<in>| f_antecedent r"
from \<open>v' |\<in>| vertices\<close> \<open>ant |\<in>| f_antecedent r\<close>
have "valid_in_port (v',ant)" by (simp add: Rule)
moreover
note \<open>v' |\<in>| vertices\<close>
moreover
hence "v' \<notin> scope (v', ant)" by (rule scopes_not_refl)
ultimately
have "freshenLC (vidx v') ` local_vars (nodeOf v') ant \<inter> subst_lconsts (inst v') = {}"
by (rule out_of_scope)
thus "freshenLC (vidx v') ` a_fresh ant \<inter> subst_lconsts (inst v') = {}" by simp
qed
also
have "subst (inst v') (freshen (vidx v') f) = labelAtOut v' p'" using Rule by (simp add: labelAtOut_def)
also
note \<open>labelAtOut v' p' = labelAtIn v p\<close>
also
have "?ants = ((\<lambda>x. (extra_assms (v',x) |\<union>| hyps_along ?pth' \<turnstile> labelAtIn v' x)) |`| f_antecedent r)"
by (rule fimage_cong[OF refl])
- (auto simp add: labelAtIn_def labelAtOut_def Rule hyps_for_fimage fmember.rep_eq ffUnion.rep_eq)
+ (auto simp add: labelAtIn_def labelAtOut_def Rule hyps_for_fimage fmember_iff_member_fset ffUnion.rep_eq)
finally
have "eff (NatRule (r, f))
(?\<Gamma>, labelAtIn v p)
((\<lambda>x. extra_assms (v',x) |\<union>| ?\<Gamma> \<turnstile> labelAtIn v' x) |`| f_antecedent r)".
}
moreover
{ fix x
assume "x |\<in>| cont ?t"
then obtain a where "x = tree v' a ?pth'" and "a |\<in>| f_antecedent r"
by (auto simp add: Rule)
note this(1)
moreover
from \<open>v' |\<in>| vertices\<close> \<open>a |\<in>| f_antecedent r\<close>
have "valid_in_port (v',a)" by (simp add: Rule)
moreover
note \<open>terminal_path v' t ?pth'\<close>
ultimately
have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and> terminal_path v t pth"
by blast
}
ultimately
show ?thesis using Rule
by (auto intro!: exI[where x = ?t] simp add: comp_def funion_assoc)
next
case Helper
from Helper
have "hyps (nodeOf v') p' = None" by simp
with e \<open>terminal_path v t pth\<close>
have "terminal_path v' t ?pth'"..
have "labelAtIn v' (plain_ant anyP) = labelAtIn v p"
unfolding s[symmetric]
using Helper by (simp add: labelAtIn_def labelAtOut_def)
moreover
{ fix x
assume "x |\<in>| cont ?t"
hence "x = tree v' (plain_ant anyP) ?pth'"
by (auto simp add: Helper)
note this(1)
moreover
from \<open>v' |\<in>| vertices\<close>
have "valid_in_port (v',plain_ant anyP)" by (simp add: Helper)
moreover
note \<open>terminal_path v' t ?pth'\<close>
ultimately
have "\<exists>v p pth. x = tree v p pth \<and> valid_in_port (v,p) \<and> terminal_path v t pth"
by blast
}
ultimately
show ?thesis using Helper
by (auto intro!: exI[where x = ?t] simp add: comp_def funion_assoc )
qed
qed
lemma global_in_ass: "global_assms TYPE('var) |\<subseteq>| ass_forms"
proof
fix x
assume "x |\<in>| global_assms TYPE('var)"
then obtain v pf where "v |\<in>| vertices" and "nodeOf v = Assumption pf" and "x = labelAtOut v (Reg pf)"
by (auto simp add: global_assms_simps)
from this (1,2) valid_nodes
- have "Assumption pf \<in> sset nodes" by (auto simp add: fmember.rep_eq)
+ have "Assumption pf \<in> sset nodes" by (auto simp add: fmember_iff_member_fset)
hence "pf \<in> set assumptions" by (auto simp add: nodes_def stream.set_map)
hence "closed pf" by (rule assumptions_closed)
with \<open>x = labelAtOut v (Reg pf)\<close>
have "x = pf" by (auto simp add: labelAtOut_def lconsts_freshen closed_no_lconsts freshen_closed subst_closed)
thus "x |\<in>| ass_forms" using \<open>pf \<in> set assumptions\<close> by (auto simp add: ass_forms_def)
qed
primcorec edge_tree :: "'vertex \<Rightarrow> ('form, 'var) in_port \<Rightarrow> ('vertex, 'form, 'var) edge' tree" where
"root (edge_tree v p) = (adjacentTo v p, (v,p))"
| "cont (edge_tree v p) =
(case adjacentTo v p of (v', p') \<Rightarrow>
(if isReg v' p' then ((\<lambda> p. edge_tree v' p) |`| inPorts (nodeOf v')) else {||}
))"
lemma tfinite_map_tree: "tfinite (map_tree f t) \<longleftrightarrow> tfinite t"
proof
assume "tfinite (map_tree f t)"
thus "tfinite t"
by (induction "map_tree f t" arbitrary: t rule: tfinite.induct)
(fastforce intro: tfinite.intros simp add: tree.map_sel)
next
assume "tfinite t"
thus "tfinite (map_tree f t)"
by (induction t rule: tfinite.induct)
(fastforce intro: tfinite.intros simp add: tree.map_sel)
qed
lemma finite_tree_edge_tree:
"tfinite (tree v p pth) \<longleftrightarrow> tfinite (edge_tree v p)"
proof-
have "map_tree (\<lambda> _. ()) (tree v p pth) = map_tree (\<lambda> _. ()) (edge_tree v p)"
by(coinduction arbitrary: v p pth)
(fastforce simp add: tree.map_sel rel_fset_def rel_set_def split: prod.split out_port.split graph_node.split option.split)
thus ?thesis by (metis tfinite_map_tree)
qed
coinductive forbidden_path :: "'vertex \<Rightarrow> ('vertex, 'form, 'var) edge' stream \<Rightarrow> bool" where
forbidden_path: "((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2)) \<in> edges \<Longrightarrow> hyps (nodeOf v\<^sub>1) p\<^sub>1 = None \<Longrightarrow> forbidden_path v\<^sub>1 pth \<Longrightarrow> forbidden_path v\<^sub>2 (((v\<^sub>1,p\<^sub>1),(v\<^sub>2,p\<^sub>2))##pth)"
lemma path_is_forbidden:
assumes "valid_in_port (v,p)"
assumes "ipath (edge_tree v p) es"
shows "forbidden_path v es"
using assms
proof(coinduction arbitrary: v p es)
case forbidden_path
let ?es' = "stl es"
from forbidden_path(2)
obtain t' where "root (edge_tree v p) = shd es" and "t' |\<in>| cont (edge_tree v p)" and "ipath t' ?es'"
by rule blast
from \<open>root (edge_tree v p) = shd es\<close>
have [simp]: "shd es = (adjacentTo v p, (v,p))" by simp
from saturated[OF \<open>valid_in_port (v,p)\<close>]
obtain v' p'
where e:"((v',p'),(v,p)) \<in> edges" and [simp]: "adjacentTo v p = (v',p')"
by (auto simp add: adjacentTo_def, metis (no_types, lifting) eq_fst_iff tfl_some)
let ?e = "((v',p'),(v,p))"
from e have "p' |\<in>| outPorts (nodeOf v')" using valid_edges by auto
thus ?case
proof(cases rule: out_port_cases)
case Hyp
with \<open>t' |\<in>| cont (edge_tree v p)\<close>
have False by auto
thus ?thesis..
next
case Assumption
with \<open>t' |\<in>| cont (edge_tree v p)\<close>
have False by auto
thus ?thesis..
next
case (Rule r f)
from \<open>t' |\<in>| cont (edge_tree v p)\<close> Rule
obtain a where [simp]: "t' = edge_tree v' a" and "a |\<in>| f_antecedent r" by auto
have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
moreover
have "?e \<in> edges" using e by simp
moreover
from \<open>p' = Reg f\<close> \<open>nodeOf v' = Rule r\<close>
have "hyps (nodeOf v') p' = None" by simp
moreover
from e valid_edges have "v' |\<in>| vertices" by auto
with \<open>nodeOf v' = Rule r\<close> \<open>a |\<in>| f_antecedent r\<close>
have "valid_in_port (v', a)" by simp
moreover
have "ipath (edge_tree v' a) ?es'" using \<open>ipath t' _\<close> by simp
ultimately
show ?thesis by metis
next
case Helper
from \<open>t' |\<in>| cont (edge_tree v p)\<close> Helper
have [simp]: "t' = edge_tree v' (plain_ant anyP)" by simp
have "es = ?e ## ?es'" by (cases es rule: stream.exhaust_sel) simp
moreover
have "?e \<in> edges" using e by simp
moreover
from \<open>p' = Reg anyP\<close> \<open>nodeOf v' = Helper\<close>
have "hyps (nodeOf v') p' = None" by simp
moreover
from e valid_edges have "v' |\<in>| vertices" by auto
with \<open>nodeOf v' = Helper\<close>
have "valid_in_port (v', plain_ant anyP)" by simp
moreover
have "ipath (edge_tree v' (plain_ant anyP)) ?es'" using \<open>ipath t' _\<close> by simp
ultimately
show ?thesis by metis
qed
qed
lemma forbidden_path_prefix_is_path:
assumes "forbidden_path v es"
obtains v' where "path v' v (rev (stake n es))"
using assms
apply (atomize_elim)
apply (induction n arbitrary: v es)
apply simp
apply (simp add: path_snoc)
apply (subst (asm) (2) forbidden_path.simps)
apply auto
done
lemma forbidden_path_prefix_is_hyp_free:
assumes "forbidden_path v es"
shows "hyps_free (rev (stake n es))"
using assms
apply (induction n arbitrary: v es)
apply (simp add: hyps_free_def)
apply (subst (asm) (2) forbidden_path.simps)
apply (force simp add: hyps_free_def)
done
text \<open>And now we prove that the tree is finite, which requires the above notion of a
@{term forbidden_path}, i.e.\@ an infinite path.\<close>
theorem finite_tree:
assumes "valid_in_port (v,p)"
assumes "terminal_vertex v"
shows "tfinite (tree v p pth)"
proof(rule ccontr)
let ?n = "Suc (fcard vertices)"
assume "\<not> tfinite (tree v p pth)"
hence "\<not> tfinite (edge_tree v p)" unfolding finite_tree_edge_tree.
then obtain es :: "('vertex, 'form, 'var) edge' stream"
where "ipath (edge_tree v p) es" using Konig by blast
with \<open>valid_in_port (v,p)\<close>
have "forbidden_path v es" by (rule path_is_forbidden)
from forbidden_path_prefix_is_path[OF this] forbidden_path_prefix_is_hyp_free[OF this]
obtain v' where "path v' v (rev (stake ?n es))" and "hyps_free (rev (stake ?n es))"
by blast
from this \<open>terminal_vertex v\<close>
have "terminal_path v' v (rev (stake ?n es))" by (rule terminal_pathI)
hence "length (rev (stake ?n es)) \<le> fcard vertices"
by (rule hyps_free_limited)
thus False by simp
qed
text \<open>The main result of this theory.\<close>
theorem solved
unfolding solved_def
proof(intro ballI allI conjI impI)
fix c
assume "c |\<in>| conc_forms"
hence "c \<in> set conclusions" by (auto simp add: conc_forms_def)
from this(1) conclusions_present
obtain v where "v |\<in>| vertices" and "nodeOf v = Conclusion c"
by (auto, metis (no_types, lifting) image_iff image_subset_iff notin_fset)
have "valid_in_port (v, (plain_ant c))"
using \<open>v |\<in>| vertices\<close> \<open>nodeOf _ = _ \<close> by simp
have "terminal_vertex v" using \<open>v |\<in>| vertices\<close> \<open>nodeOf v = Conclusion c\<close> by auto
let ?t = "tree v (plain_ant c) []"
have "fst (root ?t) = (global_assms TYPE('var), c)"
using \<open>c \<in> set conclusions\<close> \<open>nodeOf _ = _\<close>
by (auto simp add: labelAtIn_def conclusions_closed closed_no_lconsts freshen_def rename_closed subst_closed)
moreover
have "global_assms TYPE('var) |\<subseteq>| ass_forms" by (rule global_in_ass)
moreover
from \<open>terminal_vertex v\<close>
have "terminal_path v v []" by (rule terminal_path_empty)
with \<open>valid_in_port (v, (plain_ant c))\<close>
have "wf ?t" by (rule wf_tree)
moreover
from \<open>valid_in_port (v, plain_ant c)\<close> \<open>terminal_vertex v\<close>
have "tfinite ?t" by (rule finite_tree)
ultimately
show "\<exists>\<Gamma> t. fst (root t) = (\<Gamma> \<turnstile> c) \<and> \<Gamma> |\<subseteq>| ass_forms \<and> wf t \<and> tfinite t" by blast
qed
end
end
\ No newline at end of file
diff --git a/thys/Incredible_Proof_Machine/Incredible_Signatures.thy b/thys/Incredible_Proof_Machine/Incredible_Signatures.thy
--- a/thys/Incredible_Proof_Machine/Incredible_Signatures.thy
+++ b/thys/Incredible_Proof_Machine/Incredible_Signatures.thy
@@ -1,69 +1,69 @@
theory Incredible_Signatures
imports
Main
"HOL-Library.FSet"
"HOL-Library.Stream"
Abstract_Formula
begin
text \<open>This theory contains the definition for proof graph signatures, in the variants
\<^item> Plain port graph
\<^item> Port graph with local hypotheses
\<^item> Labeled port graph
\<^item> Port graph with local constants
\<close>
locale Port_Graph_Signature =
fixes nodes :: "'node stream"
fixes inPorts :: "'node \<Rightarrow> 'inPort fset"
fixes outPorts :: "'node \<Rightarrow> 'outPort fset"
locale Port_Graph_Signature_Scoped =
Port_Graph_Signature +
fixes hyps :: "'node \<Rightarrow> 'outPort \<rightharpoonup> 'inPort"
assumes hyps_correct: "hyps n p1 = Some p2 \<Longrightarrow> p1 |\<in>| outPorts n \<and> p2 |\<in>| inPorts n"
begin
inductive_set hyps_for' :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort set" for n p
where "hyps n h = Some p \<Longrightarrow> h \<in> hyps_for' n p"
lemma hyps_for'_subset: "hyps_for' n p \<subseteq> fset (outPorts n)"
using hyps_correct by (meson hyps_for'.cases notin_fset subsetI)
context includes fset.lifting
begin
lift_definition hyps_for :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'outPort fset" is hyps_for'
by (meson finite_fset hyps_for'_subset rev_finite_subset)
lemma hyps_for_simp[simp]: "h |\<in>| hyps_for n p \<longleftrightarrow> hyps n h = Some p"
by transfer (simp add: hyps_for'.simps)
lemma hyps_for_simp'[simp]: "h \<in> fset (hyps_for n p) \<longleftrightarrow> hyps n h = Some p"
by transfer (simp add: hyps_for'.simps)
lemma hyps_for_collect: "fset (hyps_for n p) = {h . hyps n h = Some p}"
by auto
end
lemma hyps_for_subset: "hyps_for n p |\<subseteq>| outPorts n"
using hyps_for'_subset
- by (fastforce simp add: fmember.rep_eq hyps_for.rep_eq simp del: hyps_for_simp hyps_for_simp')
+ by (fastforce simp add: fmember_iff_member_fset hyps_for.rep_eq simp del: hyps_for_simp hyps_for_simp')
end
locale Labeled_Signature =
Port_Graph_Signature_Scoped +
fixes labelsIn :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'form"
fixes labelsOut :: "'node \<Rightarrow> 'outPort \<Rightarrow> 'form"
locale Port_Graph_Signature_Scoped_Vars =
Port_Graph_Signature nodes inPorts outPorts +
Abstract_Formulas freshenLC renameLCs lconsts closed subst subst_lconsts subst_renameLCs anyP
for nodes :: "'node stream" and inPorts :: "'node \<Rightarrow> 'inPort fset" and outPorts :: "'node \<Rightarrow> 'outPort fset"
and freshenLC :: "nat \<Rightarrow> 'var \<Rightarrow> 'var"
and renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> 'form \<Rightarrow> 'form"
and lconsts :: "'form \<Rightarrow> 'var set"
and closed :: "'form \<Rightarrow> bool"
and subst :: "'subst \<Rightarrow> 'form \<Rightarrow> 'form"
and subst_lconsts :: "'subst \<Rightarrow> 'var set"
and subst_renameLCs :: "('var \<Rightarrow> 'var) \<Rightarrow> ('subst \<Rightarrow> 'subst)"
and anyP :: "'form" +
fixes local_vars :: "'node \<Rightarrow> 'inPort \<Rightarrow> 'var set"
end
diff --git a/thys/Incredible_Proof_Machine/Incredible_Trees.thy b/thys/Incredible_Proof_Machine/Incredible_Trees.thy
--- a/thys/Incredible_Proof_Machine/Incredible_Trees.thy
+++ b/thys/Incredible_Proof_Machine/Incredible_Trees.thy
@@ -1,642 +1,642 @@
theory Incredible_Trees
imports
"HOL-Library.Sublist"
"HOL-Library.Countable"
Entailment
Rose_Tree
Abstract_Rules_To_Incredible
begin
text \<open>This theory defines incredible trees, which carry roughly the same information
as a (tree-shaped) incredible graph, but where the structure is still given by the data type,
and not by a set of edges etc.\<close>
text \<open>
Tree-shape, but incredible-graph-like content (port names, explicit annotation and substitution)
\<close>
datatype ('form,'rule,'subst,'var) itnode =
I (iNodeOf': "('form, 'rule) graph_node")
(iOutPort': "'form reg_out_port")
(iAnnot': "nat")
(iSubst': "'subst")
| H (iAnnot': "nat")
(iSubst': "'subst")
abbreviation "INode n p i s ants \<equiv> RNode (I n p i s) ants"
abbreviation "HNode i s ants \<equiv> RNode (H i s) ants"
type_synonym ('form,'rule,'subst,'var) itree = "('form,'rule,'subst,'var) itnode rose_tree"
fun iNodeOf where
"iNodeOf (INode n p i s ants) = n"
| "iNodeOf (HNode i s ants) = Helper"
context Abstract_Formulas begin
fun iOutPort where
"iOutPort (INode n p i s ants) = p"
| "iOutPort (HNode i s ants) = anyP"
end
fun iAnnot where "iAnnot it = iAnnot' (root it)"
fun iSubst where "iSubst it = iSubst' (root it)"
fun iAnts where "iAnts it = children it"
type_synonym ('form, 'rule, 'subst) fresh_check = "('form, 'rule) graph_node \<Rightarrow> nat \<Rightarrow> 'subst \<Rightarrow> 'form entailment \<Rightarrow> bool"
context Abstract_Task
begin
text \<open>The well-formedness of the tree. The first argument can be varied, depending on whether we
are interested in the local freshness side-conditions or not.\<close>
inductive iwf :: "('form, 'rule, 'subst) fresh_check \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> 'form entailment \<Rightarrow> bool"
for fc
where
iwf: "\<lbrakk>
n \<in> sset nodes;
Reg p |\<in>| outPorts n;
list_all2 (\<lambda> ip t. iwf fc t ((\<lambda> h . subst s (freshen i (labelsOut n h))) |`| hyps_for n ip |\<union>| \<Gamma> \<turnstile> subst s (freshen i (labelsIn n ip))))
(inPorts' n) ants;
fc n i s (\<Gamma> \<turnstile> c);
c = subst s (freshen i p)
\<rbrakk> \<Longrightarrow> iwf fc (INode n p i s ants) (\<Gamma> \<turnstile> c)"
| iwfH: "\<lbrakk>
c |\<notin>| ass_forms;
c |\<in>| \<Gamma>;
c = subst s (freshen i anyP)
\<rbrakk> \<Longrightarrow> iwf fc (HNode i s []) (\<Gamma> \<turnstile> c)"
lemma iwf_subst_freshen_outPort:
"iwf lc ts ent \<Longrightarrow>
snd ent = subst (iSubst ts) (freshen (iAnnot ts) (iOutPort ts))"
by (auto elim: iwf.cases)
definition all_local_vars :: "('form, 'rule) graph_node \<Rightarrow> 'var set" where
"all_local_vars n = \<Union>(local_vars n ` fset (inPorts n))"
lemma all_local_vars_Helper[simp]:
"all_local_vars Helper = {}"
unfolding all_local_vars_def by simp
lemma all_local_vars_Assumption[simp]:
"all_local_vars (Assumption c) = {}"
unfolding all_local_vars_def by simp
text \<open>Local freshness side-conditions, corresponding what we have in the
theory \<open>Natural_Deduction\<close>.\<close>
inductive local_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
"\<lbrakk>\<And> f. f |\<in>| \<Gamma> \<Longrightarrow> freshenLC i ` (all_local_vars n) \<inter> lconsts f = {};
freshenLC i ` (all_local_vars n) \<inter> subst_lconsts s = {}
\<rbrakk> \<Longrightarrow> local_fresh_check n i s (\<Gamma> \<turnstile> c)"
abbreviation "local_iwf \<equiv> iwf local_fresh_check"
text \<open>No freshness side-conditions. Used with the tree that comes out of
\<open>globalize\<close>, where we establish the (global) freshness conditions
separately.\<close>
inductive no_fresh_check :: "('form, 'rule, 'subst) fresh_check" where
"no_fresh_check n i s (\<Gamma> \<turnstile> c)"
abbreviation "plain_iwf \<equiv> iwf no_fresh_check"
fun isHNode where
"isHNode (HNode _ _ _ ) = True"
|"isHNode _ = False"
lemma iwf_edge_match:
assumes "iwf fc t ent"
assumes "is@[i] \<in> it_paths t"
shows "subst (iSubst (tree_at t (is@[i]))) (freshen (iAnnot (tree_at t (is@[i]))) (iOutPort (tree_at t (is@[i]))))
= subst (iSubst (tree_at t is)) (freshen (iAnnot (tree_at t is)) (a_conc (inPorts' (iNodeOf (tree_at t is)) ! i)))"
using assms
apply (induction arbitrary: "is" i)
apply (auto elim!: it_paths_SnocE)[1]
apply (rename_tac "is" i)
apply (case_tac "is")
apply (auto dest!: list_all2_nthD2)[1]
using iwf_subst_freshen_outPort
apply (solves \<open>(auto)[1]\<close>)
apply (auto elim!: it_paths_ConsE dest!: list_all2_nthD2)[1]
using it_path_SnocI
apply (solves blast)
apply (solves auto)
done
lemma iwf_length_inPorts:
assumes "iwf fc t ent"
assumes "is \<in> it_paths t"
shows "length (iAnts (tree_at t is)) \<le> length (inPorts' (iNodeOf (tree_at t is)))"
using assms
by (induction arbitrary: "is" rule: iwf.induct)
(auto elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)
lemma iwf_local_not_in_subst:
assumes "local_iwf t ent"
assumes "is \<in> it_paths t"
assumes "var \<in> all_local_vars (iNodeOf (tree_at t is))"
shows "freshenLC (iAnnot (tree_at t is)) var \<notin> subst_lconsts (iSubst (tree_at t is))"
using assms
by (induction arbitrary: "is" rule: iwf.induct)
(auto 4 4 elim!: it_paths_RNodeE local_fresh_check.cases dest: list_all2_lengthD list_all2_nthD2)
lemma iwf_length_inPorts_not_HNode:
assumes "iwf fc t ent"
assumes "is \<in> it_paths t"
assumes "\<not> (isHNode (tree_at t is))"
shows "length (iAnts (tree_at t is)) = length (inPorts' (iNodeOf (tree_at t is)))"
using assms
by (induction arbitrary: "is" rule: iwf.induct)
(auto 4 4 elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)
lemma iNodeOf_outPorts:
"iwf fc t ent \<Longrightarrow> is \<in> it_paths t \<Longrightarrow> outPorts (iNodeOf (tree_at t is)) = {||} \<Longrightarrow> False"
by (induction arbitrary: "is" rule: iwf.induct)
(auto 4 4 elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)
lemma iNodeOf_tree_at:
"iwf fc t ent \<Longrightarrow> is \<in> it_paths t \<Longrightarrow> iNodeOf (tree_at t is) \<in> sset nodes"
by (induction arbitrary: "is" rule: iwf.induct)
(auto 4 4 elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)
lemma iwf_outPort:
assumes "iwf fc t ent"
assumes "is \<in> it_paths t"
shows "Reg (iOutPort (tree_at t is)) |\<in>| outPorts (iNodeOf (tree_at t is))"
using assms
by (induction arbitrary: "is" rule: iwf.induct)
(auto 4 4 elim!: it_paths_RNodeE dest: list_all2_lengthD list_all2_nthD2)
inductive_set hyps_along for t "is" where
"prefix (is'@[i]) is \<Longrightarrow>
i < length (inPorts' (iNodeOf (tree_at t is'))) \<Longrightarrow>
hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<Longrightarrow>
subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)) \<in> hyps_along t is"
lemma hyps_along_Nil[simp]: "hyps_along t [] = {}"
by (auto simp add: hyps_along.simps)
lemma prefix_app_Cons_elim:
assumes "prefix (xs@[y]) (z#zs)"
obtains "xs = []" and "y = z"
| xs' where "xs = z#xs'" and "prefix (xs'@[y]) zs"
using assms by (cases xs) auto
lemma hyps_along_Cons:
assumes "iwf fc t ent"
assumes "i#is \<in> it_paths t"
shows "hyps_along t (i#is) =
(\<lambda>h. subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))) ` fset (hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i))
\<union> hyps_along (iAnts t ! i) is" (is "?S1 = ?S2 \<union> ?S3")
proof-
from assms
have "i < length (iAnts t)" and "is \<in> it_paths (iAnts t ! i)"
by (auto elim: it_paths_ConsE)
let "?t'" = "iAnts t ! i"
show ?thesis
proof (rule; rule)
fix x
assume "x \<in> hyps_along t (i # is)"
then obtain is' i' h where
"prefix (is'@[i']) (i#is)"
and "i' < length (inPorts' (iNodeOf (tree_at t is')))"
and "hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')"
and [simp]: "x = subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))"
by (auto elim!: hyps_along.cases)
from this(1)
show "x \<in> ?S2 \<union> ?S3"
proof(cases rule: prefix_app_Cons_elim)
assume "is' = []" and "i' = i"
with \<open>hyps (iNodeOf (tree_at t is')) h = Some _\<close>
have "x \<in> ?S2" by auto
thus ?thesis..
next
fix is''
assume [simp]: "is' = i # is''" and "prefix (is'' @ [i']) is"
have "tree_at t is' = tree_at ?t' is''" by simp
note \<open>prefix (is'' @ [i']) is\<close>
\<open>i' < length (inPorts' (iNodeOf (tree_at t is')))\<close>
\<open>hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i')\<close>
from this[unfolded \<open>tree_at t is' = tree_at ?t' is''\<close>]
have "subst (iSubst (tree_at (iAnts t ! i) is'')) (freshen (iAnnot (tree_at (iAnts t ! i) is'')) (labelsOut (iNodeOf (tree_at (iAnts t ! i) is'')) h))
\<in> hyps_along (iAnts t ! i) is" by (rule hyps_along.intros)
hence "x \<in> ?S3" by simp
thus ?thesis..
qed
next
fix x
assume "x \<in> ?S2 \<union> ?S3"
thus "x \<in> ?S1"
proof
have "prefix ([]@[i]) (i#is)" by simp
moreover
from \<open>iwf _ t _\<close>
have "length (iAnts t) \<le> length (inPorts' (iNodeOf (tree_at t []))) "
by cases (auto dest: list_all2_lengthD)
with \<open>i < _\<close>
have "i < length (inPorts' (iNodeOf (tree_at t [])))" by simp
moreover
assume "x \<in> ?S2"
then obtain h where "h |\<in>| hyps_for (iNodeOf t) (inPorts' (iNodeOf t) ! i)"
and [simp]: "x = subst (iSubst t) (freshen (iAnnot t) (labelsOut (iNodeOf t) h))" by auto
from this(1)
have "hyps (iNodeOf (tree_at t [])) h = Some (inPorts' (iNodeOf (tree_at t [])) ! i)" by simp
ultimately
have "subst (iSubst (tree_at t [])) (freshen (iAnnot (tree_at t [])) (labelsOut (iNodeOf (tree_at t [])) h)) \<in> hyps_along t (i # is)"
by (rule hyps_along.intros)
thus "x \<in> hyps_along t (i # is)" by simp
next
assume "x \<in> ?S3"
thus "x \<in> ?S1"
apply (auto simp add: hyps_along.simps)
apply (rule_tac x = "i#is'" in exI)
apply auto
done
qed
qed
qed
lemma iwf_hyps_exist:
assumes "iwf lc it ent"
assumes "is \<in> it_paths it"
assumes "tree_at it is = (HNode i s ants')"
assumes "fst ent |\<subseteq>| ass_forms"
shows "subst s (freshen i anyP) \<in> hyps_along it is"
proof-
from assms(1,2,3)
have "subst s (freshen i anyP) \<in> hyps_along it is
\<or> subst s (freshen i anyP) |\<in>| fst ent
\<and> subst s (freshen i anyP) |\<notin>| ass_forms"
proof(induction arbitrary: "is" rule: iwf.induct)
case (iwf n p s' a' \<Gamma> ants c "is")
have "iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)"
using iwf(1,2,3,4,5)
by (auto intro!: iwf.intros elim!: list_all2_mono)
show ?case
proof(cases "is")
case Nil
with \<open>tree_at (INode n p a' s' ants) is = HNode i s ants'\<close>
show ?thesis by auto
next
case (Cons i' "is'")
with \<open>is \<in> it_paths (INode n p a' s' ants)\<close>
have "i' < length ants" and "is' \<in> it_paths (ants ! i')"
by (auto elim: it_paths_ConsE)
let ?\<Gamma>' = "(\<lambda>h. subst s' (freshen a' (labelsOut n h))) |`| hyps_for n (inPorts' n ! i')"
from \<open>tree_at (INode n p a' s' ants) is = HNode i s ants'\<close>
have "tree_at (ants ! i') is' = HNode i s ants'" using Cons by simp
from iwf.IH \<open>i' < length ants\<close> \<open>is' \<in> it_paths (ants ! i')\<close> this
have "subst s (freshen i anyP) \<in> hyps_along (ants ! i') is'
\<or> subst s (freshen i anyP) |\<in>| ?\<Gamma>' |\<union>| \<Gamma> \<and> subst s (freshen i anyP) |\<notin>| ass_forms"
by (auto dest: list_all2_nthD2)
moreover
from \<open>is \<in> it_paths (INode n p a' s' ants)\<close>
have "hyps_along (INode n p a' s' ants) is = fset ?\<Gamma>' \<union> hyps_along (ants ! i') is'"
using \<open>is = _\<close>
by (simp add: hyps_along_Cons[OF \<open>iwf lc (INode n p a' s' ants) (\<Gamma> \<turnstile> c)\<close>])
ultimately
show ?thesis by auto
qed
next
case (iwfH c \<Gamma> s' i' "is")
hence [simp]: "is = []" "i' = i" "s' = s" by simp_all
from \<open>c = subst s' (freshen i' anyP)\<close> \<open>c |\<in>| \<Gamma>\<close> \<open>c |\<notin>| ass_forms\<close>
show ?case by simp
qed
with assms(4)
show ?thesis by blast
qed
definition hyp_port_for' :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list \<times> nat \<times> ('form, 'var) out_port" where
"hyp_port_for' t is f = (SOME x.
(case x of (is', i, h) \<Rightarrow>
prefix (is' @ [i]) is \<and>
i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
f = subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h))
))"
lemma hyp_port_for_spec':
assumes "f \<in> hyps_along t is"
shows "(case hyp_port_for' t is f of (is', i, h) \<Rightarrow>
prefix (is' @ [i]) is \<and>
i < length (inPorts' (iNodeOf (tree_at t is'))) \<and>
hyps (iNodeOf (tree_at t is')) h = Some (inPorts' (iNodeOf (tree_at t is')) ! i) \<and>
f = subst (iSubst (tree_at t is')) (freshen (iAnnot (tree_at t is')) (labelsOut (iNodeOf (tree_at t is')) h)))"
using assms unfolding hyps_along.simps hyp_port_for'_def by -(rule someI_ex, blast)
definition hyp_port_path_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat list"
where "hyp_port_path_for t is f = fst (hyp_port_for' t is f)"
definition hyp_port_i_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> nat"
where "hyp_port_i_for t is f = fst (snd (hyp_port_for' t is f))"
definition hyp_port_h_for :: "('form, 'rule, 'subst, 'var) itree \<Rightarrow> nat list \<Rightarrow> 'form \<Rightarrow> ('form, 'var) out_port"
where "hyp_port_h_for t is f = snd (snd (hyp_port_for' t is f))"
lemma hyp_port_prefix:
assumes "f \<in> hyps_along t is"
shows "prefix (hyp_port_path_for t is f@[hyp_port_i_for t is f]) is"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def by auto
lemma hyp_port_strict_prefix:
assumes "f \<in> hyps_along t is"
shows "strict_prefix (hyp_port_path_for t is f) is"
using hyp_port_prefix[OF assms] by (simp add: strict_prefixI' prefix_order.dual_order.strict_trans1)
lemma hyp_port_it_paths:
assumes "is \<in> it_paths t"
assumes "f \<in> hyps_along t is"
shows "hyp_port_path_for t is f \<in> it_paths t"
using assms by (rule it_paths_strict_prefix[OF _ hyp_port_strict_prefix] )
lemma hyp_port_hyps:
assumes "f \<in> hyps_along t is"
shows "hyps (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f) = Some (inPorts' (iNodeOf (tree_at t (hyp_port_path_for t is f))) ! hyp_port_i_for t is f)"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto
lemma hyp_port_outPort:
assumes "f \<in> hyps_along t is"
shows "(hyp_port_h_for t is f) |\<in>| outPorts (iNodeOf (tree_at t (hyp_port_path_for t is f)))"
using hyps_correct[OF hyp_port_hyps[OF assms]]..
lemma hyp_port_eq:
assumes "f \<in> hyps_along t is"
shows "f = subst (iSubst (tree_at t (hyp_port_path_for t is f))) (freshen (iAnnot (tree_at t (hyp_port_path_for t is f))) (labelsOut (iNodeOf (tree_at t (hyp_port_path_for t is f))) (hyp_port_h_for t is f)))"
using hyp_port_for_spec'[OF assms] unfolding hyp_port_path_for_def hyp_port_i_for_def hyp_port_h_for_def by auto
definition isidx :: "nat list \<Rightarrow> nat" where "isidx xs = to_nat (Some xs)"
definition v_away :: "nat" where "v_away = to_nat (None :: nat list option)"
lemma isidx_inj[simp]: "isidx xs = isidx ys \<longleftrightarrow> xs = ys"
unfolding isidx_def by simp
lemma isidx_v_away[simp]: "isidx xs \<noteq> v_away"
unfolding isidx_def v_away_def by simp
definition mapWithIndex where "mapWithIndex f xs = map (\<lambda> (i,t) . f i t) (List.enumerate 0 xs)"
lemma mapWithIndex_cong [fundef_cong]:
"xs = ys \<Longrightarrow> (\<And>x i. x \<in> set ys \<Longrightarrow> f i x = g i x) \<Longrightarrow> mapWithIndex f xs = mapWithIndex g ys"
unfolding mapWithIndex_def by (auto simp add: in_set_enumerate_eq)
lemma mapWithIndex_Nil[simp]: "mapWithIndex f [] = []"
unfolding mapWithIndex_def by simp
lemma length_mapWithIndex[simp]: "length (mapWithIndex f xs) = length xs"
unfolding mapWithIndex_def by simp
lemma nth_mapWithIndex[simp]: "i < length xs \<Longrightarrow> mapWithIndex f xs ! i = f i (xs ! i)"
unfolding mapWithIndex_def by (auto simp add: nth_enumerate_eq)
lemma list_all2_mapWithIndex2E:
assumes "list_all2 P as bs"
assumes "\<And> i a b . i < length bs \<Longrightarrow> P a b \<Longrightarrow> Q a (f i b)"
shows "list_all2 Q as (mapWithIndex f bs)"
using assms(1)
by (auto simp add: list_all2_conv_all_nth mapWithIndex_def nth_enumerate_eq intro: assms(2) split: prod.split)
text \<open>The globalize function, which renames all local constants so that they cannot clash with
local constants occurring anywhere else in the tree.\<close>
fun globalize_node :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itnode \<Rightarrow> ('form,'rule,'subst,'var) itnode" where
"globalize_node is f (I n p i s) = I n p (isidx is) (subst_renameLCs f s)"
| "globalize_node is f (H i s) = H (isidx is) (subst_renameLCs f s)"
fun globalize :: "nat list \<Rightarrow> ('var \<Rightarrow> 'var) \<Rightarrow> ('form,'rule,'subst,'var) itree \<Rightarrow> ('form,'rule,'subst,'var) itree" where
"globalize is f (RNode r ants) = RNode
(globalize_node is f r)
(mapWithIndex (\<lambda> i' t.
globalize (is@[i'])
(rerename (a_fresh (inPorts' (iNodeOf (RNode r ants)) ! i'))
(iAnnot (RNode r ants)) (isidx is) f)
t
) ants)"
lemma iAnnot'_globalize_node[simp]: "iAnnot' (globalize_node is f n) = isidx is"
by (cases n) auto
lemma iAnnot_globalize:
assumes "is' \<in> it_paths (globalize is f t)"
shows "iAnnot (tree_at (globalize is f t) is') = isidx (is@is')"
using assms
by (induction t arbitrary: f "is" is') (auto elim!: it_paths_RNodeE)
lemma all_local_consts_listed':
assumes "n \<in> sset nodes"
assumes "p |\<in>| inPorts n"
shows "lconsts (a_conc p) \<union> (\<Union>(lconsts ` fset (a_hyps p))) \<subseteq> a_fresh p "
using assms
- by (auto simp add: nodes_def stream.set_map lconsts_anyP closed_no_lconsts conclusions_closed fmember.rep_eq f_antecedent_def dest!: all_local_consts_listed)
+ by (auto simp add: nodes_def stream.set_map lconsts_anyP closed_no_lconsts conclusions_closed fmember_iff_member_fset f_antecedent_def dest!: all_local_consts_listed)
lemma no_local_consts_in_consequences':
"n \<in> sset nodes \<Longrightarrow> Reg p |\<in>| outPorts n \<Longrightarrow> lconsts p = {}"
using no_local_consts_in_consequences
by (auto simp add: nodes_def lconsts_anyP closed_no_lconsts assumptions_closed stream.set_map f_consequent_def)
lemma iwf_globalize:
assumes "local_iwf t (\<Gamma> \<turnstile> c)"
shows "plain_iwf (globalize is f t) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
using assms
proof (induction t "\<Gamma> \<turnstile> c" arbitrary: "is" f \<Gamma> c rule: iwf.induct)
case (iwf n p s i \<Gamma> ants c "is" f)
note \<open>n \<in> sset nodes\<close>
moreover
note \<open>Reg p |\<in>| outPorts n\<close>
moreover
{ fix i'
let ?V = "a_fresh (inPorts' n ! i')"
let ?f' = "rerename ?V i (isidx is) f"
let ?t = "globalize (is @ [i']) ?f' (ants ! i')"
let ?ip = "inPorts' n ! i'"
let ?\<Gamma>' = "(\<lambda>h. subst (subst_renameLCs f s) (freshen (isidx is) (labelsOut n h))) |`| hyps_for n ?ip"
let ?c' = "subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ?ip))"
assume "i' < length (inPorts' n)"
hence "(inPorts' n ! i') |\<in>| inPorts n" by (simp add: inPorts_fset_of)
from \<open>i' < length (inPorts' n)\<close>
have subset_V: "?V \<subseteq> all_local_vars n"
unfolding all_local_vars_def
by (auto simp add: inPorts_fset_of set_conv_nth)
from \<open>local_fresh_check n i s (\<Gamma> \<turnstile> c)\<close>
have "freshenLC i ` all_local_vars n \<inter> subst_lconsts s = {}"
by (rule local_fresh_check.cases) simp
hence "freshenLC i ` ?V \<inter> subst_lconsts s = {}"
using subset_V by auto
hence rerename_subst: "subst_renameLCs ?f' s = subst_renameLCs f s"
by (rule rerename_subst_noop)
from all_local_consts_listed'[OF \<open> n \<in> sset nodes\<close> \<open>(inPorts' n ! i') |\<in>| inPorts n\<close>]
have subset_conc: "lconsts (a_conc (inPorts' n ! i')) \<subseteq> ?V"
and subset_hyp': "\<And> hyp . hyp |\<in>| a_hyps (inPorts' n ! i') \<Longrightarrow> lconsts hyp \<subseteq> ?V"
- by (auto simp add: fmember.rep_eq)
+ by (auto simp add: fmember_iff_member_fset)
from List.list_all2_nthD[OF \<open>list_all2 _ _ _\<close> \<open>i' < length (inPorts' n)\<close>,simplified]
have "plain_iwf ?t
(renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>| \<Gamma>) \<turnstile>
renameLCs ?f' (subst s (freshen i (a_conc ?ip))))"
by simp
also have "renameLCs ?f' |`| ((\<lambda>h. subst s (freshen i (labelsOut n h))) |`| hyps_for n ?ip |\<union>| \<Gamma>)
= (\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`| hyps_for n ?ip |\<union>| renameLCs ?f' |`| \<Gamma>"
by (simp add: fimage_fimage fimage_funion comp_def rename_subst)
also have "renameLCs ?f' |`| \<Gamma> = renameLCs f |`| \<Gamma>"
proof(rule fimage_cong[OF refl])
fix x
assume "x |\<in>| \<Gamma>"
with \<open>local_fresh_check n i s (\<Gamma> \<turnstile> c)\<close>
have "freshenLC i ` all_local_vars n \<inter> lconsts x = {}"
by (elim local_fresh_check.cases) simp
hence "freshenLC i ` ?V \<inter> lconsts x = {}"
using subset_V by auto
thus "renameLCs ?f' x = renameLCs f x"
by (rule rerename_rename_noop)
qed
also have "(\<lambda>x. subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n x)))) |`| hyps_for n ?ip = ?\<Gamma>'"
proof(rule fimage_cong[OF refl])
fix hyp
assume "hyp |\<in>| hyps_for n (inPorts' n ! i')"
hence "labelsOut n hyp |\<in>| a_hyps (inPorts' n ! i')"
apply (cases hyp)
apply (solves simp)
apply (cases n)
apply (auto split: if_splits)
done
from subset_hyp'[OF this]
have subset_hyp: "lconsts (labelsOut n hyp) \<subseteq> ?V".
show "subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (labelsOut n hyp))) =
subst (subst_renameLCs f s) (freshen (isidx is) (labelsOut n hyp))"
apply (simp add: freshen_def rename_rename rerename_subst)
apply (rule arg_cong[OF renameLCs_cong])
apply (auto dest: subsetD[OF subset_hyp])
done
qed
also have "renameLCs ?f' (subst s (freshen i (a_conc ?ip))) = subst (subst_renameLCs ?f' s) (renameLCs ?f' (freshen i (a_conc ?ip)))" by (simp add: rename_subst)
also have "... = ?c'"
apply (simp add: freshen_def rename_rename rerename_subst)
apply (rule arg_cong[OF renameLCs_cong])
apply (auto dest: subsetD[OF subset_conc])
done
finally
have "plain_iwf ?t (?\<Gamma>' |\<union>| renameLCs f |`| \<Gamma> \<turnstile> ?c')".
}
with list_all2_lengthD[OF \<open>list_all2 _ _ _\<close>]
have "list_all2
(\<lambda>ip t. plain_iwf t ((\<lambda>h. subst (subst_renameLCs f s)
(freshen (isidx is) (labelsOut n h))) |`| hyps_for n ip |\<union>| renameLCs f |`| \<Gamma> \<turnstile> subst (subst_renameLCs f s) (freshen (isidx is) (labelsIn n ip))))
(inPorts' n)
(mapWithIndex (\<lambda> i' t. globalize (is@[i']) (rerename (a_fresh (inPorts' n ! i')) i (isidx is) f) t) ants)"
by (auto simp add: list_all2_conv_all_nth)
moreover
have "no_fresh_check n (isidx is) (subst_renameLCs f s) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"..
moreover
from \<open>n \<in> sset nodes\<close> \<open>Reg p |\<in>| outPorts n\<close>
have "lconsts p = {}" by (rule no_local_consts_in_consequences')
with \<open>c = subst s (freshen i p)\<close>
have "renameLCs f c = subst (subst_renameLCs f s) (freshen (isidx is) p)"
by (simp add: rename_subst rename_closed freshen_closed)
ultimately
show ?case
unfolding globalize.simps globalize_node.simps iNodeOf.simps iAnnot.simps itnode.sel rose_tree.sel Let_def
by (rule iwf.intros(1))
next
case (iwfH c \<Gamma> s i "is" f)
from \<open>c |\<notin>| ass_forms\<close>
have "renameLCs f c |\<notin>| ass_forms"
using assumptions_closed closed_no_lconsts lconsts_renameLCs rename_closed by fastforce
moreover
from \<open>c |\<in>| \<Gamma>\<close>
have "renameLCs f c |\<in>| renameLCs f |`| \<Gamma>" by auto
moreover
from \<open>c = subst s (freshen i anyP)\<close>
have "renameLCs f c = subst (subst_renameLCs f s) (freshen (isidx is) anyP)"
by (metis freshen_closed lconsts_anyP rename_closed rename_subst)
ultimately
show "plain_iwf (globalize is f (HNode i s [])) (renameLCs f |`| \<Gamma> \<turnstile> renameLCs f c)"
unfolding globalize.simps globalize_node.simps mapWithIndex_Nil Let_def
by (rule iwf.intros(2))
qed
definition fresh_at where
"fresh_at t xs =
(case rev xs of [] \<Rightarrow> {}
| (i#is') \<Rightarrow> freshenLC (iAnnot (tree_at t (rev is'))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (rev is'))) ! i)))"
lemma fresh_at_Nil[simp]:
"fresh_at t [] = {}"
unfolding fresh_at_def by simp
lemma fresh_at_snoc[simp]:
"fresh_at t (is@[i]) = freshenLC (iAnnot (tree_at t is)) ` (a_fresh (inPorts' (iNodeOf (tree_at t is)) ! i))"
unfolding fresh_at_def by simp
lemma fresh_at_def':
"fresh_at t is =
(if is = [] then {}
else freshenLC (iAnnot (tree_at t (butlast is))) ` (a_fresh (inPorts' (iNodeOf (tree_at t (butlast is))) ! last is)))"
unfolding fresh_at_def by (auto split: list.split)
lemma fresh_at_Cons[simp]:
"fresh_at t (i#is) = (if is = [] then freshenLC (iAnnot t) ` (a_fresh (inPorts' (iNodeOf t) ! i)) else (let t' = iAnts t ! i in fresh_at t' is))"
unfolding fresh_at_def'
by (auto simp add: Let_def)
definition fresh_at_path where
"fresh_at_path t is = \<Union>(fresh_at t ` set (prefixes is))"
lemma fresh_at_path_Nil[simp]:
"fresh_at_path t [] = {}"
unfolding fresh_at_path_def by simp
lemma fresh_at_path_Cons[simp]:
"fresh_at_path t (i#is) = fresh_at t [i] \<union> fresh_at_path (iAnts t ! i) is"
unfolding fresh_at_path_def
by (fastforce split: if_splits)
lemma globalize_local_consts:
assumes "is' \<in> it_paths (globalize is f t)"
shows "subst_lconsts (iSubst (tree_at (globalize is f t) is')) \<subseteq>
fresh_at_path (globalize is f t) is' \<union> range f"
using assms
apply (induction "is" f t arbitrary: is' rule:globalize.induct)
apply (rename_tac "is" f r ants is')
apply (case_tac r)
apply (auto simp add: subst_lconsts_subst_renameLCs elim!: it_paths_RNodeE)
apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
apply (solves \<open>force dest!: subsetD[OF range_rerename]\<close>)
done
lemma iwf_globalize':
assumes "local_iwf t ent"
assumes "\<And> x. x |\<in>| fst ent \<Longrightarrow> closed x"
assumes "closed (snd ent)"
shows "plain_iwf (globalize is (freshenLC v_away) t) ent"
using assms
proof(induction ent rule: prod.induct)
case (Pair \<Gamma> c)
have "plain_iwf (globalize is (freshenLC v_away) t) (renameLCs (freshenLC v_away) |`| \<Gamma> \<turnstile> renameLCs (freshenLC v_away) c)"
by (rule iwf_globalize[OF Pair(1)])
also
from Pair(3) have "closed c" by simp
hence "renameLCs (freshenLC v_away) c = c" by (simp add: closed_no_lconsts rename_closed)
also
from Pair(2)
have "renameLCs (freshenLC v_away) |`| \<Gamma> = \<Gamma>"
- by (auto simp add: closed_no_lconsts rename_closed fmember.rep_eq image_iff)
+ by (auto simp add: closed_no_lconsts rename_closed fmember_iff_member_fset image_iff)
finally show ?case.
qed
end
end
diff --git a/thys/Incredible_Proof_Machine/Indexed_FSet.thy b/thys/Incredible_Proof_Machine/Indexed_FSet.thy
--- a/thys/Incredible_Proof_Machine/Indexed_FSet.thy
+++ b/thys/Incredible_Proof_Machine/Indexed_FSet.thy
@@ -1,92 +1,92 @@
theory Indexed_FSet
imports
"HOL-Library.FSet"
begin
text \<open>It is convenient to address the members of a finite set by a natural number, and
also to convert a finite set to a list.\<close>
context includes fset.lifting
begin
lift_definition fset_from_list :: "'a list => 'a fset" is set by (rule finite_set)
lemma mem_fset_from_list[simp]: "x |\<in>| fset_from_list l \<longleftrightarrow> x \<in> set l" by transfer rule
lemma fimage_fset_from_list[simp]: "f |`| fset_from_list l = fset_from_list (map f l)" by transfer auto
lemma fset_fset_from_list[simp]: "fset (fset_from_list l) = set l" by transfer auto
lemmas fset_simps[simp] = set_simps[Transfer.transferred]
lemma size_fset_from_list[simp]: "distinct l \<Longrightarrow> size (fset_from_list l) = length l"
by (induction l) auto
definition list_of_fset :: "'a fset \<Rightarrow> 'a list" where
"list_of_fset s = (SOME l. fset_from_list l = s \<and> distinct l)"
lemma fset_from_list_of_fset[simp]: "fset_from_list (list_of_fset s) = s"
and distinct_list_of_fset[simp]: "distinct (list_of_fset s)"
unfolding atomize_conj list_of_fset_def
by (transfer, rule someI_ex, rule finite_distinct_list)
lemma length_list_of_fset[simp]: "length (list_of_fset s) = size s"
by (metis distinct_list_of_fset fset_from_list_of_fset size_fset_from_list)
lemma nth_list_of_fset_mem[simp]: "i < size s \<Longrightarrow> list_of_fset s ! i |\<in>| s"
by (metis fset_from_list_of_fset length_list_of_fset mem_fset_from_list nth_mem)
inductive indexed_fmember :: "'a \<Rightarrow> nat \<Rightarrow> 'a fset \<Rightarrow> bool" ("_ |\<in>|\<^bsub>_\<^esub> _" [50,50,50] 50 ) where
"i < size s \<Longrightarrow> list_of_fset s ! i |\<in>|\<^bsub>i\<^esub> s"
lemma indexed_fmember_is_fmember: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> x |\<in>| s"
proof (induction rule: indexed_fmember.induct)
case (1 i s)
hence "i < length (list_of_fset s)" by (metis length_list_of_fset)
hence "list_of_fset s ! i \<in> set (list_of_fset s)" by (rule nth_mem)
thus "list_of_fset s ! i |\<in>| s" by (metis mem_fset_from_list fset_from_list_of_fset)
qed
lemma fmember_is_indexed_fmember:
assumes "x |\<in>| s"
shows "\<exists>i. x |\<in>|\<^bsub>i\<^esub> s"
proof-
from assms
have "x \<in> set (list_of_fset s)" using mem_fset_from_list by fastforce
then obtain i where "i < length (list_of_fset s)" and "x = list_of_fset s ! i" by (metis in_set_conv_nth)
hence "x |\<in>|\<^bsub>i\<^esub> s" by (simp add: indexed_fmember.simps)
thus ?thesis..
qed
lemma indexed_fmember_unique: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> y |\<in>|\<^bsub>j\<^esub> s \<Longrightarrow> x = y \<longleftrightarrow> i = j"
by (metis distinct_list_of_fset indexed_fmember.cases length_list_of_fset nth_eq_iff_index_eq)
definition indexed_members :: "'a fset \<Rightarrow> (nat \<times> 'a) list" where
"indexed_members s = zip [0..<size s] (list_of_fset s)"
lemma mem_set_indexed_members:
"(i,x) \<in> set (indexed_members s) \<longleftrightarrow> x |\<in>|\<^bsub>i\<^esub> s"
unfolding indexed_members_def indexed_fmember.simps
by (force simp add: set_zip)
lemma mem_set_indexed_members'[simp]:
"t \<in> set (indexed_members s) \<longleftrightarrow> snd t |\<in>|\<^bsub>fst t\<^esub> s"
by (cases t, simp add: mem_set_indexed_members)
definition fnth (infixl "|!|" 100) where
"s |!| n = list_of_fset s ! n"
lemma fnth_indexed_fmember: "i < size s \<Longrightarrow> s |!| i |\<in>|\<^bsub>i\<^esub> s"
unfolding fnth_def by (rule indexed_fmember.intros)
lemma indexed_fmember_fnth: "x |\<in>|\<^bsub>i\<^esub> s \<longleftrightarrow> (s |!| i = x \<and> i < size s)"
unfolding fnth_def by (metis indexed_fmember.simps)
end
definition fidx :: "'a fset \<Rightarrow> 'a \<Rightarrow> nat" where
"fidx s x = (SOME i. x |\<in>|\<^bsub>i\<^esub> s)"
lemma fidx_eq[simp]: "x |\<in>|\<^bsub>i\<^esub> s \<Longrightarrow> fidx s x = i"
unfolding fidx_def
by (rule someI2)(auto simp add: indexed_fmember_fnth fnth_def nth_eq_iff_index_eq)
lemma fidx_inj[simp]: "x |\<in>| s \<Longrightarrow> y |\<in>| s \<Longrightarrow> fidx s x = fidx s y \<longleftrightarrow> x = y"
by (auto dest!: fmember_is_indexed_fmember simp add: indexed_fmember_unique)
lemma inj_on_fidx: "inj_on (fidx vertices) (fset vertices)"
- by (rule inj_onI) (auto simp: fmember.rep_eq [symmetric])
+ by (rule inj_onI) (auto simp: fmember_iff_member_fset [symmetric])
end
diff --git a/thys/IsaNet/infrastructure/Abstract_XOR.thy b/thys/IsaNet/infrastructure/Abstract_XOR.thy
--- a/thys/IsaNet/infrastructure/Abstract_XOR.thy
+++ b/thys/IsaNet/infrastructure/Abstract_XOR.thy
@@ -1,150 +1,150 @@
(*******************************************************************************
Project: IsaNet
Author: Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
Version: JCSPaper.1.0
Isabelle Version: Isabelle2021-1
Copyright (c) 2022 Tobias Klenze
Licence: Mozilla Public License 2.0 (MPL) / BSD-3-Clause (dual license)
*******************************************************************************)
section \<open>Abstract XOR\<close>
theory "Abstract_XOR"
imports
"HOL.Finite_Set" "HOL-Library.FSet" "Message"
(*the latter half of this theory uses msgterm. If split it off, we have to add
- declare fmember.rep_eq[simp]
+ declare fmember_iff_member_fset[simp]
in order to show the first half*)
begin
(******************************************************************************)
subsection\<open>Abstract XOR definition and lemmas\<close>
(******************************************************************************)
text\<open>We model xor as an operation on finite sets (fset). @{term "{||}"} is defined as the identity element.\<close>
text\<open>xor of two fsets is the symmetric difference\<close>
definition xor :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"xor xs ys = (xs |\<union>| ys) |-| (xs |\<inter>| ys)"
lemma xor_singleton:
"xor xs {| z |} = (if z |\<in>| xs then xs |-| {| z |} else finsert z xs)"
"xor {| z |} xs = (if z |\<in>| xs then xs |-| {| z |} else finsert z xs)"
by (auto simp add: xor_def)
(*auto loops with this rule declared intro!. We could alternatively try using safe instead of auto*)
declare finsertCI[rule del]
declare finsertCI[intro]
lemma xor_assoc: "xor (xor xs ys) zs = xor xs (xor ys zs)"
by (auto simp add: xor_def)
lemma xor_commut: "xor xs ys = xor ys xs"
by (auto simp add: xor_def)
lemma xor_self_inv: "\<lbrakk>xor xs ys = zs; xs = ys\<rbrakk> \<Longrightarrow> zs = {||}"
by (auto simp add: xor_def)
lemma xor_self_inv': "xor xs xs = {||}"
by (auto simp add: xor_def)
lemma xor_self_inv''[dest!]: "xor xs ys = {||} \<Longrightarrow> xs = ys"
by (auto simp add: xor_def)
lemma xor_identity1[simp]: "xor xs {||} = xs"
by (auto simp add: xor_def)
lemma xor_identity2[simp]: "xor {||} xs = xs"
by (auto simp add: xor_def)
lemma xor_in: "z |\<in>| xs \<Longrightarrow> z |\<notin>| (xor xs {| z |})"
by (auto simp add: xor_singleton)
lemma xor_out: "z |\<notin>| xs \<Longrightarrow> z |\<in>| (xor xs {| z |})"
by (auto simp add: xor_singleton)
lemma xor_elem1[dest]: "\<lbrakk>x \<in> fset (xor X Y); x |\<notin>| X\<rbrakk> \<Longrightarrow> x |\<in>| Y"
by(auto simp add: xor_def)
lemma xor_elem2[dest]: "\<lbrakk>x \<in> fset (xor X Y); x |\<notin>| Y\<rbrakk> \<Longrightarrow> x |\<in>| X"
by(auto simp add: xor_def)
lemma xor_finsert_self: "xor (finsert x xs) {|x|} = xs - {| x |}"
by(auto simp add: xor_def)
(******************************************************************************)
subsection\<open>Lemmas refering to XOR and msgterm\<close>
(******************************************************************************)
lemma FS_contains_elem:
assumes "elem = f (FS zs_s)" "zs_s = xor zs_b {| elem |}" "\<And> x. size (f x) > size x"
shows "elem \<in> fset zs_b"
using assms(1)
apply(auto simp add: xor_def)
using FS_mono assms notin_fset xor_singleton(1)
by (metis)
lemma FS_is_finsert_elem:
assumes "elem = f (FS zs_s)" "zs_s = xor zs_b {| elem |}" "\<And> x. size (f x) > size x"
shows "zs_b = finsert elem zs_s"
using assms FS_contains_elem finsert_fminus xor_singleton(1) FS_mono
by (metis FS_mono)
lemma FS_update_eq:
assumes "xs = f (FS (xor zs {|xs|}))"
and "ys = g (FS (xor zs {|ys|}))"
and "\<And> x. size (f x) > size x"
and "\<And> x. size (g x) > size x"
shows "xs = ys"
proof(rule ccontr)
assume elem_neq: "xs \<noteq> ys"
obtain zs_s1 zs_s2 where zs_defs:
"zs_s1 = xor zs {|xs|}" "zs_s2 = xor zs {|ys|}" by simp
have elems_contained_zs: "xs \<in> fset zs" "ys \<in> fset zs"
using assms FS_contains_elem by blast+
then have elems_elem: "ys |\<in>| zs_s1" "xs |\<in>| zs_s2"
using elem_neq by(auto simp add: xor_def zs_defs)
have zs_finsert: "finsert xs zs_s2 = zs_s2" "finsert ys zs_s1 = zs_s1"
using elems_elem by fastforce+
have f1: "\<forall>m f fa. \<not> sum fa (fset (finsert (m::msgterm) f)) < (fa m::nat)"
by (simp add: sum.insert_remove)
from assms(1-2) have "size xs > size (f (FS {| ys |}))" "size ys > size (g (FS {| xs |}))"
apply(simp_all add: zs_defs[symmetric])
using zs_finsert f1 by (metis (no_types) add_Suc_right assms(3-4) dual_order.strict_trans
less_add_Suc1 msgterm.size(17) not_less_eq size_fset_simps)+
then show False using assms(3,4) elems_elem
by (metis add.right_neutral add_Suc_right f1 less_add_Suc1 msgterm.size(17) not_less_eq
not_less_iff_gr_or_eq order.strict_trans size_fset_simps)
qed
declare fminusE[rule del]
declare finsertCI[rule del]
(*add back the removed rules without !*)
declare fminusE[elim]
declare finsertCI[intro]
(*currently not needed*)
lemma fset_size_le:
assumes "x \<in> fset xs"
shows "size x < Suc (\<Sum>x\<in>fset xs. Suc (size x))"
proof-
have "size x \<le> (\<Sum>x\<in>fset xs. size x)" using assms
by (auto intro: member_le_sum)
moreover have "(\<Sum>x\<in>fset xs. size x) < (\<Sum>x\<in>fset xs. Suc (size x))"
by (metis assms empty_iff finite_fset lessI sum_strict_mono)
ultimately show ?thesis by auto
qed
text\<open>We can show that xor is a commutative function.\<close>
(*not needed*)
locale abstract_xor
begin
sublocale comp_fun_commute xor
by(auto simp add: comp_fun_commute_def xor_def)
end
end
\ No newline at end of file
diff --git a/thys/IsaNet/infrastructure/Message.thy b/thys/IsaNet/infrastructure/Message.thy
--- a/thys/IsaNet/infrastructure/Message.thy
+++ b/thys/IsaNet/infrastructure/Message.thy
@@ -1,1203 +1,1203 @@
(*******************************************************************************
Title: HOL/Auth/Message
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1996 University of Cambridge
Datatypes of agents and messages;
Inductive relations "parts", "analz" and "synth"
********************************************************************************
Edited: Tobias Klenze, ETH Zurich <tobias.klenze@inf.ethz.ch>
Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>
Integrated and adapted for security protocol refinement and to add a constructor for finite sets.
*******************************************************************************)
section \<open>Theory of ASes and Messages for Security Protocols\<close>
theory Message imports Keys "HOL-Library.Sublist" "HOL.Finite_Set" "HOL-Library.FSet"
begin
datatype msgterm =
\<epsilon> \<comment> \<open>Empty message. Used for instance to denote non-existent interface\<close>
| AS as \<comment> \<open>Autonomous System identifier, i.e. agents. Note that AS is an alias of nat\<close>
| Num nat \<comment> \<open>Ordinary integers, timestamps, ...\<close>
| Key key \<comment> \<open>Crypto keys\<close>
| Nonce nonce \<comment> \<open>Unguessable nonces\<close>
| L "msgterm list" \<comment> \<open>Lists\<close>
| FS "msgterm fset" \<comment> \<open>Finite Sets. Used to represent XOR values.\<close>
| MPair msgterm msgterm \<comment> \<open>Compound messages\<close>
| Hash msgterm \<comment> \<open>Hashing\<close>
| Crypt key msgterm \<comment> \<open>Encryption, public- or shared-key\<close>
text \<open>Syntax sugar\<close>
syntax
"_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b" ("(2\<langle>_,/ _\<rangle>)")
syntax (xsymbols)
"_MTuple" :: "['a, args] \<Rightarrow> 'a * 'b" ("(2\<langle>_,/ _\<rangle>)")
translations
"\<langle>x, y, z\<rangle>" \<rightleftharpoons> "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
"\<langle>x, y\<rangle>" \<rightleftharpoons> "CONST MPair x y"
syntax
"_MHF" :: "['a, 'b , 'c, 'd, 'e] \<Rightarrow> 'a * 'b * 'c * 'd * 'e" ("(5HF\<lhd>_,/ _,/ _,/ _,/ _\<rhd>)")
abbreviation
Mac :: "[msgterm,msgterm] \<Rightarrow> msgterm" ("(4Mac[_] /_)" [0, 1000])
where
\<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
"Mac[X] Y \<equiv> Hash \<langle>X,Y\<rangle>"
abbreviation macKey where "macKey a \<equiv> Key (macK a)"
definition
keysFor :: "msgterm set \<Rightarrow> key set"
where
\<comment> \<open>Keys useful to decrypt elements of a message set\<close>
"keysFor H \<equiv> invKey ` {K. \<exists>X. Crypt K X \<in> H}"
subsubsection \<open>Inductive Definition of "All Parts" of a Message\<close>
inductive_set
parts :: "msgterm set \<Rightarrow> msgterm set"
for H :: "msgterm set"
where
Inj [intro]: "X \<in> H \<Longrightarrow> X \<in> parts H"
| Fst: "\<langle>X,_\<rangle> \<in> parts H \<Longrightarrow> X \<in> parts H"
| Snd: "\<langle>_,Y\<rangle> \<in> parts H \<Longrightarrow> Y \<in> parts H"
| Lst: "\<lbrakk> L xs \<in> parts H; X \<in> set xs \<rbrakk> \<Longrightarrow> X \<in> parts H"
| FSt: "\<lbrakk> FS xs \<in> parts H; X |\<in>| xs \<rbrakk> \<Longrightarrow> X \<in> parts H"
(*| Hd: "L (X # xs) \<in> parts H \<Longrightarrow> X \<in> parts H"
| Tl: "L (X # xs) \<in> parts H \<Longrightarrow> L xs \<in> parts H" *)
| Body: "Crypt K X \<in> parts H \<Longrightarrow> X \<in> parts H"
text \<open>Monotonicity\<close>
lemma parts_mono: "G \<subseteq> H \<Longrightarrow> parts G \<subseteq> parts H"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)+
done
text \<open>Equations hold because constructors are injective.\<close>
lemma Other_image_eq [simp]: "(AS x \<in> AS`A) = (x:A)"
by auto
lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto
lemma AS_Key_image_eq [simp]: "(AS x \<notin> Key`A)"
by auto
lemma Num_Key_image_eq [simp]: "(Num x \<notin> Key`A)"
by auto
subsection \<open>keysFor operator\<close>
lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)
lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)
lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)
text \<open>Monotonicity\<close>
lemma keysFor_mono: "G \<subseteq> H \<Longrightarrow> keysFor G \<subseteq> keysFor H"
by (unfold keysFor_def, blast)
lemma keysFor_insert_AS [simp]: "keysFor (insert (AS A) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_Num [simp]: "keysFor (insert (Num N) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce n) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_L [simp]: "keysFor (insert (L X) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_FS [simp]: "keysFor (insert (FS X) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_MPair [simp]: "keysFor (insert \<langle>X,Y\<rangle> H) = keysFor H"
by (unfold keysFor_def, auto)
lemma keysFor_insert_Crypt [simp]:
"keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)
lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)
lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H \<Longrightarrow> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)
subsection \<open>Inductive relation "parts"\<close>
lemma MPair_parts:
"\<lbrakk>
\<langle>X,Y\<rangle> \<in> parts H;
\<lbrakk> X \<in> parts H; Y \<in> parts H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
by (blast dest: parts.Fst parts.Snd)
lemma L_parts:
"\<lbrakk>
L l \<in> parts H;
\<lbrakk> set l \<subseteq> parts H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
by (blast dest: parts.Lst)
lemma FS_parts:
"\<lbrakk>
FS l \<in> parts H;
\<lbrakk> fset l \<subseteq> parts H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
- by (simp add: fmember.rep_eq parts.FSt subsetI)
-thm fmember.rep_eq parts.FSt subsetI
+ by (simp add: fmember_iff_member_fset parts.FSt subsetI)
+thm fmember_iff_member_fset parts.FSt subsetI
-declare fmember.rep_eq[simp]
+declare fmember_iff_member_fset[simp]
declare MPair_parts [elim!] L_parts [elim!] FS_parts [elim] parts.Body [dest!]
text \<open>NB These two rules are UNSAFE in the formal sense, as they discard the
compound message. They work well on THIS FILE.
@{text MPair_parts} is left as SAFE because it speeds up proofs.
The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.\<close>
lemma parts_increasing: "H \<subseteq> parts H"
by blast
lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]
lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done
lemma parts_emptyE [elim!]: "X\<in> parts{} \<Longrightarrow> P"
by simp
text \<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
lemma parts_singleton: "X \<in> parts H \<Longrightarrow> \<exists>Y \<in> H. X \<in> parts {Y}"
apply (erule parts.induct, fast)
using parts.FSt by blast+
lemma parts_singleton_set: "x \<in> parts {s . P s} \<Longrightarrow> \<exists>Y. P Y \<and> x \<in> parts {Y}"
by(auto dest: parts_singleton)
lemma parts_singleton_set_rev: "\<lbrakk>x \<in> parts {Y}; P Y\<rbrakk> \<Longrightarrow> x \<in> parts {s . P s}"
by (induction rule: parts.induct)
(blast dest: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)+
lemma parts_Hash: "\<lbrakk>\<And>t . t \<in> H \<Longrightarrow> \<exists>t' . t = Hash t'\<rbrakk> \<Longrightarrow> parts H = H"
by (auto, erule parts.induct, fast+)
subsubsection \<open>Unions\<close>
lemma parts_Un_subset1: "parts G \<union> parts H \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)
lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts G \<union> parts H"
apply (rule subsetI)
apply (erule parts.induct, blast+)
using parts.FSt by auto
lemma parts_Un [simp]: "parts(G \<union> H) = parts G \<union> parts H"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)
lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done
text \<open>TWO inserts to avoid looping. This rewrite is better than nothing.
Not suitable for Addsimps: its behaviour can be strange.\<close>
lemma parts_insert2:
"parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done
(*needed?!*)
lemma parts_two: "\<lbrakk>x \<in> parts {e1, e2}; x \<notin> parts {e1}\<rbrakk>\<Longrightarrow> x \<in> parts {e2}"
by (simp add: parts_insert2)
lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)
lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct)
using parts.FSt by auto
lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)
text \<open>Added to simplify arguments to parts, analz and synth.
NOTE: the UN versions are no longer used!\<close>
text \<open>This allows @{text blast} to simplify occurrences of
@{term "parts(G\<union>H)"} in the assumption.\<close>
lemmas in_parts_UnE = parts_Un [THEN equalityD1, THEN subsetD, THEN UnE]
declare in_parts_UnE [elim!]
lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])
subsubsection \<open>Idempotence\<close>
lemma parts_partsD [dest!]: "X\<in> parts (parts H) \<Longrightarrow> X\<in> parts H"
apply (erule parts.induct, blast+)
using parts.FSt by auto
lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast
lemma parts_subset_iff [simp]: "(parts G \<subseteq> parts H) = (G \<subseteq> parts H)"
apply (rule iffI)
apply (iprover intro: subset_trans parts_increasing)
apply (frule parts_mono, simp)
done
subsubsection \<open>Transitivity\<close>
lemma parts_trans: "\<lbrakk> X\<in> parts G; G \<subseteq> parts H \<rbrakk> \<Longrightarrow> X\<in> parts H"
by (drule parts_mono, blast)
subsubsection \<open>Unions, revisited\<close>
text \<open>You can take the union of parts h for all h in H\<close>
lemma parts_split: "parts H = \<Union> { parts {h} | h . h \<in> H}"
apply auto
apply (erule parts.induct)
apply (blast dest: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)+
using parts_trans apply blast
done
text \<open>Cut\<close>
lemma parts_cut:
"\<lbrakk> Y\<in> parts (insert X G); X \<in> parts H \<rbrakk> \<Longrightarrow> Y \<in> parts (G \<union> H)"
by (blast intro: parts_trans)
lemma parts_cut_eq [simp]: "X \<in> parts H \<Longrightarrow> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)
subsubsection \<open>Rewrite rules for pulling out atomic messages\<close>
lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]
lemma parts_insert_AS [simp]:
"parts (insert (AS agt) H) = insert (AS agt) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto elim!: FS_parts)
lemma parts_insert_Epsilon [simp]:
"parts (insert \<epsilon> H) = insert \<epsilon> (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)
lemma parts_insert_Num [simp]:
"parts (insert (Num N) H) = insert (Num N) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)
lemma parts_insert_Key [simp]:
"parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)
lemma parts_insert_Nonce [simp]:
"parts (insert (Nonce n) H) = insert (Nonce n) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)
lemma parts_insert_Hash [simp]:
"parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
by (erule parts.induct, auto)
lemma parts_insert_Crypt [simp]:
"parts (insert (Crypt K X) H) = insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (blast intro: parts.Body)
lemma parts_insert_MPair [simp]:
"parts (insert \<langle>X,Y\<rangle> H) =
insert \<langle>X,Y\<rangle> (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (blast intro: parts.Fst parts.Snd)+
lemma parts_insert_L [simp]:
"parts (insert (L xs) H) =
insert (L xs) (parts ((set xs) \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (blast intro: parts.Lst)+
lemma parts_insert_FS [simp]:
"parts (insert (FS xs) H) =
insert (FS xs) (parts ((fset xs) \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
by (auto intro: parts.FSt)+
lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done
text \<open>Parts of lists and finite sets.\<close>
lemma parts_list_set (*[simp]*):
"parts (L`ls) = (L`ls) \<union> (\<Union>l \<in> ls. parts (set l)) "
apply (rule equalityI, rule subsetI)
apply (erule parts.induct, auto)
by (meson L_parts image_subset_iff parts_increasing parts_trans)
lemma parts_insert_list_set (*[simp]*):
"parts ((L`ls) \<union> H) = (L`ls) \<union> (\<Union>l \<in> ls. parts ((set l))) \<union> parts H"
apply (rule equalityI, rule subsetI)
by (erule parts.induct, auto simp add: parts_list_set)
(*needed?!*)
lemma parts_fset_set (*[simp]*):
"parts (FS`ls) = (FS`ls) \<union> (\<Union>l \<in> ls. parts (fset l)) "
apply (rule equalityI, rule subsetI)
apply (erule parts.induct, auto)
by (meson FS_parts image_subset_iff parts_increasing parts_trans)
subsubsection \<open>suffix of parts\<close>
lemma suffix_in_parts:
"suffix (x#xs) ys \<Longrightarrow> x \<in> parts {L ys}"
by (auto simp add: suffix_def)
lemma parts_L_set:
"\<lbrakk>x \<in> parts {L ys}; ys \<in> St\<rbrakk> \<Longrightarrow> x \<in> parts (L`St)"
by (metis (no_types, lifting) image_insert insert_iff mk_disjoint_insert parts.Inj
parts_cut_eq parts_insert parts_insert2)
lemma suffix_in_parts_set:
"\<lbrakk>suffix (x#xs) ys; ys \<in> St\<rbrakk> \<Longrightarrow> x \<in> parts (L`St)"
using parts_L_set suffix_in_parts
by blast
subsection \<open>Inductive relation "analz"\<close>
text \<open>Inductive definition of "analz" -- what can be broken down from a set of
messages, including keys. A form of downward closure. Pairs can
be taken apart; messages decrypted with known keys.\<close>
inductive_set
analz :: "msgterm set \<Rightarrow> msgterm set"
for H :: "msgterm set"
where
Inj [intro,simp] : "X \<in> H \<Longrightarrow> X \<in> analz H"
| Fst: "\<langle>X,Y\<rangle> \<in> analz H \<Longrightarrow> X \<in> analz H"
| Snd: "\<langle>X,Y\<rangle> \<in> analz H \<Longrightarrow> Y \<in> analz H"
| Lst: "(L y) \<in> analz H \<Longrightarrow> x \<in> set (y) \<Longrightarrow> x \<in> analz H "
| FSt: "\<lbrakk> FS xs \<in> analz H; X |\<in>| xs \<rbrakk> \<Longrightarrow> X \<in> analz H"
| Decrypt [dest]: "\<lbrakk> Crypt K X \<in> analz H; Key (invKey K) \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
text \<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
lemma analz_mono: "G \<subseteq> H \<Longrightarrow> analz(G) \<subseteq> analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt )
done
lemmas analz_monotonic = analz_mono [THEN [2] rev_subsetD]
text \<open>Making it safe speeds up proofs\<close>
lemma MPair_analz [elim!]:
"\<lbrakk>
\<langle>X,Y\<rangle> \<in> analz H;
\<lbrakk> X \<in> analz H; Y \<in> analz H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
by (blast dest: analz.Fst analz.Snd)
lemma L_analz [elim!]:
"\<lbrakk>
L l \<in> analz H;
\<lbrakk> set l \<subseteq> analz H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
by (blast dest: analz.Lst analz.FSt)
lemma FS_analz [elim!]:
"\<lbrakk>
FS l \<in> analz H;
\<lbrakk> fset l \<subseteq> analz H \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
- by (simp add: fmember.rep_eq analz.FSt subsetI)
+ by (simp add: fmember_iff_member_fset analz.FSt subsetI)
-thm fmember.rep_eq parts.FSt subsetI
+thm fmember_iff_member_fset parts.FSt subsetI
lemma analz_increasing: "H \<subseteq> analz(H)"
by blast
lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
apply auto
done
text \<open>If there is no cryptography, then analz and parts is equivalent.\<close>
lemma no_crypt_analz_is_parts:
"\<not> (\<exists> K X . Crypt K X \<in> parts A) \<Longrightarrow> analz A = parts A"
apply (rule equalityI, simp add: analz_subset_parts)
apply (rule subsetI)
by (erule parts.induct, blast+, auto)
lemmas analz_into_parts = analz_subset_parts [THEN subsetD]
lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]
lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done
lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done
lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]
subsubsection \<open>General equational properties\<close>
lemma analz_empty [simp]: "analz {} = {}"
apply safe
apply (erule analz.induct, blast+)
done
text \<open>Converse fails: we can analz more from the union than from the
separate parts, as a key in one might decrypt a message in the other\<close>
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)
lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])
subsubsection \<open>Rewrite rules for pulling out atomic messages\<close>
lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]
lemma analz_insert_AS [simp]:
"analz (insert (AS agt) H) = insert (AS agt) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
lemma analz_insert_Num [simp]:
"analz (insert (Num N) H) = insert (Num N) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
text \<open>Can only pull out Keys if they are not needed to decrypt the rest\<close>
lemma analz_insert_Key [simp]:
"K \<notin> keysFor (analz H) \<Longrightarrow>
analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
lemma analz_insert_LEmpty [simp]:
"analz (insert (L []) H) = insert (L []) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
lemma analz_insert_L [simp]:
"analz (insert (L l) H) = insert (L l) (analz (set l \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using analz.Inj by blast
lemma analz_insert_FS [simp]:
"analz (insert (FS l) H) = insert (FS l) (analz (fset l \<union> H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using analz.Inj by blast
lemma "L[] \<in> analz {L[L[]]}"
using analz.Inj by simp
lemma analz_insert_Hash [simp]:
"analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
lemma analz_insert_MPair [simp]:
"analz (insert \<langle>X,Y\<rangle> H) =
insert \<langle>X,Y\<rangle> (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct, auto)
using Fst Snd analz.Inj insertI1
by (metis)+
text \<open>Can pull out enCrypted message if the Key is not known\<close>
lemma analz_insert_Crypt:
"Key (invKey K) \<notin> analz H
\<Longrightarrow> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
by (erule analz.induct, auto)
lemma analz_insert_Decrypt1:
"Key (invKey K) \<in> analz H \<Longrightarrow>
analz (insert (Crypt K X) H) \<subseteq>
insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
by (erule_tac x = x in analz.induct, auto)
lemma analz_insert_Decrypt2:
"Key (invKey K) \<in> analz H \<Longrightarrow>
insert (Crypt K X) (analz (insert X H)) \<subseteq>
analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
by (blast intro: analz_insertI analz.Decrypt)
lemma analz_insert_Decrypt:
"Key (invKey K) \<in> analz H \<Longrightarrow>
analz (insert (Crypt K X) H) =
insert (Crypt K X) (analz (insert X H))"
by (intro equalityI analz_insert_Decrypt1 analz_insert_Decrypt2)
text \<open>Case analysis: either the message is secure, or it is not! Effective,
but can cause subgoals to blow up! Use with @{text "split_if"}; apparently
@{text "split_tac"} does not cope with patterns such as @{term"analz (insert
(Crypt K X) H)"}\<close>
lemma analz_Crypt_if [simp]:
"analz (insert (Crypt K X) H) =
(if (Key (invKey K) \<in> analz H)
then insert (Crypt K X) (analz (insert X H))
else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)
text \<open>This rule supposes "for the sake of argument" that we have the key.\<close>
lemma analz_insert_Crypt_subset:
"analz (insert (Crypt K X) H) \<subseteq>
insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
by (erule analz.induct, auto)
lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done
subsubsection \<open>Idempotence and transitivity\<close>
lemma analz_analzD [dest!]: "X\<in> analz (analz H) \<Longrightarrow> X\<in> analz H"
by (erule analz.induct, auto)
lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast
lemma analz_subset_iff [simp]: "(analz G \<subseteq> analz H) = (G \<subseteq> analz H)"
apply (rule iffI)
apply (iprover intro: subset_trans analz_increasing)
apply (frule analz_mono, simp)
done
lemma analz_trans: "\<lbrakk> X\<in> analz G; G \<subseteq> analz H \<rbrakk> \<Longrightarrow> X\<in> analz H"
by (drule analz_mono, blast)
text \<open>Cut; Lemma 2 of Lowe\<close>
lemma analz_cut: "\<lbrakk> Y\<in> analz (insert X H); X\<in> analz H \<rbrakk> \<Longrightarrow> Y\<in> analz H"
by (erule analz_trans, blast)
(*Cut can be proved easily by induction on
"Y: analz (insert X H) \<Longrightarrow> X: analz H --> Y: analz H"
*)
text \<open>This rewrite rule helps in the simplification of messages that involve
the forwarding of unknown components (X). Without it, removing occurrences
of X can be very complicated.\<close>
lemma analz_insert_eq: "X\<in> analz H \<Longrightarrow> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)
text \<open>A congruence rule for "analz"\<close>
lemma analz_subset_cong:
"\<lbrakk> analz G \<subseteq> analz G'; analz H \<subseteq> analz H' \<rbrakk>
\<Longrightarrow> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply simp
apply (iprover intro: conjI subset_trans analz_mono Un_upper1 Un_upper2)
done
lemma analz_cong:
"\<lbrakk> analz G = analz G'; analz H = analz H' \<rbrakk>
\<Longrightarrow> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)
lemma analz_insert_cong:
"analz H = analz H' \<Longrightarrow> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)
text \<open>If there are no pairs, lists or encryptions then analz does nothing\<close>
(*needed?*)
lemma analz_trivial:
"\<lbrakk>
\<forall>X Y. \<langle>X,Y\<rangle> \<notin> H; \<forall>xs. L xs \<notin> H; \<forall>xs. FS xs \<notin> H;
\<forall>X K. Crypt K X \<notin> H
\<rbrakk> \<Longrightarrow> analz H = H"
apply safe
by (erule analz.induct, auto)
text \<open>These two are obsolete (with a single Spy) but cost little to prove...\<close>
lemma analz_UN_analz_lemma:
"X\<in> analz (\<Union>i\<in>A. analz (H i)) \<Longrightarrow> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
by (auto intro: analz_mono [THEN [2] rev_subsetD])
lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])
subsubsection \<open>Lemmas assuming absense of keys\<close>
text \<open>If there are no keys in analz H, you can take the union of analz h for all h in H\<close>
lemma analz_split:
"\<not>(\<exists> K . Key K \<in> analz H)
\<Longrightarrow> analz H = \<Union> { analz {h} | h . h \<in> H}"
apply auto
subgoal
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt)
done
apply (erule analz.induct)
apply (auto dest: analz.Fst analz.Snd analz.Lst analz.FSt)
done
lemma analz_Un_eq:
assumes "\<not>(\<exists> K . Key K \<in> analz H)" and "\<not>(\<exists> K . Key K \<in> analz G)"
shows "analz (H \<union> G) = analz H \<union> analz G"
apply (intro equalityI, rule subsetI)
apply (erule analz.induct)
using assms by auto
lemma analz_Un_eq_Crypt:
assumes "\<not>(\<exists> K . Key K \<in> analz G)" and "\<not>(\<exists> K X . Crypt K X \<in> analz G)"
shows "analz (H \<union> G) = analz H \<union> analz G"
apply (intro equalityI, rule subsetI)
apply (erule analz.induct)
using assms by auto
lemma analz_list_set (*[simp]*):
"\<not>(\<exists> K . Key K \<in> analz (L`ls))
\<Longrightarrow> analz (L`ls) = (L`ls) \<union> (\<Union>l \<in> ls. analz (set l)) "
apply (rule equalityI, rule subsetI)
apply (erule analz.induct, auto)
using L_analz image_subset_iff analz_increasing analz_trans by metis
lemma analz_fset_set (*[simp]*):
"\<not>(\<exists> K . Key K \<in> analz (FS`ls))
\<Longrightarrow> analz (FS`ls) = (FS`ls) \<union> (\<Union>l \<in> ls. analz (fset l)) "
apply (rule equalityI, rule subsetI)
apply (erule analz.induct, auto)
using FS_analz image_subset_iff analz_increasing analz_trans by metis
subsection \<open>Inductive relation "synth"\<close>
text \<open>Inductive definition of "synth" -- what can be built up from a set of
messages. A form of upward closure. Pairs can be built, messages
encrypted with known keys. AS names are public domain.
Nums can be guessed, but Nonces cannot be.\<close>
inductive_set
synth :: "msgterm set \<Rightarrow> msgterm set"
for H :: "msgterm set"
where
Inj [intro]: "X \<in> H \<Longrightarrow> X \<in> synth H"
| \<epsilon> [simp,intro!]: "\<epsilon> \<in> synth H"
| AS [simp,intro!]: "AS agt \<in> synth H"
| Num [simp,intro!]: "Num n \<in> synth H"
| Lst [intro]: "\<lbrakk> \<And>x . x \<in> set xs \<Longrightarrow> x \<in> synth H \<rbrakk> \<Longrightarrow> L xs \<in> synth H"
| FSt [intro]: "\<lbrakk> \<And>x . x \<in> fset xs \<Longrightarrow> x \<in> synth H;
\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys \<rbrakk>
\<Longrightarrow> FS xs \<in> synth H"
| Hash [intro]: "X \<in> synth H \<Longrightarrow> Hash X \<in> synth H"
| MPair [intro]: "\<lbrakk> X \<in> synth H; Y \<in> synth H \<rbrakk> \<Longrightarrow> \<langle>X,Y\<rangle> \<in> synth H"
| Crypt [intro]: "\<lbrakk> X \<in> synth H; Key K \<in> H \<rbrakk> \<Longrightarrow> Crypt K X \<in> synth H"
(*removed fcard xs \<noteq> Suc 0 from FSt premise*)
text \<open>Monotonicity\<close>
lemma synth_mono: "G \<subseteq> H \<Longrightarrow> synth(G) \<subseteq> synth(H)"
apply (auto, erule synth.induct, auto)
by blast
text \<open>NO @{text AS_synth}, as any AS name can be synthesized.
The same holds for @{term Num}\<close>
inductive_cases Key_synth [elim!]: "Key K \<in> synth H"
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Hash_synth [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "\<langle>X,Y\<rangle> \<in> synth H"
inductive_cases L_synth [elim!]: "L X \<in> synth H"
inductive_cases FS_synth [elim!]: "FS X \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"
lemma synth_increasing: "H \<subseteq> synth(H)"
by blast
lemma synth_analz_self: "x \<in> H \<Longrightarrow> x \<in> synth (analz H)"
by blast
subsubsection \<open>Unions\<close>
text \<open>Converse fails: we can synth more from the union than from the
separate parts, building a compound message using elements of each.\<close>
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)
lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])
subsubsection \<open>Idempotence and transitivity\<close>
lemma synth_synthD [dest!]: "X\<in> synth (synth H) \<Longrightarrow> X \<in> synth H"
apply (erule synth.induct, blast)
apply auto by blast
lemma synth_idem: "synth (synth H) = synth H"
by blast
lemma synth_subset_iff [simp]: "(synth G \<subseteq> synth H) = (G \<subseteq> synth H)"
apply (rule iffI)
apply (iprover intro: subset_trans synth_increasing)
apply (frule synth_mono, simp add: synth_idem)
done
lemma synth_trans: "\<lbrakk> X\<in> synth G; G \<subseteq> synth H \<rbrakk> \<Longrightarrow> X\<in> synth H"
by (drule synth_mono, blast)
text \<open>Cut; Lemma 2 of Lowe\<close>
lemma synth_cut: "\<lbrakk> Y\<in> synth (insert X H); X\<in> synth H \<rbrakk> \<Longrightarrow> Y\<in> synth H"
by (erule synth_trans, blast)
lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast
lemma Key_synth_eq [simp]: "(Key K \<in> synth H) = (Key K \<in> H)"
by blast
lemma Crypt_synth_eq [simp]:
"Key K \<notin> H \<Longrightarrow> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast
lemma keysFor_synth [simp]:
"keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)
lemma L_cons_synth [simp]:
"(set xs \<subseteq> H) \<Longrightarrow> (L xs \<in> synth H)"
by auto
lemma FS_cons_synth [simp]:
"\<lbrakk>fset xs \<subseteq> H; \<And>x ys. x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow> (FS xs \<in> synth H)"
by auto
subsubsection \<open>Combinations of parts, analz and synth\<close>
lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
proof (safe del: UnCI)
fix X
assume "X \<in> parts (synth H)"
thus "X \<in> parts H \<union> synth H"
by (induct rule: parts.induct)
(auto intro: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)
next
fix X
assume "X \<in> parts H"
thus "X \<in> parts (synth H)"
by (induction rule: parts.induct)
(auto intro: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)
next
fix X
assume "X \<in> synth H"
thus "X \<in> parts (synth H)"
apply (induction rule: synth.induct)
apply(auto intro: parts.Fst parts.Snd parts.Lst parts.FSt parts.Body)
by blast
qed
lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done
lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
proof (safe del: UnCI)
fix X
assume "X \<in> analz (synth G \<union> H)"
thus "X \<in> analz (G \<union> H) \<union> synth G"
by (induction rule: analz.induct)
(auto intro: analz.Fst analz.Snd analz.Lst analz.FSt analz.Decrypt)
qed (auto elim: analz_mono [THEN [2] rev_subsetD])
lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done
lemma analz_Un_analz [simp]: "analz (G \<union> analz H) = analz (G \<union> H)"
by (subst Un_commute, auto)+
lemma analz_synth_Un2 [simp]: "analz (G \<union> synth H) = analz (G \<union> H) \<union> synth H"
by (subst Un_commute, auto)+
subsubsection \<open>For reasoning about the Fake rule in traces\<close>
lemma parts_insert_subset_Un: "X\<in> G \<Longrightarrow> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)
text \<open>More specifically for Fake. Very occasionally we could do with a version
of the form @{term"parts{X} \<subseteq> synth (analz H) \<union> parts H"}\<close>
lemma Fake_parts_insert:
"X \<in> synth (analz H) \<Longrightarrow>
parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done
lemma Fake_parts_insert_in_Un:
"\<lbrakk>Z \<in> parts (insert X H); X \<in> synth (analz H)\<rbrakk>
\<Longrightarrow> Z \<in> synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])
text \<open>@{term H} is sometimes @{term"Key ` KK \<union> spies evs"}, so can't put @{term "G=H"}.\<close>
lemma Fake_analz_insert:
"X\<in> synth (analz G) \<Longrightarrow>
analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
prefer 2
apply (blast intro: analz_mono [THEN [2] rev_subsetD]
analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done
lemma analz_conj_parts [simp]:
"(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])
lemma analz_disj_parts [simp]:
"(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])
text \<open>Without this equation, other rules for synth and analz would yield
redundant cases\<close>
lemma MPair_synth_analz [iff]:
"(\<langle>X,Y\<rangle> \<in> synth (analz H)) =
(X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast
lemma L_cons_synth_analz [iff]:
"(L xs \<in> synth (analz H)) =
(set xs \<subseteq> synth (analz H))"
by blast
lemma L_cons_synth_parts [iff]:
"(L xs \<in> synth (parts H)) =
(set xs \<subseteq> synth (parts H))"
by blast
lemma FS_cons_synth_analz [iff]:
"\<lbrakk>\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow>
(FS xs \<in> synth (analz H)) =
(fset xs \<subseteq> synth (analz H))"
by blast
lemma FS_cons_synth_parts [iff]:
"\<lbrakk>\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys; fcard xs \<noteq> Suc 0 \<rbrakk> \<Longrightarrow>
(FS xs \<in> synth (parts H)) =
(fset xs \<subseteq> synth (parts H))"
by blast
lemma Crypt_synth_analz:
"\<lbrakk> Key K \<in> analz H; Key (invKey K) \<in> analz H \<rbrakk>
\<Longrightarrow> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast
lemma Hash_synth_analz [simp]:
"X \<notin> synth (analz H)
\<Longrightarrow> (Hash\<langle>X,Y\<rangle> \<in> synth (analz H)) = (Hash\<langle>X,Y\<rangle> \<in> analz H)"
by blast
subsection \<open>HPair: a combination of Hash and MPair\<close>
text \<open>We do NOT want Crypt... messages broken up in protocols!!\<close>
declare parts.Body [rule del]
text \<open>Rewrites to push in Key and Crypt messages, so that other messages can
be pulled out using the @{text analz_insert} rules\<close>
(*needed?*)
lemmas pushKeys =
insert_commute [of "Key K" "AS C" for K C]
insert_commute [of "Key K" "Nonce N" for K N]
insert_commute [of "Key K" "Num N" for K N]
insert_commute [of "Key K" "Hash X" for K X]
insert_commute [of "Key K" "MPair X Y" for K X Y]
insert_commute [of "Key K" "Crypt X K'" for K K' X]
(*needed?*)
lemmas pushCrypts =
insert_commute [of "Crypt X K" "AS C" for X K C]
insert_commute [of "Crypt X K" "AS C" for X K C]
insert_commute [of "Crypt X K" "Nonce N" for X K N]
insert_commute [of "Crypt X K" "Num N" for X K N]
insert_commute [of "Crypt X K" "Hash X'" for X K X']
insert_commute [of "Crypt X K" "MPair X' Y" for X K X' Y]
text \<open>Cannot be added with @{text "[simp]"} -- messages should not always be
re-ordered.\<close>
lemmas pushes = pushKeys pushCrypts
text \<open>By default only @{text o_apply} is built-in. But in the presence of
eta-expansion this means that some terms displayed as @{term "f o g"} will be
rewritten, and others will not!\<close>
declare o_def [simp]
lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto
lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto
lemma synth_analz_mono: "G\<subseteq>H \<Longrightarrow> synth (analz(G)) \<subseteq> synth (analz(H))"
by (iprover intro: synth_mono analz_mono)
lemma synth_parts_mono: "G\<subseteq>H \<Longrightarrow> synth (parts G) \<subseteq> synth (parts H)"
by (iprover intro: synth_mono parts_mono)
lemma Fake_analz_eq [simp]:
"X \<in> synth(analz H) \<Longrightarrow> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (rule equalityI)
apply (simp add: )
apply (rule synth_analz_mono, blast)
done
text \<open>Two generalizations of @{text analz_insert_eq}\<close>
lemma gen_analz_insert_eq [rule_format]:
"X \<in> analz H \<Longrightarrow> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])
lemma Fake_parts_sing:
"X \<in> synth (analz H) \<Longrightarrow> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
apply (erule_tac [2] Fake_parts_insert)
apply (rule parts_mono, blast)
done
lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]
text \<open>For some reason, moving this up can make some proofs loop!\<close>
declare invKey_K [simp]
lemma synth_analz_insert:
assumes "analz H \<subseteq> synth (analz H')"
shows "analz (insert X H) \<subseteq> synth (analz (insert X H'))"
proof
fix x
assume "x \<in> analz (insert X H)"
then have "x \<in> analz (insert X (synth (analz H')))"
using assms by (meson analz_increasing analz_monotonic insert_mono)
then show "x \<in> synth (analz (insert X H'))"
by (metis (no_types) Un_iff analz_idem analz_insert analz_monotonic analz_synth synth.Inj
synth_insert synth_mono)
qed
lemma synth_parts_insert:
assumes "parts H \<subseteq> synth (parts H')"
shows "parts (insert X H) \<subseteq> synth (parts (insert X H'))"
proof
fix x
assume "x \<in> parts (insert X H)"
then have "x \<in> parts (insert X (synth (parts H')))"
using assms parts_increasing
by (metis UnE UnI1 analz_monotonic analz_parts parts_insert parts_insertI)
then show "x \<in> synth (parts (insert X H'))"
using Un_iff parts_idem parts_insert parts_synth synth.Inj
by (metis Un_subset_iff synth_increasing synth_trans)
qed
lemma parts_insert_subset_impl:
"\<lbrakk>x \<in> parts (insert a G); x \<in> parts G \<Longrightarrow> x \<in> synth (parts H); a \<in> synth (parts H)\<rbrakk>
\<Longrightarrow> x \<in> synth (parts H)"
using Fake_parts_sing in_parts_UnE insert_is_Un
parts_idem parts_synth subsetCE sup.absorb2 synth_idem synth_increasing
by (metis (no_types, lifting) analz_parts)
lemma synth_parts_subset_elem:
"\<lbrakk>A \<subseteq> synth (parts B); x \<in> parts A\<rbrakk> \<Longrightarrow> x \<in> synth (parts B)"
by (meson parts_emptyE parts_insert_subset_impl parts_singleton subset_iff)
lemma synth_parts_subset:
"A \<subseteq> synth (parts B) \<Longrightarrow> parts A \<subseteq> synth (parts B)"
by (auto simp add: synth_parts_subset_elem)
lemma parts_synth_parts[simp]: "parts (synth (parts H)) = synth (parts H)"
by auto
lemma synth_parts_trans:
assumes "A \<subseteq> synth (parts B)" and "B \<subseteq> synth (parts C)"
shows "A \<subseteq> synth (parts C)"
using assms by (metis order_trans parts_synth_parts synth_idem synth_parts_mono)
lemma synth_parts_trans_elem:
assumes "x \<in> A" and "A \<subseteq> synth (parts B)" and "B \<subseteq> synth (parts C)"
shows "x \<in> synth (parts C)"
using synth_parts_trans assms by auto
lemma synth_un_parts_split:
assumes "x \<in> synth (parts A \<union> parts B)"
and "\<And>x . x \<in> A \<Longrightarrow> x \<in> synth (parts C)"
and "\<And>x . x \<in> B \<Longrightarrow> x \<in> synth (parts C)"
shows "x \<in> synth (parts C)"
proof -
have "parts A \<subseteq> synth (parts C)" "parts B \<subseteq> synth (parts C)"
using assms(2) assms(3) synth_parts_subset by blast+
then have "x \<in> synth (synth (parts C) \<union> synth (parts C))" using assms(1)
using synth_trans by auto
then show ?thesis by auto
qed
subsubsection \<open>Normalization of Messages\<close>
text\<open>Prevent FS from being contained directly in other FS.
For instance, a term @{term "FS {| FS {| Num 0 |}, Num 0 |}"} is
not normalized, whereas @{term "FS {| Hash (FS {| Num 0 |}), Num 0 |}"} is normalized.\<close>
inductive normalized :: "msgterm \<Rightarrow> bool" where
\<epsilon> [simp,intro!]: "normalized \<epsilon>"
| AS [simp,intro!]: "normalized (AS agt)"
| Num [simp,intro!]: "normalized (Num n)"
| Key [simp,intro!]: "normalized (Key n)"
| Nonce [simp,intro!]: "normalized (Nonce n)"
| Lst [intro]: "\<lbrakk> \<And>x . x \<in> set xs \<Longrightarrow> normalized x \<rbrakk> \<Longrightarrow> normalized (L xs)"
| FSt [intro]: "\<lbrakk> \<And>x . x \<in> fset xs \<Longrightarrow> normalized x;
\<And>x ys . x \<in> fset xs \<Longrightarrow> x \<noteq> FS ys \<rbrakk>
\<Longrightarrow> normalized (FS xs)"
| Hash [intro]: "normalized X \<Longrightarrow> normalized (Hash X)"
| MPair [intro]: "\<lbrakk> normalized X; normalized Y \<rbrakk> \<Longrightarrow> normalized \<langle>X,Y\<rangle>"
| Crypt [intro]: "\<lbrakk> normalized X \<rbrakk> \<Longrightarrow> normalized (Crypt K X)"
thm normalized.simps
find_theorems normalized
text\<open>Examples\<close>
lemma "normalized (FS {| Hash (FS {| Num 0 |}), Num 0 |})" by fastforce
lemma "\<not> normalized (FS {| FS {| Num 0 |}, Num 0 |})" by (auto elim: normalized.cases)
subsubsection\<open>Closure of @{text "normalized"} under @{text "parts"}, @{text "analz"} and @{text "synth"}\<close>
text\<open>All synthesized terms are normalized (since @{text "synth"} prevents directly nested FSets).\<close>
lemma normalized_synth[elim!]: "\<lbrakk>t \<in> synth H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
by(induction t, auto 3 4)
lemma normalized_parts[elim!]: "\<lbrakk>t \<in> parts H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
by(induction t rule: parts.induct)
(auto elim: normalized.cases)
lemma normalized_analz[elim!]: "\<lbrakk>t \<in> analz H; \<And>t. t \<in> H \<Longrightarrow> normalized t\<rbrakk> \<Longrightarrow> normalized t"
by(induction t rule: analz.induct)
(auto elim: normalized.cases)
subsubsection\<open>Properties of @{text "normalized"}\<close>
lemma normalized_FS[elim]: "\<lbrakk>normalized (FS xs); x |\<in>| xs\<rbrakk> \<Longrightarrow> normalized x"
by(auto simp add: normalized.simps[of "FS xs"])
lemma normalized_FS_FS[elim]: "\<lbrakk>normalized (FS xs); x |\<in>| xs; x = FS ys\<rbrakk> \<Longrightarrow> False"
by(auto simp add: normalized.simps[of "FS xs"])
lemma normalized_subset: "\<lbrakk>normalized (FS xs); ys |\<subseteq>| xs\<rbrakk> \<Longrightarrow> normalized (FS ys)"
by (auto intro!: normalized.FSt)
lemma normalized_insert[elim!]: "normalized (FS (finsert x xs)) \<Longrightarrow> normalized (FS xs)"
by(auto elim!: normalized_subset)
lemma normalized_union:
assumes "normalized (FS xs)" "normalized (FS ys)" "zs |\<subseteq>| xs |\<union>| ys"
shows "normalized (FS zs)"
using assms by(auto intro!: normalized.FSt)
lemma normalized_minus[elim]:
assumes "normalized (FS (ys |-| xs))" "normalized (FS xs)"
shows "normalized (FS ys)"
using normalized_union assms by blast
subsubsection\<open>Lemmas that do not use @{text "normalized"}, but are helpful in proving its properties\<close>
lemma FS_mono: "\<lbrakk>zs_s = finsert (f (FS zs_s)) zs_b; \<And> x. size (f x) > size x\<rbrakk> \<Longrightarrow> False"
by (metis (no_types) add.right_neutral add_Suc_right finite_fset finsert.rep_eq less_add_Suc1
msgterm.size(17) not_less_eq size_fset_simps sum.insert_remove)
lemma FS_contr: "\<lbrakk>zs = f (FS {|zs|}); \<And> x. size (f x) > size x\<rbrakk> \<Longrightarrow> False"
using FS_mono by blast
end
diff --git a/thys/Nested_Multisets_Ordinals/Unary_PCF.thy b/thys/Nested_Multisets_Ordinals/Unary_PCF.thy
--- a/thys/Nested_Multisets_Ordinals/Unary_PCF.thy
+++ b/thys/Nested_Multisets_Ordinals/Unary_PCF.thy
@@ -1,659 +1,659 @@
(* Title: Towards Decidability of Behavioral Equivalence for Unary PCF
Author: Dmitriy Traytel <traytel at inf.ethz.ch>, 2017
Maintainer: Dmitriy Traytel <traytel at inf.ethz.ch>
*)
section \<open>Towards Decidability of Behavioral Equivalence for Unary PCF\<close>
theory Unary_PCF
imports
"HOL-Library.FSet"
"HOL-Library.Countable_Set_Type"
"HOL-Library.Nat_Bijection"
Hereditary_Multiset
"List-Index.List_Index"
begin
subsection \<open>Preliminaries\<close>
lemma prod_UNIV: "UNIV = UNIV \<times> UNIV"
by auto
lemma infinite_cartesian_productI1: "infinite A \<Longrightarrow> B \<noteq> {} \<Longrightarrow> infinite (A \<times> B)"
by (auto dest!: finite_cartesian_productD1)
subsection \<open>Types\<close>
datatype type = \<B> ("\<B>") | Fun type type (infixr "\<rightarrow>" 65)
definition mk_fun (infixr "\<rightarrow>\<rightarrow>" 65) where
"Ts \<rightarrow>\<rightarrow> T = fold (\<rightarrow>) (rev Ts) T"
primrec dest_fun where
"dest_fun \<B> = []"
| "dest_fun (T \<rightarrow> U) = T # dest_fun U"
definition arity where
"arity T = length (dest_fun T)"
lemma mk_fun_dest_fun[simp]: "dest_fun T \<rightarrow>\<rightarrow> \<B> = T"
by (induct T) (auto simp: mk_fun_def)
lemma dest_fun_mk_fun[simp]: "dest_fun (Ts \<rightarrow>\<rightarrow> T) = Ts @ dest_fun T"
by (induct Ts) (auto simp: mk_fun_def)
primrec \<delta> where
"\<delta> \<B> = HMSet {#}"
| "\<delta> (T \<rightarrow> U) = HMSet (add_mset (\<delta> T) (hmsetmset (\<delta> U)))"
lemma \<delta>_mk_fun: "\<delta> (Ts \<rightarrow>\<rightarrow> T) = HMSet (hmsetmset (\<delta> T) + mset (map \<delta> Ts))"
by (induct Ts) (auto simp: mk_fun_def)
lemma type_induct [case_names Fun]:
assumes
"(\<And>T. (\<And>T1 T2. T = T1 \<rightarrow> T2 \<Longrightarrow> P T1) \<Longrightarrow>
(\<And>T1 T2. T = T1 \<rightarrow> T2 \<Longrightarrow> P T2) \<Longrightarrow> P T)"
shows "P T"
proof (induct T)
case \<B>
show ?case by (rule assms) simp_all
next
case Fun
show ?case by (rule assms) (insert Fun, simp_all)
qed
subsection \<open>Terms\<close>
type_synonym name = string
type_synonym idx = nat
datatype expr =
Var "name * type" ("\<langle>_\<rangle>") | Bound idx | B bool
| Seq expr expr (infixr "?" 75) | App expr expr (infixl "\<cdot>" 75)
| Abs type expr ("\<Lambda>\<langle>_\<rangle> _" [100, 100] 800)
declare [[coercion_enabled]]
declare [[coercion B]]
declare [[coercion Bound]]
notation (output) B ("_")
notation (output) Bound ("_")
primrec "open" :: "idx \<Rightarrow> expr \<Rightarrow> expr \<Rightarrow> expr" where
"open i t (j :: idx) = (if i = j then t else j)"
| "open i t \<langle>yU\<rangle> = \<langle>yU\<rangle>"
| "open i t (b :: bool) = b"
| "open i t (e1 ? e2) = open i t e1 ? open i t e2"
| "open i t (e1 \<cdot> e2) = open i t e1 \<cdot> open i t e2"
| "open i t (\<Lambda>\<langle>U\<rangle> e) = \<Lambda>\<langle>U\<rangle> (open (i + 1) t e)"
abbreviation "open0 \<equiv> open 0"
abbreviation "open_Var i xT \<equiv> open i \<langle>xT\<rangle>"
abbreviation "open0_Var xT \<equiv> open 0 \<langle>xT\<rangle>"
primrec "close_Var" :: "idx \<Rightarrow> name \<times> type \<Rightarrow> expr \<Rightarrow> expr" where
"close_Var i xT (j :: idx) = j"
| "close_Var i xT \<langle>yU\<rangle> = (if xT = yU then i else \<langle>yU\<rangle>)"
| "close_Var i xT (b :: bool) = b"
| "close_Var i xT (e1 ? e2) = close_Var i xT e1 ? close_Var i xT e2"
| "close_Var i xT (e1 \<cdot> e2) = close_Var i xT e1 \<cdot> close_Var i xT e2"
| "close_Var i xT (\<Lambda>\<langle>U\<rangle> e) = \<Lambda>\<langle>U\<rangle> (close_Var (i + 1) xT e)"
abbreviation "close0_Var \<equiv> close_Var 0"
primrec "fv" :: "expr \<Rightarrow> (name \<times> type) fset" where
"fv (j :: idx) = {||}"
| "fv \<langle>yU\<rangle> = {|yU|}"
| "fv (b :: bool) = {||}"
| "fv (e1 ? e2) = fv e1 |\<union>| fv e2"
| "fv (e1 \<cdot> e2) = fv e1 |\<union>| fv e2"
| "fv (\<Lambda>\<langle>U\<rangle> e) = fv e"
abbreviation "fresh x e \<equiv> x |\<notin>| fv e"
lemma ex_fresh: "\<exists>x. (x :: char list, T) |\<notin>| A"
proof (rule ccontr, unfold not_ex not_not)
assume "\<forall>x. (x, T) |\<in>| A"
then have "infinite {x. (x, T) |\<in>| A}" (is "infinite ?P")
by (auto simp add: infinite_UNIV_listI)
moreover
have "?P \<subseteq> fst ` fset A"
- by (force simp: fmember.rep_eq)
+ by (force simp: fmember_iff_member_fset)
from finite_surj[OF _ this] have "finite ?P"
by simp
ultimately show False by blast
qed
inductive lc where
lc_Var[simp]: "lc \<langle>xT\<rangle>"
| lc_B[simp]: "lc (b :: bool)"
| lc_Seq: "lc e1 \<Longrightarrow> lc e2 \<Longrightarrow> lc (e1 ? e2)"
| lc_App: "lc e1 \<Longrightarrow> lc e2 \<Longrightarrow> lc (e1 \<cdot> e2)"
| lc_Abs: "(\<forall>x. (x, T) |\<notin>| X \<longrightarrow> lc (open0_Var (x, T) e)) \<Longrightarrow> lc (\<Lambda>\<langle>T\<rangle> e)"
declare lc.intros[intro]
definition "body T t \<equiv> (\<exists>X. \<forall>x. (x, T) |\<notin>| X \<longrightarrow> lc (open0_Var (x, T) t))"
lemma lc_Abs_iff_body: "lc (\<Lambda>\<langle>T\<rangle> t) \<longleftrightarrow> body T t"
unfolding body_def by (subst lc.simps) simp
lemma fv_open_Var: "fresh xT t \<Longrightarrow> fv (open_Var i xT t) |\<subseteq>| finsert xT (fv t)"
by (induct t arbitrary: i) auto
lemma fv_close_Var[simp]: "fv (close_Var i xT t) = fv t |-| {|xT|}"
by (induct t arbitrary: i) auto
lemma close_Var_open_Var[simp]: "fresh xT t \<Longrightarrow> close_Var i xT (open_Var i xT t) = t"
by (induct t arbitrary: i) auto
lemma open_Var_inj: "fresh xT t \<Longrightarrow> fresh xT u \<Longrightarrow> open_Var i xT t = open_Var i xT u \<Longrightarrow> t = u"
by (metis close_Var_open_Var)
context begin
private lemma open_Var_open_Var_close_Var: "i \<noteq> j \<Longrightarrow> xT \<noteq> yU \<Longrightarrow> fresh yU t \<Longrightarrow>
open_Var i yU (open_Var j zV (close_Var j xT t)) = open_Var j zV (close_Var j xT (open_Var i yU t))"
by (induct t arbitrary: i j) auto
lemma open_Var_close_Var[simp]: "lc t \<Longrightarrow> open_Var i xT (close_Var i xT t) = t"
proof (induction t arbitrary: i rule: lc.induct)
case (lc_Abs T X e i)
obtain x where x: "fresh (x, T) e" "(x, T) \<noteq> xT" "(x, T) |\<notin>| X"
using ex_fresh[of _ "fv e |\<union>| finsert xT X"] by blast
with lc_Abs.IH have "lc (open0_Var (x, T) e)"
"open_Var (i + 1) xT (close_Var (i + 1) xT (open0_Var (x, T) e)) = open0_Var (x, T) e"
by auto
with x show ?case
by (auto simp: open_Var_open_Var_close_Var
dest: fset_mp[OF fv_open_Var, rotated]
intro!: open_Var_inj[of "(x, T)" _ e 0])
qed auto
end
lemma close_Var_inj: "lc t \<Longrightarrow> lc u \<Longrightarrow> close_Var i xT t = close_Var i xT u \<Longrightarrow> t = u"
by (metis open_Var_close_Var)
primrec Apps (infixl "\<bullet>" 75) where
"f \<bullet> [] = f"
| "f \<bullet> (x # xs) = f \<cdot> x \<bullet> xs"
lemma Apps_snoc: "f \<bullet> (xs @ [x]) = f \<bullet> xs \<cdot> x"
by (induct xs arbitrary: f) auto
lemma Apps_append: "f \<bullet> (xs @ ys) = f \<bullet> xs \<bullet> ys"
by (induct xs arbitrary: f) auto
lemma Apps_inj[simp]: "f \<bullet> ts = g \<bullet> ts \<longleftrightarrow> f = g"
by (induct ts arbitrary: f g) auto
lemma eq_Apps_conv[simp]:
fixes i :: idx and b :: bool and f :: expr and ts :: "expr list"
shows
"(\<langle>m\<rangle> = f \<bullet> ts) = (\<langle>m\<rangle> = f \<and> ts = [])"
"(f \<bullet> ts = \<langle>m\<rangle>) = (\<langle>m\<rangle> = f \<and> ts = [])"
"(i = f \<bullet> ts) = (i = f \<and> ts = [])"
"(f \<bullet> ts = i) = (i = f \<and> ts = [])"
"(b = f \<bullet> ts) = (b = f \<and> ts = [])"
"(f \<bullet> ts = b) = (b = f \<and> ts = [])"
"(e1 ? e2 = f \<bullet> ts) = (e1 ? e2 = f \<and> ts = [])"
"(f \<bullet> ts = e1 ? e2) = (e1 ? e2 = f \<and> ts = [])"
"(\<Lambda>\<langle>T\<rangle> t = f \<bullet> ts) = (\<Lambda>\<langle>T\<rangle> t = f \<and> ts = [])"
"(f \<bullet> ts = \<Lambda>\<langle>T\<rangle> t) = (\<Lambda>\<langle>T\<rangle> t = f \<and> ts = [])"
by (induct ts arbitrary: f) auto
lemma Apps_Var_eq[simp]: "\<langle>xT\<rangle> \<bullet> ss = \<langle>yU\<rangle> \<bullet> ts \<longleftrightarrow> xT = yU \<and> ss = ts"
proof (induct ss arbitrary: ts rule: rev_induct)
case snoc
then show ?case by (induct ts rule: rev_induct) (auto simp: Apps_snoc)
qed auto
lemma Apps_Abs_neq_Apps[simp, symmetric, simp]:
"\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> \<langle>xT\<rangle> \<bullet> ss"
"\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (i :: idx) \<bullet> ss"
"\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (b :: bool) \<bullet> ss"
"\<Lambda>\<langle>T\<rangle> r \<cdot> t \<noteq> (e1 ? e2) \<bullet> ss"
by (induct ss rule: rev_induct) (auto simp: Apps_snoc)
lemma App_Abs_eq_Apps_Abs[simp]: "\<Lambda>\<langle>T\<rangle> r \<cdot> t = \<Lambda>\<langle>T'\<rangle> r' \<bullet> ss \<longleftrightarrow> T = T' \<and> r = r' \<and> ss = [t]"
by (induct ss rule: rev_induct) (auto simp: Apps_snoc)
lemma Apps_Var_neq_Apps_Abs[simp, symmetric, simp]: "\<langle>xT\<rangle> \<bullet> ss \<noteq> \<Lambda>\<langle>T\<rangle> r \<bullet> ts"
proof (induct ss arbitrary: ts rule: rev_induct)
case (snoc a ss)
then show ?case by (induct ts rule: rev_induct) (auto simp: Apps_snoc)
qed simp
lemma Apps_Var_neq_Apps_beta[simp, THEN not_sym, simp]:
"\<langle>xT\<rangle> \<bullet> ss \<noteq> \<Lambda>\<langle>T\<rangle> r \<cdot> s \<bullet> ts"
by (metis Apps_Var_neq_Apps_Abs Apps_append Apps_snoc eq_Apps_conv(9))
lemma [simp]:
"(\<Lambda>\<langle>T\<rangle> r \<bullet> ts = \<Lambda>\<langle>T'\<rangle> r' \<cdot> s' \<bullet> ts') = (T = T' \<and> r = r' \<and> ts = s' # ts')"
proof (induct ts arbitrary: ts' rule: rev_induct)
case Nil
then show ?case by (induct ts' rule: rev_induct) (auto simp: Apps_snoc)
next
case snoc
then show ?case by (induct ts' rule: rev_induct) (auto simp: Apps_snoc)
qed
lemma fold_eq_Bool_iff[simp]:
"fold (\<rightarrow>) (rev Ts) T = \<B> \<longleftrightarrow> Ts = [] \<and> T = \<B>"
"\<B> = fold (\<rightarrow>) (rev Ts) T \<longleftrightarrow> Ts = [] \<and> T = \<B>"
by (induct Ts) auto
lemma fold_eq_Fun_iff[simp]:
"fold (\<rightarrow>) (rev Ts) T = U \<rightarrow> V \<longleftrightarrow>
(Ts = [] \<and> T = U \<rightarrow> V \<or> (\<exists>Us. Ts = U # Us \<and> fold (\<rightarrow>) (rev Us) T = V))"
by (induct Ts) auto
subsection \<open>Substitution\<close>
primrec subst where
"subst xT t \<langle>yU\<rangle> = (if xT = yU then t else \<langle>yU\<rangle>)"
| "subst xT t (i :: idx) = i"
| "subst xT t (b :: bool) = b"
| "subst xT t (e1 ? e2) = subst xT t e1 ? subst xT t e2"
| "subst xT t (e1 \<cdot> e2) = subst xT t e1 \<cdot> subst xT t e2"
| "subst xT t (\<Lambda>\<langle>T\<rangle> e) = \<Lambda>\<langle>T\<rangle> (subst xT t e)"
lemma fv_subst:
"fv (subst xT t u) = fv u |-| {|xT|} |\<union>| (if xT |\<in>| fv u then fv t else {||})"
by (induct u) auto
lemma subst_fresh: "fresh xT u \<Longrightarrow> subst xT t u = u"
by (induct u) auto
context begin
private lemma open_open_id: "i \<noteq> j \<Longrightarrow> open i t (open j t' u) = open j t' u \<Longrightarrow> open i t u = u"
by (induct u arbitrary: i j) (auto 6 0)
lemma lc_open_id: "lc u \<Longrightarrow> open k t u = u"
proof (induct u arbitrary: k rule: lc.induct)
case (lc_Abs T X e)
obtain x where x: "fresh (x, T) e" "(x, T) |\<notin>| X"
using ex_fresh[of _ "fv e |\<union>| X"] by blast
with lc_Abs show ?case
by (auto intro: open_open_id dest: spec[of _ x] spec[of _ "Suc k"])
qed auto
lemma subst_open: "lc u \<Longrightarrow> subst xT u (open i t v) = open i (subst xT u t) (subst xT u v)"
by (induction v arbitrary: i) (auto intro: lc_open_id[symmetric])
lemma subst_open_Var:
"xT \<noteq> yU \<Longrightarrow> lc u \<Longrightarrow> subst xT u (open_Var i yU v) = open_Var i yU (subst xT u v)"
by (auto simp: subst_open)
lemma subst_Apps[simp]:
"subst xT u (f \<bullet> xs) = subst xT u f \<bullet> map (subst xT u) xs"
by (induct xs arbitrary: f) auto
end
context begin
private lemma fresh_close_Var_id: "fresh xT t \<Longrightarrow> close_Var k xT t = t"
by (induct t arbitrary: k) auto
lemma subst_close_Var:
"xT \<noteq> yU \<Longrightarrow> fresh yU u \<Longrightarrow> subst xT u (close_Var i yU t) = close_Var i yU (subst xT u t)"
by (induct t arbitrary: i) (auto simp: fresh_close_Var_id)
end
lemma subst_intro: "fresh xT t \<Longrightarrow> lc u \<Longrightarrow> open0 u t = subst xT u (open0_Var xT t)"
by (auto simp: subst_fresh subst_open)
lemma lc_subst[simp]: "lc u \<Longrightarrow> lc t \<Longrightarrow> lc (subst xT t u)"
proof (induct u rule: lc.induct)
case (lc_Abs T X e)
then show ?case
by (auto simp: subst_open_Var intro!: lc.lc_Abs[of _ "fv e |\<union>| X |\<union>| {|xT|}"])
qed auto
lemma body_subst[simp]: "body U u \<Longrightarrow> lc t \<Longrightarrow> body U (subst xT t u)"
proof (subst (asm) body_def, elim conjE exE)
fix X
assume [simp]: "lc t" "\<forall>x. (x, U) |\<notin>| X \<longrightarrow> lc (open0_Var (x, U) u)"
show "body U (subst xT t u)"
proof (unfold body_def, intro exI[of _ "finsert xT X"] conjI allI impI)
fix x
assume "(x, U) |\<notin>| finsert xT X"
then show "lc (open0_Var (x, U) (subst xT t u))"
by (auto simp: subst_open_Var[symmetric])
qed
qed
lemma lc_open_Var: "lc u \<Longrightarrow> lc (open_Var i xT u)"
by (simp add: lc_open_id)
lemma lc_open[simp]: "body U u \<Longrightarrow> lc t \<Longrightarrow> lc (open0 t u)"
proof (unfold body_def, elim conjE exE)
fix X
assume [simp]: "lc t" "\<forall>x. (x, U) |\<notin>| X \<longrightarrow> lc (open0_Var (x, U) u)"
with ex_fresh[of _ "fv u |\<union>| X"] obtain x where [simp]: "fresh (x, U) u" "(x, U) |\<notin>| X" by blast
show ?thesis by (subst subst_intro[of "(x, U)"]) auto
qed
subsection \<open>Typing\<close>
inductive welltyped :: "expr \<Rightarrow> type \<Rightarrow> bool" (infix ":::" 60) where
welltyped_Var[intro!]: "\<langle>(x, T)\<rangle> ::: T"
| welltyped_B[intro!]: "(b :: bool) ::: \<B>"
| welltyped_Seq[intro!]: "e1 ::: \<B> \<Longrightarrow> e2 ::: \<B> \<Longrightarrow> e1 ? e2 ::: \<B>"
| welltyped_App[intro]: "e1 ::: T \<rightarrow> U \<Longrightarrow> e2 ::: T \<Longrightarrow> e1 \<cdot> e2 ::: U"
| welltyped_Abs[intro]: "(\<forall>x. (x, T) |\<notin>| X \<longrightarrow> open0_Var (x, T) e ::: U) \<Longrightarrow> \<Lambda>\<langle>T\<rangle> e ::: T \<rightarrow> U"
inductive_cases welltypedE[elim!]:
"\<langle>x\<rangle> ::: T"
"(i :: idx) ::: T"
"(b :: bool) ::: T"
"e1 ? e2 ::: T"
"e1 \<cdot> e2 ::: T"
"\<Lambda>\<langle>T\<rangle> e ::: U"
lemma welltyped_unique: "t ::: T \<Longrightarrow> t ::: U \<Longrightarrow> T = U"
proof (induction t T arbitrary: U rule: welltyped.induct)
case (welltyped_Abs T X t U T')
from welltyped_Abs.prems show ?case
proof (elim welltypedE)
fix Y U'
obtain x where [simp]: "(x, T) |\<notin>| X" "(x, T) |\<notin>| Y"
using ex_fresh[of _ "X |\<union>| Y"] by blast
assume [simp]: "T' = T \<rightarrow> U'" "\<forall>x. (x, T) |\<notin>| Y \<longrightarrow> open0_Var (x, T) t ::: U'"
show "T \<rightarrow> U = T'"
by (auto intro: conjunct2[OF welltyped_Abs.IH[rule_format], rule_format, of x])
qed
qed blast+
lemma welltyped_lc[simp]: "t ::: T \<Longrightarrow> lc t"
by (induction t T rule: welltyped.induct) auto
lemma welltyped_subst[intro]:
"u ::: U \<Longrightarrow> t ::: snd xT \<Longrightarrow> subst xT t u ::: U"
proof (induction u U rule: welltyped.induct)
case (welltyped_Abs T' X u U)
then show ?case unfolding subst.simps
by (intro welltyped.welltyped_Abs[of _ "finsert xT X"]) (auto simp: subst_open_Var[symmetric])
qed auto
lemma rename_welltyped: "u ::: U \<Longrightarrow> subst (x, T) \<langle>(y, T)\<rangle> u ::: U"
by (rule welltyped_subst) auto
lemma welltyped_Abs_fresh:
assumes "fresh (x, T) u" "open0_Var (x, T) u ::: U"
shows "\<Lambda>\<langle>T\<rangle> u ::: T \<rightarrow> U"
proof (intro welltyped_Abs[of _ "fv u"] allI impI)
fix y
assume "fresh (y, T) u"
with assms(2) have "subst (x, T) \<langle>(y, T)\<rangle> (open0_Var (x, T) u) ::: U" (is "?t ::: _")
by (auto intro: rename_welltyped)
also have "?t = open0_Var (y, T) u"
by (subst subst_intro[symmetric]) (auto simp: assms(1))
finally show "open0_Var (y, T) u ::: U" .
qed
lemma Apps_alt: "f \<bullet> ts ::: T \<longleftrightarrow>
(\<exists>Ts. f ::: fold (\<rightarrow>) (rev Ts) T \<and> list_all2 (:::) ts Ts)"
proof (induct ts arbitrary: f)
case (Cons t ts)
from Cons(1)[of "f \<cdot> t"] show ?case
by (force simp: list_all2_Cons1)
qed simp
subsection \<open>Definition 10 and Lemma 11 from Schmidt-Schau{\ss}'s paper\<close>
abbreviation "closed t \<equiv> fv t = {||}"
primrec constant0 where
"constant0 \<B> = Var (''bool'', \<B>)"
| "constant0 (T \<rightarrow> U) = \<Lambda>\<langle>T\<rangle> (constant0 U)"
definition "constant T = \<Lambda>\<langle>\<B>\<rangle> (close0_Var (''bool'', \<B>) (constant0 T))"
lemma fv_constant0[simp]: "fv (constant0 T) = {|(''bool'', \<B>)|}"
by (induct T) auto
lemma closed_constant[simp]: "closed (constant T)"
unfolding constant_def by auto
lemma welltyped_constant0[simp]: "constant0 T ::: T"
by (induct T) (auto simp: lc_open_id)
lemma lc_constant0[simp]: "lc (constant0 T)"
using welltyped_constant0 welltyped_lc by blast
lemma welltyped_constant[simp]: "constant T ::: \<B> \<rightarrow> T"
unfolding constant_def by (auto intro: welltyped_Abs_fresh[of "''bool''"])
definition nth_drop where
"nth_drop i xs \<equiv> take i xs @ drop (Suc i) xs"
definition nth_arg (infixl "!-" 100) where
"nth_arg T i \<equiv> nth (dest_fun T) i"
abbreviation ar where
"ar T \<equiv> length (dest_fun T)"
lemma size_nth_arg[simp]: "i < ar T \<Longrightarrow> size (T !- i) < size T"
by (induct T arbitrary: i) (force simp: nth_Cons' nth_arg_def gr0_conv_Suc)+
fun \<pi> :: "type \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> type" where
"\<pi> T i 0 = (if i < ar T then nth_drop i (dest_fun T) \<rightarrow>\<rightarrow> \<B> else \<B>)"
| "\<pi> T i (Suc j) = (if i < ar T \<and> j < ar (T!-i)
then \<pi> (T!-i) j 0 \<rightarrow>
map (\<pi> (T!-i) j o Suc) [0 ..< ar (T!-i!-j)] \<rightarrow>\<rightarrow> \<pi> T i 0 else \<B>)"
theorem \<pi>_induct[rotated -2, consumes 2, case_names 0 Suc]:
assumes "\<And>T i. i < ar T \<Longrightarrow> P T i 0"
and "\<And>T i j. i < ar T \<Longrightarrow> j < ar (T !- i) \<Longrightarrow> P (T !- i) j 0 \<Longrightarrow>
(\<forall>x < ar (T !- i !- j). P (T !- i) j (x + 1)) \<Longrightarrow> P T i (j + 1)"
shows "i < ar T \<Longrightarrow> j \<le> ar (T !- i) \<Longrightarrow> P T i j"
by (induct T i j rule: \<pi>.induct) (auto intro: assms[simplified])
definition \<epsilon> :: "type \<Rightarrow> nat \<Rightarrow> type" where
"\<epsilon> T i = \<pi> T i 0 \<rightarrow> map (\<pi> T i o Suc) [0 ..< ar (T!-i)] \<rightarrow>\<rightarrow> T"
definition Abss ("\<Lambda>[_] _" [100, 100] 800) where
"\<Lambda>[xTs] b = fold (\<lambda>xT t. \<Lambda>\<langle>snd xT\<rangle> close0_Var xT t) (rev xTs) b"
definition Seqs (infixr "??" 75) where
"ts ?? t = fold (\<lambda>u t. u ? t) (rev ts) t"
definition "variant k base = base @ replicate k CHR ''*''"
lemma variant_inj: "variant i base = variant j base \<Longrightarrow> i = j"
unfolding variant_def by auto
lemma variant_inj2:
"CHR ''*'' \<notin> set b1 \<Longrightarrow> CHR ''*'' \<notin> set b2 \<Longrightarrow> variant i b1 = variant j b2 \<Longrightarrow> b1 = b2"
unfolding variant_def
by (auto simp: append_eq_append_conv2)
(metis Nil_is_append_conv hd_append2 hd_in_set hd_rev last_ConsR
last_snoc replicate_append_same rev_replicate)+
fun E :: "type \<Rightarrow> nat \<Rightarrow> expr" and P :: "type \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> expr" where
"E T i = (if i < ar T then (let
Ti = T!-i;
x = \<lambda>k. (variant k ''x'', T!-k);
xs = map x [0 ..< ar T];
xx_var = \<langle>nth xs i\<rangle>;
x_vars = map (\<lambda>x. \<langle>x\<rangle>) (nth_drop i xs);
yy = (''z'', \<pi> T i 0);
yy_var = \<langle>yy\<rangle>;
y = \<lambda>j. (variant j ''y'', \<pi> T i (j + 1));
ys = map y [0 ..< ar Ti];
e = \<lambda>j. \<langle>y j\<rangle> \<bullet> (P Ti j 0 \<cdot> xx_var # map (\<lambda>k. P Ti j (k + 1) \<cdot> xx_var) [0 ..< ar (Ti!-j)]);
guards = map (\<lambda>i. xx_var \<bullet>
map (\<lambda>j. constant (Ti!-j) \<cdot> (if i = j then e i \<bullet> x_vars else True)) [0 ..< ar Ti])
[0 ..< ar Ti]
in \<Lambda>[(yy # ys @ xs)] (guards ?? (yy_var \<bullet> x_vars))) else constant (\<epsilon> T i) \<cdot> False)"
| "P T i 0 =
(if i < ar T then (let
f = (''f'', T);
f_var = \<langle>f\<rangle>;
x = \<lambda>k. (variant k ''x'', T!-k);
xs = nth_drop i (map x [0 ..< ar T]);
x_vars = insert_nth i (constant (T!-i) \<cdot> True) (map (\<lambda>x. \<langle>x\<rangle>) xs)
in \<Lambda>[(f # xs)] (f_var \<bullet> x_vars)) else constant (T \<rightarrow> \<pi> T i 0) \<cdot> False)"
| "P T i (Suc j) = (if i < ar T \<and> j < ar (T!-i) then (let
Ti = T!-i;
Tij = Ti!-j;
f = (''f'', T);
f_var = \<langle>f\<rangle>;
x = \<lambda>k. (variant k ''x'', T!-k);
xs = nth_drop i (map x [0 ..< ar T]);
yy = (''z'', \<pi> Ti j 0);
yy_var = \<langle>yy\<rangle>;
y = \<lambda>k. (variant k ''y'', \<pi> Ti j (k + 1));
ys = map y [0 ..< ar Tij];
y_vars = yy_var # map (\<lambda>x. \<langle>x\<rangle>) ys;
x_vars = insert_nth i (E Ti j \<bullet> y_vars) (map (\<lambda>x. \<langle>x\<rangle>) xs)
in \<Lambda>[(f # yy # ys @ xs)] (f_var \<bullet> x_vars)) else constant (T \<rightarrow> \<pi> T i (j + 1)) \<cdot> False)"
lemma Abss_Nil[simp]: "\<Lambda>[[]] b = b"
unfolding Abss_def by simp
lemma Abss_Cons[simp]: "\<Lambda>[(x#xs)] b = \<Lambda>\<langle>snd x\<rangle> (close0_Var x (\<Lambda>[xs] b))"
unfolding Abss_def by simp
lemma welltyped_Abss: "b ::: U \<Longrightarrow> T = map snd xTs \<rightarrow>\<rightarrow> U \<Longrightarrow> \<Lambda>[xTs] b ::: T"
by (hypsubst_thin, induct xTs) (auto simp: mk_fun_def intro!: welltyped_Abs_fresh)
lemma welltyped_Apps: "list_all2 (:::) ts Ts \<Longrightarrow> f ::: Ts \<rightarrow>\<rightarrow> U \<Longrightarrow> f \<bullet> ts ::: U"
by (induct ts Ts arbitrary: f rule: list.rel_induct) (auto simp: mk_fun_def)
lemma welltyped_open_Var_close_Var[intro!]:
"t ::: T \<Longrightarrow> open0_Var xT (close0_Var xT t) ::: T"
by auto
lemma welltyped_Var_iff[simp]:
"\<langle>(x, T)\<rangle> ::: U \<longleftrightarrow> T = U"
by auto
lemma welltyped_bool_iff[simp]: "(b :: bool) ::: T \<longleftrightarrow> T = \<B>"
by auto
lemma welltyped_constant0_iff[simp]: "constant0 T ::: U \<longleftrightarrow> (U = T)"
by (induct T arbitrary: U) (auto simp: ex_fresh lc_open_id)
lemma welltyped_constant_iff[simp]: "constant T ::: U \<longleftrightarrow> (U = \<B> \<rightarrow> T)"
unfolding constant_def
proof (intro iffI, elim welltypedE, hypsubst_thin, unfold type.inject simp_thms)
fix X U
assume "\<forall>x. (x, \<B>) |\<notin>| X \<longrightarrow> open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U"
moreover obtain x where "(x, \<B>) |\<notin>| X" using ex_fresh[of \<B> X] by blast
ultimately have "open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U" by simp
then have "open0_Var (''bool'', \<B>) (close0_Var (''bool'', \<B>) (constant0 T)) ::: U"
using rename_welltyped[of \<open>open0_Var (x, \<B>) (close0_Var (''bool'', \<B>) (constant0 T))\<close>
U x \<B> "''bool''"]
by (auto simp: subst_open subst_fresh)
then show "U = T" by auto
qed (auto intro!: welltyped_Abs_fresh)
lemma welltyped_Seq_iff[simp]: "e1 ? e2 ::: T \<longleftrightarrow> (T = \<B> \<and> e1 ::: \<B> \<and> e2 ::: \<B>)"
by auto
lemma welltyped_Seqs_iff[simp]: "es ?? e ::: T \<longleftrightarrow>
((es \<noteq> [] \<longrightarrow> T = \<B>) \<and> (\<forall>e \<in> set es. e ::: \<B>) \<and> e ::: T)"
by (induct es arbitrary: e) (auto simp: Seqs_def)
lemma welltyped_App_iff[simp]: "f \<cdot> t ::: U \<longleftrightarrow> (\<exists>T. f ::: T \<rightarrow> U \<and> t ::: T)"
by auto
lemma welltyped_Apps_iff[simp]: "f \<bullet> ts ::: U \<longleftrightarrow> (\<exists>Ts. f ::: Ts \<rightarrow>\<rightarrow> U \<and> list_all2 (:::) ts Ts)"
by (induct ts arbitrary: f) (auto 0 3 simp: mk_fun_def list_all2_Cons1 intro: exI[of _ "_ # _"])
lemma eq_mk_fun_iff[simp]: "T = Ts \<rightarrow>\<rightarrow> \<B> \<longleftrightarrow> Ts = dest_fun T"
by auto
lemma map_nth_eq_drop_take[simp]: "j \<le> length xs \<Longrightarrow> map (nth xs) [i ..< j] = drop i (take j xs)"
by (induct j) (auto simp: take_Suc_conv_app_nth)
lemma dest_fun_\<pi>_0: "i < ar T \<Longrightarrow> dest_fun (\<pi> T i 0) = nth_drop i (dest_fun T)"
by auto
lemma welltyped_E: "E T i ::: \<epsilon> T i" and welltyped_P: "P T i j ::: T \<rightarrow> \<pi> T i j"
proof (induct T i and T i j rule: E_P.induct)
case (1 T i)
note P.simps[simp del] \<pi>.simps[simp del] \<epsilon>_def[simp] nth_drop_def[simp] nth_arg_def[simp]
from 1(1)[OF _ refl refl refl refl refl refl refl refl refl]
1(2)[OF _ refl refl refl refl refl refl refl refl refl]
show ?case
by (auto 0 4 simp: Let_def o_def take_map[symmetric] drop_map[symmetric]
list_all2_conv_all_nth nth_append min_def dest_fun_\<pi>_0 \<pi>.simps[of T i]
intro!: welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
next
case (2 T i)
show ?case
by (auto simp: Let_def take_map drop_map o_def list_all2_conv_all_nth nth_append nth_Cons'
nth_drop_def nth_arg_def
intro!: welltyped_constant welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
next
case (3 T i j)
note E.simps[simp del] \<pi>.simps[simp del] Abss_Cons[simp del] \<epsilon>_def[simp]
nth_drop_def[simp] nth_arg_def[simp]
from 3(1)[OF _ refl refl refl refl refl refl refl refl refl refl refl]
show ?case
by (auto 0 3 simp: Let_def o_def take_map[symmetric] drop_map[symmetric]
list_all2_conv_all_nth nth_append nth_Cons' min_def \<pi>.simps[of T i]
intro!: welltyped_Abs_fresh welltyped_Abss[of _ \<B>])
qed
lemma \<delta>_gt_0[simp]: "T \<noteq> \<B> \<Longrightarrow> HMSet {#} < \<delta> T"
by (cases T) auto
lemma mset_nth_drop_less: "i < length xs \<Longrightarrow> mset (nth_drop i xs) < mset xs"
by (induct xs arbitrary: i) (auto simp: take_Cons' nth_drop_def gr0_conv_Suc)
lemma map_nth_drop: "i < length xs \<Longrightarrow> map f (nth_drop i xs) = nth_drop i (map f xs)"
by (induct xs arbitrary: i) (auto simp: take_Cons' nth_drop_def gr0_conv_Suc)
lemma empty_less_mset: "{#} < mset xs \<longleftrightarrow> xs \<noteq> []"
by auto
lemma dest_fun_alt: "dest_fun T = map (\<lambda>i. T !- i) [0..<ar T]"
unfolding list_eq_iff_nth_eq nth_arg_def by auto
context notes \<pi>.simps[simp del] notes One_nat_def[simp del] begin
lemma \<delta>_\<pi>:
assumes "i < ar T" "j \<le> ar (T !- i)"
shows "\<delta> (\<pi> T i j) < \<delta> T"
using assms proof (induct T i j rule: \<pi>_induct)
fix T i
assume "i < ar T"
then show "\<delta> (\<pi> T i 0) < \<delta> T"
by (subst (2) mk_fun_dest_fun[symmetric, of T], unfold \<delta>_mk_fun)
(auto simp: \<delta>_mk_fun mset_map[symmetric] take_map[symmetric] drop_map[symmetric] \<pi>.simps
mset_nth_drop_less map_nth_drop simp del: mset_map)
next
fix T i j
let ?Ti = "T !- i"
assume [rule_format, simp]: "i < ar T" "j < ar ?Ti" "\<delta> (\<pi> ?Ti j 0) < \<delta> ?Ti"
"\<forall>k < ar (?Ti !- j). \<delta> (\<pi> ?Ti j (k + 1)) < \<delta> ?Ti"
define X and Y and M where
[simp]: "X = {#\<delta> ?Ti#}" and
[simp]: "Y = {#\<delta> (\<pi> ?Ti j 0)#} + {#\<delta> (\<pi> ?Ti j (k + 1)). k \<in># mset [0 ..< ar (?Ti !- j)]#}" and
[simp]: "M \<equiv> {# \<delta> z. z \<in># mset (nth_drop i (dest_fun T))#}"
have "\<delta> (\<pi> T i (j + 1)) = HMSet (Y + M)"
by (auto simp: One_nat_def \<pi>.simps \<delta>_mk_fun)
also have "Y + M < X + M"
unfolding less_multiset\<^sub>D\<^sub>M by (rule exI[of _ "X"], rule exI[of _ "Y"]) auto
also have "HMSet (X + M) = \<delta> T"
unfolding M_def
by (subst (2) mk_fun_dest_fun[symmetric, of T], subst (2) id_take_nth_drop[of i "dest_fun T"])
(auto simp: \<delta>_mk_fun nth_arg_def nth_drop_def)
finally show "\<delta> (\<pi> T i (j + 1)) < \<delta> T" by simp
qed
end
end
diff --git a/thys/PAC_Checker/Finite_Map_Multiset.thy b/thys/PAC_Checker/Finite_Map_Multiset.thy
--- a/thys/PAC_Checker/Finite_Map_Multiset.thy
+++ b/thys/PAC_Checker/Finite_Map_Multiset.thy
@@ -1,229 +1,229 @@
(*
File: Finite_Map_Multiset.thy
Author: Mathias Fleury, Daniela Kaufmann, JKU
Maintainer: Mathias Fleury, JKU
*)
theory Finite_Map_Multiset
imports
"HOL-Library.Finite_Map"
Nested_Multisets_Ordinals.Duplicate_Free_Multiset
begin
notation image_mset (infixr "`#" 90)
section \<open>Finite maps and multisets\<close>
subsection \<open>Finite sets and multisets\<close>
abbreviation mset_fset :: \<open>'a fset \<Rightarrow> 'a multiset\<close> where
\<open>mset_fset N \<equiv> mset_set (fset N)\<close>
definition fset_mset :: \<open>'a multiset \<Rightarrow> 'a fset\<close> where
\<open>fset_mset N \<equiv> Abs_fset (set_mset N)\<close>
lemma fset_mset_mset_fset: \<open>fset_mset (mset_fset N) = N\<close>
by (auto simp: fset.fset_inverse fset_mset_def)
lemma mset_fset_fset_mset[simp]:
\<open>mset_fset (fset_mset N) = remdups_mset N\<close>
by (auto simp: fset.fset_inverse fset_mset_def Abs_fset_inverse remdups_mset_def)
lemma in_mset_fset_fmember[simp]: \<open>x \<in># mset_fset N \<longleftrightarrow> x |\<in>| N\<close>
- by (auto simp: fmember.rep_eq)
+ by (auto simp: fmember_iff_member_fset)
lemma in_fset_mset_mset[simp]: \<open>x |\<in>| fset_mset N \<longleftrightarrow> x \<in># N\<close>
- by (auto simp: fmember.rep_eq fset_mset_def Abs_fset_inverse)
+ by (auto simp: fmember_iff_member_fset fset_mset_def Abs_fset_inverse)
subsection \<open>Finite map and multisets\<close>
text \<open>Roughly the same as \<^term>\<open>ran\<close> and \<^term>\<open>dom\<close>, but with duplication in the content (unlike their
finite sets counterpart) while still working on finite domains (unlike a function mapping).
Remark that \<^term>\<open>dom_m\<close> (the keys) does not contain duplicates, but we keep for symmetry (and for
easier use of multiset operators as in the definition of \<^term>\<open>ran_m\<close>).
\<close>
definition dom_m where
\<open>dom_m N = mset_fset (fmdom N)\<close>
definition ran_m where
\<open>ran_m N = the `# fmlookup N `# dom_m N\<close>
lemma dom_m_fmdrop[simp]: \<open>dom_m (fmdrop C N) = remove1_mset C (dom_m N)\<close>
unfolding dom_m_def
by (cases \<open>C |\<in>| fmdom N\<close>)
- (auto simp: mset_set.remove fmember.rep_eq)
+ (auto simp: mset_set.remove fmember_iff_member_fset)
lemma dom_m_fmdrop_All: \<open>dom_m (fmdrop C N) = removeAll_mset C (dom_m N)\<close>
unfolding dom_m_def
by (cases \<open>C |\<in>| fmdom N\<close>)
- (auto simp: mset_set.remove fmember.rep_eq)
+ (auto simp: mset_set.remove fmember_iff_member_fset)
lemma dom_m_fmupd[simp]: \<open>dom_m (fmupd k C N) = add_mset k (remove1_mset k (dom_m N))\<close>
unfolding dom_m_def
by (cases \<open>k |\<in>| fmdom N\<close>)
- (auto simp: mset_set.remove fmember.rep_eq mset_set.insert_remove)
+ (auto simp: mset_set.remove fmember_iff_member_fset mset_set.insert_remove)
lemma distinct_mset_dom: \<open>distinct_mset (dom_m N)\<close>
by (simp add: distinct_mset_mset_set dom_m_def)
lemma in_dom_m_lookup_iff: \<open>C \<in># dom_m N' \<longleftrightarrow> fmlookup N' C \<noteq> None\<close>
by (auto simp: dom_m_def fmdom.rep_eq fmlookup_dom'_iff)
lemma in_dom_in_ran_m[simp]: \<open>i \<in># dom_m N \<Longrightarrow> the (fmlookup N i) \<in># ran_m N\<close>
by (auto simp: ran_m_def)
lemma fmupd_same[simp]:
\<open>x1 \<in># dom_m x1aa \<Longrightarrow> fmupd x1 (the (fmlookup x1aa x1)) x1aa = x1aa\<close>
by (metis fmap_ext fmupd_lookup in_dom_m_lookup_iff option.collapse)
lemma ran_m_fmempty[simp]: \<open>ran_m fmempty = {#}\<close> and
dom_m_fmempty[simp]: \<open>dom_m fmempty = {#}\<close>
by (auto simp: ran_m_def dom_m_def)
lemma fmrestrict_set_fmupd:
\<open>a \<in> xs \<Longrightarrow> fmrestrict_set xs (fmupd a C N) = fmupd a C (fmrestrict_set xs N)\<close>
\<open>a \<notin> xs \<Longrightarrow> fmrestrict_set xs (fmupd a C N) = fmrestrict_set xs N\<close>
by (auto simp: fmfilter_alt_defs)
lemma fset_fmdom_fmrestrict_set:
\<open>fset (fmdom (fmrestrict_set xs N)) = fset (fmdom N) \<inter> xs\<close>
by (auto simp: fmfilter_alt_defs)
lemma dom_m_fmrestrict_set: \<open>dom_m (fmrestrict_set (set xs) N) = mset xs \<inter># dom_m N\<close>
using fset_fmdom_fmrestrict_set[of \<open>set xs\<close> N] distinct_mset_dom[of N]
distinct_mset_inter_remdups_mset[of \<open>mset_fset (fmdom N)\<close> \<open>mset xs\<close>]
by (auto simp: dom_m_def fset_mset_mset_fset finite_mset_set_inter multiset_inter_commute
remdups_mset_def)
lemma dom_m_fmrestrict_set': \<open>dom_m (fmrestrict_set xs N) = mset_set (xs \<inter> set_mset (dom_m N))\<close>
using fset_fmdom_fmrestrict_set[of \<open>xs\<close> N] distinct_mset_dom[of N]
by (auto simp: dom_m_def fset_mset_mset_fset finite_mset_set_inter multiset_inter_commute
remdups_mset_def)
lemma indom_mI: \<open>fmlookup m x = Some y \<Longrightarrow> x \<in># dom_m m\<close>
- by (drule fmdomI) (auto simp: dom_m_def fmember.rep_eq)
+ by (drule fmdomI) (auto simp: dom_m_def fmember_iff_member_fset)
lemma fmupd_fmdrop_id:
assumes \<open>k |\<in>| fmdom N'\<close>
shows \<open>fmupd k (the (fmlookup N' k)) (fmdrop k N') = N'\<close>
proof -
have [simp]: \<open>map_upd k (the (fmlookup N' k))
(\<lambda>x. if x \<noteq> k then fmlookup N' x else None) =
map_upd k (the (fmlookup N' k))
(fmlookup N')\<close>
by (auto intro!: ext simp: map_upd_def)
have [simp]: \<open>map_upd k (the (fmlookup N' k)) (fmlookup N') = fmlookup N'\<close>
using assms
by (auto intro!: ext simp: map_upd_def)
have [simp]: \<open>finite (dom (\<lambda>x. if x = k then None else fmlookup N' x))\<close>
by (subst dom_if) auto
show ?thesis
apply (auto simp: fmupd_def fmupd.abs_eq[symmetric])
unfolding fmlookup_drop
apply (simp add: fmlookup_inverse)
done
qed
lemma fm_member_split: \<open>k |\<in>| fmdom N' \<Longrightarrow> \<exists>N'' v. N' = fmupd k v N'' \<and> the (fmlookup N' k) = v \<and>
k |\<notin>| fmdom N''\<close>
by (rule exI[of _ \<open>fmdrop k N'\<close>])
(auto simp: fmupd_fmdrop_id)
lemma \<open>fmdrop k (fmupd k va N'') = fmdrop k N''\<close>
by (simp add: fmap_ext)
lemma fmap_ext_fmdom:
\<open>(fmdom N = fmdom N') \<Longrightarrow> (\<And> x. x |\<in>| fmdom N \<Longrightarrow> fmlookup N x = fmlookup N' x) \<Longrightarrow>
N = N'\<close>
by (rule fmap_ext)
(case_tac \<open>x |\<in>| fmdom N\<close>, auto simp: fmdom_notD)
lemma fmrestrict_set_insert_in:
\<open>xa \<in> fset (fmdom N) \<Longrightarrow>
fmrestrict_set (insert xa l1) N = fmupd xa (the (fmlookup N xa)) (fmrestrict_set l1 N)\<close>
apply (rule fmap_ext_fmdom)
- apply (auto simp: fset_fmdom_fmrestrict_set fmember.rep_eq notin_fset; fail)[]
+ apply (auto simp: fset_fmdom_fmrestrict_set fmember_iff_member_fset notin_fset; fail)[]
apply (auto simp: fmlookup_dom_iff; fail)
done
lemma fmrestrict_set_insert_notin:
\<open>xa \<notin> fset (fmdom N) \<Longrightarrow>
fmrestrict_set (insert xa l1) N = fmrestrict_set l1 N\<close>
by (rule fmap_ext_fmdom)
- (auto simp: fset_fmdom_fmrestrict_set fmember.rep_eq notin_fset)
+ (auto simp: fset_fmdom_fmrestrict_set fmember_iff_member_fset notin_fset)
lemma fmrestrict_set_insert_in_dom_m[simp]:
\<open>xa \<in># dom_m N \<Longrightarrow>
fmrestrict_set (insert xa l1) N = fmupd xa (the (fmlookup N xa)) (fmrestrict_set l1 N)\<close>
by (simp add: fmrestrict_set_insert_in dom_m_def)
lemma fmrestrict_set_insert_notin_dom_m[simp]:
\<open>xa \<notin># dom_m N \<Longrightarrow>
fmrestrict_set (insert xa l1) N = fmrestrict_set l1 N\<close>
by (simp add: fmrestrict_set_insert_notin dom_m_def)
lemma fmlookup_restrict_set_id: \<open>fset (fmdom N) \<subseteq> A \<Longrightarrow> fmrestrict_set A N = N\<close>
by (metis fmap_ext fmdom'_alt_def fmdom'_notD fmlookup_restrict_set subset_iff)
lemma fmlookup_restrict_set_id': \<open>set_mset (dom_m N) \<subseteq> A \<Longrightarrow> fmrestrict_set A N = N\<close>
by (rule fmlookup_restrict_set_id)
(auto simp: dom_m_def)
lemma ran_m_mapsto_upd:
assumes
NC: \<open>C \<in># dom_m N\<close>
shows \<open>ran_m (fmupd C C' N) = add_mset C' (remove1_mset (the (fmlookup N C)) (ran_m N))\<close>
proof -
define N' where
\<open>N' = fmdrop C N\<close>
have N_N': \<open>dom_m N = add_mset C (dom_m N')\<close>
using NC unfolding N'_def by auto
have \<open>C \<notin># dom_m N'\<close>
using NC distinct_mset_dom[of N] unfolding N_N' by auto
then show ?thesis
by (auto simp: N_N' ran_m_def mset_set.insert_remove image_mset_remove1_mset_if
intro!: image_mset_cong)
qed
lemma ran_m_mapsto_upd_notin:
assumes NC: \<open>C \<notin># dom_m N\<close>
shows \<open>ran_m (fmupd C C' N) = add_mset C' (ran_m N)\<close>
using NC
by (auto simp: ran_m_def mset_set.insert_remove image_mset_remove1_mset_if
intro!: image_mset_cong split: if_splits)
lemma image_mset_If_eq_notin:
\<open>C \<notin># A \<Longrightarrow> {#f (if x = C then a x else b x). x \<in># A#} = {# f(b x). x \<in># A #}\<close>
by (induction A) auto
lemma filter_mset_cong2:
"(\<And>x. x \<in># M \<Longrightarrow> f x = g x) \<Longrightarrow> M = N \<Longrightarrow> filter_mset f M = filter_mset g N"
by (hypsubst, rule filter_mset_cong, simp)
lemma ran_m_fmdrop:
\<open>C \<in># dom_m N \<Longrightarrow> ran_m (fmdrop C N) = remove1_mset (the (fmlookup N C)) (ran_m N)\<close>
using distinct_mset_dom[of N]
by (cases \<open>fmlookup N C\<close>)
(auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
dest!: multi_member_split
intro!: filter_mset_cong2 image_mset_cong2)
lemma ran_m_fmdrop_notin:
\<open>C \<notin># dom_m N \<Longrightarrow> ran_m (fmdrop C N) = ran_m N\<close>
using distinct_mset_dom[of N]
by (auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
dest!: multi_member_split
intro!: filter_mset_cong2 image_mset_cong2)
lemma ran_m_fmdrop_If:
\<open>ran_m (fmdrop C N) = (if C \<in># dom_m N then remove1_mset (the (fmlookup N C)) (ran_m N) else ran_m N)\<close>
using distinct_mset_dom[of N]
by (auto simp: ran_m_def image_mset_If_eq_notin[of C _ \<open>\<lambda>x. fst (the x)\<close>]
dest!: multi_member_split
intro!: filter_mset_cong2 image_mset_cong2)
lemma dom_m_empty_iff[iff]:
\<open>dom_m NU = {#} \<longleftrightarrow> NU = fmempty\<close>
by (cases NU) (auto simp: dom_m_def mset_set.insert_remove)
end
\ No newline at end of file
diff --git a/thys/PAC_Checker/PAC_Map_Rel.thy b/thys/PAC_Checker/PAC_Map_Rel.thy
--- a/thys/PAC_Checker/PAC_Map_Rel.thy
+++ b/thys/PAC_Checker/PAC_Map_Rel.thy
@@ -1,321 +1,321 @@
(*
File: PAC_Map_Rel.thy
Author: Mathias Fleury, Daniela Kaufmann, JKU
Maintainer: Mathias Fleury, JKU
*)
theory PAC_Map_Rel
imports
Refine_Imperative_HOL.IICF Finite_Map_Multiset
begin
section \<open>Hash-Map for finite mappings\<close>
text \<open>
This function declares hash-maps for \<^typ>\<open>('a, 'b)fmap\<close>, that are nicer
to use especially here where everything is finite.
\<close>
definition fmap_rel where
[to_relAPP]:
"fmap_rel K V \<equiv> {(m1, m2).
(\<forall>i j. i |\<in>| fmdom m2 \<longrightarrow> (j, i) \<in> K \<longrightarrow> (the (fmlookup m1 j), the (fmlookup m2 i)) \<in> V) \<and>
fset (fmdom m1) \<subseteq> Domain K \<and> fset (fmdom m2) \<subseteq> Range K \<and>
(\<forall>i j. (i, j) \<in> K \<longrightarrow> j |\<in>| fmdom m2 \<longleftrightarrow> i |\<in>| fmdom m1)}"
lemma fmap_rel_alt_def:
\<open>\<langle>K, V\<rangle>fmap_rel \<equiv>
{(m1, m2).
(\<forall>i j. i \<in># dom_m m2 \<longrightarrow>
(j, i) \<in> K \<longrightarrow> (the (fmlookup m1 j), the (fmlookup m2 i)) \<in> V) \<and>
fset (fmdom m1) \<subseteq> Domain K \<and>
fset (fmdom m2) \<subseteq> Range K \<and>
(\<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m m2) = (i \<in># dom_m m1))}
\<close>
- unfolding fmap_rel_def dom_m_def fmember.rep_eq
+ unfolding fmap_rel_def dom_m_def fmember_iff_member_fset
by auto
lemma fmdom_empty_fmempty_iff[simp]: \<open>fmdom m = {||} \<longleftrightarrow> m = fmempty\<close>
by (metis fmdom_empty fmdrop_fset_fmdom fmdrop_fset_null)
lemma fmap_rel_empty1_simp[simp]:
"(fmempty,m)\<in>\<langle>K,V\<rangle>fmap_rel \<longleftrightarrow> m=fmempty"
apply (cases \<open>fmdom m = {||}\<close>)
apply (auto simp: fmap_rel_def)[]
- by (auto simp add: fmember.rep_eq fmap_rel_def simp del: fmdom_empty_fmempty_iff)
+ by (auto simp add: fmember_iff_member_fset fmap_rel_def simp del: fmdom_empty_fmempty_iff)
lemma fmap_rel_empty2_simp[simp]:
"(m,fmempty)\<in>\<langle>K,V\<rangle>fmap_rel \<longleftrightarrow> m=fmempty"
apply (cases \<open>fmdom m = {||}\<close>)
apply (auto simp: fmap_rel_def)[]
- by (fastforce simp add: fmember.rep_eq fmap_rel_def simp del: fmdom_empty_fmempty_iff)
+ by (fastforce simp add: fmember_iff_member_fset fmap_rel_def simp del: fmdom_empty_fmempty_iff)
sepref_decl_intf ('k,'v) f_map is "('k, 'v) fmap"
lemma [synth_rules]: "\<lbrakk>INTF_OF_REL K TYPE('k); INTF_OF_REL V TYPE('v)\<rbrakk>
\<Longrightarrow> INTF_OF_REL (\<langle>K,V\<rangle>fmap_rel) TYPE(('k,'v) f_map)" by simp
subsection \<open>Operations\<close>
sepref_decl_op fmap_empty: "fmempty" :: "\<langle>K,V\<rangle>fmap_rel" .
sepref_decl_op fmap_is_empty: "(=) fmempty" :: "\<langle>K,V\<rangle>fmap_rel \<rightarrow> bool_rel"
apply (rule fref_ncI)
apply parametricity
apply (rule fun_relI; auto)
done
lemma fmap_rel_fmupd_fmap_rel:
\<open>(A, B) \<in> \<langle>K, R\<rangle>fmap_rel \<Longrightarrow> (p, p') \<in> K \<Longrightarrow> (q, q') \<in> R \<Longrightarrow>
(fmupd p q A, fmupd p' q' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
if "single_valued K" "single_valued (K\<inverse>)"
using that
unfolding fmap_rel_alt_def
apply (case_tac \<open>p' \<in># dom_m B\<close>)
apply (auto simp add: all_conj_distrib IS_RIGHT_UNIQUED dest!: multi_member_split)
done
sepref_decl_op fmap_update: "fmupd" :: "K \<rightarrow> V \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> \<langle>K,V\<rangle>fmap_rel"
where "single_valued K" "single_valued (K\<inverse>)"
apply (rule fref_ncI)
apply parametricity
apply (intro fun_relI)
by (rule fmap_rel_fmupd_fmap_rel)
lemma remove1_mset_eq_add_mset_iff:
\<open>remove1_mset a A = add_mset a A' \<longleftrightarrow> A = add_mset a (add_mset a A')\<close>
by (metis add_mset_add_single add_mset_diff_bothsides diff_zero remove1_mset_eqE)
lemma fmap_rel_fmdrop_fmap_rel:
\<open>(fmdrop p A, fmdrop p' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
if single: "single_valued K" "single_valued (K\<inverse>)" and
H0: \<open>(A, B) \<in> \<langle>K, R\<rangle>fmap_rel\<close> \<open>(p, p') \<in> K\<close>
proof -
have H: \<open>\<And>Aa j.
\<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
remove1_mset p' (dom_m B) = add_mset p' Aa \<Longrightarrow> (j, p') \<in> K \<Longrightarrow> False\<close>
by (metis dom_m_fmdrop fmlookup_drop in_dom_m_lookup_iff union_single_eq_member)
have H2: \<open>\<And>i Aa j.
(p, p') \<in> K \<Longrightarrow>
\<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
\<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m B) = (i \<in># dom_m A) \<Longrightarrow>
remove1_mset p' (dom_m B) = add_mset i Aa \<Longrightarrow>
(j, i) \<in> K \<Longrightarrow>
(the (fmlookup A j), the (fmlookup B i)) \<in> R \<and> j \<in># remove1_mset p (dom_m A) \<and>
i \<in># remove1_mset p' (dom_m B)\<close>
\<open>\<And>i j Aa.
(p, p') \<in> K \<Longrightarrow>
single_valued K \<Longrightarrow>
single_valued (K\<inverse>) \<Longrightarrow>
\<forall>i. i \<in># dom_m B \<longrightarrow> (\<forall>j. (j, i) \<in> K \<longrightarrow> (the (fmlookup A j), the (fmlookup B i)) \<in> R) \<Longrightarrow>
fset (fmdom A) \<subseteq> Domain K \<Longrightarrow>
fset (fmdom B) \<subseteq> Range K \<Longrightarrow>
\<forall>i j. (i, j) \<in> K \<longrightarrow> (j \<in># dom_m B) = (i \<in># dom_m A) \<Longrightarrow>
(i, j) \<in> K \<Longrightarrow> remove1_mset p (dom_m A) = add_mset i Aa \<Longrightarrow> j \<in># remove1_mset p' (dom_m B)\<close>
using single
by (metis IS_RIGHT_UNIQUED converse.intros dom_m_fmdrop fmlookup_drop in_dom_m_lookup_iff
union_single_eq_member)+
show \<open>(fmdrop p A, fmdrop p' B) \<in> \<langle>K, R\<rangle>fmap_rel\<close>
using that
unfolding fmap_rel_alt_def
by (auto simp add: all_conj_distrib IS_RIGHT_UNIQUED
dest!: multi_member_split dest: H H2)
qed
sepref_decl_op fmap_delete: "fmdrop" :: "K \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> \<langle>K,V\<rangle>fmap_rel"
where "single_valued K" "single_valued (K\<inverse>)"
apply (rule fref_ncI)
apply parametricity
by (auto simp add: fmap_rel_fmdrop_fmap_rel)
lemma fmap_rel_nat_the_fmlookup[intro]:
\<open>(A, B) \<in> \<langle>S, R\<rangle>fmap_rel \<Longrightarrow> (p, p') \<in> S \<Longrightarrow> p' \<in># dom_m B \<Longrightarrow>
(the (fmlookup A p), the (fmlookup B p')) \<in> R\<close>
by (auto simp: fmap_rel_alt_def distinct_mset_dom)
lemma fmap_rel_in_dom_iff:
\<open>(aa, a'a) \<in> \<langle>K, V\<rangle>fmap_rel \<Longrightarrow>
(a, a') \<in> K \<Longrightarrow>
a' \<in># dom_m a'a \<longleftrightarrow>
a \<in># dom_m aa\<close>
unfolding fmap_rel_alt_def
by auto
lemma fmap_rel_fmlookup_rel:
\<open>(a, a') \<in> K \<Longrightarrow> (aa, a'a) \<in> \<langle>K, V\<rangle>fmap_rel \<Longrightarrow>
(fmlookup aa a, fmlookup a'a a') \<in> \<langle>V\<rangle>option_rel\<close>
using fmap_rel_nat_the_fmlookup[of aa a'a K V a a']
fmap_rel_in_dom_iff[of aa a'a K V a a']
in_dom_m_lookup_iff[of a' a'a]
in_dom_m_lookup_iff[of a aa]
by (cases \<open>a' \<in># dom_m a'a\<close>)
(auto simp del: fmap_rel_nat_the_fmlookup)
sepref_decl_op fmap_lookup: "fmlookup" :: "\<langle>K,V\<rangle>fmap_rel \<rightarrow> K \<rightarrow> \<langle>V\<rangle>option_rel"
apply (rule fref_ncI)
apply parametricity
apply (intro fun_relI)
apply (rule fmap_rel_fmlookup_rel; assumption)
done
lemma in_fdom_alt: "k\<in>#dom_m m \<longleftrightarrow> \<not>is_None (fmlookup m k)"
- apply (auto split: option.split intro: fmdom_notI simp: dom_m_def fmember.rep_eq)
+ apply (auto split: option.split intro: fmdom_notI simp: dom_m_def fmember_iff_member_fset)
apply (meson fmdom_notI notin_fset)
using notin_fset by fastforce
sepref_decl_op fmap_contains_key: "\<lambda>k m. k\<in>#dom_m m" :: "K \<rightarrow> \<langle>K,V\<rangle>fmap_rel \<rightarrow> bool_rel"
unfolding in_fdom_alt
apply (rule fref_ncI)
apply parametricity
apply (rule fmap_rel_fmlookup_rel; assumption)
done
subsection \<open>Patterns\<close>
lemma pat_fmap_empty[pat_rules]: "fmempty \<equiv> op_fmap_empty" by simp
lemma pat_map_is_empty[pat_rules]:
"(=) $m$fmempty \<equiv> op_fmap_is_empty$m"
"(=) $fmempty$m \<equiv> op_fmap_is_empty$m"
"(=) $(dom_m$m)${#} \<equiv> op_fmap_is_empty$m"
"(=) ${#}$(dom_m$m) \<equiv> op_fmap_is_empty$m"
unfolding atomize_eq
by (auto dest: sym)
lemma op_map_contains_key[pat_rules]:
"(\<in>#) $ k $ (dom_m$m) \<equiv> op_fmap_contains_key$'k$'m"
by (auto intro!: eq_reflection)
subsection \<open>Mapping to Normal Hashmaps\<close>
abbreviation map_of_fmap :: \<open>('k \<Rightarrow> 'v option) \<Rightarrow> ('k, 'v) fmap\<close> where
\<open>map_of_fmap h \<equiv> Abs_fmap h\<close>
definition map_fmap_rel where
\<open>map_fmap_rel = br map_of_fmap (\<lambda>a. finite (dom a))\<close>
lemma fmdrop_set_None:
\<open>(op_map_delete, fmdrop) \<in> Id \<rightarrow> map_fmap_rel \<rightarrow> map_fmap_rel\<close>
apply (auto simp: map_fmap_rel_def br_def)
apply (subst fmdrop.abs_eq)
apply (auto simp: eq_onp_def fmap.Abs_fmap_inject
map_drop_def map_filter_finite
intro!: ext)
apply (auto simp: map_filter_def)
done
lemma map_upd_fmupd:
\<open>(op_map_update, fmupd) \<in> Id \<rightarrow> Id \<rightarrow> map_fmap_rel \<rightarrow> map_fmap_rel\<close>
apply (auto simp: map_fmap_rel_def br_def)
apply (subst fmupd.abs_eq)
apply (auto simp: eq_onp_def fmap.Abs_fmap_inject
map_drop_def map_filter_finite map_upd_def
intro!: ext)
done
text \<open>Technically @{term op_map_lookup} has the arguments in the wrong direction.\<close>
definition fmlookup' where
[simp]: \<open>fmlookup' A k = fmlookup k A\<close>
lemma [def_pat_rules]:
\<open>((\<in>#)$k$(dom_m$A)) \<equiv> Not$(is_None$(fmlookup'$k$A))\<close>
by (simp add: fold_is_None in_fdom_alt)
lemma op_map_lookup_fmlookup:
\<open>(op_map_lookup, fmlookup') \<in> Id \<rightarrow> map_fmap_rel \<rightarrow> \<langle>Id\<rangle>option_rel\<close>
by (auto simp: map_fmap_rel_def br_def fmap.Abs_fmap_inverse)
abbreviation hm_fmap_assn where
\<open>hm_fmap_assn K V \<equiv> hr_comp (hm.assn K V) map_fmap_rel\<close>
lemmas fmap_delete_hnr [sepref_fr_rules] =
hm.delete_hnr[FCOMP fmdrop_set_None]
lemmas fmap_update_hnr [sepref_fr_rules] =
hm.update_hnr[FCOMP map_upd_fmupd]
lemmas fmap_lookup_hnr [sepref_fr_rules] =
hm.lookup_hnr[FCOMP op_map_lookup_fmlookup]
lemma fmempty_empty:
\<open>(uncurry0 (RETURN op_map_empty), uncurry0 (RETURN fmempty)) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>map_fmap_rel\<rangle>nres_rel\<close>
by (auto simp: map_fmap_rel_def br_def fmempty_def frefI nres_relI)
lemmas [sepref_fr_rules] =
hm.empty_hnr[FCOMP fmempty_empty, unfolded op_fmap_empty_def[symmetric]]
abbreviation iam_fmap_assn where
\<open>iam_fmap_assn K V \<equiv> hr_comp (iam.assn K V) map_fmap_rel\<close>
lemmas iam_fmap_delete_hnr [sepref_fr_rules] =
iam.delete_hnr[FCOMP fmdrop_set_None]
lemmas iam_ffmap_update_hnr [sepref_fr_rules] =
iam.update_hnr[FCOMP map_upd_fmupd]
lemmas iam_ffmap_lookup_hnr [sepref_fr_rules] =
iam.lookup_hnr[FCOMP op_map_lookup_fmlookup]
definition op_iam_fmap_empty where
\<open>op_iam_fmap_empty = fmempty\<close>
lemma iam_fmempty_empty:
\<open>(uncurry0 (RETURN op_map_empty), uncurry0 (RETURN op_iam_fmap_empty)) \<in> unit_rel \<rightarrow>\<^sub>f \<langle>map_fmap_rel\<rangle>nres_rel\<close>
by (auto simp: map_fmap_rel_def br_def fmempty_def frefI nres_relI op_iam_fmap_empty_def)
lemmas [sepref_fr_rules] =
iam.empty_hnr[FCOMP fmempty_empty, unfolded op_iam_fmap_empty_def[symmetric]]
definition upper_bound_on_dom where
\<open>upper_bound_on_dom A = SPEC(\<lambda>n. \<forall>i \<in>#(dom_m A). i < n)\<close>
lemma [sepref_fr_rules]:
\<open>((Array.len), upper_bound_on_dom) \<in> (iam_fmap_assn nat_assn V)\<^sup>k \<rightarrow>\<^sub>a nat_assn\<close>
proof -
have [simp]: \<open>finite (dom b) \<Longrightarrow> i \<in> fset (fmdom (map_of_fmap b)) \<longleftrightarrow> i \<in> dom b\<close> for i b
by (subst fmdom.abs_eq)
(auto simp: eq_onp_def fset.Abs_fset_inverse)
have 2: \<open>nat_rel = the_pure (nat_assn)\<close> and
3: \<open>nat_assn = pure nat_rel\<close>
by auto
have [simp]: \<open>the_pure (\<lambda>a c :: nat. \<up> (c = a)) = nat_rel\<close>
apply (subst 2)
apply (subst 3)
apply (subst pure_def)
apply auto
done
have [simp]: \<open>(iam_of_list l, b) \<in> the_pure (\<lambda>a c :: nat. \<up> (c = a)) \<rightarrow> \<langle>the_pure V\<rangle>option_rel \<Longrightarrow>
b i = Some y \<Longrightarrow> i < length l\<close> for i b l y
by (auto dest!: fun_relD[of _ _ _ _ i i] simp: option_rel_def
iam_of_list_def split: if_splits)
show ?thesis
by sepref_to_hoare
(sep_auto simp: upper_bound_on_dom_def hr_comp_def iam.assn_def map_rel_def
map_fmap_rel_def is_iam_def br_def dom_m_def)
qed
lemma fmap_rel_nat_rel_dom_m[simp]:
\<open>(A, B) \<in> \<langle>nat_rel, R\<rangle>fmap_rel \<Longrightarrow> dom_m A = dom_m B\<close>
by (subst distinct_set_mset_eq_iff[symmetric])
(auto simp: fmap_rel_alt_def distinct_mset_dom
simp del: fmap_rel_nat_the_fmlookup)
lemma ref_two_step':
\<open>A \<le> B \<Longrightarrow> \<Down> R A \<le> \<Down> R B\<close>
using ref_two_step by auto
end
diff --git a/thys/Regular_Tree_Relations/GTT_Compose.thy b/thys/Regular_Tree_Relations/GTT_Compose.thy
--- a/thys/Regular_Tree_Relations/GTT_Compose.thy
+++ b/thys/Regular_Tree_Relations/GTT_Compose.thy
@@ -1,403 +1,403 @@
theory GTT_Compose
imports GTT
begin
subsection \<open>GTT closure under composition\<close>
inductive_set \<Delta>\<^sub>\<epsilon>_set :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for \<A> \<B> where
\<Delta>\<^sub>\<epsilon>_set_cong: "TA_rule f ps p |\<in>| rules \<A> \<Longrightarrow> TA_rule f qs q |\<in>| rules \<B> \<Longrightarrow> length ps = length qs \<Longrightarrow>
(\<And>i. i < length qs \<Longrightarrow> (ps ! i, qs ! i) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>) \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"
| \<Delta>\<^sub>\<epsilon>_set_eps1: "(p, p') |\<in>| eps \<A> \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<Longrightarrow> (p', q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"
| \<Delta>\<^sub>\<epsilon>_set_eps2: "(q, q') |\<in>| eps \<B> \<Longrightarrow> (p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<Longrightarrow> (p, q') \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>"
lemma \<Delta>\<^sub>\<epsilon>_states: "\<Delta>\<^sub>\<epsilon>_set \<A> \<B> \<subseteq> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
proof -
{fix p q assume "(p, q) \<in> \<Delta>\<^sub>\<epsilon>_set \<A> \<B>" then have "(p, q) \<in> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
- by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember.rep_eq)}
+ by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember_iff_member_fset)}
then show ?thesis by auto
qed
lemma finite_\<Delta>\<^sub>\<epsilon> [simp]: "finite (\<Delta>\<^sub>\<epsilon>_set \<A> \<B>)"
using finite_subset[OF \<Delta>\<^sub>\<epsilon>_states]
by simp
context
includes fset.lifting
begin
lift_definition \<Delta>\<^sub>\<epsilon> :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>\<^sub>\<epsilon>_set by simp
lemmas \<Delta>\<^sub>\<epsilon>_cong = \<Delta>\<^sub>\<epsilon>_set_cong [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_eps1 = \<Delta>\<^sub>\<epsilon>_set_eps1 [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_eps2 = \<Delta>\<^sub>\<epsilon>_set_eps2 [Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_cases = \<Delta>\<^sub>\<epsilon>_set.cases[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_induct [consumes 1, case_names \<Delta>\<^sub>\<epsilon>_cong \<Delta>\<^sub>\<epsilon>_eps1 \<Delta>\<^sub>\<epsilon>_eps2] = \<Delta>\<^sub>\<epsilon>_set.induct[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_intros = \<Delta>\<^sub>\<epsilon>_set.intros[Transfer.transferred]
lemmas \<Delta>\<^sub>\<epsilon>_simps = \<Delta>\<^sub>\<epsilon>_set.simps[Transfer.transferred]
end
lemma finite_alt_def [simp]:
"finite {(\<alpha>, \<beta>). (\<exists>t. ground t \<and> \<alpha> |\<in>| ta_der \<A> t \<and> \<beta> |\<in>| ta_der \<B> t)}" (is "finite ?S")
- by (auto dest: ground_ta_der_states[THEN fsubsetD] simp flip: fmember.rep_eq
+ by (auto dest: ground_ta_der_states[THEN fsubsetD] simp flip: fmember_iff_member_fset
intro!: finite_subset[of ?S "fset (\<Q> \<A> |\<times>| \<Q> \<B>)"])
lemma \<Delta>\<^sub>\<epsilon>_def':
"\<Delta>\<^sub>\<epsilon> \<A> \<B> = {|(\<alpha>, \<beta>). (\<exists>t. ground t \<and> \<alpha> |\<in>| ta_der \<A> t \<and> \<beta> |\<in>| ta_der \<B> t)|}"
proof (intro fset_eqI iffI, goal_cases lr rl)
case (lr x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
have "\<exists>t. ground t \<and> p |\<in>| ta_der \<A> t \<and> q |\<in>| ta_der \<B> t" using lr unfolding x
proof (induct rule: \<Delta>\<^sub>\<epsilon>_induct)
case (\<Delta>\<^sub>\<epsilon>_cong f ps p qs q)
obtain ts where ts: "ground (ts i) \<and> ps ! i |\<in>| ta_der \<A> (ts i) \<and> qs ! i |\<in>| ta_der \<B> (ts i)"
if "i < length qs" for i using \<Delta>\<^sub>\<epsilon>_cong(5) by metis
then show ?case using \<Delta>\<^sub>\<epsilon>_cong(1-3)
by (auto intro!: exI[of _ "Fun f (map ts [0..<length qs])"]) blast+
qed (meson ta_der_eps)+
then show ?case by auto
next
case (rl x) obtain p q where x [simp]: "x = (p, q)" by (cases x)
obtain t where "ground t" "p |\<in>| ta_der \<A> t" "q |\<in>| ta_der \<B> t" using rl by auto
then show ?case unfolding x
proof (induct t arbitrary: p q)
case (Fun f ts)
obtain p' ps where p': "TA_rule f ps p' |\<in>| rules \<A>" "p' = p \<or> (p', p) |\<in>| (eps \<A>)|\<^sup>+|" "length ps = length ts"
"\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<A> (ts ! i)" using Fun(3) by auto
obtain q' qs where q': "f qs \<rightarrow> q' |\<in>| rules \<B>" "q' = q \<or> (q', q) |\<in>| (eps \<B>)|\<^sup>+|" "length qs = length ts"
"\<And>i. i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der \<B> (ts ! i)" using Fun(4) by auto
have st: "(p', q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>"
using Fun(1)[OF nth_mem _ p'(4) q'(4)] Fun(2) p'(3) q'(3)
by (intro \<Delta>\<^sub>\<epsilon>_cong[OF p'(1) q'(1)]) auto
{assume "(p', p) |\<in>| (eps \<A>)|\<^sup>+|" then have "(p, q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" using st
by (induct rule: ftrancl_induct) (auto intro: \<Delta>\<^sub>\<epsilon>_eps1)}
from st this p'(2) have st: "(p, q') |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" by auto
{assume "(q', q) |\<in>| (eps \<B>)|\<^sup>+|" then have "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" using st
by (induct rule: ftrancl_induct) (auto intro: \<Delta>\<^sub>\<epsilon>_eps2)}
from st this q'(2) show "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B>" by auto
qed auto
qed
lemma \<Delta>\<^sub>\<epsilon>_fmember:
"(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<longleftrightarrow> (\<exists>t. ground t \<and> p |\<in>| ta_der \<A> t \<and> q |\<in>| ta_der \<B> t)"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def')
definition GTT_comp :: "('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt \<Rightarrow> ('q, 'f) gtt" where
"GTT_comp \<G>\<^sub>1 \<G>\<^sub>2 =
(let \<Delta> = \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2) in
(TA (gtt_rules (fst \<G>\<^sub>1, fst \<G>\<^sub>2)) (eps (fst \<G>\<^sub>1) |\<union>| eps (fst \<G>\<^sub>2) |\<union>| \<Delta>),
TA (gtt_rules (snd \<G>\<^sub>1, snd \<G>\<^sub>2)) (eps (snd \<G>\<^sub>1) |\<union>| eps (snd \<G>\<^sub>2) |\<union>| (\<Delta>|\<inverse>|))))"
lemma gtt_syms_GTT_comp:
"gtt_syms (GTT_comp A B) = gtt_syms A |\<union>| gtt_syms B"
by (auto simp: GTT_comp_def ta_sig_def Let_def)
lemma \<Delta>\<^sub>\<epsilon>_statesD:
"(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<Longrightarrow> p |\<in>| \<Q> \<A>"
"(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<Longrightarrow> q |\<in>| \<Q> \<B>"
using subsetD[OF \<Delta>\<^sub>\<epsilon>_states, of "(p, q)" \<A> \<B>]
- by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq fmember.rep_eq)
+ by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq fmember_iff_member_fset)
lemma \<Delta>\<^sub>\<epsilon>_statesD':
"q |\<in>| eps_states (\<Delta>\<^sub>\<epsilon> \<A> \<B>) \<Longrightarrow> q |\<in>| \<Q> \<A> |\<union>| \<Q> \<B>"
by (auto simp: eps_states_def fmember.abs_eq dest: \<Delta>\<^sub>\<epsilon>_statesD)
lemma \<Delta>\<^sub>\<epsilon>_swap:
"prod.swap p |\<in>| \<Delta>\<^sub>\<epsilon> \<A> \<B> \<longleftrightarrow> p |\<in>| \<Delta>\<^sub>\<epsilon> \<B> \<A>"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def')
lemma \<Delta>\<^sub>\<epsilon>_inverse [simp]:
"(\<Delta>\<^sub>\<epsilon> \<A> \<B>)|\<inverse>| = \<Delta>\<^sub>\<epsilon> \<B> \<A>"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def')
lemma gtt_states_comp_union:
"gtt_states (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) |\<subseteq>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
proof (intro fsubsetI, goal_cases lr)
case (lr q) then show ?case
by (auto simp: GTT_comp_def gtt_states_def \<Q>_def dest: \<Delta>\<^sub>\<epsilon>_statesD')
qed
lemma GTT_comp_swap [simp]:
"GTT_comp (prod.swap \<G>\<^sub>2) (prod.swap \<G>\<^sub>1) = prod.swap (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
by (simp add: GTT_comp_def ac_simps)
lemma gtt_comp_complete_semi:
assumes s: "q |\<in>| gta_der (fst \<G>\<^sub>1) s" and u: "q |\<in>| gta_der (snd \<G>\<^sub>1) u" and ut: "gtt_accept \<G>\<^sub>2 u t"
shows "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
proof (goal_cases L R)
let ?\<G> = "GTT_comp \<G>\<^sub>1 \<G>\<^sub>2"
have sub1l: "rules (fst \<G>\<^sub>1) |\<subseteq>| rules (fst ?\<G>)" "eps (fst \<G>\<^sub>1) |\<subseteq>| eps (fst ?\<G>)"
and sub1r: "rules (snd \<G>\<^sub>1) |\<subseteq>| rules (snd ?\<G>)" "eps (snd \<G>\<^sub>1) |\<subseteq>| eps (snd ?\<G>)"
and sub2r: "rules (snd \<G>\<^sub>2) |\<subseteq>| rules (snd ?\<G>)" "eps (snd \<G>\<^sub>2) |\<subseteq>| eps (snd ?\<G>)"
by (auto simp: GTT_comp_def)
{ case L then show ?case using s ta_der_mono[OF sub1l]
by (auto simp: gta_der_def)
next
case R then show ?case using ut u unfolding gtt_accept_def
proof (induct arbitrary: q s)
case (base s t)
from base(1) obtain p where p: "p |\<in>| gta_der (fst \<G>\<^sub>2) s" "p |\<in>| gta_der (snd \<G>\<^sub>2) t"
by (auto simp: agtt_lang_def)
then have "(p, q) |\<in>| eps (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2))"
using \<Delta>\<^sub>\<epsilon>_fmember[of p q "fst \<G>\<^sub>2" "snd \<G>\<^sub>1"] base(2)
by (auto simp: GTT_comp_def gta_der_def)
from ta_der_eps[OF this] show ?case using p ta_der_mono[OF sub2r]
by (auto simp add: gta_der_def)
next
case (step ss ts f)
from step(1, 4) obtain ps p where "TA_rule f ps p |\<in>| rules (snd \<G>\<^sub>1)" "p = q \<or> (p, q) |\<in>| (eps (snd \<G>\<^sub>1))|\<^sup>+|"
"length ps = length ts" "\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| gta_der (snd \<G>\<^sub>1) (ss ! i)"
unfolding gta_der_def by auto
then show ?case using step(1, 2) sub1r(1) ftrancl_mono[OF _ sub1r(2)]
by (auto simp: gta_der_def intro!: exI[of _ p] exI[of _ ps])
qed}
qed
lemmas gtt_comp_complete_semi' = gtt_comp_complete_semi[of _ "prod.swap \<G>\<^sub>2" _ _ "prod.swap \<G>\<^sub>1" for \<G>\<^sub>1 \<G>\<^sub>2,
unfolded fst_swap snd_swap GTT_comp_swap gtt_accept_swap]
lemma gtt_comp_acomplete:
"gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2) \<subseteq> agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
proof (intro subrelI, goal_cases LR)
case (LR s t)
then consider
q u where "q |\<in>| gta_der (fst \<G>\<^sub>1) s" "q |\<in>| gta_der (snd \<G>\<^sub>1) u" "gtt_accept \<G>\<^sub>2 u t"
| q u where "q |\<in>| gta_der (snd \<G>\<^sub>2) t" "q |\<in>| gta_der (fst \<G>\<^sub>2) u" "gtt_accept \<G>\<^sub>1 s u"
by (auto simp: gcomp_rel_def gtt_accept_def elim!: agtt_langE)
then show ?case
proof (cases)
case 1 show ?thesis using gtt_comp_complete_semi[OF 1]
by (auto simp: agtt_lang_def gta_der_def)
next
case 2 show ?thesis using gtt_comp_complete_semi'[OF 2]
by (auto simp: agtt_lang_def gta_der_def)
qed
qed
lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2:
assumes "(q, q') |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "q |\<in>| gtt_states \<G>\<^sub>2"
"gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
shows "(q, q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+| \<and> q' |\<in>| gtt_states \<G>\<^sub>2"
using assms(1-2)
proof (induct rule: converse_ftrancl_induct)
case (Base y)
then show ?case using assms(3)
by (fastforce simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD(1))
next
case (Step q p)
have "(q, p) |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>2"
using Step(1, 4) assms(3)
by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD(1))
then show ?case using Step(3)
by (auto intro: ftrancl_trans)
qed
lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1:
assumes "(p, r) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>1"
"gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
obtains "r |\<in>| gtt_states \<G>\<^sub>1" "(p, r) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
| q p' where "r |\<in>| gtt_states \<G>\<^sub>2" "p = p' \<or> (p, p') |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|" "(p', q) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)"
"q = r \<or> (q, r) |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|"
using assms(1,2)
proof (induct arbitrary: thesis rule: converse_ftrancl_induct)
case (Base p)
from Base(1) consider (a) "(p, r) |\<in>| eps (fst \<G>\<^sub>1)" | (b) "(p, r) |\<in>| eps (fst \<G>\<^sub>2)" |
(c) "(p, r) |\<in>| (\<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2))"
by (auto simp: GTT_comp_def fmember.abs_eq)
then show ?case using assms(3) Base
by cases (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)
next
case (Step q p)
consider "(q, p) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|" "p |\<in>| gtt_states \<G>\<^sub>1"
| "(q, p) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)" "p |\<in>| gtt_states \<G>\<^sub>2" using assms(3) Step(1, 6)
by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)
then show ?case
proof (cases)
case 1 note a = 1 show ?thesis
proof (cases rule: Step(3))
case (2 p' q)
then show ?thesis using assms a
by (auto intro: Step(5) ftrancl_trans)
qed (auto simp: a(2) intro: Step(4) ftrancl_trans[OF a(1)])
next
case 2 show ?thesis using \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2[OF Step(2) 2(2) assms(3)] Step(5)[OF _ _ 2(1)] by auto
qed
qed
lemma \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2:
assumes "(q, q') |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
"gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
obtains "q |\<in>| gtt_states \<G>\<^sub>1" "q' |\<in>| gtt_states \<G>\<^sub>1" "(q, q') |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
| p p' where "q |\<in>| gtt_states \<G>\<^sub>1" "q' |\<in>| gtt_states \<G>\<^sub>2" "q = p \<or> (q, p) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
"(p, p') |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)" "p' = q' \<or> (p', q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+|"
| "q |\<in>| gtt_states \<G>\<^sub>2" "(q, q') |\<in>| (eps (fst \<G>\<^sub>2))|\<^sup>+| \<and> q' |\<in>| gtt_states \<G>\<^sub>2"
using assms \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1 \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>2
by (metis funion_iff)
lemma GTT_comp_eps_fst_statesD:
"(p, q) |\<in>| eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) \<Longrightarrow> p |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
"(p, q) |\<in>| eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) \<Longrightarrow> q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
by (auto simp: GTT_comp_def gtt_states_def fmember.abs_eq dest: eps_statesD \<Delta>\<^sub>\<epsilon>_statesD)
lemma GTT_comp_eps_ftrancl_fst_statesD:
"(p, q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| \<Longrightarrow> p |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
"(p, q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+| \<Longrightarrow> q |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2"
using GTT_comp_eps_fst_statesD[of _ _ \<G>\<^sub>1 \<G>\<^sub>2]
by (meson converse_ftranclE ftranclE)+
lemma GTT_comp_first:
assumes "q |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t" "q |\<in>| gtt_states \<G>\<^sub>1"
"gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
shows "q |\<in>| ta_der (fst \<G>\<^sub>1) t"
using assms(1,2)
proof (induct t arbitrary: q)
case (Var q')
have "q \<noteq> q' \<Longrightarrow> q' |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" using Var
by (auto dest: GTT_comp_eps_ftrancl_fst_statesD)
then show ?case using Var assms(3)
by (auto elim: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2)
next
case (Fun f ts)
obtain q' qs where q': "TA_rule f qs q' |\<in>| rules (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2))"
"q' = q \<or> (q', q) |\<in>| (eps (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" "length qs = length ts"
"\<And>i. i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (ts ! i)"
using Fun(2) by auto
have "q' |\<in>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" using q'(1)
by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
then have st: "q' |\<in>| gtt_states \<G>\<^sub>1" and eps:"q' = q \<or> (q', q) |\<in>| (eps (fst \<G>\<^sub>1))|\<^sup>+|"
using q'(2) Fun(3) assms(3)
by (auto elim!: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2)
from st have rule: "TA_rule f qs q' |\<in>| rules (fst \<G>\<^sub>1)" using assms(3) q'(1)
by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
have "i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der (fst \<G>\<^sub>1) (ts ! i)" for i
using rule q'(3, 4)
by (intro Fun(1)[OF nth_mem]) (auto simp: gtt_states_def dest!: rule_statesD(4))
then show ?case using q'(3) rule eps
by auto
qed
lemma GTT_comp_second:
assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}" "q |\<in>| gtt_states \<G>\<^sub>2"
"q |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
shows "q |\<in>| ta_der (snd \<G>\<^sub>2) t"
using assms GTT_comp_first[of q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1"]
by (auto simp: gtt_states_def)
lemma gtt_comp_sound_semi:
fixes \<G>\<^sub>1 \<G>\<^sub>2 :: "('f, 'q) gtt"
assumes as2: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
and 1: "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t" "q |\<in>| gtt_states \<G>\<^sub>1"
shows "\<exists>u. q |\<in>| gta_der (snd \<G>\<^sub>1) u \<and> gtt_accept \<G>\<^sub>2 u t" using 1(2,3) unfolding gta_der_def
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
show ?case
proof (cases "p |\<in>| gtt_states \<G>\<^sub>1")
case True
then have *: "TA_rule f ps p |\<in>| rules (snd \<G>\<^sub>1)" using GFun(1, 6) as2
by (auto simp: GTT_comp_def gtt_states_def dest: rule_statesD)
moreover have st: "i < length ps \<Longrightarrow> ps ! i |\<in>| gtt_states \<G>\<^sub>1" for i using *
by (force simp: gtt_states_def dest: rule_statesD)
moreover have "i < length ps \<Longrightarrow> \<exists>u. ps ! i |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm u) \<and> gtt_accept \<G>\<^sub>2 u (ts ! i)" for i
using st GFun(2) by (intro GFun(5)) simp
then obtain us where
"\<And>i. i < length ps \<Longrightarrow> ps ! i |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm (us i)) \<and> gtt_accept \<G>\<^sub>2 (us i) (ts ! i)"
by metis
moreover have "p = q \<or> (p, q) |\<in>| (eps (snd \<G>\<^sub>1))|\<^sup>+|" using GFun(3, 6) True as2
by (auto simp: gtt_states_def elim!: \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2[of p q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1", simplified])
ultimately show ?thesis using GFun(2)
by (intro exI[of _ "GFun f (map us [0..<length ts])"])
(auto simp: gtt_accept_def intro!: exI[of _ ps] exI[of _ p])
next
case False note nt_st = this
then have False: "p \<noteq> q" using GFun(6) by auto
then have eps: "(p, q) |\<in>| (eps (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)))|\<^sup>+|" using GFun(3) by simp
show ?thesis using \<Delta>\<^sub>\<epsilon>_steps_from_\<G>\<^sub>1_\<G>\<^sub>2[of p q "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1", simplified, OF eps]
proof (cases, goal_cases)
case 1 then show ?case using False GFun(3)
by (metis GTT_comp_eps_ftrancl_fst_statesD(1) GTT_comp_swap fst_swap funion_iff)
next
case 2 then show ?case using as2 by (auto simp: gtt_states_def)
next
case 3 then show ?case using as2 GFun(6) by (auto simp: gtt_states_def)
next
case (4 r p')
have meet: "r |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (Fun f (map term_of_gterm ts))"
using GFun(1 - 4) 4(3) False
by (auto simp: GTT_comp_def in_ftrancl_UnI intro!: exI[ of _ ps] exI[ of _ p])
then obtain u where wit: "ground u" "p' |\<in>| ta_der (snd \<G>\<^sub>1) u" "r |\<in>| ta_der (fst \<G>\<^sub>2) u"
using 4(4-) unfolding \<Delta>\<^sub>\<epsilon>_def' by blast
from wit(1, 3) have "gtt_accept \<G>\<^sub>2 (gterm_of_term u) (GFun f ts)"
using GTT_comp_second[OF as2 _ meet] unfolding gtt_accept_def
by (intro gmctxt_cl.base agtt_langI[of r])
(auto simp add: gta_der_def gtt_states_def simp del: ta_der_Fun dest: ground_ta_der_states)
then show ?case using 4(5) wit(1, 2)
by (intro exI[of _ "gterm_of_term u"]) (auto simp add: ta_der_trancl_eps)
next
case 5
then show ?case using nt_st as2
by (simp add: gtt_states_def)
qed
qed
qed
lemma gtt_comp_asound:
assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
shows "agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) \<subseteq> gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
proof (intro subrelI, goal_cases LR)
case (LR s t)
obtain q where q: "q |\<in>| gta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) s" "q |\<in>| gta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) t"
using LR by (auto simp: agtt_lang_def)
{ (* prepare symmetric cases: q |\<in>| gtt_states \<G>\<^sub>1 and q |\<in>| gtt_states \<G>\<^sub>2 *)
fix \<G>\<^sub>1 \<G>\<^sub>2 s t assume as2: "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
and 1: "q |\<in>| ta_der (fst (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (term_of_gterm s)"
"q |\<in>| ta_der (snd (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)) (term_of_gterm t)" "q |\<in>| gtt_states \<G>\<^sub>1"
note st = GTT_comp_first[OF 1(1,3) as2]
obtain u where u: "q |\<in>| ta_der (snd \<G>\<^sub>1) (term_of_gterm u)" "gtt_accept \<G>\<^sub>2 u t"
using gtt_comp_sound_semi[OF as2 1[folded gta_der_def]] by (auto simp: gta_der_def)
have "(s, u) \<in> agtt_lang \<G>\<^sub>1" using st u(1)
by (auto simp: agtt_lang_def gta_der_def)
moreover have "(u, t) \<in> gtt_lang \<G>\<^sub>2" using u(2)
by (auto simp: gtt_accept_def)
ultimately have "(s, t) \<in> agtt_lang \<G>\<^sub>1 O gmctxt_cl UNIV (agtt_lang \<G>\<^sub>2)"
by auto}
note base = this
consider "q |\<in>| gtt_states \<G>\<^sub>1" | "q |\<in>| gtt_states \<G>\<^sub>2" | "q |\<notin>| gtt_states \<G>\<^sub>1 |\<union>| gtt_states \<G>\<^sub>2" by blast
then show ?case using q assms
proof (cases, goal_cases)
case 1 then show ?case using base[of \<G>\<^sub>1 \<G>\<^sub>2 s t]
by (auto simp: gcomp_rel_def gta_der_def)
next
case 2 then show ?case using base[of "prod.swap \<G>\<^sub>2" "prod.swap \<G>\<^sub>1" t s, THEN converseI]
by (auto simp: gcomp_rel_def converse_relcomp converse_agtt_lang gta_der_def gtt_states_def)
(simp add: finter_commute funion_commute gtt_lang_swap prod.swap_def)+
next
case 3 then show ?case using fsubsetD[OF gtt_states_comp_union[of \<G>\<^sub>1 \<G>\<^sub>2], of q]
by (auto simp: gta_der_def gtt_states_def)
qed
qed
lemma gtt_comp_lang_complete:
shows "gtt_lang \<G>\<^sub>1 O gtt_lang \<G>\<^sub>2 \<subseteq> gtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2)"
using gmctxt_cl_mono_rel[OF gtt_comp_acomplete, of UNIV \<G>\<^sub>1 \<G>\<^sub>2]
by (simp only: gcomp_rel[symmetric])
lemma gtt_comp_alang:
assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
shows "agtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) = gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
by (intro equalityI gtt_comp_asound[OF assms] gtt_comp_acomplete)
lemma gtt_comp_lang:
assumes "gtt_states \<G>\<^sub>1 |\<inter>| gtt_states \<G>\<^sub>2 = {||}"
shows "gtt_lang (GTT_comp \<G>\<^sub>1 \<G>\<^sub>2) = gtt_lang \<G>\<^sub>1 O gtt_lang \<G>\<^sub>2"
by (simp only: arg_cong[OF gtt_comp_alang[OF assms], of "gmctxt_cl UNIV"] gcomp_rel)
abbreviation GTT_comp' where
"GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2 \<equiv> GTT_comp (fmap_states_gtt Inl \<G>\<^sub>1) (fmap_states_gtt Inr \<G>\<^sub>2)"
lemma gtt_comp'_alang:
shows "agtt_lang (GTT_comp' \<G>\<^sub>1 \<G>\<^sub>2) = gcomp_rel UNIV (agtt_lang \<G>\<^sub>1) (agtt_lang \<G>\<^sub>2)"
proof -
have [simp]: "finj_on Inl (gtt_states \<G>\<^sub>1)" "finj_on Inr (gtt_states \<G>\<^sub>2)"
by (auto simp add: finj_on.rep_eq)
then show ?thesis
by (subst gtt_comp_alang) (auto simp: agtt_lang_fmap_states_gtt)
qed
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/GTT_Transitive_Closure.thy b/thys/Regular_Tree_Relations/GTT_Transitive_Closure.thy
--- a/thys/Regular_Tree_Relations/GTT_Transitive_Closure.thy
+++ b/thys/Regular_Tree_Relations/GTT_Transitive_Closure.thy
@@ -1,286 +1,286 @@
theory GTT_Transitive_Closure
imports GTT_Compose
begin
subsection \<open>GTT closure under transitivity\<close>
inductive_set \<Delta>_trancl_set :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for A B where
\<Delta>_set_cong: "TA_rule f ps p |\<in>| rules A \<Longrightarrow> TA_rule f qs q |\<in>| rules B \<Longrightarrow> length ps = length qs \<Longrightarrow>
(\<And>i. i < length qs \<Longrightarrow> (ps ! i, qs ! i) \<in> \<Delta>_trancl_set A B) \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_eps1: "(p, p') |\<in>| eps A \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p', q) \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_eps2: "(q, q') |\<in>| eps B \<Longrightarrow> (p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p, q') \<in> \<Delta>_trancl_set A B"
| \<Delta>_set_trans: "(p, q) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (q, r) \<in> \<Delta>_trancl_set A B \<Longrightarrow> (p, r) \<in> \<Delta>_trancl_set A B"
lemma \<Delta>_trancl_set_states: "\<Delta>_trancl_set \<A> \<B> \<subseteq> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
proof -
{fix p q assume "(p, q) \<in> \<Delta>_trancl_set \<A> \<B>" then have "(p, q) \<in> fset (\<Q> \<A> |\<times>| \<Q> \<B>)"
- by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember.rep_eq)}
+ by (induct) (auto dest: rule_statesD eps_statesD simp flip: fmember_iff_member_fset)}
then show ?thesis by auto
qed
lemma finite_\<Delta>_trancl_set [simp]: "finite (\<Delta>_trancl_set \<A> \<B>)"
using finite_subset[OF \<Delta>_trancl_set_states]
by simp
context
includes fset.lifting
begin
lift_definition \<Delta>_trancl :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>_trancl_set by simp
lemmas \<Delta>_trancl_cong = \<Delta>_set_cong [Transfer.transferred]
lemmas \<Delta>_trancl_eps1 = \<Delta>_set_eps1 [Transfer.transferred]
lemmas \<Delta>_trancl_eps2 = \<Delta>_set_eps2 [Transfer.transferred]
lemmas \<Delta>_trancl_cases = \<Delta>_trancl_set.cases[Transfer.transferred]
lemmas \<Delta>_trancl_induct [consumes 1, case_names \<Delta>_cong \<Delta>_eps1 \<Delta>_eps2 \<Delta>_trans] = \<Delta>_trancl_set.induct[Transfer.transferred]
lemmas \<Delta>_trancl_intros = \<Delta>_trancl_set.intros[Transfer.transferred]
lemmas \<Delta>_trancl_simps = \<Delta>_trancl_set.simps[Transfer.transferred]
end
lemma \<Delta>_trancl_cl [simp]:
"(\<Delta>_trancl A B)|\<^sup>+| = \<Delta>_trancl A B"
proof -
{fix s t assume "(s, t) |\<in>| (\<Delta>_trancl A B)|\<^sup>+|" then have "(s, t) |\<in>| \<Delta>_trancl A B"
by (induct rule: ftrancl_induct) (auto intro: \<Delta>_trancl_intros)}
then show ?thesis by auto
qed
lemma \<Delta>_trancl_states: "\<Delta>_trancl \<A> \<B> |\<subseteq>| (\<Q> \<A> |\<times>| \<Q> \<B>)"
using \<Delta>_trancl_set_states
by (metis \<Delta>_trancl.rep_eq fSigma_cong less_eq_fset.rep_eq)
definition GTT_trancl where
"GTT_trancl G =
(let \<Delta> = \<Delta>_trancl (snd G) (fst G) in
(TA (rules (fst G)) (eps (fst G) |\<union>| \<Delta>),
TA (rules (snd G)) (eps (snd G) |\<union>| (\<Delta>|\<inverse>|))))"
lemma \<Delta>_trancl_inv:
"(\<Delta>_trancl A B)|\<inverse>| = \<Delta>_trancl B A"
proof -
have [dest]: "(p, q) |\<in>| \<Delta>_trancl A B \<Longrightarrow> (q, p) |\<in>| \<Delta>_trancl B A" for p q A B
by (induct rule: \<Delta>_trancl_induct) (auto intro: \<Delta>_trancl_intros)
show ?thesis by auto
qed
lemma gtt_states_GTT_trancl:
"gtt_states (GTT_trancl G) |\<subseteq>| gtt_states G"
unfolding GTT_trancl_def
- by (auto simp: gtt_states_def \<Q>_def \<Delta>_trancl_inv dest!: fsubsetD[OF \<Delta>_trancl_states] simp flip: fmember.rep_eq)
+ by (auto simp: gtt_states_def \<Q>_def \<Delta>_trancl_inv dest!: fsubsetD[OF \<Delta>_trancl_states] simp flip: fmember_iff_member_fset)
lemma gtt_syms_GTT_trancl:
"gtt_syms (GTT_trancl G) = gtt_syms G"
by (auto simp: GTT_trancl_def ta_sig_def \<Delta>_trancl_inv)
lemma GTT_trancl_base:
"gtt_lang G \<subseteq> gtt_lang (GTT_trancl G)"
using gtt_lang_mono[of G "GTT_trancl G"] by (auto simp: \<Delta>_trancl_inv GTT_trancl_def)
lemma GTT_trancl_trans:
"gtt_lang (GTT_comp (GTT_trancl G) (GTT_trancl G)) \<subseteq> gtt_lang (GTT_trancl G)"
proof -
have [dest]: "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A)))
(TA (rules B) (eps B |\<union>| (\<Delta>_trancl A B))) \<Longrightarrow> (p, q) |\<in>| \<Delta>_trancl A B" for p q A B
by (induct rule: \<Delta>\<^sub>\<epsilon>_induct) (auto intro: \<Delta>_trancl_intros simp: \<Delta>_trancl_inv[of B A, symmetric])
show ?thesis
by (intro gtt_lang_mono[of "GTT_comp (GTT_trancl G) (GTT_trancl G)" "GTT_trancl G"])
(auto simp: GTT_comp_def GTT_trancl_def fmember.abs_eq \<Delta>_trancl_inv)
qed
lemma agtt_lang_base:
"agtt_lang G \<subseteq> agtt_lang (GTT_trancl G)"
by (rule agtt_lang_mono) (auto simp: GTT_trancl_def \<Delta>_trancl_inv)
lemma \<Delta>\<^sub>\<epsilon>_tr_incl:
"\<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| \<Delta>_trancl B A)) (TA (rules B) (eps B |\<union>| \<Delta>_trancl A B)) = \<Delta>_trancl A B"
(is "?LS = ?RS")
proof -
{fix p q assume "(p, q) |\<in>| ?LS" then have "(p, q) |\<in>| ?RS"
by (induct rule: \<Delta>\<^sub>\<epsilon>_induct)
(auto simp: \<Delta>_trancl_inv[of B A, symmetric] intro: \<Delta>_trancl_intros)}
moreover
{fix p q assume "(p, q) |\<in>| ?RS" then have "(p, q) |\<in>| ?LS"
by (induct rule: \<Delta>_trancl_induct)
(auto simp: \<Delta>_trancl_inv[of B A, symmetric] intro: \<Delta>\<^sub>\<epsilon>_intros)}
ultimately show ?thesis
by auto
qed
lemma agtt_lang_trans:
"gcomp_rel UNIV (agtt_lang (GTT_trancl G)) (agtt_lang (GTT_trancl G)) \<subseteq> agtt_lang (GTT_trancl G)"
proof -
have [intro!, dest]: "(p, q) |\<in>| \<Delta>\<^sub>\<epsilon> (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A)))
(TA (rules B) (eps B |\<union>| (\<Delta>_trancl A B))) \<Longrightarrow> (p, q) |\<in>| \<Delta>_trancl A B" for p q A B
by (induct rule: \<Delta>\<^sub>\<epsilon>_induct) (auto intro: \<Delta>_trancl_intros simp: \<Delta>_trancl_inv[of B A, symmetric])
show ?thesis
by (rule subset_trans[OF gtt_comp_acomplete agtt_lang_mono])
(auto simp: GTT_comp_def GTT_trancl_def \<Delta>_trancl_inv)
qed
lemma GTT_trancl_acomplete:
"gtrancl_rel UNIV (agtt_lang G) \<subseteq> agtt_lang (GTT_trancl G)"
unfolding gtrancl_rel_def
using agtt_lang_base[of G] gmctxt_cl_mono_rel[OF agtt_lang_base[of G], of UNIV]
using agtt_lang_trans[of G]
unfolding gcomp_rel_def
by (intro kleene_trancl_induct) blast+
lemma Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang:
"(gtt_lang G)\<^sup>* = (gtt_lang G)\<^sup>+"
by (auto simp: rtrancl_trancl_reflcl simp del: reflcl_trancl dest: tranclD tranclD2 intro: gmctxt_cl_refl)
lemma GTT_trancl_complete:
"(gtt_lang G)\<^sup>+ \<subseteq> gtt_lang (GTT_trancl G)"
using GTT_trancl_base subset_trans[OF gtt_comp_lang_complete GTT_trancl_trans]
by (metis trancl_id trancl_mono_set trans_O_iff)
lemma trancl_gtt_lang_arg_closed:
assumes "length ss = length ts" "\<forall>i < length ts. (ss ! i, ts ! i) \<in> (gtt_lang \<G>)\<^sup>+"
shows "(GFun f ss, GFun f ts) \<in> (gtt_lang \<G>)\<^sup>+" (is "?e \<in> _")
proof -
have "all_ctxt_closed UNIV ((gtt_lang \<G>)\<^sup>+)" by (intro all_ctxt_closed_trancl) auto
from all_ctxt_closedD[OF this _ assms] show ?thesis
by auto
qed
lemma \<Delta>_trancl_sound:
assumes "(p, q) |\<in>| \<Delta>_trancl A B"
obtains s t where "(s, t) \<in> (gtt_lang (B, A))\<^sup>+" "p |\<in>| gta_der A s" "q |\<in>| gta_der B t"
using assms
proof (induct arbitrary: thesis rule: \<Delta>_trancl_induct)
case (\<Delta>_cong f ps p qs q)
have "\<exists>si ti. (si, ti) \<in> (gtt_lang (B, A))\<^sup>+ \<and> ps ! i |\<in>| gta_der A (si) \<and>
qs ! i |\<in>| gta_der B (ti)" if "i < length qs" for i
using \<Delta>_cong(5)[OF that] by metis
then obtain ss ts where
"\<And>i. i < length qs \<Longrightarrow> (ss i, ts i) \<in> (gtt_lang (B, A))\<^sup>+ \<and> ps ! i |\<in>| gta_der A (ss i) \<and> qs ! i |\<in>| gta_der B (ts i)" by metis
then show ?case using \<Delta>_cong(1-5)
by (intro \<Delta>_cong(6)[of "GFun f (map ss [0..<length ps])" "GFun f (map ts [0..<length qs])"])
(auto simp: gta_der_def intro!: trancl_gtt_lang_arg_closed)
next
case (\<Delta>_eps1 p p' q) then show ?case
by (metis gta_der_def ta_der_eps)
next
case (\<Delta>_eps2 q q' p) then show ?case
by (metis gta_der_def ta_der_eps)
next
case (\<Delta>_trans p q r)
obtain s1 t1 where "(s1, t1) \<in> (gtt_lang (B, A))\<^sup>+" "p |\<in>| gta_der A s1" "q |\<in>| gta_der B t1"
using \<Delta>_trans(2) .note 1 = this
obtain s2 t2 where "(s2, t2) \<in> (gtt_lang (B, A))\<^sup>+" "q |\<in>| gta_der A s2" "r |\<in>| gta_der B t2"
using \<Delta>_trans(4) . note 2 = this
have "(t1, s2) \<in> gtt_lang (B, A)" using 1(1,3) 2(1,2)
by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
then have "(s1, t2) \<in> (gtt_lang (B, A))\<^sup>+" using 1(1) 2(1)
by (meson trancl.trancl_into_trancl trancl_trans)
then show ?case using 1(2) 2(3) by (auto intro: \<Delta>_trans(5)[of s1 t2])
qed
lemma GTT_trancl_sound_aux:
assumes "p |\<in>| gta_der (TA (rules A) (eps A |\<union>| (\<Delta>_trancl B A))) s"
shows "\<exists>t. (s, t) \<in> (gtt_lang (A, B))\<^sup>+ \<and> p |\<in>| gta_der A t"
using assms
proof (induct s arbitrary: p)
case (GFun f ss)
let ?eps = "eps A |\<union>| \<Delta>_trancl B A"
obtain qs q where q: "TA_rule f qs q |\<in>| rules A" "q = p \<or> (q, p) |\<in>| ?eps|\<^sup>+|" "length qs = length ss"
"\<And>i. i < length ss \<Longrightarrow> qs ! i |\<in>| gta_der (TA (rules A) ?eps) (ss ! i)"
using GFun(2) by (auto simp: gta_der_def)
have "\<And>i. i < length ss \<Longrightarrow> \<exists>ti. (ss ! i, ti) \<in> (gtt_lang (A, B))\<^sup>+ \<and> qs ! i |\<in>| gta_der A (ti)"
using GFun(1)[OF nth_mem q(4)] unfolding gta_der_def by fastforce
then obtain ts where ts: "\<And>i. i < length ss \<Longrightarrow> (ss ! i, ts i) \<in> (gtt_lang (A, B))\<^sup>+ \<and> qs ! i |\<in>| gta_der A (ts i)"
by metis
then have q': "q |\<in>| gta_der A (GFun f (map ts [0..<length ss]))"
"(GFun f ss, GFun f (map ts [0..<length ss])) \<in> (gtt_lang (A, B))\<^sup>+" using q(1, 3)
by (auto simp: gta_der_def intro!: exI[of _ qs] exI[of _ q] trancl_gtt_lang_arg_closed)
{fix p q u assume ass: "(p, q) |\<in>| \<Delta>_trancl B A" "(GFun f ss, u) \<in> (gtt_lang (A, B))\<^sup>+ \<and> p |\<in>| gta_der A u"
from \<Delta>_trancl_sound[OF this(1)] obtain s t
where "(s, t) \<in> (gtt_lang (A, B))\<^sup>+" "p |\<in>| gta_der B s" "q |\<in>| gta_der A t" . note st = this
have "(u, s) \<in> gtt_lang (A, B)" using st conjunct2[OF ass(2)]
by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
then have "(GFun f ss, t) \<in> (gtt_lang (A, B))\<^sup>+"
using ass st(1) by (meson trancl_into_trancl2 trancl_trans)
then have "\<exists> s t. (GFun f ss, t) \<in> (gtt_lang (A, B))\<^sup>+ \<and> q |\<in>| gta_der A t" using st by blast}
note trancl_step = this
show ?case
proof (cases "q = p")
case True
then show ?thesis using ts q(1, 3)
by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"] trancl_gtt_lang_arg_closed) blast
next
case False
then have "(q, p) |\<in>| ?eps|\<^sup>+|" using q(2) by simp
then show ?thesis using q(1) q'
proof (induct rule: ftrancl_induct)
case (Base q p) from Base(1) show ?case
proof
assume "(q, p) |\<in>| eps A" then show ?thesis using Base(2) ts q(3)
by (auto simp: gta_der_def intro!: exI[of _"GFun f (map ts [0..< length ss])"]
trancl_gtt_lang_arg_closed exI[of _ qs] exI[of _ q])
next
assume "(q, p) |\<in>| (\<Delta>_trancl B A)"
then have "(q, p) |\<in>| \<Delta>_trancl B A" by (simp add: fmember.abs_eq)
from trancl_step[OF this] show ?thesis using Base(3, 4)
by auto
qed
next
case (Step p q r)
from Step(2, 4-) obtain s' where s': "(GFun f ss, s') \<in> (gtt_lang (A, B))\<^sup>+ \<and> q |\<in>| gta_der A s'" by auto
show ?case using Step(3)
proof
assume "(q, r) |\<in>| eps A" then show ?thesis using s'
by (auto simp: gta_der_def ta_der_eps intro!: exI[of _ s'])
next
assume "(q, r) |\<in>| \<Delta>_trancl B A"
then have "(q, r) |\<in>| \<Delta>_trancl B A" by (simp add: fmember.abs_eq)
from trancl_step[OF this] show ?thesis using s' by auto
qed
qed
qed
qed
lemma GTT_trancl_asound:
"agtt_lang (GTT_trancl G) \<subseteq> gtrancl_rel UNIV (agtt_lang G)"
proof (intro subrelI, goal_cases LR)
case (LR s t)
then obtain s' q t' where *: "(s, s') \<in> (gtt_lang G)\<^sup>+"
"q |\<in>| gta_der (fst G) s'" "q |\<in>| gta_der (snd G) t'" "(t', t) \<in> (gtt_lang G)\<^sup>+"
by (auto simp: agtt_lang_def GTT_trancl_def trancl_converse \<Delta>_trancl_inv
simp flip: gtt_lang_swap[of "fst G" "snd G", unfolded prod.collapse agtt_lang_def, simplified]
dest!: GTT_trancl_sound_aux)
then have "(s', t') \<in> agtt_lang G" using *(2,3)
by (auto simp: agtt_lang_def)
then show ?case using *(1,4) unfolding gtrancl_rel_def
by auto
qed
lemma GTT_trancl_sound:
"gtt_lang (GTT_trancl G) \<subseteq> (gtt_lang G)\<^sup>+"
proof -
note [dest] = GTT_trancl_sound_aux
have "gtt_accept (GTT_trancl G) s t \<Longrightarrow> (s, t) \<in> (gtt_lang G)\<^sup>+" for s t unfolding gtt_accept_def
proof (induct rule: gmctxt_cl.induct)
case (base s t)
from base obtain q where join: "q |\<in>| gta_der (fst (GTT_trancl G)) s" "q |\<in>| gta_der (snd (GTT_trancl G)) t"
by (auto simp: agtt_lang_def)
obtain s' where "(s, s') \<in> (gtt_lang G)\<^sup>+" "q |\<in>| gta_der (fst G) s'" using base join
by (auto simp: GTT_trancl_def \<Delta>_trancl_inv agtt_lang_def)
moreover obtain t' where "(t', t) \<in> (gtt_lang G)\<^sup>+" "q |\<in>| gta_der (snd G) t'" using join
by (auto simp: GTT_trancl_def gtt_lang_swap[of "fst G" "snd G", symmetric] trancl_converse \<Delta>_trancl_inv)
moreover have "(s', t') \<in> gtt_lang G" using calculation
by (auto simp: Restr_rtrancl_gtt_lang_eq_trancl_gtt_lang[symmetric] gtt_lang_join)
ultimately show "(s, t) \<in> (gtt_lang G)\<^sup>+" by (meson trancl.trancl_into_trancl trancl_trans)
qed (auto intro!: trancl_gtt_lang_arg_closed)
then show ?thesis by (auto simp: gtt_accept_def)
qed
lemma GTT_trancl_alang:
"agtt_lang (GTT_trancl G) = gtrancl_rel UNIV (agtt_lang G)"
using GTT_trancl_asound GTT_trancl_acomplete by blast
lemma GTT_trancl_lang:
"gtt_lang (GTT_trancl G) = (gtt_lang G)\<^sup>+"
using GTT_trancl_sound GTT_trancl_complete by blast
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Horn_Setup/Horn_Fset.thy b/thys/Regular_Tree_Relations/Horn_Setup/Horn_Fset.thy
--- a/thys/Regular_Tree_Relations/Horn_Setup/Horn_Fset.thy
+++ b/thys/Regular_Tree_Relations/Horn_Setup/Horn_Fset.thy
@@ -1,105 +1,105 @@
theory Horn_Fset
imports Horn_Inference FSet_Utils
begin
locale horn_fset_impl = horn +
fixes infer0_impl :: "'a list" and infer1_impl :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a list"
begin
lemma saturate_fold_simp [simp]:
"fold (\<lambda>xa. case_option None (f xa)) xs None = None"
by (induct xs) auto
lemma saturate_fold_mono [partial_function_mono]:
"option.mono_body (\<lambda>f. fold (\<lambda>x. case_option None (\<lambda>y. f (x, y))) xs b)"
unfolding monotone_def fun_ord_def flat_ord_def
proof (intro allI impI, induct xs arbitrary: b)
case (Cons a xs)
show ?case
using Cons(1)[OF Cons(2), of "x (a, the b)"] Cons(2)[rule_format, of "(a, the b)"]
by (cases b) auto
qed auto
partial_function (option) saturate_rec :: "'a \<Rightarrow> 'a fset \<Rightarrow> ('a fset) option" where
"saturate_rec x bs = (if x |\<in>| bs then Some bs else
fold (\<lambda>x. case_option None (saturate_rec x)) (infer1_impl x bs) (Some (finsert x bs)))"
definition saturate_impl where
"saturate_impl = fold (\<lambda>x. case_option None (saturate_rec x)) infer0_impl (Some {||})"
end
locale horn_fset = horn_fset_impl +
assumes infer0: "infer0 = set infer0_impl"
and infer1: "\<And>x bs. infer1 x (fset bs) = set (infer1_impl x bs)"
begin
lemma saturate_rec_sound:
"saturate_rec x bs = Some bs' \<Longrightarrow> ({x}, fset bs) \<turnstile> ({}, fset bs')"
proof (induct arbitrary: x bs bs' rule: saturate_rec.fixp_induct)
case 1 show ?case using option_admissible[of "\<lambda>(x, y) z. _ x y z"]
by fastforce
next
case (3 rec)
have [dest!]: "(set xs, fset ys) \<turnstile> ({}, fset bs')"
if "fold (\<lambda>x a. case a of None \<Rightarrow> None | Some a \<Rightarrow> rec x a) xs (Some ys) = Some bs'"
for xs ys using that
proof (induct xs arbitrary: ys)
case (Cons a xs)
show ?case using trans[OF step_mono[OF 3(1)], of a ys _ "set xs" "{}" "fset bs'"] Cons
by (cases "rec a ys") auto
qed (auto intro: refl)
show ?case using propagate[of x "{}" "fset bs", unfolded infer1 Un_empty_left] 3(2)
- by (auto simp: delete fmember.rep_eq split: if_splits intro: trans delete)
+ by (auto simp: delete fmember_iff_member_fset split: if_splits intro: trans delete)
qed auto
lemma saturate_impl_sound:
assumes "saturate_impl = Some B'"
shows "fset B' = saturate"
proof -
have "(set xs, fset ys) \<turnstile> ({}, fset bs')"
if "fold (\<lambda>x a. case a of None \<Rightarrow> None | Some a \<Rightarrow> saturate_rec x a) xs (Some ys) = Some bs'"
for xs ys bs' using that
proof (induct xs arbitrary: ys)
case (Cons a xs)
show ?case
using trans[OF step_mono[OF saturate_rec_sound], of a ys _ "set xs" "{}" "fset bs'"] Cons
by (cases "saturate_rec a ys") auto
qed (auto intro: refl)
from this[of infer0_impl "{||}" B'] assms step_sound show ?thesis
by (auto simp: saturate_impl_def infer0)
qed
lemma saturate_impl_complete:
assumes "finite saturate"
shows "saturate_impl \<noteq> None"
proof -
have *: "fold (\<lambda>x. case_option None (saturate_rec x)) ds (Some bs) \<noteq> None"
if "fset bs \<subseteq> saturate" "set ds \<subseteq> saturate" for bs ds
using that
proof (induct "card (saturate - fset bs)" arbitrary: bs ds rule: less_induct)
case less
show ?case using less(3)
proof (induct ds)
case (Cons d ds)
have "infer1 d (fset bs) \<subseteq> saturate" using less(2) Cons(2)
unfolding infer1_def by (auto intro: saturate.infer)
moreover have "card (saturate - fset (finsert d bs)) < card (saturate - fset bs)" if "d \<notin> fset bs"
using Cons(2) assms that
by (metis DiffI Diff_insert card_Diff1_less finite_Diff finsert.rep_eq in_mono insertCI list.simps(15))
ultimately show ?case using less(1)[of "finsert d bs" "infer1_impl d bs @ ds"] less(2) Cons assms
unfolding fold.simps comp_def option.simps
apply (subst saturate_rec.simps)
apply (auto simp flip: saturate_rec.simps split!: if_splits simp: infer1)
apply (simp add: notin_fset saturate_rec.simps)
done
qed simp
qed
show ?thesis using *[of "{||}" "infer0_impl"] inv_start by (simp add: saturate_impl_def infer0)
qed
end
lemmas [code] = horn_fset_impl.saturate_rec.simps horn_fset_impl.saturate_impl_def
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Pair_Automaton.thy b/thys/Regular_Tree_Relations/Pair_Automaton.thy
--- a/thys/Regular_Tree_Relations/Pair_Automaton.thy
+++ b/thys/Regular_Tree_Relations/Pair_Automaton.thy
@@ -1,370 +1,370 @@
theory Pair_Automaton
imports Tree_Automata_Complement GTT_Compose
begin
subsection \<open>Pair automaton and anchored GTTs\<close>
definition pair_at_lang :: "('q, 'f) gtt \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'f gterm rel" where
"pair_at_lang \<G> Q = {(s, t) | s t p q. q |\<in>| gta_der (fst \<G>) s \<and> p |\<in>| gta_der (snd \<G>) t \<and> (q, p) |\<in>| Q}"
lemma pair_at_lang_restr_states:
"pair_at_lang \<G> Q = pair_at_lang \<G> (Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)))"
by (auto simp: pair_at_lang_def gta_der_def) (meson gterm_ta_der_states)
lemma pair_at_langE:
assumes "(s, t) \<in> pair_at_lang \<G> Q"
obtains q p where "(q, p) |\<in>| Q" and "q |\<in>| gta_der (fst \<G>) s" and "p |\<in>| gta_der (snd \<G>) t"
using assms by (auto simp: pair_at_lang_def)
lemma pair_at_langI:
assumes "q |\<in>| gta_der (fst \<G>) s" "p |\<in>| gta_der (snd \<G>) t" "(q, p) |\<in>| Q"
shows "(s, t) \<in> pair_at_lang \<G> Q"
using assms by (auto simp: pair_at_lang_def)
lemma pair_at_lang_fun_states:
assumes "finj_on f (\<Q> (fst \<G>))" and "finj_on g (\<Q> (snd \<G>))"
and "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
shows "pair_at_lang \<G> Q = pair_at_lang (map_prod (fmap_states_ta f) (fmap_states_ta g) \<G>) (map_prod f g |`| Q)"
(is "?LS = ?RS")
proof
{fix s t assume "(s, t) \<in> ?LS"
then have "(s, t) \<in> ?RS" using ta_der_fmap_states_ta_mono[of f "fst \<G>" s]
using ta_der_fmap_states_ta_mono[of g "snd \<G>" t]
by (force simp: gta_der_def map_prod_def image_iff elim!: pair_at_langE split: prod.split intro!: pair_at_langI)}
then show "?LS \<subseteq> ?RS" by auto
next
{fix s t assume "(s, t) \<in> ?RS"
then obtain p q where rs: "p |\<in>| ta_der (fst \<G>) (term_of_gterm s)" "f p |\<in>| ta_der (fmap_states_ta f (fst \<G>)) (term_of_gterm s)" and
ts: "q |\<in>| ta_der (snd \<G>) (term_of_gterm t)" "g q |\<in>| ta_der (fmap_states_ta g (snd \<G>)) (term_of_gterm t)" and
st: "(f p, g q) |\<in>| (map_prod f g |`| Q)" using assms ta_der_fmap_states_inv[of f "fst \<G>" _ s]
using ta_der_fmap_states_inv[of g "snd \<G>" _ t]
by (auto simp: gta_der_def adapt_vars_term_of_gterm elim!: pair_at_langE)
(metis (no_types, opaque_lifting) fimageE fmap_prod_fimageI ta_der_fmap_states_conv)
then have "p |\<in>| \<Q> (fst \<G>)" "q |\<in>| \<Q> (snd \<G>)" by auto
then have "(p, q) |\<in>| Q" using assms st unfolding fimage_iff fBex_def
by (auto dest!: fsubsetD simp: finj_on_eq_iff)
then have "(s, t) \<in> ?LS" using st rs(1) ts(1) by (auto simp: gta_der_def intro!: pair_at_langI)}
then show "?RS \<subseteq> ?LS" by auto
qed
lemma converse_pair_at_lang:
"(pair_at_lang \<G> Q)\<inverse> = pair_at_lang (prod.swap \<G>) (Q|\<inverse>|)"
by (auto simp: pair_at_lang_def)
lemma pair_at_agtt:
"agtt_lang \<G> = pair_at_lang \<G> (fId_on (gtt_interface \<G>))"
by (auto simp: agtt_lang_def gtt_interface_def pair_at_lang_def gtt_states_def gta_der_def fId_on_iff)
definition \<Delta>_eps_pair where
"\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2 \<equiv> Q\<^sub>1 |O| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2) |O| Q\<^sub>2"
lemma pair_comp_sound1:
assumes "(s, t) \<in> pair_at_lang \<G>\<^sub>1 Q\<^sub>1"
and "(t, u) \<in> pair_at_lang \<G>\<^sub>2 Q\<^sub>2"
shows "(s, u) \<in> pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
proof -
from pair_at_langE assms obtain p q q' r where
wit: "(p, q) |\<in>| Q\<^sub>1" "p |\<in>| gta_der (fst \<G>\<^sub>1) s" "q |\<in>| gta_der (snd \<G>\<^sub>1) t"
"(q', r) |\<in>| Q\<^sub>2" "q' |\<in>| gta_der (fst \<G>\<^sub>2) t" "r |\<in>| gta_der (snd \<G>\<^sub>2) u"
by metis
from wit(3, 5) have "(q, q') |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def intro!: exI[of _ "term_of_gterm t"])
then have "(p, r) |\<in>| \<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2" using wit(1, 4)
by (auto simp: \<Delta>_eps_pair_def)
then show ?thesis using wit(2, 6) unfolding pair_at_lang_def
by auto
qed
lemma pair_comp_sound2:
assumes "(s, u) \<in> pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
shows "\<exists> t. (s, t) \<in> pair_at_lang \<G>\<^sub>1 Q\<^sub>1 \<and> (t, u) \<in> pair_at_lang \<G>\<^sub>2 Q\<^sub>2"
using assms unfolding pair_at_lang_def \<Delta>_eps_pair_def
by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def) (metis gterm_of_term_inv)
lemma pair_comp_sound:
"pair_at_lang \<G>\<^sub>1 Q\<^sub>1 O pair_at_lang \<G>\<^sub>2 Q\<^sub>2 = pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
by (auto simp: pair_comp_sound1 pair_comp_sound2 relcomp.simps)
inductive_set \<Delta>_Atrans_set :: "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for Q \<A> \<B> where
base [simp]: "(p, q) |\<in>| Q \<Longrightarrow> (p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B>"
| step [intro]: "(p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (q, r) |\<in>| \<Delta>\<^sub>\<epsilon> \<B> \<A> \<Longrightarrow>
(r, v) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (p, v) \<in> \<Delta>_Atrans_set Q \<A> \<B>"
lemma \<Delta>_Atrans_set_states:
"(p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (p, q) \<in> fset ((fst |`| Q |\<union>| \<Q> \<A>) |\<times>| (snd |`| Q |\<union>| \<Q> \<B>))"
- by (induct rule: \<Delta>_Atrans_set.induct) (auto simp: fimage_iff fBex_def simp flip: fmember.rep_eq)
+ by (induct rule: \<Delta>_Atrans_set.induct) (auto simp: fimage_iff fBex_def simp flip: fmember_iff_member_fset)
lemma finite_\<Delta>_Atrans_set: "finite (\<Delta>_Atrans_set Q \<A> \<B>)"
proof -
have "\<Delta>_Atrans_set Q \<A> \<B> \<subseteq> fset ((fst |`| Q |\<union>| \<Q> \<A>) |\<times>| (snd |`| Q |\<union>| \<Q> \<B>))"
using \<Delta>_Atrans_set_states by auto
from finite_subset[OF this] show ?thesis by simp
qed
context
includes fset.lifting
begin
lift_definition \<Delta>_Atrans :: "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>_Atrans_set
by (simp add: finite_\<Delta>_Atrans_set)
lemmas \<Delta>_Atrans_base [simp] = \<Delta>_Atrans_set.base [Transfer.transferred]
lemmas \<Delta>_Atrans_step [intro] = \<Delta>_Atrans_set.step [Transfer.transferred]
lemmas \<Delta>_Atrans_cases = \<Delta>_Atrans_set.cases[Transfer.transferred]
lemmas \<Delta>_Atrans_induct [consumes 1, case_names base step] = \<Delta>_Atrans_set.induct[Transfer.transferred]
end
abbreviation "\<Delta>_Atrans_gtt \<G> Q \<equiv> \<Delta>_Atrans Q (fst \<G>) (snd \<G>)"
lemma pair_trancl_sound1:
assumes "(s, t) \<in> (pair_at_lang \<G> Q)\<^sup>+"
shows "\<exists> q p. p |\<in>| gta_der (fst \<G>) s \<and> q |\<in>| gta_der (snd \<G>) t \<and> (p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
using assms
proof (induct)
case (step t v)
obtain p q r r' where reach_t: "r |\<in>| gta_der (fst \<G>) t" "q |\<in>| gta_der (snd \<G>) t" and
reach: "p |\<in>| gta_der (fst \<G>) s" "r' |\<in>| gta_der (snd \<G>) v" and
st: "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q" "(r, r') |\<in>| Q" using step(2, 3)
by (auto simp: pair_at_lang_def)
from reach_t have "(q, r) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def intro: ground_term_of_gterm)
then have "(p, r') |\<in>| \<Delta>_Atrans_gtt \<G> Q" using st by auto
then show ?case using reach reach_t
by (auto simp: pair_at_lang_def gta_der_def \<Delta>\<^sub>\<epsilon>_def' intro: ground_term_of_gterm)
qed (auto simp: pair_at_lang_def intro: \<Delta>_Atrans_base)
lemma pair_trancl_sound2:
assumes "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
and "p |\<in>| gta_der (fst \<G>) s" "q |\<in>| gta_der (snd \<G>) t"
shows "(s, t) \<in> (pair_at_lang \<G> Q)\<^sup>+" using assms
proof (induct arbitrary: s t rule:\<Delta>_Atrans_induct)
case (step p q r v)
from step(2)[OF step(6)] step(5)[OF _ step(7)] step(3)
show ?case by (auto simp: gta_der_def \<Delta>\<^sub>\<epsilon>_def' intro!: ground_term_of_gterm)
(metis gterm_of_term_inv trancl_trans)
qed (auto simp: pair_at_lang_def)
lemma pair_trancl_sound:
"(pair_at_lang \<G> Q)\<^sup>+ = pair_at_lang \<G> (\<Delta>_Atrans_gtt \<G> Q)"
by (auto simp: pair_trancl_sound2 dest: pair_trancl_sound1 elim: pair_at_langE intro: pair_at_langI)
abbreviation "fst_pair_cl \<A> Q \<equiv> TA (rules \<A>) (eps \<A> |\<union>| (fId_on (\<Q> \<A>) |O| Q))"
definition pair_at_to_agtt :: "('q, 'f) gtt \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q, 'f) gtt" where
"pair_at_to_agtt \<G> Q = (fst_pair_cl (fst \<G>) Q , TA (rules (snd \<G>)) (eps (snd \<G>)))"
lemma fst_pair_cl_eps:
assumes "(p, q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|"
and "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
shows "(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<or> (\<exists> r. (p = r \<or> (p, r) |\<in>| (eps \<A>)|\<^sup>+|) \<and> (r, q) |\<in>| Q)" using assms
proof (induct rule: ftrancl_induct)
case (Step p q r)
then have y: "q |\<in>| \<Q> \<A>" by (auto simp add: eps_trancl_statesD eps_statesD)
have [simp]: "(p, q) |\<in>| Q \<Longrightarrow> q |\<in>| snd |`| Q" for p q by (auto simp: fimage_iff) force
then show ?case using Step y
by auto (simp add: ftrancl_into_trancl)
qed auto
lemma fst_pair_cl_res_aux:
assumes "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
and "q |\<in>| ta_der (fst_pair_cl \<A> Q) (term_of_gterm t)"
shows "\<exists> p. p |\<in>| ta_der \<A> (term_of_gterm t) \<and> (q |\<notin>| \<Q> \<A> \<longrightarrow> (p, q) |\<in>| Q) \<and> (q |\<in>| \<Q> \<A> \<longrightarrow> p = q)" using assms
proof (induct t arbitrary: q)
case (GFun f ts)
then obtain qs q' where rule: "TA_rule f qs q' |\<in>| rules \<A>" "length qs = length ts" and
eps: "q' = q \<or> (q', q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|" and
reach: "\<forall> i < length ts. qs ! i |\<in>| ta_der (fst_pair_cl \<A> Q) (term_of_gterm (ts ! i))"
by auto
{fix i assume ass: "i < length ts" then have st: "qs ! i |\<in>| \<Q> \<A>" using rule
by (auto simp: rule_statesD)
then have "qs ! i |\<notin>| snd |`| Q" using GFun(2) by auto
then have "qs ! i |\<in>| ta_der \<A> (term_of_gterm (ts ! i))" using reach st ass
using fst_pair_cl_eps[OF _ GFun(2)] GFun(1)[OF nth_mem[OF ass] GFun(2), of "qs ! i"]
by blast} note IH = this
show ?case
proof (cases "q' = q")
case True
then show ?thesis using rule reach IH
by (auto dest: rule_statesD intro!: exI[of _ q'] exI[of _ qs])
next
case False note nt_eq = this
then have eps: "(q', q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|" using eps by simp
from fst_pair_cl_eps[OF this assms(1)] show ?thesis
using False rule IH
proof (cases "q |\<notin>| \<Q> \<A>")
case True
from fst_pair_cl_eps[OF eps assms(1)] obtain r where
"q' = r \<or> (q', r) |\<in>| (eps \<A>)|\<^sup>+|" "(r, q) |\<in>| Q" using True
by (auto simp: eps_trancl_statesD)
then show ?thesis using nt_eq rule IH True
by (auto simp: fimage_iff eps_trancl_statesD)
next
case False
from fst_pair_cl_eps[OF eps assms(1)] False assms(1)
have "(q', q) |\<in>| (eps \<A>)|\<^sup>+|"
by (auto simp: fimage_iff) (metis fempty_iff fimage_eqI finterI snd_conv)+
then show ?thesis using IH rule
by (intro exI[of _ q]) (auto simp: eps_trancl_statesD)
qed
qed
qed
lemma restr_distjoing:
assumes "Q |\<subseteq>| \<Q> \<A> |\<times>| \<Q> \<BB>"
and "\<Q> \<A> |\<inter>| \<Q> \<BB> = {||}"
shows "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
using assms by auto
lemma pair_at_agtt_conv:
assumes "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)" and "\<Q> (fst \<G>) |\<inter>| \<Q> (snd \<G>) = {||}"
shows "pair_at_lang \<G> Q = agtt_lang (pair_at_to_agtt \<G> Q)" (is "?LS = ?RS")
proof
let ?TA = "fst_pair_cl (fst \<G>) Q"
{fix s t assume ls: "(s, t) \<in> ?LS"
then obtain q p where w: "(q, p) |\<in>| Q" "q |\<in>| gta_der (fst \<G>) s" "p |\<in>| gta_der (snd \<G>) t"
by (auto elim: pair_at_langE)
from w(2) have "q |\<in>| gta_der ?TA s" "q |\<in>| \<Q> (fst \<G>)"
using ta_der_mono'[of "fst \<G>" ?TA "term_of_gterm s"]
by (auto simp add: fin_mono ta_subset_def gta_der_def in_mono)
then have "(s, t) \<in> ?RS" using w(1, 3)
by (auto simp: pair_at_to_agtt_def agtt_lang_def gta_der_def ta_der_eps intro!: exI[of _ p])
(metis fId_onI frelcompI funionI2 ta.sel(2) ta_der_eps)}
then show "?LS \<subseteq> ?RS" by auto
next
{fix s t assume ls: "(s, t) \<in> ?RS"
then obtain q where w: "q |\<in>| ta_der (fst_pair_cl (fst \<G>) Q) (term_of_gterm s)"
"q |\<in>| ta_der (snd \<G>) (term_of_gterm t)"
by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def)
from w(2) have "q |\<in>| \<Q> (snd \<G>)" "q |\<notin>| \<Q> (fst \<G>)" using assms(2)
by auto
from fst_pair_cl_res_aux[OF restr_distjoing[OF assms] w(1)] this w(2)
have "(s, t) \<in> ?LS" by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def intro: pair_at_langI)}
then show "?RS \<subseteq> ?LS" by auto
qed
definition pair_at_to_agtt' where
"pair_at_to_agtt' \<G> Q = (let \<A> = fmap_states_ta Inl (fst \<G>) in
let \<B> = fmap_states_ta Inr (snd \<G>) in
let Q' = Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)) in
pair_at_to_agtt (\<A>, \<B>) (map_prod Inl Inr |`| Q'))"
lemma pair_at_agtt_cost:
"pair_at_lang \<G> Q = agtt_lang (pair_at_to_agtt' \<G> Q)"
proof -
let ?G = "(fmap_states_ta CInl (fst \<G>), fmap_states_ta CInr (snd \<G>))"
let ?Q = "(Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)))"
let ?Q' = "map_prod CInl CInr |`| ?Q"
have *: "pair_at_lang \<G> Q = pair_at_lang \<G> ?Q"
using pair_at_lang_restr_states by blast
have "pair_at_lang \<G> ?Q = pair_at_lang (map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) \<G>) (map_prod CInl CInr |`| ?Q)"
by (intro pair_at_lang_fun_states[where ?\<G> = \<G> and ?Q = ?Q and ?f = CInl and ?g = CInr])
(auto simp: finj_CInl_CInr)
then have **:"pair_at_lang \<G> ?Q = pair_at_lang ?G ?Q'" by (simp add: map_prod_simp')
have "pair_at_lang ?G ?Q' = agtt_lang (pair_at_to_agtt ?G ?Q')"
by (intro pair_at_agtt_conv[where ?\<G> = ?G]) auto
then show ?thesis unfolding * ** pair_at_to_agtt'_def Let_def
by simp
qed
lemma \<Delta>_Atrans_states_stable:
assumes "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
shows "\<Delta>_Atrans_gtt \<G> Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
proof
fix s assume ass: "s |\<in>| \<Delta>_Atrans_gtt \<G> Q"
then obtain t u where s: "s = (t, u)" by (cases s) blast
show "s |\<in>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)" using ass assms unfolding s
by (induct rule: \<Delta>_Atrans_induct) auto
qed
lemma \<Delta>_Atrans_map_prod:
assumes "finj_on f (\<Q> (fst \<G>))" and "finj_on g (\<Q> (snd \<G>))"
and "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
shows "map_prod f g |`| (\<Delta>_Atrans_gtt \<G> Q) = \<Delta>_Atrans_gtt (map_prod (fmap_states_ta f) (fmap_states_ta g) \<G>) (map_prod f g |`| Q)"
(is "?LS = ?RS")
proof -
{fix p q assume "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
then have "(f p, g q) |\<in>| ?RS" using assms
proof (induct rule: \<Delta>_Atrans_induct)
case (step p q r v)
from step(3, 6, 7) have "(g q, f r) |\<in>| \<Delta>\<^sub>\<epsilon> (fmap_states_ta g (snd \<G>)) (fmap_states_ta f (fst \<G>))"
by (auto simp: \<Delta>\<^sub>\<epsilon>_def' intro!: ground_term_of_gterm)
(metis ground_term_of_gterm ground_term_to_gtermD ta_der_to_fmap_states_der)
then show ?case using step by auto
qed (auto simp add: fmap_prod_fimageI)}
moreover
{fix p q assume "(p, q) |\<in>| ?RS"
then have "(p, q) |\<in>| ?LS" using assms
proof (induct rule: \<Delta>_Atrans_induct)
case (step p q r v)
let ?f = "the_finv_into (\<Q> (fst \<G>)) f" let ?g = "the_finv_into (\<Q> (snd \<G>)) g"
have sub: "\<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>) |\<subseteq>| \<Q> (snd \<G>) |\<times>| \<Q> (fst \<G>)"
using \<Delta>\<^sub>\<epsilon>_statesD(1, 2) by fastforce
have s_e: "(?f p, ?g q) |\<in>| \<Delta>_Atrans_gtt \<G> Q" "(?f r, ?g v) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
using step assms(1, 2) fsubsetD[OF \<Delta>_Atrans_states_stable[OF assms(3)]]
using finj_on_eq_iff[OF assms(1)] finj_on_eq_iff
using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
by auto
from step(3) have "(?g q, ?f r) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)"
using step(6-) sub
using ta_der_fmap_states_conv[OF assms(1)] ta_der_fmap_states_conv[OF assms(2)]
using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
by (auto simp: \<Delta>\<^sub>\<epsilon>_fmember fimage_iff fBex_def)
(metis ground_term_of_gterm ground_term_to_gtermD ta_der_fmap_states_inv)
then have "(q, r) |\<in>| map_prod g f |`| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)" using step
using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)] sub
by auto (smt \<Delta>\<^sub>\<epsilon>_statesD(1, 2) f_the_finv_into_f fmap_prod_fimageI fmap_states)
then show ?case using s_e assms(1, 2) s_e
using fsubsetD[OF sub]
using fsubsetD[OF \<Delta>_Atrans_states_stable[OF assms(3)]]
using \<Delta>_Atrans_step[of "?f p" "?g q" Q "fst \<G>" "snd \<G>" "?f r" "?g v"]
using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
by (auto simp: fimage_iff fBex_def)
(smt Pair_inject prod_fun_fimageE step.hyps(2) step.hyps(5) step.prems(3))
qed auto}
ultimately show ?thesis by auto
qed
\<comment> \<open>Section: Pair Automaton is closed under Determinization\<close>
definition Q_pow where
"Q_pow Q \<S>\<^sub>1 \<S>\<^sub>2 =
{|(Wrapp X, Wrapp Y) | X Y p q. X |\<in>| fPow \<S>\<^sub>1 \<and> Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| X \<and> q |\<in>| Y \<and> (p, q) |\<in>| Q|}"
lemma Q_pow_fmember:
"(X, Y) |\<in>| Q_pow Q \<S>\<^sub>1 \<S>\<^sub>2 \<longleftrightarrow> (\<exists> p q. ex X |\<in>| fPow \<S>\<^sub>1 \<and> ex Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| ex X \<and> q |\<in>| ex Y \<and> (p, q) |\<in>| Q)"
proof -
let ?S = "{(Wrapp X, Wrapp Y) | X Y p q. X |\<in>| fPow \<S>\<^sub>1 \<and> Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| X \<and> q |\<in>| Y \<and> (p, q) |\<in>| Q}"
- have "?S \<subseteq> map_prod Wrapp Wrapp ` fset (fPow \<S>\<^sub>1 |\<times>| fPow \<S>\<^sub>2)" by (auto simp flip: fmember.rep_eq)
+ have "?S \<subseteq> map_prod Wrapp Wrapp ` fset (fPow \<S>\<^sub>1 |\<times>| fPow \<S>\<^sub>2)" by (auto simp flip: fmember_iff_member_fset)
from finite_subset[OF this] show ?thesis unfolding Q_pow_def
apply auto apply blast
by (meson FSet_Lex_Wrapper.exhaust_sel)
qed
lemma pair_automaton_det_lang_sound_complete:
"pair_at_lang \<G> Q = pair_at_lang (map_both ps_ta \<G>) (Q_pow Q (\<Q> (fst \<G>)) (\<Q> (snd \<G>)))" (is "?LS = ?RS")
proof -
{fix s t assume "(s, t) \<in> ?LS"
then obtain p q where
res : "p |\<in>| ta_der (fst \<G>) (term_of_gterm s)"
"q |\<in>| ta_der (snd \<G>) (term_of_gterm t)" "(p, q) |\<in>| Q"
by (auto simp: pair_at_lang_def gta_der_def)
from ps_rules_complete[OF this(1)] ps_rules_complete[OF this(2)] this(3)
have "(s, t) \<in> ?RS" using fPow_iff ps_ta_states'
by (auto simp: pair_at_lang_def gta_der_def Q_pow_fmember)
force}
moreover
{fix s t assume "(s, t) \<in> ?RS" then have "(s, t) \<in> ?LS"
using ps_rules_sound
by (auto simp: pair_at_lang_def gta_der_def ps_ta_def Let_def Q_pow_fmember) blast}
ultimately show ?thesis by auto
qed
lemma pair_automaton_complement_sound_complete:
assumes "partially_completely_defined_on \<A> \<F>" and "partially_completely_defined_on \<B> \<F>"
and "ta_det \<A>" and "ta_det \<B>"
shows "pair_at_lang (\<A>, \<B>) (\<Q> \<A> |\<times>| \<Q> \<B> |-| Q) = gterms (fset \<F>) \<times> gterms (fset \<F>) - pair_at_lang (\<A>, \<B>) Q"
using assms unfolding partially_completely_defined_on_def pair_at_lang_def
apply (auto simp: gta_der_def)
apply (metis ta_detE)
apply fastforce
done
end
diff --git a/thys/Regular_Tree_Relations/RR2_Infinite_Q_infinity.thy b/thys/Regular_Tree_Relations/RR2_Infinite_Q_infinity.thy
--- a/thys/Regular_Tree_Relations/RR2_Infinite_Q_infinity.thy
+++ b/thys/Regular_Tree_Relations/RR2_Infinite_Q_infinity.thy
@@ -1,464 +1,464 @@
theory RR2_Infinite_Q_infinity
imports RR2_Infinite
begin
(* This section constructs an executable membership check for Q infinity,
since Inf_automata is already executable (for all sets Q where checking membership is executable)
*)
lemma if_cong':
"b = c \<Longrightarrow> x = u \<Longrightarrow> y = v \<Longrightarrow> (if b then x else y) = (if c then u else v)"
by auto
(* The reachable terms where eps transitions can only occur after the rule *)
fun ta_der_strict :: "('q,'f) ta \<Rightarrow> ('f,'q) term \<Rightarrow> 'q fset" where
"ta_der_strict \<A> (Var q) = {|q|}"
| "ta_der_strict \<A> (Fun f ts) = {| q' | q' q qs. TA_rule f qs q |\<in>| rules \<A> \<and> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|) \<and>
length qs = length ts \<and> (\<forall> i < length ts. qs ! i |\<in>| ta_der_strict \<A> (ts ! i))|}"
lemma ta_der_strict_Var:
"q |\<in>| ta_der_strict \<A> (Var x) \<longleftrightarrow> x = q"
unfolding ta_der.simps by auto
lemma ta_der_strict_Fun:
"q |\<in>| ta_der_strict \<A> (Fun f ts) \<longleftrightarrow> (\<exists> ps p. TA_rule f ps p |\<in>| (rules \<A>) \<and>
(p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|) \<and> length ps = length ts \<and>
(\<forall> i < length ts. ps ! i |\<in>| ta_der_strict \<A> (ts ! i)))" (is "?Ls \<longleftrightarrow> ?Rs")
unfolding ta_der_strict.simps
by (intro iffI fCollect_memberI finite_Collect_less_eq[OF _ finite_eps[of \<A>]]) auto
declare ta_der_strict.simps[simp del]
lemmas ta_der_strict_simps [simp] = ta_der_strict_Var ta_der_strict_Fun
lemma ta_der_strict_sub_ta_der:
"ta_der_strict \<A> t |\<subseteq>| ta_der \<A> t"
proof (induct t)
case (Fun f ts)
then show ?case
by auto (metis fsubsetD nth_mem)+
qed auto
lemma ta_der_strict_ta_der_eq_on_ground:
assumes"ground t"
shows "ta_der \<A> t = ta_der_strict \<A> t"
proof
{fix q assume "q |\<in>| ta_der \<A> t" then have "q |\<in>| ta_der_strict \<A> t" using assms
proof (induct t arbitrary: q)
case (Fun f ts)
then show ?case apply auto
using nth_mem by blast+
qed auto}
then show "ta_der \<A> t |\<subseteq>| ta_der_strict \<A> t"
by auto
next
show "ta_der_strict \<A> t |\<subseteq>| ta_der \<A> t" using ta_der_strict_sub_ta_der .
qed
lemma ta_der_to_ta_strict:
assumes "q |\<in>| ta_der A C\<langle>Var p\<rangle>" and "ground_ctxt C"
shows "\<exists> q'. (p = q' \<or> (p, q') |\<in>| (eps A)|\<^sup>+|) \<and> q |\<in>| ta_der_strict A C\<langle>Var q'\<rangle>"
using assms
proof (induct C arbitrary: q p)
case (More f ss C ts)
from More(2) obtain qs q' where
r: "TA_rule f qs q' |\<in>| rules A" "length qs = Suc (length ss + length ts)" "q' = q \<or> (q', q) |\<in>| (eps A)|\<^sup>+|" and
rec: "\<forall> i < length qs. qs ! i |\<in>| ta_der A ((ss @ C\<langle>Var p\<rangle> # ts) ! i)"
by auto
from More(1)[of "qs ! length ss" p] More(3) rec r(2) obtain q'' where
mid: "(p = q'' \<or> (p, q'') |\<in>| (eps A)|\<^sup>+|) \<and> qs ! length ss |\<in>| ta_der_strict A C\<langle>Var q''\<rangle>"
by auto (metis length_map less_add_Suc1 nth_append_length)
then have "\<forall> i < length qs. qs ! i |\<in>| ta_der_strict A ((ss @ C\<langle>Var q''\<rangle> # ts) ! i)"
using rec r(2) More(3)
using ta_der_strict_ta_der_eq_on_ground[of _ A]
- by (auto simp: nth_append_Cons all_Suc_conv fmember.rep_eq split:if_splits cong: if_cong')
+ by (auto simp: nth_append_Cons all_Suc_conv fmember_iff_member_fset split:if_splits cong: if_cong')
then show ?case using rec r conjunct1[OF mid]
by (rule_tac x = q'' in exI, auto intro!: exI[of _ q'] exI[of _ qs])
qed auto
fun root_ctxt where
"root_ctxt (More f ss C ts) = f"
| "root_ctxt \<box> = undefined"
lemma root_to_root_ctxt [simp]:
assumes "C \<noteq> \<box>"
shows "fst (the (root C\<langle>t\<rangle>)) \<longleftrightarrow> root_ctxt C"
using assms by (cases C) auto
(* Q_inf section *)
inductive_set Q_inf for \<A> where
trans: "(p, q) \<in> Q_inf \<A> \<Longrightarrow> (q, r) \<in> Q_inf \<A> \<Longrightarrow> (p, r) \<in> Q_inf \<A>"
| rule: "(None, Some f) qs \<rightarrow> q |\<in>| rules \<A> \<Longrightarrow> i < length qs \<Longrightarrow> (qs ! i, q) \<in> Q_inf \<A>"
| eps: "(p, q) \<in> Q_inf \<A> \<Longrightarrow> (q, r) |\<in>| eps \<A> \<Longrightarrow> (p, r) \<in> Q_inf \<A>"
abbreviation "Q_inf_e \<A> \<equiv> {q | p q. (p, p) \<in> Q_inf \<A> \<and> (p, q) \<in> Q_inf \<A>}"
lemma Q_inf_states_ta_states:
assumes "(p, q) \<in> Q_inf \<A>"
shows "p |\<in>| \<Q> \<A>" "q |\<in>| \<Q> \<A>"
using assms by (induct) (auto simp: rule_statesD eps_statesD)
lemma Q_inf_finite:
"finite (Q_inf \<A>)" "finite (Q_inf_e \<A>)"
proof -
have *: "Q_inf \<A> \<subseteq> fset (\<Q> \<A> |\<times>| \<Q> \<A>)" "Q_inf_e \<A> \<subseteq> fset (\<Q> \<A>)"
- by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember.rep_eq)
+ by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember_iff_member_fset)
show "finite (Q_inf \<A>)"
by (intro finite_subset[OF *(1)]) simp
show "finite (Q_inf_e \<A>)"
by (intro finite_subset[OF *(2)]) simp
qed
context
includes fset.lifting
begin
lift_definition fQ_inf :: "('a, 'b option \<times> 'c option) ta \<Rightarrow> ('a \<times> 'a) fset" is Q_inf
by (simp add: Q_inf_finite(1))
lift_definition fQ_inf_e :: "('a, 'b option \<times> 'c option) ta \<Rightarrow> 'a fset" is Q_inf_e
using Q_inf_finite(2) .
end
lemma Q_inf_ta_eps_Q_inf:
assumes "(p, q) \<in> Q_inf \<A>" and "(q, q') |\<in>| (eps \<A>)|\<^sup>+|"
shows "(p, q') \<in> Q_inf \<A>" using assms(2, 1)
by (induct rule: ftrancl_induct) (auto simp add: Q_inf.eps)
lemma lhs_state_rule:
assumes "(p, q) \<in> Q_inf \<A>"
shows "\<exists> f qs r. (None, Some f) qs \<rightarrow> r |\<in>| rules \<A> \<and> p |\<in>| fset_of_list qs"
using assms by induct (force intro: nth_mem)+
lemma Q_inf_reach_state_rule:
assumes "(p, q) \<in> Q_inf \<A>" and "\<Q> \<A> |\<subseteq>| ta_reachable \<A>"
shows "\<exists> ss ts f C. q |\<in>| ta_der \<A> (More (None, Some f) ss C ts)\<langle>Var p\<rangle> \<and> ground_ctxt (More (None, Some f) ss C ts)"
(is "\<exists> ss ts f C. ?P ss ts f C q p")
using assms
proof (induct)
case (trans p q r)
then obtain f1 f2 ss1 ts1 ss2 ts2 C1 C2 where
C: "?P ss1 ts1 f1 C1 q p" "?P ss2 ts2 f2 C2 r q" by blast
then show ?case
apply (rule_tac x = "ss2" in exI, rule_tac x = "ts2" in exI, rule_tac x = "f2" in exI,
rule_tac x = "C2 \<circ>\<^sub>c (More (None, Some f1) ss1 C1 ts1)" in exI)
apply (auto simp del: ctxt_apply_term.simps)
apply (metis Subterm_and_Context.ctxt_ctxt_compose ctxt_compose.simps(2) ta_der_ctxt)
done
next
case (rule f qs q i)
have "\<forall> i < length qs. \<exists> t. qs ! i |\<in>| ta_der \<A> t \<and> ground t"
using rule(1, 2) fset_mp[OF rule(3), of "qs ! i" for i]
by auto (meson fnth_mem rule_statesD(4) ta_reachableE)
then obtain ts where wit: "length ts = length qs"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (ts ! i) \<and> ground (ts ! i)"
using Ex_list_of_length_P[of "length qs" "\<lambda> x i. qs ! i |\<in>| ta_der \<A> x \<and> ground x"] by blast
{fix j assume "j < length qs"
then have "qs ! j |\<in>| ta_der \<A> ((take i ts @ Var (qs ! i) # drop (Suc i) ts) ! j)"
using wit by (cases "j < i") (auto simp: min_def nth_append_Cons)}
then have "\<forall> i < length qs. qs ! i |\<in>| (map (ta_der \<A>) (take i ts @ Var (qs ! i) # drop (Suc i) ts)) ! i"
using wit rule(2) by (auto simp: nth_append_Cons)
then have res: "q |\<in>| ta_der \<A> (Fun (None, Some f) (take i ts @ Var (qs ! i) # drop (Suc i) ts))"
using rule(1, 2) wit by (auto simp: min_def nth_append_Cons intro!: exI[of _ q] exI[of _ qs])
then show ?case using rule(1, 2) wit
apply (rule_tac x = "take i ts" in exI, rule_tac x = "drop (Suc i) ts" in exI)
apply (auto simp: take_map drop_map dest!: in_set_takeD in_set_dropD simp del: ta_der_simps intro!: exI[of _ f] exI[of _ Hole])
apply (metis all_nth_imp_all_set)+
done
next
case (eps p q r)
then show ?case by (meson r_into_rtrancl ta_der_eps)
qed
lemma rule_target_Q_inf:
assumes "(None, Some f) qs \<rightarrow> q' |\<in>| rules \<A>" and "i < length qs"
shows "(qs ! i, q') \<in> Q_inf \<A>" using assms
by (intro rule) auto
lemma rule_target_eps_Q_inf:
assumes "(None, Some f) qs \<rightarrow> q' |\<in>| rules \<A>" "(q', q) |\<in>| (eps \<A>)|\<^sup>+|"
and "i < length qs"
shows "(qs ! i, q) \<in> Q_inf \<A>"
using assms(2, 1, 3) by (induct rule: ftrancl_induct) (auto intro: rule eps)
lemma step_in_Q_inf:
assumes "q |\<in>| ta_der_strict \<A> (map_funs_term (\<lambda>f. (None, Some f)) (Fun f (ss @ Var p # ts)))"
shows "(p, q) \<in> Q_inf \<A>"
using assms rule_target_eps_Q_inf[of f _ _ \<A> q] rule_target_Q_inf[of f _ q \<A>]
by (auto simp: comp_def nth_append_Cons split!: if_splits)
lemma ta_der_Q_inf:
assumes "q |\<in>| ta_der_strict \<A> (map_funs_term (\<lambda>f. (None, Some f)) (C\<langle>Var p\<rangle>))" and "C \<noteq> Hole"
shows "(p, q) \<in> Q_inf \<A>" using assms
proof (induct C arbitrary: q)
case (More f ss C ts)
then show ?case
proof (cases "C = Hole")
case True
then show ?thesis using More(2) by (auto simp: step_in_Q_inf)
next
case False
then obtain q' where q: "q' |\<in>| ta_der_strict \<A> (map_funs_term (\<lambda>f. (None, Some f)) C\<langle>Var p\<rangle>)"
"q |\<in>| ta_der_strict \<A> (map_funs_term (\<lambda>f. (None, Some f)) (Fun f (ss @ Var q' # ts)))"
using More(2) length_map
(* SLOW *)
by (auto simp: comp_def nth_append_Cons split: if_splits cong: if_cong')
(smt nat_neq_iff nth_map ta_der_strict_simps)+
have "(p, q') \<in> Q_inf \<A>" using More(1)[OF q(1) False] .
then show ?thesis using step_in_Q_inf[OF q(2)] by (auto intro: trans)
qed
qed auto
lemma Q_inf_e_infinite_terms_res:
assumes "q \<in> Q_inf_e \<A>" and "\<Q> \<A> |\<subseteq>| ta_reachable \<A>"
shows "infinite {t. q |\<in>| ta_der \<A> (term_of_gterm t) \<and> fst (groot_sym t) = None}"
proof -
let ?P ="\<lambda> u. ground u \<and> q |\<in>| ta_der \<A> u \<and> fst (fst (the (root u))) = None"
have groot[simp]: "fst (fst (the (root (term_of_gterm t)))) = fst (groot_sym t)" for t by (cases t) auto
have [simp]: "C \<noteq> \<box> \<Longrightarrow> fst (fst (the (root C\<langle>t\<rangle>))) = fst (root_ctxt C)" for C t by (cases C) auto
from assms(1) obtain p where cycle: "(p, p) \<in> Q_inf \<A>" "(p, q) \<in> Q_inf \<A>" by auto
from Q_inf_reach_state_rule[OF cycle(1) assms(2)] obtain C where
ctxt: "C \<noteq> \<box>" "ground_ctxt C" and reach: "p |\<in>| ta_der \<A> C\<langle>Var p\<rangle>"
by blast
obtain C2 where
closing_ctxt: "C2 \<noteq> \<box>" "ground_ctxt C2" "fst (root_ctxt C2) = None" and cl_reach: "q |\<in>| ta_der \<A> C2\<langle>Var p\<rangle>"
by (metis (full_types) Q_inf_reach_state_rule[OF cycle(2) assms(2)] ctxt.distinct(1) fst_conv root_ctxt.simps(1))
from assms(2) obtain t where t: "p |\<in>| ta_der \<A> t" and gr_t: "ground t"
by (meson Q_inf_states_ta_states(1) cycle(1) fsubsetD ta_reachableE)
let ?terms = "\<lambda> n. (C ^ Suc n)\<langle>t\<rangle>" let ?S = "{?terms n | n. p |\<in>| ta_der \<A> (?terms n) \<and> ground (?terms n)}"
have "ground (?terms n)" for n using ctxt(2) gr_t by auto
moreover have "p |\<in>| ta_der \<A> (?terms n)" for n using reach t(1)
by (auto simp: ta_der_ctxt) (meson ta_der_ctxt ta_der_ctxt_n_loop)
ultimately have inf: "infinite ?S" using ctxt_comp_n_lower_bound[OF ctxt(1)]
using no_upper_bound_infinite[of _ depth, of ?S] by blast
from infinite_inj_image_infinite[OF this] have inf:"infinite (ctxt_apply_term C2 ` ?S)"
by (smt ctxt_eq inj_on_def)
{fix u assume "u \<in> (ctxt_apply_term C2 ` ?S)"
then have "?P u" unfolding image_Collect using closing_ctxt cl_reach
by (auto simp: ta_der_ctxt)}
from this have inf: "infinite {u. ground u \<and> q |\<in>| ta_der \<A> u \<and> fst (fst (the (root u))) = None}"
by (intro infinite_super[OF _ inf] subsetI) fast
have inf: "infinite (gterm_of_term ` {u. ground u \<and> q |\<in>| ta_der \<A> u \<and> fst (fst (the (root u))) = None})"
by (intro infinite_inj_image_infinite[OF inf] gterm_of_term_inj) auto
show ?thesis
by (intro infinite_super[OF _ inf]) (auto dest: groot_sym_gterm_of_term)
qed
lemma gfun_at_after_hole_pos:
assumes "ghole_pos C \<le>\<^sub>p p"
shows "gfun_at C\<langle>t\<rangle>\<^sub>G p = gfun_at t (p -\<^sub>p ghole_pos C)" using assms
proof (induct C arbitrary: p)
case (GMore f ss C ts) then show ?case
by (cases p) auto
qed auto
lemma pos_diff_0 [simp]: "p -\<^sub>p p = []"
by (auto simp: pos_diff_def)
lemma Max_suffI: "finite A \<Longrightarrow> A = B \<Longrightarrow> Max A = Max B"
by (intro Max_eq_if) auto
lemma nth_args_depth_eqI:
assumes "length ss = length ts"
and "\<And> i. i < length ts \<Longrightarrow> depth (ss ! i) = depth (ts ! i)"
shows "depth (Fun f ss) = depth (Fun g ts)"
proof -
from assms(1, 2) have "depth ` set ss = depth ` set ts"
using nth_map_conv[OF assms(1), of depth depth]
by (simp flip: set_map)
from Max_suffI[OF _ this] show ?thesis using assms(1)
by (cases ss; cases ts) auto
qed
lemma subt_at_ctxt_apply_hole_pos [simp]: "C\<langle>s\<rangle> |_ hole_pos C = s"
by (induct C) auto
lemma ctxt_at_pos_ctxt_apply_hole_poss [simp]: "ctxt_at_pos C\<langle>s\<rangle> (hole_pos C) = C"
by (induct C) auto
abbreviation "map_funs_ctxt f \<equiv> map_ctxt f (\<lambda> x. x)"
lemma map_funs_term_ctxt_apply [simp]:
"map_funs_term f C\<langle>s\<rangle> = (map_funs_ctxt f C)\<langle>map_funs_term f s\<rangle>"
by (induct C) auto
lemma map_funs_term_ctxt_decomp:
assumes "map_funs_term fg t = C\<langle>s\<rangle>"
shows "\<exists> D u. C = map_funs_ctxt fg D \<and> s = map_funs_term fg u \<and> t = D\<langle>u\<rangle>"
using assms
proof (induct C arbitrary: t)
case Hole
show ?case
by (rule exI[of _ Hole], rule exI[of _ t], insert Hole, auto)
next
case (More g bef C aft)
from More(2) obtain f ts where t: "t = Fun f ts" by (cases t, auto)
from More(2)[unfolded t] have f: "fg f = g" and ts: "map (map_funs_term fg) ts = bef @ C\<langle>s\<rangle> # aft" (is "?ts = ?bca") by auto
from ts have "length ?ts = length ?bca" by auto
then have len: "length ts = length ?bca" by auto
note id = ts[unfolded map_nth_eq_conv[OF len], THEN spec, THEN mp]
let ?i = "length bef"
from len have i: "?i < length ts" by auto
from id[of ?i] have "map_funs_term fg (ts ! ?i) = C\<langle>s\<rangle>" by auto
from More(1)[OF this] obtain D u where D: "C = map_funs_ctxt fg D" and
u: "s = map_funs_term fg u" and id: "ts ! ?i = D\<langle>u\<rangle>" by auto
from ts have "take ?i ?ts = take ?i ?bca" by simp
also have "... = bef" by simp
finally have bef: "map (map_funs_term fg) (take ?i ts) = bef" by (simp add: take_map)
from ts have "drop (Suc ?i) ?ts = drop (Suc ?i) ?bca" by simp
also have "... = aft" by simp
finally have aft: "map (map_funs_term fg) (drop (Suc ?i) ts) = aft" by (simp add:drop_map)
let ?bda = "take ?i ts @ D\<langle>u\<rangle> # drop (Suc ?i) ts"
show ?case
proof (rule exI[of _ "More f (take ?i ts) D (drop (Suc ?i) ts)"],
rule exI[of _ u], simp add: u f D bef aft t)
have "ts = take ?i ts @ ts ! ?i # drop (Suc ?i) ts"
by (rule id_take_nth_drop[OF i])
also have "... = ?bda" by (simp add: id)
finally show "ts = ?bda" .
qed
qed
lemma prod_automata_from_none_root_dec:
assumes "gta_lang Q \<A> \<subseteq> {gpair s t| s t. funas_gterm s \<subseteq> \<F> \<and> funas_gterm t \<subseteq> \<F>}"
and "q |\<in>| ta_der \<A> (term_of_gterm t)" and "fst (groot_sym t) = None"
and "\<Q> \<A> |\<subseteq>| ta_reachable \<A>" and "q |\<in>| ta_productive Q \<A>"
shows "\<exists> u. t = gterm_to_None_Some u \<and> funas_gterm u \<subseteq> \<F>"
proof -
have *: "gfun_at t [] = Some (groot_sym t)" by (cases t) auto
from assms(4, 5) obtain C q\<^sub>f where ctxt: "ground_ctxt C" and
fin: "q\<^sub>f |\<in>| ta_der \<A> C\<langle>Var q\<rangle>" "q\<^sub>f |\<in>| Q"
by (auto simp: ta_productive_def'[OF assms(4)])
then obtain s v where gp: "gpair s v = (gctxt_of_ctxt C)\<langle>t\<rangle>\<^sub>G" and
funas: "funas_gterm v \<subseteq> \<F>"
using assms(1, 2) gta_langI[OF fin(2), of \<A> "(gctxt_of_ctxt C)\<langle>t\<rangle>\<^sub>G"]
by (auto simp: ta_der_ctxt ground_gctxt_of_ctxt_apply_gterm)
from gp have mem: "hole_pos C \<in> gposs s \<union> gposs v"
by auto (metis Un_iff ctxt ghole_pos_in_apply gposs_of_gpair ground_hole_pos_to_ghole)
from this have "hole_pos C \<notin> gposs s" using assms(3)
using arg_cong[OF gp, of "\<lambda> t. gfun_at t (hole_pos C)"]
using ground_hole_pos_to_ghole[OF ctxt]
using gfun_at_after_hole_pos[OF position_less_refl, of "gctxt_of_ctxt C"]
by (auto simp: gfun_at_gpair * split: if_splits)
(metis fstI gfun_at_None_ngposs_iff)+
from subst_at_gpair_nt_poss_None_Some[OF _ this, of v] this
have "t = gterm_to_None_Some (gsubt_at v (hole_pos C)) \<and> funas_gterm (gsubt_at v (hole_pos C)) \<subseteq> \<F>"
using funas mem funas_gterm_gsubt_at_subseteq
by (auto simp: gp intro!: exI[of _ "gsubt_at v (hole_pos C)"])
(metis ctxt ground_hole_pos_to_ghole gsubt_at_gctxt_apply_ghole)
then show ?thesis by blast
qed
lemma infinite_set_dec_infinite:
assumes "infinite S" and "\<And> s. s \<in> S \<Longrightarrow> \<exists> t. f t = s \<and> P t"
shows "infinite {t | t s. s \<in> S \<and> f t = s \<and> P t}" (is "infinite ?T")
proof (rule ccontr)
assume ass: "\<not> infinite ?T"
have "S \<subseteq> f ` {x . P x}" using assms(2) by auto
then show False using ass assms(1)
by (auto simp: subset_image_iff)
(smt Ball_Collect finite_imageI image_subset_iff infinite_iff_countable_subset subset_eq)
qed
lemma Q_inf_exec_impl_Q_inf:
assumes "gta_lang Q \<A> \<subseteq> {gpair s t| s t. funas_gterm s \<subseteq> fset \<F> \<and> funas_gterm t \<subseteq> fset \<F>}"
and "\<Q> \<A> |\<subseteq>| ta_reachable \<A>" and "\<Q> \<A> |\<subseteq>| ta_productive Q \<A>"
and "q \<in> Q_inf_e \<A>"
shows "q |\<in>| Q_infty \<A> \<F>"
proof -
let ?S = "{t. q |\<in>| ta_der \<A> (term_of_gterm t) \<and> fst (groot_sym t) = None}"
let ?P = "\<lambda> t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (term_of_gterm (gterm_to_None_Some t))"
let ?F = "(\<lambda>(f, n). ((None, Some f), n)) |`| \<F>"
from Q_inf_e_infinite_terms_res[OF assms(4, 2)] have inf: "infinite ?S" by auto
{fix t assume "t \<in> ?S"
then have "\<exists> u. t = gterm_to_None_Some u \<and> funas_gterm u \<subseteq> fset \<F>"
using prod_automata_from_none_root_dec[OF assms(1)] assms(2, 3)
using fin_mono by fastforce}
then show ?thesis using infinite_set_dec_infinite[OF inf, of gterm_to_None_Some ?P]
by (auto simp: Q_infty_fmember) blast
qed
lemma Q_inf_impl_Q_inf_exec:
assumes "q |\<in>| Q_infty \<A> \<F>"
shows "q \<in> Q_inf_e \<A>"
proof -
let ?t_of_g = "\<lambda> t. term_of_gterm t :: ('b option \<times> 'b option, 'a) term"
let ?t_og_g2 = "\<lambda> t. term_of_gterm t :: ('b, 'a) term"
let ?inf = "(?t_og_g2 :: 'b gterm \<Rightarrow> ('b, 'a) term) ` {t |t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (?t_of_g (gterm_to_None_Some t))}"
obtain n where card_st: "fcard (\<Q> \<A>) < n" by blast
from assms(1) have "infinite {t |t. funas_gterm t \<subseteq> fset \<F> \<and> q |\<in>| ta_der \<A> (?t_of_g (gterm_to_None_Some t))}"
unfolding Q_infty_def by blast
from infinite_inj_image_infinite[OF this, of "?t_og_g2"] have inf: "infinite ?inf" using inj_term_of_gterm by blast
{fix s assume "s \<in> ?inf" then have "ground s" "funas_term s \<subseteq> fset \<F>" by (auto simp: funas_term_of_gterm_conv subsetD)}
from infinte_no_depth_limit[OF inf, of "fset \<F>"] this obtain u where
funas: "funas_gterm u \<subseteq> fset \<F>" and card_d: "n < depth (?t_og_g2 u)" and reach: "q |\<in>| ta_der \<A> (?t_of_g (gterm_to_None_Some u))"
by auto blast
have "depth (?t_og_g2 u) = depth (?t_of_g (gterm_to_None_Some u))"
proof (induct u)
case (GFun f ts) then show ?case
by (auto simp: comp_def intro: nth_args_depth_eqI)
qed
from this pigeonhole_tree_automata[OF _ reach] card_st card_d obtain C2 C s v p where
ctxt: "C2 \<noteq> \<box>" "C\<langle>s\<rangle> = term_of_gterm (gterm_to_None_Some u)" "C2\<langle>v\<rangle> = s" and
loop: "p |\<in>| ta_der \<A> v \<and> p |\<in>| ta_der \<A> C2\<langle>Var p\<rangle> \<and> q |\<in>| ta_der \<A> C\<langle>Var p\<rangle>"
by auto
from ctxt have gr: "ground_ctxt C2" "ground_ctxt C" by auto (metis ground_ctxt_apply ground_term_of_gterm)+
from ta_der_to_ta_strict[OF _ gr(1)] loop obtain q' where
to_strict: "(p = q' \<or> (p, q') |\<in>| (eps \<A>)|\<^sup>+|) \<and> p |\<in>| ta_der_strict \<A> C2\<langle>Var q'\<rangle>" by fastforce
have *: "\<exists> C. C2 = map_funs_ctxt lift_None_Some C \<and> C \<noteq> \<box>" using ctxt(1, 2)
by (auto simp flip: ctxt(3)) (smt ctxt.simps(8) map_funs_term_ctxt_decomp map_term_of_gterm)
then have q_p: "(q', p) \<in> Q_inf \<A>" using to_strict ta_der_Q_inf[of p \<A> _ q'] ctxt
by auto
then have cycle: "(q', q') \<in> Q_inf \<A>" using to_strict by (auto intro: Q_inf_ta_eps_Q_inf)
show ?thesis
proof (cases "C = \<box>")
case True then show ?thesis
using cycle q_p loop by (auto intro: Q_inf_ta_eps_Q_inf)
next
case False
obtain q'' where r: "p = q'' \<or> (p, q'') |\<in>| (eps \<A>)|\<^sup>+|" "q |\<in>| ta_der_strict \<A> C\<langle>Var q''\<rangle>"
using ta_der_to_ta_strict[OF conjunct2[OF conjunct2[OF loop]] gr(2)] by auto
then have "(q'', q) \<in> Q_inf \<A>" using ta_der_Q_inf[of q \<A> _ q''] ctxt False
by auto (smt (z3) ctxt.simps(8) map_funs_term_ctxt_decomp map_term_of_gterm)+
then show ?thesis using r(1) cycle q_p
by (auto simp: Q_inf_ta_eps_Q_inf intro!: exI[of _ q'])
(meson Q_inf.trans Q_inf_ta_eps_Q_inf)+
qed
qed
lemma Q_infty_fQ_inf_e_conv:
assumes "gta_lang Q \<A> \<subseteq> {gpair s t| s t. funas_gterm s \<subseteq> fset \<F> \<and> funas_gterm t \<subseteq> fset \<F>}"
and "\<Q> \<A> |\<subseteq>| ta_reachable \<A>" and "\<Q> \<A> |\<subseteq>| ta_productive Q \<A>"
shows "Q_infty \<A> \<F> = fQ_inf_e \<A>"
using Q_inf_impl_Q_inf_exec Q_inf_exec_impl_Q_inf[OF assms]
- by (auto simp: fQ_inf_e.rep_eq fmember.rep_eq) fastforce
+ by (auto simp: fQ_inf_e.rep_eq fmember_iff_member_fset) fastforce
definition Inf_reg_impl where
"Inf_reg_impl R = Inf_reg R (fQ_inf_e (ta R))"
lemma Inf_reg_impl_sound:
assumes "\<L> \<A> \<subseteq> {gpair s t| s t. funas_gterm s \<subseteq> fset \<F> \<and> funas_gterm t \<subseteq> fset \<F>}"
and "\<Q>\<^sub>r \<A> |\<subseteq>| ta_reachable (ta \<A>)" and "\<Q>\<^sub>r \<A> |\<subseteq>| ta_productive (fin \<A>) (ta \<A>)"
shows "\<L> (Inf_reg_impl \<A>) = \<L> (Inf_reg \<A> (Q_infty (ta \<A>) \<F>))"
using Q_infty_fQ_inf_e_conv[of "fin \<A>" "ta \<A>" \<F>] assms[unfolded \<L>_def]
by (simp add: Inf_reg_impl_def)
end
diff --git a/thys/Regular_Tree_Relations/RRn_Automata.thy b/thys/Regular_Tree_Relations/RRn_Automata.thy
--- a/thys/Regular_Tree_Relations/RRn_Automata.thy
+++ b/thys/Regular_Tree_Relations/RRn_Automata.thy
@@ -1,1536 +1,1536 @@
theory RRn_Automata
imports Tree_Automata_Complement Ground_Ctxt
begin
section \<open>Regular relations\<close>
subsection \<open>Encoding pairs of terms\<close>
text \<open>The encoding of two terms $s$ and $t$ is given by its tree domain, which is the union of the
domains of $s$ and $t$, and the labels, which arise from looking up each position in $s$ and $t$,
respectively.\<close>
definition gpair :: "'f gterm \<Rightarrow> 'g gterm \<Rightarrow> ('f option \<times> 'g option) gterm" where
"gpair s t = glabel (\<lambda>p. (gfun_at s p, gfun_at t p)) (gunion (gdomain s) (gdomain t))"
text \<open>We provide an efficient implementation of gpair.\<close>
definition zip_fill :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a option \<times> 'b option) list" where
"zip_fill xs ys = zip (map Some xs @ replicate (length ys - length xs) None)
(map Some ys @ replicate (length xs - length ys) None)"
lemma zip_fill_code [code]:
"zip_fill xs [] = map (\<lambda>x. (Some x, None)) xs"
"zip_fill [] ys = map (\<lambda>y. (None, Some y)) ys"
"zip_fill (x # xs) (y # ys) = (Some x, Some y) # zip_fill xs ys"
subgoal by (induct xs) (auto simp: zip_fill_def)
subgoal by (induct ys) (auto simp: zip_fill_def)
subgoal by (auto simp: zip_fill_def)
done
lemma length_zip_fill [simp]:
"length (zip_fill xs ys) = max (length xs) (length ys)"
by (auto simp: zip_fill_def)
lemma nth_zip_fill:
assumes "i < max (length xs) (length ys)"
shows "zip_fill xs ys ! i = (if i < length xs then Some (xs ! i) else None, if i < length ys then Some (ys ! i) else None)"
using assms by (auto simp: zip_fill_def nth_append)
fun gpair_impl :: "'f gterm option \<Rightarrow> 'g gterm option \<Rightarrow> ('f option \<times> 'g option) gterm" where
"gpair_impl (Some s) (Some t) = gpair s t"
| "gpair_impl (Some s) None = map_gterm (\<lambda>f. (Some f, None)) s"
| "gpair_impl None (Some t) = map_gterm (\<lambda>f. (None, Some f)) t"
| "gpair_impl None None = GFun (None, None) []"
declare gpair_impl.simps(2-4)[code]
lemma gpair_impl_code [simp, code]:
"gpair_impl (Some s) (Some t) =
(case s of GFun f ss \<Rightarrow> case t of GFun g ts \<Rightarrow>
GFun (Some f, Some g) (map (\<lambda>(s, t). gpair_impl s t) (zip_fill ss ts)))"
proof (induct "gdomain s" "gdomain t" arbitrary: s t rule: gunion.induct)
case (1 f ss g ts)
obtain f' ss' where [simp]: "s = GFun f' ss'" by (cases s)
obtain g' ts' where [simp]: "t = GFun g' ts'" by (cases t)
show ?case using 1(2,3) 1(1)[of i "ss' ! i" "ts' ! i" for i]
by (auto simp: gpair_def comp_def nth_zip_fill intro: glabel_map_gterm_conv[unfolded comp_def]
intro!: nth_equalityI)
qed
lemma gpair_code [code]:
"gpair s t = gpair_impl (Some s) (Some t)"
by simp
(* export_code gpair in Haskell *)
declare gpair_impl.simps(1)[simp del]
text \<open>We can easily prove some basic properties. I believe that proving them by induction with a
definition along the lines of @{const gpair_impl} would be very cumbersome.\<close>
lemma gpair_swap:
"map_gterm prod.swap (gpair s t) = gpair t s"
by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gpair_def)
lemma gpair_assoc:
defines "f \<equiv> \<lambda>(f, gh). (f, gh \<bind> fst, gh \<bind> snd)"
defines "g \<equiv> \<lambda>(fg, h). (fg \<bind> fst, fg \<bind> snd, h)"
shows "map_gterm f (gpair s (gpair t u)) = map_gterm g (gpair (gpair s t) u)"
by (intro eq_gterm_by_gposs_gfun_at) (auto simp: gpair_def f_def g_def)
subsection \<open>Decoding of pairs\<close>
fun gcollapse :: "'f option gterm \<Rightarrow> 'f gterm option" where
"gcollapse (GFun None _) = None"
| "gcollapse (GFun (Some f) ts) = Some (GFun f (map the (filter (\<lambda>t. \<not> Option.is_none t) (map gcollapse ts))))"
lemma gcollapse_groot_None [simp]:
"groot_sym t = None \<Longrightarrow> gcollapse t = None"
"fst (groot t) = None \<Longrightarrow> gcollapse t = None"
by (cases t, simp)+
definition gfst :: "('f option \<times> 'g option) gterm \<Rightarrow> 'f gterm" where
"gfst = the \<circ> gcollapse \<circ> map_gterm fst"
definition gsnd :: "('f option \<times> 'g option) gterm \<Rightarrow> 'g gterm" where
"gsnd = the \<circ> gcollapse \<circ> map_gterm snd"
lemma filter_less_upt:
"[i\<leftarrow>[i..<m] . i < n] = [i..<min n m]"
proof (cases "i \<le> m")
case True then show ?thesis
proof (induct rule: inc_induct)
case (step n) then show ?case by (auto simp: upt_rec[of n])
qed simp
qed simp
lemma gcollapse_aux:
assumes "gposs s = {p. p \<in> gposs t \<and> gfun_at t p \<noteq> Some None}"
shows "gposs (the (gcollapse t)) = gposs s"
"\<And>p. p \<in> gposs s \<Longrightarrow> gfun_at (the (gcollapse t)) p = (gfun_at t p \<bind> id)"
proof (goal_cases)
define s' t' where "s' \<equiv> gdomain s" and "t' \<equiv> gdomain t"
have *: "gposs (the (gcollapse t)) = gposs s \<and>
(\<forall>p. p \<in> gposs s \<longrightarrow> gfun_at (the (gcollapse t)) p = (gfun_at t p \<bind> id))"
using assms s'_def t'_def
proof (induct s' t' arbitrary: s t rule: gunion.induct)
case (1 f' ss' g' ts')
obtain f ss where s [simp]: "s = GFun f ss" by (cases s)
obtain g ts where t [simp]: "t = GFun (Some g) ts"
using arg_cong[OF 1(2), of "\<lambda>P. [] \<in> P"] by (cases t) auto
have *: "i < length ts \<Longrightarrow> \<not> Option.is_none (gcollapse (ts ! i)) \<longleftrightarrow> i < length ss" for i
using arg_cong[OF 1(2), of "\<lambda>P. [i] \<in> P"] by (cases "ts ! i") auto
have l: "length ss \<le> length ts"
using arg_cong[OF 1(2), of "\<lambda>P. [length ss-1] \<in> P"] by auto
have [simp]: "[t\<leftarrow>map gcollapse ts . \<not> Option.is_none t] = take (length ss) (map gcollapse ts)"
by (subst (2) map_nth[symmetric]) (auto simp add: * filter_map comp_def filter_less_upt
cong: filter_cong[OF refl, of "[0..<length ts]", unfolded set_upt atLeastLessThan_iff]
intro!: nth_equalityI)
have [simp]: "i < length ss \<Longrightarrow> gposs (ss ! i) = gposs (the (gcollapse (ts ! i)))" for i
using conjunct1[OF 1(1), of i "ss ! i" "ts ! i"] l arg_cong[OF 1(2), of "\<lambda>P. {p. i # p \<in> P}"]
1(3,4) by simp
show ?case
proof (intro conjI allI, goal_cases A B)
case A show ?case using l by (auto simp: comp_def split: if_splits)
next
case (B p) show ?case
proof (cases p)
case (Cons i q) then show ?thesis using arg_cong[OF 1(2), of "\<lambda>P. {p. i # p \<in> P}"]
spec[OF conjunct2[OF 1(1)], of i "ss ! i" "ts ! i" q] 1(3,4) by auto
qed auto
qed
qed
{ case 1 then show ?case using * by blast
next
case 2 then show ?case using * by blast }
qed
lemma gfst_gpair:
"gfst (gpair s t) = s"
proof -
have *: "gposs s = {p \<in> gposs (map_gterm fst (gpair s t)). gfun_at (map_gterm fst (gpair s t)) p \<noteq> Some None}"
using gfun_at_nongposs
by (fastforce simp: gpair_def elim: gfun_at_possE)
show ?thesis unfolding gfst_def comp_def using gcollapse_aux[OF *]
by (auto intro!: eq_gterm_by_gposs_gfun_at simp: gpair_def)
qed
lemma gsnd_gpair:
"gsnd (gpair s t) = t"
using gfst_gpair[of t s] gpair_swap[of t s, symmetric]
by (simp add: gfst_def gsnd_def gpair_def gterm.map_comp comp_def)
lemma gpair_impl_None_Inv:
"map_gterm (the \<circ> snd) (gpair_impl None (Some t)) = t"
by (simp add: gterm.map_ident gterm.map_comp comp_def)
subsection \<open>Contexts to gpair\<close>
lemma gpair_context1:
assumes "length ts = length us"
shows "gpair (GFun f ts) (GFun f us) = GFun (Some f, Some f) (map (case_prod gpair) (zip ts us))"
using assms unfolding gpair_code by (auto intro!: nth_equalityI simp: zip_fill_def)
lemma gpair_context2:
assumes "\<And> i. i < length ts \<Longrightarrow> ts ! i = gpair (ss ! i) (us ! i)"
and "length ss = length ts" and "length us = length ts"
shows "GFun (Some f, Some h) ts = gpair (GFun f ss) (GFun h us)"
using assms unfolding gpair_code gpair_impl_code
by (auto simp: zip_fill_def intro!: nth_equalityI)
lemma map_funs_term_some_gpair:
shows "gpair t t = map_gterm (\<lambda>f. (Some f, Some f)) t"
proof (induct t)
case (GFun f ts)
then show ?case by (auto intro!: gpair_context2[symmetric])
qed
lemma gpair_inject [simp]:
"gpair s t = gpair s' t' \<longleftrightarrow> s = s' \<and> t = t'"
by (metis gfst_gpair gsnd_gpair)
abbreviation gterm_to_None_Some :: "'f gterm \<Rightarrow> ('f option \<times> 'f option) gterm" where
"gterm_to_None_Some t \<equiv> map_gterm (\<lambda>f. (None, Some f)) t"
abbreviation "gterm_to_Some_None t \<equiv> map_gterm (\<lambda>f. (Some f, None)) t"
lemma inj_gterm_to_None_Some: "inj gterm_to_None_Some"
by (meson Pair_inject gterm.inj_map inj_onI option.inject)
lemma zip_fill1:
assumes "length ss < length ts"
shows "zip_fill ss ts = zip (map Some ss) (map Some (take (length ss) ts)) @
map (\<lambda> x. (None, Some x)) (drop (length ss) ts)"
using assms by (auto simp: zip_fill_def list_eq_iff_nth_eq nth_append simp add: min.absorb2)
lemma zip_fill2:
assumes "length ts < length ss"
shows "zip_fill ss ts = zip (map Some (take (length ts) ss)) (map Some ts) @
map (\<lambda> x. (Some x, None)) (drop (length ts) ss)"
using assms by (auto simp: zip_fill_def list_eq_iff_nth_eq nth_append simp add: min.absorb2)
(* GPair position lemmas *)
(* MOVE me*)
lemma not_gposs_append [simp]:
assumes "p \<notin> gposs t"
shows "p @ q \<in> gposs t = False" using assms poss_gposs_conv
using poss_append_poss by blast
(*end Move *)
lemma gfun_at_gpair:
"gfun_at (gpair s t) p = (if p \<in> gposs s then (if p \<in> gposs t
then Some (gfun_at s p, gfun_at t p)
else Some (gfun_at s p, None)) else
(if p \<in> gposs t then Some (None, gfun_at t p) else None))"
using gfun_at_glabel by (auto simp: gpair_def)
lemma gposs_of_gpair [simp]:
shows "gposs (gpair s t) = gposs s \<union> gposs t"
by (auto simp: gpair_def)
lemma poss_to_gpair_poss:
"p \<in> gposs s \<Longrightarrow> p \<in> gposs (gpair s t)"
"p \<in> gposs t \<Longrightarrow> p \<in> gposs (gpair s t)"
by auto
lemma gsubt_at_gpair_poss:
assumes "p \<in> gposs s" and "p \<in> gposs t"
shows "gsubt_at (gpair s t) p = gpair (gsubt_at s p) (gsubt_at t p)" using assms
by (auto simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)
lemma subst_at_gpair_nt_poss_Some_None:
assumes "p \<in> gposs s" and "p \<notin> gposs t"
shows "gsubt_at (gpair s t) p = gterm_to_Some_None (gsubt_at s p)" using assms gfun_at_poss
by (force simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)
lemma subst_at_gpair_nt_poss_None_Some:
assumes "p \<in> gposs t" and "p \<notin> gposs s"
shows "gsubt_at (gpair s t) p = gterm_to_None_Some (gsubt_at t p)" using assms gfun_at_poss
by (force simp: gunion_gsubt_at_poss gfun_at_gpair intro!: eq_gterm_by_gposs_gfun_at)
lemma gpair_ctxt_decomposition:
fixes C defines "p \<equiv> ghole_pos C"
assumes "p \<notin> gposs s" and "gpair s t = C\<langle>gterm_to_None_Some u\<rangle>\<^sub>G"
shows "gpair s (gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G = C\<langle>gterm_to_None_Some v\<rangle>\<^sub>G"
using assms(2-)
proof -
note p[simp] = assms(1)
have pt: "p \<in> gposs t" and pc: "p \<in> gposs C\<langle>gterm_to_None_Some v\<rangle>\<^sub>G"
and pu: "p \<in> gposs C\<langle>gterm_to_None_Some u\<rangle>\<^sub>G"
using arg_cong[OF assms(3), of gposs] assms(2) ghole_pos_in_apply
by auto
have *: "gctxt_at_pos (gpair s (gctxt_at_pos t (ghole_pos C))\<langle>v\<rangle>\<^sub>G) (ghole_pos C) = gctxt_at_pos (gpair s t) (ghole_pos C)"
using assms(2) pt
by (intro eq_gctxt_at_pos)
(auto simp: gposs_gctxt_at_pos gunion_gsubt_at_poss gfun_at_gpair gfun_at_gctxt_at_pos_not_after)
have "gsubt_at (gpair s (gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G) p = gsubt_at C\<langle>gterm_to_None_Some v\<rangle>\<^sub>G p"
using pt assms(2) subst_at_gpair_nt_poss_None_Some[OF _ assms(2), of "(gctxt_at_pos t p)\<langle>v\<rangle>\<^sub>G"]
using ghole_pos_gctxt_at_pos
by (simp add: ghole_pos_in_apply)
then show ?thesis using assms(2) ghole_pos_gctxt_at_pos
using gsubst_at_gctxt_at_eq_gtermD[OF assms(3) pu]
by (intro gsubst_at_gctxt_at_eq_gtermI[OF _ pc])
(auto simp: ghole_pos_in_apply * gposs_gctxt_at_pos[OF pt, unfolded p])
qed
lemma groot_gpair [simp]:
"fst (groot (gpair s t)) = (Some (fst (groot s)), Some (fst (groot t)))"
by (cases s; cases t) (auto simp add: gpair_code)
lemma ground_ctxt_adapt_ground [intro]:
assumes "ground_ctxt C"
shows "ground_ctxt (adapt_vars_ctxt C)"
using assms by (induct C) auto
lemma adapt_vars_ctxt2 :
assumes "ground_ctxt C"
shows "adapt_vars_ctxt (adapt_vars_ctxt C) = adapt_vars_ctxt C" using assms
by (induct C) (auto simp: adapt_vars2)
subsection \<open>Encoding of lists of terms\<close>
definition gencode :: "'f gterm list \<Rightarrow> 'f option list gterm" where
"gencode ts = glabel (\<lambda>p. map (\<lambda>t. gfun_at t p) ts) (gunions (map gdomain ts))"
definition gdecode_nth :: "'f option list gterm \<Rightarrow> nat \<Rightarrow> 'f gterm" where
"gdecode_nth t i = the (gcollapse (map_gterm (\<lambda>f. f ! i) t))"
lemma gdecode_nth_gencode:
assumes "i < length ts"
shows "gdecode_nth (gencode ts) i = ts ! i"
proof -
have *: "gposs (ts ! i) = {p \<in> gposs (map_gterm (\<lambda>f. f ! i) (gencode ts)).
gfun_at (map_gterm (\<lambda>f. f ! i) (gencode ts)) p \<noteq> Some None}"
using assms
by (auto simp: gencode_def elim: gfun_at_possE dest: gfun_at_poss_gpossD) (force simp: fun_at_def' split: if_splits)
show ?thesis unfolding gdecode_nth_def comp_def using assms gcollapse_aux[OF *]
by (auto intro!: eq_gterm_by_gposs_gfun_at simp: gencode_def)
(metis (no_types) gposs_map_gterm length_map list.set_map map_nth_eq_conv nth_mem)
qed
definition gdecode :: "'f option list gterm \<Rightarrow> 'f gterm list" where
"gdecode t = (case t of GFun f ts \<Rightarrow> map (\<lambda>i. gdecode_nth t i) [0..<length f])"
lemma gdecode_gencode:
"gdecode (gencode ts) = ts"
proof (cases "gencode ts")
case (GFun f ts')
have "length f = length ts" using arg_cong[OF GFun, of "\<lambda>t. gfun_at t []"]
by (auto simp: gencode_def)
then show ?thesis using gdecode_nth_gencode[of _ ts]
by (auto intro!: nth_equalityI simp: gdecode_def GFun)
qed
definition gencode_impl :: "'f gterm option list \<Rightarrow> 'f option list gterm" where
"gencode_impl ts = glabel (\<lambda>p. map (\<lambda>t. t \<bind> (\<lambda>t. gfun_at t p)) ts) (gunions (map (case_option (GFun () []) gdomain) ts))"
lemma gencode_code [code]:
"gencode ts = gencode_impl (map Some ts)"
by (auto simp: gencode_def gencode_impl_def comp_def)
lemma gencode_singleton:
"gencode [t] = map_gterm (\<lambda>f. [Some f]) t"
using glabel_map_gterm_conv[unfolded comp_def, of "\<lambda>t. [t]" t]
by (simp add: gunions_def gencode_def)
lemma gencode_pair:
"gencode [t, u] = map_gterm (\<lambda>(f, g). [f, g]) (gpair t u)"
by (simp add: gunions_def gencode_def gpair_def map_gterm_glabel comp_def)
subsection \<open>RRn relations\<close>
definition RR1_spec where
"RR1_spec A T \<longleftrightarrow> \<L> A = T"
definition RR2_spec where
"RR2_spec A T \<longleftrightarrow> \<L> A = {gpair t u |t u. (t, u) \<in> T}"
definition RRn_spec where
"RRn_spec n A R \<longleftrightarrow> \<L> A = gencode ` R \<and> (\<forall>ts \<in> R. length ts = n)"
lemma RR1_to_RRn_spec:
assumes "RR1_spec A T"
shows "RRn_spec 1 (fmap_funs_reg (\<lambda>f. [Some f]) A) ((\<lambda>t. [t]) ` T)"
proof -
have [simp]: "inj_on (\<lambda>f. [Some f]) X" for X by (auto simp: inj_on_def)
show ?thesis using assms
by (auto simp: RR1_spec_def RRn_spec_def fmap_funs_\<L> image_comp comp_def gencode_singleton)
qed
lemma RR2_to_RRn_spec:
assumes "RR2_spec A T"
shows "RRn_spec 2 (fmap_funs_reg (\<lambda>(f, g). [f, g]) A) ((\<lambda>(t, u). [t, u]) ` T)"
proof -
have [simp]: "inj_on (\<lambda>(f, g). [f, g]) X" for X by (auto simp: inj_on_def)
show ?thesis using assms
by (auto simp: RR2_spec_def RRn_spec_def fmap_funs_\<L> image_comp comp_def prod.case_distrib gencode_pair)
qed
lemma RRn_to_RR2_spec:
assumes "RRn_spec 2 A T"
shows "RR2_spec (fmap_funs_reg (\<lambda> f. (f ! 0 , f ! 1)) A) ((\<lambda> f. (f ! 0, f ! 1)) ` T)" (is "RR2_spec ?A ?T")
proof -
{fix xs assume "xs \<in> T" then have "length xs = 2" using assms by (auto simp: RRn_spec_def)
then obtain t u where *: "xs = [t, u]"
by (metis (no_types, lifting) One_nat_def Suc_1 length_0_conv length_Suc_conv)
have **: "(\<lambda>f. (f ! 0, f ! Suc 0)) \<circ> (\<lambda>(f, g). [f, g]) = id" by auto
have "map_gterm (\<lambda>f. (f ! 0, f ! Suc 0)) (gencode xs) = gpair t u"
unfolding * gencode_pair gterm.map_comp ** gterm.map_id ..
then have "\<exists> t u. xs = [t, u] \<and> map_gterm (\<lambda>f. (f ! 0, f ! Suc 0)) (gencode xs) = gpair t u"
using * by blast}
then show ?thesis using assms
by (force simp: RR2_spec_def RRn_spec_def fmap_funs_\<L> image_comp comp_def prod.case_distrib gencode_pair image_iff Bex_def)
qed
lemma relabel_RR1_spec [simp]:
"RR1_spec (relabel_reg A) T \<longleftrightarrow> RR1_spec A T"
by (simp add: RR1_spec_def)
lemma relabel_RR2_spec [simp]:
"RR2_spec (relabel_reg A) T \<longleftrightarrow> RR2_spec A T"
by (simp add: RR2_spec_def)
lemma relabel_RRn_spec [simp]:
"RRn_spec n (relabel_reg A) T \<longleftrightarrow> RRn_spec n A T"
by (simp add: RRn_spec_def)
lemma trim_RR1_spec [simp]:
"RR1_spec (trim_reg A) T \<longleftrightarrow> RR1_spec A T"
by (simp add: RR1_spec_def \<L>_trim)
lemma trim_RR2_spec [simp]:
"RR2_spec (trim_reg A) T \<longleftrightarrow> RR2_spec A T"
by (simp add: RR2_spec_def \<L>_trim)
lemma trim_RRn_spec [simp]:
"RRn_spec n (trim_reg A) T \<longleftrightarrow> RRn_spec n A T"
by (simp add: RRn_spec_def \<L>_trim)
lemma swap_RR2_spec:
assumes "RR2_spec A R"
shows "RR2_spec (fmap_funs_reg prod.swap A) (prod.swap ` R)" using assms
by (force simp add: RR2_spec_def fmap_funs_\<L> gpair_swap image_iff)
subsection \<open>Nullary automata\<close>
lemma false_RRn_spec:
"RRn_spec n empty_reg {}"
by (auto simp: RRn_spec_def \<L>_epmty)
lemma true_RR0_spec:
"RRn_spec 0 (Reg {|q|} (TA {|[] [] \<rightarrow> q|} {||})) {[]}"
by (auto simp: RRn_spec_def \<L>_def const_ta_lang gencode_def gunions_def)
subsection \<open>Pairing RR1 languages\<close>
text \<open>cf. @{const "gpair"}.\<close>
abbreviation "lift_Some_None s \<equiv> (Some s, None)"
abbreviation "lift_None_Some s \<equiv> (None, Some s)"
abbreviation "pair_eps A B \<equiv> (\<lambda> (p, q). ((Some (fst p), q), (Some (snd p), q))) |`| (eps A |\<times>| finsert None (Some |`| \<Q> B))"
abbreviation "pair_rule \<equiv> (\<lambda> (ra, rb). TA_rule (Some (r_root ra), Some (r_root rb)) (zip_fill (r_lhs_states ra) (r_lhs_states rb)) (Some (r_rhs ra), Some (r_rhs rb)))"
lemma lift_Some_None_pord_swap [simp]:
"prod.swap \<circ> lift_Some_None = lift_None_Some"
"prod.swap \<circ> lift_None_Some = lift_Some_None"
by auto
lemma eps_to_pair_eps_Some_None:
"(p, q) |\<in>| eps \<A> \<Longrightarrow> (lift_Some_None p, lift_Some_None q) |\<in>| pair_eps \<A> \<B>"
by force
definition pair_automaton :: "('p, 'f) ta \<Rightarrow> ('q, 'g) ta \<Rightarrow> ('p option \<times> 'q option, 'f option \<times> 'g option) ta" where
"pair_automaton A B = TA
(map_ta_rule lift_Some_None lift_Some_None |`| rules A |\<union>|
map_ta_rule lift_None_Some lift_None_Some |`| rules B |\<union>|
pair_rule |`| (rules A |\<times>| rules B))
(pair_eps A B |\<union>| map_both prod.swap |`| (pair_eps B A))"
definition pair_automaton_reg where
"pair_automaton_reg R L = Reg (Some |`| fin R |\<times>| Some |`| fin L) (pair_automaton (ta R) (ta L))"
lemma pair_automaton_eps_simps:
"(lift_Some_None p, p') |\<in>| eps (pair_automaton A B) \<longleftrightarrow> (lift_Some_None p, p') |\<in>| pair_eps A B"
"(q , lift_Some_None q') |\<in>| eps (pair_automaton A B) \<longleftrightarrow> (q , lift_Some_None q') |\<in>| pair_eps A B"
by (auto simp: pair_automaton_def eps_to_pair_eps_Some_None)
lemma pair_automaton_eps_Some_SomeD:
"((Some p, Some p'), r) |\<in>| eps (pair_automaton A B) \<Longrightarrow> fst r \<noteq> None \<and> snd r \<noteq> None \<and> (Some p = fst r \<or> Some p' = snd r) \<and>
(Some p \<noteq> fst r \<longrightarrow> (p, the (fst r)) |\<in>| (eps A)) \<and> (Some p' \<noteq> snd r \<longrightarrow> (p', the (snd r)) |\<in>| (eps B))"
by (auto simp: pair_automaton_def)
lemma pair_automaton_eps_Some_SomeD2:
"(r, (Some p, Some p')) |\<in>| eps (pair_automaton A B) \<Longrightarrow> fst r \<noteq> None \<and> snd r \<noteq> None \<and> (fst r = Some p \<or> snd r = Some p') \<and>
(fst r \<noteq> Some p \<longrightarrow> (the (fst r), p) |\<in>| (eps A)) \<and> (snd r \<noteq> Some p' \<longrightarrow> (the (snd r), p') |\<in>| (eps B))"
by (auto simp: pair_automaton_def)
lemma pair_eps_Some_None:
fixes p q q'
defines "l \<equiv> (p, q)" and "r \<equiv> lift_Some_None q'"
assumes "(l, r) |\<in>| (eps (pair_automaton A B))|\<^sup>+|"
shows "q = None \<and> p \<noteq> None \<and> (the p, q') |\<in>| (eps A)|\<^sup>+|" using assms(3, 1, 2)
proof (induct arbitrary: q' q rule: ftrancl_induct)
case (Step b)
then show ?case unfolding pair_automaton_eps_simps
by (auto simp: pair_automaton_eps_simps)
(meson not_ftrancl_into)
qed (auto simp: pair_automaton_def)
lemma pair_eps_Some_Some:
fixes p q
defines "l \<equiv> (Some p, Some q)"
assumes "(l, r) |\<in>| (eps (pair_automaton A B))|\<^sup>+|"
shows "fst r \<noteq> None \<and> snd r \<noteq> None \<and>
(fst l \<noteq> fst r \<longrightarrow> (p, the (fst r)) |\<in>| (eps A)|\<^sup>+|) \<and>
(snd l \<noteq> snd r \<longrightarrow> (q, the (snd r)) |\<in>| (eps B)|\<^sup>+|)"
using assms(2, 1)
proof (induct arbitrary: p q rule: ftrancl_induct)
case (Step b c)
then obtain r r' where *: "b = (Some r, Some r')" by (cases b) auto
show ?case using Step(2)
using pair_automaton_eps_Some_SomeD[OF Step(3)[unfolded *]]
by (auto simp: *) (meson not_ftrancl_into)+
qed (auto simp: pair_automaton_def)
lemma pair_eps_Some_Some2:
fixes p q
defines "r \<equiv> (Some p, Some q)"
assumes "(l, r) |\<in>| (eps (pair_automaton A B))|\<^sup>+|"
shows "fst l \<noteq> None \<and> snd l \<noteq> None \<and>
(fst l \<noteq> fst r \<longrightarrow> (the (fst l), p) |\<in>| (eps A)|\<^sup>+|) \<and>
(snd l \<noteq> snd r \<longrightarrow> (the (snd l), q) |\<in>| (eps B)|\<^sup>+|)"
using assms(2, 1)
proof (induct arbitrary: p q rule: ftrancl_induct)
case (Step b c)
from pair_automaton_eps_Some_SomeD2[OF Step(3)]
obtain r r' where *: "c = (Some r, Some r')" by (cases c) auto
from Step(2)[OF this] show ?case
using pair_automaton_eps_Some_SomeD[OF Step(3)[unfolded *]]
by (auto simp: *) (meson not_ftrancl_into)+
qed (auto simp: pair_automaton_def)
lemma map_pair_automaton:
"pair_automaton (fmap_funs_ta f A) (fmap_funs_ta g B) =
fmap_funs_ta (\<lambda>(a, b). (map_option f a, map_option g b)) (pair_automaton A B)" (is "?Ls = ?Rs")
proof -
let ?ls = "pair_rule \<circ> map_prod (map_ta_rule id f) (map_ta_rule id g)"
let ?rs = "map_ta_rule id (\<lambda>(a, b). (map_option f a, map_option g b)) \<circ> pair_rule"
have *: "(\<lambda>(a, b). (map_option f a, map_option g b)) \<circ> lift_Some_None = lift_Some_None \<circ> f"
"(\<lambda>(a, b). (map_option f a, map_option g b)) \<circ> lift_None_Some = lift_None_Some \<circ> g"
by (auto simp: comp_def)
have "?ls x = ?rs x" for x
by (cases x) (auto simp: ta_rule.map_sel)
then have [simp]: "?ls = ?rs" by blast
then have "rules ?Ls = rules ?Rs"
unfolding pair_automaton_def fmap_funs_ta_def
by (simp add: fimage_funion map_ta_rule_comp * map_prod_ftimes)
moreover have "eps ?Ls = eps ?Rs"
unfolding pair_automaton_def fmap_funs_ta_def
by (simp add: fimage_funion \<Q>_def)
ultimately show ?thesis
by (intro TA_equalityI) simp
qed
lemmas map_pair_automaton_12 =
map_pair_automaton[of _ _ id, unfolded fmap_funs_ta_id option.map_id]
map_pair_automaton[of id _ _, unfolded fmap_funs_ta_id option.map_id]
lemma fmap_states_funs_ta_commute:
"fmap_states_ta f (fmap_funs_ta g A) = fmap_funs_ta g (fmap_states_ta f A)"
proof -
have [simp]: "map_ta_rule f id (map_ta_rule id g r) = map_ta_rule id g (map_ta_rule f id r)" for r
by (cases r) auto
show ?thesis
by (auto simp: ta_rule.case_distrib fmap_states_ta_def fmap_funs_ta_def fimage_iff fBex_def split: ta_rule.splits)
qed
lemma states_pair_automaton:
"\<Q> (pair_automaton A B) |\<subseteq>| (finsert None (Some |`| \<Q> A) |\<times>| (finsert None (Some |`| \<Q> B)))"
unfolding pair_automaton_def
apply (intro \<Q>_subseteq_I)
apply (auto simp: ta_rule.map_sel in_fset_conv_nth nth_zip_fill rule_statesD eps_statesD)
apply (simp add: rule_statesD)+
done
lemma swap_pair_automaton:
assumes "(p, q) |\<in>| ta_der (pair_automaton A B) (term_of_gterm t)"
shows "(q, p) |\<in>| ta_der (pair_automaton B A) (term_of_gterm (map_gterm prod.swap t))"
proof -
let ?m = "map_ta_rule prod.swap prod.swap"
have [simp]: "map prod.swap (zip_fill xs ys) = zip_fill ys xs" for xs ys
by (auto simp: zip_fill_def zip_nth_conv comp_def intro!: nth_equalityI)
let ?swp = "\<lambda>X. fmap_states_ta prod.swap (fmap_funs_ta prod.swap X)"
{ fix A B
let ?AB = "?swp (pair_automaton A B)" and ?BA = "pair_automaton B A"
have "eps ?AB |\<subseteq>| eps ?BA" "rules ?AB |\<subseteq>| rules ?BA"
by (auto simp: fmap_states_ta_def fmap_funs_ta_def pair_automaton_def fimage_iff ta_rule.map_comp)
force+
} note * = this
let ?BA = "?swp (?swp (pair_automaton B A))" and ?AB = "?swp (pair_automaton A B)"
have **: "r |\<in>| rules (pair_automaton B A) \<Longrightarrow> ?m r |\<in>| ?m |`| rules (pair_automaton B A)" for r
by blast
have "r |\<in>| rules ?BA \<Longrightarrow> r |\<in>| rules ?AB" "e |\<in>| eps ?BA \<Longrightarrow> e |\<in>| eps ?AB" for r e
using *[of B A] map_ta_rule_prod_swap_id
unfolding fmap_funs_ta_def fmap_states_ta_def
by (auto simp: map_ta_rule_comp fimage_iff fBex_def ta_rule.map_id0 intro!: exI[of _ "?m r"])
then have "eps ?BA |\<subseteq>| eps ?AB" "rules ?BA |\<subseteq>| rules ?AB"
by blast+
then have "fmap_states_ta prod.swap (fmap_funs_ta prod.swap (pair_automaton A B)) = pair_automaton B A"
using *[of A B] by (simp add: fmap_states_funs_ta_commute fmap_funs_ta_comp fmap_states_ta_comp TA_equalityI)
then show ?thesis
using ta_der_fmap_states_ta[OF ta_der_fmap_funs_ta[OF assms], of prod.swap prod.swap]
by (simp add: gterm.map_comp comp_def)
qed
lemma to_ta_der_pair_automaton:
"p |\<in>| ta_der A (term_of_gterm t) \<Longrightarrow>
(Some p, None) |\<in>| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (\<lambda>f. (Some f, None)) t))"
"q |\<in>| ta_der B (term_of_gterm u) \<Longrightarrow>
(None, Some q) |\<in>| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (\<lambda>f. (None, Some f)) u))"
"p |\<in>| ta_der A (term_of_gterm t) \<Longrightarrow> q |\<in>| ta_der B (term_of_gterm u) \<Longrightarrow>
(Some p, Some q) |\<in>| ta_der (pair_automaton A B) (term_of_gterm (gpair t u))"
proof (goal_cases sn ns ss)
let ?AB = "pair_automaton A B"
have 1: "(Some p, None) |\<in>| ta_der (pair_automaton A B) (term_of_gterm (map_gterm (\<lambda>f. (Some f, None)) s))"
if "p |\<in>| ta_der A (term_of_gterm s)" for A B p s
by (intro fsubsetD[OF ta_der_mono, OF _ _ ta_der_fmap_states_ta[OF ta_der_fmap_funs_ta[OF that]],
unfolded map_term_of_gterm id_def gterm.map_ident])
(auto simp add: pair_automaton_def fmap_states_ta_def fmap_funs_ta_def ta_rule.map_comp image_iff eps_to_pair_eps_Some_None)
have 2: "q |\<in>| ta_der B (term_of_gterm t) \<Longrightarrow>
(None, Some q) |\<in>| ta_der ?AB (term_of_gterm (map_gterm (\<lambda>g. (None, Some g)) t))"
for q t using swap_pair_automaton[OF 1[of q B t A]] by (simp add: gterm.map_comp comp_def)
{
case sn then show ?case by (rule 1)
next
case ns then show ?case by (rule 2)
next
case ss then show ?case
proof (induct t arbitrary: p q u)
case (GFun f ts)
obtain g us where u [simp]: "u = GFun g us" by (cases u)
obtain p' ps where p': "f ps \<rightarrow> p' |\<in>| rules A" "p' = p \<or> (p', p) |\<in>| (eps A)|\<^sup>+|" "length ps = length ts"
"\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der A (term_of_gterm (ts ! i))" using GFun(2) by auto
obtain q' qs where q': "g qs \<rightarrow> q' |\<in>| rules B" "q' = q \<or> (q', q) |\<in>| (eps B)|\<^sup>+|" "length qs = length us"
"\<And>i. i < length us \<Longrightarrow> qs ! i |\<in>| ta_der B (term_of_gterm (us ! i))" using GFun(3) by auto
have *: "Some p |\<in>| Some |`| \<Q> A" "Some q' |\<in>| Some |`| \<Q> B"
using p'(2,1) q'(1)
by (auto simp: rule_statesD eps_trancl_statesD)
have eps: "p' = p \<and> q' = q \<or> ((Some p', Some q'), (Some p, Some q)) |\<in>| (eps ?AB)|\<^sup>+|"
proof (cases "p' = p")
case True note p = this then show ?thesis
proof (cases "q' = q")
case False
then have "(q', q) |\<in>| (eps B)|\<^sup>+|" using q'(2) by auto
then show ?thesis using p'(1)
using ftrancl_map[of "eps B" "\<lambda>q. (Some p', Some q)" "eps ?AB" q' q]
by (auto simp: p pair_automaton_def fimage_iff fBex_def rule_statesD)
qed (simp add: p)
next
case False note p = this
then have *: "(p', p) |\<in>| (eps A)|\<^sup>+|" using p'(2) by auto
then have eps: "((Some p', Some q'), Some p, Some q') |\<in>| (eps (pair_automaton A B))|\<^sup>+|"
using q'(1) ftrancl_map[of "eps A" "\<lambda>p. (Some p, Some q')" "eps ?AB" p' p]
by (auto simp: p pair_automaton_def fimage_iff fBex_def rule_statesD)
show ?thesis
proof (cases "q' = q")
case True then show ?thesis using eps
by simp
next
case False
then have "(q', q) |\<in>| (eps B)|\<^sup>+|" using q'(2) by auto
then have "((Some p, Some q'), Some p, Some q) |\<in>| (eps (pair_automaton A B))|\<^sup>+|"
using * ftrancl_map[of "eps B" "\<lambda>q. (Some p, Some q)" "eps ?AB" q' q]
by (auto simp: p pair_automaton_def fimage_iff fBex_def eps_trancl_statesD)
then show ?thesis using eps
by (meson ftrancl_trans)
qed
qed
have "(Some f, Some g) zip_fill ps qs \<rightarrow> (Some p', Some q') |\<in>| rules ?AB"
using p'(1) q'(1) by (force simp: pair_automaton_def)
then show ?case using GFun(1)[OF nth_mem p'(4) q'(4)] p'(1 - 3) q'(1 - 3) eps
using 1[OF p'(4), of _ B] 2[OF q'(4)]
by (auto simp: gpair_code nth_zip_fill less_max_iff_disj
intro!: exI[of _ "zip_fill ps qs"] exI[of _ "Some p'"] exI[of _ "Some q'"])
qed
}
qed
lemma from_ta_der_pair_automaton:
"(None, None) |\<notin>| ta_der (pair_automaton A B) (term_of_gterm s)"
"(Some p, None) |\<in>| ta_der (pair_automaton A B) (term_of_gterm s) \<Longrightarrow>
\<exists>t. p |\<in>| ta_der A (term_of_gterm t) \<and> s = map_gterm (\<lambda>f. (Some f, None)) t"
"(None, Some q) |\<in>| ta_der (pair_automaton A B) (term_of_gterm s) \<Longrightarrow>
\<exists>u. q |\<in>| ta_der B (term_of_gterm u) \<and> s = map_gterm (\<lambda>f. (None, Some f)) u"
"(Some p, Some q) |\<in>| ta_der (pair_automaton A B) (term_of_gterm s) \<Longrightarrow>
\<exists>t u. p |\<in>| ta_der A (term_of_gterm t) \<and> q |\<in>| ta_der B (term_of_gterm u) \<and> s = gpair t u"
proof (goal_cases nn sn ns ss)
let ?AB = "pair_automaton A B"
{ fix p s A B assume "(Some p, None) |\<in>| ta_der (pair_automaton A B) (term_of_gterm s)"
then have "\<exists>t. p |\<in>| ta_der A (term_of_gterm t) \<and> s = map_gterm (\<lambda>f. (Some f, None)) t"
proof (induct s arbitrary: p)
case (GFun h ss)
obtain rs sp nq where r: "h rs \<rightarrow> (sp, nq) |\<in>| rules (pair_automaton A B)"
"sp = Some p \<and> nq = None \<or> ((sp, nq), (Some p, None)) |\<in>| (eps (pair_automaton A B))|\<^sup>+|" "length rs = length ss"
"\<And>i. i < length ss \<Longrightarrow> rs ! i |\<in>| ta_der (pair_automaton A B) (term_of_gterm (ss ! i))"
using GFun(2) by auto
obtain p' where pq: "sp = Some p'" "nq = None" "p' = p \<or> (p', p) |\<in>| (eps A)|\<^sup>+|"
using r(2) pair_eps_Some_None[of sp nq p A B]
by (cases sp) auto
obtain f ps where h: "h = lift_Some_None f" "rs = map lift_Some_None ps"
"f ps \<rightarrow> p' |\<in>| rules A"
using r(1) unfolding pq(1, 2) by (auto simp: pair_automaton_def map_ta_rule_cases)
obtain ts where "\<And>i. i < length ss \<Longrightarrow>
ps ! i |\<in>| ta_der A (term_of_gterm (ts i)) \<and> ss ! i = map_gterm (\<lambda>f. (Some f, None)) (ts i)"
using GFun(1)[OF nth_mem, of i "ps ! i" for i] r(4)[unfolded h(2)] r(3)[unfolded h(2) length_map]
by auto metis
then show ?case using h(3) pq(3) r(3)[unfolded h(2) length_map]
by (intro exI[of _ "GFun f (map ts [0..<length ss])"]) (auto simp: h(1) intro!: nth_equalityI)
qed
} note 1 = this
have 2: "\<exists>u. q |\<in>| ta_der B (term_of_gterm u) \<and> s = map_gterm (\<lambda>g. (None, Some g)) u"
if "(None, Some q) |\<in>| ta_der ?AB (term_of_gterm s)" for q s
using 1[OF swap_pair_automaton, OF that]
by (auto simp: gterm.map_comp comp_def gterm.map_ident
dest!: arg_cong[of "map_gterm prod.swap _" _ "map_gterm prod.swap", unfolded gterm.map_comp])
{
case nn
then show ?case
by (intro ta_der_not_reach) (auto simp: pair_automaton_def map_ta_rule_cases)
next
case sn then show ?case by (rule 1)
next
case ns then show ?case by (rule 2)
next
case ss then show ?case
proof (induct s arbitrary: p q)
case (GFun h ss)
obtain rs sp sq where r: "h rs \<rightarrow> (sp, sq) |\<in>| rules ?AB"
"sp = Some p \<and> sq = Some q \<or> ((sp, sq), (Some p, Some q)) |\<in>| (eps ?AB)|\<^sup>+|" "length rs = length ss"
"\<And>i. i < length ss \<Longrightarrow> rs ! i |\<in>| ta_der ?AB (term_of_gterm (ss ! i))"
using GFun(2) by auto
from r(2) have "sp \<noteq> None" "sq \<noteq> None" using pair_eps_Some_Some2[of "(sp, sq)" p q]
by auto
then obtain p' q' where pq: "sp = Some p'" "sq = Some q'"
"p' = p \<or> (p', p) |\<in>| (eps A)|\<^sup>+|" "q' = q \<or> (q', q) |\<in>| (eps B)|\<^sup>+|"
using r(2) pair_eps_Some_Some[where ?r = "(Some p, Some q)" and ?A = A and ?B = B]
using pair_eps_Some_Some2[of "(sp, sq)" p q]
by (cases sp; cases sq) auto
obtain f g ps qs where h: "h = (Some f, Some g)" "rs = zip_fill ps qs"
"f ps \<rightarrow> p' |\<in>| rules A" "g qs \<rightarrow> q' |\<in>| rules B"
using r(1) unfolding pq(1,2) by (auto simp: pair_automaton_def map_ta_rule_cases)
have *: "\<exists>t u. ps ! i |\<in>| ta_der A (term_of_gterm t) \<and> qs ! i |\<in>| ta_der B (term_of_gterm u) \<and> ss ! i = gpair t u"
if "i < length ps" "i < length qs" for i
using GFun(1)[OF nth_mem, of i "ps ! i" "qs ! i"] r(4)[unfolded pq(1,2) h(2), of i] that
r(3)[symmetric] by (auto simp: nth_zip_fill h(2))
{ fix i assume "i < length ss"
then have "\<exists>t u. (i < length ps \<longrightarrow> ps ! i |\<in>| ta_der A (term_of_gterm t)) \<and>
(i < length qs \<longrightarrow> qs ! i |\<in>| ta_der B (term_of_gterm u)) \<and>
ss ! i = gpair_impl (if i < length ps then Some t else None) (if i < length qs then Some u else None)"
using *[of i] 1[of "ps ! i" A B "ss ! i"] 2[of "qs ! i" "ss ! i"] r(4)[of i] r(3)[symmetric]
by (cases "i < length ps"; cases "i < length qs")
(auto simp add: h(2) nth_zip_fill less_max_iff_disj gpair_code split: gterm.splits) }
then obtain ts us where "\<And>i. i < length ss \<Longrightarrow>
(i < length ps \<longrightarrow> ps ! i |\<in>| ta_der A (term_of_gterm (ts i))) \<and>
(i < length qs \<longrightarrow> qs ! i |\<in>| ta_der B (term_of_gterm (us i))) \<and>
ss ! i = gpair_impl (if i < length ps then Some (ts i) else None) (if i < length qs then Some (us i) else None)"
by metis
moreover then have "\<And>i. i < length ps \<Longrightarrow> ps ! i |\<in>| ta_der A (term_of_gterm (ts i))"
"\<And>i. i < length qs \<Longrightarrow> qs ! i |\<in>| ta_der B (term_of_gterm (us i))"
using r(3)[unfolded h(2)] by auto
ultimately show ?case using h(3,4) pq(3,4) r(3)[symmetric]
by (intro exI[of _ "GFun f (map ts [0..<length ps])"] exI[of _ "GFun g (map us [0..<length qs])"])
(auto simp: gpair_code h(1,2) less_max_iff_disj nth_zip_fill intro!: nth_equalityI split: prod.splits gterm.splits)
qed
}
qed
lemma diagonal_automaton:
assumes "RR1_spec A R"
shows "RR2_spec (fmap_funs_reg (\<lambda>f. (Some f, Some f)) A) {(s, s) | s. s \<in> R}" using assms
by (auto simp: RR2_spec_def RR1_spec_def fmap_funs_reg_def fmap_funs_gta_lang map_funs_term_some_gpair \<L>_def)
lemma pair_automaton:
assumes "RR1_spec A T" "RR1_spec B U"
shows "RR2_spec (pair_automaton_reg A B) (T \<times> U)"
proof -
let ?AB = "pair_automaton (ta A) (ta B)"
{ fix t u assume t: "t \<in> T" and u: "u \<in> U"
obtain p where p: "p |\<in>| fin A" "p |\<in>| ta_der (ta A) (term_of_gterm t)" using t assms(1)
by (auto simp: RR1_spec_def gta_lang_def \<L>_def gta_der_def)
obtain q where q: "q |\<in>| fin B" "q |\<in>| ta_der (ta B) (term_of_gterm u)" using u assms(2)
by (auto simp: RR1_spec_def gta_lang_def \<L>_def gta_der_def)
have "gpair t u \<in> \<L> (pair_automaton_reg A B)" using p(1) q(1) to_ta_der_pair_automaton(3)[OF p(2) q(2)]
by (auto simp: pair_automaton_reg_def \<L>_def)
} moreover
{ fix s assume "s \<in> \<L> (pair_automaton_reg A B)"
from this[unfolded gta_lang_def \<L>_def]
obtain r where r: "r |\<in>| fin (pair_automaton_reg A B)" "r |\<in>| gta_der ?AB s"
by (auto simp: pair_automaton_reg_def)
obtain p q where pq: "r = (Some p, Some q)" "p |\<in>| fin A" "q |\<in>| fin B"
using r(1) by (auto simp: pair_automaton_reg_def)
from from_ta_der_pair_automaton(4)[OF r(2)[unfolded pq(1) gta_der_def]]
obtain t u where "p |\<in>| ta_der (ta A) (term_of_gterm t)" "q |\<in>| ta_der (ta B) (term_of_gterm u)" "s = gpair t u"
by (elim exE conjE) note * = this
then have "t \<in> \<L> A" "u \<in> \<L> B" using pq(2,3)
by (auto simp: \<L>_def)
then have "\<exists>t u. s = gpair t u \<and> t \<in> T \<and> u \<in> U" using assms
by (auto simp: RR1_spec_def *(3) intro!: exI[of _ t, OF exI[of _ u]])
} ultimately show ?thesis by (auto simp: RR2_spec_def)
qed
lemma pair_automaton':
shows "\<L> (pair_automaton_reg A B) = case_prod gpair ` (\<L> A \<times> \<L> B)"
using pair_automaton[of A _ B] by (auto simp: RR1_spec_def RR2_spec_def)
subsection \<open>Collapsing\<close>
text \<open>cf. @{const "gcollapse"}.\<close>
fun collapse_state_list where
"collapse_state_list Qn Qs [] = [[]]"
| "collapse_state_list Qn Qs (q # qs) = (let rec = collapse_state_list Qn Qs qs in
(if q |\<in>| Qn \<and> q |\<in>| Qs then map (Cons None) rec @ map (Cons (Some q)) rec
else if q |\<in>| Qn then map (Cons None) rec
else if q |\<in>| Qs then map (Cons (Some q)) rec
else [[]]))"
lemma collapse_state_list_inner_length:
assumes "qss = collapse_state_list Qn Qs qs"
and "\<forall> i < length qs. qs ! i |\<in>| Qn \<or> qs ! i |\<in>| Qs"
and "i < length qss"
shows "length (qss ! i) = length qs" using assms
proof (induct qs arbitrary: qss i)
case (Cons q qs)
have "\<forall>i<length qs. qs ! i |\<in>| Qn \<or> qs ! i |\<in>| Qs" using Cons(3) by auto
then show ?case using Cons(1)[of "collapse_state_list Qn Qs qs"] Cons(2-)
by (auto simp: Let_def nth_append)
qed auto
lemma collapse_fset_inv_constr:
assumes "\<forall> i < length qs'. qs ! i |\<in>| Qn \<and> qs' ! i = None \<or>
qs ! i |\<in>| Qs \<and> qs' ! i = Some (qs ! i)"
and "length qs = length qs'"
shows "qs' |\<in>| fset_of_list (collapse_state_list Qn Qs qs)" using assms
proof (induct qs arbitrary: qs')
case (Cons q qs)
have "(tl qs') |\<in>| fset_of_list (collapse_state_list Qn Qs qs)" using Cons(2-)
by (intro Cons(1)[of "tl qs'"]) (cases qs', auto)
then show ?case using Cons(2-)
by (cases qs') (auto simp: Let_def image_def)
qed auto
lemma collapse_fset_inv_constr2:
assumes "\<forall> i < length qs. qs ! i |\<in>| Qn \<or> qs ! i |\<in>| Qs"
and "qs' |\<in>| fset_of_list (collapse_state_list Qn Qs qs)" and "i < length qs'"
shows "qs ! i |\<in>| Qn \<and> qs' ! i = None \<or> qs ! i |\<in>| Qs \<and> qs' ! i = Some (qs ! i)"
using assms
proof (induct qs arbitrary: qs' i)
case (Cons a qs)
have "i \<noteq> 0 \<Longrightarrow> qs ! (i - 1) |\<in>| Qn \<and> tl qs' ! (i - 1) = None \<or> qs ! (i - 1) |\<in>| Qs \<and> tl qs' ! (i - 1) = Some (qs ! (i - 1))"
using Cons(2-)
by (intro Cons(1)[of "tl qs'" "i - 1"]) (auto simp: Let_def split: if_splits)
then show ?case using Cons(2-)
by (cases i) (auto simp: Let_def split: if_splits)
qed auto
definition collapse_rule where
"collapse_rule A Qn Qs =
|\<Union>| ((\<lambda> r. fset_of_list (map (\<lambda> qs. TA_rule (r_root r) qs (Some (r_rhs r))) (collapse_state_list Qn Qs (r_lhs_states r)))) |`|
ffilter (\<lambda> r. (\<forall> i < length (r_lhs_states r). r_lhs_states r ! i |\<in>| Qn \<or> r_lhs_states r ! i |\<in>| Qs))
(ffilter (\<lambda> r. r_root r \<noteq> None) (rules A)))"
definition collapse_rule_fset where
"collapse_rule_fset A Qn Qs = (\<lambda> r. TA_rule (the (r_root r)) (map the (filter (\<lambda>q. \<not> Option.is_none q) (r_lhs_states r))) (the (r_rhs r))) |`|
collapse_rule A Qn Qs"
lemma collapse_rule_set_conv:
"fset (collapse_rule_fset A Qn Qs) = {TA_rule f (map the (filter (\<lambda>q. \<not> Option.is_none q) qs')) q | f qs qs' q.
TA_rule (Some f) qs q |\<in>| rules A \<and> length qs = length qs' \<and>
(\<forall>i < length qs. qs ! i |\<in>| Qn \<and> qs' ! i = None \<or> qs ! i |\<in>| Qs \<and> (qs' ! i) = Some (qs ! i))} " (is "?Ls = ?Rs")
proof
{fix f qs' q qs assume ass: "TA_rule (Some f) qs q |\<in>| rules A"
"length qs = length qs'"
"\<forall>i < length qs. qs ! i |\<in>| Qn \<and> qs' ! i = None \<or> qs ! i |\<in>| Qs \<and> (qs' ! i) = Some (qs ! i)"
then have "TA_rule (Some f) qs' (Some q) |\<in>| collapse_rule A Qn Qs"
using collapse_fset_inv_constr[of qs' qs Qn Qs] unfolding collapse_rule_def
by (auto simp: fset_of_list.rep_eq fimage_iff intro!: fBexI[of _ "TA_rule (Some f) qs q"])
then have "TA_rule f (map the (filter (\<lambda>q. \<not> Option.is_none q) qs')) q \<in> ?Ls"
unfolding collapse_rule_fset_def
- by (auto simp: image_iff Bex_def fmember.rep_eq intro!: exI[of _"TA_rule (Some f) qs' (Some q)"])}
+ by (auto simp: image_iff Bex_def fmember_iff_member_fset intro!: exI[of _"TA_rule (Some f) qs' (Some q)"])}
then show "?Rs \<subseteq> ?Ls" by blast
next
{fix f qs q assume ass: "TA_rule f qs q \<in> ?Ls"
then obtain ps qs' where w: "TA_rule (Some f) ps q |\<in>| rules A"
"\<forall> i < length ps. ps ! i |\<in>| Qn \<or> ps ! i |\<in>| Qs"
"qs' |\<in>| fset_of_list (collapse_state_list Qn Qs ps)"
"qs = map the (filter (\<lambda>q. \<not> Option.is_none q) qs')"
unfolding collapse_rule_fset_def collapse_rule_def
- by (auto simp: fmember.rep_eq ffUnion.rep_eq fset_of_list.rep_eq) (metis ta_rule.collapse)
+ by (auto simp: fmember_iff_member_fset ffUnion.rep_eq fset_of_list.rep_eq) (metis ta_rule.collapse)
then have "\<forall> i < length qs'. ps ! i |\<in>| Qn \<and> qs' ! i = None \<or> ps ! i |\<in>| Qs \<and> qs' ! i = Some (ps ! i)"
using collapse_fset_inv_constr2
by metis
moreover have "length ps = length qs'"
using collapse_state_list_inner_length[of _ Qn Qs ps]
using w(2, 3) calculation(1)
by (auto simp: in_fset_conv_nth)
ultimately have "TA_rule f qs q \<in> ?Rs"
using w(1) unfolding w(4)
by auto fastforce}
then show "?Ls \<subseteq> ?Rs"
by (intro subsetI) (metis (no_types, lifting) ta_rule.collapse)
qed
lemma collapse_rule_fmember [simp]:
"TA_rule f qs q |\<in>| (collapse_rule_fset A Qn Qs) \<longleftrightarrow> (\<exists> qs' ps.
qs = map the (filter (\<lambda>q. \<not> Option.is_none q) qs') \<and> TA_rule (Some f) ps q |\<in>| rules A \<and> length ps = length qs' \<and>
(\<forall>i < length ps. ps ! i |\<in>| Qn \<and> qs' ! i = None \<or> ps ! i |\<in>| Qs \<and> (qs' ! i) = Some (ps ! i)))"
- unfolding fmember.rep_eq collapse_rule_set_conv
+ unfolding fmember_iff_member_fset collapse_rule_set_conv
by auto
definition "Qn A \<equiv> (let S = (r_rhs |`| ffilter (\<lambda> r. r_root r = None) (rules A)) in (eps A)|\<^sup>+| |``| S |\<union>| S)"
definition "Qs A \<equiv> (let S = (r_rhs |`| ffilter (\<lambda> r. r_root r \<noteq> None) (rules A)) in (eps A)|\<^sup>+| |``| S |\<union>| S)"
lemma Qn_member_iff [simp]:
"q |\<in>| Qn A \<longleftrightarrow> (\<exists> ps p. TA_rule None ps p |\<in>| rules A \<and> (p = q \<or> (p, q) |\<in>| (eps A)|\<^sup>+|))" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
{assume ass: "q |\<in>| Qn A" then obtain r where
"r_rhs r = q \<or> (r_rhs r, q) |\<in>| (eps A)|\<^sup>+|" "r |\<in>| rules A" "r_root r = None"
- by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember.rep_eq)
+ by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember_iff_member_fset)
then have "?Ls \<Longrightarrow> ?Rs" by (cases r) auto}
- moreover have "?Rs \<Longrightarrow> ?Ls" by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq fmember.rep_eq)
+ moreover have "?Rs \<Longrightarrow> ?Ls" by (force simp: Qn_def Image_def image_def Let_def fImage.rep_eq fmember_iff_member_fset)
ultimately show ?thesis by blast
qed
lemma Qs_member_iff [simp]:
"q |\<in>| Qs A \<longleftrightarrow> (\<exists> f ps p. TA_rule (Some f) ps p |\<in>| rules A \<and> (p = q \<or> (p, q) |\<in>| (eps A)|\<^sup>+|))" (is "?Ls \<longleftrightarrow> ?Rs")
proof -
{assume ass: "q |\<in>| Qs A" then obtain f r where
"r_rhs r = q \<or> (r_rhs r, q) |\<in>| (eps A)|\<^sup>+|" "r |\<in>| rules A" "r_root r = Some f"
- by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember.rep_eq)
+ by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq simp flip: fmember_iff_member_fset)
then have "?Ls \<Longrightarrow> ?Rs" by (cases r) auto}
- moreover have "?Rs \<Longrightarrow> ?Ls" by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq fmember.rep_eq)
+ moreover have "?Rs \<Longrightarrow> ?Ls" by (force simp: Qs_def Image_def image_def Let_def fImage.rep_eq fmember_iff_member_fset)
ultimately show ?thesis by blast
qed
lemma collapse_Qn_Qs_set_conv:
"fset (Qn A) = {q' |qs q q'. TA_rule None qs q |\<in>| rules A \<and> (q = q' \<or> (q, q') |\<in>| (eps A)|\<^sup>+|)}" (is "?Ls1 = ?Rs1")
"fset (Qs A) = {q' |f qs q q'. TA_rule (Some f) qs q |\<in>| rules A \<and> (q = q' \<or> (q, q') |\<in>| (eps A)|\<^sup>+|)}" (is "?Ls2 = ?Rs2")
- by (auto simp flip: fmember.rep_eq) force+
+ by (auto simp flip: fmember_iff_member_fset) force+
definition collapse_automaton :: "('q, 'f option) ta \<Rightarrow> ('q, 'f) ta" where
"collapse_automaton A = TA (collapse_rule_fset A (Qn A) (Qs A)) (eps A)"
definition collapse_automaton_reg where
"collapse_automaton_reg R = Reg (fin R) (collapse_automaton (ta R))"
lemma ta_states_collapse_automaton:
"\<Q> (collapse_automaton A) |\<subseteq>| \<Q> A"
apply (intro \<Q>_subseteq_I)
- apply (auto simp: collapse_automaton_def fmember.rep_eq collapse_Qn_Qs_set_conv collapse_rule_set_conv
- fset_of_list.rep_eq in_set_conv_nth rule_statesD[unfolded fmember.rep_eq] eps_statesD[unfolded fmember.rep_eq])
+ apply (auto simp: collapse_automaton_def fmember_iff_member_fset collapse_Qn_Qs_set_conv collapse_rule_set_conv
+ fset_of_list.rep_eq in_set_conv_nth rule_statesD[unfolded fmember_iff_member_fset] eps_statesD[unfolded fmember_iff_member_fset])
apply (metis Option.is_none_def fnth_mem notin_fset option.sel rule_statesD(3) ta_rule.sel(2))
done
lemma last_nthI:
assumes "i < length ts" "\<not> i < length ts - Suc 0"
shows "ts ! i = last ts" using assms
by (induct ts arbitrary: i)
(auto, metis last_conv_nth length_0_conv less_antisym nth_Cons')
lemma collapse_automaton':
assumes "\<Q> A |\<subseteq>| ta_reachable A" (* cf. ta_trim *)
shows "gta_lang Q (collapse_automaton A) = the ` (gcollapse ` gta_lang Q A - {None})"
proof -
define Qn' where "Qn' = Qn A"
define Qs' where "Qs' = Qs A"
{fix t assume t: "t \<in> gta_lang Q (collapse_automaton A)"
then obtain q where q: "q |\<in>| Q" "q |\<in>| ta_der (collapse_automaton A) (term_of_gterm t)" by auto
have "\<exists> t'. q |\<in>| ta_der A (term_of_gterm t') \<and> gcollapse t' \<noteq> None \<and> t = the (gcollapse t')" using q(2)
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
from GFun(1 - 3) obtain qs rs where ps: "TA_rule (Some f) qs p |\<in>| rules A" "length qs = length rs"
"\<And>i. i < length qs \<Longrightarrow> qs ! i |\<in>| Qn' \<and> rs ! i = None \<or> qs ! i |\<in>| Qs' \<and> rs ! i = Some (qs ! i)"
"ps = map the (filter (\<lambda>q. \<not> Option.is_none q) rs)"
by (auto simp: collapse_automaton_def Qn'_def Qs'_def)
obtain ts' where ts':
"ps ! i |\<in>| ta_der A (term_of_gterm (ts' i))" "gcollapse (ts' i) \<noteq> None" "ts ! i = the (gcollapse (ts' i))"
if "i < length ts" for i using GFun(5) by metis
from ps(2, 3, 4) have rs: "i < length qs \<Longrightarrow> rs ! i = None \<or> rs ! i = Some (qs ! i)" for i
by auto
{fix i assume "i < length qs" "rs ! i = None"
then have "\<exists> t'. groot_sym t' = None \<and> qs ! i |\<in>| ta_der A (term_of_gterm t')"
using ps(1, 2) ps(3)[of i]
by (auto simp: ta_der_trancl_eps Qn'_def groot_sym_groot_conv elim!: ta_reachable_rule_gtermE[OF assms])
(force dest: ta_der_trancl_eps)+}
note None = this
{fix i assume i: "i < length qs" "rs ! i = Some (qs ! i)"
have "map Some ps = filter (\<lambda>q. \<not> Option.is_none q) rs" using ps(4)
by (induct rs arbitrary: ps) (auto simp add: Option.is_none_def)
from filter_rev_nth_idx[OF _ _ this, of i]
have *: "rs ! i = map Some ps ! filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i"
"filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i < length ps"
using ps(2, 4) i by auto
then have "the (rs ! i) = ps ! filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i"
"filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i < length ps"
by auto} note Some = this
let ?P = "\<lambda> t i. qs ! i |\<in>| ta_der A (term_of_gterm t) \<and>
(rs ! i = None \<longrightarrow> groot_sym t = None) \<and>
(rs ! i = Some (qs ! i) \<longrightarrow> t = ts' (filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i))"
{fix i assume i: "i < length qs"
then have "\<exists> t. ?P t i" using Some[OF i] None[OF i] ts' ps(2, 4) GFun(2) rs[OF i]
by (cases "rs ! i") auto}
then obtain ts'' where ts'': "length ts'' = length qs"
"i < length qs \<Longrightarrow> qs ! i |\<in>| ta_der A (term_of_gterm (ts'' ! i))"
"i < length qs \<Longrightarrow> rs ! i = None \<Longrightarrow> groot_sym (ts'' ! i) = None"
"i < length qs \<Longrightarrow> rs ! i = Some (qs ! i) \<Longrightarrow> ts'' ! i = ts' (filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs i)"
for i using that Ex_list_of_length_P[of "length qs" ?P] by auto
from ts''(1, 3, 4) Some ps(2, 4) GFun(2) rs ts'(2-)
have "map Some ts = (filter (\<lambda>q. \<not> Option.is_none q) (map gcollapse ts''))"
proof (induct ts'' arbitrary: qs rs ps ts rule: rev_induct)
case (snoc a us)
from snoc(2, 7) obtain r rs' where [simp]: "rs = rs' @ [r]"
by (metis append_butlast_last_id append_is_Nil_conv length_0_conv not_Cons_self2)
have l: "length us = length (butlast qs)" "length (butlast qs) = length (butlast rs)"
using snoc(2, 7) by auto
have *: "i < length (butlast qs) \<Longrightarrow> butlast rs ! i = None \<Longrightarrow> groot_sym (us ! i) = None" for i
using snoc(3)[of i] snoc(2, 7)
by (auto simp:nth_append l(1) nth_butlast split!: if_splits)
have **: "i < length (butlast qs) \<Longrightarrow> butlast rs ! i = None \<or> butlast rs ! i = Some (butlast qs ! i)" for i
using snoc(10)[of i] snoc(2, 7) l by (auto simp: nth_append nth_butlast)
have "i < length (butlast qs) \<Longrightarrow> butlast rs ! i = Some (butlast qs ! i) \<Longrightarrow>
us ! i = ts' (filter_rev_nth (\<lambda>q. \<not> Option.is_none q) (butlast rs) i)" for i
using snoc(4)[of i] snoc(2, 7) l
by (auto simp: nth_append nth_butlast filter_rev_nth_def take_butlast)
note IH = snoc(1)[OF l(1) * this _ _ l(2) _ _ **]
show ?case
proof (cases "r = None")
case True
then have "map Some ts = filter (\<lambda>q. \<not> Option.is_none q) (map gcollapse us)"
using snoc(2, 5-)
by (intro IH[of ps ts]) (auto simp: nth_append nth_butlast filter_rev_nth_butlast)
then show ?thesis using True snoc(2, 7) snoc(3)[of "length (butlast rs)"]
by (auto simp: nth_append l(1) last_nthI split!: if_splits)
next
case False
then obtain t' ss where *: "ts = ss @ [t']" using snoc(2, 7, 8, 9)
by (cases ts) (auto, metis append_butlast_last_id list.distinct(1))
let ?i = "filter_rev_nth (\<lambda>q. \<not> Option.is_none q) rs (length us)"
have "map Some (butlast ts) = filter (\<lambda>q. \<not> Option.is_none q) (map gcollapse us)"
using False snoc(2, 5-) l filter_rev_nth_idx
by (intro IH[of "butlast ps" "butlast ts"])
(fastforce simp: nth_butlast filter_rev_nth_butlast)+
moreover have "a = ts' ?i" "?i < length ps"
using False snoc(2, 9) l snoc(4, 6, 10)[of "length us"]
by (auto simp: nth_append)
moreover have "filter_rev_nth (\<lambda>q. \<not> Option.is_none q) (rs' @ [r]) (length rs') = length ss"
using l snoc(2, 7, 8, 9) False unfolding *
by (auto simp: filter_rev_nth_def)
ultimately show ?thesis using l snoc(2, 7, 9) snoc(11-)[of ?i]
by (auto simp: nth_append *)
qed
qed simp
then have "ts = map the (filter (\<lambda>t. \<not> Option.is_none t) (map gcollapse ts''))"
by (metis comp_the_Some list.map_id map_map)
then show ?case using ps(1, 2) ts''(1, 2) GFun(3)
by (auto simp: collapse_automaton_def intro!: exI[of _ "GFun (Some f) ts''"] exI[of _ qs] exI[of _ p])
qed
then have "t \<in> the ` (gcollapse ` gta_lang Q A - {None})"
by (meson Diff_iff gta_langI imageI q(1) singletonD)
} moreover
{ fix t assume t: "t \<in> gta_lang Q A" "gcollapse t \<noteq> None"
obtain q where q: "q |\<in>| Q" "q |\<in>| ta_der A (term_of_gterm t)" using t(1) by auto
have "q |\<in>| ta_der (collapse_automaton A) (term_of_gterm (the (gcollapse t)))" using q(2) t(2)
proof (induct t arbitrary: q)
case (GFun f ts)
obtain qs q' where q: "TA_rule f qs q' |\<in>| rules A" "q' = q \<or> (q', q) |\<in>| (eps (collapse_automaton A))|\<^sup>+|"
"length qs = length ts" "\<And>i. i < length ts \<Longrightarrow> qs ! i |\<in>| ta_der A (term_of_gterm (ts ! i))"
using GFun(2) by (auto simp: collapse_automaton_def)
obtain f' where f [simp]: "f = Some f'" using GFun(3) by (cases f) auto
define qs' where
"qs' = map (\<lambda>i. if Option.is_none (gcollapse (ts ! i)) then None else Some (qs ! i)) [0..<length qs]"
have "Option.is_none (gcollapse (ts ! i)) \<Longrightarrow> qs ! i |\<in>| Qn'" if "i < length qs" for i
using q(4)[of i] that
by (cases "ts ! i" rule: gcollapse.cases)
- (auto simp: q(3) Qn'_def fmember.rep_eq collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
+ (auto simp: q(3) Qn'_def fmember_iff_member_fset collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
moreover have "\<not> Option.is_none (gcollapse (ts ! i)) \<Longrightarrow> qs ! i |\<in>| Qs'" if "i < length qs" for i
using q(4)[of i] that
by (cases "ts ! i" rule: gcollapse.cases)
- (auto simp: q(3) Qs'_def fmember.rep_eq collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
+ (auto simp: q(3) Qs'_def fmember_iff_member_fset collapse_Qn_Qs_set_conv, meson notin_fset ta_der_Fun)
ultimately have "f' (map the (filter (\<lambda>q. \<not> Option.is_none q) qs')) \<rightarrow> q' |\<in>| rules (collapse_automaton A)"
using q(1, 4) unfolding collapse_automaton_def Qn'_def[symmetric] Qs'_def[symmetric]
by (fastforce simp: qs'_def q(3) intro: exI[of _ qs] exI[of _ qs'] split: if_splits)
moreover have ***: "length (filter (\<lambda>i.\<not> Option.is_none (gcollapse (ts ! i))) [0..<length ts]) =
length (filter (\<lambda>t. \<not> Option.is_none (gcollapse t)) ts)" for ts
by (subst length_map[of "(!) ts", symmetric] filter_map[unfolded comp_def, symmetric] map_nth)+
(rule refl)
note this[of ts]
moreover have "the (filter (\<lambda>q. \<not> Option.is_none q) qs' ! i) |\<in>| ta_der (collapse_automaton A)
(term_of_gterm (the (filter (\<lambda>t. \<not> Option.is_none t) (map gcollapse ts) ! i)))"
if "i < length [x\<leftarrow>ts . \<not> Option.is_none (gcollapse x)]" for i
unfolding qs'_def using that q(3) GFun(1)[OF nth_mem q(4)]
proof (induct ts arbitrary: qs rule: List.rev_induct)
case (snoc t ts)
have x1 [simp]: "i < length xs \<Longrightarrow> (xs @ ys) ! i = xs ! i" for xs ys i by (auto simp: nth_append)
have x2: "i = length xs \<Longrightarrow> (xs @ ys) ! i = ys ! 0" for xs ys i by (auto simp: nth_append)
obtain q qs' where qs [simp]: "qs = qs' @ [q]" using snoc(3) by (cases "rev qs") auto
have [simp]:
"map (\<lambda>x. if Option.is_none (gcollapse ((ts @ [t]) ! x)) then None else Some ((qs' @ [q]) ! x)) [0..<length ts] =
map (\<lambda>x. if Option.is_none (gcollapse (ts ! x)) then None else Some (qs' ! x)) [0..<length ts]"
using snoc(3) by auto
show ?case
proof (cases "Option.is_none (gcollapse t)")
case True then show ?thesis using snoc(1)[of qs'] snoc(2,3)
snoc(4)[unfolded length_append list.size add_0 add_0_right add_Suc_right, OF less_SucI]
by (auto cong: if_cong)
next
case False note False' = this
show ?thesis
proof (cases "i = length [x\<leftarrow>ts . \<not> Option.is_none (gcollapse x)]")
case True
then show ?thesis using snoc(3) snoc(4)[of "length ts"]
unfolding qs length_append list.size add_0 add_0_right add_Suc_right
upt_Suc_append[OF zero_le] filter_append map_append
by (subst (5 6) x2) (auto simp: comp_def *** False' Option.is_none_def[symmetric])
next
case False
then show ?thesis using snoc(1)[of qs'] snoc(2,3)
snoc(4)[unfolded length_append list.size add_0 add_0_right add_Suc_right, OF less_SucI]
unfolding qs length_append list.size add_0 add_0_right add_Suc_right
upt_Suc_append[OF zero_le] filter_append map_append
by (subst (5 6) x1) (auto simp: comp_def *** False')
qed
qed
qed auto
ultimately show ?case using q(2) by (auto simp: qs'_def comp_def q(3)
intro!: exI[of _ q'] exI[of _ "map the (filter (\<lambda>q. \<not> Option.is_none q) qs')"])
qed
then have "the (gcollapse t) \<in> gta_lang Q (collapse_automaton A)"
by (metis q(1) gta_langI)
} ultimately show ?thesis by blast
qed
lemma \<L>_collapse_automaton':
assumes "\<Q>\<^sub>r A |\<subseteq>| ta_reachable (ta A)" (* cf. ta_trim *)
shows "\<L> (collapse_automaton_reg A) = the ` (gcollapse ` \<L> A - {None})"
using assms by (auto simp: collapse_automaton_reg_def \<L>_def collapse_automaton')
lemma collapse_automaton:
assumes "\<Q>\<^sub>r A |\<subseteq>| ta_reachable (ta A)" "RR1_spec A T"
shows "RR1_spec (collapse_automaton_reg A) (the ` (gcollapse ` \<L> A - {None}))"
using collapse_automaton'[OF assms(1)] assms(2)
by (simp add: collapse_automaton_reg_def \<L>_def RR1_spec_def)
subsection \<open>Cylindrification\<close>
(* cylindrification is a product ("pairing") of a RR1 language accepting all terms, and an RRn language,
modulo some fairly trivial renaming of symbols. *)
definition pad_with_Nones where
"pad_with_Nones n m = (\<lambda>(f, g). case_option (replicate n None) id f @ case_option (replicate m None) id g)"
lemma gencode_append:
"gencode (ss @ ts) = map_gterm (pad_with_Nones (length ss) (length ts)) (gpair (gencode ss) (gencode ts))"
proof -
have [simp]: "p \<notin> gposs (gunions (map gdomain ts)) \<Longrightarrow> map (\<lambda>t. gfun_at t p) ts = replicate (length ts) None"
for p ts by (intro nth_equalityI)
(fastforce simp: poss_gposs_mem_conv fun_at_def' image_def all_set_conv_all_nth)+
note [simp] = glabel_map_gterm_conv[of "\<lambda>(_ :: unit option). ()", unfolded comp_def gdomain_id]
show ?thesis by (auto intro!: arg_cong[of _ _ "\<lambda>x. glabel x _"] simp del: gposs_gunions
simp: pad_with_Nones_def gencode_def gunions_append gpair_def map_gterm_glabel comp_def)
qed
lemma append_automaton:
assumes "RRn_spec n A T" "RRn_spec m B U"
shows "RRn_spec (n + m) (fmap_funs_reg (pad_with_Nones n m) (pair_automaton_reg A B)) {ts @ us |ts us. ts \<in> T \<and> us \<in> U}"
using assms pair_automaton[of A "gencode ` T" B "gencode ` U"]
unfolding RRn_spec_def
proof (intro conjI set_eqI iffI, goal_cases)
case (1 s)
then obtain ts us where "ts \<in> T" "us \<in> U" "s = gencode (ts @ us)"
by (fastforce simp: \<L>_def fmap_funs_reg_def RR1_spec_def RR2_spec_def gencode_append fmap_funs_gta_lang)
then show ?case by blast
qed (fastforce simp: RR1_spec_def RR2_spec_def fmap_funs_reg_def \<L>_def gencode_append fmap_funs_gta_lang)+
lemma cons_automaton:
assumes "RR1_spec A T" "RRn_spec m B U"
shows "RRn_spec (Suc m) (fmap_funs_reg (\<lambda>(f, g). pad_with_Nones 1 m (map_option (\<lambda>f. [Some f]) f, g))
(pair_automaton_reg A B)) {t # us |t us. t \<in> T \<and> us \<in> U}"
proof -
have [simp]: "{ts @ us |ts us. ts \<in> (\<lambda>t. [t]) ` T \<and> us \<in> U} = {t # us |t us. t \<in> T \<and> us \<in> U}"
by (auto intro: exI[of _ "[_]", OF exI])
show ?thesis using append_automaton[OF RR1_to_RRn_spec, OF assms]
by (auto simp: \<L>_def fmap_funs_reg_def pair_automaton_reg_def comp_def
fmap_funs_gta_lang map_pair_automaton_12 fmap_funs_ta_comp prod.case_distrib
gencode_append[of "[_]", unfolded gencode_singleton List.append.simps])
qed
subsection \<open>Projection\<close>
(* projection is composed from fmap_funs_ta and collapse_automaton, corresponding to gsnd *)
abbreviation "drop_none_rule m fs \<equiv> if list_all (Option.is_none) (drop m fs) then None else Some (drop m fs)"
lemma drop_automaton_reg:
assumes "\<Q>\<^sub>r A |\<subseteq>| ta_reachable (ta A)" "m < n" "RRn_spec n A T"
defines "f \<equiv> \<lambda>fs. drop_none_rule m fs"
shows "RRn_spec (n - m) (collapse_automaton_reg (fmap_funs_reg f A)) (drop m ` T)"
proof -
have [simp]: "length ts = n - m ==> p \<in> gposs (gencode ts) \<Longrightarrow> \<exists>f. \<exists>t\<in>set ts. Some f = gfun_at t p" for p ts
proof (cases p, goal_cases Empty PCons)
case Empty
obtain t where "t \<in> set ts" using assms(2) Empty(1) by (cases ts) auto
moreover then obtain f where "Some f = gfun_at t p" using Empty(3) by (cases t rule: gterm.exhaust) auto
ultimately show ?thesis by auto
next
case (PCons i p')
then have "p \<noteq> []" by auto
then show ?thesis using PCons(2)
by (auto 0 3 simp: gencode_def eq_commute[of "gfun_at _ _" "Some _"] elim!: gfun_at_possE)
qed
{ fix p ts y assume that: "gfun_at (gencode ts) p = Some y"
have "p \<in> gposs (gencode ts) \<Longrightarrow> gfun_at (gencode ts) p = Some (map (\<lambda>t. gfun_at t p) ts)"
by (auto simp: gencode_def)
moreover have "gfun_at (gencode ts) p = Some y \<Longrightarrow> p \<in> gposs (gencode ts)"
using gfun_at_nongposs by force
ultimately have "y = map (\<lambda>t. gfun_at t p) ts \<and> p \<in> gposs (gencode ts)" by (simp add: that)
} note [dest!] = this
have [simp]: "list_all f (replicate n x) \<longleftrightarrow> n = 0 \<or> f x" for f n x by (induct n) auto
have [dest]: "x \<in> set xs \<Longrightarrow> list_all f xs \<Longrightarrow> f x" for f x xs by (induct xs) auto
have *: "f (pad_with_Nones m' n' z) = snd z"
if "fst z = None \<or> fst z \<noteq> None \<and> length (the (fst z)) = m"
"snd z = None \<or> snd z \<noteq> None \<and> length (the (snd z)) = n - m \<and> (\<exists>y. Some y \<in> set (the (snd z)))"
"m' = m" "n' = n - m" for z m' n'
using that by (auto simp: f_def pad_with_Nones_def split: option.splits prod.splits)
{ fix ts assume ts: "ts \<in> T" "length ts = n"
have "gencode (drop m ts) = the (gcollapse (map_gterm f (gencode ts)))"
"gcollapse (map_gterm f (gencode ts)) \<noteq> None"
proof (goal_cases)
case 1 show ?case
using ts assms(2)
apply (subst gsnd_gpair[of "gencode (take m ts)", symmetric])
apply (subst gencode_append[of "take m ts" "drop m ts", unfolded append_take_drop_id])
unfolding gsnd_def comp_def gterm.map_comp
apply (intro arg_cong[where f = "\<lambda>x. the (gcollapse x)"] gterm.map_cong refl)
by (subst *) (auto simp: gpair_def set_gterm_gposs_conv image_def)
next
case 2
have [simp]: "gcollapse t = None \<longleftrightarrow> gfun_at t [] = Some None" for t
by (cases t rule: gcollapse.cases) auto
obtain t where "t \<in> set (drop m ts)" using ts(2) assms(2) by (cases "drop m ts") auto
moreover then have "\<not> Option.is_none (gfun_at t [])" by (cases t rule: gterm.exhaust) auto
ultimately show ?case
by (auto simp: f_def gencode_def list_all_def drop_map)
qed
}
then show ?thesis using assms(3)
by (fastforce simp: \<L>_def collapse_automaton_reg_def fmap_funs_reg_def
RRn_spec_def fmap_funs_gta_lang gsnd_def gpair_def gterm.map_comp comp_def
glabel_map_gterm_conv[unfolded comp_def] assms(1) collapse_automaton')
qed
lemma gfst_collapse_simp:
"the (gcollapse (map_gterm fst t)) = gfst t"
by (simp add: gfst_def)
lemma gsnd_collapse_simp:
"the (gcollapse (map_gterm snd t)) = gsnd t"
by (simp add: gsnd_def)
definition proj_1_reg where
"proj_1_reg A = collapse_automaton_reg (fmap_funs_reg fst (trim_reg A))"
definition proj_2_reg where
"proj_2_reg A = collapse_automaton_reg (fmap_funs_reg snd (trim_reg A))"
lemmas proj_1_reg_simp = proj_1_reg_def collapse_automaton_reg_def fmap_funs_reg_def trim_reg_def
lemmas proj_2_reg_simp = proj_2_reg_def collapse_automaton_reg_def fmap_funs_reg_def trim_reg_def
lemma \<L>_proj_1_reg_collapse:
"\<L> (proj_1_reg \<A>) = the ` (gcollapse ` map_gterm fst ` (\<L> \<A>) - {None})"
proof -
have "\<Q>\<^sub>r (fmap_funs_reg fst (trim_reg \<A>)) |\<subseteq>| ta_reachable (ta (fmap_funs_reg fst (trim_reg \<A>)))"
by (auto simp: fmap_funs_reg_def)
note [simp] = \<L>_collapse_automaton'[OF this]
show ?thesis by (auto simp: proj_1_reg_def fmap_funs_\<L> \<L>_trim)
qed
lemma \<L>_proj_2_reg_collapse:
"\<L> (proj_2_reg \<A>) = the ` (gcollapse ` map_gterm snd ` (\<L> \<A>) - {None})"
proof -
have "\<Q>\<^sub>r (fmap_funs_reg snd (trim_reg \<A>)) |\<subseteq>| ta_reachable (ta (fmap_funs_reg snd (trim_reg \<A>)))"
by (auto simp: fmap_funs_reg_def)
note [simp] = \<L>_collapse_automaton'[OF this]
show ?thesis by (auto simp: proj_2_reg_def fmap_funs_\<L> \<L>_trim)
qed
lemma proj_1:
assumes "RR2_spec A R"
shows "RR1_spec (proj_1_reg A) (fst ` R)"
proof -
{fix s t assume ass: "(s, t) \<in> R"
from ass have s: "s = the (gcollapse (map_gterm fst (gpair s t)))"
by (auto simp: gfst_gpair gfst_collapse_simp)
then have "Some s = gcollapse (map_gterm fst (gpair s t))"
by (cases s; cases t) (auto simp: gpair_def)
then have "s \<in> \<L> (proj_1_reg A)" using assms ass s
by (auto simp: proj_1_reg_simp \<L>_def trim_ta_reach trim_gta_lang
image_def image_Collect RR2_spec_def fmap_funs_gta_lang
collapse_automaton'[of "fmap_funs_ta fst (trim_ta (fin A) (ta A))"])
force}
moreover
{fix s assume "s \<in> \<L> (proj_1_reg A)" then have "s \<in> fst ` R" using assms
by (auto simp: gfst_collapse_simp gfst_gpair rev_image_eqI RR2_spec_def trim_ta_reach trim_gta_lang
\<L>_def proj_1_reg_simp fmap_funs_gta_lang collapse_automaton'[of "fmap_funs_ta fst (trim_ta (fin A) (ta A))"])}
ultimately show ?thesis using assms unfolding RR2_spec_def RR1_spec_def \<L>_def proj_1_reg_simp
by auto
qed
lemma proj_2:
assumes "RR2_spec A R"
shows "RR1_spec (proj_2_reg A) (snd ` R)"
proof -
{fix s t assume ass: "(s, t) \<in> R"
then have s: "t = the (gcollapse (map_gterm snd (gpair s t)))"
by (auto simp: gsnd_gpair gsnd_collapse_simp)
then have "Some t = gcollapse (map_gterm snd (gpair s t))"
by (cases s; cases t) (auto simp: gpair_def)
then have "t \<in> \<L> (proj_2_reg A)" using assms ass s
by (auto simp: \<L>_def trim_ta_reach trim_gta_lang proj_2_reg_simp
image_def image_Collect RR2_spec_def fmap_funs_gta_lang
collapse_automaton'[of "fmap_funs_ta snd (trim_ta (fin A) (ta A))"])
fastforce}
moreover
{fix s assume "s \<in> \<L> (proj_2_reg A)" then have "s \<in> snd ` R" using assms
by (auto simp: \<L>_def gsnd_collapse_simp gsnd_gpair rev_image_eqI RR2_spec_def
trim_ta_reach trim_gta_lang proj_2_reg_simp
fmap_funs_gta_lang collapse_automaton'[of "fmap_funs_ta snd (trim_ta (fin A) (ta A))"])}
ultimately show ?thesis using assms unfolding RR2_spec_def RR1_spec_def
by auto
qed
lemma \<L>_proj:
assumes "RR2_spec A R"
shows "\<L> (proj_1_reg A) = gfst ` \<L> A" "\<L> (proj_2_reg A) = gsnd ` \<L> A"
proof -
have [simp]: "gfst ` {gpair t u |t u. (t, u) \<in> R} = fst ` R"
by (force simp: gfst_gpair image_def)
have [simp]: "gsnd ` {gpair t u |t u. (t, u) \<in> R} = snd ` R"
by (force simp: gsnd_gpair image_def)
show "\<L> (proj_1_reg A) = gfst ` \<L> A" "\<L> (proj_2_reg A) = gsnd ` \<L> A"
using proj_1[OF assms] proj_2[OF assms] assms gfst_gpair gsnd_gpair
by (auto simp: RR1_spec_def RR2_spec_def)
qed
lemmas proj_automaton_gta_lang = proj_1 proj_2
subsection \<open>Permutation\<close>
(* permutations are a direct application of fmap_funs_ta *)
lemma gencode_permute:
assumes "set ps = {0..<length ts}"
shows "gencode (map ((!) ts) ps) = map_gterm (\<lambda>xs. map ((!) xs) ps) (gencode ts)"
proof -
have *: "(!) ts ` set ps = set ts" using assms by (auto simp: image_def set_conv_nth)
show ?thesis using subsetD[OF equalityD1[OF assms]]
apply (intro eq_gterm_by_gposs_gfun_at)
unfolding gencode_def gposs_glabel gposs_map_gterm gposs_gunions gfun_at_map_gterm gfun_at_glabel
set_map * by auto
qed
lemma permute_automaton:
assumes "RRn_spec n A T" "set ps = {0..<n}"
shows "RRn_spec (length ps) (fmap_funs_reg (\<lambda>xs. map ((!) xs) ps) A) ((\<lambda>xs. map ((!) xs) ps) ` T)"
using assms by (auto simp: RRn_spec_def gencode_permute fmap_funs_reg_def \<L>_def fmap_funs_gta_lang image_def)
subsection \<open>Intersection\<close>
(* intersection is already defined in IsaFoR *)
lemma intersect_automaton:
assumes "RRn_spec n A T" "RRn_spec n B U"
shows "RRn_spec n (reg_intersect A B) (T \<inter> U)" using assms
by (simp add: RRn_spec_def \<L>_intersect)
(metis gdecode_gencode image_Int inj_on_def)
(*
lemma swap_union_automaton:
"fmap_states_ta (case_sum Inr Inl) (union_automaton B A) = union_automaton A B"
by (simp add: fmap_states_ta_def' union_automaton_def image_Un image_comp case_sum_o_inj
ta_rule.map_comp prod.map_comp comp_def id_def ac_simps)
*)
lemma union_automaton:
assumes "RRn_spec n A T" "RRn_spec n B U"
shows "RRn_spec n (reg_union A B) (T \<union> U)"
using assms by (auto simp: RRn_spec_def \<L>_union)
subsection \<open>Difference\<close>
lemma RR1_difference:
assumes "RR1_spec A T" "RR1_spec B U"
shows "RR1_spec (difference_reg A B) (T - U)"
using assms by (auto simp: RR1_spec_def \<L>_difference_reg)
lemma RR2_difference:
assumes "RR2_spec A T" "RR2_spec B U"
shows "RR2_spec (difference_reg A B) (T - U)"
using assms by (auto simp: RR2_spec_def \<L>_difference_reg)
lemma RRn_difference:
assumes "RRn_spec n A T" "RRn_spec n B U"
shows "RRn_spec n (difference_reg A B) (T - U)"
using assms by (auto simp: RRn_spec_def \<L>_difference_reg) (metis gdecode_gencode)+
subsection \<open>All terms over a signature\<close>
definition term_automaton :: "('f \<times> nat) fset \<Rightarrow> (unit, 'f) ta" where
"term_automaton \<F> = TA ((\<lambda> (f, n). TA_rule f (replicate n ()) ()) |`| \<F>) {||}"
definition term_reg where
"term_reg \<F> = Reg {|()|} (term_automaton \<F>)"
lemma term_automaton:
"RR1_spec (term_reg \<F>) (\<T>\<^sub>G (fset \<F>))"
unfolding RR1_spec_def gta_lang_def term_reg_def \<L>_def
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr t)
then have "() |\<in>| ta_der (term_automaton \<F>) (term_of_gterm t)"
by (auto simp: gta_der_def)
then show ?case
- by (induct t) (auto simp: term_automaton_def split: if_splits simp flip: fmember.rep_eq)
+ by (induct t) (auto simp: term_automaton_def split: if_splits simp flip: fmember_iff_member_fset)
next
case (rl t)
then have "() |\<in>| ta_der (term_automaton \<F>) (term_of_gterm t)"
proof (induct t rule: \<T>\<^sub>G.induct)
case (const a) then show ?case
- by (auto simp: term_automaton_def fimage_iff simp flip: fmember.rep_eq intro: fBexI[of _ "(a, 0)"])
+ by (auto simp: term_automaton_def fimage_iff simp flip: fmember_iff_member_fset intro: fBexI[of _ "(a, 0)"])
next
case (ind f n ss) then show ?case
- by (auto simp: term_automaton_def fimage_iff simp flip: fmember.rep_eq intro: fBexI[of _ "(f, n)"])
+ by (auto simp: term_automaton_def fimage_iff simp flip: fmember_iff_member_fset intro: fBexI[of _ "(f, n)"])
qed
then show ?case
by (auto simp: gta_der_def)
qed
fun true_RRn :: "('f \<times> nat) fset \<Rightarrow> nat \<Rightarrow> (nat, 'f option list) reg" where
"true_RRn \<F> 0 = Reg {|0|} (TA {|TA_rule [] [] 0|} {||})"
| "true_RRn \<F> (Suc 0) = relabel_reg (fmap_funs_reg (\<lambda>f. [Some f]) (term_reg \<F>))"
| "true_RRn \<F> (Suc n) = relabel_reg
(trim_reg (fmap_funs_reg (pad_with_Nones 1 n) (pair_automaton_reg (true_RRn \<F> 1) (true_RRn \<F> n))))"
lemma true_RRn_spec:
"RRn_spec n (true_RRn \<F> n) {ts. length ts = n \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)}"
proof (induct \<F> n rule: true_RRn.induct)
case (1 \<F>) show ?case
by (simp cong: conj_cong add: true_RR0_spec)
next
case (2 \<F>)
moreover have "{ts. length ts = 1 \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} = (\<lambda>t. [t]) ` \<T>\<^sub>G (fset \<F>)"
apply (intro equalityI subsetI)
subgoal for ts by (cases ts) auto
by auto
ultimately show ?case
using RR1_to_RRn_spec[OF term_automaton, of \<F>] by auto
next
case (3 \<F> n)
have [simp]: "{ts @ us |ts us. length ts = n \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>) \<and> length us = m \<and>
set us \<subseteq> \<T>\<^sub>G (fset \<F>)} = {ss. length ss = n + m \<and> set ss \<subseteq> \<T>\<^sub>G (fset \<F>)}" for n m
by (auto 0 4 intro!: exI[of _ "take n _", OF exI[of _ "drop n _"], of _ xs xs for xs]
dest!: subsetD[OF set_take_subset] subsetD[OF set_drop_subset])
show ?case using append_automaton[OF 3]
by simp
qed
subsection \<open>RR2 composition\<close>
abbreviation "RR2_to_RRn A \<equiv> fmap_funs_reg (\<lambda>(f, g). [f, g]) A"
abbreviation "RRn_to_RR2 A \<equiv> fmap_funs_reg (\<lambda>f. (f ! 0, f ! 1)) A"
definition rr2_compositon where
"rr2_compositon \<F> A B =
(let A' = RR2_to_RRn A in
let B' = RR2_to_RRn B in
let F = true_RRn \<F> 1 in
let CA = trim_reg (fmap_funs_reg (pad_with_Nones 2 1) (pair_automaton_reg A' F)) in
let CB = trim_reg (fmap_funs_reg (pad_with_Nones 1 2) (pair_automaton_reg F B')) in
let PI = trim_reg (fmap_funs_reg (\<lambda>xs. map ((!) xs) [1, 0, 2]) (reg_intersect CA CB)) in
RRn_to_RR2 (collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) PI))
)"
lemma list_length1E:
assumes "length xs = Suc 0" obtains x where "xs = [x]" using assms
by (cases xs) auto
lemma rr2_compositon:
assumes "\<R> \<subseteq> \<T>\<^sub>G (fset \<F>) \<times> \<T>\<^sub>G (fset \<F>)" "\<LL> \<subseteq> \<T>\<^sub>G (fset \<F>) \<times> \<T>\<^sub>G (fset \<F>)"
and "RR2_spec A \<R>" and "RR2_spec B \<LL>"
shows "RR2_spec (rr2_compositon \<F> A B) (\<R> O \<LL>)"
proof -
let ?R = "(\<lambda>(t, u). [t, u]) ` \<R>" let ?L = "(\<lambda>(t, u). [t, u]) ` \<LL>"
let ?A = "RR2_to_RRn A" let ?B = "RR2_to_RRn B" let ?F = "true_RRn \<F> 1"
let ?CA = "trim_reg (fmap_funs_reg (pad_with_Nones 2 1) (pair_automaton_reg ?A ?F))"
let ?CB = "trim_reg (fmap_funs_reg (pad_with_Nones 1 2) (pair_automaton_reg ?F ?B))"
let ?PI = "trim_reg (fmap_funs_reg (\<lambda>xs. map ((!) xs) [1, 0, 2]) (reg_intersect ?CA ?CB))"
let ?DR = "collapse_automaton_reg (fmap_funs_reg (drop_none_rule 1) ?PI)"
let ?Rs = "{ts @ us | ts us. ts \<in> ?R \<and> (\<exists>t. us = [t] \<and> t \<in> \<T>\<^sub>G (fset \<F>))}"
let ?Ls = "{us @ ts | ts us. ts \<in> ?L \<and> (\<exists>t. us = [t] \<and> t \<in> \<T>\<^sub>G (fset \<F>))}"
from RR2_to_RRn_spec assms(3, 4)
have rr2: "RRn_spec 2 ?A ?R" "RRn_spec 2 ?B ?L" by auto
have *: "{ts. length ts = 1 \<and> set ts \<subseteq> \<T>\<^sub>G (fset \<F>)} = {[t] | t. t \<in> \<T>\<^sub>G (fset \<F>)}"
by (auto elim!: list_length1E)
have F: "RRn_spec 1 ?F {[t] | t. t \<in> \<T>\<^sub>G (fset \<F>)}" using true_RRn_spec[of 1 \<F>] unfolding * .
have "RRn_spec 3 ?CA ?Rs" "RRn_spec 3 ?CB ?Ls"
using append_automaton[OF rr2(1) F] append_automaton[OF F rr2(2)]
by (auto simp: numeral_3_eq_3) (smt Collect_cong)
from permute_automaton[OF intersect_automaton[OF this], of "[1, 0, 2]"]
have "RRn_spec 3 ?PI ((\<lambda>xs. map ((!) xs) [1, 0, 2]) ` (?Rs \<inter> ?Ls))"
by (auto simp: atLeast0_lessThan_Suc insert_commute numeral_2_eq_2 numeral_3_eq_3)
from drop_automaton_reg[OF _ _ this, of 1]
have sp: "RRn_spec 2 ?DR (drop 1 ` (\<lambda>xs. map ((!) xs) [1, 0, 2]) ` (?Rs \<inter> ?Ls))"
by auto
{fix s assume "s \<in> (\<lambda>(t, u). [t, u]) ` (\<R> O \<LL>)"
then obtain t u v where comp: "s = [t, u]" "(t, v) \<in> \<R>" "(v, u) \<in> \<LL>"
by (auto simp: image_iff relcomp_unfold split!: prod.split)
then have "[t, v] \<in> ?R" "[v , u] \<in> ?L" "u \<in> \<T>\<^sub>G (fset \<F>)" "v \<in> \<T>\<^sub>G (fset \<F>)" "t \<in> \<T>\<^sub>G (fset \<F>)" using assms(1, 2)
by (auto simp: image_iff relcomp_unfold split!: prod.splits)
then have "[t, v, u] \<in> ?Rs" "[t, v, u] \<in> ?Ls"
apply (simp_all)
subgoal
apply (rule exI[of _ "[t, v]"], rule exI[of _ "[u]"])
apply simp
done
subgoal
apply (rule exI[of _ "[v, u]"], rule exI[of _ "[t]"])
apply simp
done
done
then have "s \<in> drop 1 ` (\<lambda>xs. map ((!) xs) [1, 0, 2]) ` (?Rs \<inter> ?Ls)" unfolding comp(1)
apply (simp add: image_def Bex_def)
apply (rule exI[of _ "[v, t, u]"]) apply simp
apply (rule exI[of _ "[t, v, u]"]) apply simp
done}
moreover have "drop 1 ` (\<lambda>xs. map ((!) xs) [1, 0, 2]) ` (?Rs \<inter> ?Ls) \<subseteq> (\<lambda>(t, u). [t, u]) ` (\<R> O \<LL>)"
by (auto simp: image_iff relcomp_unfold Bex_def split!: prod.splits)
ultimately have *: "drop 1 ` (\<lambda>xs. map ((!) xs) [1, 0, 2]) ` (?Rs \<inter> ?Ls) = (\<lambda>(t, u). [t, u]) ` (\<R> O \<LL>)"
by (simp add: subsetI subset_antisym)
have **: "(\<lambda>f. (f ! 0, f ! 1)) ` (\<lambda>(t, u). [t, u]) ` (\<R> O \<LL>) = \<R> O \<LL>"
by (force simp: image_def relcomp_unfold split!: prod.splits)
show ?thesis using sp unfolding *
using RRn_to_RR2_spec[where ?T = "(\<lambda>(t, u). [t, u]) ` (\<R> O \<LL>)" and ?A = ?DR]
unfolding ** by (auto simp: rr2_compositon_def Let_def image_iff)
qed
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Regular_Relation_Abstract_Impl.thy b/thys/Regular_Tree_Relations/Regular_Relation_Abstract_Impl.thy
--- a/thys/Regular_Tree_Relations/Regular_Relation_Abstract_Impl.thy
+++ b/thys/Regular_Tree_Relations/Regular_Relation_Abstract_Impl.thy
@@ -1,240 +1,240 @@
theory Regular_Relation_Abstract_Impl
imports Pair_Automaton
GTT_Transitive_Closure
RR2_Infinite_Q_infinity
Horn_Fset
begin
abbreviation TA_of_lists where
"TA_of_lists \<Delta> \<Delta>\<^sub>E \<equiv> TA (fset_of_list \<Delta>) (fset_of_list \<Delta>\<^sub>E)"
section \<open>Computing the epsilon transitions for the composition of GTT's\<close>
definition \<Delta>\<^sub>\<epsilon>_rules :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
"\<Delta>\<^sub>\<epsilon>_rules A B =
{zip ps qs \<rightarrow>\<^sub>h (p, q) |f ps p qs q. f ps \<rightarrow> p |\<in>| rules A \<and> f qs \<rightarrow> q |\<in>| rules B \<and> length ps = length qs} \<union>
{[(p, q)] \<rightarrow>\<^sub>h (p', q) |p p' q. (p, p') |\<in>| eps A} \<union>
{[(p, q)] \<rightarrow>\<^sub>h (p, q') |p q q'. (q, q') |\<in>| eps B}"
locale \<Delta>\<^sub>\<epsilon>_horn =
fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin
sublocale horn "\<Delta>\<^sub>\<epsilon>_rules A B" .
lemma \<Delta>\<^sub>\<epsilon>_infer0:
"infer0 = {(p, q) |f p q. f [] \<rightarrow> p |\<in>| rules A \<and> f [] \<rightarrow> q |\<in>| rules B}"
unfolding horn.infer0_def \<Delta>\<^sub>\<epsilon>_rules_def
using zip_Nil[of "[]"]
by auto (metis length_greater_0_conv zip_eq_Nil_iff)+
lemma \<Delta>\<^sub>\<epsilon>_infer1:
"infer1 pq X = {(p, q) |f ps p qs q. f ps \<rightarrow> p |\<in>| rules A \<and> f qs \<rightarrow> q |\<in>| rules B \<and> length ps = length qs \<and>
(fst pq, snd pq) \<in> set (zip ps qs) \<and> set (zip ps qs) \<subseteq> insert pq X} \<union>
{(p', snd pq) |p p'. (p, p') |\<in>| eps A \<and> p = fst pq} \<union>
{(fst pq, q') |q q'. (q, q') |\<in>| eps B \<and> q = snd pq}"
unfolding \<Delta>\<^sub>\<epsilon>_rules_def horn_infer1_union
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+
lemma \<Delta>\<^sub>\<epsilon>_sound:
"\<Delta>\<^sub>\<epsilon>_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using lr unfolding x
proof (induct)
case (\<Delta>\<^sub>\<epsilon>_set_cong f ps p qs q) show ?case
apply (intro infer[of "zip ps qs" "(p, q)"])
subgoal using \<Delta>\<^sub>\<epsilon>_set_cong(1-3) by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
subgoal using \<Delta>\<^sub>\<epsilon>_set_cong(3,5) by (auto simp: zip_nth_conv)
done
next
case (\<Delta>\<^sub>\<epsilon>_set_eps1 p p' q) then show ?case
by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
next
case (\<Delta>\<^sub>\<epsilon>_set_eps2 q q' p) then show ?case
by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
qed
next
case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using rl unfolding x
proof (induct)
case (infer as a) then show ?case
using \<Delta>\<^sub>\<epsilon>_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
\<Delta>\<^sub>\<epsilon>_set_eps1[of _ "fst a" A "snd a" B] \<Delta>\<^sub>\<epsilon>_set_eps2[of _ "snd a" B "fst a" A]
by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def)
qed
qed
end
section \<open>Computing the epsilon transitions for the transitive closure of GTT's\<close>
definition \<Delta>_trancl_rules :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
"\<Delta>_trancl_rules A B =
\<Delta>\<^sub>\<epsilon>_rules A B \<union> {[(p, q), (q, r)] \<rightarrow>\<^sub>h (p, r) |p q r. True}"
locale \<Delta>_trancl_horn =
fixes A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin
sublocale horn "\<Delta>_trancl_rules A B" .
lemma \<Delta>_trancl_infer0:
"infer0 = horn.infer0 (\<Delta>\<^sub>\<epsilon>_rules A B)"
by (auto simp: \<Delta>\<^sub>\<epsilon>_rules_def \<Delta>_trancl_rules_def horn.infer0_def)
lemma \<Delta>_trancl_infer1:
"infer1 pq X = horn.infer1 (\<Delta>\<^sub>\<epsilon>_rules A B) pq X \<union>
{(r, snd pq) |r p'. (r, p') \<in> X \<and> p' = fst pq} \<union>
{(fst pq, r) |q' r. (q', r) \<in> (insert pq X) \<and> q' = snd pq}"
unfolding \<Delta>_trancl_rules_def horn_infer1_union Un_assoc
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"] HOL.refl)
by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+
lemma \<Delta>_trancl_sound:
"\<Delta>_trancl_set A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using lr unfolding x
proof (induct)
case (\<Delta>_set_cong f ps p qs q) show ?case
apply (intro infer[of "zip ps qs" "(p, q)"])
subgoal using \<Delta>_set_cong(1-3) by (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
subgoal using \<Delta>_set_cong(3,5) by (auto simp: zip_nth_conv)
done
next
case (\<Delta>_set_eps1 p p' q) then show ?case
by (intro infer[of "[(p, q)]" "(p', q)"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
next
case (\<Delta>_set_eps2 q q' p) then show ?case
by (intro infer[of "[(p, q)]" "(p, q')"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
next
case (\<Delta>_set_trans p q r) then show ?case
by (intro infer[of "[(p,q), (q,r)]" "(p, r)"]) (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
qed
next
case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using rl unfolding x
proof (induct)
case (infer as a) then show ?case
using \<Delta>_set_cong[of _ "map fst as" "fst a" A "map snd as" "snd a" B]
\<Delta>_set_eps1[of _ "fst a" A "snd a" B] \<Delta>_set_eps2[of _ "snd a" B "fst a" A]
\<Delta>_set_trans[of "fst a" "snd (hd as)" A B "snd a"]
by (auto simp: \<Delta>_trancl_rules_def \<Delta>\<^sub>\<epsilon>_rules_def)
qed
qed
end
section \<open>Computing the epsilon transitions for the transitive closure of pair automata\<close>
definition \<Delta>_Atr_rules :: "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) horn set" where
"\<Delta>_Atr_rules Q A B =
{[] \<rightarrow>\<^sub>h (p, q) | p q. (p , q) |\<in>| Q} \<union>
{[(p, q),(r, v)] \<rightarrow>\<^sub>h (p, v) |p q r v. (q, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A}"
locale \<Delta>_Atr_horn =
fixes Q :: "('q \<times> 'q) fset" and A :: "('q, 'f) ta" and B :: "('q, 'f) ta"
begin
sublocale horn "\<Delta>_Atr_rules Q A B" .
lemma \<Delta>_Atr_infer0: "infer0 = fset Q"
- by (auto simp: horn.infer0_def \<Delta>_Atr_rules_def fmember.rep_eq)
+ by (auto simp: horn.infer0_def \<Delta>_Atr_rules_def fmember_iff_member_fset)
lemma \<Delta>_Atr_infer1:
"infer1 pq X = {(p, snd pq) | p q. (p, q) \<in> X \<and> (q, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} \<union>
{(fst pq, v) | q r v. (snd pq, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A \<and> (r, v) \<in> X} \<union>
{(fst pq, snd pq) | q . (snd pq, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A}"
unfolding \<Delta>_Atr_rules_def horn_infer1_union
by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+
lemma \<Delta>_Atr_sound:
"\<Delta>_Atrans_set Q A B = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using lr unfolding x
proof (induct)
case (base p q)
then show ?case
by (intro infer[of "[]" "(p, q)"]) (auto simp: \<Delta>_Atr_rules_def)
next
case (step p q r v)
then show ?case
by (intro infer[of "[(p, q), (r, v)]" "(p, v)"]) (auto simp: \<Delta>_Atr_rules_def)
qed
next
case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using rl unfolding x
proof (induct)
case (infer as a) then show ?case
using base[of "fst a" "snd a" Q A B]
using \<Delta>_Atrans_set.step[of "fst a" _ Q A B "snd a"]
by (auto simp: \<Delta>_Atr_rules_def) blast
qed
qed
end
section \<open>Computing the Q infinity set for the infinity predicate automaton\<close>
definition Q_inf_rules :: "('q, 'f option \<times> 'g option) ta \<Rightarrow> ('q \<times> 'q) horn set" where
"Q_inf_rules A =
{[] \<rightarrow>\<^sub>h (ps ! i, p) |f ps p i. (None, Some f) ps \<rightarrow> p |\<in>| rules A \<and> i < length ps} \<union>
{[(p, q)] \<rightarrow>\<^sub>h (p, r) |p q r. (q, r) |\<in>| eps A} \<union>
{[(p, q), (q, r)] \<rightarrow>\<^sub>h (p, r) |p q r. True}"
locale Q_horn =
fixes A :: "('q, 'f option \<times> 'g option) ta"
begin
sublocale horn "Q_inf_rules A" .
lemma Q_infer0:
"infer0 = {(ps ! i, p) |f ps p i. (None, Some f) ps \<rightarrow> p |\<in>| rules A \<and> i < length ps}"
unfolding horn.infer0_def Q_inf_rules_def by auto
lemma Q_infer1:
"infer1 pq X = {(fst pq, r) | q r. (q, r) |\<in>| eps A \<and> q = snd pq} \<union>
{(r, snd pq) |r p'. (r, p') \<in> X \<and> p' = fst pq} \<union>
{(fst pq, r) |q' r. (q', r) \<in> (insert pq X) \<and> q' = snd pq}"
unfolding Q_inf_rules_def horn_infer1_union
by (auto simp: horn.infer1_def simp flip: ex_simps(1)) force+
lemma Q_sound:
"Q_inf A = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using lr unfolding x
proof (induct)
case (trans p q r)
then show ?case
by (intro infer[of "[(p,q), (q,r)]" "(p, r)"])
(auto simp: Q_inf_rules_def)
next
case (rule f qs q i)
then show ?case
by (intro infer[of "[]" "(qs ! i, q)"])
(auto simp: Q_inf_rules_def)
next
case (eps p q r)
then show ?case
by (intro infer[of "[(p, q)]" "(p, r)"])
(auto simp: Q_inf_rules_def)
qed
next
case (rl x) obtain p q where x: "x = (p, q)" by (cases x)
show ?case using rl unfolding x
proof (induct)
case (infer as a) then show ?case
using Q_inf.eps[of "fst a" _ A "snd a"]
using Q_inf.trans[of "fst a" "snd (hd as)" A "snd a"]
by (auto simp: Q_inf_rules_def intro: Q_inf.rule)
qed
qed
end
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Regular_Relation_Impl.thy b/thys/Regular_Tree_Relations/Regular_Relation_Impl.thy
--- a/thys/Regular_Tree_Relations/Regular_Relation_Impl.thy
+++ b/thys/Regular_Tree_Relations/Regular_Relation_Impl.thy
@@ -1,301 +1,301 @@
theory Regular_Relation_Impl
imports Tree_Automata_Impl
Regular_Relation_Abstract_Impl
Horn_Fset
begin
section \<open>Computing the epsilon transitions for the composition of GTT's\<close>
definition \<Delta>\<^sub>\<epsilon>_infer0_cont where
"\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B =
(let arules = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>\<^sub>A) in
let brules = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>\<^sub>B) in
(map (map_prod r_rhs r_rhs) (filter (\<lambda>(ra, rb). r_root ra = r_root rb) (List.product arules brules))))"
definition \<Delta>\<^sub>\<epsilon>_infer1_cont where
"\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
(let (arules, aeps) = (sorted_list_of_fset \<Delta>\<^sub>A, sorted_list_of_fset \<Delta>\<^sub>A\<^sub>\<epsilon>) in
let (brules, beps) = (sorted_list_of_fset \<Delta>\<^sub>B, sorted_list_of_fset \<Delta>\<^sub>B\<^sub>\<epsilon>) in
let prules = List.product arules brules in
(\<lambda> pq bs.
map (map_prod r_rhs r_rhs) (filter (\<lambda>(ra, rb). case (ra, rb) of (TA_rule f ps p, TA_rule g qs q) \<Rightarrow>
f = g \<and> length ps = length qs \<and> (fst pq, snd pq) \<in> set (zip ps qs) \<and>
set (zip ps qs) \<subseteq> insert (fst pq, snd pq) (fset bs)) prules) @
map (\<lambda>(p, p'). (p', snd pq)) (filter (\<lambda>(p, p') \<Rightarrow> p = fst pq) aeps) @
map (\<lambda>(q, q'). (fst pq, q')) (filter (\<lambda>(q, q') \<Rightarrow> q = snd pq) beps)))"
locale \<Delta>\<^sub>\<epsilon>_fset =
fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin
abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
sublocale \<Delta>\<^sub>\<epsilon>_horn A B .
sublocale l: horn_fset "\<Delta>\<^sub>\<epsilon>_rules A B" "\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B" "\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
apply (unfold_locales)
unfolding \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_infer0 \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_infer1 \<Delta>\<^sub>\<epsilon>_infer0_cont_def \<Delta>\<^sub>\<epsilon>_infer1_cont_def set_append Un_assoc[symmetric]
unfolding sorted_list_of_fset_simps union_fset
subgoal
apply (auto split!: prod.splits ta_rule.splits simp: comp_def fset_of_list_elem r_rhs_def
- map_prod_def fSigma.rep_eq image_def Bex_def simp flip: fmember.rep_eq)
+ map_prod_def fSigma.rep_eq image_def Bex_def simp flip: fmember_iff_member_fset)
apply (metis ta_rule.exhaust_sel)
done
unfolding Let_def prod.case set_append Un_assoc
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
subgoal
- apply (auto split!: prod.splits ta_rule.splits simp flip: fmember.rep_eq )
+ apply (auto split!: prod.splits ta_rule.splits simp flip: fmember_iff_member_fset )
apply (smt (verit, del_insts) Pair_inject map_prod_imageI mem_Collect_eq ta_rule.inject ta_rule.sel(3))
done
-by (force simp add: image_def fmember.rep_eq split!: prod.splits)+
+by (force simp add: image_def fmember_iff_member_fset split!: prod.splits)+
lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition \<Delta>\<^sub>\<epsilon>_impl where
"\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = horn_fset_impl.saturate_impl (\<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B) (\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
lemma \<Delta>\<^sub>\<epsilon>_impl_sound:
assumes "\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
shows "xs = \<Delta>\<^sub>\<epsilon> (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
using \<Delta>\<^sub>\<epsilon>_fset.saturate_impl_sound[OF assms[unfolded \<Delta>\<^sub>\<epsilon>_impl_def]]
unfolding \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_sound[symmetric]
- by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq simp: fmember.rep_eq)
+ by (auto simp flip: \<Delta>\<^sub>\<epsilon>.rep_eq simp: fmember_iff_member_fset)
lemma \<Delta>\<^sub>\<epsilon>_impl_complete:
fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset"
and \<Delta>\<^sub>\<epsilon>\<^sub>A :: "('q \<times> 'q) fset" and \<Delta>\<^sub>\<epsilon>\<^sub>B :: "('q \<times> 'q) fset"
shows "\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>\<epsilon>\<^sub>A \<Delta>\<^sub>B \<Delta>\<^sub>\<epsilon>\<^sub>B \<noteq> None" unfolding \<Delta>\<^sub>\<epsilon>_impl_def
by (intro \<Delta>\<^sub>\<epsilon>_fset.saturate_impl_complete)
(auto simp flip: \<Delta>\<^sub>\<epsilon>_horn.\<Delta>\<^sub>\<epsilon>_sound)
lemma \<Delta>\<^sub>\<epsilon>_impl [code]:
"\<Delta>\<^sub>\<epsilon> (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = the (\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
using \<Delta>\<^sub>\<epsilon>_impl_complete[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>] \<Delta>\<^sub>\<epsilon>_impl_sound[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
by force
section \<open>Computing the epsilon transitions for the transitive closure of GTT's\<close>
definition \<Delta>_trancl_infer0 where
"\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B = \<Delta>\<^sub>\<epsilon>_infer0_cont \<Delta>\<^sub>A \<Delta>\<^sub>B"
definition \<Delta>_trancl_infer1 :: "('q :: linorder , 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset
\<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
"\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs =
\<Delta>\<^sub>\<epsilon>_infer1_cont \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs @
sorted_list_of_fset (
(\<lambda>(r, p'). (r, snd pq)) |`| (ffilter (\<lambda>(r, p') \<Rightarrow> p' = fst pq) bs) |\<union>|
(\<lambda>(q', r). (fst pq, r)) |`| (ffilter (\<lambda>(q', r) \<Rightarrow> q' = snd pq) (finsert pq bs)))"
locale \<Delta>_trancl_list =
fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin
abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
sublocale \<Delta>_trancl_horn A B .
sublocale l: horn_fset "\<Delta>_trancl_rules A B"
"\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B" "\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
apply (unfold_locales)
unfolding \<Delta>_trancl_rules_def horn_infer0_union horn_infer1_union
\<Delta>_trancl_infer0_def \<Delta>_trancl_infer1_def \<Delta>\<^sub>\<epsilon>_fset.infer set_append
by (auto simp flip: ex_simps(1) simp: horn.infer0_def horn.infer1_def intro!: arg_cong2[of _ _ _ _ "(\<union>)"])
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
horn_fset_impl.saturate_impl (\<Delta>_trancl_infer0 \<Delta>\<^sub>A \<Delta>\<^sub>B) (\<Delta>_trancl_infer1 \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
lemma \<Delta>_trancl_impl_sound:
assumes "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
shows "xs = \<Delta>_trancl (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
using \<Delta>_trancl_list.saturate_impl_sound[OF assms[unfolded \<Delta>_trancl_impl_def]]
unfolding \<Delta>_trancl_horn.\<Delta>_trancl_sound[symmetric] \<Delta>_trancl.rep_eq[symmetric]
- by (auto simp: fmember.rep_eq)
+ by (auto simp: fmember_iff_member_fset)
lemma \<Delta>_trancl_impl_complete:
fixes \<Delta>\<^sub>A :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset"
and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
shows "\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<noteq> None"
unfolding \<Delta>_trancl_impl_def
by (intro \<Delta>_trancl_list.saturate_impl_complete)
(auto simp flip: \<Delta>_trancl_horn.\<Delta>_trancl_sound)
lemma \<Delta>_trancl_impl [code]:
"\<Delta>_trancl (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = (the (\<Delta>_trancl_impl \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>))"
using \<Delta>_trancl_impl_complete[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
using \<Delta>_trancl_impl_sound[of \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
by force
section \<open>Computing the epsilon transitions for the transitive closure of pair automata\<close>
definition \<Delta>_Atr_infer1_cont :: "('q :: linorder \<times> 'q) fset \<Rightarrow> ('q, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow>
('q, 'f) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
"\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
(let G = sorted_list_of_fset (the (\<Delta>\<^sub>\<epsilon>_impl \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>)) in
(\<lambda> pq bs.
(let bs_list = sorted_list_of_fset bs in
map (\<lambda> (p, q). (fst p, snd pq)) (filter (\<lambda> (p, q). snd p = fst q \<and> snd q = fst pq) (List.product bs_list G)) @
map (\<lambda> (p, q). (fst pq, snd q)) (filter (\<lambda> (p, q). snd p = fst q \<and> fst p = snd pq) (List.product G bs_list)) @
map (\<lambda> (p, q). (fst pq, snd pq)) (filter (\<lambda> (p, q). snd pq = p \<and> fst pq = q) G))))"
locale \<Delta>_Atr_fset =
fixes Q :: "('q :: linorder \<times> 'q) fset" and \<Delta>\<^sub>A :: "('q, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>A\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
and \<Delta>\<^sub>B :: "('q, 'f) ta_rule fset" and \<Delta>\<^sub>B\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin
abbreviation A where "A \<equiv> TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>"
abbreviation B where "B \<equiv> TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
sublocale \<Delta>_Atr_horn Q A B .
lemma infer1:
"infer1 pq (fset bs) = set (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs)"
proof -
have "{(p, snd pq) | p q. (p, q) \<in> (fset bs) \<and> (q, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} \<union>
{(fst pq, v) | q r v. (snd pq, r) |\<in>| \<Delta>\<^sub>\<epsilon> B A \<and> (r, v) \<in> (fset bs)} \<union>
{(fst pq, snd pq) | q . (snd pq, fst pq) |\<in>| \<Delta>\<^sub>\<epsilon> B A} = set (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> pq bs)"
unfolding \<Delta>_Atr_infer1_cont_def set_append Un_assoc[symmetric] Let_def
unfolding sorted_list_of_fset_simps union_fset
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
- apply (simp_all add: fSigma_repeq fmember.rep_eq flip: \<Delta>\<^sub>\<epsilon>_impl fset_of_list_elem)
+ apply (simp_all add: fSigma_repeq fmember_iff_member_fset flip: \<Delta>\<^sub>\<epsilon>_impl fset_of_list_elem)
apply force+
done
then show ?thesis
using \<Delta>_Atr_horn.\<Delta>_Atr_infer1[of Q A B pq "fset bs"]
by simp
qed
sublocale l: horn_fset "\<Delta>_Atr_rules Q A B" "sorted_list_of_fset Q" "\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>"
apply (unfold_locales)
unfolding \<Delta>_Atr_horn.\<Delta>_Atr_infer0 fset_of_list.rep_eq
using infer1
by auto
lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> =
horn_fset_impl.saturate_impl (sorted_list_of_fset Q) (\<Delta>_Atr_infer1_cont Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
lemma \<Delta>_Atr_impl_sound:
assumes "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> = Some xs"
shows "xs = \<Delta>_Atrans Q (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>)"
using \<Delta>_Atr_fset.saturate_impl_sound[OF assms[unfolded \<Delta>_Atr_impl_def]]
unfolding \<Delta>_Atr_horn.\<Delta>_Atr_sound[symmetric] \<Delta>_Atrans.rep_eq[symmetric]
by (simp add: fset_inject)
lemma \<Delta>_Atr_impl_complete:
shows "\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon> \<noteq> None" unfolding \<Delta>_Atr_impl_def
by (intro \<Delta>_Atr_fset.saturate_impl_complete)
(auto simp: finite_\<Delta>_Atrans_set simp flip: \<Delta>_Atr_horn.\<Delta>_Atr_sound)
lemma \<Delta>_Atr_impl [code]:
"\<Delta>_Atrans Q (TA \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon>) (TA \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>) = (the (\<Delta>_Atr_impl Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>))"
using \<Delta>_Atr_impl_complete[of Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>] \<Delta>_Atr_impl_sound[of Q \<Delta>\<^sub>A \<Delta>\<^sub>A\<^sub>\<epsilon> \<Delta>\<^sub>B \<Delta>\<^sub>B\<^sub>\<epsilon>]
by force
section \<open>Computing the Q infinity set for the infinity predicate automaton\<close>
definition Q_infer0_cont :: "('q :: linorder, 'f :: linorder option \<times> 'g :: linorder option) ta_rule fset \<Rightarrow> ('q \<times> 'q) list" where
"Q_infer0_cont \<Delta> = concat (sorted_list_of_fset (
(\<lambda> r. case r of TA_rule f ps p \<Rightarrow> map (\<lambda> x. Pair x p) ps) |`|
(ffilter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> fst f = None \<and> snd f \<noteq> None \<and> ps \<noteq> []) \<Delta>)))"
definition Q_infer1_cont :: "('q ::linorder \<times> 'q) fset \<Rightarrow> 'q \<times> 'q \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q \<times> 'q) list" where
"Q_infer1_cont \<Delta>\<epsilon> =
(let eps = sorted_list_of_fset \<Delta>\<epsilon> in
(\<lambda> pq bs.
let bs_list = sorted_list_of_fset bs in
map (\<lambda> (q, r). (fst pq, r)) (filter (\<lambda> (q, r) \<Rightarrow> q = snd pq) eps) @
map (\<lambda>(r, p'). (r, snd pq)) (filter (\<lambda>(r, p') \<Rightarrow> p' = fst pq) bs_list) @
map (\<lambda>(q', r). (fst pq, r)) (filter (\<lambda>(q', r) \<Rightarrow> q' = snd pq) (pq # bs_list))))"
locale Q_fset =
fixes \<Delta> :: "('q :: linorder, 'f :: linorder option \<times> 'g :: linorder option) ta_rule fset" and \<Delta>\<epsilon> :: "('q \<times> 'q) fset"
begin
abbreviation A where "A \<equiv> TA \<Delta> \<Delta>\<epsilon>"
sublocale Q_horn A .
sublocale l: horn_fset "Q_inf_rules A" "Q_infer0_cont \<Delta>" "Q_infer1_cont \<Delta>\<epsilon>"
apply (unfold_locales)
unfolding Q_horn.Q_infer0 Q_horn.Q_infer1 Q_infer0_cont_def Q_infer1_cont_def set_append Un_assoc[symmetric]
unfolding sorted_list_of_fset_simps union_fset
subgoal
- apply (auto simp add: Bex_def fmember.rep_eq split!: ta_rule.splits)
+ apply (auto simp add: Bex_def fmember_iff_member_fset split!: ta_rule.splits)
apply (rule_tac x = "TA_rule (lift_None_Some f) ps p" in exI)
apply (force dest: in_set_idx)+
done
unfolding Let_def set_append Un_assoc
- by (intro arg_cong2[of _ _ _ _ "(\<union>)"]) (auto simp add: fmember.rep_eq)
+ by (intro arg_cong2[of _ _ _ _ "(\<union>)"]) (auto simp add: fmember_iff_member_fset)
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition Q_impl where
"Q_impl \<Delta> \<Delta>\<epsilon> = horn_fset_impl.saturate_impl (Q_infer0_cont \<Delta>) (Q_infer1_cont \<Delta>\<epsilon>)"
lemma Q_impl_sound:
"Q_impl \<Delta> \<Delta>\<epsilon> = Some xs \<Longrightarrow> fset xs = Q_inf (TA \<Delta> \<Delta>\<epsilon>)"
using Q_fset.saturate_impl_sound unfolding Q_impl_def Q_horn.Q_sound .
lemma Q_impl_complete:
"Q_impl \<Delta> \<Delta>\<epsilon> \<noteq> None"
proof -
let ?A = "TA \<Delta> \<Delta>\<epsilon>"
have *: "Q_inf ?A \<subseteq> fset (\<Q> ?A |\<times>| \<Q> ?A)"
- by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember.rep_eq)
+ by (auto simp add: Q_inf_states_ta_states(1, 2) subrelI simp flip: fmember_iff_member_fset)
have "finite (Q_inf ?A)"
by (intro finite_subset[OF *]) simp
then show ?thesis unfolding Q_impl_def
by (intro Q_fset.saturate_impl_complete) (auto simp: Q_horn.Q_sound)
qed
definition "Q_infinity_impl \<Delta> \<Delta>\<epsilon> = (let Q = the (Q_impl \<Delta> \<Delta>\<epsilon>) in
snd |`| ((ffilter (\<lambda> (p, q). p = q) Q) |O| Q))"
lemma Q_infinity_impl_fmember:
"q |\<in>| Q_infinity_impl \<Delta> \<Delta>\<epsilon> \<longleftrightarrow> (\<exists> p. (p, p) |\<in>| the (Q_impl \<Delta> \<Delta>\<epsilon>) \<and>
(p, q) |\<in>| the (Q_impl \<Delta> \<Delta>\<epsilon>))"
unfolding Q_infinity_impl_def
by (auto simp: Let_def fimage_iff fBex_def) fastforce
lemma loop_sound_correct [simp]:
"fset (Q_infinity_impl \<Delta> \<Delta>\<epsilon>) = Q_inf_e (TA \<Delta> \<Delta>\<epsilon>)"
proof -
obtain Q where [simp]: "Q_impl \<Delta> \<Delta>\<epsilon> = Some Q" using Q_impl_complete[of \<Delta> \<Delta>\<epsilon>]
by blast
have "fset Q = (Q_inf (TA \<Delta> \<Delta>\<epsilon>))"
using Q_impl_sound[of \<Delta> \<Delta>\<epsilon>]
by (auto simp: fset_of_list.rep_eq)
then show ?thesis
by (force simp: Q_infinity_impl_fmember Let_def fset_of_list_elem
- fset_of_list.rep_eq simp flip: fmember.rep_eq)
+ fset_of_list.rep_eq simp flip: fmember_iff_member_fset)
qed
lemma fQ_inf_e_code [code]:
"fQ_inf_e (TA \<Delta> \<Delta>\<epsilon>) = Q_infinity_impl \<Delta> \<Delta>\<epsilon>"
using loop_sound_correct
- by (auto simp add: fQ_inf_e.rep_eq fmember.rep_eq)
+ by (auto simp add: fQ_inf_e.rep_eq fmember_iff_member_fset)
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata.thy b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata.thy
--- a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata.thy
+++ b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata.thy
@@ -1,2184 +1,2184 @@
section \<open>Tree automaton\<close>
theory Tree_Automata
imports FSet_Utils
"HOL-Library.Product_Lexorder"
"HOL-Library.Option_ord"
begin
subsection \<open>Tree automaton definition and functionality\<close>
datatype ('q, 'f) ta_rule = TA_rule (r_root: 'f) (r_lhs_states: "'q list") (r_rhs: 'q) ("_ _ \<rightarrow> _" [51, 51, 51] 52)
datatype ('q, 'f) ta = TA (rules: "('q, 'f) ta_rule fset") (eps: "('q \<times> 'q) fset")
text \<open>In many application we are interested in specific subset of all terms. If these
can be captured by a tree automaton (identified by a state) then we say the set is regular.
This gives the motivation for the following definition\<close>
datatype ('q, 'f) reg = Reg (fin: "'q fset") (ta: "('q, 'f) ta")
text \<open>The state set induced by a tree automaton is implicit in our representation.
We compute it based on the rules and epsilon transitions of a given tree automaton\<close>
abbreviation rule_arg_states where "rule_arg_states \<Delta> \<equiv> |\<Union>| ((fset_of_list \<circ> r_lhs_states) |`| \<Delta>)"
abbreviation rule_target_states where "rule_target_states \<Delta> \<equiv> (r_rhs |`| \<Delta>)"
definition rule_states where "rule_states \<Delta> \<equiv> rule_arg_states \<Delta> |\<union>| rule_target_states \<Delta>"
definition eps_states where "eps_states \<Delta>\<^sub>\<epsilon> \<equiv> (fst |`| \<Delta>\<^sub>\<epsilon>) |\<union>| (snd |`| \<Delta>\<^sub>\<epsilon>)"
definition "\<Q> \<A> = rule_states (rules \<A>) |\<union>| eps_states (eps \<A>)"
abbreviation "\<Q>\<^sub>r \<A> \<equiv> \<Q> (ta \<A>)"
definition ta_rhs_states :: "('q, 'f) ta \<Rightarrow> 'q fset" where
"ta_rhs_states \<A> \<equiv> {| q | p q. (p |\<in>| rule_target_states (rules \<A>)) \<and> (p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)|}"
definition "ta_sig \<A> = (\<lambda> r. (r_root r, length (r_lhs_states r))) |`| (rules \<A>)"
subsubsection \<open>Rechability of a term induced by a tree automaton\<close>
(* The reachable states of some term. *)
fun ta_der :: "('q, 'f) ta \<Rightarrow> ('f, 'q) term \<Rightarrow> 'q fset" where
"ta_der \<A> (Var q) = {|q' | q'. q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+| |}"
| "ta_der \<A> (Fun f ts) = {|q' | q' q qs.
TA_rule f qs q |\<in>| (rules \<A>) \<and> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|) \<and> length qs = length ts \<and>
(\<forall> i < length ts. qs ! i |\<in>| ta_der \<A> (ts ! i))|}"
(* The reachable mixed terms of some term. *)
fun ta_der' :: "('q,'f) ta \<Rightarrow> ('f,'q) term \<Rightarrow> ('f,'q) term fset" where
"ta_der' \<A> (Var p) = {|Var q | q. p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+| |}"
| "ta_der' \<A> (Fun f ts) = {|Var q | q. q |\<in>| ta_der \<A> (Fun f ts)|} |\<union>|
{|Fun f ss | ss. length ss = length ts \<and>
(\<forall>i < length ts. ss ! i |\<in>| ta_der' \<A> (ts ! i))|}"
text \<open>Sometimes it is useful to analyse a concrete computation done by a tree automaton.
To do this we introduce the notion of run which keeps track which states are computed in each
subterm to reach a certain state.\<close>
abbreviation "ex_rule_state \<equiv> fst \<circ> groot_sym"
abbreviation "ex_comp_state \<equiv> snd \<circ> groot_sym"
inductive run for \<A> where
step: "length qs = length ts \<Longrightarrow> (\<forall> i < length ts. run \<A> (qs ! i) (ts ! i)) \<Longrightarrow>
TA_rule f (map ex_comp_state qs) q |\<in>| (rules \<A>) \<Longrightarrow> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|) \<Longrightarrow>
run \<A> (GFun (q, q') qs) (GFun f ts)"
subsubsection \<open>Language acceptance\<close>
definition ta_lang :: "'q fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('f, 'v) terms" where
[code del]: "ta_lang Q \<A> = {adapt_vars t | t. ground t \<and> Q |\<inter>| ta_der \<A> t \<noteq> {||}}"
definition gta_der where
"gta_der \<A> t = ta_der \<A> (term_of_gterm t)"
definition gta_lang where
"gta_lang Q \<A> = {t. Q |\<inter>| gta_der \<A> t \<noteq> {||}}"
definition \<L> where
"\<L> \<A> = gta_lang (fin \<A>) (ta \<A>)"
definition reg_Restr_Q\<^sub>f where
"reg_Restr_Q\<^sub>f R = Reg (fin R |\<inter>| \<Q>\<^sub>r R) (ta R)"
subsubsection \<open>Trimming\<close>
definition ta_restrict where
"ta_restrict \<A> Q = TA {| TA_rule f qs q| f qs q. TA_rule f qs q |\<in>| rules \<A> \<and> fset_of_list qs |\<subseteq>| Q \<and> q |\<in>| Q |} (fRestr (eps \<A>) Q)"
definition ta_reachable :: "('q, 'f) ta \<Rightarrow> 'q fset" where
"ta_reachable \<A> = {|q| q. \<exists> t. ground t \<and> q |\<in>| ta_der \<A> t |}"
definition ta_productive :: "'q fset \<Rightarrow> ('q,'f) ta \<Rightarrow> 'q fset" where
"ta_productive P \<A> \<equiv> {|q| q q' C. q' |\<in>| ta_der \<A> (C\<langle>Var q\<rangle>) \<and> q' |\<in>| P |}"
text \<open>An automaton is trim if all its states are reachable and productive.\<close>
definition ta_is_trim :: "'q fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> bool" where
"ta_is_trim P \<A> \<equiv> \<forall> q. q |\<in>| \<Q> \<A> \<longrightarrow> q |\<in>| ta_reachable \<A> \<and> q |\<in>| ta_productive P \<A>"
definition reg_is_trim :: "('q, 'f) reg \<Rightarrow> bool" where
"reg_is_trim R \<equiv> ta_is_trim (fin R) (ta R)"
text \<open>We obtain a trim automaton by restriction it to reachable and productive states.\<close>
abbreviation ta_only_reach :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta" where
"ta_only_reach \<A> \<equiv> ta_restrict \<A> (ta_reachable \<A>)"
abbreviation ta_only_prod :: "'q fset \<Rightarrow> ('q,'f) ta \<Rightarrow> ('q,'f) ta" where
"ta_only_prod P \<A> \<equiv> ta_restrict \<A> (ta_productive P \<A>)"
definition reg_reach where
"reg_reach R = Reg (fin R) (ta_only_reach (ta R))"
definition reg_prod where
"reg_prod R = Reg (fin R) (ta_only_prod (fin R) (ta R))"
definition trim_ta :: "'q fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta" where
"trim_ta P \<A> = ta_only_prod P (ta_only_reach \<A>)"
definition trim_reg where
"trim_reg R = Reg (fin R) (trim_ta (fin R) (ta R))"
subsubsection \<open>Mapping over tree automata\<close>
definition fmap_states_ta :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'f) ta \<Rightarrow> ('b, 'f) ta" where
"fmap_states_ta f \<A> = TA (map_ta_rule f id |`| rules \<A>) (map_both f |`| eps \<A>)"
definition fmap_funs_ta :: "('f \<Rightarrow> 'g) \<Rightarrow> ('a, 'f) ta \<Rightarrow> ('a, 'g) ta" where
"fmap_funs_ta f \<A> = TA (map_ta_rule id f |`| rules \<A>) (eps \<A>)"
definition fmap_states_reg :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a, 'f) reg \<Rightarrow> ('b, 'f) reg" where
"fmap_states_reg f R = Reg (f |`| fin R) (fmap_states_ta f (ta R))"
definition fmap_funs_reg :: "('f \<Rightarrow> 'g) \<Rightarrow> ('a, 'f) reg \<Rightarrow> ('a, 'g) reg" where
"fmap_funs_reg f R = Reg (fin R) (fmap_funs_ta f (ta R))"
subsubsection \<open>Product construction (language intersection)\<close>
definition prod_ta_rules :: "('q1,'f) ta \<Rightarrow> ('q2,'f) ta \<Rightarrow> ('q1 \<times> 'q2, 'f) ta_rule fset" where
"prod_ta_rules \<A> \<B> = {| TA_rule f qs q | f qs q. TA_rule f (map fst qs) (fst q) |\<in>| rules \<A> \<and>
TA_rule f (map snd qs) (snd q) |\<in>| rules \<B>|}"
declare prod_ta_rules_def [simp]
definition prod_epsLp where
"prod_epsLp \<A> \<B> = (\<lambda> (p, q). (fst p, fst q) |\<in>| eps \<A> \<and> snd p = snd q \<and> snd q |\<in>| \<Q> \<B>)"
definition prod_epsRp where
"prod_epsRp \<A> \<B> = (\<lambda> (p, q). (snd p, snd q) |\<in>| eps \<B> \<and> fst p = fst q \<and> fst q |\<in>| \<Q> \<A>)"
definition prod_ta :: "('q1,'f) ta \<Rightarrow> ('q2,'f) ta \<Rightarrow> ('q1 \<times> 'q2, 'f) ta" where
"prod_ta \<A> \<B> = TA (prod_ta_rules \<A> \<B>)
(fCollect (prod_epsLp \<A> \<B>) |\<union>| fCollect (prod_epsRp \<A> \<B>))"
definition reg_intersect where
"reg_intersect R L = Reg (fin R |\<times>| fin L) (prod_ta (ta R) (ta L))"
subsubsection \<open>Union construction (language union)\<close>
definition ta_union where
"ta_union \<A> \<B> = TA (rules \<A> |\<union>| rules \<B>) (eps \<A> |\<union>| eps \<B>)"
definition reg_union where
"reg_union R L = Reg (Inl |`| (fin R |\<inter>| \<Q>\<^sub>r R) |\<union>| Inr |`| (fin L |\<inter>| \<Q>\<^sub>r L))
(ta_union (fmap_states_ta Inl (ta R)) (fmap_states_ta Inr (ta L)))"
subsubsection \<open>Epsilon free and tree automaton accepting empty language\<close>
definition eps_free_rulep where
"eps_free_rulep \<A> = (\<lambda> r. \<exists> f qs q q'. r = TA_rule f qs q' \<and> TA_rule f qs q |\<in>| rules \<A> \<and> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|))"
definition eps_free :: "('q, 'f) ta \<Rightarrow> ('q, 'f) ta" where
"eps_free \<A> = TA (fCollect (eps_free_rulep \<A>)) {||}"
definition is_ta_eps_free :: "('q, 'f) ta \<Rightarrow> bool" where
"is_ta_eps_free \<A> \<longleftrightarrow> eps \<A> = {||}"
definition ta_empty :: "'q fset \<Rightarrow> ('q,'f) ta \<Rightarrow> bool" where
"ta_empty Q \<A> \<longleftrightarrow> ta_reachable \<A> |\<inter>| Q |\<subseteq>| {||}"
definition eps_free_reg where
"eps_free_reg R = Reg (fin R) (eps_free (ta R))"
definition reg_empty where
"reg_empty R = ta_empty (fin R) (ta R)"
subsubsection \<open>Relabeling tree automaton states to natural numbers\<close>
definition map_fset_to_nat :: "('a :: linorder) fset \<Rightarrow> 'a \<Rightarrow> nat" where
"map_fset_to_nat X = (\<lambda>x. the (mem_idx x (sorted_list_of_fset X)))"
definition map_fset_fset_to_nat :: "('a :: linorder) fset fset \<Rightarrow> 'a fset \<Rightarrow> nat" where
"map_fset_fset_to_nat X = (\<lambda>x. the (mem_idx (sorted_list_of_fset x) (sorted_list_of_fset (sorted_list_of_fset |`| X))))"
definition relabel_ta :: "('q :: linorder, 'f) ta \<Rightarrow> (nat, 'f) ta" where
"relabel_ta \<A> = fmap_states_ta (map_fset_to_nat (\<Q> \<A>)) \<A>"
definition relabel_Q\<^sub>f :: "('q :: linorder) fset \<Rightarrow> ('q :: linorder, 'f) ta \<Rightarrow> nat fset" where
"relabel_Q\<^sub>f Q \<A> = map_fset_to_nat (\<Q> \<A>) |`| (Q |\<inter>| \<Q> \<A>)"
definition relabel_reg :: "('q :: linorder, 'f) reg \<Rightarrow> (nat, 'f) reg" where
"relabel_reg R = Reg (relabel_Q\<^sub>f (fin R) (ta R)) (relabel_ta (ta R))"
\<comment> \<open>The instantiation of $<$ and $\leq$ for finite sets are $\mid \subset \mid$ and $\mid \subseteq \mid$
which don't give rise to a total order and therefore it cannot be an instance of the type class linorder.
However taking the lexographic order of the sorted list of each finite set gives rise
to a total order. Therefore we provide a relabeling for tree automata where the states
are finite sets. This allows us to relabel the well known power set construction.\<close>
definition relabel_fset_ta :: "(('q :: linorder) fset, 'f) ta \<Rightarrow> (nat, 'f) ta" where
"relabel_fset_ta \<A> = fmap_states_ta (map_fset_fset_to_nat (\<Q> \<A>)) \<A>"
definition relabel_fset_Q\<^sub>f :: "('q :: linorder) fset fset \<Rightarrow> (('q :: linorder) fset, 'f) ta \<Rightarrow> nat fset" where
"relabel_fset_Q\<^sub>f Q \<A> = map_fset_fset_to_nat (\<Q> \<A>) |`| (Q |\<inter>| \<Q> \<A>)"
definition relable_fset_reg :: "(('q :: linorder) fset, 'f) reg \<Rightarrow> (nat, 'f) reg" where
"relable_fset_reg R = Reg (relabel_fset_Q\<^sub>f (fin R) (ta R)) (relabel_fset_ta (ta R))"
definition "srules \<A> = fset (rules \<A>)"
definition "seps \<A> = fset (eps \<A>)"
lemma rules_transfer [transfer_rule]:
"rel_fun (=) (pcr_fset (=)) srules rules" unfolding rel_fun_def
by (auto simp add: cr_fset_def fset.pcr_cr_eq srules_def)
lemma eps_transfer [transfer_rule]:
"rel_fun (=) (pcr_fset (=)) seps eps" unfolding rel_fun_def
by (auto simp add: cr_fset_def fset.pcr_cr_eq seps_def)
lemma TA_equalityI:
"rules \<A> = rules \<B> \<Longrightarrow> eps \<A> = eps \<B> \<Longrightarrow> \<A> = \<B>"
using ta.expand by blast
lemma rule_states_code [code]:
"rule_states \<Delta> = |\<Union>| ((\<lambda> r. finsert (r_rhs r) (fset_of_list (r_lhs_states r))) |`| \<Delta>)"
unfolding rule_states_def
by fastforce
lemma eps_states_code [code]:
"eps_states \<Delta>\<^sub>\<epsilon> = |\<Union>| ((\<lambda> (q,q'). {|q,q'|}) |`| \<Delta>\<^sub>\<epsilon>)" (is "?Ls = ?Rs")
unfolding eps_states_def
by (force simp add: case_prod_beta')
lemma rule_states_empty [simp]:
"rule_states {||} = {||}"
by (auto simp: rule_states_def)
lemma eps_states_empty [simp]:
"eps_states {||} = {||}"
by (auto simp: eps_states_def)
lemma rule_states_union [simp]:
"rule_states (\<Delta> |\<union>| \<Gamma>) = rule_states \<Delta> |\<union>| rule_states \<Gamma>"
unfolding rule_states_def
by fastforce
lemma rule_states_mono:
"\<Delta> |\<subseteq>| \<Gamma> \<Longrightarrow> rule_states \<Delta> |\<subseteq>| rule_states \<Gamma>"
unfolding rule_states_def
by force
lemma eps_states_union [simp]:
"eps_states (\<Delta> |\<union>| \<Gamma>) = eps_states \<Delta> |\<union>| eps_states \<Gamma>"
unfolding eps_states_def
by auto
lemma eps_states_image [simp]:
"eps_states (map_both f |`| \<Delta>\<^sub>\<epsilon>) = f |`| eps_states \<Delta>\<^sub>\<epsilon>"
unfolding eps_states_def map_prod_def
by (force simp: fimage_iff)
lemma eps_states_mono:
"\<Delta> |\<subseteq>| \<Gamma> \<Longrightarrow> eps_states \<Delta> |\<subseteq>| eps_states \<Gamma>"
unfolding eps_states_def
by transfer auto
lemma eps_statesI [intro]:
"(p, q) |\<in>| \<Delta> \<Longrightarrow> p |\<in>| eps_states \<Delta>"
"(p, q) |\<in>| \<Delta> \<Longrightarrow> q |\<in>| eps_states \<Delta>"
unfolding eps_states_def
by (auto simp add: rev_fimage_eqI)
lemma eps_statesE [elim]:
assumes "p |\<in>| eps_states \<Delta>"
obtains q where "(p, q) |\<in>| \<Delta> \<or> (q, p) |\<in>| \<Delta>" using assms
unfolding eps_states_def
by (transfer, auto)+
lemma rule_statesE [elim]:
assumes "q |\<in>| rule_states \<Delta>"
obtains f ps p where "TA_rule f ps p |\<in>| \<Delta>" "q |\<in>| (fset_of_list ps) \<or> q = p" using assms
proof -
assume ass: "(\<And>f ps p. f ps \<rightarrow> p |\<in>| \<Delta> \<Longrightarrow> q |\<in>| fset_of_list ps \<or> q = p \<Longrightarrow> thesis)"
from assms obtain r where "r |\<in>| \<Delta>" "q |\<in>| fset_of_list (r_lhs_states r) \<or> q = r_rhs r"
by (auto simp: rule_states_def)
then show thesis using ass
by (cases r) auto
qed
lemma rule_statesI [intro]:
assumes "r |\<in>| \<Delta>" "q |\<in>| finsert (r_rhs r) (fset_of_list (r_lhs_states r))"
shows "q |\<in>| rule_states \<Delta>" using assms
by (auto simp: rule_states_def)
text \<open>Destruction rule for states\<close>
lemma rule_statesD:
"r |\<in>| (rules \<A>) \<Longrightarrow> r_rhs r |\<in>| \<Q> \<A>" "f qs \<rightarrow> q |\<in>| (rules \<A>) \<Longrightarrow> q |\<in>| \<Q> \<A>"
"r |\<in>| (rules \<A>) \<Longrightarrow> p |\<in>| fset_of_list (r_lhs_states r) \<Longrightarrow> p |\<in>| \<Q> \<A>"
"f qs \<rightarrow> q |\<in>| (rules \<A>) \<Longrightarrow> p |\<in>| fset_of_list qs \<Longrightarrow> p |\<in>| \<Q> \<A>"
by (force simp: \<Q>_def rule_states_def fimage_iff)+
lemma eps_states [simp]: "(eps \<A>) |\<subseteq>| \<Q> \<A> |\<times>| \<Q> \<A>"
unfolding \<Q>_def eps_states_def rule_states_def
by (auto simp add: rev_fimage_eqI)
lemma eps_statesD: "(p, q) |\<in>| (eps \<A>) \<Longrightarrow> p |\<in>| \<Q> \<A> \<and> q |\<in>| \<Q> \<A>"
using eps_states by (auto simp add: \<Q>_def)
lemma eps_trancl_statesD:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> p |\<in>| \<Q> \<A> \<and> q |\<in>| \<Q> \<A>"
by (induct rule: ftrancl_induct) (auto dest: eps_statesD)
lemmas eps_dest_all = eps_statesD eps_trancl_statesD
text \<open>Mapping over function symbols/states\<close>
lemma finite_Collect_ta_rule:
"finite {TA_rule f qs q | f qs q. TA_rule f qs q |\<in>| rules \<A>}" (is "finite ?S")
proof -
have "{f qs \<rightarrow> q |f qs q. f qs \<rightarrow> q |\<in>| rules \<A>} \<subseteq> fset (rules \<A>)"
- by (auto simp flip: fmember.rep_eq)
+ by (auto simp flip: fmember_iff_member_fset)
from finite_subset[OF this] show ?thesis by simp
qed
lemma map_ta_rule_finite:
"finite \<Delta> \<Longrightarrow> finite {TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q \<in> \<Delta>}"
proof (induct rule: finite.induct)
case (insertI A a)
have union: "{TA_rule (g h) (map f qs) (f q) |h qs q. TA_rule h qs q \<in> insert a A} =
{TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q = a} \<union> {TA_rule (g h) (map f qs) (f q) |h qs q. TA_rule h qs q \<in> A}"
by auto
have "finite {g h map f qs \<rightarrow> f q |h qs q. h qs \<rightarrow> q = a}"
by (cases a) auto
from finite_UnI[OF this insertI(2)] show ?case unfolding union .
qed auto
-lemmas map_ta_rule_fset_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" for \<Delta>, simplified, unfolded fmember.rep_eq[symmetric]]
-lemmas map_ta_rule_states_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" id for \<Delta>, simplified, unfolded fmember.rep_eq[symmetric]]
-lemmas map_ta_rule_funsym_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" _ id for \<Delta>, simplified, unfolded fmember.rep_eq[symmetric]]
+lemmas map_ta_rule_fset_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" for \<Delta>, simplified, unfolded fmember_iff_member_fset[symmetric]]
+lemmas map_ta_rule_states_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" id for \<Delta>, simplified, unfolded fmember_iff_member_fset[symmetric]]
+lemmas map_ta_rule_funsym_finite [simp] = map_ta_rule_finite[of "fset \<Delta>" _ id for \<Delta>, simplified, unfolded fmember_iff_member_fset[symmetric]]
lemma map_ta_rule_comp:
"map_ta_rule f g \<circ> map_ta_rule f' g' = map_ta_rule (f \<circ> f') (g \<circ> g')"
using ta_rule.map_comp[of f g]
by (auto simp: comp_def)
lemma map_ta_rule_cases:
"map_ta_rule f g r = TA_rule (g (r_root r)) (map f (r_lhs_states r)) (f (r_rhs r))"
by (cases r) auto
lemma map_ta_rule_prod_swap_id [simp]:
"map_ta_rule prod.swap prod.swap (map_ta_rule prod.swap prod.swap r) = r"
by (auto simp: map_ta_rule_cases)
lemma rule_states_image [simp]:
"rule_states (map_ta_rule f g |`| \<Delta>) = f |`| rule_states \<Delta>" (is "?Ls = ?Rs")
proof -
{fix q assume "q |\<in>| ?Ls"
then obtain r where "r |\<in>| \<Delta>"
"q |\<in>| finsert (r_rhs (map_ta_rule f g r)) (fset_of_list (r_lhs_states (map_ta_rule f g r)))"
by (auto simp: rule_states_def)
then have "q |\<in>| ?Rs" by (cases r) (force simp: fimage_iff)}
moreover
{fix q assume "q |\<in>| ?Rs"
then obtain r p where "r |\<in>| \<Delta>" "f p = q"
"p |\<in>| finsert (r_rhs r) (fset_of_list (r_lhs_states r))"
by (auto simp: rule_states_def)
then have "q |\<in>| ?Ls" by (cases r) (force simp: fimage_iff)}
ultimately show ?thesis by blast
qed
lemma \<Q>_mono:
"(rules \<A>) |\<subseteq>| (rules \<B>) \<Longrightarrow> (eps \<A>) |\<subseteq>| (eps \<B>) \<Longrightarrow> \<Q> \<A> |\<subseteq>| \<Q> \<B>"
using rule_states_mono eps_states_mono unfolding \<Q>_def
by blast
lemma \<Q>_subseteq_I:
assumes "\<And> r. r |\<in>| rules \<A> \<Longrightarrow> r_rhs r |\<in>| S"
and "\<And> r. r |\<in>| rules \<A> \<Longrightarrow> fset_of_list (r_lhs_states r) |\<subseteq>| S"
and "\<And> e. e |\<in>| eps \<A> \<Longrightarrow> fst e |\<in>| S \<and> snd e |\<in>| S"
shows "\<Q> \<A> |\<subseteq>| S" using assms unfolding \<Q>_def
by (auto simp: rule_states_def) blast
lemma finite_states:
"finite {q. \<exists> f p ps. f ps \<rightarrow> p |\<in>| rules \<A> \<and> (p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)}" (is "finite ?set")
proof -
have "?set \<subseteq> fset (\<Q> \<A>)"
by (intro subsetI, drule CollectD)
(metis eps_trancl_statesD notin_fset rule_statesD(2))
from finite_subset[OF this] show ?thesis by auto
qed
text \<open>Collecting all states reachable from target of rules\<close>
lemma finite_ta_rhs_states [simp]:
"finite {q. \<exists>p. p |\<in>| rule_target_states (rules \<A>) \<and> (p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)}" (is "finite ?Set")
proof -
have "?Set \<subseteq> fset (\<Q> \<A>)"
by (auto dest: rule_statesD)
(metis eps_trancl_statesD notin_fset rule_statesD(1))+
from finite_subset[OF this] show ?thesis
by auto
qed
text \<open>Computing the signature induced by the rule set of given tree automaton\<close>
lemma ta_sigI [intro]:
"TA_rule f qs q |\<in>| (rules \<A>) \<Longrightarrow> length qs = n \<Longrightarrow> (f, n) |\<in>| ta_sig \<A>" unfolding ta_sig_def
using mk_disjoint_finsert by fastforce
lemma ta_sig_mono:
"(rules \<A>) |\<subseteq>| (rules \<B>) \<Longrightarrow> ta_sig \<A> |\<subseteq>| ta_sig \<B>"
by (auto simp: ta_sig_def)
lemma finite_eps:
"finite {q. \<exists> f ps p. f ps \<rightarrow> p |\<in>| rules \<A> \<and> (p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)}" (is "finite ?S")
by (intro finite_subset[OF _ finite_ta_rhs_states[of \<A>]]) auto
lemma collect_snd_trancl_fset:
"{p. (q, p) |\<in>| (eps \<A>)|\<^sup>+|} = fset (snd |`| (ffilter (\<lambda> x. fst x = q) ((eps \<A>)|\<^sup>+|)))"
- by (auto simp: image_iff fmember.rep_eq) force
+ by (auto simp: image_iff fmember_iff_member_fset) force
lemma ta_der_Var:
"q |\<in>| ta_der \<A> (Var x) \<longleftrightarrow> x = q \<or> (x, q) |\<in>| (eps \<A>)|\<^sup>+|"
by (auto simp: collect_snd_trancl_fset)
lemma ta_der_Fun:
"q |\<in>| ta_der \<A> (Fun f ts) \<longleftrightarrow> (\<exists> ps p. TA_rule f ps p |\<in>| (rules \<A>) \<and>
(p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|) \<and> length ps = length ts \<and>
(\<forall> i < length ts. ps ! i |\<in>| ta_der \<A> (ts ! i)))" (is "?Ls \<longleftrightarrow> ?Rs")
unfolding ta_der.simps
by (intro iffI fCollect_memberI finite_Collect_less_eq[OF _ finite_eps[of \<A>]]) auto
declare ta_der.simps[simp del]
declare ta_der.simps[code del]
lemmas ta_der_simps [simp] = ta_der_Var ta_der_Fun
lemma ta_der'_Var:
"Var q |\<in>| ta_der' \<A> (Var x) \<longleftrightarrow> x = q \<or> (x, q) |\<in>| (eps \<A>)|\<^sup>+|"
by (auto simp: collect_snd_trancl_fset)
lemma ta_der'_Fun:
"Var q |\<in>| ta_der' \<A> (Fun f ts) \<longleftrightarrow> q |\<in>| ta_der \<A> (Fun f ts)"
unfolding ta_der'.simps
by (intro iffI funionI1 fCollect_memberI)
(auto simp del: ta_der_Fun ta_der_Var simp: fset_image_conv)
lemma ta_der'_Fun2:
"Fun f ps |\<in>| ta_der' \<A> (Fun g ts) \<longleftrightarrow> f = g \<and> length ps = length ts \<and> (\<forall>i<length ts. ps ! i |\<in>| ta_der' \<A> (ts ! i))"
proof -
have f: "finite {ss. set ss \<subseteq> fset ( |\<Union>| (fset_of_list (map (ta_der' \<A>) ts))) \<and> length ss = length ts}"
by (intro finite_lists_length_eq) auto
have "finite {ss. length ss = length ts \<and> (\<forall>i<length ts. ss ! i |\<in>| ta_der' \<A> (ts ! i))}"
by (intro finite_subset[OF _ f])
- (force simp: in_fset_conv_nth simp flip: fset_of_list_elem fmember.rep_eq)
+ (force simp: in_fset_conv_nth simp flip: fset_of_list_elem fmember_iff_member_fset)
then show ?thesis unfolding ta_der'.simps
by (intro iffI funionI2 fCollect_memberI)
(auto simp del: ta_der_Fun ta_der_Var)
qed
declare ta_der'.simps[simp del]
declare ta_der'.simps[code del]
lemmas ta_der'_simps [simp] = ta_der'_Var ta_der'_Fun ta_der'_Fun2
text \<open>Induction schemes for the most used cases\<close>
lemma ta_der_induct[consumes 1, case_names Var Fun]:
assumes reach: "q |\<in>| ta_der \<A> t"
and VarI: "\<And> q v. v = q \<or> (v, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> P (Var v) q"
and FunI: "\<And>f ts ps p q. f ps \<rightarrow> p |\<in>| rules \<A> \<Longrightarrow> length ts = length ps \<Longrightarrow> p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow>
(\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<A> (ts ! i)) \<Longrightarrow>
(\<And>i. i < length ts \<Longrightarrow> P (ts ! i) (ps ! i)) \<Longrightarrow> P (Fun f ts) q"
shows "P t q" using assms(1)
by (induct t arbitrary: q) (auto simp: VarI FunI)
lemma ta_der_gterm_induct[consumes 1, case_names GFun]:
assumes reach: "q |\<in>| ta_der \<A> (term_of_gterm t)"
and Fun: "\<And>f ts ps p q. TA_rule f ps p |\<in>| rules \<A> \<Longrightarrow> length ts = length ps \<Longrightarrow> p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow>
(\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<A> (term_of_gterm (ts ! i))) \<Longrightarrow>
(\<And>i. i < length ts \<Longrightarrow> P (ts ! i) (ps ! i)) \<Longrightarrow> P (GFun f ts) q"
shows "P t q" using assms(1)
by (induct t arbitrary: q) (auto simp: Fun)
lemma ta_der_rule_empty:
assumes "q |\<in>| ta_der (TA {||} \<Delta>\<^sub>\<epsilon>) t"
obtains p where "t = Var p" "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<epsilon>|\<^sup>+|"
using assms by (cases t) auto
lemma ta_der_eps:
assumes "(p, q) |\<in>| (eps \<A>)" and "p |\<in>| ta_der \<A> t"
shows "q |\<in>| ta_der \<A> t" using assms
by (cases t) (auto intro: ftrancl_into_trancl)
lemma ta_der_trancl_eps:
assumes "(p, q) |\<in>| (eps \<A>)|\<^sup>+|" and "p |\<in>| ta_der \<A> t"
shows "q |\<in>| ta_der \<A> t" using assms
by (induct rule: ftrancl_induct) (auto intro: ftrancl_into_trancl ta_der_eps)
lemma ta_der_mono:
"(rules \<A>) |\<subseteq>| (rules \<B>) \<Longrightarrow> (eps \<A>) |\<subseteq>| (eps \<B>) \<Longrightarrow> ta_der \<A> t |\<subseteq>| ta_der \<B> t"
proof (induct t)
case (Var x) then show ?case
by (auto dest: ftrancl_mono[of _ "eps \<A>" "eps \<B>"])
next
case (Fun f ts)
show ?case using Fun(1)[OF nth_mem Fun(2, 3)]
by (auto dest!: fsubsetD[OF Fun(2)] ftrancl_mono[OF _ Fun(3)]) blast+
qed
lemma ta_der_el_mono:
"(rules \<A>) |\<subseteq>| (rules \<B>) \<Longrightarrow> (eps \<A>) |\<subseteq>| (eps \<B>) \<Longrightarrow> q |\<in>| ta_der \<A> t \<Longrightarrow> q |\<in>| ta_der \<B> t"
using ta_der_mono by blast
lemma ta_der'_ta_der:
assumes "t |\<in>| ta_der' \<A> s" "p |\<in>| ta_der \<A> t"
shows "p |\<in>| ta_der \<A> s" using assms
proof (induction arbitrary: p t rule: ta_der'.induct)
case (2 \<A> f ts) show ?case using 2(2-)
proof (induction t)
case (Var x) then show ?case
by auto (meson ftrancl_trans)
next
case (Fun g ss)
have ss_props: "g = f" "length ss = length ts" "\<forall>i < length ts. ss ! i |\<in>| ta_der' \<A> (ts ! i)"
using Fun(2) by auto
then show ?thesis using Fun(1)[OF nth_mem] Fun(2-)
by (auto simp: ss_props)
(metis (no_types, lifting) "2.IH" ss_props(3))+
qed
qed (auto dest: ftrancl_trans simp: ta_der'.simps)
lemma ta_der'_empty:
assumes "t |\<in>| ta_der' (TA {||} {||}) s"
shows "t = s" using assms
by (induct s arbitrary: t) (auto simp add: ta_der'.simps nth_equalityI)
lemma ta_der'_to_ta_der:
"Var q |\<in>| ta_der' \<A> s \<Longrightarrow> q |\<in>| ta_der \<A> s"
using ta_der'_ta_der by fastforce
lemma ta_der_to_ta_der':
"q |\<in>| ta_der \<A> s \<longleftrightarrow> Var q |\<in>| ta_der' \<A> s "
by (induct s arbitrary: q) auto
lemma ta_der'_poss:
assumes "t |\<in>| ta_der' \<A> s"
shows "poss t \<subseteq> poss s" using assms
proof (induct s arbitrary: t)
case (Fun f ts)
show ?case using Fun(2) Fun(1)[OF nth_mem, of i "args t ! i" for i]
by (cases t) auto
qed (auto simp: ta_der'.simps)
lemma ta_der'_refl[simp]: "t |\<in>| ta_der' \<A> t"
by (induction t) fastforce+
lemma ta_der'_eps:
assumes "Var p |\<in>| ta_der' \<A> s" and "(p, q) |\<in>| (eps \<A>)|\<^sup>+|"
shows "Var q |\<in>| ta_der' \<A> s" using assms
by (cases s, auto dest: ftrancl_trans) (meson ftrancl_trans)
lemma ta_der'_trans:
assumes "t |\<in>| ta_der' \<A> s" and "u |\<in>| ta_der' \<A> t"
shows "u |\<in>| ta_der' \<A> s" using assms
proof (induct t arbitrary: u s)
case (Fun f ts) note IS = Fun(2-) note IH = Fun(1)[OF nth_mem, of i "args s ! i" for i]
show ?case
proof (cases s)
case (Var x1)
then show ?thesis using IS by (auto simp: ta_der'.simps)
next
case [simp]: (Fun g ss)
show ?thesis using IS IH
by (cases u, auto) (metis ta_der_to_ta_der')+
qed
qed (auto simp: ta_der'.simps ta_der'_eps)
text \<open>Connecting contexts to derivation definition\<close>
lemma ta_der_ctxt:
assumes p: "p |\<in>| ta_der \<A> t" "q |\<in>| ta_der \<A> C\<langle>Var p\<rangle>"
shows "q |\<in>| ta_der \<A> C\<langle>t\<rangle>" using assms(2)
proof (induct C arbitrary: q)
case Hole then show ?case using assms
by (auto simp: ta_der_trancl_eps)
next
case (More f ss C ts)
from More(2) obtain qs r where
rule: "f qs \<rightarrow> r |\<in>| rules \<A>" "length qs = Suc (length ss + length ts)" and
reach: "\<forall> i < Suc (length ss + length ts). qs ! i |\<in>| ta_der \<A> ((ss @ C\<langle>Var p\<rangle> # ts) ! i)" "r = q \<or> (r, q) |\<in>| (eps \<A>)|\<^sup>+|"
by auto
have "i < Suc (length ss + length ts) \<Longrightarrow> qs ! i |\<in>| ta_der \<A> ((ss @ C\<langle>t\<rangle> # ts) ! i)" for i
using More(1)[of "qs ! length ss"] assms rule(2) reach(1)
unfolding nth_append_Cons by presburger
then show ?case using rule reach(2) by auto
qed
lemma ta_der_eps_ctxt:
assumes "p |\<in>| ta_der A C\<langle>Var q'\<rangle>" and "(q, q') |\<in>| (eps A)|\<^sup>+|"
shows "p |\<in>| ta_der A C\<langle>Var q\<rangle>"
using assms by (meson ta_der_Var ta_der_ctxt)
lemma rule_reachable_ctxt_exist:
assumes rule: "f qs \<rightarrow> q |\<in>| rules \<A>" and "i < length qs"
shows "\<exists> C. q |\<in>| ta_der \<A> (C \<langle>Var (qs ! i)\<rangle>)" using assms
by (intro exI[of _ "More f (map Var (take i qs)) \<box> (map Var (drop (Suc i) qs))"])
(auto simp: min_def nth_append_Cons intro!: exI[of _ q] exI[of _ qs])
lemma ta_der_ctxt_decompose:
assumes "q |\<in>| ta_der \<A> C\<langle>t\<rangle>"
shows "\<exists> p . p |\<in>| ta_der \<A> t \<and> q |\<in>| ta_der \<A> C\<langle>Var p\<rangle>" using assms
proof (induct C arbitrary: q)
case (More f ss C ts)
from More(2) obtain qs r where
rule: "f qs \<rightarrow> r |\<in>| rules \<A>" "length qs = Suc (length ss + length ts)" and
reach: "\<forall> i < Suc (length ss + length ts). qs ! i |\<in>| ta_der \<A> ((ss @ C\<langle>t\<rangle> # ts) ! i)"
"r = q \<or> (r, q) |\<in>| (eps \<A>)|\<^sup>+|"
by auto
obtain p where p: "p |\<in>| ta_der \<A> t" "qs ! length ss |\<in>| ta_der \<A> C\<langle>Var p\<rangle>"
using More(1)[of "qs ! length ss"] reach(1) rule(2)
by (metis less_add_Suc1 nth_append_length)
have "i < Suc (length ss + length ts) \<Longrightarrow> qs ! i |\<in>| ta_der \<A> ((ss @ C\<langle>Var p\<rangle> # ts) ! i)" for i
using reach rule(2) p by (auto simp: p(2) nth_append_Cons)
then have "q |\<in>| ta_der \<A> (More f ss C ts)\<langle>Var p\<rangle>" using rule reach
by auto
then show ?case using p(1) by (intro exI[of _ p]) blast
qed auto
\<comment> \<open>Relation between reachable states and states of a tree automaton\<close>
lemma ta_der_states:
"ta_der \<A> t |\<subseteq>| \<Q> \<A> |\<union>| fvars_term t"
proof (induct t)
case (Var x) then show ?case
by (auto simp: eq_onp_same_args fmember.abs_eq)
(metis eps_trancl_statesD)
case (Fun f ts) then show ?case
by (auto simp: rule_statesD(2) eps_trancl_statesD)
qed
lemma ground_ta_der_states:
"ground t \<Longrightarrow> ta_der \<A> t |\<subseteq>| \<Q> \<A>"
using ta_der_states[of \<A> t] by auto
lemmas ground_ta_der_statesD = fsubsetD[OF ground_ta_der_states]
lemma gterm_ta_der_states [simp]:
"q |\<in>| ta_der \<A> (term_of_gterm t) \<Longrightarrow> q |\<in>| \<Q> \<A>"
by (intro ground_ta_der_states[THEN fsubsetD, of "term_of_gterm t"]) simp
lemma ta_der_states':
"q |\<in>| ta_der \<A> t \<Longrightarrow> q |\<in>| \<Q> \<A> \<Longrightarrow> fvars_term t |\<subseteq>| \<Q> \<A>"
proof (induct rule: ta_der_induct)
case (Fun f ts ps p r)
then have "i < length ts \<Longrightarrow> fvars_term (ts ! i) |\<subseteq>| \<Q> \<A>" for i
by (auto simp: in_fset_conv_nth dest!: rule_statesD(3))
then show ?case by (force simp: in_fset_conv_nth)
qed (auto simp: eps_trancl_statesD)
lemma ta_der_not_stateD:
"q |\<in>| ta_der \<A> t \<Longrightarrow> q |\<notin>| \<Q> \<A> \<Longrightarrow> t = Var q"
using fsubsetD[OF ta_der_states, of q \<A> t]
by (cases t) (auto dest: rule_statesD eps_trancl_statesD)
lemma ta_der_is_fun_stateD:
"is_Fun t \<Longrightarrow> q |\<in>| ta_der \<A> t \<Longrightarrow> q |\<in>| \<Q> \<A>"
using ta_der_not_stateD[of q \<A> t]
by (cases t) auto
lemma ta_der_is_fun_fvars_stateD:
"is_Fun t \<Longrightarrow> q |\<in>| ta_der \<A> t \<Longrightarrow> fvars_term t |\<subseteq>| \<Q> \<A>"
using ta_der_is_fun_stateD[of t q \<A>]
using ta_der_states'[of q \<A> t]
by (cases t) auto
lemma ta_der_not_reach:
assumes "\<And> r. r |\<in>| rules \<A> \<Longrightarrow> r_rhs r \<noteq> q"
and "\<And> e. e |\<in>| eps \<A> \<Longrightarrow> snd e \<noteq> q"
shows "q |\<notin>| ta_der \<A> (term_of_gterm t)" using assms
by (cases t) (fastforce dest!: assms(1) ftranclD2[of _ q])
lemma ta_rhs_states_subset_states: "ta_rhs_states \<A> |\<subseteq>| \<Q> \<A>"
by (auto simp: ta_rhs_states_def dest: rtranclD rule_statesD eps_trancl_statesD)
(* a resulting state is always some rhs of a rule (or epsilon transition) *)
lemma ta_rhs_states_res: assumes "is_Fun t"
shows "ta_der \<A> t |\<subseteq>| ta_rhs_states \<A>"
proof
fix q assume q: "q |\<in>| ta_der \<A> t"
from \<open>is_Fun t\<close> obtain f ts where t: "t = Fun f ts" by (cases t, auto)
from q[unfolded t] obtain q' qs where "TA_rule f qs q' |\<in>| rules \<A>"
and q: "q' = q \<or> (q', q) |\<in>| (eps \<A>)|\<^sup>+|" by auto
then show "q |\<in>| ta_rhs_states \<A>" unfolding ta_rhs_states_def
by auto
qed
text \<open>Reachable states of ground terms are preserved over the @{const adapt_vars} function\<close>
lemma ta_der_adapt_vars_ground [simp]:
"ground t \<Longrightarrow> ta_der A (adapt_vars t) = ta_der A t"
by (induct t) auto
lemma gterm_of_term_inv':
"ground t \<Longrightarrow> term_of_gterm (gterm_of_term t) = adapt_vars t"
by (induct t) (auto 0 0 intro!: nth_equalityI)
lemma map_vars_term_term_of_gterm:
"map_vars_term f (term_of_gterm t) = term_of_gterm t"
by (induct t) auto
lemma adapt_vars_term_of_gterm:
"adapt_vars (term_of_gterm t) = term_of_gterm t"
by (induct t) auto
(* a term can be reduced to a state, only if all symbols appear in the automaton *)
lemma ta_der_term_sig:
"q |\<in>| ta_der \<A> t \<Longrightarrow> ffunas_term t |\<subseteq>| ta_sig \<A>"
proof (induct rule: ta_der_induct)
case (Fun f ts ps p q)
show ?case using Fun(1 - 4) Fun(5)[THEN fsubsetD]
by (auto simp: in_fset_conv_nth)
qed auto
lemma ta_der_gterm_sig:
"q |\<in>| ta_der \<A> (term_of_gterm t) \<Longrightarrow> ffunas_gterm t |\<subseteq>| ta_sig \<A>"
using ta_der_term_sig ffunas_term_of_gterm_conv
by fastforce
text \<open>@{const ta_lang} for terms with arbitrary variable type\<close>
lemma ta_langE: assumes "t \<in> ta_lang Q \<A>"
obtains t' q where "ground t'" "q |\<in>| Q" "q |\<in>| ta_der \<A> t'" "t = adapt_vars t'"
using assms unfolding ta_lang_def by blast
lemma ta_langI: assumes "ground t'" "q |\<in>| Q" "q |\<in>| ta_der \<A> t'" "t = adapt_vars t'"
shows "t \<in> ta_lang Q \<A>"
using assms unfolding ta_lang_def by blast
lemma ta_lang_def2: "(ta_lang Q (\<A> :: ('q,'f)ta) :: ('f,'v)terms) = {t. ground t \<and> Q |\<inter>| ta_der \<A> (adapt_vars t) \<noteq> {||}}"
by (auto elim!: ta_langE) (metis adapt_vars_adapt_vars ground_adapt_vars ta_langI)
text \<open>@{const ta_lang} for @{const gterms}\<close>
lemma ta_lang_to_gta_lang [simp]:
"ta_lang Q \<A> = term_of_gterm ` gta_lang Q \<A>" (is "?Ls = ?Rs")
proof -
{fix t assume "t \<in> ?Ls"
from ta_langE[OF this] obtain q t' where "ground t'" "q |\<in>| Q" "q |\<in>| ta_der \<A> t'" "t = adapt_vars t'"
by blast
then have "t \<in> ?Rs" unfolding gta_lang_def gta_der_def
by (auto simp: image_iff gterm_of_term_inv' intro!: exI[of _ "gterm_of_term t'"])}
moreover
{fix t assume "t \<in> ?Rs" then have "t \<in> ?Ls"
using ta_langI[OF ground_term_of_gterm _ _ gterm_of_term_inv'[OF ground_term_of_gterm]]
by (force simp: gta_lang_def gta_der_def)}
ultimately show ?thesis by blast
qed
lemma term_of_gterm_in_ta_lang_conv:
"term_of_gterm t \<in> ta_lang Q \<A> \<longleftrightarrow> t \<in> gta_lang Q \<A>"
by (metis (mono_tags, lifting) image_iff ta_lang_to_gta_lang term_of_gterm_inv)
lemma gta_lang_def_sym:
"gterm_of_term ` ta_lang Q \<A> = gta_lang Q \<A>"
(* this is nontrivial because the lhs has a more general type than the rhs of gta_lang_def *)
unfolding gta_lang_def image_def
by (intro Collect_cong) (simp add: gta_lang_def)
lemma gta_langI [intro]:
assumes "q |\<in>| Q" and "q |\<in>| ta_der \<A> (term_of_gterm t)"
shows "t \<in> gta_lang Q \<A>" using assms
by (metis adapt_vars_term_of_gterm ground_term_of_gterm ta_langI term_of_gterm_in_ta_lang_conv)
lemma gta_langE [elim]:
assumes "t \<in> gta_lang Q \<A>"
obtains q where "q |\<in>| Q" and "q |\<in>| ta_der \<A> (term_of_gterm t)" using assms
by (metis adapt_vars_adapt_vars adapt_vars_term_of_gterm ta_langE term_of_gterm_in_ta_lang_conv)
lemma gta_lang_mono:
assumes "\<And> t. ta_der \<A> t |\<subseteq>| ta_der \<BB> t" and "Q\<^sub>\<A> |\<subseteq>| Q\<^sub>\<BB>"
shows "gta_lang Q\<^sub>\<A> \<A> \<subseteq> gta_lang Q\<^sub>\<BB> \<BB>"
using assms by (auto elim!: gta_langE intro!: gta_langI)
lemma gta_lang_term_of_gterm [simp]:
"term_of_gterm t \<in> term_of_gterm ` gta_lang Q \<A> \<longleftrightarrow> t \<in> gta_lang Q \<A>"
by (auto elim!: gta_langE intro!: gta_langI) (metis term_of_gterm_inv)
(* terms can be accepted, only if all their symbols appear in the automaton *)
lemma gta_lang_subset_rules_funas:
"gta_lang Q \<A> \<subseteq> \<T>\<^sub>G (fset (ta_sig \<A>))"
using ta_der_gterm_sig[THEN fsubsetD]
- by (force simp: \<T>\<^sub>G_equivalent_def simp flip: fmember.rep_eq ffunas_gterm.rep_eq)
+ by (force simp: \<T>\<^sub>G_equivalent_def simp flip: fmember_iff_member_fset ffunas_gterm.rep_eq)
lemma reg_funas:
"\<L> \<A> \<subseteq> \<T>\<^sub>G (fset (ta_sig (ta \<A>)))" using gta_lang_subset_rules_funas
by (auto simp: \<L>_def)
lemma ta_syms_lang: "t \<in> ta_lang Q \<A> \<Longrightarrow> ffunas_term t |\<subseteq>| ta_sig \<A>"
using gta_lang_subset_rules_funas ffunas_gterm_gterm_of_term ta_der_gterm_sig ta_lang_def2
by fastforce
lemma gta_lang_Rest_states_conv:
"gta_lang Q \<A> = gta_lang (Q |\<inter>| \<Q> \<A>) \<A>"
by (auto elim!: gta_langE)
lemma reg_Rest_fin_states [simp]:
"\<L> (reg_Restr_Q\<^sub>f \<A>) = \<L> \<A>"
using gta_lang_Rest_states_conv
by (auto simp: \<L>_def reg_Restr_Q\<^sub>f_def)
text \<open>Deterministic tree automatons\<close>
definition ta_det :: "('q,'f) ta \<Rightarrow> bool" where
"ta_det \<A> \<longleftrightarrow> eps \<A> = {||} \<and>
(\<forall> f qs q q'. TA_rule f qs q |\<in>| rules \<A> \<longrightarrow> TA_rule f qs q' |\<in>| rules \<A> \<longrightarrow> q = q')"
definition "ta_subset \<A> \<B> \<longleftrightarrow> rules \<A> |\<subseteq>| rules \<B> \<and> eps \<A> |\<subseteq>| eps \<B>"
(* determinism implies unique results *)
lemma ta_detE[elim, consumes 1]: assumes det: "ta_det \<A>"
shows "q |\<in>| ta_der \<A> t \<Longrightarrow> q' |\<in>| ta_der \<A> t \<Longrightarrow> q = q'" using assms
by (induct t arbitrary: q q') (auto simp: ta_det_def, metis nth_equalityI nth_mem)
lemma ta_subset_states: "ta_subset \<A> \<B> \<Longrightarrow> \<Q> \<A> |\<subseteq>| \<Q> \<B>"
using \<Q>_mono by (auto simp: ta_subset_def)
lemma ta_subset_refl[simp]: "ta_subset \<A> \<A>"
unfolding ta_subset_def by auto
lemma ta_subset_trans: "ta_subset \<A> \<B> \<Longrightarrow> ta_subset \<B> \<CC> \<Longrightarrow> ta_subset \<A> \<CC>"
unfolding ta_subset_def by auto
lemma ta_subset_det: "ta_subset \<A> \<B> \<Longrightarrow> ta_det \<B> \<Longrightarrow> ta_det \<A>"
unfolding ta_det_def ta_subset_def by blast
lemma ta_der_mono': "ta_subset \<A> \<B> \<Longrightarrow> ta_der \<A> t |\<subseteq>| ta_der \<B> t"
using ta_der_mono unfolding ta_subset_def by auto
lemma ta_lang_mono': "ta_subset \<A> \<B> \<Longrightarrow> Q\<^sub>\<A> |\<subseteq>| Q\<^sub>\<B> \<Longrightarrow> ta_lang Q\<^sub>\<A> \<A> \<subseteq> ta_lang Q\<^sub>\<B> \<B>"
using gta_lang_mono[of \<A> \<B>] ta_der_mono'[of \<A> \<B>]
by auto blast
(* the restriction of an automaton to a given set of states *)
lemma ta_restrict_subset: "ta_subset (ta_restrict \<A> Q) \<A>"
unfolding ta_subset_def ta_restrict_def
by auto
lemma ta_restrict_states_Q: "\<Q> (ta_restrict \<A> Q) |\<subseteq>| Q"
by (auto simp: \<Q>_def ta_restrict_def rule_states_def eps_states_def dest!: fsubsetD)
lemma ta_restrict_states: "\<Q> (ta_restrict \<A> Q) |\<subseteq>| \<Q> \<A>"
using ta_subset_states[OF ta_restrict_subset] by fastforce
lemma ta_restrict_states_eq_imp_eq [simp]:
assumes eq: "\<Q> (ta_restrict \<A> Q) = \<Q> \<A>"
shows "ta_restrict \<A> Q = \<A>" using assms
apply (auto simp: ta_restrict_def
intro!: ta.expand finite_subset[OF _ finite_Collect_ta_rule, of _ \<A>])
apply (metis (no_types, lifting) eq fsubsetD fsubsetI rule_statesD(1) rule_statesD(4) ta_restrict_states_Q ta_rule.collapse)
apply (metis eps_statesD eq fin_mono ta_restrict_states_Q)
by (metis eps_statesD eq fsubsetD ta_restrict_states_Q)
lemma ta_der_ta_derict_states:
"fvars_term t |\<subseteq>| Q \<Longrightarrow> q |\<in>| ta_der (ta_restrict \<A> Q) t \<Longrightarrow> q |\<in>| Q"
by (induct t arbitrary: q) (auto simp: ta_restrict_def elim: ftranclE)
lemma ta_derict_ruleI [intro]:
"TA_rule f qs q |\<in>| rules \<A> \<Longrightarrow> fset_of_list qs |\<subseteq>| Q \<Longrightarrow> q |\<in>| Q \<Longrightarrow> TA_rule f qs q |\<in>| rules (ta_restrict \<A> Q)"
by (auto simp: ta_restrict_def intro!: ta.expand finite_subset[OF _ finite_Collect_ta_rule, of _ \<A>])
text \<open>Reachable and productive states: There always is a trim automaton\<close>
lemma finite_ta_reachable [simp]:
"finite {q. \<exists>t. ground t \<and> q |\<in>| ta_der \<A> t}"
proof -
have "{q. \<exists>t. ground t \<and> q |\<in>| ta_der \<A> t} \<subseteq> fset (\<Q> \<A>)"
using ground_ta_der_states[of _ \<A>]
by auto (metis fsubsetD notin_fset)
from finite_subset[OF this] show ?thesis by auto
qed
lemma ta_reachable_states:
"ta_reachable \<A> |\<subseteq>| \<Q> \<A>"
unfolding ta_reachable_def using ground_ta_der_states
by force
lemma ta_reachableE:
assumes "q |\<in>| ta_reachable \<A>"
obtains t where "ground t" "q |\<in>| ta_der \<A> t"
using assms[unfolded ta_reachable_def] by auto
lemma ta_reachable_gtermE [elim]:
assumes "q |\<in>| ta_reachable \<A>"
obtains t where "q |\<in>| ta_der \<A> (term_of_gterm t)"
using ta_reachableE[OF assms]
by (metis ground_term_to_gtermD)
lemma ta_reachableI [intro]:
assumes "ground t" and "q |\<in>| ta_der \<A> t"
shows "q |\<in>| ta_reachable \<A>"
using assms finite_ta_reachable
by (auto simp: ta_reachable_def)
lemma ta_reachable_gtermI [intro]:
"q |\<in>| ta_der \<A> (term_of_gterm t) \<Longrightarrow> q |\<in>| ta_reachable \<A>"
by (intro ta_reachableI[of "term_of_gterm t"]) simp
lemma ta_reachableI_rule:
assumes sub: "fset_of_list qs |\<subseteq>| ta_reachable \<A>"
and rule: "TA_rule f qs q |\<in>| rules \<A>"
shows "q |\<in>| ta_reachable \<A>"
"\<exists> ts. length qs = length ts \<and> (\<forall> i < length ts. ground (ts ! i)) \<and>
(\<forall> i < length ts. qs ! i |\<in>| ta_der \<A> (ts ! i))" (is "?G")
proof -
{
fix i
assume i: "i < length qs"
then have "qs ! i |\<in>| fset_of_list qs" by auto
with sub have "qs ! i |\<in>| ta_reachable \<A>" by auto
from ta_reachableE[OF this] have "\<exists> t. ground t \<and> qs ! i |\<in>| ta_der \<A> t" by auto
}
then have "\<forall> i. \<exists> t. i < length qs \<longrightarrow> ground t \<and> qs ! i |\<in>| ta_der \<A> t" by auto
from choice[OF this] obtain ts where ts: "\<And> i. i < length qs \<Longrightarrow> ground (ts i) \<and> qs ! i |\<in>| ta_der \<A> (ts i)" by blast
let ?t = "Fun f (map ts [0 ..< length qs])"
have gt: "ground ?t" using ts by auto
have r: "q |\<in>| ta_der \<A> ?t" unfolding ta_der_Fun using rule ts
by (intro exI[of _ qs] exI[of _ q]) simp
with gt show "q |\<in>| ta_reachable \<A>" by blast
from gt ts show ?G by (intro exI[of _ "map ts [0..<length qs]"]) simp
qed
lemma ta_reachable_rule_gtermE:
assumes "\<Q> \<A> |\<subseteq>| ta_reachable \<A>"
and "TA_rule f qs q |\<in>| rules \<A>"
obtains t where "groot t = (f, length qs)" "q |\<in>| ta_der \<A> (term_of_gterm t)"
proof -
assume *: "\<And>t. groot t = (f, length qs) \<Longrightarrow> q |\<in>| ta_der \<A> (term_of_gterm t) \<Longrightarrow> thesis"
from assms have "fset_of_list qs |\<subseteq>| ta_reachable \<A>"
by (auto dest: rule_statesD(3))
from ta_reachableI_rule[OF this assms(2)] obtain ts where args: "length qs = length ts"
"\<forall> i < length ts. ground (ts ! i)" "\<forall> i < length ts. qs ! i |\<in>| ta_der \<A> (ts ! i)"
using assms by force
then show ?thesis using assms(2)
by (intro *[of "GFun f (map gterm_of_term ts)"]) auto
qed
lemma ta_reachableI_eps':
assumes reach: "q |\<in>| ta_reachable \<A>"
and eps: "(q, q') |\<in>| (eps \<A>)|\<^sup>+|"
shows "q' |\<in>| ta_reachable \<A>"
proof -
from ta_reachableE[OF reach] obtain t where g: "ground t" and res: "q |\<in>| ta_der \<A> t" by auto
from ta_der_trancl_eps[OF eps res] g show ?thesis by blast
qed
lemma ta_reachableI_eps:
assumes reach: "q |\<in>| ta_reachable \<A>"
and eps: "(q, q') |\<in>| eps \<A>"
shows "q' |\<in>| ta_reachable \<A>"
by (rule ta_reachableI_eps'[OF reach], insert eps, auto)
\<comment> \<open>Automata are productive on a set P if all states can reach a state in P\<close>
lemma finite_ta_productive:
"finite {p. \<exists>q q' C. p = q \<and> q' |\<in>| ta_der \<A> C\<langle>Var q\<rangle> \<and> q' |\<in>| P}"
proof -
{fix x q C assume ass: "x \<notin> fset P" "q |\<in>| P" "q |\<in>| ta_der \<A> C\<langle>Var x\<rangle>"
then have "x \<in> fset (\<Q> \<A>)"
proof (cases "is_Fun C\<langle>Var x\<rangle>")
case True
then show ?thesis using ta_der_is_fun_fvars_stateD[OF _ ass(3)]
by auto (metis notin_fset)
next
case False
then show ?thesis using ass
by (cases C, auto, (metis eps_trancl_statesD notin_fset)+)
qed}
then have "{q | q q' C. q' |\<in>| ta_der \<A> (C\<langle>Var q\<rangle>) \<and> q' |\<in>| P} \<subseteq> fset (\<Q> \<A>) \<union> fset P" by auto
from finite_subset[OF this] show ?thesis by auto
qed
lemma ta_productiveE: assumes "q |\<in>| ta_productive P \<A>"
obtains q' C where "q' |\<in>| ta_der \<A> (C\<langle>Var q\<rangle>)" "q' |\<in>| P"
using assms[unfolded ta_productive_def] by auto
lemma ta_productiveI:
assumes "q' |\<in>| ta_der \<A> (C\<langle>Var q\<rangle>)" "q' |\<in>| P"
shows "q |\<in>| ta_productive P \<A>"
using assms unfolding ta_productive_def
using finite_ta_productive
by auto
lemma ta_productiveI':
assumes "q |\<in>| ta_der \<A> (C\<langle>Var p\<rangle>)" "q |\<in>| ta_productive P \<A>"
shows "p |\<in>| ta_productive P \<A>"
using assms unfolding ta_productive_def
by auto (metis (mono_tags, lifting) ctxt_ctxt_compose ta_der_ctxt)
lemma ta_productive_setI:
"q |\<in>| P \<Longrightarrow> q |\<in>| ta_productive P \<A>"
using ta_productiveI[of q \<A> \<box> q]
by simp
lemma ta_reachable_empty_rules [simp]:
"rules \<A> = {||} \<Longrightarrow> ta_reachable \<A> = {||}"
by (auto simp: ta_reachable_def)
(metis ground.simps(1) ta.exhaust_sel ta_der_rule_empty)
lemma ta_reachable_mono:
"ta_subset \<A> \<B> \<Longrightarrow> ta_reachable \<A> |\<subseteq>| ta_reachable \<B>" using ta_der_mono'
by (auto simp: ta_reachable_def) blast
lemma ta_reachabe_rhs_states:
"ta_reachable \<A> |\<subseteq>| ta_rhs_states \<A>"
proof -
{fix q assume "q |\<in>| ta_reachable \<A>"
then obtain t where "ground t" "q |\<in>| ta_der \<A> t"
by (auto simp: ta_reachable_def)
then have "q |\<in>| ta_rhs_states \<A>"
by (cases t) (auto simp: ta_rhs_states_def)}
then show ?thesis by blast
qed
lemma ta_reachable_eps:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> p |\<in>| ta_reachable \<A> \<Longrightarrow> (p, q) |\<in>| (fRestr (eps \<A>) (ta_reachable \<A>))|\<^sup>+|"
proof (induct rule: ftrancl_induct)
case (Base a b)
then show ?case
by (metis fSigmaI finterI fr_into_trancl ta_reachableI_eps)
next
case (Step p q r)
then have "q |\<in>| ta_reachable \<A>" "r |\<in>| ta_reachable \<A>"
by (metis ta_reachableI_eps ta_reachableI_eps')+
then show ?case using Step
by (metis fSigmaI finterI ftrancl_into_trancl)
qed
(* major lemma to show that one can restrict to reachable states *)
lemma ta_der_only_reach:
assumes "fvars_term t |\<subseteq>| ta_reachable \<A>"
shows "ta_der \<A> t = ta_der (ta_only_reach \<A>) t" (is "?LS = ?RS")
proof -
have "?RS |\<subseteq>| ?LS" using ta_der_mono'[OF ta_restrict_subset]
by fastforce
moreover
{fix q assume "q |\<in>| ?LS"
then have "q |\<in>| ?RS" using assms
proof (induct rule: ta_der_induct)
case (Fun f ts ps p q)
from Fun(2, 6) have ta_reach [simp]: "i < length ps \<Longrightarrow> fvars_term (ts ! i) |\<subseteq>| ta_reachable \<A>" for i
by auto (metis ffUnionI fimage_fset fnth_mem funionI2 length_map nth_map sup.orderE)
from Fun have r: "i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der (ta_only_reach \<A>) (ts ! i)"
"i < length ts \<Longrightarrow> ps ! i |\<in>| ta_reachable \<A>" for i
by (auto) (metis ta_reach ta_der_ta_derict_states)+
then have "f ps \<rightarrow> p |\<in>| rules (ta_only_reach \<A>)"
using Fun(1, 2)
by (intro ta_derict_ruleI)
(fastforce simp: in_fset_conv_nth intro!: ta_reachableI_rule[OF _ Fun(1)])+
then show ?case using ta_reachable_eps[of p q] ta_reachableI_rule[OF _ Fun(1)] r Fun(2, 3)
by (auto simp: ta_restrict_def intro!: exI[of _ p] exI[of _ ps])
qed (auto simp: ta_restrict_def intro: ta_reachable_eps)}
ultimately show ?thesis by blast
qed
lemma ta_der_gterm_only_reach:
"ta_der \<A> (term_of_gterm t) = ta_der (ta_only_reach \<A>) (term_of_gterm t)"
using ta_der_only_reach[of "term_of_gterm t" \<A>]
by simp
lemma ta_reachable_ta_only_reach [simp]:
"ta_reachable (ta_only_reach \<A>) = ta_reachable \<A>" (is "?LS = ?RS")
proof -
have "?LS |\<subseteq>| ?RS" using ta_der_mono'[OF ta_restrict_subset]
by (auto simp: ta_reachable_def) fastforce
moreover
{fix t assume "ground (t :: ('b, 'a) term)"
then have "ta_der \<A> t = ta_der (ta_only_reach \<A>) t" using ta_der_only_reach[of t \<A>]
by simp}
ultimately show ?thesis unfolding ta_reachable_def
by auto
qed
lemma ta_only_reach_reachable:
"\<Q> (ta_only_reach \<A>) |\<subseteq>| ta_reachable (ta_only_reach \<A>)"
using ta_restrict_states_Q[of \<A> "ta_reachable \<A>"]
by auto
(* It is sound to restrict to reachable states. *)
lemma gta_only_reach_lang:
"gta_lang Q (ta_only_reach \<A>) = gta_lang Q \<A>"
using ta_der_gterm_only_reach
by (auto elim!: gta_langE intro!: gta_langI) force+
lemma \<L>_only_reach: "\<L> (reg_reach R) = \<L> R"
using gta_only_reach_lang
by (auto simp: \<L>_def reg_reach_def)
lemma ta_only_reach_lang:
"ta_lang Q (ta_only_reach \<A>) = ta_lang Q \<A>"
using gta_only_reach_lang
by (metis ta_lang_to_gta_lang)
lemma ta_prod_epsD:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> q |\<in>| ta_productive P \<A> \<Longrightarrow> p |\<in>| ta_productive P \<A>"
using ta_der_ctxt[of q \<A> "\<box>\<langle>Var p\<rangle>"]
by (auto simp: ta_productive_def ta_der_trancl_eps)
lemma ta_only_prod_eps:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> q |\<in>| ta_productive P \<A> \<Longrightarrow> (p, q) |\<in>| (eps (ta_only_prod P \<A>))|\<^sup>+|"
proof (induct rule: ftrancl_induct)
case (Base p q)
then show ?case
by (metis (no_types, lifting) fSigmaI finterI fr_into_trancl ta.sel(2) ta_prod_epsD ta_restrict_def)
next
case (Step p q r) note IS = this
show ?case using IS(2 - 4) ta_prod_epsD[OF fr_into_trancl[OF IS(3)] IS(4)]
by (auto simp: ta_restrict_def) (simp add: ftrancl_into_trancl)
qed
(* Major lemma to show that it is sound to restrict to productive states. *)
lemma ta_der_only_prod:
"q |\<in>| ta_der \<A> t \<Longrightarrow> q |\<in>| ta_productive P \<A> \<Longrightarrow> q |\<in>| ta_der (ta_only_prod P \<A>) t"
proof (induct rule: ta_der_induct)
case (Fun f ts ps p q)
let ?\<A> = "ta_only_prod P \<A>"
have pr: "p |\<in>| ta_productive P \<A>" "i < length ts \<Longrightarrow> ps ! i |\<in>| ta_productive P \<A>" for i
using Fun(2) ta_prod_epsD[of p q] Fun(3, 6) rule_reachable_ctxt_exist[OF Fun(1)]
using ta_productiveI'[of p \<A> _ "ps ! i" P]
by auto
then have "f ps \<rightarrow> p |\<in>| rules ?\<A>" using Fun(1, 2) unfolding ta_restrict_def
by (auto simp: in_fset_conv_nth intro: finite_subset[OF _ finite_Collect_ta_rule, of _ \<A>])
then show ?case using pr Fun ta_only_prod_eps[of p q \<A> P] Fun(3, 6)
by auto
qed (auto intro: ta_only_prod_eps)
lemma ta_der_ta_only_prod_ta_der:
"q |\<in>| ta_der (ta_only_prod P \<A>) t \<Longrightarrow> q |\<in>| ta_der \<A> t"
by (meson ta_der_el_mono ta_restrict_subset ta_subset_def)
(* It is sound to restrict to productive states. *)
lemma gta_only_prod_lang:
"gta_lang Q (ta_only_prod Q \<A>) = gta_lang Q \<A>" (is "gta_lang Q ?\<A> = _")
proof
show "gta_lang Q ?\<A> \<subseteq> gta_lang Q \<A>"
using gta_lang_mono[OF ta_der_mono'[OF ta_restrict_subset]]
by blast
next
{fix t assume "t \<in> gta_lang Q \<A>"
from gta_langE[OF this] obtain q where
reach: "q |\<in>| ta_der \<A> (term_of_gterm t)" "q |\<in>| Q" .
from ta_der_only_prod[OF reach(1) ta_productive_setI[OF reach(2)]] reach(2)
have "t \<in> gta_lang Q ?\<A>" by (auto intro: gta_langI)}
then show "gta_lang Q \<A> \<subseteq> gta_lang Q ?\<A>" by blast
qed
lemma \<L>_only_prod: "\<L> (reg_prod R) = \<L> R"
using gta_only_prod_lang
by (auto simp: \<L>_def reg_prod_def)
lemma ta_only_prod_lang:
"ta_lang Q (ta_only_prod Q \<A>) = ta_lang Q \<A>"
using gta_only_prod_lang
by (metis ta_lang_to_gta_lang)
(* the productive states are also productive w.r.t. the new automaton *)
lemma ta_prodictive_ta_only_prod [simp]:
"ta_productive P (ta_only_prod P \<A>) = ta_productive P \<A>" (is "?LS = ?RS")
proof -
have "?LS |\<subseteq>| ?RS" using ta_der_mono'[OF ta_restrict_subset]
using finite_ta_productive[of \<A> P]
by (auto simp: ta_productive_def) fastforce
moreover have "?RS |\<subseteq>| ?LS" using ta_der_only_prod
by (auto elim!: ta_productiveE)
(smt (z3) ta_der_only_prod ta_productiveI ta_productive_setI)
ultimately show ?thesis by blast
qed
lemma ta_only_prod_productive:
"\<Q> (ta_only_prod P \<A>) |\<subseteq>| ta_productive P (ta_only_prod P \<A>)"
using ta_restrict_states_Q by force
lemma ta_only_prod_reachable:
assumes all_reach: "\<Q> \<A> |\<subseteq>| ta_reachable \<A>"
shows "\<Q> (ta_only_prod P \<A>) |\<subseteq>| ta_reachable (ta_only_prod P \<A>)" (is "?Ls |\<subseteq>| ?Rs")
proof -
{fix q assume "q |\<in>| ?Ls"
then obtain t where "ground t" "q |\<in>| ta_der \<A> t" "q |\<in>| ta_productive P \<A>"
using fsubsetD[OF ta_only_prod_productive[of \<A> P]]
using fsubsetD[OF fsubset_trans[OF ta_restrict_states all_reach, of "ta_productive P \<A>"]]
by (auto elim!: ta_reachableE)
then have "q |\<in>| ?Rs"
by (intro ta_reachableI[where ?\<A> = "ta_only_prod P \<A>" and ?t = t]) (auto simp: ta_der_only_prod)}
then show ?thesis by blast
qed
lemma ta_prod_reach_subset:
"ta_subset (ta_only_prod P (ta_only_reach \<A>)) \<A>"
by (rule ta_subset_trans, (rule ta_restrict_subset)+)
lemma ta_prod_reach_states:
"\<Q> (ta_only_prod P (ta_only_reach \<A>)) |\<subseteq>| \<Q> \<A>"
by (rule ta_subset_states[OF ta_prod_reach_subset])
(* If all states are reachable then there exists a ground context for all productive states *)
lemma ta_productive_aux:
assumes "\<Q> \<A> |\<subseteq>| ta_reachable \<A>" "q |\<in>| ta_der \<A> (C\<langle>t\<rangle>)"
shows "\<exists>C'. ground_ctxt C' \<and> q |\<in>| ta_der \<A> (C'\<langle>t\<rangle>)" using assms(2)
proof (induct C arbitrary: q)
case Hole then show ?case by (intro exI[of _ "\<box>"]) auto
next
case (More f ts1 C ts2)
from More(2) obtain qs q' where q': "f qs \<rightarrow> q' |\<in>| rules \<A>" "q' = q \<or> (q', q) |\<in>| (eps \<A>)|\<^sup>+|"
"qs ! length ts1 |\<in>| ta_der \<A> (C\<langle>t\<rangle>)" "length qs = Suc (length ts1 + length ts2)"
by simp (metis less_add_Suc1 nth_append_length)
{ fix i assume "i < length qs"
then have "qs ! i |\<in>| \<Q> \<A>" using q'(1)
by (auto dest!: rule_statesD(4))
then have "\<exists>t. ground t \<and> qs ! i |\<in>| ta_der \<A> t" using assms(1)
by (simp add: ta_reachable_def) force}
then obtain ts where ts: "i < length qs \<Longrightarrow> ground (ts i) \<and> qs ! i |\<in>| ta_der \<A> (ts i)" for i by metis
obtain C' where C: "ground_ctxt C'" "qs ! length ts1 |\<in>| ta_der \<A> C'\<langle>t\<rangle>" using More(1)[OF q'(3)] by blast
define D where "D \<equiv> More f (map ts [0..<length ts1]) C' (map ts [Suc (length ts1)..<Suc (length ts1 + length ts2)])"
have "ground_ctxt D" unfolding D_def using ts C(1) q'(4) by auto
moreover have "q |\<in>| ta_der \<A> D\<langle>t\<rangle>" using ts C(2) q' unfolding D_def
by (auto simp: nth_append_Cons not_le not_less le_less_Suc_eq Suc_le_eq intro!: exI[of _ qs] exI[of _ q'])
ultimately show ?case by blast
qed
lemma ta_productive_def':
assumes "\<Q> \<A> |\<subseteq>| ta_reachable \<A>"
shows "ta_productive Q \<A> = {| q| q q' C. ground_ctxt C \<and> q' |\<in>| ta_der \<A> (C\<langle>Var q\<rangle>) \<and> q' |\<in>| Q |}"
using ta_productive_aux[OF assms]
by (auto simp: ta_productive_def intro!: finite_subset[OF _ finite_ta_productive, of _ \<A> Q]) force+
(* turn a finite automaton into a trim one, by removing
first all unreachable and then all non-productive states *)
lemma trim_gta_lang: "gta_lang Q (trim_ta Q \<A>) = gta_lang Q \<A>"
unfolding trim_ta_def gta_only_reach_lang gta_only_prod_lang ..
lemma trim_ta_subset: "ta_subset (trim_ta Q \<A>) \<A>"
unfolding trim_ta_def by (rule ta_prod_reach_subset)
theorem trim_ta: "ta_is_trim Q (trim_ta Q \<A>)" unfolding ta_is_trim_def
by (metis fin_mono ta_only_prod_reachable ta_only_reach_reachable
ta_prodictive_ta_only_prod ta_restrict_states_Q trim_ta_def)
lemma reg_is_trim_trim_reg [simp]: "reg_is_trim (trim_reg R)"
unfolding reg_is_trim_def trim_reg_def
by (simp add: trim_ta)
lemma trim_reg_reach [simp]:
"\<Q>\<^sub>r (trim_reg A) |\<subseteq>| ta_reachable (ta (trim_reg A))"
by (auto simp: trim_reg_def) (meson ta_is_trim_def trim_ta)
lemma trim_reg_prod [simp]:
"\<Q>\<^sub>r (trim_reg A) |\<subseteq>| ta_productive (fin (trim_reg A)) (ta (trim_reg A))"
by (auto simp: trim_reg_def) (meson ta_is_trim_def trim_ta)
(* Proposition 7: every tree automaton can be turned into an equivalent trim one *)
lemmas obtain_trimmed_ta = trim_ta trim_gta_lang ta_subset_det[OF trim_ta_subset]
(* Trim tree automaton signature *)
lemma \<L>_trim_ta_sig:
assumes "reg_is_trim R" "\<L> R \<subseteq> \<T>\<^sub>G (fset \<F>)"
shows "ta_sig (ta R) |\<subseteq>| \<F>"
proof -
{fix r assume r: "r |\<in>| rules (ta R)"
then obtain f ps p where [simp]: "r = f ps \<rightarrow> p" by (cases r) auto
from r assms(1) have "fset_of_list ps |\<subseteq>| ta_reachable (ta R)"
by (auto simp add: rule_statesD(4) reg_is_trim_def ta_is_trim_def)
from ta_reachableI_rule[OF this, of f p] r
obtain ts where ts: "length ts = length ps" "\<forall> i < length ps. ground (ts ! i)"
"\<forall> i < length ps. ps ! i |\<in>| ta_der (ta R) (ts ! i)"
by auto
obtain C q where ctxt: "ground_ctxt C" "q |\<in>| ta_der (ta R) (C\<langle>Var p\<rangle>)" "q |\<in>| fin R"
using assms(1) unfolding reg_is_trim_def
by (metis \<open>r = f ps \<rightarrow> p\<close> fsubsetI r rule_statesD(2) ta_productiveE ta_productive_aux ta_is_trim_def)
from ts ctxt r have reach: "q |\<in>| ta_der (ta R) C\<langle>Fun f ts\<rangle>"
by auto (metis ta_der_Fun ta_der_ctxt)
have gr: "ground C\<langle>Fun f ts\<rangle>" using ts(1, 2) ctxt(1)
by (auto simp: in_set_conv_nth)
then have "C\<langle>Fun f ts\<rangle> \<in> ta_lang (fin R) (ta R)" using ctxt(1, 3) ts(1, 2)
apply (intro ta_langI[OF _ _ reach, of "fin R" "C\<langle>Fun f ts\<rangle>"])
apply (auto simp del: adapt_vars_ctxt)
by (metis gr adapt_vars2 adapt_vars_adapt_vars)
then have *: "gterm_of_term C\<langle>Fun f ts\<rangle> \<in> \<L> R" using gr
by (auto simp: \<L>_def)
then have "funas_gterm (gterm_of_term C\<langle>Fun f ts\<rangle>) \<subseteq> fset \<F>" using assms(2) gr
by (auto simp: \<T>\<^sub>G_equivalent_def)
moreover have "(f, length ps) \<in> funas_gterm (gterm_of_term C\<langle>Fun f ts\<rangle>)"
using ts(1) by (auto simp: funas_gterm_gterm_of_term[OF gr])
ultimately have "(r_root r, length (r_lhs_states r)) |\<in>| \<F>"
- by (auto simp: fmember.rep_eq)}
+ by (auto simp: fmember_iff_member_fset)}
then show ?thesis
by (auto simp: ta_sig_def)
qed
text \<open>Map function over TA rules which change states/signature\<close>
lemma map_ta_rule_iff:
"map_ta_rule f g |`| \<Delta> = {|TA_rule (g h) (map f qs) (f q) | h qs q. TA_rule h qs q |\<in>| \<Delta>|}"
apply (intro fequalityI fsubsetI)
apply (auto simp add: rev_fimage_eqI)
apply (metis map_ta_rule_cases ta_rule.collapse)
done
lemma \<L>_trim: "\<L> (trim_reg R) = \<L> R"
by (auto simp: trim_gta_lang \<L>_def trim_reg_def)
lemma fmap_funs_ta_def':
"fmap_funs_ta h \<A> = TA {|(h f) qs \<rightarrow> q |f qs q. f qs \<rightarrow> q |\<in>| rules \<A>|} (eps \<A>)"
unfolding fmap_funs_ta_def map_ta_rule_iff by auto
lemma fmap_states_ta_def':
"fmap_states_ta h \<A> = TA {|f (map h qs) \<rightarrow> h q |f qs q. f qs \<rightarrow> q |\<in>| rules \<A>|} (map_both h |`| eps \<A>)"
unfolding fmap_states_ta_def map_ta_rule_iff by auto
lemma fmap_states [simp]:
"\<Q> (fmap_states_ta h \<A>) = h |`| \<Q> \<A>"
unfolding fmap_states_ta_def \<Q>_def
by auto
lemma fmap_states_ta_sig [simp]:
"ta_sig (fmap_states_ta f \<A>) = ta_sig \<A>"
by (auto simp: fBex_def fmap_states_ta_def ta_sig_def fimage_iff)
(metis id_def length_map ta_rule.map_sel(1, 2))+
lemma fmap_states_ta_eps_wit:
assumes "(h p, q) |\<in>| (map_both h |`| eps \<A>)|\<^sup>+|" "finj_on h (\<Q> \<A>)" "p |\<in>| \<Q> \<A>"
obtains q' where "q = h q'" "(p, q') |\<in>| (eps \<A>)|\<^sup>+|" "q' |\<in>| \<Q> \<A>" using assms
by (auto simp: fimage_iff finj_on_def' ftrancl_map_both_fsubset[OF assms(2), of "eps \<A>"])
(metis (mono_tags, lifting) assms(2) eps_trancl_statesD finj_on_eq_iff)
lemma ta_der_fmap_states_inv_superset:
assumes "\<Q> \<A> |\<subseteq>| \<B>" "finj_on h \<B>"
and "q |\<in>| ta_der (fmap_states_ta h \<A>) (term_of_gterm t)"
shows "the_finv_into \<B> h q |\<in>| ta_der \<A> (term_of_gterm t)" using assms(3)
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
from assms(1, 2) have inj: "finj_on h (\<Q> \<A>)" using fsubset_finj_on by blast
have "x |\<in>| \<Q> \<A> \<Longrightarrow> the_finv_into (\<Q> \<A>) h (h x) = the_finv_into \<B> h (h x)" for x
using assms(1, 2) by (metis fsubsetD inj the_finv_into_f_f)
then show ?case using GFun the_finv_into_f_f[OF inj] assms(1)
by (auto simp: fmap_states_ta_def' finj_on_def' rule_statesD eps_statesD
elim!: fmap_states_ta_eps_wit[OF _ inj]
intro!: exI[of _ "the_finv_into \<B> h p"])
qed
lemma ta_der_fmap_states_inv:
assumes "finj_on h (\<Q> \<A>)" "q |\<in>| ta_der (fmap_states_ta h \<A>) (term_of_gterm t)"
shows "the_finv_into (\<Q> \<A>) h q |\<in>| ta_der \<A> (term_of_gterm t)"
by (simp add: ta_der_fmap_states_inv_superset assms)
lemma ta_der_to_fmap_states_der:
assumes "q |\<in>| ta_der \<A> (term_of_gterm t)"
shows "h q |\<in>| ta_der (fmap_states_ta h \<A>) (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then show ?case
using ftrancl_map_prod_mono[of h "eps \<A>"]
by (auto simp: fmap_states_ta_def' intro!: exI[of _ "h p"] exI[of _ "map h ps"])
qed
lemma ta_der_fmap_states_conv:
assumes "finj_on h (\<Q> \<A>)"
shows "ta_der (fmap_states_ta h \<A>) (term_of_gterm t) = h |`| ta_der \<A> (term_of_gterm t)"
using ta_der_to_fmap_states_der[of _ \<A> t] ta_der_fmap_states_inv[OF assms]
using f_the_finv_into_f[OF assms] finj_on_the_finv_into[OF assms]
using gterm_ta_der_states
by (auto intro!: rev_fimage_eqI) fastforce
lemma fmap_states_ta_det:
assumes "finj_on f (\<Q> \<A>)"
shows "ta_det (fmap_states_ta f \<A>) = ta_det \<A>" (is "?Ls = ?Rs")
proof
{fix g ps p q assume ass: "?Ls" "TA_rule g ps p |\<in>| rules \<A>" "TA_rule g ps q |\<in>| rules \<A>"
then have "TA_rule g (map f ps) (f p) |\<in>| rules (fmap_states_ta f \<A>)"
"TA_rule g (map f ps) (f q) |\<in>| rules (fmap_states_ta f \<A>)"
by (force simp: fmap_states_ta_def)+
then have "p = q" using ass finj_on_eq_iff[OF assms]
by (auto simp: ta_det_def) (meson rule_statesD(2))}
then show "?Ls \<Longrightarrow> ?Rs"
by (auto simp: ta_det_def fmap_states_ta_def')
next
{fix g ps qs p q assume ass: "?Rs" "TA_rule g ps p |\<in>| rules \<A>" "TA_rule g qs q |\<in>| rules \<A>"
then have "map f ps = map f qs \<Longrightarrow> ps = qs" using finj_on_eq_iff[OF assms]
by (auto simp: map_eq_nth_conv in_fset_conv_nth dest!: rule_statesD(4) intro!: nth_equalityI)}
then show "?Rs \<Longrightarrow> ?Ls" using finj_on_eq_iff[OF assms]
by (auto simp: ta_det_def fmap_states_ta_def') blast
qed
lemma fmap_states_ta_lang:
"finj_on f (\<Q> \<A>) \<Longrightarrow> Q |\<subseteq>| \<Q> \<A> \<Longrightarrow> gta_lang (f |`| Q) (fmap_states_ta f \<A>) = gta_lang Q \<A>"
using ta_der_fmap_states_conv[of f \<A>]
by (auto simp: finj_on_def' finj_on_eq_iff fsubsetD elim!: gta_langE intro!: gta_langI)
lemma fmap_states_ta_lang2:
"finj_on f (\<Q> \<A> |\<union>| Q) \<Longrightarrow> gta_lang (f |`| Q) (fmap_states_ta f \<A>) = gta_lang Q \<A>"
using ta_der_fmap_states_conv[OF fsubset_finj_on[of f "\<Q> \<A> |\<union>| Q" "\<Q> \<A>"]]
by (auto simp: finj_on_def' elim!: gta_langE intro!: gta_langI) fastforce
definition funs_ta :: "('q, 'f) ta \<Rightarrow> 'f fset" where
"funs_ta \<A> = {|f |f qs q. TA_rule f qs q |\<in>| rules \<A>|}"
lemma funs_ta[code]:
"funs_ta \<A> = (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> f) |`| (rules \<A>)" (is "?Ls = ?Rs")
- by (force simp: funs_ta_def rev_fimage_eqI simp flip: fset.set_map fmember.rep_eq
+ by (force simp: funs_ta_def rev_fimage_eqI simp flip: fset.set_map fmember_iff_member_fset
split!: ta_rule.splits intro!: finite_subset[of "{f. \<exists>qs q. TA_rule f qs q |\<in>| rules \<A>}" "fset ?Rs"])
lemma finite_funs_ta [simp]:
"finite {f. \<exists>qs q. TA_rule f qs q |\<in>| rules \<A>}"
by (intro finite_subset[of "{f. \<exists>qs q. TA_rule f qs q |\<in>| rules \<A>}" "fset (funs_ta \<A>)"])
- (auto simp: funs_ta rev_fimage_eqI simp flip: fset.set_map fmember.rep_eq split!: ta_rule.splits)
+ (auto simp: funs_ta rev_fimage_eqI simp flip: fset.set_map fmember_iff_member_fset split!: ta_rule.splits)
lemma funs_taE [elim]:
assumes "f |\<in>| funs_ta \<A>"
obtains ps p where "TA_rule f ps p |\<in>| rules \<A>" using assms
by (auto simp: funs_ta_def)
lemma funs_taI [intro]:
"TA_rule f ps p |\<in>| rules \<A> \<Longrightarrow> f |\<in>| funs_ta \<A>"
by (auto simp: funs_ta_def)
lemma fmap_funs_ta_cong:
"(\<And>x. x |\<in>| funs_ta \<A> \<Longrightarrow> h x = k x) \<Longrightarrow> \<A> = \<B> \<Longrightarrow> fmap_funs_ta h \<A> = fmap_funs_ta k \<B>"
by (force simp: fmap_funs_ta_def')
lemma [simp]: "{|TA_rule f qs q |f qs q. TA_rule f qs q |\<in>| X|} = X"
by (intro fset_eqI; case_tac x) auto
lemma fmap_funs_ta_id [simp]:
"fmap_funs_ta id \<A> = \<A>" by (simp add: fmap_funs_ta_def')
lemma fmap_states_ta_id [simp]:
"fmap_states_ta id \<A> = \<A>"
by (auto simp: fmap_states_ta_def map_ta_rule_iff prod.map_id0)
lemmas fmap_funs_ta_id' [simp] = fmap_funs_ta_id[unfolded id_def]
lemma fmap_funs_ta_comp:
"fmap_funs_ta h (fmap_funs_ta k A) = fmap_funs_ta (h \<circ> k) A"
proof -
have "r |\<in>| rules A \<Longrightarrow> map_ta_rule id h (map_ta_rule id k r) = map_ta_rule id (\<lambda>x. h (k x)) r" for r
by (cases r) (auto)
then show ?thesis
by (force simp: fmap_funs_ta_def fimage_iff cong: fmap_funs_ta_cong)
qed
lemma fmap_funs_reg_comp:
"fmap_funs_reg h (fmap_funs_reg k A) = fmap_funs_reg (h \<circ> k) A"
using fmap_funs_ta_comp unfolding fmap_funs_reg_def
by auto
lemma fmap_states_ta_comp:
"fmap_states_ta h (fmap_states_ta k A) = fmap_states_ta (h \<circ> k) A"
by (auto simp: fmap_states_ta_def ta_rule.map_comp comp_def id_def prod.map_comp)
lemma funs_ta_fmap_funs_ta [simp]:
"funs_ta (fmap_funs_ta f A) = f |`| funs_ta A"
by (auto simp: funs_ta fmap_funs_ta_def' comp_def fimage_iff
split!: ta_rule.splits) force+
lemma ta_der_funs_ta:
"q |\<in>| ta_der A t \<Longrightarrow> ffuns_term t |\<subseteq>| funs_ta A"
proof (induct t arbitrary: q)
case (Fun f ts)
then have "f |\<in>| funs_ta A" by (auto simp: funs_ta_def)
then show ?case using Fun(1)[OF nth_mem, THEN fsubsetD] Fun(2)
by (auto simp: in_fset_conv_nth) blast+
qed auto
lemma ta_der_fmap_funs_ta:
"q |\<in>| ta_der A t \<Longrightarrow> q |\<in>| ta_der (fmap_funs_ta f A) (map_funs_term f t)"
by (induct t arbitrary: q) (auto 0 4 simp: fmap_funs_ta_def')
lemma ta_der_fmap_states_ta:
assumes "q |\<in>| ta_der A t"
shows "h q |\<in>| ta_der (fmap_states_ta h A) (map_vars_term h t)"
proof -
have [intro]: "(q, q') |\<in>| (eps A)|\<^sup>+| \<Longrightarrow> (h q, h q') |\<in>| (eps (fmap_states_ta h A))|\<^sup>+|" for q q'
by (force intro!: ftrancl_map[of "eps A"] simp: fmap_states_ta_def)
show ?thesis using assms
proof (induct rule: ta_der_induct)
case (Fun f ts ps p q)
have "f (map h ps) \<rightarrow> h p |\<in>| rules (fmap_states_ta h A)"
using Fun(1) by (force simp: fmap_states_ta_def')
then show ?case using Fun by (auto 0 4)
qed auto
qed
lemma ta_der_fmap_states_ta_mono:
shows "f |`| ta_der A (term_of_gterm s) |\<subseteq>| ta_der (fmap_states_ta f A) (term_of_gterm s)"
using ta_der_fmap_states_ta[of _ A "term_of_gterm s" f]
by (simp add: fimage_fsubsetI ta_der_to_fmap_states_der)
lemma ta_der_fmap_states_ta_mono2:
assumes "finj_on f (\<Q> A)"
shows "ta_der (fmap_states_ta f A) (term_of_gterm s) |\<subseteq>| f |`| ta_der A (term_of_gterm s)"
using ta_der_fmap_states_conv[OF assms] by auto
lemma fmap_funs_ta_der':
"q |\<in>| ta_der (fmap_funs_ta h A) t \<Longrightarrow> \<exists>t'. q |\<in>| ta_der A t' \<and> map_funs_term h t' = t"
proof (induct rule: ta_der_induct)
case (Var q v)
then show ?case by (auto simp: fmap_funs_ta_def intro!: exI[of _ "Var v"])
next
case (Fun f ts ps p q)
obtain f' ts' where root: "f = h f'" "f' ps \<rightarrow> p |\<in>| rules A" and
"\<And>i. i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der A (ts' i) \<and> map_funs_term h (ts' i) = ts ! i"
using Fun(1, 5) unfolding fmap_funs_ta_def'
by auto metis
note [simp] = conjunct1[OF this(3)] conjunct2[OF this(3), unfolded id_def]
have [simp]: "p = q \<Longrightarrow> f' ps \<rightarrow> q |\<in>| rules A" using root(2) by auto
show ?case using Fun(3)
by (auto simp: comp_def Fun root fmap_funs_ta_def'
intro!: exI[of _ "Fun f' (map ts' [0..<length ts])"] exI[of _ ps] exI[of _ p] nth_equalityI)
qed
lemma fmap_funs_gta_lang:
"gta_lang Q (fmap_funs_ta h \<A>) = map_gterm h ` gta_lang Q \<A>" (is "?Ls = ?Rs")
proof -
{fix s assume "s \<in> ?Ls" then obtain q where
lang: "q |\<in>| Q" "q |\<in>| ta_der (fmap_funs_ta h \<A>) (term_of_gterm s)"
by auto
from fmap_funs_ta_der'[OF this(2)] obtain t where
t: "q |\<in>| ta_der \<A> t" "map_funs_term h t = term_of_gterm s" "ground t"
by (metis ground_map_term ground_term_of_gterm)
then have "s \<in> ?Rs" using map_gterm_of_term[OF t(3), of h id] lang
by (auto simp: gta_lang_def gta_der_def image_iff)
(metis fempty_iff finterI ground_term_to_gtermD map_term_of_gterm term_of_gterm_inv)}
moreover have "?Rs \<subseteq> ?Ls" using ta_der_fmap_funs_ta[of _ \<A> _ h]
by (auto elim!: gta_langE intro!: gta_langI) fastforce
ultimately show ?thesis by blast
qed
lemma fmap_funs_\<L>:
"\<L> (fmap_funs_reg h R) = map_gterm h ` \<L> R"
using fmap_funs_gta_lang[of "fin R" h]
by (auto simp: fmap_funs_reg_def \<L>_def)
lemma ta_states_fmap_funs_ta [simp]: "\<Q> (fmap_funs_ta f A) = \<Q> A"
by (auto simp: fmap_funs_ta_def \<Q>_def)
lemma ta_reachable_fmap_funs_ta [simp]:
"ta_reachable (fmap_funs_ta f A) = ta_reachable A" unfolding ta_reachable_def
by (metis (mono_tags, lifting) fmap_funs_ta_der' ta_der_fmap_funs_ta ground_map_term)
lemma fin_in_states:
"fin (reg_Restr_Q\<^sub>f R) |\<subseteq>| \<Q>\<^sub>r (reg_Restr_Q\<^sub>f R)"
by (auto simp: reg_Restr_Q\<^sub>f_def)
lemma fmap_states_reg_Restr_Q\<^sub>f_fin:
"finj_on f (\<Q> \<A>) \<Longrightarrow> fin (fmap_states_reg f (reg_Restr_Q\<^sub>f R)) |\<subseteq>| \<Q>\<^sub>r (fmap_states_reg f (reg_Restr_Q\<^sub>f R))"
by (auto simp: fmap_states_reg_def reg_Restr_Q\<^sub>f_def)
lemma \<L>_fmap_states_reg_Inl_Inr [simp]:
"\<L> (fmap_states_reg Inl R) = \<L> R"
"\<L> (fmap_states_reg Inr R) = \<L> R"
unfolding \<L>_def fmap_states_reg_def
by (auto simp: finj_Inl_Inr intro!: fmap_states_ta_lang2)
lemma finite_Collect_prod_ta_rules:
"finite {f qs \<rightarrow> (a, b) |f qs a b. f map fst qs \<rightarrow> a |\<in>| rules \<A> \<and> f map snd qs \<rightarrow> b |\<in>| rules \<BB>}" (is "finite ?set")
proof -
have "?set \<subseteq> (\<lambda> (ra, rb). case ra of f ps \<rightarrow> p \<Rightarrow> case rb of g qs \<rightarrow> q \<Rightarrow> f (zip ps qs) \<rightarrow> (p, q)) ` (srules \<A> \<times> srules \<BB>)"
- by (auto simp: srules_def image_iff fmember.rep_eq split!: ta_rule.splits)
+ by (auto simp: srules_def image_iff fmember_iff_member_fset split!: ta_rule.splits)
(metis ta_rule.inject zip_map_fst_snd)
from finite_imageI[of "srules \<A> \<times> srules \<BB>", THEN finite_subset[OF this]]
show ?thesis by (auto simp: srules_def)
qed
\<comment> \<open>The product automaton of the automata A and B is constructed
by applying the rules on pairs of states\<close>
lemmas prod_eps_def = prod_epsLp_def prod_epsRp_def
lemma finite_prod_epsLp:
"finite (Collect (prod_epsLp \<A> \<B>))"
by (intro finite_subset[of "Collect (prod_epsLp \<A> \<B>)" "fset ((\<Q> \<A> |\<times>| \<Q> \<B>) |\<times>| \<Q> \<A> |\<times>| \<Q> \<B>)"])
- (auto simp: prod_epsLp_def simp flip: fmember.rep_eq dest: eps_statesD)
+ (auto simp: prod_epsLp_def simp flip: fmember_iff_member_fset dest: eps_statesD)
lemma finite_prod_epsRp:
"finite (Collect (prod_epsRp \<A> \<B>))"
by (intro finite_subset[of "Collect (prod_epsRp \<A> \<B>)" "fset ((\<Q> \<A> |\<times>| \<Q> \<B>) |\<times>| \<Q> \<A> |\<times>| \<Q> \<B>)"])
- (auto simp: prod_epsRp_def simp flip: fmember.rep_eq dest: eps_statesD)
+ (auto simp: prod_epsRp_def simp flip: fmember_iff_member_fset dest: eps_statesD)
lemmas finite_prod_eps [simp] = finite_prod_epsLp[unfolded prod_epsLp_def] finite_prod_epsRp[unfolded prod_epsRp_def]
lemma [simp]: "f qs \<rightarrow> q |\<in>| rules (prod_ta \<A> \<B>) \<longleftrightarrow> f qs \<rightarrow> q |\<in>| prod_ta_rules \<A> \<B>"
"r |\<in>| rules (prod_ta \<A> \<B>) \<longleftrightarrow> r |\<in>| prod_ta_rules \<A> \<B>"
by (auto simp: prod_ta_def)
lemma prod_ta_states:
"\<Q> (prod_ta \<A> \<B>) |\<subseteq>| \<Q> \<A> |\<times>| \<Q> \<B>"
proof -
{fix q assume "q |\<in>| rule_states (rules (prod_ta \<A> \<B>))"
then obtain f ps p where "f ps \<rightarrow> p |\<in>| rules (prod_ta \<A> \<B>)" and "q |\<in>| fset_of_list ps \<or> p = q"
by (metis rule_statesE)
then have "fst q |\<in>| \<Q> \<A> \<and> snd q |\<in>| \<Q> \<B>"
using rule_statesD(2, 4)[of f "map fst ps" "fst p" \<A>]
using rule_statesD(2, 4)[of f "map snd ps" "snd p" \<B>]
by auto}
moreover
{fix q assume "q |\<in>| eps_states (eps (prod_ta \<A> \<B>))" then have "fst q |\<in>| \<Q> \<A> \<and> snd q |\<in>| \<Q> \<B>"
by (auto simp: eps_states_def prod_ta_def prod_eps_def dest: eps_statesD)}
ultimately show ?thesis
by (auto simp: \<Q>_def) blast+
qed
lemma prod_ta_det:
assumes "ta_det \<A>" and "ta_det \<B>"
shows "ta_det (prod_ta \<A> \<B>)"
using assms unfolding ta_det_def prod_ta_def prod_eps_def
by auto
lemma prod_ta_sig:
"ta_sig (prod_ta \<A> \<B>) |\<subseteq>| ta_sig \<A> |\<union>| ta_sig \<B>"
by (auto simp add: ta_sig_def fimage_iff fBall_def)+
lemma from_prod_eps:
"(p, q) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+| \<Longrightarrow> (snd p, snd q) |\<notin>| (eps \<B>)|\<^sup>+| \<Longrightarrow> snd p = snd q \<and> (fst p, fst q) |\<in>| (eps \<A>)|\<^sup>+|"
"(p, q) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+| \<Longrightarrow> (fst p, fst q) |\<notin>| (eps \<A>)|\<^sup>+| \<Longrightarrow> fst p = fst q \<and> (snd p, snd q) |\<in>| (eps \<B>)|\<^sup>+|"
apply (induct rule: ftrancl_induct)
apply (auto simp: prod_ta_def prod_eps_def intro: ftrancl_into_trancl )
apply (simp add: fr_into_trancl not_ftrancl_into)+
done
lemma to_prod_eps\<A>:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> r |\<in>| \<Q> \<B> \<Longrightarrow> ((p, r), (q, r)) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|"
by (induct rule: ftrancl_induct)
(auto simp: prod_ta_def prod_eps_def intro: fr_into_trancl ftrancl_into_trancl)
lemma to_prod_eps\<B>:
"(p, q) |\<in>| (eps \<B>)|\<^sup>+| \<Longrightarrow> r |\<in>| \<Q> \<A> \<Longrightarrow> ((r, p), (r, q)) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|"
by (induct rule: ftrancl_induct)
(auto simp: prod_ta_def prod_eps_def intro: fr_into_trancl ftrancl_into_trancl)
lemma to_prod_eps:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> (p', q') |\<in>| (eps \<B>)|\<^sup>+| \<Longrightarrow> ((p, p'), (q, q')) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|"
proof (induct rule: ftrancl_induct)
case (Base a b)
show ?case using Base(2, 1)
proof (induct rule: ftrancl_induct)
case (Base c d)
then have "((a, c), b, c) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|" using finite_prod_eps
by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl ftrancl_into_trancl)
moreover have "((b, c), b, d) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|" using finite_prod_eps Base
by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl ftrancl_into_trancl)
ultimately show ?case
by (auto intro: ftrancl_trans)
next
case (Step p q r)
then have "((b, q), b, r) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|" using finite_prod_eps
by (auto simp: prod_ta_def prod_eps_def dest: eps_statesD intro!: fr_into_trancl)
then show ?case using Step
by (auto intro: ftrancl_trans)
qed
next
case (Step a b c)
from Step have "q' |\<in>| \<Q> \<B>"
by (auto dest: eps_trancl_statesD)
then have "((b, q'), (c,q')) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|"
using Step(3) finite_prod_eps
by (auto simp: prod_ta_def prod_eps_def intro!: fr_into_trancl)
then show ?case using ftrancl_trans Step
by auto
qed
lemma prod_ta_der_to_\<A>_\<B>_der1:
assumes "q |\<in>| ta_der (prod_ta \<A> \<B>) (term_of_gterm t)"
shows "fst q |\<in>| ta_der \<A> (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then show ?case
by (auto dest: from_prod_eps intro!: exI[of _ "map fst ps"] exI[of _ "fst p"])
qed
lemma prod_ta_der_to_\<A>_\<B>_der2:
assumes "q |\<in>| ta_der (prod_ta \<A> \<B>) (term_of_gterm t)"
shows "snd q |\<in>| ta_der \<B> (term_of_gterm t)" using assms
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then show ?case
by (auto dest: from_prod_eps intro!: exI[of _ "map snd ps"] exI[of _ "snd p"])
qed
lemma \<A>_\<B>_der_to_prod_ta:
assumes "fst q |\<in>| ta_der \<A> (term_of_gterm t)" "snd q |\<in>| ta_der \<B> (term_of_gterm t)"
shows "q |\<in>| ta_der (prod_ta \<A> \<B>) (term_of_gterm t)" using assms
proof (induct t arbitrary: q)
case (GFun f ts)
from GFun(2, 3) obtain ps qs p q' where
rules: "f ps \<rightarrow> p |\<in>| rules \<A>" "f qs \<rightarrow> q' |\<in>| rules \<B>" "length ps = length ts" "length ps = length qs" and
eps: "p = fst q \<or> (p, fst q) |\<in>| (eps \<A>)|\<^sup>+|" "q' = snd q \<or> (q', snd q) |\<in>| (eps \<B>)|\<^sup>+|" and
steps: "\<forall> i < length qs. ps ! i |\<in>| ta_der \<A> (term_of_gterm (ts ! i))"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<B> (term_of_gterm (ts ! i))"
by auto
from rules have st: "p |\<in>| \<Q> \<A>" "q' |\<in>| \<Q> \<B>" by (auto dest: rule_statesD)
have "(p, snd q) = q \<or> ((p, q'), q) |\<in>| (eps (prod_ta \<A> \<B>))|\<^sup>+|" using eps st
using to_prod_eps\<B>[of q' "snd q" \<B> "fst q" \<A>]
using to_prod_eps\<A>[of p "fst q" \<A> "snd q" \<B>]
using to_prod_eps[of p "fst q" \<A> q' "snd q" \<B>]
by (cases "p = fst q"; cases "q' = snd q") (auto simp: prod_ta_def)
then show ?case using rules eps steps GFun(1) st
by (cases "(p, snd q) = q")
(auto simp: finite_Collect_prod_ta_rules dest: to_prod_eps\<B> intro!: exI[of _ p] exI[of _ q'] exI[of _ "zip ps qs"])
qed
lemma prod_ta_der:
"q |\<in>| ta_der (prod_ta \<A> \<B>) (term_of_gterm t) \<longleftrightarrow>
fst q |\<in>| ta_der \<A> (term_of_gterm t) \<and> snd q |\<in>| ta_der \<B> (term_of_gterm t)"
using prod_ta_der_to_\<A>_\<B>_der1 prod_ta_der_to_\<A>_\<B>_der2 \<A>_\<B>_der_to_prod_ta
by blast
lemma intersect_ta_gta_lang:
"gta_lang (Q\<^sub>\<A> |\<times>| Q\<^sub>\<B>) (prod_ta \<A> \<B>) = gta_lang Q\<^sub>\<A> \<A> \<inter> gta_lang Q\<^sub>\<B> \<B>"
by (auto simp: prod_ta_der elim!: gta_langE intro: gta_langI)
lemma \<L>_intersect: "\<L> (reg_intersect R L) = \<L> R \<inter> \<L> L"
by (auto simp: intersect_ta_gta_lang \<L>_def reg_intersect_def)
lemma intersect_ta_ta_lang:
"ta_lang (Q\<^sub>\<A> |\<times>| Q\<^sub>\<B>) (prod_ta \<A> \<B>) = ta_lang Q\<^sub>\<A> \<A> \<inter> ta_lang Q\<^sub>\<B> \<B>"
using intersect_ta_gta_lang[of Q\<^sub>\<A> Q\<^sub>\<B> \<A> \<B>]
by auto (metis IntI imageI term_of_gterm_inv)
\<comment> \<open>Union of tree automata\<close>
lemma ta_union_ta_subset:
"ta_subset \<A> (ta_union \<A> \<B>)" "ta_subset \<B> (ta_union \<A> \<B>)"
unfolding ta_subset_def ta_union_def
by auto
lemma ta_union_states [simp]:
"\<Q> (ta_union \<A> \<B>) = \<Q> \<A> |\<union>| \<Q> \<B>"
by (auto simp: ta_union_def \<Q>_def)
lemma ta_union_sig [simp]:
"ta_sig (ta_union \<A> \<B>) = ta_sig \<A> |\<union>| ta_sig \<B>"
by (auto simp: ta_union_def ta_sig_def)
lemma ta_union_eps_disj_states:
assumes "\<Q> \<A> |\<inter>| \<Q> \<B> = {||}" and "(p, q) |\<in>| (eps (ta_union \<A> \<B>))|\<^sup>+|"
shows "(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<or> (p, q) |\<in>| (eps \<B>)|\<^sup>+|" using assms(2, 1)
by (induct rule: ftrancl_induct)
(auto simp: ta_union_def ftrancl_into_trancl dest: eps_statesD eps_trancl_statesD)
lemma eps_ta_union_eps [simp]:
"(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> (p, q) |\<in>| (eps (ta_union \<A> \<B>))|\<^sup>+|"
"(p, q) |\<in>| (eps \<B>)|\<^sup>+| \<Longrightarrow> (p, q) |\<in>| (eps (ta_union \<A> \<B>))|\<^sup>+|"
by (auto simp add: in_ftrancl_UnI ta_union_def)
lemma disj_states_eps [simp]:
"\<Q> \<A> |\<inter>| \<Q> \<B> = {||} \<Longrightarrow> f ps \<rightarrow> p |\<in>| rules \<A> \<Longrightarrow> (p, q) |\<in>| (eps \<B>)|\<^sup>+| \<longleftrightarrow> False"
"\<Q> \<A> |\<inter>| \<Q> \<B> = {||} \<Longrightarrow> f ps \<rightarrow> p |\<in>| rules \<B> \<Longrightarrow> (p, q) |\<in>| (eps \<A>)|\<^sup>+| \<longleftrightarrow> False"
by (auto simp: rtrancl_eq_or_trancl dest: rule_statesD eps_trancl_statesD)
lemma ta_union_der_disj_states:
assumes "\<Q> \<A> |\<inter>| \<Q> \<B> = {||}" and "q |\<in>| ta_der (ta_union \<A> \<B>) t"
shows "q |\<in>| ta_der \<A> t \<or> q |\<in>| ta_der \<B> t" using assms(2)
proof (induct rule: ta_der_induct)
case (Var q v)
then show ?case using ta_union_eps_disj_states[OF assms(1)]
by auto
next
case (Fun f ts ps p q)
have dist: "fset_of_list ps |\<subseteq>| \<Q> \<A> \<Longrightarrow> i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<A> (ts ! i)"
"fset_of_list ps |\<subseteq>| \<Q> \<B> \<Longrightarrow> i < length ts \<Longrightarrow> ps ! i |\<in>| ta_der \<B> (ts ! i)" for i
using Fun(2) Fun(5)[of i] assms(1)
by (auto dest!: ta_der_not_stateD fsubsetD)
from Fun(1) consider (a) "fset_of_list ps |\<subseteq>| \<Q> \<A>" | (b) "fset_of_list ps |\<subseteq>| \<Q> \<B>"
by (auto simp: ta_union_def dest: rule_statesD)
then show ?case using dist Fun(1, 2) assms(1) ta_union_eps_disj_states[OF assms(1), of p q] Fun(3)
by (cases) (auto simp: fsubsetI rule_statesD ta_union_def intro!: exI[of _ p] exI[of _ ps])
qed
lemma ta_union_der_disj_states':
assumes "\<Q> \<A> |\<inter>| \<Q> \<B> = {||}"
shows "ta_der (ta_union \<A> \<B>) t = ta_der \<A> t |\<union>| ta_der \<B> t"
using ta_union_der_disj_states[OF assms] ta_der_mono' ta_union_ta_subset
by (auto, fastforce) blast
lemma ta_union_gta_lang:
assumes "\<Q> \<A> |\<inter>| \<Q> \<B> = {||}" and "Q\<^sub>\<A> |\<subseteq>| \<Q> \<A>" and "Q\<^sub>\<B> |\<subseteq>| \<Q> \<B>"
shows"gta_lang (Q\<^sub>\<A> |\<union>| Q\<^sub>\<B>) (ta_union \<A> \<B>) = gta_lang Q\<^sub>\<A> \<A> \<union> gta_lang Q\<^sub>\<B> \<B>" (is "?Ls = ?Rs")
proof -
{fix s assume "s \<in> ?Ls" then obtain q
where w: "q |\<in>| Q\<^sub>\<A> |\<union>| Q\<^sub>\<B>" "q |\<in>| ta_der (ta_union \<A> \<B>) (term_of_gterm s)"
by (auto elim: gta_langE)
from ta_union_der_disj_states[OF assms(1) w(2)] consider
(a) "q |\<in>| ta_der \<A> (term_of_gterm s)" | "q |\<in>| ta_der \<B> (term_of_gterm s)" by blast
then have "s \<in> ?Rs" using w(1) assms
by (cases, auto simp: gta_langI)
(metis fempty_iff finterI funion_iff gterm_ta_der_states sup.orderE)}
moreover have "?Rs \<subseteq> ?Ls" using ta_union_der_disj_states'[OF assms(1)]
by (auto elim!: gta_langE intro!: gta_langI)
ultimately show ?thesis by blast
qed
lemma \<L>_union: "\<L> (reg_union R L) = \<L> R \<union> \<L> L"
proof -
let ?inl = "Inl :: 'b \<Rightarrow> 'b + 'c" let ?inr = "Inr :: 'c \<Rightarrow> 'b + 'c"
let ?fr = "?inl |`| (fin R |\<inter>| \<Q>\<^sub>r R)" let ?fl = "?inr |`| (fin L |\<inter>| \<Q>\<^sub>r L)"
have [simp]:"gta_lang (?fr |\<union>| ?fl) (ta_union (fmap_states_ta ?inl (ta R)) (fmap_states_ta ?inr (ta L))) =
gta_lang ?fr (fmap_states_ta ?inl (ta R)) \<union> gta_lang ?fl (fmap_states_ta ?inr (ta L))"
by (intro ta_union_gta_lang) (auto simp: fimage_iff)
have [simp]: "gta_lang ?fr (fmap_states_ta ?inl (ta R)) = gta_lang (fin R |\<inter>| \<Q>\<^sub>r R) (ta R)"
by (intro fmap_states_ta_lang) (auto simp: finj_Inl_Inr)
have [simp]: "gta_lang ?fl (fmap_states_ta ?inr (ta L)) = gta_lang (fin L |\<inter>| \<Q>\<^sub>r L) (ta L)"
by (intro fmap_states_ta_lang) (auto simp: finj_Inl_Inr)
show ?thesis
using gta_lang_Rest_states_conv
by (auto simp: \<L>_def reg_union_def ta_union_gta_lang) fastforce
qed
lemma reg_union_states:
"\<Q>\<^sub>r (reg_union A B) = (Inl |`| \<Q>\<^sub>r A) |\<union>| (Inr |`| \<Q>\<^sub>r B)"
by (auto simp: reg_union_def)
\<comment> \<open>Deciding emptiness\<close>
lemma ta_empty [simp]:
"ta_empty Q \<A> = (gta_lang Q \<A> = {})"
by (auto simp: ta_empty_def elim!: gta_langE ta_reachable_gtermE
intro: ta_reachable_gtermI gta_langI)
lemma reg_empty [simp]:
"reg_empty R = (\<L> R = {})"
by (simp add: \<L>_def reg_empty_def)
text \<open>Epsilon free automaton\<close>
lemma finite_eps_free_rulep [simp]:
"finite (Collect (eps_free_rulep \<A>))"
proof -
let ?par = "(\<lambda> r. case r of f qs \<rightarrow> q \<Rightarrow> (f, qs)) |`| (rules \<A>)"
let ?st = "(\<lambda> (r, q). case r of (f, qs) \<Rightarrow> TA_rule f qs q) |`| (?par |\<times>| \<Q> \<A>)"
show ?thesis using rule_statesD eps_trancl_statesD
by (intro finite_subset[of "Collect (eps_free_rulep \<A>)" "fset ?st"])
(auto simp: eps_free_rulep_def fimage_iff
- simp flip: fset.set_map fmember.rep_eq
+ simp flip: fset.set_map fmember_iff_member_fset
split!: ta_rule.splits, fastforce+)
qed
lemmas finite_eps_free_rule [simp] = finite_eps_free_rulep[unfolded eps_free_rulep_def]
lemma ta_res_eps_free:
"ta_der (eps_free \<A>) (term_of_gterm t) = ta_der \<A> (term_of_gterm t)" (is "?Ls = ?Rs")
proof -
{fix q assume "q |\<in>| ?Ls" then have "q |\<in>| ?Rs"
by (induct rule: ta_der_gterm_induct)
(auto simp: eps_free_def eps_free_rulep_def)}
moreover
{fix q assume "q |\<in>| ?Rs" then have "q |\<in>| ?Ls"
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then show ?case
by (auto simp: eps_free_def eps_free_rulep_def intro!: exI[of _ ps])
qed}
ultimately show ?thesis by blast
qed
lemma ta_lang_eps_free [simp]:
"gta_lang Q (eps_free \<A>) = gta_lang Q \<A>"
by (auto simp add: ta_res_eps_free elim!: gta_langE intro: gta_langI)
lemma \<L>_eps_free: "\<L> (eps_free_reg R) = \<L> R"
by (auto simp: \<L>_def eps_free_reg_def)
text \<open>Sufficient criterion for containment\<close>
(* sufficient criterion to check whether automaton accepts at least T_g(F) where F is a subset of
the signature *)
definition ta_contains_aux :: "('f \<times> nat) set \<Rightarrow> 'q fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q fset \<Rightarrow> bool" where
"ta_contains_aux \<F> Q\<^sub>1 \<A> Q\<^sub>2 \<equiv> (\<forall> f qs. (f, length qs) \<in> \<F> \<and> fset_of_list qs |\<subseteq>| Q\<^sub>1 \<longrightarrow>
(\<exists> q q'. TA_rule f qs q |\<in>| rules \<A> \<and> q' |\<in>| Q\<^sub>2 \<and> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|)))"
lemma ta_contains_aux_state_set:
assumes "ta_contains_aux \<F> Q \<A> Q" "t \<in> \<T>\<^sub>G \<F>"
shows "\<exists> q. q |\<in>| Q \<and> q |\<in>| ta_der \<A> (term_of_gterm t)" using assms(2)
proof (induct rule: \<T>\<^sub>G.induct)
case (const a)
then show ?case using assms(1)
by (force simp: ta_contains_aux_def)
next
case (ind f n ss)
obtain qs where "fset_of_list qs |\<subseteq>| Q" "length ss = length qs"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (term_of_gterm (ss ! i))"
using ind(4) Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| Q \<and> q |\<in>| ta_der \<A> (term_of_gterm (ss ! i))"]
by (auto simp: fset_list_fsubset_eq_nth_conv) metis
then show ?case using ind(1 - 3) assms(1)
by (auto simp: ta_contains_aux_def) blast
qed
lemma ta_contains_aux_mono:
assumes "ta_subset \<A> \<B>" and "Q\<^sub>2 |\<subseteq>| Q\<^sub>2'"
shows "ta_contains_aux \<F> Q\<^sub>1 \<A> Q\<^sub>2 \<Longrightarrow> ta_contains_aux \<F> Q\<^sub>1 \<B> Q\<^sub>2'"
using assms unfolding ta_contains_aux_def ta_subset_def
by (meson fin_mono ftrancl_mono)
definition ta_contains :: "('f \<times> nat) set \<Rightarrow> ('f \<times> nat) set \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q fset \<Rightarrow> 'q fset \<Rightarrow> bool"
where "ta_contains \<F> \<G> \<A> Q Q\<^sub>f \<equiv> ta_contains_aux \<F> Q \<A> Q \<and> ta_contains_aux \<G> Q \<A> Q\<^sub>f"
lemma ta_contains_mono:
assumes "ta_subset \<A> \<B>" and "Q\<^sub>f |\<subseteq>| Q\<^sub>f'"
shows "ta_contains \<F> \<G> \<A> Q Q\<^sub>f \<Longrightarrow> ta_contains \<F> \<G> \<B> Q Q\<^sub>f'"
unfolding ta_contains_def
using ta_contains_aux_mono[OF assms(1) fsubset_refl]
using ta_contains_aux_mono[OF assms]
by blast
lemma ta_contains_both:
assumes contain: "ta_contains \<F> \<G> \<A> Q Q\<^sub>f"
shows "\<And> t. groot t \<in> \<G> \<Longrightarrow> \<Union> (funas_gterm ` set (gargs t)) \<subseteq> \<F> \<Longrightarrow> t \<in> gta_lang Q\<^sub>f \<A>"
proof -
fix t :: "'a gterm"
assume F: "\<Union> (funas_gterm ` set (gargs t)) \<subseteq> \<F>" and G: "groot t \<in> \<G>"
obtain g ss where t[simp]: "t = GFun g ss" by (cases t, auto)
then have "\<exists> qs. length qs = length ss \<and> (\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (term_of_gterm (ss ! i)) \<and> qs ! i |\<in>| Q)"
using contain ta_contains_aux_state_set[of \<F> Q \<A> "ss ! i" for i] F
unfolding ta_contains_def \<T>\<^sub>G_funas_gterm_conv
using Ex_list_of_length_P[of "length ss" "\<lambda> q i. q |\<in>| Q \<and> q |\<in>| ta_der \<A> (term_of_gterm (ss ! i))"]
by auto (metis SUP_le_iff nth_mem)
then obtain qs where " length qs = length ss"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (term_of_gterm (ss ! i))"
"\<forall> i < length qs. qs ! i |\<in>| Q"
by blast
then obtain q where "q |\<in>| Q\<^sub>f" "q |\<in>| ta_der \<A> (term_of_gterm t)"
using conjunct2[OF contain[unfolded ta_contains_def]] G
by (auto simp: ta_contains_def ta_contains_aux_def fset_list_fsubset_eq_nth_conv) metis
then show "t \<in> gta_lang Q\<^sub>f \<A>"
by (intro gta_langI) simp
qed
lemma ta_contains:
assumes contain: "ta_contains \<F> \<F> \<A> Q Q\<^sub>f"
shows "\<T>\<^sub>G \<F> \<subseteq> gta_lang Q\<^sub>f \<A>" (is "?A \<subseteq> _")
proof -
have [simp]: "funas_gterm t \<subseteq> \<F> \<Longrightarrow> groot t \<in> \<F>" for t by (cases t) auto
have [simp]: "funas_gterm t \<subseteq> \<F> \<Longrightarrow> \<Union> (funas_gterm ` set (gargs t)) \<subseteq> \<F>" for t
by (cases t) auto
show ?thesis using ta_contains_both[OF contain]
by (auto simp: \<T>\<^sub>G_equivalent_def)
qed
text \<open>Relabeling, map finite set to natural numbers\<close>
lemma map_fset_to_nat_inj:
assumes "Y |\<subseteq>| X"
shows "finj_on (map_fset_to_nat X) Y"
proof -
{ fix x y assume "x |\<in>| X" "y |\<in>| X"
then have "x |\<in>| fset_of_list (sorted_list_of_fset X)" "y |\<in>| fset_of_list (sorted_list_of_fset X)"
by simp_all
note this[unfolded mem_idx_fset_sound]
then have "x = y" if "map_fset_to_nat X x = map_fset_to_nat X y"
using that nth_eq_iff_index_eq[OF distinct_sorted_list_of_fset[of X]]
by (force dest: mem_idx_sound_output simp: map_fset_to_nat_def) }
then show ?thesis using assms
by (auto simp add: finj_on_def' fBall_def)
qed
lemma map_fset_fset_to_nat_inj:
assumes "Y |\<subseteq>| X"
shows "finj_on (map_fset_fset_to_nat X) Y" using assms
proof -
let ?f = "map_fset_fset_to_nat X"
{ fix x y assume "x |\<in>| X" "y |\<in>| X"
then have "sorted_list_of_fset x |\<in>| fset_of_list (sorted_list_of_fset (sorted_list_of_fset |`| X))"
"sorted_list_of_fset y |\<in>| fset_of_list (sorted_list_of_fset (sorted_list_of_fset |`| X))"
unfolding map_fset_fset_to_nat_def by auto
note this[unfolded mem_idx_fset_sound]
then have "x = y" if "?f x = ?f y"
using that nth_eq_iff_index_eq[OF distinct_sorted_list_of_fset[of "sorted_list_of_fset |`| X"]]
by (auto simp: map_fset_fset_to_nat_def)
(metis mem_idx_sound_output notin_fset sorted_list_of_fset_simps(1))+}
then show ?thesis using assms
by (auto simp add: finj_on_def' fBall_def)
qed
lemma relabel_gta_lang [simp]:
"gta_lang (relabel_Q\<^sub>f Q \<A>) (relabel_ta \<A>) = gta_lang Q \<A>"
proof -
have "gta_lang (relabel_Q\<^sub>f Q \<A>) (relabel_ta \<A>) = gta_lang (Q |\<inter>| \<Q> \<A>) \<A>"
unfolding relabel_ta_def relabel_Q\<^sub>f_def
by (intro fmap_states_ta_lang2 map_fset_to_nat_inj) simp
then show ?thesis by fastforce
qed
lemma \<L>_relable [simp]: "\<L> (relabel_reg R) = \<L> R"
by (auto simp: \<L>_def relabel_reg_def)
lemma relabel_ta_lang [simp]:
"ta_lang (relabel_Q\<^sub>f Q \<A>) (relabel_ta \<A>) = ta_lang Q \<A>"
unfolding ta_lang_to_gta_lang
using relabel_gta_lang
by simp
lemma relabel_fset_gta_lang [simp]:
"gta_lang (relabel_fset_Q\<^sub>f Q \<A>) (relabel_fset_ta \<A>) = gta_lang Q \<A>"
proof -
have "gta_lang (relabel_fset_Q\<^sub>f Q \<A>) (relabel_fset_ta \<A>) = gta_lang (Q |\<inter>| \<Q> \<A>) \<A>"
unfolding relabel_fset_Q\<^sub>f_def relabel_fset_ta_def
by (intro fmap_states_ta_lang2 map_fset_fset_to_nat_inj) simp
then show ?thesis by fastforce
qed
lemma \<L>_relable_fset [simp]: "\<L> (relable_fset_reg R) = \<L> R"
by (auto simp: \<L>_def relable_fset_reg_def)
lemma ta_states_trim_ta:
"\<Q> (trim_ta Q \<A>) |\<subseteq>| \<Q> \<A>"
unfolding trim_ta_def using ta_prod_reach_states .
lemma trim_ta_reach: "\<Q> (trim_ta Q \<A>) |\<subseteq>| ta_reachable (trim_ta Q \<A>)"
unfolding trim_ta_def using ta_only_prod_reachable ta_only_reach_reachable
by metis
lemma trim_ta_prod: "\<Q> (trim_ta Q A) |\<subseteq>| ta_productive Q (trim_ta Q A)"
unfolding trim_ta_def using ta_only_prod_productive
by metis
lemma empty_gta_lang:
"gta_lang Q (TA {||} {||}) = {}"
using ta_reachable_gtermI
by (force simp: gta_lang_def gta_der_def elim!: ta_langE)
abbreviation empty_reg where
"empty_reg \<equiv> Reg {||} (TA {||} {||})"
lemma \<L>_epmty:
"\<L> empty_reg = {}"
by (auto simp: \<L>_def empty_gta_lang)
lemma const_ta_lang:
"gta_lang {|q|} (TA {| TA_rule f [] q |} {||}) = {GFun f []}"
proof -
have [dest!]: "q' |\<in>| ta_der (TA {| TA_rule f [] q |} {||}) t' \<Longrightarrow> ground t' \<Longrightarrow> t' = Fun f []" for t' q'
by (induct t') auto
show ?thesis
by (auto simp: gta_lang_def gta_der_def elim!: gta_langE)
(metis gterm_of_term.simps list.simps(8) term_of_gterm_inv)
qed
lemma run_argsD:
"run \<A> s t \<Longrightarrow> length (gargs s) = length (gargs t) \<and> (\<forall> i < length (gargs t). run \<A> (gargs s ! i) (gargs t ! i))"
using run.cases by fastforce
lemma run_root_rule:
"run \<A> s t \<Longrightarrow> TA_rule (groot_sym t) (map ex_comp_state (gargs s)) (ex_rule_state s) |\<in>| (rules \<A>) \<and>
(ex_rule_state s = ex_comp_state s \<or> (ex_rule_state s, ex_comp_state s) |\<in>| (eps \<A>)|\<^sup>+|)"
by (cases s; cases t) (auto elim: run.cases)
lemma run_poss_eq: "run \<A> s t \<Longrightarrow> gposs s = gposs t"
by (induct rule: run.induct) auto
lemma run_gsubt_cl:
assumes "run \<A> s t" and "p \<in> gposs t"
shows "run \<A> (gsubt_at s p) (gsubt_at t p)" using assms
proof (induct p arbitrary: s t)
case (Cons i p) show ?case using Cons(1) Cons(2-)
by (cases s; cases t) (auto dest: run_argsD)
qed auto
lemma run_replace_at:
assumes "run \<A> s t" and "run \<A> u v" and "p \<in> gposs s"
and "ex_comp_state (gsubt_at s p) = ex_comp_state u"
shows "run \<A> s[p \<leftarrow> u]\<^sub>G t[p \<leftarrow> v]\<^sub>G" using assms
proof (induct p arbitrary: s t)
case (Cons i p)
obtain r q qs f ts where [simp]: "s = GFun (r, q) qs" "t = GFun f ts" by (cases s, cases t) auto
have *: "j < length qs \<Longrightarrow> ex_comp_state (qs[i := (qs ! i)[p \<leftarrow> u]\<^sub>G] ! j) = ex_comp_state (qs ! j)" for j
using Cons(5) by (cases "i = j", cases p) auto
have [simp]: "map ex_comp_state (qs[i := (qs ! i)[p \<leftarrow> u]\<^sub>G]) = map ex_comp_state qs" using Cons(5)
by (auto simp: *[unfolded comp_def] intro!: nth_equalityI)
have "run \<A> (qs ! i)[p \<leftarrow> u]\<^sub>G (ts ! i)[p \<leftarrow> v]\<^sub>G" using Cons(2-)
by (intro Cons(1)) (auto dest: run_argsD)
moreover have "i < length qs" "i < length ts" using Cons(4) run_poss_eq[OF Cons(2)]
by force+
ultimately show ?case using Cons(2) run_root_rule[OF Cons(2)]
by (fastforce simp: nth_list_update dest: run_argsD intro!: run.intros)
qed simp
text \<open>relating runs to derivation definition\<close>
lemma run_to_comp_st_gta_der:
"run \<A> s t \<Longrightarrow> ex_comp_state s |\<in>| gta_der \<A> t"
proof (induct s arbitrary: t)
case (GFun q qs)
show ?case using GFun(1)[OF nth_mem, of i "gargs t ! i" for i]
using run_argsD[OF GFun(2)] run_root_rule[OF GFun(2-)]
by (cases t) (auto simp: gta_der_def intro!: exI[of _ "map ex_comp_state qs"] exI[of _ "fst q"])
qed
lemma run_to_rule_st_gta_der:
assumes "run \<A> s t" shows "ex_rule_state s |\<in>| gta_der \<A> t"
proof (cases s)
case [simp]: (GFun q qs)
have "i < length qs \<Longrightarrow> ex_comp_state (qs ! i) |\<in>| gta_der \<A> (gargs t ! i)" for i
using run_to_comp_st_gta_der[of \<A>] run_argsD[OF assms] by force
then show ?thesis using conjunct1[OF run_argsD[OF assms]] run_root_rule[OF assms]
by (cases t) (auto simp: gta_der_def intro!: exI[of _ "map ex_comp_state qs"] exI[of _ "fst q"])
qed
lemma run_to_gta_der_gsubt_at:
assumes "run \<A> s t" and "p \<in> gposs t"
shows "ex_rule_state (gsubt_at s p) |\<in>| gta_der \<A> (gsubt_at t p)"
"ex_comp_state (gsubt_at s p) |\<in>| gta_der \<A> (gsubt_at t p)"
using assms run_gsubt_cl[THEN run_to_comp_st_gta_der] run_gsubt_cl[THEN run_to_rule_st_gta_der]
by blast+
lemma gta_der_to_run:
"q |\<in>| gta_der \<A> t \<Longrightarrow> (\<exists> p qs. run \<A> (GFun (p, q) qs) t)" unfolding gta_der_def
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
from GFun(5) Ex_list_of_length_P[of "length ts" "\<lambda> qs i. run \<A> (GFun (fst qs, ps ! i) (snd qs)) (ts ! i)"]
obtain qss where mid: "length qss = length ts" "\<forall> i < length ts .run \<A> (GFun (fst (qss ! i), ps ! i) (snd (qss ! i))) (ts ! i)"
by auto
have [simp]: "map (ex_comp_state \<circ> (\<lambda>(qs, y). GFun (fst y, qs) (snd y))) (zip ps qss) = ps" using GFun(2) mid(1)
by (intro nth_equalityI) auto
show ?case using mid GFun(1 - 4)
by (intro exI[of _ p] exI[of _ "map2 (\<lambda> f args. GFun (fst args, f) (snd args)) ps qss"])
(auto intro: run.intros)
qed
lemma run_ta_der_ctxt_split1:
assumes "run \<A> s t" "p \<in> gposs t"
shows "ex_comp_state s |\<in>| ta_der \<A> (ctxt_at_pos (term_of_gterm t) p)\<langle>Var (ex_comp_state (gsubt_at s p))\<rangle>"
using assms
proof (induct p arbitrary: s t)
case (Cons i p)
obtain q f qs ts where [simp]: "s = GFun q qs" "t = GFun f ts" and l: "length qs = length ts"
using run_argsD[OF Cons(2)] by (cases s, cases t) auto
from Cons(2, 3) l have "ex_comp_state (qs ! i) |\<in>| ta_der \<A> (ctxt_at_pos (term_of_gterm (ts ! i)) p)\<langle>Var (ex_comp_state (gsubt_at (qs ! i) p))\<rangle>"
by (intro Cons(1)) (auto dest: run_argsD)
then show ?case using Cons(2-) l
by (fastforce simp: nth_append_Cons min_def dest: run_root_rule run_argsD
intro!: exI[of _ "map ex_comp_state (gargs s)"] exI[of _ "ex_rule_state s"]
run_to_comp_st_gta_der[of \<A> "qs ! i" "ts ! i" for i, unfolded comp_def gta_der_def])
qed auto
lemma run_ta_der_ctxt_split2:
assumes "run \<A> s t" "p \<in> gposs t"
shows "ex_comp_state s |\<in>| ta_der \<A> (ctxt_at_pos (term_of_gterm t) p)\<langle>Var (ex_rule_state (gsubt_at s p))\<rangle>"
proof (cases "ex_rule_state (gsubt_at s p) = ex_comp_state (gsubt_at s p)")
case False then show ?thesis
using run_root_rule[OF run_gsubt_cl[OF assms]]
by (intro ta_der_eps_ctxt[OF run_ta_der_ctxt_split1[OF assms]]) auto
qed (auto simp: run_ta_der_ctxt_split1[OF assms, unfolded comp_def])
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Abstract_Impl.thy b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Abstract_Impl.thy
--- a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Abstract_Impl.thy
+++ b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Abstract_Impl.thy
@@ -1,333 +1,333 @@
theory Tree_Automata_Abstract_Impl
imports Tree_Automata_Det Horn_Fset
begin
section \<open>Computing state derivation\<close>
lemma ta_der_Var_code [code]:
"ta_der \<A> (Var q) = finsert q ((eps \<A>)|\<^sup>+| |``| {|q|})"
by (auto)
lemma ta_der_Fun_code [code]:
"ta_der \<A> (Fun f ts) =
(let args = map (ta_der \<A>) ts in
let P = (\<lambda> r. case r of TA_rule g ps p \<Rightarrow> f = g \<and> list_all2 fmember ps args) in
let S = r_rhs |`| ffilter P (rules \<A>) in
S |\<union>| (eps \<A>)|\<^sup>+| |``| S)" (is "?Ls = ?Rs")
proof
{fix q assume "q |\<in>| ?Ls" then have "q |\<in>| ?Rs"
by (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
split!: ta_rule.splits) force}
then show "?Ls |\<subseteq>| ?Rs" by blast
next
{fix q assume "q |\<in>| ?Rs" then have "q |\<in>| ?Ls"
apply (auto simp: Let_def ffmember_filter fimage_iff fBex_def list_all2_conv_all_nth fImage_iff
split!: ta_rule.splits)
apply (metis ta_rule.collapse)
apply blast
done}
then show "?Rs |\<subseteq>| ?Ls" by blast
qed
definition eps_free_automata where
"eps_free_automata epscl \<A> =
(let ruleps = (\<lambda> r. finsert (r_rhs r) (epscl |``| {|r_rhs r|})) in
let rules = (\<lambda> r. (\<lambda> q. TA_rule (r_root r) (r_lhs_states r) q) |`| (ruleps r)) |`| (rules \<A>) in
TA ( |\<Union>| rules) {||})"
lemma eps_free [code]:
"eps_free \<A> = eps_free_automata ((eps \<A>)|\<^sup>+|) \<A>"
apply (intro TA_equalityI)
apply (auto simp: eps_free_def eps_free_rulep_def eps_free_automata_def)
using fBex_def apply fastforce
apply (metis ta_rule.exhaust_sel)+
done
lemma eps_of_eps_free_automata [simp]:
"eps (eps_free_automata S \<A>) = {||}"
by (auto simp add: eps_free_automata_def)
lemma eps_free_automata_empty [simp]:
"eps \<A> = {||} \<Longrightarrow> eps_free_automata {||} \<A> = \<A>"
by (auto simp add: eps_free_automata_def intro!: TA_equalityI)
section \<open>Computing the restriction of tree automata to state set\<close>
lemma ta_restrict [code]:
"ta_restrict \<A> Q =
(let rules = ffilter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> fset_of_list ps |\<subseteq>| Q \<and> p |\<in>| Q) (rules \<A>) in
let eps = ffilter (\<lambda> r. case r of (p, q) \<Rightarrow> p |\<in>| Q \<and> q |\<in>| Q) (eps \<A>) in
TA rules eps)"
by (auto simp: Let_def ta_restrict_def split!: ta_rule.splits intro: finite_subset[OF _ finite_Collect_ta_rule])
section \<open>Computing the epsilon transition for the product automaton\<close>
lemma prod_eps[code_unfold]:
"fCollect (prod_epsLp \<A> \<B>) = (\<lambda> ((p, q), r). ((p, r), (q, r))) |`| (eps \<A> |\<times>| \<Q> \<B>)"
"fCollect (prod_epsRp \<A> \<B>) = (\<lambda> ((p, q), r). ((r, p), (r, q))) |`| (eps \<B> |\<times>| \<Q> \<A>)"
by (auto simp: finite_prod_epsLp prod_epsLp_def finite_prod_epsRp prod_epsRp_def fimage_iff fBex_def)
section \<open>Computing reachability\<close>
inductive_set ta_reach for \<A> where
rule [intro]: "f qs \<rightarrow> q |\<in>| rules \<A> \<Longrightarrow> \<forall> i < length qs. qs ! i \<in> ta_reach \<A> \<Longrightarrow> q \<in> ta_reach \<A>"
| eps [intro]: "q \<in> ta_reach \<A> \<Longrightarrow> (q, r) |\<in>| eps \<A> \<Longrightarrow> r \<in> ta_reach \<A>"
lemma ta_reach_eps_transI:
assumes "(p, q) |\<in>| (eps \<A>)|\<^sup>+|" "p \<in> ta_reach \<A>"
shows "q \<in> ta_reach \<A>" using assms
by (induct rule: ftrancl_induct) auto
lemma ta_reach_ground_term_der:
assumes "q \<in> ta_reach \<A>"
shows "\<exists> t. ground t \<and> q |\<in>| ta_der \<A> t" using assms
proof (induct)
case (rule f qs q)
then obtain ts where "length ts = length qs"
"\<forall> i < length qs. ground (ts ! i)"
"\<forall> i < length qs. qs ! i |\<in>| ta_der \<A> (ts ! i)"
using Ex_list_of_length_P[of "length qs" "\<lambda> t i. ground t \<and> qs ! i |\<in>| ta_der \<A> t"]
by auto
then show ?case using rule(1)
by (auto dest!: in_set_idx intro!: exI[of _ "Fun f ts"]) blast
qed (auto, meson ta_der_eps)
lemma ground_term_der_ta_reach:
assumes "ground t" "q |\<in>| ta_der \<A> t"
shows "q \<in> ta_reach \<A>" using assms(2, 1)
by (induct rule: ta_der_induct) (auto simp add: rule ta_reach_eps_transI)
lemma ta_reach_reachable:
"ta_reach \<A> = fset (ta_reachable \<A>)"
using ta_reach_ground_term_der[of _ \<A>]
using ground_term_der_ta_reach[of _ _ \<A>]
unfolding ta_reachable_def
- by (auto simp flip: fmember.rep_eq)
+ by (auto simp flip: fmember_iff_member_fset)
subsection \<open>Horn setup for reachable states\<close>
definition "reach_rules \<A> =
{qs \<rightarrow>\<^sub>h q | f qs q. TA_rule f qs q |\<in>| rules \<A>} \<union>
{[q] \<rightarrow>\<^sub>h r | q r. (q, r) |\<in>| eps \<A>}"
locale reach_horn =
fixes \<A> :: "('q, 'f) ta"
begin
sublocale horn "reach_rules \<A>" .
lemma reach_infer0: "infer0 = {q | f q. TA_rule f [] q |\<in>| rules \<A>}"
by (auto simp: horn.infer0_def reach_rules_def)
lemma reach_infer1:
"infer1 p X = {r | f qs r. TA_rule f qs r |\<in>| rules \<A> \<and> p \<in> set qs \<and> set qs \<subseteq> insert p X} \<union>
{r | r. (p, r) |\<in>| eps \<A>}"
unfolding reach_rules_def
by (auto simp: horn.infer1_def simp flip: ex_simps(1))
lemma reach_sound:
"ta_reach \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr x) obtain p where x: "p = ta_reach \<A>" by auto
show ?case using lr unfolding x
proof (induct)
case (rule f qs q)
then show ?case
by (intro infer[of qs q]) (auto simp: reach_rules_def dest: in_set_idx)
next
case (eps q r)
then show ?case
by (intro infer[of "[q]" r]) (auto simp: reach_rules_def)
qed
next
case (rl x)
then show ?case
by (induct) (auto simp: reach_rules_def)
qed
end
subsection \<open>Computing productivity\<close>
text \<open>First, use an alternative definition of productivity\<close>
inductive_set ta_productive_ind :: "'q fset \<Rightarrow> ('q,'f) ta \<Rightarrow> 'q set" for P and \<A> :: "('q,'f) ta" where
basic [intro]: "q |\<in>| P \<Longrightarrow> q \<in> ta_productive_ind P \<A>"
| eps [intro]: "(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<Longrightarrow> q \<in> ta_productive_ind P \<A> \<Longrightarrow> p \<in> ta_productive_ind P \<A>"
| rule: "TA_rule f qs q |\<in>| rules \<A> \<Longrightarrow> q \<in> ta_productive_ind P \<A> \<Longrightarrow> q' \<in> set qs \<Longrightarrow> q' \<in> ta_productive_ind P \<A>"
lemma ta_productive_ind:
"ta_productive_ind P \<A> = fset (ta_productive P \<A>)" (is "?LS = ?RS")
proof -
{fix q assume "q \<in> ?LS" then have "q \<in> ?RS"
- by (induct) (auto dest: ta_prod_epsD simp flip: fmember.rep_eq intro: ta_productive_setI,
+ by (induct) (auto dest: ta_prod_epsD simp flip: fmember_iff_member_fset intro: ta_productive_setI,
metis (full_types) in_set_conv_nth rule_reachable_ctxt_exist ta_productiveI')}
moreover
- {fix q assume "q \<in> ?RS" note * = this[unfolded fmember.rep_eq[symmetric]]
+ {fix q assume "q \<in> ?RS" note * = this[unfolded fmember_iff_member_fset[symmetric]]
from ta_productiveE[OF *] obtain r C where
reach : "r |\<in>| ta_der \<A> C\<langle>Var q\<rangle>" and f: "r |\<in>| P" by auto
from f have "r \<in> ta_productive_ind P \<A>" "r |\<in>| ta_productive P \<A>"
by (auto intro: ta_productive_setI)
then have "q \<in> ?LS" using reach
proof (induct C arbitrary: q r)
case (More f ss C ts)
from iffD1 ta_der_Fun[THEN iffD1, OF More(4)[unfolded ctxt_apply_term.simps]] obtain ps p where
inv: "f ps \<rightarrow> p |\<in>| rules \<A>" "p = r \<or> (p, r) |\<in>| (eps \<A>)|\<^sup>+|" "length ps = length (ss @ C\<langle>Var q\<rangle> # ts)"
"ps ! length ss |\<in>| ta_der \<A> C\<langle>Var q\<rangle>"
by (auto simp: nth_append_Cons split: if_splits)
then have "p \<in> ta_productive_ind P \<A> \<Longrightarrow> p |\<in>| ta_der \<A> C\<langle>Var q\<rangle> \<Longrightarrow> q \<in> ta_productive_ind P \<A>" for p
- using More(1) calculation by (auto simp flip: fmember.rep_eq)
+ using More(1) calculation by (auto simp flip: fmember_iff_member_fset)
note [intro!] = this[of "ps ! length ss"]
show ?case using More(2) inv
- by (auto simp flip: fmember.rep_eq simp: nth_append_Cons ta_productive_ind.rule)
+ by (auto simp flip: fmember_iff_member_fset simp: nth_append_Cons ta_productive_ind.rule)
(metis less_add_Suc1 nth_mem ta_productive_ind.simps)
qed (auto intro: ta_productive_setI)
}
ultimately show ?thesis by auto
qed
subsubsection \<open>Horn setup for productive states\<close>
definition "productive_rules P \<A> = {[] \<rightarrow>\<^sub>h q | q. q |\<in>| P} \<union>
{[r] \<rightarrow>\<^sub>h q | q r. (q, r) |\<in>| eps \<A>} \<union>
{[q] \<rightarrow>\<^sub>h r | f qs q r. TA_rule f qs q |\<in>| rules \<A> \<and> r \<in> set qs}"
locale productive_horn =
fixes \<A> :: "('q, 'f) ta" and P :: "'q fset"
begin
sublocale horn "productive_rules P \<A>" .
lemma productive_infer0: "infer0 = fset P"
- by (auto simp: productive_rules_def horn.infer0_def simp flip: fmember.rep_eq)
+ by (auto simp: productive_rules_def horn.infer0_def simp flip: fmember_iff_member_fset)
lemma productive_infer1:
"infer1 p X = {r | r. (r, p) |\<in>| eps \<A>} \<union>
{r | f qs r. TA_rule f qs p |\<in>| rules \<A> \<and> r \<in> set qs}"
unfolding productive_rules_def horn_infer1_union
by (auto simp add: horn.infer1_def)
(metis insertCI list.set(1) list.simps(15) singletonD subsetI)
lemma productive_sound:
"ta_productive_ind P \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr p) then show ?case using lr
proof (induct)
case (basic q)
then show ?case
by (intro infer[of "[]" q]) (auto simp: productive_rules_def)
next
case (eps p q) then show ?case
proof (induct rule: ftrancl_induct)
case (Base p q)
then show ?case using infer[of "[q]" p]
by (auto simp: productive_rules_def)
next
case (Step p q r)
then show ?case using infer[of "[r]" q]
by (auto simp: productive_rules_def)
qed
next
case (rule f qs q p)
then show ?case
by (intro infer[of "[q]" p]) (auto simp: productive_rules_def)
qed
next
case (rl p)
then show ?case
by (induct) (auto simp: productive_rules_def ta_productive_ind.rule)
qed
end
subsection \<open>Horn setup for power set construction states\<close>
lemma prod_list_exists:
assumes "fst p \<in> set qs" "set qs \<subseteq> insert (fst p) (fst ` X)"
obtains as where "p \<in> set as" "map fst as = qs" "set as \<subseteq> insert p X"
proof -
from assms have "qs \<in> lists (fst ` (insert p X))" by blast
then obtain ts where ts: "map fst ts = qs" "ts \<in> lists (insert p X)"
by (metis image_iff lists_image)
then obtain i where mem: "i < length qs" "qs ! i = fst p" using assms(1)
by (metis in_set_idx)
from ts have p: "ts[i := p] \<in> lists (insert p X)"
using set_update_subset_insert by fastforce
then have "p \<in> set (ts[i := p])" "map fst (ts[i := p]) = qs" "set (ts[i := p]) \<subseteq> insert p X"
using mem ts(1)
by (auto simp add: nth_list_update set_update_memI intro!: nth_equalityI)
then show ?thesis using that
by blast
qed
definition "ps_states_rules \<A> = {rs \<rightarrow>\<^sub>h (Wrapp q) | rs f q.
q = ps_reachable_states \<A> f (map ex rs) \<and> q \<noteq> {||}}"
locale ps_states_horn =
fixes \<A> :: "('q, 'f) ta"
begin
sublocale horn "ps_states_rules \<A>" .
lemma ps_construction_infer0: "infer0 =
{Wrapp q | f q. q = ps_reachable_states \<A> f [] \<and> q \<noteq> {||}}"
- by (auto simp: ps_states_rules_def horn.infer0_def simp flip: fmember.rep_eq)
+ by (auto simp: ps_states_rules_def horn.infer0_def simp flip: fmember_iff_member_fset)
lemma ps_construction_infer1:
"infer1 p X = {Wrapp q | f qs q. q = ps_reachable_states \<A> f (map ex qs) \<and> q \<noteq> {||} \<and>
p \<in> set qs \<and> set qs \<subseteq> insert p X}"
unfolding ps_states_rules_def horn_infer1_union
by (auto simp add: horn.infer1_def ps_reachable_states_def comp_def elim!: prod_list_exists)
lemma ps_states_sound:
"ps_states_set \<A> = saturate"
proof (intro set_eqI iffI, goal_cases lr rl)
case (lr p) then show ?case using lr
proof (induct)
case (1 ps f)
then have "ps \<rightarrow>\<^sub>h (Wrapp (ps_reachable_states \<A> f (map ex ps))) \<in> ps_states_rules \<A>"
by (auto simp: ps_states_rules_def)
then show ?case using horn.saturate.simps 1
by fastforce
qed
next
case (rl p)
then obtain q where "q \<in> saturate" "q = p" by blast
then show ?case
by (induct arbitrary: p)
(auto simp: ps_states_rules_def intro!: ps_states_set.intros)
qed
end
definition ps_reachable_states_cont where
"ps_reachable_states_cont \<Delta> \<Delta>\<^sub>\<epsilon> f ps =
(let R = ffilter (\<lambda> r. case r of TA_rule g qs q \<Rightarrow> f = g \<and> list_all2 (|\<in>|) qs ps) \<Delta> in
let S = r_rhs |`| R in
S |\<union>| \<Delta>\<^sub>\<epsilon>|\<^sup>+| |``| S)"
lemma ps_reachable_states [code]:
"ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f ps = ps_reachable_states_cont \<Delta> \<Delta>\<^sub>\<epsilon> f ps"
by (auto simp: ps_reachable_states_fmember ps_reachable_states_cont_def Let_def fimage_iff fBex_def
split!: ta_rule.splits) force+
definition ps_rules_cont where
"ps_rules_cont \<A> Q =
(let sig = ta_sig \<A> in
let qss = (\<lambda> (f, n). (f, n, fset_of_list (List.n_lists n (sorted_list_of_fset Q)))) |`| sig in
let res = (\<lambda> (f, n, Qs). (\<lambda> qs. TA_rule f qs (Wrapp (ps_reachable_states \<A> f (map ex qs)))) |`| Qs) |`| qss in
ffilter (\<lambda> r. ex (r_rhs r) \<noteq> {||}) ( |\<Union>| res))"
lemma ps_rules [code]:
"ps_rules \<A> Q = ps_rules_cont \<A> Q"
using ps_reachable_states_sig finite_ps_rulesp_unfolded[of Q \<A>]
unfolding ps_rules_cont_def
apply (auto simp: fset_of_list_elem ps_rules_def fin_mono ps_rulesp_def
- fimage_iff set_n_lists simp flip: fmember.rep_eq split!: prod.splits dest!: in_set_idx)
+ fimage_iff set_n_lists simp flip: fmember_iff_member_fset split!: prod.splits dest!: in_set_idx)
apply fastforce
- apply (meson fmember.rep_eq nth_mem subsetD)
+ apply (meson fmember_iff_member_fset nth_mem subsetD)
done
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Complement.thy b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Complement.thy
--- a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Complement.thy
+++ b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Complement.thy
@@ -1,193 +1,193 @@
theory Tree_Automata_Complement
imports Tree_Automata_Det
begin
subsection \<open>Complement closure of regular languages\<close>
definition partially_completely_defined_on where
"partially_completely_defined_on \<A> \<F> \<longleftrightarrow>
(\<forall> t. funas_gterm t \<subseteq> fset \<F> \<longleftrightarrow> (\<exists> q. q |\<in>| ta_der \<A> (term_of_gterm t)))"
definition sig_ta where
"sig_ta \<F> = TA ((\<lambda> (f, n). TA_rule f (replicate n ()) ()) |`| \<F>) {||}"
lemma sig_ta_rules_fmember:
"TA_rule f qs q |\<in>| rules (sig_ta \<F>) \<longleftrightarrow> (\<exists> n. (f, n) |\<in>| \<F> \<and> qs = replicate n () \<and> q = ())"
by (auto simp: sig_ta_def fimage_iff fBex_def)
lemma sig_ta_completely_defined:
"partially_completely_defined_on (sig_ta \<F>) \<F>"
proof -
{fix t assume "funas_gterm t \<subseteq> fset \<F>"
then have "() |\<in>| ta_der (sig_ta \<F>) (term_of_gterm t)"
proof (induct t)
case (GFun f ts)
then show ?case
by (auto simp: sig_ta_rules_fmember SUP_le_iff
- simp flip: fmember.rep_eq intro!: exI[of _ "replicate (length ts) ()"])
+ simp flip: fmember_iff_member_fset intro!: exI[of _ "replicate (length ts) ()"])
qed}
moreover
{fix t q assume "q |\<in>| ta_der (sig_ta \<F>) (term_of_gterm t)"
then have "funas_gterm t \<subseteq> fset \<F>"
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
from GFun(1 - 4) GFun(5)[THEN subsetD] show ?case
- by (auto simp: sig_ta_rules_fmember simp flip: fmember.rep_eq dest!: in_set_idx)
+ by (auto simp: sig_ta_rules_fmember simp flip: fmember_iff_member_fset dest!: in_set_idx)
qed}
ultimately show ?thesis
unfolding partially_completely_defined_on_def
by blast
qed
lemma ta_der_fsubset_sig_ta_completely:
assumes "ta_subset (sig_ta \<F>) \<A>" "ta_sig \<A> |\<subseteq>| \<F>"
shows "partially_completely_defined_on \<A> \<F>"
proof -
have "ta_der (sig_ta \<F>) t |\<subseteq>| ta_der \<A> t" for t
using assms by (simp add: ta_der_mono')
then show ?thesis using sig_ta_completely_defined assms(2)
by (auto simp: partially_completely_defined_on_def)
(metis ffunas_gterm.rep_eq fin_mono notin_fset ta_der_gterm_sig)
qed
lemma completely_definied_ps_taI:
"partially_completely_defined_on \<A> \<F> \<Longrightarrow> partially_completely_defined_on (ps_ta \<A>) \<F>"
unfolding partially_completely_defined_on_def
using ps_rules_not_empty_reach[of \<A>]
using fsubsetD[OF ps_rules_sound[of _ \<A>]] ps_rules_complete[of _ \<A>]
by (metis FSet_Lex_Wrapper.collapse fsubsetI fsubset_fempty)
lemma completely_definied_ta_union1I:
"partially_completely_defined_on \<A> \<F> \<Longrightarrow> ta_sig \<B> |\<subseteq>| \<F> \<Longrightarrow> \<Q> \<A> |\<inter>| \<Q> \<B> = {||} \<Longrightarrow>
partially_completely_defined_on (ta_union \<A> \<B>) \<F>"
unfolding partially_completely_defined_on_def
using ta_union_der_disj_states'[of \<A> \<B>]
by (auto simp: ta_union_der_disj_states)
(metis ffunas_gterm.rep_eq fsubset_trans less_eq_fset.rep_eq ta_der_gterm_sig)
lemma completely_definied_fmaps_statesI:
"partially_completely_defined_on \<A> \<F> \<Longrightarrow> finj_on f (\<Q> \<A>) \<Longrightarrow> partially_completely_defined_on (fmap_states_ta f \<A>) \<F>"
unfolding partially_completely_defined_on_def
using fsubsetD[OF ta_der_fmap_states_ta_mono2, of f \<A>]
using ta_der_to_fmap_states_der[of _ \<A> _ f]
by (auto simp: fimage_iff fBex_def) fastforce+
lemma det_completely_defined_complement:
assumes "partially_completely_defined_on \<A> \<F>" "ta_det \<A>"
shows "gta_lang (\<Q> \<A> |-| Q) \<A> = \<T>\<^sub>G (fset \<F>) - gta_lang Q \<A>" (is "?Ls = ?Rs")
proof -
{fix t assume "t \<in> ?Ls"
then obtain p where p: "p |\<in>| \<Q> \<A>" "p |\<notin>| Q" "p |\<in>| ta_der \<A> (term_of_gterm t)"
by auto
from ta_detE[OF assms(2) p(3)] have "\<forall> q. q |\<in>| ta_der \<A> (term_of_gterm t) \<longrightarrow> q = p"
by blast
moreover have "funas_gterm t \<subseteq> fset \<F>"
using p(3) assms(1) unfolding partially_completely_defined_on_def
by (auto simp: less_eq_fset.rep_eq ffunas_gterm.rep_eq)
ultimately have "t \<in> ?Rs" using p(2)
by (auto simp: \<T>\<^sub>G_equivalent_def)}
moreover
{fix t assume "t \<in> ?Rs"
then have f: "funas_gterm t \<subseteq> fset \<F>" "\<forall> q. q |\<in>| ta_der \<A> (term_of_gterm t) \<longrightarrow> q |\<notin>| Q"
by (auto simp: \<T>\<^sub>G_equivalent_def)
from f(1) obtain p where "p |\<in>| ta_der \<A> (term_of_gterm t)" using assms(1)
by (force simp: partially_completely_defined_on_def)
then have "t \<in> ?Ls" using f(2)
by (auto simp: gterm_ta_der_states intro: gta_langI[of p])}
ultimately show ?thesis by blast
qed
lemma ta_der_gterm_sig_fset:
"q |\<in>| ta_der \<A> (term_of_gterm t) \<Longrightarrow> funas_gterm t \<subseteq> fset (ta_sig \<A>)"
using ta_der_gterm_sig
by (metis ffunas_gterm.rep_eq less_eq_fset.rep_eq)
definition filter_ta_sig where
"filter_ta_sig \<F> \<A> = TA (ffilter (\<lambda> r. (r_root r, length (r_lhs_states r)) |\<in>| \<F>) (rules \<A>)) (eps \<A>)"
definition filter_ta_reg where
"filter_ta_reg \<F> R = Reg (fin R) (filter_ta_sig \<F> (ta R))"
lemma filter_ta_sig:
"ta_sig (filter_ta_sig \<F> \<A>) |\<subseteq>| \<F>"
by (auto simp: ta_sig_def filter_ta_sig_def)
lemma filter_ta_sig_lang:
"gta_lang Q (filter_ta_sig \<F> \<A>) = gta_lang Q \<A> \<inter> \<T>\<^sub>G (fset \<F>)" (is "?Ls = ?Rs")
proof -
let ?A = "filter_ta_sig \<F> \<A>"
{fix t assume "t \<in> ?Ls"
then obtain q where q: "q |\<in>| Q" "q |\<in>| ta_der ?A (term_of_gterm t)"
by auto
then have "funas_gterm t \<subseteq> fset \<F>"
using subset_trans[OF ta_der_gterm_sig_fset[OF q(2)] filter_ta_sig[unfolded less_eq_fset.rep_eq]]
by blast
then have "t \<in> ?Rs" using q
by (auto simp: \<T>\<^sub>G_equivalent_def filter_ta_sig_def
intro!: gta_langI[of q] ta_der_el_mono[where ?q = q and \<B> = \<A> and \<A> = ?A])}
moreover
{fix t assume ass: "t \<in> ?Rs"
then have funas: "funas_gterm t \<subseteq> fset \<F>"
by (auto simp: \<T>\<^sub>G_equivalent_def)
from ass obtain p where p: "p |\<in>| Q" "p |\<in>| ta_der \<A> (term_of_gterm t)"
by auto
from this(2) funas have "p |\<in>| ta_der ?A (term_of_gterm t)"
proof (induct rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then show ?case
- by (auto simp: filter_ta_sig_def SUP_le_iff simp flip: fmember.rep_eq
+ by (auto simp: filter_ta_sig_def SUP_le_iff simp flip: fmember_iff_member_fset
intro!: exI[of _ ps] exI[of _ p])
qed
then have "t \<in> ?Ls" using p(1) by auto}
ultimately show ?thesis by blast
qed
lemma \<L>_filter_ta_reg:
"\<L> (filter_ta_reg \<F> \<A>) = \<L> \<A> \<inter> \<T>\<^sub>G (fset \<F>)"
using filter_ta_sig_lang
by (auto simp: \<L>_def filter_ta_reg_def)
definition sig_ta_reg where
"sig_ta_reg \<F> = Reg {||} (sig_ta \<F>)"
lemma \<L>_sig_ta_reg:
"\<L> (sig_ta_reg \<F>) = {}"
by (auto simp: \<L>_def sig_ta_reg_def)
definition complement_reg where
"complement_reg R \<F> = (let \<A> = ps_reg (reg_union (sig_ta_reg \<F>) R) in
Reg (\<Q>\<^sub>r \<A> |-| fin \<A>) (ta \<A>))"
lemma \<L>_complement_reg:
assumes "ta_sig (ta \<A>) |\<subseteq>| \<F>"
shows "\<L> (complement_reg \<A> \<F>) = \<T>\<^sub>G (fset \<F>) - \<L> \<A>"
proof -
have "\<L> (complement_reg \<A> \<F>) = \<T>\<^sub>G (fset \<F>) - \<L> (ps_reg (reg_union (sig_ta_reg \<F>) \<A>))"
unfolding \<L>_def complement_reg_def using assms
by (auto simp: complement_reg_def Let_def ps_reg_def reg_union_def sig_ta_reg_def
sig_ta_completely_defined finj_Inl_Inr
intro!: det_completely_defined_complement completely_definied_ps_taI
completely_definied_ta_union1I completely_definied_fmaps_statesI)
then show ?thesis
by (auto simp: \<L>_ps_reg \<L>_union \<L>_sig_ta_reg)
qed
lemma \<L>_complement_filter_reg:
"\<L> (complement_reg (filter_ta_reg \<F> \<A>) \<F>) = \<T>\<^sub>G (fset \<F>) - \<L> \<A>"
proof -
have *: "ta_sig (ta (filter_ta_reg \<F> \<A>)) |\<subseteq>| \<F>"
by (auto simp: filter_ta_reg_def filter_ta_sig)
show ?thesis unfolding \<L>_complement_reg[OF *] \<L>_filter_ta_reg
by blast
qed
definition difference_reg where
"difference_reg R L = (let F = ta_sig (ta R) in
reg_intersect R (trim_reg (complement_reg (filter_ta_reg F L) F)))"
lemma \<L>_difference_reg:
"\<L> (difference_reg R L) = \<L> R - \<L> L" (is "?Ls = ?Rs")
unfolding difference_reg_def Let_def \<L>_trim \<L>_intersect \<L>_complement_filter_reg
using reg_funas by blast
end
\ No newline at end of file
diff --git a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Det.thy b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Det.thy
--- a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Det.thy
+++ b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Det.thy
@@ -1,268 +1,268 @@
theory Tree_Automata_Det
imports
Tree_Automata
begin
subsection \<open>Powerset Construction for Tree Automata\<close>
text \<open>
The idea to treat states and transitions separately is from arXiv:1511.03595. Some parts of
the implementation are also based on that paper. (The Algorithm corresponds roughly to the one
in "Step 5")
\<close>
text \<open>Abstract Definitions and Correctness Proof\<close>
definition ps_reachable_statesp where
"ps_reachable_statesp \<A> f ps = (\<lambda> q'. \<exists> qs q. TA_rule f qs q |\<in>| rules \<A> \<and> list_all2 (|\<in>|) qs ps \<and>
(q = q' \<or> (q,q') |\<in>| (eps \<A>)|\<^sup>+|))"
lemma ps_reachable_statespE:
assumes "ps_reachable_statesp \<A> f qs q"
obtains ps p where "TA_rule f ps p |\<in>| rules \<A>" "list_all2 (|\<in>|) ps qs" "(p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)"
using assms unfolding ps_reachable_statesp_def
by auto
lemma ps_reachable_statesp_\<Q>:
"ps_reachable_statesp \<A> f ps q \<Longrightarrow> q |\<in>| \<Q> \<A>"
- by (auto simp: ps_reachable_statesp_def simp flip: fmember.rep_eq dest: rule_statesD eps_trancl_statesD)
+ by (auto simp: ps_reachable_statesp_def simp flip: fmember_iff_member_fset dest: rule_statesD eps_trancl_statesD)
lemma finite_Collect_ps_statep [simp]:
"finite (Collect (ps_reachable_statesp \<A> f ps))" (is "finite ?S")
by (intro finite_subset[of ?S "fset (\<Q> \<A>)"])
- (auto simp: ps_reachable_statesp_\<Q> simp flip: fmember.rep_eq)
+ (auto simp: ps_reachable_statesp_\<Q> simp flip: fmember_iff_member_fset)
lemmas finite_Collect_ps_statep_unfolded [simp] = finite_Collect_ps_statep[unfolded ps_reachable_statesp_def, simplified]
definition "ps_reachable_states \<A> f ps \<equiv> fCollect (ps_reachable_statesp \<A> f ps)"
lemmas ps_reachable_states_simp = ps_reachable_statesp_def ps_reachable_states_def
lemma ps_reachable_states_fmember:
"q' |\<in>| ps_reachable_states \<A> f ps \<longleftrightarrow> (\<exists> qs q. TA_rule f qs q |\<in>| rules \<A> \<and>
list_all2 (|\<in>|) qs ps \<and> (q = q' \<or> (q, q') |\<in>| (eps \<A>)|\<^sup>+|))"
by (auto simp: ps_reachable_states_simp)
lemma ps_reachable_statesI:
assumes "TA_rule f ps p |\<in>| rules \<A>" "list_all2 (|\<in>|) ps qs" "(p = q \<or> (p, q) |\<in>| (eps \<A>)|\<^sup>+|)"
shows "p |\<in>| ps_reachable_states \<A> f qs"
using assms unfolding ps_reachable_states_simp
by auto
lemma ps_reachable_states_sig:
"ps_reachable_states \<A> f ps \<noteq> {||} \<Longrightarrow> (f, length ps) |\<in>| ta_sig \<A>"
by (auto simp: ps_reachable_states_simp ta_sig_def fimage_iff fBex_def dest!: list_all2_lengthD)
text \<open>
A set of "powerset states" is complete if it is sufficient to capture all (non)deterministic
derivations.
\<close>
definition ps_states_complete_it :: "('a, 'b) ta \<Rightarrow> 'a FSet_Lex_Wrapper fset \<Rightarrow> 'a FSet_Lex_Wrapper fset \<Rightarrow> bool"
where "ps_states_complete_it \<A> Q Qnext \<equiv>
\<forall>f ps. fset_of_list ps |\<subseteq>| Q \<and> ps_reachable_states \<A> f (map ex ps) \<noteq> {||} \<longrightarrow> Wrapp (ps_reachable_states \<A> f (map ex ps)) |\<in>| Qnext"
lemma ps_states_complete_itD:
"ps_states_complete_it \<A> Q Qnext \<Longrightarrow> fset_of_list ps |\<subseteq>| Q \<Longrightarrow>
ps_reachable_states \<A> f (map ex ps) \<noteq> {||} \<Longrightarrow> Wrapp (ps_reachable_states \<A> f (map ex ps)) |\<in>| Qnext"
unfolding ps_states_complete_it_def by blast
abbreviation "ps_states_complete \<A> Q \<equiv> ps_states_complete_it \<A> Q Q"
text \<open>The least complete set of states\<close>
inductive_set ps_states_set for \<A> where
"\<forall> p \<in> set ps. p \<in> ps_states_set \<A> \<Longrightarrow> ps_reachable_states \<A> f (map ex ps) \<noteq> {||} \<Longrightarrow>
Wrapp (ps_reachable_states \<A> f (map ex ps)) \<in> ps_states_set \<A>"
lemma ps_states_Pow:
"ps_states_set \<A> \<subseteq> fset (Wrapp |`| fPow (\<Q> \<A>))"
proof -
{fix q assume "q \<in> ps_states_set \<A>" then have "q \<in> fset (Wrapp |`| fPow (\<Q> \<A>))"
- by induct (auto simp: ps_reachable_statesp_\<Q> ps_reachable_states_def image_iff simp flip: fmember.rep_eq)}
+ by induct (auto simp: ps_reachable_statesp_\<Q> ps_reachable_states_def image_iff simp flip: fmember_iff_member_fset)}
then show ?thesis by blast
qed
context
includes fset.lifting
begin
lift_definition ps_states :: "('a, 'b) ta \<Rightarrow> 'a FSet_Lex_Wrapper fset" is ps_states_set
by (auto intro: finite_subset[OF ps_states_Pow])
lemma ps_states: "ps_states \<A> |\<subseteq>| Wrapp |`| fPow (\<Q> \<A>)" using ps_states_Pow
by (simp add: ps_states_Pow less_eq_fset.rep_eq ps_states.rep_eq)
lemmas ps_states_cases = ps_states_set.cases[Transfer.transferred]
lemmas ps_states_induct = ps_states_set.induct[Transfer.transferred]
lemmas ps_states_simps = ps_states_set.simps[Transfer.transferred]
lemmas ps_states_intros= ps_states_set.intros[Transfer.transferred]
end
lemma ps_states_complete:
"ps_states_complete \<A> (ps_states \<A>)"
unfolding ps_states_complete_it_def
by (auto intro: ps_states_intros)
lemma ps_states_least_complete:
assumes "ps_states_complete_it \<A> Q Qnext" "Qnext |\<subseteq>| Q"
shows "ps_states \<A> |\<subseteq>| Q"
proof standard
fix q assume ass: "q |\<in>| ps_states \<A>" then show "q |\<in>| Q"
using ps_states_complete_itD[OF assms(1)] fsubsetD[OF assms(2)]
by (induct rule: ps_states_induct[of _ \<A>]) (fastforce intro: ass)+
qed
definition ps_rulesp :: "('a, 'b) ta \<Rightarrow> 'a FSet_Lex_Wrapper fset \<Rightarrow> ('a FSet_Lex_Wrapper, 'b) ta_rule \<Rightarrow> bool" where
"ps_rulesp \<A> Q = (\<lambda> r. \<exists> f ps p. r = TA_rule f ps (Wrapp p) \<and> fset_of_list ps |\<subseteq>| Q \<and>
p = ps_reachable_states \<A> f (map ex ps) \<and> p \<noteq> {||})"
definition "ps_rules" where
"ps_rules \<A> Q \<equiv> fCollect (ps_rulesp \<A> Q)"
lemma finite_ps_rulesp [simp]:
"finite (Collect (ps_rulesp \<A> Q))" (is "finite ?S")
proof -
let ?Q = "fset (Wrapp |`| fPow (\<Q> \<A>) |\<union>| Q)" let ?sig = "fset (ta_sig \<A>)"
define args where "args \<equiv> \<Union> (f,n) \<in> ?sig. {qs| qs. set qs \<subseteq> ?Q \<and> length qs = n}"
define bound where "bound \<equiv> \<Union>(f,_) \<in> ?sig. \<Union>q \<in> ?Q. \<Union>qs \<in> args. {TA_rule f qs q}"
have finite: "finite ?Q" "finite ?sig" by (auto intro: finite_subset)
then have "finite args" using finite_lists_length_eq[OF \<open>finite ?Q\<close>]
by (force simp: args_def)
with finite have "finite bound" unfolding bound_def by (auto simp only: finite_UN)
moreover have "Collect (ps_rulesp \<A> Q) \<subseteq> bound"
proof standard
fix r assume *: "r \<in> Collect (ps_rulesp \<A> Q)"
obtain f ps p where r[simp]: "r = TA_rule f ps p" by (cases r)
from * obtain qs q where "TA_rule f qs q |\<in>| rules \<A>" and len: "length ps = length qs"
unfolding ps_rulesp_def ps_reachable_states_simp
using list_all2_lengthD by fastforce
from this have sym: "(f, length qs) \<in> ?sig"
- by (auto simp flip: fmember.rep_eq)
+ by (auto simp flip: fmember_iff_member_fset)
moreover from * have "set ps \<subseteq> ?Q" unfolding ps_rulesp_def
- by (auto simp flip: fset_of_list_elem fmember.rep_eq simp: ps_reachable_statesp_def)
+ by (auto simp flip: fset_of_list_elem fmember_iff_member_fset simp: ps_reachable_statesp_def)
ultimately have ps: "ps \<in> args"
by (auto simp only: args_def UN_iff intro!: bexI[of _ "(f, length qs)"] len)
from * have "p \<in> ?Q" unfolding ps_rulesp_def ps_reachable_states_def
- using fmember.rep_eq ps_reachable_statesp_\<Q>
+ using fmember_iff_member_fset ps_reachable_statesp_\<Q>
by (fastforce simp add: image_iff)
with ps sym show "r \<in> bound"
by (auto simp only: r bound_def UN_iff intro!: bexI[of _ "(f, length qs)"] bexI[of _ "p"] bexI[of _ "ps"])
qed
ultimately show ?thesis by (blast intro: finite_subset)
qed
lemmas finite_ps_rulesp_unfolded = finite_ps_rulesp[unfolded ps_rulesp_def, simplified]
lemmas ps_rulesI [intro!] = fCollect_memberI[OF finite_ps_rulesp]
lemma ps_rules_states:
"rule_states (fCollect (ps_rulesp \<A> Q)) |\<subseteq>| (Wrapp |`| fPow (\<Q> \<A>) |\<union>| Q)"
by (auto simp: ps_rulesp_def rule_states_def ps_reachable_states_def ps_reachable_statesp_\<Q>) blast
definition ps_ta :: "('q, 'f) ta \<Rightarrow> ('q FSet_Lex_Wrapper, 'f) ta" where
"ps_ta \<A> = (let Q = ps_states \<A> in
TA (ps_rules \<A> Q) {||})"
definition ps_ta_Q\<^sub>f :: "'q fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> 'q FSet_Lex_Wrapper fset" where
"ps_ta_Q\<^sub>f Q \<A> = (let Q' = ps_states \<A> in
ffilter (\<lambda> S. Q |\<inter>| (ex S) \<noteq> {||}) Q')"
lemma ps_rules_sound:
assumes "p |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t)"
shows "ex p |\<subseteq>| ta_der \<A> (term_of_gterm t)" using assms
proof (induction rule: ta_der_gterm_induct)
case (GFun f ts ps p q)
then have IH: "\<forall>i < length ts. ex (ps ! i) |\<subseteq>| gta_der \<A> (ts ! i)" unfolding gta_der_def by auto
show ?case
proof standard
fix r assume "r |\<in>| ex q"
with GFun(1 - 3) obtain qs q' where "TA_rule f qs q' |\<in>| rules \<A>"
"q' = r \<or> (q', r) |\<in>| (eps \<A>)|\<^sup>+|" "list_all2 (|\<in>|) qs (map ex ps)"
by (auto simp: Let_def ps_ta_def ps_rulesp_def ps_reachable_states_simp ps_rules_def)
then show "r |\<in>| ta_der \<A> (term_of_gterm (GFun f ts))"
using GFun(2) IH unfolding gta_der_def
by (force dest!: fsubsetD intro!: exI[of _ q'] exI[of _ qs] simp: list_all2_conv_all_nth)
qed
qed
lemma ps_ta_nt_empty_set:
"TA_rule f qs (Wrapp {||}) |\<in>| rules (ps_ta \<A>) \<Longrightarrow> False"
by (auto simp: ps_ta_def ps_rulesp_def ps_rules_def)
lemma ps_rules_not_empty_reach:
assumes "Wrapp {||} |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t)"
shows False using assms
proof (induction t)
case (GFun f ts)
then show ?case using ps_ta_nt_empty_set[of f _ \<A>]
by (auto simp: ps_ta_def)
qed
lemma ps_rules_complete:
assumes "q |\<in>| ta_der \<A> (term_of_gterm t)"
shows "\<exists>p. q |\<in>| ex p \<and> p |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t) \<and> p |\<in>| ps_states \<A>" using assms
proof (induction rule: ta_der_gterm_induct)
let ?P = "\<lambda>t q p. q |\<in>| ex p \<and> p |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t) \<and> p |\<in>| ps_states \<A>"
case (GFun f ts ps p q)
then have "\<forall>i. \<exists>p. i < length ts \<longrightarrow> ?P (ts ! i) (ps ! i) p" by auto
with choice[OF this] obtain psf where ps: "\<forall>i < length ts. ?P (ts ! i) (ps ! i) (psf i)" by auto
define qs where "qs = map psf [0 ..< length ts]"
let ?p = "ps_reachable_states \<A> f (map ex qs)"
from ps have in_Q: "fset_of_list qs |\<subseteq>| ps_states \<A>"
by (auto simp: qs_def fset_of_list_elem)
from ps GFun(2) have all: "list_all2 (|\<in>|) ps (map ex qs)"
by (auto simp: list_all2_conv_all_nth qs_def)
then have in_p: "q |\<in>| ?p" using GFun(1, 3)
unfolding ps_reachable_statesp_def ps_reachable_states_def by auto
then have rule: "TA_rule f qs (Wrapp ?p) |\<in>| ps_rules \<A> (ps_states \<A>)" using in_Q unfolding ps_rules_def
by (intro ps_rulesI) (auto simp: ps_rulesp_def)
from in_Q in_p have "Wrapp ?p |\<in>| (ps_states \<A>)"
by (auto intro!: ps_states_complete[unfolded ps_states_complete_it_def, rule_format])
with in_p ps rule show ?case
by (auto intro!: exI[of _ "Wrapp ?p"] exI[of _ qs] simp: ps_ta_def qs_def)
qed
lemma ps_ta_eps[simp]: "eps (ps_ta \<A>) = {||}" by (auto simp: Let_def ps_ta_def)
lemma ps_ta_det[iff]: "ta_det (ps_ta \<A>)" by (auto simp: Let_def ps_ta_def ta_det_def ps_rulesp_def ps_rules_def)
lemma ps_gta_lang:
"gta_lang (ps_ta_Q\<^sub>f Q \<A>) (ps_ta \<A>) = gta_lang Q \<A>" (is "?R = ?L")
proof standard
show "?L \<subseteq> ?R" proof standard
fix t assume "t \<in> ?L"
then obtain q where q_res: "q |\<in>| ta_der \<A> (term_of_gterm t)" and q_final: "q |\<in>| Q"
by auto
from ps_rules_complete[OF q_res] obtain p where
"p |\<in>| ps_states \<A>" "q |\<in>| ex p" "p |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t)"
by auto
moreover with q_final have "p |\<in>| ps_ta_Q\<^sub>f Q \<A>"
by (auto simp: ps_ta_Q\<^sub>f_def)
ultimately show "t \<in> ?R" by auto
qed
show "?R \<subseteq> ?L" proof standard
fix t assume "t \<in> ?R"
then obtain p where
p_res: "p |\<in>| ta_der (ps_ta \<A>) (term_of_gterm t)" and p_final: "p |\<in>| ps_ta_Q\<^sub>f Q \<A>"
by (auto simp: ta_lang_def)
from ps_rules_sound[OF p_res] have "ex p |\<subseteq>| ta_der \<A> (term_of_gterm t)"
by auto
moreover from p_final obtain q where "q |\<in>| ex p" "q |\<in>| Q" by (auto simp: ps_ta_Q\<^sub>f_def)
ultimately show "t \<in> ?L" by auto
qed
qed
definition ps_reg where
"ps_reg R = Reg (ps_ta_Q\<^sub>f (fin R) (ta R)) (ps_ta (ta R))"
lemma \<L>_ps_reg:
"\<L> (ps_reg R) = \<L> R"
by (auto simp: \<L>_def ps_gta_lang ps_reg_def)
lemma ps_ta_states: "\<Q> (ps_ta \<A>) |\<subseteq>| Wrapp |`| fPow (\<Q> \<A>)"
using ps_rules_states ps_states unfolding ps_ta_def \<Q>_def
by (auto simp: Let_def ps_rules_def) blast
lemma ps_ta_states': "ex |`| \<Q> (ps_ta \<A>) |\<subseteq>| fPow (\<Q> \<A>)"
using ps_ta_states[of \<A>]
by fastforce
end
diff --git a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Impl.thy b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Impl.thy
--- a/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Impl.thy
+++ b/thys/Regular_Tree_Relations/Tree_Automata/Tree_Automata_Impl.thy
@@ -1,406 +1,406 @@
theory Tree_Automata_Impl
imports Tree_Automata_Abstract_Impl
"HOL-Library.List_Lexorder"
"HOL-Library.AList_Mapping"
Tree_Automata_Class_Instances_Impl
Containers.Containers
begin
definition map_val_of_list :: "('b \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'c list) \<Rightarrow> 'b list \<Rightarrow> ('a, 'c list) mapping" where
"map_val_of_list ek ev xs = foldr (\<lambda>x m. Mapping.update (ek x) (ev x @ case_option Nil id (Mapping.lookup m (ek x))) m) xs Mapping.empty"
abbreviation "map_of_list ek ev xs \<equiv> map_val_of_list ek (\<lambda> x. [ev x]) xs"
lemma map_val_of_list_tabulate_conv:
"map_val_of_list ek ev xs = Mapping.tabulate (sort (remdups (map ek xs))) (\<lambda> k. concat (map ev (filter (\<lambda> x. k = ek x) xs)))"
unfolding map_val_of_list_def
proof (induct xs)
case (Cons x xs) then show ?case
by (intro mapping_eqI) (auto simp: lookup_combine lookup_update' lookup_empty lookup_tabulate image_iff)
qed (simp add: empty_Mapping tabulate_Mapping)
lemmas map_val_of_list_simp = map_val_of_list_tabulate_conv lookup_tabulate
subsection \<open>Setup for the list implementation of reachable states\<close>
definition reach_infer0_cont where
"reach_infer0_cont \<Delta> =
map r_rhs (filter (\<lambda> r. case r of TA_rule f ps p \<Rightarrow> ps = []) (sorted_list_of_fset \<Delta>))"
definition reach_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<Rightarrow> 'q fset \<Rightarrow> 'q list" where
"reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
(let rules = sorted_list_of_fset \<Delta> in
let eps = sorted_list_of_fset \<Delta>\<^sub>\<epsilon> in
let mapp_r = map_val_of_list fst snd (concat (map (\<lambda> r. map (\<lambda> q. (q, [r])) (r_lhs_states r)) rules)) in
let mapp_e = map_of_list fst snd eps in
(\<lambda> p bs.
(map r_rhs (filter (\<lambda> r. case r of TA_rule f qs q \<Rightarrow>
fset_of_list qs |\<subseteq>| finsert p bs) (case_option Nil id (Mapping.lookup mapp_r p)))) @
case_option Nil id (Mapping.lookup mapp_e p)))"
locale reach_rules_fset =
fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin
sublocale reach_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" .
lemma infer1:
"infer1 p (fset bs) = set (reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)"
unfolding reach_infer1 reach_infer1_cont_def set_append Un_assoc[symmetric] Let_def
unfolding sorted_list_of_fset_simps union_fset
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
subgoal
apply (auto simp: fset_of_list_elem less_eq_fset.rep_eq fset_of_list.rep_eq image_iff
- map_val_of_list_simp fmember.rep_eq split!: ta_rule.splits)
+ map_val_of_list_simp fmember_iff_member_fset split!: ta_rule.splits)
apply (metis list.set_intros(1) ta_rule.sel(2, 3))
apply (metis in_set_simps(2) ta_rule.exhaust_sel)
done
subgoal
- apply (simp add: image_def Bex_def fmember.rep_eq map_val_of_list_simp)
+ apply (simp add: image_def Bex_def fmember_iff_member_fset map_val_of_list_simp)
done
done
sublocale l: horn_fset "reach_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "reach_infer0_cont \<Delta>" "reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
apply (unfold_locales)
unfolding reach_infer0 reach_infer0_cont_def
subgoal
- apply (auto simp: image_iff ta_rule.case_eq_if Bex_def fset_of_list_elem fmember.rep_eq)
+ apply (auto simp: image_iff ta_rule.case_eq_if Bex_def fset_of_list_elem fmember_iff_member_fset)
apply force
apply (metis ta_rule.collapse)+
done
subgoal using infer1
apply blast
done
done
lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition "reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> =
horn_fset_impl.saturate_impl (reach_infer0_cont \<Delta>) (reach_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"
lemma reach_fset_impl_sound:
"reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs \<Longrightarrow> fset xs = ta_reach (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
using reach_rules_fset.saturate_impl_sound unfolding reach_cont_impl_def
unfolding reach_horn.reach_sound .
lemma reach_fset_impl_complete:
"reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
have "finite (ta_reach (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
unfolding ta_reach_reachable by simp
then show ?thesis unfolding reach_cont_impl_def
by (intro reach_rules_fset.saturate_impl_complete)
(auto simp: reach_horn.reach_sound)
qed
lemma reach_impl [code]:
"ta_reachable (TA \<Delta> \<Delta>\<^sub>\<epsilon>) = the (reach_cont_impl \<Delta> \<Delta>\<^sub>\<epsilon>)"
using reach_fset_impl_sound[of \<Delta> \<Delta>\<^sub>\<epsilon>]
apply (auto simp add: ta_reach_reachable reach_fset_impl_complete fset_of_list_elem)
apply (metis fset_inject option.exhaust_sel reach_fset_impl_complete)+
done
subsection \<open>Setup for list implementation of productive states\<close>
definition productive_infer1_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'q \<Rightarrow> 'q fset \<Rightarrow> 'q list" where
"productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
(let rules = sorted_list_of_fset \<Delta> in
let eps = sorted_list_of_fset \<Delta>\<^sub>\<epsilon> in
let mapp_r = map_of_list (\<lambda> r. r_rhs r) r_lhs_states rules in
let mapp_e = map_of_list snd fst eps in
(\<lambda> p bs.
(case_option Nil id (Mapping.lookup mapp_e p)) @
concat (case_option Nil id (Mapping.lookup mapp_r p))))"
locale productive_rules_fset =
fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset" and P :: "'q fset"
begin
sublocale productive_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" P .
lemma infer1:
"infer1 p (fset bs) = set (productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)"
unfolding productive_infer1 productive_infer1_cont_def set_append Un_assoc[symmetric]
unfolding union_fset sorted_list_of_fset_simps Let_def set_append
apply (intro arg_cong2[of _ _ _ _ "(\<union>)"])
subgoal
- apply (simp add: image_def Bex_def fmember.rep_eq map_val_of_list_simp)
+ apply (simp add: image_def Bex_def fmember_iff_member_fset map_val_of_list_simp)
done
subgoal
- apply (auto simp flip: fmember.rep_eq simp: map_val_of_list_simp image_iff)
+ apply (auto simp flip: fmember_iff_member_fset simp: map_val_of_list_simp image_iff)
apply (metis ta_rule.sel(2, 3))
apply (metis ta_rule.collapse)
apply (metis notin_fset ta_rule.sel(3))
done
done
sublocale l: horn_fset "productive_rules P (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "sorted_list_of_fset P" "productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
apply (unfold_locales)
using infer1 productive_infer0 fset_of_list.rep_eq
by fastforce+
lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition "productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> =
horn_fset_impl.saturate_impl (sorted_list_of_fset P) (productive_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"
lemma productive_cont_impl_sound:
"productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs \<Longrightarrow> fset xs = ta_productive_ind P (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
using productive_rules_fset.saturate_impl_sound unfolding productive_cont_impl_def
unfolding productive_horn.productive_sound .
lemma productive_cont_impl_complete:
"productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
have "finite (ta_productive_ind P (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
unfolding ta_productive_ind by simp
then show ?thesis unfolding productive_cont_impl_def
by (intro productive_rules_fset.saturate_impl_complete)
(auto simp: productive_horn.productive_sound)
qed
lemma productive_impl [code]:
"ta_productive P (TA \<Delta> \<Delta>\<^sub>\<epsilon>) = the (productive_cont_impl P \<Delta> \<Delta>\<^sub>\<epsilon>)"
using productive_cont_impl_complete[of P \<Delta>] productive_cont_impl_sound[of P \<Delta>]
- by (auto simp add: ta_productive_ind fset_of_list_elem fmember.rep_eq)
+ by (auto simp add: ta_productive_ind fset_of_list_elem fmember_iff_member_fset)
subsection \<open>Setup for the implementation of power set construction states\<close>
abbreviation "r_statesl r \<equiv> length (r_lhs_states r)"
definition ps_reachable_states_list where
"ps_reachable_states_list mapp_r mapp_e f ps =
(let R = filter (\<lambda> r. list_all2 (|\<in>|) (r_lhs_states r) ps)
(case_option Nil id (Mapping.lookup mapp_r (f, length ps))) in
let S = map r_rhs R in
S @ concat (map (case_option Nil id \<circ> Mapping.lookup mapp_e) S))"
lemma ps_reachable_states_list_sound:
assumes "length ps = n"
and mapp_r: "case_option Nil id (Mapping.lookup mapp_r (f, n)) =
filter (\<lambda>r. r_root r = f \<and> r_statesl r = n) (sorted_list_of_fset \<Delta>)"
and mapp_e: "\<And>p. case_option Nil id (Mapping.lookup mapp_e p) =
map snd (filter (\<lambda> q. fst q = p) (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|)))"
shows "fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex ps)) =
ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex ps)" (is "?Ls = ?Rs")
proof -
have *: "length ps = n" "length (map ex ps) = n" using assms by auto
{fix q assume "q |\<in>| ?Ls"
then obtain qs p where "TA_rule f qs p |\<in>| \<Delta>" "length ps = length qs"
"list_all2 (|\<in>|) qs (map ex ps)" "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<epsilon>|\<^sup>+|"
unfolding ps_reachable_states_list_def Let_def comp_def assms(1, 2, 3) *
- by (force simp add: fset_of_list_elem image_iff fBex_def simp flip: fmember.rep_eq)
+ by (force simp add: fset_of_list_elem image_iff fBex_def simp flip: fmember_iff_member_fset)
then have "q |\<in>| ?Rs"
by (force simp add: ps_reachable_states_fmember image_iff)}
moreover
{fix q assume "q |\<in>| ?Rs"
then obtain qs p where "TA_rule f qs p |\<in>| \<Delta>" "length ps = length qs"
"list_all2 (|\<in>|) qs (map ex ps)" "p = q \<or> (p, q) |\<in>| \<Delta>\<^sub>\<epsilon>|\<^sup>+|"
by (auto simp add: ps_reachable_states_fmember list_all2_iff)
then have "q |\<in>| ?Ls"
unfolding ps_reachable_states_list_def Let_def * comp_def assms(2, 3)
- by (force simp add: fset_of_list_elem image_iff simp flip: fmember.rep_eq)}
+ by (force simp add: fset_of_list_elem image_iff simp flip: fmember_iff_member_fset)}
ultimately show ?thesis by blast
qed
lemma rule_target_statesI:
"\<exists> r |\<in>| \<Delta>. r_rhs r = q \<Longrightarrow> q |\<in>| rule_target_states \<Delta>"
by auto
definition ps_states_infer0_cont :: "('q :: linorder, 'f :: linorder) ta_rule fset \<Rightarrow>
('q \<times> 'q) fset \<Rightarrow> 'q FSet_Lex_Wrapper list" where
"ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
(let sig = filter (\<lambda> r. r_lhs_states r = []) (sorted_list_of_fset \<Delta>) in
filter (\<lambda> p. ex p \<noteq> {||}) (map (\<lambda> r. Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) (r_root r) [])) sig))"
definition ps_states_infer1_cont :: "('q :: linorder , 'f :: linorder) ta_rule fset \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow>
'q FSet_Lex_Wrapper \<Rightarrow> 'q FSet_Lex_Wrapper fset \<Rightarrow> 'q FSet_Lex_Wrapper list" where
"ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> =
(let sig = remdups (map (\<lambda> r. (r_root r, r_statesl r)) (filter (\<lambda> r. r_lhs_states r \<noteq> []) (sorted_list_of_fset \<Delta>))) in
let arities = remdups (map snd sig) in
let etr = sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|) in
let mapp_r = map_of_list (\<lambda> r. (r_root r, r_statesl r)) id (sorted_list_of_fset \<Delta>) in
let mapp_e = map_of_list fst snd etr in
(\<lambda> p bs.
(let states = sorted_list_of_fset (finsert p bs) in
let arity_to_states_map = Mapping.tabulate arities (\<lambda> n. list_of_permutation_element_n p n states) in
let res = map (\<lambda> (f, n).
map (\<lambda> s. let rules = the (Mapping.lookup mapp_r (f, n)) in
Wrapp (fset_of_list (ps_reachable_states_list mapp_r mapp_e f (map ex s))))
(the (Mapping.lookup arity_to_states_map n)))
sig in
filter (\<lambda> p. ex p \<noteq> {||}) (concat res))))"
locale ps_states_fset =
fixes \<Delta> :: "('q :: linorder, 'f :: linorder) ta_rule fset" and \<Delta>\<^sub>\<epsilon> :: "('q \<times> 'q) fset"
begin
sublocale ps_states_horn "TA \<Delta> \<Delta>\<^sub>\<epsilon>" .
lemma infer0: "infer0 = set (ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"
unfolding ps_states_horn.ps_construction_infer0
unfolding ps_states_infer0_cont_def Let_def
using ps_reachable_states_fmember
by (auto simp add: image_def Ball_def Bex_def)
- (metis fmember.rep_eq list_all2_Nil2 ps_reachable_states_fmember ta.sel(1) ta_rule.sel(1, 2))
+ (metis fmember_iff_member_fset list_all2_Nil2 ps_reachable_states_fmember ta.sel(1) ta_rule.sel(1, 2))
lemma r_lhs_states_nConst:
"r_lhs_states r \<noteq> [] \<Longrightarrow> r_statesl r \<noteq> 0" for r by auto
lemma filter_empty_conv':
"[] = filter P xs \<longleftrightarrow> (\<forall>x\<in>set xs. \<not> P x)"
by (metis filter_empty_conv)
lemma infer1:
"infer1 p (fset bs) = set (ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon> p bs)" (is "?Ls = ?Rs")
proof -
let ?mapp_r = "map_of_list (\<lambda>r. (r_root r, r_statesl r)) (\<lambda>x. x) (sorted_list_of_fset \<Delta>)"
let ?mapp_e = "map_of_list fst snd (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|))"
have mapr: "case_option Nil id (Mapping.lookup ?mapp_r (f, n)) =
filter (\<lambda>r. r_root r = f \<and> r_statesl r = n) (sorted_list_of_fset \<Delta>)" for f n
by (auto simp: map_val_of_list_simp image_iff filter_empty_conv' intro: filter_cong)
have epsr: "\<And>p. case_option Nil id (Mapping.lookup ?mapp_e p) =
map snd (filter (\<lambda> q. fst q = p) (sorted_list_of_fset (\<Delta>\<^sub>\<epsilon>|\<^sup>+|)))"
by (auto simp: map_val_of_list_simp image_iff filter_empty_conv) metis
have *: "p \<in> set qs \<Longrightarrow> x |\<in>| ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qs) \<Longrightarrow>
(\<exists> ps q. TA_rule f ps q |\<in>| \<Delta> \<and> length ps = length qs)" for x f qs
by (auto simp: ps_reachable_states_fmember list_all2_conv_all_nth)
{fix q assume "q \<in> ?Ls"
then obtain f qss where sp: "q = Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qss))"
"ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) f (map ex qss) \<noteq> {||}" "p \<in> set qss" "set qss \<subseteq> insert p (fset bs)"
by (auto simp add: ps_construction_infer1 ps_reachable_states_fmember)
from sp(2, 3) obtain ps p' where r: "TA_rule f ps p' |\<in>| \<Delta>" "length ps = length qss" using *
by blast
then have mem: "qss \<in> set (list_of_permutation_element_n p (length ps) (sorted_list_of_fset (finsert p bs)))" using sp(2-)
by (auto simp: list_of_permutation_element_n_iff)
(meson in_set_idx insertE set_list_subset_eq_nth_conv)
then have "q \<in> ?Rs" using sp r
unfolding ps_construction_infer1 ps_states_infer1_cont_def Let_def
- apply (simp add: lookup_tabulate ps_reachable_states_fmember image_iff flip: fmember.rep_eq)
+ apply (simp add: lookup_tabulate ps_reachable_states_fmember image_iff flip: fmember_iff_member_fset)
apply (rule_tac x = "f ps \<rightarrow> p'" in exI)
apply (auto simp: Bex_def ps_reachable_states_list_sound[OF _ mapr epsr] intro: exI[of _ qss])
done}
moreover
{fix q assume ass: "q \<in> ?Rs"
then obtain r qss where "r |\<in>| \<Delta>" "r_lhs_states r \<noteq> []" "qss \<in> set (list_of_permutation_element_n p (r_statesl r) (sorted_list_of_fset (finsert p bs)))"
"q = Wrapp (ps_reachable_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>) (r_root r) (map ex qss))"
unfolding ps_states_infer1_cont_def Let_def
by (auto simp add: lookup_tabulate ps_reachable_states_fmember image_iff
- ps_reachable_states_list_sound[OF _ mapr epsr] split: if_splits simp flip: fmember.rep_eq)
+ ps_reachable_states_list_sound[OF _ mapr epsr] split: if_splits simp flip: fmember_iff_member_fset)
moreover have "q \<noteq> Wrapp {||}" using ass
by (auto simp: ps_states_infer1_cont_def Let_def)
ultimately have "q \<in> ?Ls" unfolding ps_construction_infer1
apply (auto simp: list_of_permutation_element_n_iff intro!: exI[of _ "r_root r"] exI[of _ qss])
apply (metis in_set_idx)
done}
ultimately show ?thesis by blast
qed
sublocale l: horn_fset "ps_states_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>)" "ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>" "ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>"
apply (unfold_locales)
using infer0 infer1
by fastforce+
lemmas infer = l.infer0 l.infer1
lemmas saturate_impl_sound = l.saturate_impl_sound
lemmas saturate_impl_complete = l.saturate_impl_complete
end
definition "ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> =
horn_fset_impl.saturate_impl (ps_states_infer0_cont \<Delta> \<Delta>\<^sub>\<epsilon>) (ps_states_infer1_cont \<Delta> \<Delta>\<^sub>\<epsilon>)"
lemma ps_states_fset_impl_sound:
assumes "ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> = Some xs"
shows "xs = ps_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
using ps_states_fset.saturate_impl_sound[OF assms[unfolded ps_states_fset_impl_def]]
using ps_states_horn.ps_states_sound[of "TA \<Delta> \<Delta>\<^sub>\<epsilon>"]
- by (auto simp: fset_of_list_elem fmember.rep_eq ps_states.rep_eq fset_of_list.rep_eq)
+ by (auto simp: fset_of_list_elem fmember_iff_member_fset ps_states.rep_eq fset_of_list.rep_eq)
lemma ps_states_fset_impl_complete:
"ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon> \<noteq> None"
proof -
let ?R = "ps_states (TA \<Delta> \<Delta>\<^sub>\<epsilon>)"
let ?S = "horn.saturate (ps_states_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>))"
have "?S \<subseteq> fset ?R"
using ps_states_horn.ps_states_sound
by (simp add: ps_states_horn.ps_states_sound ps_states.rep_eq)
from finite_subset[OF this] show ?thesis
unfolding ps_states_fset_impl_def
by (intro ps_states_fset.saturate_impl_complete) simp
qed
lemma ps_ta_impl [code]:
"ps_ta (TA \<Delta> \<Delta>\<^sub>\<epsilon>) =
(let xs = the (ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon>) in
TA (ps_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>) xs) {||})"
using ps_states_fset_impl_complete
using ps_states_fset_impl_sound
unfolding ps_ta_def Let_def
by (metis option.exhaust_sel)
lemma ps_reg_impl [code]:
"ps_reg (Reg Q (TA \<Delta> \<Delta>\<^sub>\<epsilon>)) =
(let xs = the (ps_states_fset_impl \<Delta> \<Delta>\<^sub>\<epsilon>) in
Reg (ffilter (\<lambda> S. Q |\<inter>| ex S \<noteq> {||}) xs)
(TA (ps_rules (TA \<Delta> \<Delta>\<^sub>\<epsilon>) xs) {||}))"
using ps_states_fset_impl_complete[of \<Delta> \<Delta>\<^sub>\<epsilon>]
using ps_states_fset_impl_sound[of \<Delta> \<Delta>\<^sub>\<epsilon>]
unfolding ps_reg_def ps_ta_Q\<^sub>f_def Let_def
unfolding ps_ta_def Let_def
using eq_ffilter by auto
lemma prod_ta_zip [code]:
"prod_ta_rules (\<A> :: ('q1 :: linorder, 'f :: linorder) ta) (\<B> :: ('q2 :: linorder, 'f :: linorder) ta) =
(let sig = sorted_list_of_fset (ta_sig \<A> |\<inter>| ta_sig \<B>) in
let mapA = map_of_list (\<lambda>r. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules \<A>)) in
let mapB = map_of_list (\<lambda>r. (r_root r, r_statesl r)) id (sorted_list_of_fset (rules \<B>)) in
let merge = (\<lambda> (ra, rb). TA_rule (r_root ra) (zip (r_lhs_states ra) (r_lhs_states rb)) (r_rhs ra, r_rhs rb)) in
fset_of_list (
concat (map (\<lambda> (f, n). map merge
(List.product (the (Mapping.lookup mapA (f, n))) (the (Mapping.lookup mapB (f, n))))) sig)))"
(is "?Ls = ?Rs")
proof -
have [simp]: "distinct (sorted_list_of_fset (ta_sig \<A>))" "distinct (sorted_list_of_fset (ta_sig \<B>))"
by (simp_all add: distinct_sorted_list_of_fset)
have *: "sort (remdups (map (\<lambda>r. (r_root r, r_statesl r)) (sorted_list_of_fset (rules \<A>)))) = sorted_list_of_fset (ta_sig \<A>)"
"sort (remdups (map (\<lambda>r. (r_root r, r_statesl r)) (sorted_list_of_fset (rules \<B>)))) = sorted_list_of_fset (ta_sig \<B>)"
by (auto simp: ta_sig_def sorted_list_of_fset_fimage_dist)
{fix r assume ass: "r |\<in>| ?Ls"
then obtain f qs q where [simp]: "r = f qs \<rightarrow> q" by auto
then have "(f, length qs) |\<in>| ta_sig \<A> |\<inter>| ta_sig \<B>" using ass by auto
then have "r |\<in>| ?Rs" using ass unfolding map_val_of_list_tabulate_conv *
- by (auto simp: Let_def fset_of_list_elem image_iff case_prod_beta lookup_tabulate simp flip: fmember.rep_eq intro!: bexI[of _ "(f, length qs)"])
+ by (auto simp: Let_def fset_of_list_elem image_iff case_prod_beta lookup_tabulate simp flip: fmember_iff_member_fset intro!: bexI[of _ "(f, length qs)"])
(metis (no_types, lifting) length_map ta_rule.sel(1 - 3) zip_map_fst_snd)}
moreover
{fix r assume ass: "r |\<in>| ?Rs" then have "r |\<in>| ?Ls" unfolding map_val_of_list_tabulate_conv *
- by (auto simp: fset_of_list_elem finite_Collect_prod_ta_rules lookup_tabulate simp flip: fmember.rep_eq)
+ by (auto simp: fset_of_list_elem finite_Collect_prod_ta_rules lookup_tabulate simp flip: fmember_iff_member_fset)
(metis ta_rule.collapse)}
ultimately show ?thesis by blast
qed
(*
export_code ta_der in Haskell
export_code ta_reachable in Haskell
export_code ta_productive in Haskell
export_code trim_ta in Haskell
export_code ta_restrict in Haskell
export_code ps_reachable_states in Haskell
export_code prod_ta_rules in Haskell
export_code ps_ta in Haskell
export_code ps_reg in Haskell
export_code reg_intersect in Haskell
*)
end
\ No newline at end of file
diff --git a/thys/Ribbon_Proofs/Ribbons_Graphical_Soundness.thy b/thys/Ribbon_Proofs/Ribbons_Graphical_Soundness.thy
--- a/thys/Ribbon_Proofs/Ribbons_Graphical_Soundness.thy
+++ b/thys/Ribbon_Proofs/Ribbons_Graphical_Soundness.thy
@@ -1,1127 +1,1127 @@
section \<open>Soundness for graphical diagrams\<close>
theory Ribbons_Graphical_Soundness imports
Ribbons_Graphical
More_Finite_Map
begin
text \<open>We prove that the proof rules for graphical ribbon proofs are sound
with respect to the rules of separation logic.
We impose an additional assumption to achieve soundness: that the
Frame rule has no side-condition. This assumption is reasonable because there
are several separation logics that lack such a side-condition, such as
``variables-as-resource''.
We first describe how to extract proofchains from a diagram. This process is
similar to the process of extracting commands from a diagram, which was
described in @{theory Ribbon_Proofs.Ribbons_Graphical}. When we extract a proofchain, we
don't just include the commands, but the assertions in between them. Our
main lemma for proving soundness says that each of these proofchains
corresponds to a valid separation logic proof.
\<close>
subsection \<open>Proofstate chains\<close>
text \<open>When extracting a proofchain from a diagram, we need to keep track
of which nodes we have processed and which ones we haven't. A
proofstate, defined below, maps a node to ``Top'' if it hasn't been
processed and ``Bot'' if it has.\<close>
datatype topbot = Top | Bot
type_synonym proofstate = "node \<rightharpoonup>\<^sub>f topbot"
text \<open>A proofstate chain contains all the nodes and edges of a graphical
diagram, interspersed with proofstates that track which nodes have been
processed at each point.\<close>
type_synonym ps_chain = "(proofstate, node + edge) chain"
text \<open>The @{term "next_ps \<sigma>"} function processes one node or one edge in a
diagram, given the current proofstate @{term \<sigma>}. It processes a node
@{term v} by replacing the mapping from @{term v} to @{term Top} with a
mapping from @{term v} to @{term Bot}. It processes an edge @{term e}
(whose source and target nodes are @{term vs} and @{term ws} respectively)
by removing all the mappings from @{term vs} to @{term Bot}, and adding
mappings from @{term ws} to @{term Top}.\<close>
fun next_ps :: "proofstate \<Rightarrow> node + edge \<Rightarrow> proofstate"
where
"next_ps \<sigma> (Inl v) = \<sigma> \<ominus> {|v|} ++\<^sub>f [{|v|} |=> Bot]"
| "next_ps \<sigma> (Inr e) = \<sigma> \<ominus> fst3 e ++\<^sub>f [thd3 e |=> Top]"
text \<open>The function @{term "mk_ps_chain \<Pi> \<pi>"} generates from @{term \<pi>}, which
is a list of nodes and edges, a proofstate chain, by interspersing the
elements of @{term \<pi>} with the appropriate proofstates. The first argument
@{term \<Pi>} is the part of the chain that has already been converted.\<close>
definition
mk_ps_chain :: "[ps_chain, (node + edge) list] \<Rightarrow> ps_chain"
where
"mk_ps_chain \<equiv> foldl (\<lambda>\<Pi> x. cSnoc \<Pi> x (next_ps (post \<Pi>) x))"
lemma mk_ps_chain_preserves_length:
fixes \<pi> \<Pi>
shows "chainlen (mk_ps_chain \<Pi> \<pi>) = chainlen \<Pi> + length \<pi>"
proof (induct \<pi> arbitrary: \<Pi>)
case Nil
show ?case by (unfold mk_ps_chain_def, auto)
next
case (Cons x \<pi>)
show ?case
apply (unfold mk_ps_chain_def list.size foldl.simps)
apply (fold mk_ps_chain_def)
apply (auto simp add: Cons len_snoc)
done
qed
text \<open>Distributing @{term mk_ps_chain} over @{term Cons}.\<close>
lemma mk_ps_chain_cons:
"mk_ps_chain \<Pi> (x # \<pi>) = mk_ps_chain (cSnoc \<Pi> x (next_ps (post \<Pi>) x)) \<pi>"
by (auto simp add: mk_ps_chain_def)
text \<open>Distributing @{term mk_ps_chain} over @{term snoc}.\<close>
lemma mk_ps_chain_snoc:
"mk_ps_chain \<Pi> (\<pi> @ [x])
= cSnoc (mk_ps_chain \<Pi> \<pi>) x (next_ps (post (mk_ps_chain \<Pi> \<pi>)) x)"
by (unfold mk_ps_chain_def, auto)
text \<open>Distributing @{term mk_ps_chain} over @{term cCons}.\<close>
lemma mk_ps_chain_ccons:
fixes \<pi> \<Pi>
shows "mk_ps_chain (\<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> \<Pi>) \<pi> = \<lbrace> \<sigma> \<rbrace> \<cdot> x \<cdot> mk_ps_chain \<Pi> \<pi> "
by (induct \<pi> arbitrary: \<Pi>, auto simp add: mk_ps_chain_cons mk_ps_chain_def)
lemma pre_mk_ps_chain:
fixes \<Pi> \<pi>
shows "pre (mk_ps_chain \<Pi> \<pi>) = pre \<Pi>"
apply (induct \<pi> arbitrary: \<Pi>)
apply (auto simp add: mk_ps_chain_def mk_ps_chain_cons pre_snoc)
done
text \<open>A chain which is obtained from the list @{term \<pi>}, has @{term \<pi>}
as its list of commands. The following lemma states this in a slightly
more general form, that allows for part of the chain to have already
been processed.\<close>
lemma comlist_mk_ps_chain:
"comlist (mk_ps_chain \<Pi> \<pi>) = comlist \<Pi> @ \<pi>"
proof (induct \<pi> arbitrary: \<Pi>)
case Nil
thus ?case by (auto simp add: mk_ps_chain_def)
next
case (Cons x \<pi>')
show ?case
apply (unfold mk_ps_chain_def foldl.simps, fold mk_ps_chain_def)
apply (auto simp add: Cons comlist_snoc)
done
qed
text \<open>In order to perform induction over our diagrams, we shall wish
to obtain ``smaller'' diagrams, by removing nodes or edges. However, the
syntax and well-formedness constraints for diagrams are such that although
we can always remove an edge from a diagram, we cannot (in general) remove
a node -- the resultant diagram would not be a well-formed if an edge
connected to that node.
Hence, we consider ``partially-processed diagrams'' @{term "(G,S)"}, which
comprise a diagram @{term G} and a set @{term S} of nodes. @{term S} denotes
the subset of @{term G}'s initial nodes that have already been processed,
and can be thought of as having been removed from @{term G}.
We now give an updated version of the @{term "lins G"} function. This was
originally defined in @{theory Ribbon_Proofs.Ribbons_Graphical}. We provide an extra
parameter, @{term S}, which denotes the subset of @{term G}'s initial nodes
that shouldn't be included in the linear extensions.\<close>
definition lins2 :: "[node fset, diagram] \<Rightarrow> lin set"
where
"lins2 S G \<equiv> {\<pi> :: lin .
(distinct \<pi>)
\<and> (set \<pi> = (fset G^V - fset S) <+> set G^E)
\<and> (\<forall>i j v e. i < length \<pi> \<and> j < length \<pi>
\<and> \<pi>!i = Inl v \<and> \<pi>!j = Inr e \<and> v |\<in>| fst3 e \<longrightarrow> i<j)
\<and> (\<forall>j k w e. j < length \<pi> \<and> k < length \<pi>
\<and> \<pi>!j = Inr e \<and> \<pi>!k = Inl w \<and> w |\<in>| thd3 e \<longrightarrow> j<k) }"
lemma lins2D:
assumes "\<pi> \<in> lins2 S G"
shows "distinct \<pi>"
and "set \<pi> = (fset G^V - fset S) <+> set G^E"
and "\<And>i j v e. \<lbrakk> i < length \<pi> ; j < length \<pi> ;
\<pi>!i = Inl v ; \<pi>!j = Inr e ; v |\<in>| fst3 e \<rbrakk> \<Longrightarrow> i<j"
and "\<And>i k w e. \<lbrakk> j < length \<pi> ; k < length \<pi> ;
\<pi>!j = Inr e ; \<pi>!k = Inl w ; w |\<in>| thd3 e \<rbrakk> \<Longrightarrow> j<k"
using assms
apply (unfold lins2_def Collect_iff)
apply (elim conjE, assumption)+
apply blast+
done
lemma lins2I:
assumes "distinct \<pi>"
and "set \<pi> = (fset G^V - fset S) <+> set G^E"
and "\<And>i j v e. \<lbrakk> i < length \<pi> ; j < length \<pi> ;
\<pi>!i = Inl v ; \<pi>!j = Inr e ; v |\<in>| fst3 e \<rbrakk> \<Longrightarrow> i<j"
and "\<And>j k w e. \<lbrakk> j < length \<pi> ; k < length \<pi> ;
\<pi>!j = Inr e ; \<pi>!k = Inl w ; w |\<in>| thd3 e \<rbrakk> \<Longrightarrow> j<k"
shows "\<pi> \<in> lins2 S G"
using assms
apply (unfold lins2_def Collect_iff, intro conjI)
apply assumption+
apply blast+
done
text \<open>When @{term S} is empty, the two definitions coincide.\<close>
lemma lins_is_lins2_with_empty_S:
"lins G = lins2 {||} G"
by (unfold lins_def lins2_def, auto)
text \<open>The first proofstate for a diagram @{term G} is obtained by
mapping each of its initial nodes to @{term Top}.\<close>
definition
initial_ps :: "diagram \<Rightarrow> proofstate"
where
"initial_ps G \<equiv> [ initials G |=> Top ]"
text \<open>The first proofstate for the partially-processed diagram @{term G} is
obtained by mapping each of its initial nodes to @{term Top}, except those
in @{term S}, which are mapped to @{term Bot}.\<close>
definition
initial_ps2 :: "[node fset, diagram] \<Rightarrow> proofstate"
where
"initial_ps2 S G \<equiv> [ initials G - S |=> Top ] ++\<^sub>f [ S |=> Bot ]"
text \<open>When @{term S} is empty, the above two definitions coincide.\<close>
lemma initial_ps_is_initial_ps2_with_empty_S:
"initial_ps = initial_ps2 {||}"
apply (unfold fun_eq_iff, intro allI)
apply (unfold initial_ps_def initial_ps2_def)
apply simp
done
text \<open>The following function extracts the set of proofstate chains from
a diagram.\<close>
definition
ps_chains :: "diagram \<Rightarrow> ps_chain set"
where
"ps_chains G \<equiv> mk_ps_chain (cNil (initial_ps G)) ` lins G"
text \<open>The following function extracts the set of proofstate chains from
a partially-processed diagram. Nodes in @{term S} are excluded from
the resulting chains.\<close>
definition
ps_chains2 :: "[node fset, diagram] \<Rightarrow> ps_chain set"
where
"ps_chains2 S G \<equiv> mk_ps_chain (cNil (initial_ps2 S G)) ` lins2 S G"
text \<open>When @{term S} is empty, the above two definitions coincide.\<close>
lemma ps_chains_is_ps_chains2_with_empty_S:
"ps_chains = ps_chains2 {||}"
apply (unfold fun_eq_iff, intro allI)
apply (unfold ps_chains_def ps_chains2_def)
apply (fold initial_ps_is_initial_ps2_with_empty_S)
apply (fold lins_is_lins2_with_empty_S)
apply auto
done
text \<open>We now wish to describe proofstates chain that are well-formed. First,
let us say that @{term "f ++\<^sub>fdisjoint g"} is defined, when @{term f} and
@{term g} have disjoint domains, as @{term "f ++\<^sub>f g"}. Then, a well-formed
proofstate chain consists of triples of the form @{term "(\<sigma> ++\<^sub>fdisjoint
[{| v |} |=> Top], Inl v, \<sigma> ++\<^sub>fdisjoint [{| v |} |=> Bot])"}, where @{term v}
is a node, or of the form @{term "(\<sigma> ++\<^sub>fdisjoint [{| vs |} |=> Bot], Inr e,
\<sigma> ++\<^sub>fdisjoint [{| ws |} |=> Top])"}, where @{term e} is an edge with source
and target nodes @{term vs} and @{term ws} respectively.
The definition below describes a well-formed triple; we then lift this
to complete chains shortly.\<close>
definition
wf_ps_triple :: "proofstate \<times> (node + edge) \<times> proofstate \<Rightarrow> bool"
where
"wf_ps_triple T = (case snd3 T of
Inl v \<Rightarrow> (\<exists>\<sigma>. v |\<notin>| fmdom \<sigma>
\<and> fst3 T = [ {|v|} |=> Top ] ++\<^sub>f \<sigma>
\<and> thd3 T = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>)
| Inr e \<Rightarrow> (\<exists>\<sigma>. (fst3 e |\<union>| thd3 e) |\<inter>| fmdom \<sigma> = {||}
\<and> fst3 T = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>
\<and> thd3 T = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>))"
lemma wf_ps_triple_nodeI:
assumes "\<exists>\<sigma>. v |\<notin>| fmdom \<sigma> \<and>
\<sigma>1 = [ {|v|} |=> Top ] ++\<^sub>f \<sigma> \<and>
\<sigma>2 = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>"
shows "wf_ps_triple (\<sigma>1, Inl v, \<sigma>2)"
using assms unfolding wf_ps_triple_def
by (auto simp add: fst3_simp snd3_simp thd3_simp)
lemma wf_ps_triple_edgeI:
assumes "\<exists>\<sigma>. (fst3 e |\<union>| thd3 e) |\<inter>| fmdom \<sigma> = {||}
\<and> \<sigma>1 = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>
\<and> \<sigma>2 = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>"
shows "wf_ps_triple (\<sigma>1, Inr e, \<sigma>2)"
using assms unfolding wf_ps_triple_def
by (auto simp add: fst3_simp snd3_simp thd3_simp)
definition
wf_ps_chain :: "ps_chain \<Rightarrow> bool"
where
"wf_ps_chain \<equiv> chain_all wf_ps_triple"
lemma next_initial_ps2_vertex:
"initial_ps2 ({|v|} |\<union>| S) G
= initial_ps2 S G \<ominus> {|v|} ++\<^sub>f [ {|v|} |=> Bot ]"
apply (unfold initial_ps2_def)
apply transfer
apply (auto simp add: make_map_def map_diff_def map_add_def restrict_map_def)
done
lemma next_initial_ps2_edge:
assumes "G = Graph V \<Lambda> E" and "G' = Graph V' \<Lambda> E'" and
"V' = V - fst3 e" and "E' = removeAll e E" and "e \<in> set E" and
"fst3 e |\<subseteq>| S" and "S |\<subseteq>| initials G" and "wf_dia G"
shows "initial_ps2 (S - fst3 e) G' =
initial_ps2 S G \<ominus> fst3 e ++\<^sub>f [ thd3 e |=> Top ]"
proof (insert assms, unfold initial_ps2_def, transfer)
fix G V \<Lambda> E G' V' E' e S
assume G_def: "G = Graph V \<Lambda> E" and G'_def: "G' = Graph V' \<Lambda> E'" and
V'_def: "V' = V - fst3 e" and E'_def: "E' = removeAll e E" and
e_in_E: "e \<in> set E" and fst_e_in_S: "fst3 e |\<subseteq>| S" and
S_initials: "S |\<subseteq>| initials G" and wf_G: "wf_dia G"
have "thd3 e |\<inter>| initials G = {||}"
by (auto simp add: initials_def G_def e_in_E)
show "make_map (initials G' - (S - fst3 e)) Top ++ make_map (S - fst3 e) Bot
= map_diff (make_map (initials G - S) Top ++ make_map S Bot) (fst3 e)
++ make_map (thd3 e) Top"
apply (unfold make_map_def map_diff_def)
apply (unfold map_add_def restrict_map_def)
apply (unfold minus_fset)
apply (unfold fun_eq_iff initials_def)
apply (unfold G_def G'_def V'_def E'_def)
apply (unfold edges.simps vertices.simps)
- apply (simp add: less_eq_fset.rep_eq fmember.rep_eq e_in_E)
+ apply (simp add: less_eq_fset.rep_eq fmember_iff_member_fset e_in_E)
apply safe
apply (insert \<open>thd3 e |\<inter>| initials G = {||}\<close>)[1]
apply (insert S_initials, fold fset_cong)[2]
apply (unfold less_eq_fset.rep_eq initials_def filter_fset)
- apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
- apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
- apply (auto simp add: fmember.rep_eq G_def e_in_E)[1]
+ apply (auto simp add: fmember_iff_member_fset G_def e_in_E)[1]
+ apply (auto simp add: fmember_iff_member_fset G_def e_in_E)[1]
+ apply (auto simp add: fmember_iff_member_fset G_def e_in_E)[1]
apply (insert wf_G)[1]
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(3))
apply (unfold acyclicity_def)
apply (metis fst_e_in_S inter_fset le_iff_inf subsetD)
apply (insert wf_G)[1]
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(4))
apply (drule linearityD2)
apply (fold fset_cong, unfold inter_fset fset_simps)
apply (insert e_in_E, blast)[1]
apply (insert wf_G)[1]
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(3))
apply (metis (lifting) e_in_E G_def empty_iff fset_simps(1)
finter_iff linearityD(2) notin_fset wf_G wf_dia_inv(4))
apply (insert wf_G)[1]
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(4))
apply (drule linearityD2)
apply (fold fset_cong, unfold inter_fset fset_simps)
apply (insert e_in_E, blast)[1]
apply (insert wf_G)[1]
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(3))
apply (metis (lifting) e_in_E G_def empty_iff fset_simps(1)
finter_iff linearityD(2) notin_fset wf_G wf_dia_inv(4))
apply (insert wf_G)
apply (unfold G_def vertices.simps edges.simps)
apply (drule wf_dia_inv(5))
apply (unfold less_eq_fset.rep_eq union_fset)
apply auto[1]
apply (drule wf_dia_inv(5))
apply (unfold less_eq_fset.rep_eq union_fset)
apply auto[1]
apply (drule wf_dia_inv(5))
apply (unfold less_eq_fset.rep_eq union_fset)
apply (auto simp add: e_in_E)[1]
apply (drule wf_dia_inv(5))
apply (unfold less_eq_fset.rep_eq union_fset)
apply (auto simp add: e_in_E)[1]
done
qed
lemma next_lins2_vertex:
assumes "Inl v # \<pi> \<in> lins2 S G"
assumes "v |\<notin>| S"
shows "\<pi> \<in> lins2 ({|v|} |\<union>| S) G"
proof -
note lins2D = lins2D[OF assms(1)]
show ?thesis
proof (intro lins2I)
show "distinct \<pi>" using lins2D(1) by auto
next
have "set \<pi> = set (Inl v # \<pi>) - {Inl v}" using lins2D(1) by auto
also have "... = (fset G^V - fset ({|v|} |\<union>| S)) <+> set G^E"
using lins2D(2) by auto
finally show "set \<pi> = (fset G^V - fset ({|v|} |\<union>| S)) <+> set G^E"
by auto
next
fix i j v e
assume "i < length \<pi>" "j < length \<pi>" "\<pi> ! i = Inl v"
"\<pi> ! j = Inr e" "v |\<in>| fst3 e"
thus "i < j" using lins2D(3)[of "i+1" "j+1"] by auto
next
fix j k w e
assume "j < length \<pi>" "k < length \<pi>" "\<pi> ! j = Inr e"
"\<pi> ! k = Inl w" "w |\<in>| thd3 e"
thus "j < k" using lins2D(4)[of "j+1" "k+1"] by auto
qed
qed
lemma next_lins2_edge:
assumes "Inr e # \<pi> \<in> lins2 S (Graph V \<Lambda> E)"
and "vs |\<subseteq>| S"
and "e = (vs,c,ws)"
shows "\<pi> \<in> lins2 (S - vs) (Graph (V - vs) \<Lambda> (removeAll e E))"
proof -
note lins2D = lins2D[OF assms(1)]
show ?thesis
proof (intro lins2I, unfold vertices.simps edges.simps)
show "distinct \<pi>"
using lins2D(1) by auto
next
show "set \<pi> = (fset (V - vs) - fset (S - vs))
<+> set (removeAll e E)"
apply (insert lins2D(1) lins2D(2) assms(2))
apply (unfold assms(3) vertices.simps edges.simps less_eq_fset.rep_eq, simp)
apply (unfold diff_diff_eq)
proof -
have "\<forall>a aa b.
insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
fset vs \<subseteq> fset S \<longrightarrow>
Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
distinct \<pi> \<longrightarrow> (a, aa, b) \<in> set E \<longrightarrow> Inr (a, aa, b) \<notin> set \<pi> \<longrightarrow> b = ws"
by (metis (lifting) InrI List.set_simps(2)
prod.inject set_ConsD sum.simps(2))
moreover have "\<forall>a aa b.
insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
fset vs \<subseteq> fset S \<longrightarrow>
Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
distinct \<pi> \<longrightarrow> (a, aa, b) \<in> set E \<longrightarrow> Inr (a, aa, b) \<notin> set \<pi> \<longrightarrow> aa = c"
by (metis (lifting) InrI List.set_simps(2)
prod.inject set_ConsD sum.simps(2))
moreover have "\<forall>x. insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<longrightarrow>
fset vs \<subseteq> fset S \<longrightarrow>
Inr (vs, c, ws) \<notin> set \<pi> \<longrightarrow>
distinct \<pi> \<longrightarrow> x \<in> set \<pi> \<longrightarrow> x \<in> (fset V - fset S) <+> set E - {(vs, c, ws)}"
apply (unfold insert_is_Un[of _ "set \<pi>"])
apply (fold assms(3))
apply clarify
apply (subgoal_tac "set \<pi> = ((fset V - fset S) <+> set E) - {Inr e}")
by auto
ultimately show "Inr (vs, c, ws) \<notin> set \<pi> \<and> distinct \<pi> \<Longrightarrow>
insert (Inr (vs, c, ws)) (set \<pi>) = (fset V - fset S) <+> set E \<Longrightarrow>
fset vs \<subseteq> fset S \<Longrightarrow> set \<pi> = (fset V - fset S) <+> set E - {(vs, c, ws)}"
by blast
qed
next
fix i j v e
assume "i < length \<pi>" "j < length \<pi>" "\<pi> ! i = Inl v"
"\<pi> ! j = Inr e" "v |\<in>| fst3 e"
thus "i < j" using lins2D(3)[of "i+1" "j+1"] by auto
next
fix j k w e
assume "j < length \<pi>" "k < length \<pi>" "\<pi> ! j = Inr e"
"\<pi> ! k = Inl w" "w |\<in>| thd3 e"
thus "j < k" using lins2D(4)[of "j+1" "k+1"] by auto
qed
qed
text \<open>We wish to prove that every proofstate chain that can be obtained from
a linear extension of @{term G} is well-formed and has as its final
proofstate that state in which every terminal node in @{term G} is mapped
to @{term Bot}.
We first prove this for partially-processed diagrams, for
then the result for ordinary diagrams follows as an easy corollary.
We use induction on the size of the partially-processed diagram. The size of
a partially-processed diagram @{term "(G,S)"} is defined as the number of
nodes in @{term G}, plus the number of edges, minus the number of nodes in
@{term S}.\<close>
-lemmas [simp] = fmember.rep_eq
+lemmas [simp] = fmember_iff_member_fset
lemma wf_chains2:
fixes k
assumes "S |\<subseteq>| initials G"
and "wf_dia G"
and "\<Pi> \<in> ps_chains2 S G"
and "fcard G^V + length G^E = k + fcard S"
shows "wf_ps_chain \<Pi> \<and> (post \<Pi> = [ terminals G |=> Bot ])"
using assms
proof (induct k arbitrary: S G \<Pi>)
case 0
obtain V \<Lambda> E where G_def: "G = Graph V \<Lambda> E" by (metis diagram.exhaust)
have "S |\<subseteq>| V"
using "0.prems"(1) initials_in_vertices[of "G"]
by (auto simp add: G_def)
have "fcard V \<le> fcard S"
using "0.prems"(4)
by (unfold G_def, auto)
from fcard_seteq[OF \<open>S |\<subseteq>| V\<close> this] have "S = V" by auto
hence "E = []" using "0.prems"(4) by (unfold G_def, auto)
have "initials G = V"
by (unfold G_def \<open>E=[]\<close>, rule no_edges_imp_all_nodes_initial)
have "terminals G = V"
by (unfold G_def \<open>E=[]\<close>, rule no_edges_imp_all_nodes_terminal)
have "{} <+> {} = {}" by auto
have "lins2 S G = { [] }"
apply (unfold G_def \<open>S=V\<close> \<open>E=[]\<close>)
apply (unfold lins2_def, auto simp add: \<open>{} <+> {} = {}\<close>)
done
hence \<Pi>_def: "\<Pi> = \<lbrace> initial_ps2 S G \<rbrace>"
using "0.prems"(3)
by (auto simp add: ps_chains2_def mk_ps_chain_def)
show ?case
apply (intro conjI)
apply (unfold \<Pi>_def wf_ps_chain_def, auto)
apply (unfold post.simps initial_ps2_def \<open>initials G = V\<close> \<open>terminals G = V\<close>)
apply (unfold \<open>S=V\<close>)
apply (subgoal_tac "V - V = {||}", simp_all)
done
next
case (Suc k)
obtain V \<Lambda> E where G_def: "G = Graph V \<Lambda> E" by (metis diagram.exhaust)
from Suc.prems(3) obtain \<pi> where
\<Pi>_def: "\<Pi> = mk_ps_chain \<lbrace> initial_ps2 S G \<rbrace> \<pi>" and
\<pi>_in: "\<pi> \<in> lins2 S G"
by (auto simp add: ps_chains2_def)
note lins2 = lins2D[OF \<pi>_in]
have "S |\<subseteq>| V"
using Suc.prems(1) initials_in_vertices[of "G"]
by (auto simp add: G_def)
show ?case
proof (cases \<pi>)
case Nil
from \<pi>_in have "V = S" "E = []"
apply (-, unfold \<open>\<pi> = []\<close> lins2_def, simp_all)
apply (unfold empty_eq_Plus_conv)
apply (unfold G_def vertices.simps edges.simps, auto)
by (metis \<open>S |\<subseteq>| V\<close> less_eq_fset.rep_eq subset_antisym)
with Suc.prems(4) have False by (simp add: G_def)
thus ?thesis by auto
next
case (Cons x \<pi>')
note \<pi>_def = this
show ?thesis
proof (cases x)
case (Inl v)
note x_def = this
have "v |\<notin>| S \<and> v |\<in>| V"
apply (subgoal_tac "v \<in> fset V - fset S")
apply (simp)
apply (subgoal_tac "Inl v \<in> (fset V - fset S) <+> set E")
apply (metis Inl_inject Inr_not_Inl PlusE)
apply (metis lins2(1) lins2(2) Cons G_def Inl distinct.simps(2)
distinct_length_2_or_more edges.simps vertices.simps)
done
hence v_notin_S: "v |\<notin>| S" and v_in_V: "v |\<in>| V" by auto
have v_initial_not_S: "v |\<in>| initials G - S"
apply (simp only: G_def initials_def vertices.simps edges.simps)
apply (simp only: fminus_iff)
apply (simp only: conj_commute, intro conjI, rule v_notin_S)
apply (subgoal_tac
"v \<in> fset (ffilter (\<lambda>v. \<forall>e\<in>set E. v |\<notin>| thd3 e) V)")
apply simp
apply (simp only: filter_fset, simp, simp only: conj_commute)
apply (intro conjI ballI notI)
apply (insert v_in_V, simp)
proof -
fix e :: edge
assume "v \<in> fset (thd3 e)"
then have "v |\<in>| (thd3 e)" by auto
assume "e \<in> set E"
hence "Inr e \<in> set \<pi>" using lins2(2) by (auto simp add: G_def)
then obtain j where
"j < length \<pi>" "0 < length \<pi>" "\<pi>!j = Inr e" "\<pi>!0 = Inl v"
by (metis \<pi>_def x_def in_set_conv_nth length_pos_if_in_set nth_Cons_0)
with lins2(4)[OF this \<open>v |\<in>| (thd3 e)\<close>] show False by auto
qed
define S' where "S' = {|v|} |\<union>| S"
define \<Pi>' where "\<Pi>' = mk_ps_chain \<lbrace> initial_ps2 S' G \<rbrace> \<pi>'"
hence pre_\<Pi>': "pre \<Pi>' = initial_ps2 S' G"
by (metis pre.simps(1) pre_mk_ps_chain)
define \<sigma> where "\<sigma> = [ initials G - ({|v|} |\<union>| S) |=> Top ] ++\<^sub>f [ S |=> Bot ]"
have "wf_ps_chain \<Pi>' \<and> (post \<Pi>' = [terminals G |=> Bot])"
proof (intro Suc.hyps[of "S'"])
show "S' |\<subseteq>| initials G"
apply (unfold S'_def, auto)
- apply (metis fmember.rep_eq fminus_iff v_initial_not_S)
- by (metis Suc.prems(1) fmember.rep_eq fset_rev_mp)
+ apply (metis fmember_iff_member_fset fminus_iff v_initial_not_S)
+ by (metis Suc.prems(1) fmember_iff_member_fset fset_rev_mp)
next
show "wf_dia G" by (rule Suc.prems(2))
next
show "\<Pi>' \<in> ps_chains2 S' G"
apply (unfold ps_chains2_def \<Pi>'_def)
apply (intro imageI)
apply (unfold S'_def)
apply (intro next_lins2_vertex)
apply (fold x_def, fold \<pi>_def)
apply (rule \<pi>_in)
by (metis v_notin_S)
next
show "fcard G^V + length G^E = k + fcard S'"
apply (unfold S'_def)
by (auto simp add: Suc.prems(4) fcard_finsert_disjoint[OF v_notin_S])
qed
hence
wf_\<Pi>': "wf_ps_chain \<Pi>'" and
post_\<Pi>': "post \<Pi>' = [terminals G |=> Bot]"
by auto
show ?thesis
proof (intro conjI)
have 1: "fmdom [ {|v|} |=> Bot ]
|\<inter>| fmdom ([ initials G - ({|v|} |\<union>| S) |=> Top ] ++\<^sub>f
[ S |=> Bot ]) = {||}"
by (metis (no_types) fdom_make_fmap fmdom_add
bot_least funion_iff finter_finsert_left le_iff_inf
fminus_iff finsert_fsubset sup_ge1 v_initial_not_S)
show "wf_ps_chain \<Pi>"
using [[unfold_abs_def = false]]
apply (simp only: \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
apply simp
apply (unfold mk_ps_chain_ccons)
apply (fold next_initial_ps2_vertex S'_def)
apply (fold \<Pi>'_def)
apply (unfold wf_ps_chain_def chain_all.simps conj_commute)
apply (intro conjI)
apply (fold wf_ps_chain_def, rule wf_\<Pi>')
apply (intro wf_ps_triple_nodeI exI[of _ "\<sigma>"] conjI)
apply (unfold \<sigma>_def fmdom_add fdom_make_fmap)
apply (metis finsertI1 fminus_iff funion_iff v_notin_S)
apply (unfold pre_\<Pi>' initial_ps2_def S'_def)
apply (unfold fmap_add_commute[OF 1])
apply (unfold fmadd_assoc)
apply (fold fmadd_assoc[of _ "[ S |=> Bot ]"])
apply (unfold make_fmap_union sup.commute[of "{|v|}"])
apply (unfold fminus_funion)
using v_initial_not_S apply auto
by (metis (opaque_lifting, no_types) finsert_absorb finsert_fminus_single finter_fminus
inf_commute inf_idem v_initial_not_S)
next
show "post \<Pi> = [ terminals G |=> Bot ]"
apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons, simp)
apply (unfold mk_ps_chain_ccons post.simps)
apply (fold next_initial_ps2_vertex S'_def)
apply (fold \<Pi>'_def, rule post_\<Pi>')
done
qed
next
case (Inr e)
note x_def = this
define vs where "vs = fst3 e"
define ws where "ws = thd3 e"
obtain c where e_def: "e = (vs, c, ws)"
by (metis vs_def ws_def fst3_simp thd3_simp prod_cases3)
have "linearity E" and "acyclicity E" and
e_in_V: "\<And>e. e \<in> set E \<Longrightarrow> fst3 e |\<union>| thd3 e |\<subseteq>| V"
by (insert Suc.prems(2) wf_dia_inv, unfold G_def, blast)+
note lin = linearityD[OF this(1)]
have acy: "\<And>e. e \<in> set E \<Longrightarrow> fst3 e |\<inter>| thd3 e = {||}"
apply (fold fset_cong, insert \<open>acyclicity E\<close>)
apply (unfold acyclicity_def acyclic_def, auto)
done
note lins = lins2D[OF \<pi>_in]
have e_in_E: "e \<in> set E"
apply (subgoal_tac "set \<pi> = (fset G^V - fset S) <+> set G^E")
apply (unfold \<pi>_def x_def G_def edges.simps, auto)[1]
apply (simp add: lins(2))
done
have vs_in_S: "vs |\<subseteq>| S"
apply (insert e_in_V[OF e_in_E])
apply (unfold less_eq_fset.rep_eq)
apply (intro subsetI)
apply (unfold vs_def)
apply (rule ccontr)
apply (subgoal_tac "x \<in> fset V")
prefer 2
apply (auto)
proof -
fix v
assume a: "v \<in> fset (fst3 e)"
assume "v \<notin> fset S" and "v \<in> fset V"
hence "Inl v \<in> set \<pi>"
by (metis (lifting) DiffI G_def InlI lins(2) vertices.simps)
then obtain i where
"i < length \<pi>" "0 < length \<pi>" "\<pi>!i = Inl v" "\<pi>!0 = Inr e"
by (metis Cons Inr in_set_conv_nth length_pos_if_in_set nth_Cons_0)
from lins(3)[OF this] show "False" by (auto simp add: a)
qed
have "ws |\<inter>| (initials G) = {||}"
apply (insert e_in_V[OF e_in_E])
- apply (unfold initials_def less_eq_fset.rep_eq fmember.rep_eq, fold fset_cong)
+ apply (unfold initials_def less_eq_fset.rep_eq fmember_iff_member_fset, fold fset_cong)
apply (unfold ws_def G_def, auto simp add: e_in_E)
done
define S' where "S' = S - vs"
define V' where "V' = V - vs"
define E' where "E' = removeAll e E"
define G' where "G' = Graph V' \<Lambda> E'"
define \<Pi>' where "\<Pi>' = mk_ps_chain \<lbrace> initial_ps2 S' G' \<rbrace> \<pi>'"
hence pre_\<Pi>': "pre \<Pi>' = initial_ps2 S' G'"
by (metis pre.simps(1) pre_mk_ps_chain)
define \<sigma> where "\<sigma> = [ initials G - S |=> Top ] ++\<^sub>f [ S - vs |=> Bot ]"
have next_initial_ps2: "initial_ps2 S' G'
= initial_ps2 S G \<ominus> vs ++\<^sub>f [ws |=> Top]"
using next_initial_ps2_edge[OF G_def _ _ _ e_in_E _ Suc.prems(1)
Suc.prems(2)] G'_def E'_def vs_def ws_def V'_def vs_in_S S'_def
by auto
have "wf_ps_chain \<Pi>' \<and> post \<Pi>' = [ terminals G' |=> Bot ]"
proof (intro Suc.hyps[of "S'"])
show "S' |\<subseteq>| initials G'"
apply (insert Suc.prems(1))
apply (unfold G'_def G_def initials_def)
apply (unfold less_eq_fset.rep_eq S'_def E'_def V'_def)
apply auto
done
next
from Suc.prems(2) have "wf_dia (Graph V \<Lambda> E)"
by (unfold G_def)
note wf_G = wf_dia_inv[OF this]
show "wf_dia G'"
apply (unfold G'_def V'_def E'_def)
apply (insert wf_G e_in_E vs_in_S Suc.prems(1))
apply (unfold vs_def)
apply (intro wf_dia)
apply (unfold linearity_def initials_def G_def)
- apply (fold fset_cong, unfold less_eq_fset.rep_eq fmember.rep_eq)
+ apply (fold fset_cong, unfold less_eq_fset.rep_eq fmember_iff_member_fset)
apply (simp, simp)
apply (unfold acyclicity_def, rule acyclic_subset)
apply (auto simp add: distinct_removeAll)
apply (metis (lifting) IntI empty_iff)
done
next
show "\<Pi>' \<in> ps_chains2 S' G'"
apply (unfold \<Pi>_def \<Pi>'_def ps_chains2_def)
apply (intro imageI)
apply (unfold S'_def G'_def V'_def E'_def)
apply (intro next_lins2_edge)
apply (metis \<pi>_def G_def x_def \<pi>_in)
by (simp only: vs_in_S e_def)+
next
have "vs |\<subseteq>| V" by (metis (lifting) \<open>S |\<subseteq>| V\<close> order_trans vs_in_S)
have "distinct E" using \<open>linearity E\<close> linearity_def by auto
show "fcard G'^V + length G'^E = k + fcard S'"
apply (insert Suc.prems(4))
apply (unfold G_def G'_def vertices.simps edges.simps)
apply (unfold V'_def E'_def S'_def)
apply (unfold fcard_funion_fsubset[OF \<open>vs |\<subseteq>| V\<close>])
apply (unfold fcard_funion_fsubset[OF \<open>vs |\<subseteq>| S\<close>])
apply (fold distinct_remove1_removeAll[OF \<open>distinct E\<close>])
apply (unfold length_remove1)
apply (simp add: e_in_E)
apply (drule arg_cong[of _ _ "\<lambda>x. x - fcard vs - 1"])
apply (subst (asm) add_diff_assoc2[symmetric])
apply (simp add: fcard_mono[OF \<open>vs |\<subseteq>| V\<close>])
apply (subst add_diff_assoc, insert length_pos_if_in_set[OF e_in_E], arith, auto)
apply (subst add_diff_assoc, auto simp add: fcard_mono[OF \<open>vs |\<subseteq>| S\<close>])
done
qed
hence
wf_\<Pi>': "wf_ps_chain \<Pi>'" and
post_\<Pi>': "post \<Pi>' = [ terminals G' |=> Bot ]"
by auto
have terms_same: "terminals G = terminals G'"
apply (unfold G'_def G_def terminals_def edges.simps vertices.simps)
apply (unfold E'_def V'_def)
apply (fold fset_cong, auto simp add: e_in_E vs_def)
done
have 1: "fmdom [ fst3 e |=> Bot ] |\<inter>|
fmdom([ ffilter (\<lambda>v. \<forall>e\<in>set E. v |\<notin>| thd3 e) V - S |=> Top ]
++\<^sub>f [ S - fst3 e |=> Bot ]) = {||}"
apply (unfold fmdom_add fdom_make_fmap)
apply (fold fset_cong)
apply auto
apply (metis in_mono less_eq_fset.rep_eq vs_def vs_in_S)
done
show ?thesis
proof (intro conjI)
show "wf_ps_chain \<Pi>"
using [[unfold_abs_def = false]]
apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
apply simp
apply (unfold mk_ps_chain_ccons)
apply (fold vs_def ws_def)
apply (fold next_initial_ps2)
apply (fold \<Pi>'_def)
apply (unfold wf_ps_chain_def chain_all.simps conj_commute)
apply (intro conjI)
apply (fold wf_ps_chain_def)
apply (rule wf_\<Pi>')
apply (intro wf_ps_triple_edgeI exI[of _ "\<sigma>"])
apply (unfold e_def fst3_simp thd3_simp \<sigma>_def, intro conjI)
apply (insert Suc.prems(1))
apply (unfold pre_\<Pi>' initial_ps2_def initials_def)
apply (insert vs_in_S acy[OF e_in_E])
apply (fold fset_cong)
apply (unfold less_eq_fset.rep_eq)[1]
apply (unfold G_def G'_def vs_def ws_def V'_def E'_def S'_def)
apply (unfold vertices.simps edges.simps)
apply (unfold fmap_add_commute[OF 1])
apply (fold fmadd_assoc)
apply (unfold make_fmap_union)
apply (auto simp add: fdom_make_fmap e_in_E)[1]
apply simp
apply (unfold fmadd_assoc)
apply (unfold make_fmap_union)
apply (metis (lifting) funion_absorb2 vs_def vs_in_S)
apply (intro arg_cong2[of _ _ "[ S - fst3 e |=> Bot ]"
"[ S - fst3 e |=> Bot ]" "(++\<^sub>f)"])
apply (intro arg_cong2[of _ _ "Top" "Top" "make_fmap"])
defer 1
apply (simp, simp)
apply (fold fset_cong)
- apply (unfold less_eq_fset.rep_eq fmember.rep_eq, simp)
+ apply (unfold less_eq_fset.rep_eq fmember_iff_member_fset, simp)
apply (elim conjE)
apply (intro set_eqI iffI, simp_all)
apply (elim conjE, intro disjI conjI ballI, simp)
apply (case_tac "ea=e", simp_all)
apply (elim disjE conjE, intro conjI ballI impI, simp_all)
apply (insert e_in_E lin(2))[1]
apply (subst (asm) (2) fset_cong[symmetric])
apply (elim conjE)
apply (subst (asm) inter_fset)
apply (subst (asm) fset_simps)
apply (insert disjoint_iff_not_equal)[1]
apply blast
apply (metis G_def Suc(3) e_in_E subsetD less_eq_fset.rep_eq wf_dia_inv')
prefer 2
apply (metis (lifting) IntI Suc(2) \<open>ws |\<inter>| initials G = {||}\<close>
empty_iff fset_simps(1) in_mono inter_fset less_eq_fset.rep_eq ws_def)
apply auto
done
next
show "post \<Pi> = [terminals G |=> Bot]"
apply (unfold \<Pi>_def \<pi>_def x_def mk_ps_chain_cons)
apply simp
apply (unfold mk_ps_chain_ccons post.simps)
apply (fold vs_def ws_def)
apply (fold next_initial_ps2)
apply (fold \<Pi>'_def)
apply (unfold terms_same)
apply (rule post_\<Pi>')
done
qed
qed
qed
qed
corollary wf_chains:
assumes "wf_dia G"
assumes "\<Pi> \<in> ps_chains G"
shows "wf_ps_chain \<Pi> \<and> post \<Pi> = [ terminals G |=> Bot ]"
apply (intro wf_chains2[of "{||}"], insert assms(2))
by (auto simp add: assms(1) ps_chains_is_ps_chains2_with_empty_S fcard_fempty)
subsection \<open>Interface chains\<close>
type_synonym int_chain = "(interface, assertion_gadget + command_gadget) chain"
text \<open>An interface chain is similar to a proofstate chain. However, where a
proofstate chain talks about nodes and edges, an interface chain talks about
the assertion-gadgets and command-gadgets that label those nodes and edges
in a diagram. And where a proofstate chain talks about proofstates, an
interface chain talks about the interfaces obtained from those proofstates.
The following functions convert a proofstate chain into an
interface chain.\<close>
definition
ps_to_int :: "[diagram, proofstate] \<Rightarrow> interface"
where
"ps_to_int G \<sigma> \<equiv>
\<Otimes>v |\<in>| fmdom \<sigma>. case_topbot top_ass bot_ass (lookup \<sigma> v) (G^\<Lambda> v)"
definition
ps_chain_to_int_chain :: "[diagram, ps_chain] \<Rightarrow> int_chain"
where
"ps_chain_to_int_chain G \<Pi> \<equiv>
chainmap (ps_to_int G) ((case_sum (Inl \<circ> G^\<Lambda>) (Inr \<circ> snd3))) \<Pi>"
lemma ps_chain_to_int_chain_simp:
"ps_chain_to_int_chain (Graph V \<Lambda> E) \<Pi> =
chainmap (ps_to_int (Graph V \<Lambda> E)) ((case_sum (Inl \<circ> \<Lambda>) (Inr \<circ> snd3))) \<Pi>"
by (simp add: ps_chain_to_int_chain_def)
subsection \<open>Soundness proof\<close>
text \<open>We assume that @{term wr_com} always returns @{term "{}"}. This is
equivalent to changing our axiomatization of separation logic such that the
frame rule has no side-condition. One way to obtain a separation logic
lacking a side-condition on its frame rule is to use variables-as-
resource.
We proceed by induction on the proof rules for graphical diagrams. We
show that: (1) if a diagram @{term G} is provable w.r.t. interfaces
@{term P} and @{term Q}, then @{term P} and @{term Q} are the top and bottom
interfaces of @{term G}, and that the Hoare triple @{term "(asn P,
c, asn Q)"} is provable for each command @{term c} that can be extracted
from @{term G}; (2) if a command-gadget @{term C} is provable w.r.t.
interfaces @{term P} and @{term Q}, then the Hoare triple @{term "(asn P,
c, asn Q)"} is provable for each command @{term c} that can be extracted
from @{term C}; and (3) if an assertion-gadget @{term A} is provable, and if
the top and bottom interfaces of @{term A} are @{term P} and @{term Q}
respectively, then the Hoare triple @{term "(asn P, c, asn Q)"} is provable
for each command @{term c} that can be extracted from @{term A}.\<close>
lemma soundness_graphical_helper:
assumes no_var_interference: "\<And>c. wr_com c = {}"
shows
"(prov_dia G P Q \<longrightarrow>
(P = top_dia G \<and> Q = bot_dia G \<and>
(\<forall>c. coms_dia G c \<longrightarrow> prov_triple (asn P, c, asn Q))))
\<and> (prov_com C P Q \<longrightarrow>
(\<forall>c. coms_com C c \<longrightarrow> prov_triple (asn P, c, asn Q)))
\<and> (prov_ass A \<longrightarrow>
(\<forall>c. coms_ass A c \<longrightarrow> prov_triple (asn (top_ass A), c, asn (bot_ass A))))"
proof (induct rule: prov_dia_prov_com_prov_ass.induct)
case (Skip p)
thus ?case
apply (intro allI impI, elim conjE coms_skip_inv)
apply (auto simp add: prov_triple.skip)
done
next
case (Exists G P Q x)
thus ?case
apply (intro allI impI, elim conjE coms_exists_inv)
apply (auto simp add: prov_triple.exists)
done
next
case (Basic P c Q)
thus ?case
by (intro allI impI, elim conjE coms_basic_inv, auto)
next
case (Choice G P Q H)
thus ?case
apply (intro allI impI, elim conjE coms_choice_inv)
apply (auto simp add: prov_triple.choose)
done
next
case (Loop G P)
thus ?case
apply (intro allI impI, elim conjE coms_loop_inv)
apply (auto simp add: prov_triple.loop)
done
next
case (Main G)
thus ?case
apply (intro conjI)
apply (simp, simp)
apply (intro allI impI)
apply (elim coms_main_inv, simp)
proof -
fix c V \<Lambda> E
fix \<pi>::"lin"
fix cs::"command list"
assume wf_G: "wf_dia (Graph V \<Lambda> E)"
assume "\<And>v. v \<in> fset V \<Longrightarrow> \<forall>c. coms_ass (\<Lambda> v) c \<longrightarrow>
prov_triple (asn (top_ass (\<Lambda> v)), c, asn (bot_ass (\<Lambda> v)))"
hence prov_vertex: "\<And>v c P Q F. \<lbrakk> coms_ass (\<Lambda> v) c; v \<in> fset V;
P = (top_ass (\<Lambda> v) \<otimes> F) ; Q = (bot_ass (\<Lambda> v) \<otimes> F) \<rbrakk>
\<Longrightarrow> prov_triple (asn P, c, asn Q)"
by (auto simp add: prov_triple.frame no_var_interference)
assume "\<And>e. e \<in> set E \<Longrightarrow> \<forall>c. coms_com (snd3 e) c \<longrightarrow> prov_triple
(asn (\<Otimes>v|\<in>|fst3 e. bot_ass (\<Lambda> v)),c,asn (\<Otimes>v|\<in>|thd3 e. top_ass (\<Lambda> v)))"
hence prov_edge: "\<And>e c P Q F. \<lbrakk> e \<in> set E ; coms_com (snd3 e) c ;
P = ((\<Otimes>v|\<in>|fst3 e. bot_ass (\<Lambda> v)) \<otimes> F) ;
Q = ((\<Otimes>v|\<in>|thd3 e. top_ass (\<Lambda> v)) \<otimes> F) \<rbrakk>
\<Longrightarrow> prov_triple (asn P, c, asn Q)"
by (auto simp add: prov_triple.frame no_var_interference)
assume len_cs: "length cs = length \<pi>"
assume "\<forall>i<length \<pi>.
case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi> ! i) (cs ! i)"
hence \<pi>_cs: "\<And>i. i < length \<pi> \<Longrightarrow>
case_sum (coms_ass \<circ> \<Lambda>) (coms_com \<circ> snd3) (\<pi> ! i) (cs ! i)" by auto
assume G_def: "G = Graph V \<Lambda> E"
assume c_def: "c = foldr (;;) cs Skip"
assume \<pi>_lin: "\<pi> \<in> lins (Graph V \<Lambda> E)"
note lins = linsD[OF \<pi>_lin]
define \<Pi> where "\<Pi> = mk_ps_chain \<lbrace> initial_ps G \<rbrace> \<pi>"
have "\<Pi> \<in> ps_chains G" by (simp add: \<pi>_lin \<Pi>_def ps_chains_def G_def)
hence 1: "post \<Pi> = [ terminals G |=> Bot ]"
and 2: "chain_all wf_ps_triple \<Pi>"
by (insert wf_chains G_def wf_G, auto simp add: wf_ps_chain_def)
show "prov_triple (asn (\<Otimes>v|\<in>|initials (Graph V \<Lambda> E). top_ass (\<Lambda> v)),
foldr (;;) cs Skip, asn (\<Otimes>v|\<in>|terminals (Graph V \<Lambda> E). bot_ass (\<Lambda> v)))"
using [[unfold_abs_def = false]]
apply (intro seq_fold[of _ "ps_chain_to_int_chain G \<Pi>"])
apply (unfold len_cs)
apply (unfold ps_chain_to_int_chain_def chainmap_preserves_length \<Pi>_def)
apply (unfold mk_ps_chain_preserves_length, simp)
apply (unfold pre_chainmap post_chainmap)
apply (unfold pre_mk_ps_chain pre.simps)
apply (fold \<Pi>_def, unfold 1)
apply (unfold initial_ps_def)
apply (unfold ps_to_int_def)
apply (unfold fdom_make_fmap)
apply (unfold G_def labelling.simps, fold G_def)
apply (subgoal_tac "\<forall>v \<in> fset (initials G). top_ass (\<Lambda> v) =
case_topbot top_ass bot_ass (lookup [ initials G |=> Top ] v) (\<Lambda> v)")
apply (unfold iter_hcomp_cong, simp)
apply (metis lookup_make_fmap topbot.simps(3))
apply (subgoal_tac "\<forall>v \<in> fset (terminals G). bot_ass (\<Lambda> v) =
case_topbot top_ass bot_ass (lookup [ terminals G |=> Bot ] v) (\<Lambda> v)")
apply (unfold iter_hcomp_cong, simp)
apply (metis lookup_make_fmap topbot.simps(4), simp)
apply (unfold G_def, fold ps_chain_to_int_chain_simp G_def)
proof -
fix i
assume "i < length \<pi>"
hence "i < chainlen \<Pi>"
by (metis \<Pi>_def add_0_left chainlen.simps(1)
mk_ps_chain_preserves_length)
hence wf_\<Pi>i: "wf_ps_triple (nthtriple \<Pi> i)"
by (insert 2, simp add: chain_all_nthtriple)
show "prov_triple (asn (fst3 (nthtriple (ps_chain_to_int_chain G \<Pi>) i)),
cs ! i, asn (thd3 (nthtriple (ps_chain_to_int_chain G \<Pi>) i)))"
apply (unfold ps_chain_to_int_chain_def)
apply (unfold nthtriple_chainmap[OF \<open>i < chainlen \<Pi>\<close>])
apply (unfold fst3_simp thd3_simp)
proof (cases "\<pi>!i")
case (Inl v)
have "snd3 (nthtriple \<Pi> i) = Inl v"
apply (unfold snds_of_triples_form_comlist[OF \<open>i < chainlen \<Pi>\<close>])
apply (auto simp add: \<Pi>_def comlist_mk_ps_chain Inl)
done
with wf_\<Pi>i wf_ps_triple_def obtain \<sigma> where
v_notin_\<sigma>: "v |\<notin>| fmdom \<sigma>" and
fst_\<Pi>i: "fst3 (nthtriple \<Pi> i) = [ {|v|} |=> Top ] ++\<^sub>f \<sigma>" and
thd_\<Pi>i: "thd3 (nthtriple \<Pi> i) = [ {|v|} |=> Bot ] ++\<^sub>f \<sigma>" by auto
show "prov_triple (asn (ps_to_int G (fst3 (nthtriple \<Pi> i))),
cs ! i, asn (ps_to_int G (thd3 (nthtriple \<Pi> i))))"
apply (intro prov_vertex[where v=v])
apply (metis (no_types) Inl \<open>i < length \<pi>\<close> \<pi>_cs o_def sum.simps(5))
apply (metis (lifting) Inl lins(2) Inl_not_Inr PlusE \<open>i < length \<pi>\<close>
nth_mem sum.simps(1) vertices.simps)
apply (unfold fst_\<Pi>i thd_\<Pi>i)
apply (unfold ps_to_int_def)
apply (unfold fmdom_add fdom_make_fmap)
apply (unfold finsert_is_funion[symmetric])
apply (insert v_notin_\<sigma>)
apply (unfold iter_hcomp_insert)
apply (unfold lookup_union2 lookup_make_fmap1)
apply (unfold G_def labelling.simps)
apply (subgoal_tac "\<forall>va \<in> fset (fmdom \<sigma>). case_topbot top_ass bot_ass
(lookup ([ {|v|} |=> Top ] ++\<^sub>f \<sigma>) va) (\<Lambda> va) =
case_topbot top_ass bot_ass (lookup ([{|v|} |=> Bot] ++\<^sub>f \<sigma>) va)(\<Lambda> va)")
apply (unfold iter_hcomp_cong, simp)
- apply (metis fmember.rep_eq lookup_union1, simp)
+ apply (metis fmember_iff_member_fset lookup_union1, simp)
done
next
case (Inr e)
have "snd3 (nthtriple \<Pi> i) = Inr e"
apply (unfold snds_of_triples_form_comlist[OF \<open>i < chainlen \<Pi>\<close>])
apply (auto simp add: \<Pi>_def comlist_mk_ps_chain Inr)
done
with wf_\<Pi>i wf_ps_triple_def obtain \<sigma> where
fst_e_disjoint_\<sigma>: "fst3 e |\<inter>| fmdom \<sigma> = {||}" and
thd_e_disjoint_\<sigma>: "thd3 e |\<inter>| fmdom \<sigma> = {||}" and
fst_\<Pi>i: "fst3 (nthtriple \<Pi> i) = [ fst3 e |=> Bot ] ++\<^sub>f \<sigma>" and
thd_\<Pi>i: "thd3 (nthtriple \<Pi> i) = [ thd3 e |=> Top ] ++\<^sub>f \<sigma>"
by (auto simp add: inf_sup_distrib2)
show "prov_triple (asn (ps_to_int G (fst3 (nthtriple \<Pi> i))),
cs ! i, asn (ps_to_int G (thd3 (nthtriple \<Pi> i))))"
apply (intro prov_edge[where e=e])
apply (subgoal_tac "Inr e \<in> set \<pi>")
apply (metis Inr_not_Inl PlusE edges.simps lins(2) sum.simps(2))
apply (metis Inr \<open>i < length \<pi>\<close> nth_mem)
apply (metis (no_types) Inr \<open>i < length \<pi>\<close> \<pi>_cs o_def sum.simps(6))
apply (unfold fst_\<Pi>i thd_\<Pi>i)
apply (unfold ps_to_int_def)
apply (unfold G_def labelling.simps)
apply (unfold fmdom_add fdom_make_fmap)
apply (insert fst_e_disjoint_\<sigma>)
apply (unfold iter_hcomp_union)
apply (subgoal_tac "\<forall>v \<in> fset (fst3 e). case_topbot top_ass bot_ass
(lookup ([ fst3 e |=> Bot ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) = bot_ass (\<Lambda> v)")
apply (unfold iter_hcomp_cong)
apply (simp)
apply (intro ballI)
apply (subgoal_tac "v |\<notin>| fmdom \<sigma>")
apply (unfold lookup_union2)
apply (metis lookup_make_fmap topbot.simps(4))
- apply (metis fempty_iff finterI fmember.rep_eq)
+ apply (metis fempty_iff finterI fmember_iff_member_fset)
apply (insert thd_e_disjoint_\<sigma>)
apply (unfold iter_hcomp_union)
apply (subgoal_tac "\<forall>v \<in> fset (thd3 e). case_topbot top_ass bot_ass
(lookup ([ thd3 e |=> Top ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) = top_ass (\<Lambda> v)")
apply (unfold iter_hcomp_cong)
apply (subgoal_tac "\<forall>v \<in> fset (fmdom \<sigma>). case_topbot top_ass bot_ass
(lookup ([ thd3 e |=> Top ] ++\<^sub>f \<sigma>) v) (\<Lambda> v) =
case_topbot top_ass bot_ass (lookup ([fst3 e |=> Bot] ++\<^sub>f \<sigma>) v) (\<Lambda> v)")
apply (unfold iter_hcomp_cong)
apply simp
apply (intro ballI)
apply (subgoal_tac "v |\<in>| fmdom \<sigma>")
apply (unfold lookup_union1, auto)
apply (subgoal_tac "v |\<notin>| fmdom \<sigma>")
apply (unfold lookup_union2)
apply (metis lookup_make_fmap topbot.simps(3))
- by (metis fempty_iff finterI fmember.rep_eq)
+ by (metis fempty_iff finterI fmember_iff_member_fset)
qed
qed
qed
qed
text \<open>The soundness theorem states that any diagram provable using the
proof rules for ribbons can be recreated as a valid proof in separation
logic.\<close>
corollary soundness_graphical:
assumes "\<And>c. wr_com c = {}"
assumes "prov_dia G P Q"
shows "\<forall>c. coms_dia G c \<longrightarrow> prov_triple (asn P, c, asn Q)"
using soundness_graphical_helper[OF assms(1)] and assms(2) by auto
end
diff --git a/thys/Ribbon_Proofs/Ribbons_Interfaces.thy b/thys/Ribbon_Proofs/Ribbons_Interfaces.thy
--- a/thys/Ribbon_Proofs/Ribbons_Interfaces.thy
+++ b/thys/Ribbon_Proofs/Ribbons_Interfaces.thy
@@ -1,210 +1,210 @@
section \<open>Ribbon proof interfaces\<close>
theory Ribbons_Interfaces imports
Ribbons_Basic
Proofchain
"HOL-Library.FSet"
begin
text \<open>Interfaces are the top and bottom boundaries through which diagrams
can be connected into a surrounding context. For instance, when composing two
diagrams vertically, the bottom interface of the upper diagram must match the
top interface of the lower diagram.
We define a datatype of concrete interfaces. We then quotient by the
associativity, commutativity and unity properties of our
horizontal-composition operator.\<close>
subsection \<open>Syntax of interfaces\<close>
datatype conc_interface =
Ribbon_conc "assertion"
| HComp_int_conc "conc_interface" "conc_interface" (infix "\<otimes>\<^sub>c" 50)
| Emp_int_conc ("\<epsilon>\<^sub>c")
| Exists_int_conc "string" "conc_interface"
text \<open>We define an equivalence on interfaces. The first three rules make this
an equivalence relation. The next three make it a congruence. The next two
identify interfaces up to associativity and commutativity of @{term "(\<otimes>\<^sub>c)"}
The final two make @{term "\<epsilon>\<^sub>c"} the left and right unit of @{term "(\<otimes>\<^sub>c)"}.
\<close>
inductive
equiv_int :: "conc_interface \<Rightarrow> conc_interface \<Rightarrow> bool" (infix "\<simeq>" 45)
where
refl: "P \<simeq> P"
| sym: "P \<simeq> Q \<Longrightarrow> Q \<simeq> P"
| trans: "\<lbrakk>P \<simeq> Q; Q \<simeq> R\<rbrakk> \<Longrightarrow> P \<simeq> R"
| cong_hcomp1: "P \<simeq> Q \<Longrightarrow> P' \<otimes>\<^sub>c P \<simeq> P' \<otimes>\<^sub>c Q"
| cong_hcomp2: "P \<simeq> Q \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c P'"
| cong_exists: "P \<simeq> Q \<Longrightarrow> Exists_int_conc x P \<simeq> Exists_int_conc x Q"
| hcomp_conc_assoc: "P \<otimes>\<^sub>c (Q \<otimes>\<^sub>c R) \<simeq> (P \<otimes>\<^sub>c Q) \<otimes>\<^sub>c R"
| hcomp_conc_comm: "P \<otimes>\<^sub>c Q \<simeq> Q \<otimes>\<^sub>c P"
| hcomp_conc_unit1: "\<epsilon>\<^sub>c \<otimes>\<^sub>c P \<simeq> P"
| hcomp_conc_unit2: "P \<otimes>\<^sub>c \<epsilon>\<^sub>c \<simeq> P"
lemma equiv_int_cong_hcomp:
"\<lbrakk> P \<simeq> Q ; P' \<simeq> Q' \<rbrakk> \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c Q'"
by (metis cong_hcomp1 cong_hcomp2 equiv_int.trans)
quotient_type interface = "conc_interface" / "equiv_int"
apply (intro equivpI)
apply (intro reflpI, simp add: equiv_int.refl)
apply (intro sympI, simp add: equiv_int.sym)
apply (intro transpI, elim equiv_int.trans, simp add: equiv_int.refl)
done
lift_definition
Ribbon :: "assertion \<Rightarrow> interface"
is "Ribbon_conc" .
lift_definition
Emp_int :: "interface" ("\<epsilon>")
is "\<epsilon>\<^sub>c" .
lift_definition
Exists_int :: "string \<Rightarrow> interface \<Rightarrow> interface"
is "Exists_int_conc"
by (rule equiv_int.cong_exists)
lift_definition
HComp_int :: "interface \<Rightarrow> interface \<Rightarrow> interface" (infix "\<otimes>" 50)
is "HComp_int_conc" by (rule equiv_int_cong_hcomp)
lemma hcomp_comm:
"(P \<otimes> Q) = (Q \<otimes> P)"
by (rule hcomp_conc_comm[Transfer.transferred])
lemma hcomp_assoc:
"(P \<otimes> (Q \<otimes> R)) = ((P \<otimes> Q) \<otimes> R)"
by (rule hcomp_conc_assoc[Transfer.transferred])
lemma emp_hcomp:
"\<epsilon> \<otimes> P = P"
by (rule hcomp_conc_unit1[Transfer.transferred])
lemma hcomp_emp:
"P \<otimes> \<epsilon> = P"
by (rule hcomp_conc_unit2[Transfer.transferred])
lemma comp_fun_commute_hcomp:
"comp_fun_commute (\<otimes>)"
by standard (simp add: hcomp_assoc fun_eq_iff, metis hcomp_comm)
subsection \<open>An iterated horizontal-composition operator\<close>
definition iter_hcomp :: "('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
where
"iter_hcomp X f \<equiv> ffold ((\<otimes>) \<circ> f) \<epsilon> X"
syntax "iter_hcomp_syntax" ::
"'a \<Rightarrow> ('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
("(\<Otimes>_|\<in>|_. _)" [0,0,10] 10)
translations "\<Otimes>x|\<in>|M. e" == "CONST iter_hcomp M (\<lambda>x. e)"
term "\<Otimes>P|\<in>|Ps. f P" \<comment> \<open>this is eta-expanded, so prints in expanded form\<close>
term "\<Otimes>P|\<in>|Ps. f" \<comment> \<open>this isn't eta-expanded, so prints as written\<close>
lemma iter_hcomp_cong:
assumes "\<forall>v \<in> fset vs. \<phi> v = \<phi>' v"
shows "(\<Otimes>v|\<in>|vs. \<phi> v) = (\<Otimes>v|\<in>|vs. \<phi>' v)"
using assms unfolding iter_hcomp_def
-by (auto simp add: fmember.rep_eq comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp
+by (auto simp add: fmember_iff_member_fset comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp
intro: ffold_cong)
lemma iter_hcomp_empty:
shows "(\<Otimes>x |\<in>| {||}. p x) = \<epsilon>"
by (metis comp_fun_commute.ffold_empty comp_fun_commute_hcomp iter_hcomp_def)
lemma iter_hcomp_insert:
assumes "v |\<notin>| ws"
shows "(\<Otimes>x |\<in>| finsert v ws. p x) = (p v \<otimes> (\<Otimes>x |\<in>| ws. p x))"
proof -
interpret comp_fun_commute "((\<otimes>) \<circ> p)"
by (metis comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp)
from assms show ?thesis unfolding iter_hcomp_def by auto
qed
lemma iter_hcomp_union:
assumes "vs |\<inter>| ws = {||}"
shows "(\<Otimes>x |\<in>| vs |\<union>| ws. p x) = ((\<Otimes>x |\<in>| vs. p x) \<otimes> (\<Otimes>x |\<in>| ws. p x))"
using assms
by (induct vs) (auto simp add: emp_hcomp iter_hcomp_empty iter_hcomp_insert hcomp_assoc)
subsection \<open>Semantics of interfaces\<close>
text \<open>The semantics of an interface is an assertion.\<close>
fun
conc_asn :: "conc_interface \<Rightarrow> assertion"
where
"conc_asn (Ribbon_conc p) = p"
| "conc_asn (P \<otimes>\<^sub>c Q) = (conc_asn P) \<star> (conc_asn Q)"
| "conc_asn (\<epsilon>\<^sub>c) = Emp"
| "conc_asn (Exists_int_conc x P) = Exists x (conc_asn P)"
lift_definition
asn :: "interface \<Rightarrow> assertion"
is "conc_asn"
by (induct_tac rule:equiv_int.induct) (auto simp add: star_assoc star_comm star_rot emp_star)
lemma asn_simps [simp]:
"asn (Ribbon p) = p"
"asn (P \<otimes> Q) = (asn P) \<star> (asn Q)"
"asn \<epsilon> = Emp"
"asn (Exists_int x P) = Exists x (asn P)"
by (transfer, simp)+
subsection \<open>Program variables mentioned in an interface.\<close>
fun
rd_conc_int :: "conc_interface \<Rightarrow> string set"
where
"rd_conc_int (Ribbon_conc p) = rd_ass p"
| "rd_conc_int (P \<otimes>\<^sub>c Q) = rd_conc_int P \<union> rd_conc_int Q"
| "rd_conc_int (\<epsilon>\<^sub>c) = {}"
| "rd_conc_int (Exists_int_conc x P) = rd_conc_int P"
lift_definition
rd_int :: "interface \<Rightarrow> string set"
is "rd_conc_int"
by (induct_tac rule: equiv_int.induct) auto
text \<open>The program variables read by an interface are the same as those read
by its corresponding assertion.\<close>
lemma rd_int_is_rd_ass:
"rd_ass (asn P) = rd_int P"
by (transfer, induct_tac P, auto simp add: rd_star rd_exists rd_emp)
text \<open>Here is an iterated version of the Hoare logic sequencing rule.\<close>
lemma seq_fold:
"\<And>\<Pi>. \<lbrakk> length cs = chainlen \<Pi> ; p1 = asn (pre \<Pi>) ; p2 = asn (post \<Pi>) ;
\<And>i. i < chainlen \<Pi> \<Longrightarrow> prov_triple
(asn (fst3 (nthtriple \<Pi> i)), cs ! i, asn (thd3 (nthtriple \<Pi> i))) \<rbrakk>
\<Longrightarrow> prov_triple (p1, foldr (;;) cs Skip, p2)"
proof (induct cs arbitrary: p1 p2)
case Nil
thus ?case
by (cases \<Pi>, auto simp add: prov_triple.skip)
next
case (Cons c cs)
obtain p x \<Pi>' where \<Pi>_def: "\<Pi> = \<lbrace> p \<rbrace> \<cdot> x \<cdot> \<Pi>'"
by (metis Cons.prems(1) chain.exhaust chainlen.simps(1) impossible_Cons le0)
show ?case
apply (unfold foldr_Cons o_def)
apply (rule prov_triple.seq[where q = "asn (pre \<Pi>')"])
apply (unfold Cons.prems(2) Cons.prems(3) \<Pi>_def pre.simps post.simps)
apply (subst nth_Cons_0[of c cs, symmetric])
apply (subst fst3_simp[of p x "pre \<Pi>'", symmetric])
apply (subst(2) thd3_simp[of p x "pre \<Pi>'", symmetric])
apply (subst(1 2) nthtriple.simps(1)[of p x "\<Pi>'", symmetric])
apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
apply (intro Cons.hyps, insert \<Pi>_def Cons.prems(1), auto)
apply (fold nth_Cons_Suc[of c cs] nthtriple.simps(2)[of p x "\<Pi>'"])
apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
done
qed
end
diff --git a/thys/SC_DOM_Components/Core_DOM_DOM_Components.thy b/thys/SC_DOM_Components/Core_DOM_DOM_Components.thy
--- a/thys/SC_DOM_Components/Core_DOM_DOM_Components.thy
+++ b/thys/SC_DOM_Components/Core_DOM_DOM_Components.thy
@@ -1,2344 +1,2344 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section \<open>Core SC DOM Components\<close>
theory Core_DOM_DOM_Components
imports Core_SC_DOM.Core_DOM
begin
subsection \<open>Components\<close>
locale l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_root_node_defs get_root_node get_root_node_locs +
l_to_tree_order_defs to_tree_order
for get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
begin
definition a_get_dom_component :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_get_dom_component ptr = do {
root \<leftarrow> get_root_node ptr;
to_tree_order root
}"
definition a_is_strongly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
where
"a_is_strongly_dom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h' = (
let removed_pointers = fset (object_ptr_kinds h) - fset (object_ptr_kinds h') in
let added_pointers = fset (object_ptr_kinds h') - fset (object_ptr_kinds h) in
let arg_components =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h). set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) in
let arg_components' =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h'). set |h' \<turnstile> a_get_dom_component ptr|\<^sub>r) in
removed_pointers \<subseteq> arg_components \<and>
added_pointers \<subseteq> arg_components' \<and>
S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t \<subseteq> arg_components' \<and>
(\<forall>outside_ptr \<in> fset (object_ptr_kinds h) \<inter> fset (object_ptr_kinds h') -
(\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r). preserved (get_M outside_ptr id) h h'))"
definition a_is_weakly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
where
"a_is_weakly_dom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h' = (
let removed_pointers = fset (object_ptr_kinds h) - fset (object_ptr_kinds h') in
let added_pointers = fset (object_ptr_kinds h') - fset (object_ptr_kinds h) in
let arg_components =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h). set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) in
let arg_components' =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h'). set |h' \<turnstile> a_get_dom_component ptr|\<^sub>r) in
removed_pointers \<subseteq> arg_components \<and>
S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t \<subseteq> arg_components' \<union> added_pointers \<and>
(\<forall>outside_ptr \<in> fset (object_ptr_kinds h) \<inter> fset (object_ptr_kinds h') -
(\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_dom_component ptr|\<^sub>r). preserved (get_M outside_ptr id) h h'))"
lemma "a_is_strongly_dom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h' \<Longrightarrow> a_is_weakly_dom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h'"
by(auto simp add: a_is_strongly_dom_component_safe_def a_is_weakly_dom_component_safe_def Let_def)
definition is_document_component :: "(_) object_ptr list \<Rightarrow> bool"
where
"is_document_component c = is_document_ptr_kind (hd c)"
definition is_disconnected_component :: "(_) object_ptr list \<Rightarrow> bool"
where
"is_disconnected_component c = is_node_ptr_kind (hd c)"
end
global_interpretation l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs to_tree_order
defines get_dom_component = a_get_dom_component
and is_strongly_dom_component_safe = a_is_strongly_dom_component_safe
and is_weakly_dom_component_safe = a_is_weakly_dom_component_safe
.
locale l_get_dom_component_defs =
fixes get_dom_component :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
fixes is_strongly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
fixes is_weakly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
locale l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_to_tree_order_wf +
l_get_dom_component_defs +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_ancestors +
l_get_ancestors_wf +
l_get_root_node +
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent +
l_get_parent_wf +
l_get_element_by +
l_to_tree_order_wf_get_root_node_wf +
(* l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ get_child_nodes +
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ get_child_nodes+
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ "l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.a_to_tree_order get_child_nodes"
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog" *)
assumes get_dom_component_impl: "get_dom_component = a_get_dom_component"
assumes is_strongly_dom_component_safe_impl:
"is_strongly_dom_component_safe = a_is_strongly_dom_component_safe"
assumes is_weakly_dom_component_safe_impl:
"is_weakly_dom_component_safe = a_is_weakly_dom_component_safe"
begin
lemmas get_dom_component_def = a_get_dom_component_def[folded get_dom_component_impl]
lemmas is_strongly_dom_component_safe_def =
a_is_strongly_dom_component_safe_def[folded is_strongly_dom_component_safe_impl]
lemmas is_weakly_dom_component_safe_def =
a_is_weakly_dom_component_safe_def[folded is_weakly_dom_component_safe_impl]
lemma get_dom_component_ptr_in_heap:
assumes "h \<turnstile> ok (get_dom_component ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms get_root_node_ptr_in_heap
by(auto simp add: get_dom_component_def)
lemma get_dom_component_ok:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_dom_component ptr)"
using assms
apply(auto simp add: get_dom_component_def a_get_root_node_def intro!: bind_is_OK_pure_I)[1]
using get_root_node_ok to_tree_order_ok get_root_node_ptr_in_heap
apply blast
by (simp add: local.get_root_node_root_in_heap local.to_tree_order_ok)
lemma get_dom_component_ptr:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
shows "ptr \<in> set c"
proof(insert assms(1) assms(4), induct ptr rule: heap_wellformed_induct_rev )
case (step child)
then show ?case
proof (cases "is_node_ptr_kind child")
case True
obtain node_ptr where
node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = child"
using \<open>is_node_ptr_kind child\<close> node_ptr_casts_commute3 by blast
have "child |\<in>| object_ptr_kinds h"
using \<open>h \<turnstile> get_dom_component child \<rightarrow>\<^sub>r c\<close> get_dom_component_ptr_in_heap by fast
with node_ptr have "node_ptr |\<in>| node_ptr_kinds h"
by auto
then obtain parent_opt where
parent: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt"
using get_parent_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by fast
then show ?thesis
proof (induct parent_opt)
case None
then have "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
by (simp add: local.get_root_node_no_parent)
then show ?case
using \<open>type_wf h\<close> \<open>known_ptrs h\<close> node_ptr step(2)
apply(auto simp add: get_dom_component_def a_get_root_node_def elim!: bind_returns_result_E2)[1]
using to_tree_order_ptr_in_result returns_result_eq by fastforce
next
case (Some parent_ptr)
then have "h \<turnstile> get_dom_component parent_ptr \<rightarrow>\<^sub>r c"
using step(2) node_ptr \<open>type_wf h\<close> \<open>known_ptrs h\<close> \<open>heap_is_wellformed h\<close>
get_root_node_parent_same
by(auto simp add: get_dom_component_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I)
then have "parent_ptr \<in> set c"
using step node_ptr Some by blast
then show ?case
using \<open>type_wf h\<close> \<open>known_ptrs h\<close> \<open>heap_is_wellformed h\<close> step(2) node_ptr Some
apply(auto simp add: get_dom_component_def elim!: bind_returns_result_E2)[1]
using to_tree_order_parent by blast
qed
next
case False
then show ?thesis
using \<open>type_wf h\<close> \<open>known_ptrs h\<close> step(2)
apply(auto simp add: get_dom_component_def elim!: bind_returns_result_E2)[1]
by (metis is_OK_returns_result_I local.get_root_node_not_node_same
local.get_root_node_ptr_in_heap local.to_tree_order_ptr_in_result returns_result_eq)
qed
qed
lemma get_dom_component_parent_inside:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "cast node_ptr \<in> set c"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some parent"
shows "parent \<in> set c"
proof -
have "parent |\<in>| object_ptr_kinds h"
using assms(6) get_parent_parent_in_heap by blast
obtain root_ptr where root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr" and c: "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using assms(4)
by (metis (no_types, opaque_lifting) bind_returns_result_E2 get_dom_component_def get_root_node_pure)
then have "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r root_ptr"
using assms(1) assms(2) assms(3) assms(5) to_tree_order_same_root by blast
then have "h \<turnstile> get_root_node parent \<rightarrow>\<^sub>r root_ptr"
using assms(6) get_root_node_parent_same by blast
then have "h \<turnstile> get_dom_component parent \<rightarrow>\<^sub>r c"
using c get_dom_component_def by auto
then show ?thesis
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
qed
lemma get_dom_component_subset:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "ptr' \<in> set c"
shows "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
proof(insert assms(1) assms(5), induct ptr' rule: heap_wellformed_induct_rev )
case (step child)
then show ?case
proof (cases "is_node_ptr_kind child")
case True
obtain node_ptr where
node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = child"
using \<open>is_node_ptr_kind child\<close> node_ptr_casts_commute3 by blast
have "child |\<in>| object_ptr_kinds h"
using to_tree_order_ptrs_in_heap assms(1) assms(2) assms(3) assms(4) step(2)
unfolding get_dom_component_def
by (meson bind_returns_result_E2 get_root_node_pure)
with node_ptr have "node_ptr |\<in>| node_ptr_kinds h"
by auto
then obtain parent_opt where
parent: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt"
using get_parent_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by fast
then show ?thesis
proof (induct parent_opt)
case None
then have "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child"
using assms(1) get_root_node_no_parent node_ptr by blast
then show ?case
using \<open>type_wf h\<close> \<open>known_ptrs h\<close> node_ptr step(2) assms(4) assms(1)
by (metis (no_types) bind_pure_returns_result_I2 bind_returns_result_E2
get_dom_component_def get_root_node_pure is_OK_returns_result_I returns_result_eq
to_tree_order_same_root)
next
case (Some parent_ptr)
then have "h \<turnstile> get_dom_component parent_ptr \<rightarrow>\<^sub>r c"
using step get_dom_component_parent_inside assms node_ptr by blast
then show ?case
using Some node_ptr
apply(auto simp add: get_dom_component_def elim!: bind_returns_result_E2
del: bind_pure_returns_result_I intro!: bind_pure_returns_result_I)[1]
using get_root_node_parent_same by blast
qed
next
case False
then have "child |\<in>| object_ptr_kinds h"
using assms(1) assms(4) step(2)
by (metis (no_types, lifting) assms(2) assms(3) bind_returns_result_E2 get_root_node_pure
get_dom_component_def to_tree_order_ptrs_in_heap)
then have "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child"
using assms(1) False get_root_node_not_node_same by blast
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) step.prems
by (metis (no_types) False \<open>child |\<in>| object_ptr_kinds h\<close> bind_pure_returns_result_I2
bind_returns_result_E2 get_dom_component_def get_root_node_ok get_root_node_pure returns_result_eq
to_tree_order_node_ptrs)
qed
qed
lemma get_dom_component_to_tree_order_subset:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
shows "set nodes \<subseteq> set c"
using assms
apply(auto simp add: get_dom_component_def elim!: bind_returns_result_E2)[1]
by (meson to_tree_order_subset assms(5) contra_subsetD get_dom_component_ptr)
lemma get_dom_component_to_tree_order:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to"
assumes "ptr \<in> set to"
shows "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
by (metis (no_types, opaque_lifting) assms(1) assms(2) assms(3) assms(4) assms(5) assms(6)
get_dom_component_ok get_dom_component_subset get_dom_component_to_tree_order_subset
is_OK_returns_result_E local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap
select_result_I2 subsetCE)
lemma get_dom_component_root_node_same:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
assumes "x \<in> set c"
shows "h \<turnstile> get_root_node x \<rightarrow>\<^sub>r root_ptr"
proof(insert assms(1) assms(6), induct x rule: heap_wellformed_induct_rev )
case (step child)
then show ?case
proof (cases "is_node_ptr_kind child")
case True
obtain node_ptr where
node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = child"
using \<open>is_node_ptr_kind child\<close> node_ptr_casts_commute3 by blast
have "child |\<in>| object_ptr_kinds h"
using to_tree_order_ptrs_in_heap assms(1) assms(2) assms(3) assms(4) step(2)
unfolding get_dom_component_def
by (meson bind_returns_result_E2 get_root_node_pure)
with node_ptr have "node_ptr |\<in>| node_ptr_kinds h"
by auto
then obtain parent_opt where
parent: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt"
using get_parent_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by fast
then show ?thesis
proof (induct parent_opt)
case None
then have "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child"
using assms(1) get_root_node_no_parent node_ptr by blast
then show ?case
using \<open>type_wf h\<close> \<open>known_ptrs h\<close> node_ptr step(2) assms(4) assms(1) assms(5)
by (metis (no_types) \<open>child |\<in>| object_ptr_kinds h\<close> bind_pure_returns_result_I
get_dom_component_def get_dom_component_ptr get_dom_component_subset get_root_node_pure
is_OK_returns_result_E returns_result_eq to_tree_order_ok to_tree_order_same_root)
next
case (Some parent_ptr)
then have "h \<turnstile> get_dom_component parent_ptr \<rightarrow>\<^sub>r c"
using step get_dom_component_parent_inside assms node_ptr
by (meson get_dom_component_subset)
then show ?case
using Some node_ptr
apply(auto simp add: get_dom_component_def elim!: bind_returns_result_E2)[1]
using get_root_node_parent_same
using \<open>h \<turnstile> get_dom_component parent_ptr \<rightarrow>\<^sub>r c\<close> assms(1) assms(2) assms(3)
get_dom_component_ptr step.hyps by blast
qed
next
case False
then have "child |\<in>| object_ptr_kinds h"
using assms(1) assms(4) step(2)
by (metis (no_types, lifting) assms(2) assms(3) bind_returns_result_E2 get_root_node_pure
get_dom_component_def to_tree_order_ptrs_in_heap)
then have "h \<turnstile> get_root_node child \<rightarrow>\<^sub>r child"
using assms(1) False get_root_node_not_node_same by auto
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) step.prems assms(5)
by (metis (no_types, opaque_lifting) bind_returns_result_E2 get_dom_component_def
get_root_node_pure returns_result_eq to_tree_order_same_root)
qed
qed
lemma get_dom_component_no_overlap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c'"
shows "set c \<inter> set c' = {} \<or> c = c'"
proof (rule ccontr, auto)
fix x
assume 1: "c \<noteq> c'" and 2: "x \<in> set c" and 3: "x \<in> set c'"
obtain root_ptr where root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
using assms(4) unfolding get_dom_component_def
by (meson bind_is_OK_E is_OK_returns_result_I)
moreover obtain root_ptr' where root_ptr': "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr'"
using assms(5) unfolding get_dom_component_def
by (meson bind_is_OK_E is_OK_returns_result_I)
ultimately have "root_ptr \<noteq> root_ptr'"
using 1 assms
unfolding get_dom_component_def
by (meson bind_returns_result_E3 get_root_node_pure returns_result_eq)
moreover have "h \<turnstile> get_root_node x \<rightarrow>\<^sub>r root_ptr"
using 2 root_ptr get_dom_component_root_node_same assms by blast
moreover have "h \<turnstile> get_root_node x \<rightarrow>\<^sub>r root_ptr'"
using 3 root_ptr' get_dom_component_root_node_same assms by blast
ultimately show False
using select_result_I2 by force
qed
lemma get_dom_component_separates_tree_order:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
assumes "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c'"
assumes "ptr' \<notin> set c"
shows "set to \<inter> set c' = {}"
proof -
have "c \<noteq> c'"
using assms get_dom_component_ptr by blast
then have "set c \<inter> set c' = {}"
using assms get_dom_component_no_overlap by blast
moreover have "set to \<subseteq> set c"
using assms get_dom_component_to_tree_order_subset by blast
ultimately show ?thesis
by blast
qed
lemma get_dom_component_separates_tree_order_general:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> to_tree_order ptr'' \<rightarrow>\<^sub>r to''"
assumes "ptr'' \<in> set c"
assumes "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c'"
assumes "ptr' \<notin> set c"
shows "set to'' \<inter> set c' = {}"
proof -
obtain root_ptr where root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
using assms(4)
by (metis bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
then have c: "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using assms(4) unfolding get_dom_component_def
by (simp add: bind_returns_result_E3)
with root_ptr show ?thesis
using assms get_dom_component_separates_tree_order get_dom_component_subset
by meson
qed
end
interpretation i_get_dom_component?: l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name
by(auto simp add: l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_dom_component_def is_strongly_dom_component_safe_def is_weakly_dom_component_safe_def instances)
declare l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_child\_nodes\<close>
locale l_get_dom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "cast child \<in> set c \<longleftrightarrow> ptr' \<in> set c"
proof
assume 1: "cast child \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
have "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using assms(1) assms(2) assms(3) assms(5) assms(6) local.child_parent_dual
local.get_root_node_parent_same by blast
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using "1" assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) local.child_parent_dual
local.get_dom_component_parent_inside local.get_dom_component_subset by blast
then show "ptr' \<in> set c"
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
next
assume 1: "ptr' \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root_ptr"
using assms(1) assms(2) assms(3) assms(5) assms(6) local.child_parent_dual
local.get_root_node_parent_same by blast
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using "1" assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) local.child_parent_dual
local.get_dom_component_parent_inside local.get_dom_component_subset by blast
then show "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child \<in> set c"
by (smt (verit) \<open>h \<turnstile> get_root_node (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r root_ptr\<close> assms(1) assms(2) assms(3)
assms(5) assms(6) disjoint_iff_not_equal is_OK_returns_result_E is_OK_returns_result_I
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_dom_component_no_overlap local.child_parent_dual local.get_dom_component_ok
local.get_dom_component_parent_inside local.get_dom_component_ptr local.get_root_node_ptr_in_heap
local.l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms)
qed
lemma get_child_nodes_get_dom_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
shows "cast ` set children \<subseteq> set c"
using assms get_child_nodes_is_strongly_dom_component_safe
using local.get_dom_component_ptr by auto
lemma
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {ptr} (cast ` set children) h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_child_nodes_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def)[1]
- by (smt (verit) IntI fmember.rep_eq get_child_nodes_is_strongly_dom_component_safe
+ by (smt (verit) IntI fmember_iff_member_fset get_child_nodes_is_strongly_dom_component_safe
is_OK_returns_result_I local.get_child_nodes_ptr_in_heap local.get_dom_component_impl
local.get_dom_component_ok local.get_dom_component_ptr returns_result_select_result)
qed
end
interpretation i_get_dom_component_get_child_nodes?: l_get_dom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_parent\<close>
locale l_get_dom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_parent_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_parent ptr' \<rightarrow>\<^sub>r Some parent"
shows "parent \<in> set c \<longleftrightarrow> cast ptr' \<in> set c"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) is_OK_returns_result_E
l_to_tree_order_wf.to_tree_order_parent local.get_dom_component_parent_inside
local.get_dom_component_subset local.get_dom_component_to_tree_order_subset
local.get_parent_parent_in_heap local.l_to_tree_order_wf_axioms local.to_tree_order_ok
local.to_tree_order_ptr_in_result subsetCE)
lemma get_parent_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some parent"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {cast node_ptr} {parent} h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_parent_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def)[1]
by (metis IntI finite_set_in local.get_dom_component_impl local.get_dom_component_ok
local.get_dom_component_parent_inside local.get_dom_component_ptr local.get_parent_parent_in_heap
local.known_ptrs_known_ptr local.parent_child_rel_child_in_heap local.parent_child_rel_parent
returns_result_select_result)
qed
end
interpretation i_get_dom_component_get_parent?: l_get_dom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_root\_node\<close>
locale l_get_dom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_root_node_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root"
shows "root \<in> set c \<longleftrightarrow> ptr' \<in> set c"
proof
assume 1: "root \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
have "h \<turnstile> get_root_node root \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
moreover have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
by (metis (no_types, lifting) calculation assms(1) assms(2) assms(3) assms(5)
is_OK_returns_result_E local.get_root_node_root_in_heap local.to_tree_order_ok
local.to_tree_order_ptr_in_result local.to_tree_order_same_root select_result_I2)
ultimately have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
apply(auto simp add: get_dom_component_def)[1]
using assms(4) bind_returns_result_E3 local.get_dom_component_def root_ptr by fastforce
then show "ptr' \<in> set c"
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
next
assume 1: "ptr' \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node root \<rightarrow>\<^sub>r root_ptr"
by (metis assms(1) assms(2) assms(3) assms(5) is_OK_returns_result_E
local.get_root_node_root_in_heap local.to_tree_order_ok local.to_tree_order_ptr_in_result
local.to_tree_order_same_root returns_result_eq)
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using "1" assms(1) assms(2) assms(3) assms(4) local.get_dom_component_subset by blast
then show "root \<in> set c"
using assms(5) bind_returns_result_E3 local.get_dom_component_def local.to_tree_order_ptr_in_result
by fastforce
qed
lemma get_root_node_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {ptr} {root} h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_root_node_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def)[1]
by (metis (no_types, lifting) IntI finite_set_in get_root_node_is_strongly_dom_component_safe_step
is_OK_returns_result_I local.get_dom_component_impl local.get_dom_component_ok
local.get_dom_component_ptr local.get_root_node_ptr_in_heap returns_result_select_result)
qed
end
interpretation i_get_dom_component_get_root_node?: l_get_dom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_element\_by\_id\<close>
locale l_get_dom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_element_by_id_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_element_by_id ptr' idd \<rightarrow>\<^sub>r Some result"
shows "cast result \<in> set c \<longleftrightarrow> ptr' \<in> set c"
proof
assume 1: "cast result \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
then have "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c\<close>
by (simp add: get_dom_component_def bind_returns_result_E3)
obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
using \<open>h \<turnstile> get_element_by_id ptr' idd \<rightarrow>\<^sub>r Some result\<close>
apply(simp add: get_element_by_id_def first_in_tree_order_def)
by (meson bind_is_OK_E is_OK_returns_result_I)
then have "cast result \<in> set to'"
using \<open>h \<turnstile> get_element_by_id ptr' idd \<rightarrow>\<^sub>r Some result\<close> get_element_by_id_result_in_tree_order
by blast
have "h \<turnstile> get_root_node (cast result) \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using \<open>cast result \<in> set to'\<close> \<open>h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'\<close>
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_ptr get_dom_component_root_node_same
get_dom_component_subset get_dom_component_to_tree_order
by blast
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c\<close>
using get_dom_component_def by auto
then show "ptr' \<in> set c"
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
next
assume "ptr' \<in> set c"
moreover obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
by (meson assms(1) assms(2) assms(3) assms(4) calculation get_dom_component_ptr_in_heap
get_dom_component_subset is_OK_returns_result_E is_OK_returns_result_I to_tree_order_ok)
ultimately have "set to' \<subseteq> set c"
using assms(1) assms(2) assms(3) assms(4) get_dom_component_subset
get_dom_component_to_tree_order_subset
by blast
moreover have "cast result \<in> set to'"
using assms(5) get_element_by_id_result_in_tree_order to' by blast
ultimately show "cast result \<in> set c"
by blast
qed
lemma get_element_by_id_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_element_by_id ptr idd \<rightarrow>\<^sub>r Some result"
assumes "h \<turnstile> get_element_by_id ptr idd \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {ptr} {cast result} h h'"
proof -
have "h = h'"
using assms(5)
by(auto simp add: preserved_def get_element_by_id_def first_in_tree_order_def
elim!: bind_returns_heap_E2 intro!: map_filter_M_pure bind_pure_I
split: option.splits list.splits)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_element_by_id_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast result \<in> set to"
using assms(4) local.get_element_by_id_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_dom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_dom_component_impl
local.get_dom_component_ok by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def get_element_by_id_def
first_in_tree_order_def elim!: bind_returns_result_E2 intro!: map_filter_M_pure bind_pure_I
split: option.splits list.splits)[1]
by (metis (no_types, lifting) Int_iff \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(4) finite_set_in
get_element_by_id_is_strongly_dom_component_safe_step local.get_dom_component_impl
local.get_dom_component_ptr select_result_I2)
qed
end
interpretation i_get_dom_component_get_element_by_id?: l_get_dom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_elements\_by\_class\_name\<close>
locale l_get_dom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_elements_by_class_name_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_elements_by_class_name ptr' idd \<rightarrow>\<^sub>r results"
assumes "result \<in> set results"
shows "cast result \<in> set c \<longleftrightarrow> ptr' \<in> set c"
proof
assume 1: "cast result \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
then have "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c\<close>
by (simp add: get_dom_component_def bind_returns_result_E3)
obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
using assms(5)
apply(simp add: get_elements_by_class_name_def first_in_tree_order_def)
by (meson bind_is_OK_E is_OK_returns_result_I)
then have "cast result \<in> set to'"
using assms get_elements_by_class_name_result_in_tree_order by blast
have "h \<turnstile> get_root_node (cast result) \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using \<open>cast result \<in> set to'\<close> \<open>h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'\<close>
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_ptr get_dom_component_root_node_same
get_dom_component_subset get_dom_component_to_tree_order
by blast
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c\<close>
using get_dom_component_def by auto
then show "ptr' \<in> set c"
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
next
assume "ptr' \<in> set c"
moreover obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
by (meson assms(1) assms(2) assms(3) assms(4) calculation get_dom_component_ptr_in_heap
get_dom_component_subset is_OK_returns_result_E is_OK_returns_result_I to_tree_order_ok)
ultimately have "set to' \<subseteq> set c"
using assms(1) assms(2) assms(3) assms(4) get_dom_component_subset
get_dom_component_to_tree_order_subset
by blast
moreover have "cast result \<in> set to'"
using assms get_elements_by_class_name_result_in_tree_order to' by blast
ultimately show "cast result \<in> set c"
by blast
qed
lemma get_elements_by_class_name_pure [simp]:
"pure (get_elements_by_class_name ptr name) h"
by(auto simp add: get_elements_by_class_name_def intro!: bind_pure_I map_filter_M_pure
split: option.splits)
lemma get_elements_by_class_name_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_elements_by_class_name ptr name \<rightarrow>\<^sub>r results"
assumes "h \<turnstile> get_elements_by_class_name ptr name \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {ptr} (cast ` set results) h h'"
proof -
have "h = h'"
using assms(5)
by (meson get_elements_by_class_name_pure pure_returns_heap_eq)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_elements_by_class_name_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast ` set results \<subseteq> set to"
using assms(4) local.get_elements_by_class_name_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_dom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_dom_component_impl
local.get_dom_component_ok by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def
get_elements_by_class_name_def first_in_tree_order_def elim!: bind_returns_result_E2
intro!: map_filter_M_pure bind_pure_I split: option.splits list.splits)[1]
by (metis (no_types, lifting) Int_iff \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(4) finite_set_in
get_elements_by_class_name_is_strongly_dom_component_safe_step local.get_dom_component_impl
local.get_dom_component_ptr select_result_I2)
qed
end
interpretation i_get_dom_component_get_elements_by_class_name?:
l_get_dom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_elements\_by\_tag\_name\<close>
locale l_get_dom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_elements_by_tag_name_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
assumes "h \<turnstile> get_elements_by_tag_name ptr' idd \<rightarrow>\<^sub>r results"
assumes "result \<in> set results"
shows "cast result \<in> set c \<longleftrightarrow> ptr' \<in> set c"
proof
assume 1: "cast result \<in> set c"
obtain root_ptr where
root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
by (metis assms(4) bind_is_OK_E get_dom_component_def is_OK_returns_result_I)
then have "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c\<close>
by (simp add: get_dom_component_def bind_returns_result_E3)
obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
using assms(5)
apply(simp add: get_elements_by_tag_name_def first_in_tree_order_def)
by (meson bind_is_OK_E is_OK_returns_result_I)
then have "cast result \<in> set to'"
using assms get_elements_by_tag_name_result_in_tree_order by blast
have "h \<turnstile> get_root_node (cast result) \<rightarrow>\<^sub>r root_ptr"
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_root_node_same root_ptr
by blast
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root_ptr"
using \<open>cast result \<in> set to'\<close> \<open>h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'\<close>
using "1" assms(1) assms(2) assms(3) assms(4) get_dom_component_ptr
get_dom_component_root_node_same get_dom_component_subset get_dom_component_to_tree_order
by blast
then have "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c"
using \<open>h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c\<close>
using get_dom_component_def by auto
then show "ptr' \<in> set c"
using assms(1) assms(2) assms(3) get_dom_component_ptr by blast
next
assume "ptr' \<in> set c"
moreover obtain to' where to': "h \<turnstile> to_tree_order ptr' \<rightarrow>\<^sub>r to'"
by (meson assms(1) assms(2) assms(3) assms(4) calculation get_dom_component_ptr_in_heap
get_dom_component_subset is_OK_returns_result_E is_OK_returns_result_I to_tree_order_ok)
ultimately have "set to' \<subseteq> set c"
using assms(1) assms(2) assms(3) assms(4) get_dom_component_subset
get_dom_component_to_tree_order_subset
by blast
moreover have "cast result \<in> set to'"
using assms get_elements_by_tag_name_result_in_tree_order to' by blast
ultimately show "cast result \<in> set c"
by blast
qed
lemma get_elements_by_tag_name_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_elements_by_tag_name ptr name \<rightarrow>\<^sub>r results"
assumes "h \<turnstile> get_elements_by_tag_name ptr name \<rightarrow>\<^sub>h h'"
shows "is_strongly_dom_component_safe {ptr} (cast ` set results) h h'"
proof -
have "h = h'"
using assms(5)
by (meson get_elements_by_tag_name_pure pure_returns_heap_eq)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_elements_by_tag_name_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast ` set results \<subseteq> set to"
using assms(4) local.get_elements_by_tag_name_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_dom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_dom_component_impl
local.get_dom_component_ok by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_dom_component_safe_def Let_def preserved_def
get_elements_by_class_name_def first_in_tree_order_def elim!: bind_returns_result_E2
intro!: map_filter_M_pure bind_pure_I split: option.splits list.splits)[1]
by (metis (no_types, lifting) IntI \<open>ptr |\<in>| object_ptr_kinds h\<close> finite_set_in
get_elements_by_tag_name_is_strongly_dom_component_safe_step local.get_dom_component_impl
local.get_dom_component_ptr select_result_I2)
qed
end
interpretation i_get_dom_component_get_elements_by_tag_name?:
l_get_dom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_dom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>remove\_child\<close>
lemma remove_child_unsafe: "\<not>(\<forall>(h
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) h' ptr child. heap_is_wellformed h \<longrightarrow> type_wf h \<longrightarrow> known_ptrs h \<longrightarrow>
h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h' \<longrightarrow> is_weakly_dom_component_safe {ptr, cast child} {} h h')"
proof -
obtain h document_ptr e1 e2 where h: "Inr ((document_ptr, e1, e2), h) = (Heap (fmempty)
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) \<turnstile> (do {
document_ptr \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
return (document_ptr, e1, e2)
})"
by(code_simp, auto simp add: equal_eq List.member_def)+
then obtain h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
h': "h \<turnstile> remove_child (cast e1) (cast e2) \<rightarrow>\<^sub>h h'" and
"\<not>(is_weakly_dom_component_safe {cast e1, cast e2} {} h h')"
apply(code_simp)
apply(clarify)
by(code_simp, auto simp add: equal_eq List.member_def)+
then show ?thesis
by auto
qed
subsubsection \<open>adopt\_node\<close>
lemma adopt_node_unsafe: "\<not>(\<forall>(h
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) h' document_ptr child. heap_is_wellformed h \<longrightarrow> type_wf h \<longrightarrow> known_ptrs h \<longrightarrow> h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h' \<longrightarrow> is_weakly_dom_component_safe {cast document_ptr, cast child} {} h h')"
proof -
obtain h document_ptr document_ptr2 e1 where h: "Inr ((document_ptr, document_ptr2, e1), h) = (Heap (fmempty)
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) \<turnstile> (do {
document_ptr \<leftarrow> create_document;
document_ptr2 \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
adopt_node document_ptr2 (cast e1);
return (document_ptr, document_ptr2, e1)
})"
by(code_simp, auto simp add: equal_eq List.member_def)+
then obtain h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
h': "h \<turnstile> adopt_node document_ptr (cast e1) \<rightarrow>\<^sub>h h'" and
"\<not>(is_weakly_dom_component_safe {cast document_ptr, cast e1} {} h h')"
apply(code_simp)
apply(clarify)
by(code_simp, auto simp add: equal_eq List.member_def)+
then show ?thesis
by auto
qed
subsubsection \<open>create\_element\<close>
lemma create_element_not_strongly_dom_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap" and
h' and document_ptr and new_element_ptr and tag where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr \<rightarrow>\<^sub>h h'" and
"\<not> is_strongly_dom_component_safe {cast document_ptr} {cast new_element_ptr} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap"
let ?P = "create_document"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?document_ptr = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and document_ptr="?document_ptr"])
by code_simp+
qed
locale l_get_dom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name +
l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf create_element known_ptr +
l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_tag_name set_tag_name_locs +
l_new_element_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs +
l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr
get_child_nodes get_child_nodes_locs +
l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs heap_is_wellformed parent_child_rel set_tag_name
set_tag_name_locs
set_disconnected_nodes set_disconnected_nodes_locs create_element
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_dom_component :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and is_strongly_dom_component_safe :: "(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and is_weakly_dom_component_safe :: "(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_ancestors :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_element_by_id :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and get_elements_by_class_name :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and get_elements_by_tag_name :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
begin
lemma create_element_is_weakly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<noteq> cast |h \<turnstile> create_element document_ptr tag|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile>set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])
have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
using new_element_ptr h2 h3 disc_nodes h'
apply(auto simp add: create_element_def intro!: bind_returns_result_I
bind_pure_returns_result_I[OF get_disconnected_nodes_pure])[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "preserved (get_M ptr getter) h h2"
using h2 new_element_ptr
apply(rule new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t)
using new_element_ptr assms(6) \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close>
by simp
have "preserved (get_M ptr getter) h2 h3"
using set_tag_name_writes h3
apply(rule reads_writes_preserved2)
apply(auto simp add: set_tag_name_locs_impl a_set_tag_name_locs_def all_args_def)[1]
by (metis (no_types, lifting) \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> assms(6)
get_M_Element_preserved8 select_result_I2)
have "document_ptr |\<in>| document_ptr_kinds h"
using create_element_document_in_heap
using assms(4)
by blast
then
have "ptr \<noteq> (cast document_ptr)"
using assms(5) assms(1) assms(2) assms(3) local.get_dom_component_ok local.get_dom_component_ptr
by auto
have "preserved (get_M ptr getter) h3 h'"
using set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved2)
apply(auto simp add: set_disconnected_nodes_locs_def all_args_def)[1]
by (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
show ?thesis
using \<open>preserved (get_M ptr getter) h h2\<close> \<open>preserved (get_M ptr getter) h2 h3\<close>
\<open>preserved (get_M ptr getter) h3 h'\<close>
by(auto simp add: preserved_def)
qed
lemma create_element_is_weakly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
shows "is_weakly_dom_component_safe {cast document_ptr} {cast result} h h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
have "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "a_acyclic_heap h'"
by (simp add: acyclic_heap_def)
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def)[1]
apply (metis \<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms
funion_iff local.get_child_nodes_ok local.known_ptrs_known_ptr local.parent_child_rel_child_in_heap
local.parent_child_rel_child_nodes2 node_ptr_kinds_commutes node_ptr_kinds_eq_h
returns_result_select_result)
by (metis assms disconnected_nodes_eq2_h document_ptr_kinds_eq_h funion_iff
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h
returns_result_select_result)
then have "a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
local.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "a_all_ptrs_in_heap h'"
using assms(1) assms(2) assms(3) assms(5) local.create_element_preserves_wellformedness(1) local.heap_is_wellformed_def
by blast
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_element_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M a_all_ptrs_in_heap_def assms fset_mp
fset_of_list_elem get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_element_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_element_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_element_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_element_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms empty_iff local.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open>local.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
local.distinct_lists_no_parent local.get_disconnected_nodes_ok returns_result_select_result)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)
then have "a_distinct_lists h'"
proof(auto simp add: a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3
intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set disc_nodes_h3\<close>
\<open>a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
apply(-)
apply(cases "x = document_ptr")
apply (metis (mono_tags, lifting) Int_Collect Int_iff \<open>type_wf h'\<close> assms(1) assms(2) assms(3)
assms(5) bot_set_def document_ptr_kinds_eq_h3 empty_Collect_eq
l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_disconnected_nodes_ok
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_one_disc_parent
local.create_element_preserves_wellformedness(1)
local.l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
local.l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms returns_result_select_result)
by (metis (no_types, opaque_lifting) \<open>type_wf h'\<close> assms(1) assms(2) assms(3) assms(5)
disjoint_iff document_ptr_kinds_eq_h3 local.create_element_preserves_wellformedness(1)
local.get_disconnected_nodes_ok local.heap_is_wellformed_one_disc_parent
returns_result_select_result)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply -
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3
\<Longrightarrow> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open>a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open>a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: a_owner_document_valid_def)[1]
apply(auto simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )[1]
apply(auto simp add: object_ptr_kinds_eq_h2)[1]
apply(auto simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )[1]
apply(auto simp add: document_ptr_kinds_eq_h2)[1]
apply(auto simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )[1]
apply(auto simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )[1]
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by(metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> children_eq2_h
children_eq2_h2 children_eq2_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
node_ptr_kinds_commutes select_result_I2)
have "parent_child_rel h = parent_child_rel h'"
proof -
have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally show ?thesis
by simp
qed
have root: "h \<turnstile> get_root_node (cast document_ptr) \<rightarrow>\<^sub>r cast document_ptr"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> local.get_root_node_not_node_same)
then
have root': "h' \<turnstile> get_root_node (cast document_ptr) \<rightarrow>\<^sub>r cast document_ptr"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h
local.get_root_node_not_node_same object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3)
have "heap_is_wellformed h'" and "known_ptrs h'"
using create_element_preserves_wellformedness assms
by blast+
have "cast result |\<notin>| object_ptr_kinds h"
using \<open>cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
by (metis (full_types) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> assms(4) returns_result_eq)
obtain to where to: "h \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to"
by (meson \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3)
document_ptr_kinds_commutes is_OK_returns_result_E local.to_tree_order_ok)
then
have "h \<turnstile> a_get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r to"
using root
by(auto simp add: a_get_dom_component_def)
moreover
obtain to' where to': "h' \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to'"
by (meson \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> is_OK_returns_result_E
local.get_root_node_root_in_heap local.to_tree_order_ok root')
then
have "h' \<turnstile> a_get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r to'"
using root'
by(auto simp add: a_get_dom_component_def)
moreover
have "\<And>child. child \<in> set to \<longleftrightarrow> child \<in> set to'"
by (metis \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close> \<open>parent_child_rel h = parent_child_rel h'\<close>
\<open>type_wf h'\<close> assms(1) assms(2) assms(3) local.to_tree_order_parent_child_rel to to')
ultimately
have "set |h \<turnstile> local.a_get_dom_component (cast document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_dom_component (cast document_ptr)|\<^sub>r"
by(auto simp add: a_get_dom_component_def)
show ?thesis
apply(auto simp add: is_weakly_dom_component_safe_def Let_def)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> assms(2) assms(3)
children_eq_h local.get_child_nodes_ok local.get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 returns_result_select_result
apply (metis is_OK_returns_result_I)
apply (metis \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> assms(4)
element_ptr_kinds_commutes h2 new_element_ptr new_element_ptr_in_heap node_ptr_kinds_eq_h2
node_ptr_kinds_eq_h3 returns_result_eq returns_result_heap_def)
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r result |\<notin>| object_ptr_kinds h\<close> element_ptr_kinds_commutes
node_ptr_kinds_commutes apply blast
using assms(1) assms(2) assms(3) \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'\<close>
apply(rule create_element_is_weakly_dom_component_safe_step)
apply (simp add: local.get_dom_component_impl)
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close>
by auto
qed
end
interpretation i_get_dom_component_create_element?: l_get_dom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr heap_is_wellformed parent_child_rel type_wf known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_tag_name
set_tag_name_locs create_element
by(auto simp add: l_get_dom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_character\_data\<close>
lemma create_character_data_not_strongly_dom_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder},
'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap" and
h' and document_ptr and create_character_datanew_character_data_ptr and tag where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> create_character_data document_ptr tag \<rightarrow>\<^sub>r create_character_datanew_character_data_ptr \<rightarrow>\<^sub>h h'" and
"\<not> is_strongly_dom_component_safe {cast document_ptr} {cast create_character_datanew_character_data_ptr} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap"
let ?P = "create_document"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?document_ptr = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and document_ptr="?document_ptr"])
by code_simp+
qed
locale l_get_dom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_disconnected_nodes get_disconnected_nodes_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name +
l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_val set_val_locs type_wf create_character_data known_ptr +
l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_val set_val_locs +
l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs heap_is_wellformed parent_child_rel set_val
set_val_locs set_disconnected_nodes set_disconnected_nodes_locs
create_character_data known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_dom_component :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and is_strongly_dom_component_safe :: "(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and is_weakly_dom_component_safe :: "(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_ancestors :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_element_by_id :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and get_elements_by_class_name :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and get_elements_by_tag_name :: "(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
begin
lemma create_character_data_is_weakly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<noteq> cast |h \<turnstile> create_character_data document_ptr text|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: create_character_data_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])
have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
using new_character_data_ptr h2 h3 disc_nodes h'
apply(auto simp add: create_character_data_def intro!: bind_returns_result_I
bind_pure_returns_result_I[OF get_disconnected_nodes_pure])[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "preserved (get_M ptr getter) h h2"
using h2 new_character_data_ptr
apply(rule new_character_data_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t)
using new_character_data_ptr assms(6)
\<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
by simp
have "preserved (get_M ptr getter) h2 h3"
using set_val_writes h3
apply(rule reads_writes_preserved2)
apply(auto simp add: set_val_locs_impl a_set_val_locs_def all_args_def)[1]
by (metis (mono_tags) CharacterData_simp11
\<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close> assms(4) assms(6)
is_OK_returns_heap_I is_OK_returns_result_E returns_result_eq select_result_I2)
have "document_ptr |\<in>| document_ptr_kinds h"
using create_character_data_document_in_heap
using assms(4)
by blast
then
have "ptr \<noteq> (cast document_ptr)"
using assms(5) assms(1) assms(2) assms(3) local.get_dom_component_ok local.get_dom_component_ptr
by auto
have "preserved (get_M ptr getter) h3 h'"
using set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved2)
apply(auto simp add: set_disconnected_nodes_locs_def all_args_def)[1]
by (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
show ?thesis
using \<open>preserved (get_M ptr getter) h h2\<close> \<open>preserved (get_M ptr getter) h2 h3\<close>
\<open>preserved (get_M ptr getter) h3 h'\<close>
by(auto simp add: preserved_def)
qed
lemma create_character_data_is_weakly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
shows "is_weakly_dom_component_safe {cast document_ptr} {cast result} h h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then
have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "parent_child_rel h = parent_child_rel h'"
proof -
have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally show ?thesis
by simp
qed
have root: "h \<turnstile> get_root_node (cast document_ptr) \<rightarrow>\<^sub>r cast document_ptr"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> local.get_root_node_not_node_same)
then
have root': "h' \<turnstile> get_root_node (cast document_ptr) \<rightarrow>\<^sub>r cast document_ptr"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h
local.get_root_node_not_node_same object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3)
have "heap_is_wellformed h'" and "known_ptrs h'"
using create_character_data_preserves_wellformedness assms
by blast+
have "cast result |\<notin>| object_ptr_kinds h"
using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
by (metis (full_types) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close> assms(4) returns_result_eq)
obtain to where to: "h \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to"
by (meson \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3)
document_ptr_kinds_commutes is_OK_returns_result_E local.to_tree_order_ok)
then
have "h \<turnstile> a_get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r to"
using root
by(auto simp add: a_get_dom_component_def)
moreover
obtain to' where to': "h' \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to'"
by (meson \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> is_OK_returns_result_E
local.get_root_node_root_in_heap local.to_tree_order_ok root')
then
have "h' \<turnstile> a_get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r to'"
using root'
by(auto simp add: a_get_dom_component_def)
moreover
have "\<And>child. child \<in> set to \<longleftrightarrow> child \<in> set to'"
by (metis \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close> \<open>parent_child_rel h = parent_child_rel h'\<close>
\<open>type_wf h'\<close> assms(1) assms(2) assms(3) local.to_tree_order_parent_child_rel to to')
ultimately
have "set |h \<turnstile> local.a_get_dom_component (cast document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_dom_component (cast document_ptr)|\<^sub>r"
by(auto simp add: a_get_dom_component_def)
show ?thesis
apply(auto simp add: is_weakly_dom_component_safe_def Let_def)[1]
using assms(2) assms(3) children_eq_h local.get_child_nodes_ok
local.get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr object_ptr_kinds_eq_h2
object_ptr_kinds_eq_h3 returns_result_select_result
apply (metis \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
is_OK_returns_result_I)
apply (metis \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close> assms(4)
character_data_ptr_kinds_commutes h2 new_character_data_ptr new_character_data_ptr_in_heap
node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3 returns_result_eq)
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
\<open>new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r\<close> assms(4) returns_result_eq
apply fastforce
using assms(2) assms(3) children_eq_h local.get_child_nodes_ok local.get_child_nodes_ptr_in_heap
local.known_ptrs_known_ptr object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 returns_result_select_result
apply (smt (verit, best) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h
\<turnstile> object_ptr_kinds_M|\<^sub>r\<close> \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r
new_character_data_ptr\<close> assms(1) assms(5)
create_character_data_is_weakly_dom_component_safe_step local.a_get_dom_component_def
local.get_dom_component_def select_result_I2)
done
qed
end
interpretation i_get_dom_component_create_character_data?: l_get_dom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr heap_is_wellformed parent_child_rel type_wf known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name set_val set_val_locs
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
create_character_data
by(auto simp add: l_get_dom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_document\<close>
lemma create_document_unsafe: "\<not>(\<forall>(h
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) h' new_document_ptr. heap_is_wellformed h \<longrightarrow> type_wf h \<longrightarrow> known_ptrs h \<longrightarrow>
h \<turnstile> create_document \<rightarrow>\<^sub>r new_document_ptr \<longrightarrow> h \<turnstile> create_document \<rightarrow>\<^sub>h h' \<longrightarrow>
is_strongly_dom_component_safe {} {cast new_document_ptr} h h')"
proof -
obtain h document_ptr where h: "Inr (document_ptr, h) = (Heap (fmempty)
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) \<turnstile> (do {
document_ptr \<leftarrow> create_document;
return (document_ptr)
})"
by(code_simp, auto simp add: equal_eq List.member_def)+
then obtain h' new_document_ptr where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
h': "h \<turnstile> create_document \<rightarrow>\<^sub>r new_document_ptr" and
h': "h \<turnstile> create_document \<rightarrow>\<^sub>h h'" and
"\<not>(is_strongly_dom_component_safe {} {cast new_document_ptr} h h')"
by(code_simp, auto simp add: equal_eq List.member_def)+
then show ?thesis
by blast
qed
locale l_get_dom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name +
l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M create_document
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_dom_component :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and is_strongly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and is_weakly_dom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_ancestors :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_element_by_id ::
"(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and get_elements_by_class_name ::
"(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and get_elements_by_tag_name ::
"(_) object_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr list) prog"
and create_document :: "((_) heap, exception, (_) document_ptr) prog"
begin
lemma create_document_is_weakly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
assumes "ptr \<noteq> cast |h \<turnstile> create_document|\<^sub>r"
shows "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
using assms
apply(auto simp add: create_document_def)[1]
by (metis assms(4) assms(5) is_OK_returns_heap_I local.create_document_def new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
select_result_I)
lemma create_document_is_weakly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_document \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
shows "is_weakly_dom_component_safe {} {cast result} h h'"
proof -
have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast result|}"
using assms(4) assms(5) local.create_document_def new_document_new_ptr by auto
moreover have "result |\<notin>| document_ptr_kinds h"
using assms(4) assms(5) local.create_document_def new_document_ptr_not_in_heap by auto
ultimately show ?thesis
using assms
apply(auto simp add: is_weakly_dom_component_safe_def Let_def local.create_document_def
new_document_ptr_not_in_heap)[1]
by (metis \<open>result |\<notin>| document_ptr_kinds h\<close> document_ptr_kinds_commutes new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t)
qed
end
interpretation i_get_dom_component_create_document?: l_get_dom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr heap_is_wellformed parent_child_rel type_wf known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name create_document
by(auto simp add: l_get_dom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>insert\_before\<close>
lemma insert_before_unsafe: "\<not>(\<forall>(h
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) h' ptr child. heap_is_wellformed h \<longrightarrow> type_wf h \<longrightarrow> known_ptrs h \<longrightarrow>
h \<turnstile> insert_before ptr child None \<rightarrow>\<^sub>h h' \<longrightarrow> is_weakly_dom_component_safe {ptr, cast child} {} h h')"
proof -
obtain h document_ptr e1 e2 where h: "Inr ((document_ptr, e1, e2), h) = (Heap (fmempty)
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) \<turnstile> (do {
document_ptr \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
e2 \<leftarrow> create_element document_ptr ''div'';
return (document_ptr, e1, e2)
})"
by(code_simp, auto simp add: equal_eq List.member_def)+
then obtain h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
h': "h \<turnstile> insert_before (cast e1) (cast e2) None \<rightarrow>\<^sub>h h'" and
"\<not>(is_weakly_dom_component_safe {cast e1, cast e2} {} h h')"
by(code_simp, auto simp add: equal_eq List.member_def)+
then show ?thesis
by auto
qed
lemma insert_before_unsafe2: "\<not>(\<forall>(h
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) h' ptr child ref. heap_is_wellformed h \<longrightarrow> type_wf h \<longrightarrow> known_ptrs h \<longrightarrow>
h \<turnstile> insert_before ptr child (Some ref) \<rightarrow>\<^sub>h h' \<longrightarrow>
is_weakly_dom_component_safe {ptr, cast child, cast ref} {} h h')"
proof -
obtain h document_ptr e1 e2 e3 where h: "Inr ((document_ptr, e1, e2, e3), h) = (Heap (fmempty)
:: ('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap
) \<turnstile> (do {
document_ptr \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
e2 \<leftarrow> create_element document_ptr ''div'';
e3 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
return (document_ptr, e1, e2, e3)
})"
by(code_simp, auto simp add: equal_eq List.member_def)+
then obtain h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
h': "h \<turnstile> insert_before (cast e1) (cast e3) (Some (cast e2)) \<rightarrow>\<^sub>h h'" and
"\<not>(is_weakly_dom_component_safe {cast e1, cast e3, cast e2} {} h h')"
apply(code_simp)
apply(clarify)
by(code_simp, auto simp add: equal_eq List.member_def)+
then show ?thesis
by fast
qed
lemma append_child_unsafe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap" and
h' and ptr and child where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_dom_component_safe {ptr, cast child} {} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
e2 \<leftarrow> create_element document_ptr ''div'';
return (e1, e2)
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e1 = "fst |?h0 \<turnstile> ?P|\<^sub>r"
let ?e2 = "snd |?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and ptr="cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ?e1" and child="cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ?e2"])
by code_simp+
qed
subsubsection \<open>get\_owner\_document\<close>
lemma get_owner_document_unsafe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap" and
h' and ptr and owner_document where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<rightarrow>\<^sub>h h'" and
"\<not>is_weakly_dom_component_safe {ptr} {cast owner_document} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
e1 \<leftarrow> create_element document_ptr ''div'';
return (document_ptr, e1)
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?document_ptr = "fst |?h0 \<turnstile> ?P|\<^sub>r"
let ?e1 = "snd |?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and ptr="cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ?e1" and owner_document="?document_ptr"])
by code_simp+
qed
end
diff --git a/thys/SC_DOM_Components/Core_DOM_SC_DOM_Components.thy b/thys/SC_DOM_Components/Core_DOM_SC_DOM_Components.thy
--- a/thys/SC_DOM_Components/Core_DOM_SC_DOM_Components.thy
+++ b/thys/SC_DOM_Components/Core_DOM_SC_DOM_Components.thy
@@ -1,3761 +1,3761 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section \<open>Core SC DOM Components II\<close>
theory Core_DOM_SC_DOM_Components
imports
Core_DOM_DOM_Components
begin
declare [[smt_timeout=2400]]
section \<open>Scope Components\<close>
subsection \<open>Definition\<close>
locale l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs +
l_get_owner_document_defs get_owner_document +
l_to_tree_order_defs to_tree_order
for get_owner_document :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
begin
definition a_get_scdom_component :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_get_scdom_component ptr = do {
document \<leftarrow> get_owner_document ptr;
disc_nodes \<leftarrow> get_disconnected_nodes document;
tree_order \<leftarrow> to_tree_order (cast document);
disconnected_tree_orders \<leftarrow> map_M (to_tree_order \<circ> cast) disc_nodes;
return (tree_order @ (concat disconnected_tree_orders))
}"
definition a_is_strongly_scdom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
where
"a_is_strongly_scdom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h' = (
let removed_pointers = fset (object_ptr_kinds h) - fset (object_ptr_kinds h') in
let added_pointers = fset (object_ptr_kinds h') - fset (object_ptr_kinds h) in
let arg_components =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h). set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) in
let arg_components' =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h'). set |h' \<turnstile> a_get_scdom_component ptr|\<^sub>r) in
removed_pointers \<subseteq> arg_components \<and>
added_pointers \<subseteq> arg_components' \<and>
S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t \<subseteq> arg_components' \<and>
(\<forall>outside_ptr \<in> fset (object_ptr_kinds h) \<inter> fset (object_ptr_kinds h') -
(\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r). preserved (get_M outside_ptr id) h h'))"
definition a_is_weakly_scdom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
where
"a_is_weakly_scdom_component_safe S\<^sub>a\<^sub>r\<^sub>g S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t h h' = (
let removed_pointers = fset (object_ptr_kinds h) - fset (object_ptr_kinds h') in
let added_pointers = fset (object_ptr_kinds h') - fset (object_ptr_kinds h) in
let arg_components =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h). set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) in
let arg_components' =
(\<Union>ptr \<in> (\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r) \<inter>
fset (object_ptr_kinds h'). set |h' \<turnstile> a_get_scdom_component ptr|\<^sub>r) in
removed_pointers \<subseteq> arg_components \<and>
S\<^sub>r\<^sub>e\<^sub>s\<^sub>u\<^sub>l\<^sub>t \<subseteq> arg_components' \<union> added_pointers \<and>
(\<forall>outside_ptr \<in> fset (object_ptr_kinds h) \<inter> fset (object_ptr_kinds h') -
(\<Union>ptr \<in> S\<^sub>a\<^sub>r\<^sub>g. set |h \<turnstile> a_get_scdom_component ptr|\<^sub>r). preserved (get_M outside_ptr id) h h'))"
end
global_interpretation l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order
defines get_scdom_component = "l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_scdom_component
get_owner_document get_disconnected_nodes to_tree_order"
and is_strongly_scdom_component_safe = a_is_strongly_scdom_component_safe
and is_weakly_scdom_component_safe = a_is_weakly_scdom_component_safe
.
locale l_get_scdom_component_defs =
fixes get_scdom_component :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
fixes is_strongly_scdom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
fixes is_weakly_scdom_component_safe ::
"(_) object_ptr set \<Rightarrow> (_) object_ptr set \<Rightarrow> (_) heap \<Rightarrow> (_) heap \<Rightarrow> bool"
locale l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_scdom_component_defs +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
assumes get_scdom_component_impl: "get_scdom_component = a_get_scdom_component"
assumes is_strongly_scdom_component_safe_impl:
"is_strongly_scdom_component_safe = a_is_strongly_scdom_component_safe"
assumes is_weakly_scdom_component_safe_impl:
"is_weakly_scdom_component_safe = a_is_weakly_scdom_component_safe"
begin
lemmas get_scdom_component_def = a_get_scdom_component_def[folded get_scdom_component_impl]
lemmas is_strongly_scdom_component_safe_def =
a_is_strongly_scdom_component_safe_def[folded is_strongly_scdom_component_safe_impl]
lemmas is_weakly_scdom_component_safe_def =
a_is_weakly_scdom_component_safe_def[folded is_weakly_scdom_component_safe_impl]
end
interpretation i_get_scdom_component?: l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_owner_document get_disconnected_nodes get_disconnected_nodes_locs to_tree_order
by(auto simp add: l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def get_scdom_component_def
is_strongly_scdom_component_safe_def is_weakly_scdom_component_safe_def instances)
declare l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_dom_component_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_get_owner_document +
l_get_owner_document_wf +
l_get_disconnected_nodes +
l_to_tree_order +
l_known_ptr +
l_known_ptrs +
l_get_owner_document_wf_get_root_node_wf +
assumes known_ptr_impl: "known_ptr = DocumentClass.known_ptr"
begin
lemma known_ptr_node_or_document: "known_ptr ptr \<Longrightarrow> is_node_ptr_kind ptr \<or> is_document_ptr_kind ptr"
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
lemma get_scdom_component_ptr_in_heap2:
assumes "h \<turnstile> ok (get_scdom_component ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms get_root_node_ptr_in_heap
apply(auto simp add: get_scdom_component_def elim!: bind_is_OK_E3 intro!: map_M_pure_I)[1]
by (simp add: is_OK_returns_result_I local.get_owner_document_ptr_in_heap)
lemma get_scdom_component_subset_get_dom_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
shows "set c \<subseteq> set sc"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where
document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
obtain root_ptr where root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
and c: "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using assms(5)
by(auto simp add: get_dom_component_def elim!: bind_returns_result_E2[rotated, OF get_root_node_pure, rotated])
show ?thesis
proof (cases "is_document_ptr_kind root_ptr")
case True
then have "cast document = root_ptr"
using get_root_node_document assms(1) assms(2) assms(3) root_ptr document
by (metis document_ptr_casts_commute3 returns_result_eq)
then have "c = tree_order"
using tree_order c
by auto
then show ?thesis
by(simp add: sc)
next
case False
moreover have "root_ptr |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) local.get_root_node_root_in_heap root_ptr by blast
ultimately have "is_node_ptr_kind root_ptr"
using assms(3) known_ptrs_known_ptr known_ptr_node_or_document
by auto
then obtain root_node_ptr where root_node_ptr: "root_ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> get_owner_document root_ptr \<rightarrow>\<^sub>r document"
using get_root_node_same_owner_document
using assms(1) assms(2) assms(3) document root_ptr by blast
then have "root_node_ptr \<in> set disc_nodes"
using assms(1) assms(2) assms(3) disc_nodes in_disconnected_nodes_no_parent root_node_ptr
using local.get_root_node_same_no_parent root_ptr by blast
then have "c \<in> set disconnected_tree_orders"
using c root_node_ptr
using map_M_pure_E[OF disconnected_tree_orders]
by (metis (mono_tags, lifting) comp_apply local.to_tree_order_pure select_result_I2)
then show ?thesis
by(auto simp add: sc)
qed
qed
lemma get_scdom_component_ptrs_same_owner_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where
document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
show ?thesis
proof (cases "ptr' \<in> set tree_order")
case True
have "owner_document = document"
using assms(6) document by fastforce
then show ?thesis
by (metis (no_types) True assms(1) assms(2) assms(3) cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject document
document_ptr_casts_commute3 document_ptr_document_ptr_cast document_ptr_kinds_commutes
local.get_owner_document_owner_document_in_heap local.get_root_node_document
local.get_root_node_not_node_same local.to_tree_order_same_root node_ptr_no_document_ptr_cast tree_order)
next
case False
then obtain disconnected_tree_order where disconnected_tree_order:
"ptr' \<in> set disconnected_tree_order" and "disconnected_tree_order \<in> set disconnected_tree_orders"
using sc \<open>ptr' \<in> set sc\<close>
by auto
obtain root_ptr' where
root_ptr': "root_ptr' \<in> set disc_nodes" and
"h \<turnstile> to_tree_order (cast root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order"
using map_M_pure_E2[OF disconnected_tree_orders \<open>disconnected_tree_order \<in> set disconnected_tree_orders\<close>]
by (metis comp_apply local.to_tree_order_pure)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). root_ptr' \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
using disc_nodes
by (meson assms(1) assms(2) assms(3) disjoint_iff_not_equal local.get_child_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr notin_fset
returns_result_select_result root_ptr')
then
have "h \<turnstile> get_parent root_ptr' \<rightarrow>\<^sub>r None"
using disc_nodes
- by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember.rep_eq local.get_parent_child_dual
+ by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember_iff_member_fset local.get_parent_child_dual
local.get_parent_ok local.get_parent_parent_in_heap local.heap_is_wellformed_disc_nodes_in_heap
returns_result_select_result root_ptr' select_result_I2 split_option_ex)
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast root_ptr'"
using \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order\<close> assms(1)
assms(2) assms(3) disconnected_tree_order local.get_root_node_no_parent
local.to_tree_order_get_root_node local.to_tree_order_ptr_in_result
by blast
then have "h \<turnstile> get_owner_document (cast root_ptr') \<rightarrow>\<^sub>r document"
using assms(1) assms(2) assms(3) disc_nodes local.get_owner_document_disconnected_nodes root_ptr'
by blast
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr'\<close> assms(1) assms(2) assms(3)
local.get_root_node_same_owner_document
by blast
then show ?thesis
using assms(6) document returns_result_eq by force
qed
qed
lemma get_scdom_component_ptrs_same_scope_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
shows "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where
document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
show ?thesis
proof (cases "ptr' \<in> set tree_order")
case True
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
by (metis assms(1) assms(2) assms(3) cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject document
document_ptr_casts_commute3 document_ptr_kinds_commutes known_ptr_node_or_document
local.get_owner_document_owner_document_in_heap local.get_root_node_document
local.get_root_node_not_node_same local.known_ptrs_known_ptr local.to_tree_order_get_root_node
local.to_tree_order_ptr_in_result node_ptr_no_document_ptr_cast tree_order)
then show ?thesis
using disc_nodes tree_order disconnected_tree_orders sc
by(auto simp add: get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
next
case False
then obtain disconnected_tree_order where disconnected_tree_order:
"ptr' \<in> set disconnected_tree_order" and "disconnected_tree_order \<in> set disconnected_tree_orders"
using sc \<open>ptr' \<in> set sc\<close>
by auto
obtain root_ptr' where
root_ptr': "root_ptr' \<in> set disc_nodes" and
"h \<turnstile> to_tree_order (cast root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order"
using map_M_pure_E2[OF disconnected_tree_orders \<open>disconnected_tree_order \<in> set disconnected_tree_orders\<close>]
by (metis comp_apply local.to_tree_order_pure)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). root_ptr' \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
using disc_nodes
by (meson assms(1) assms(2) assms(3) disjoint_iff_not_equal local.get_child_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr notin_fset
returns_result_select_result root_ptr')
then
have "h \<turnstile> get_parent root_ptr' \<rightarrow>\<^sub>r None"
using disc_nodes
- by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember.rep_eq
+ by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember_iff_member_fset
local.get_parent_child_dual local.get_parent_ok local.get_parent_parent_in_heap
local.heap_is_wellformed_disc_nodes_in_heap returns_result_select_result root_ptr'
select_result_I2 split_option_ex)
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast root_ptr'"
using \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order\<close> assms(1)
assms(2) assms(3) disconnected_tree_order local.get_root_node_no_parent
local.to_tree_order_get_root_node local.to_tree_order_ptr_in_result
by blast
then have "h \<turnstile> get_owner_document (cast root_ptr') \<rightarrow>\<^sub>r document"
using assms(1) assms(2) assms(3) disc_nodes local.get_owner_document_disconnected_nodes root_ptr'
by blast
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr'\<close> assms(1) assms(2) assms(3)
local.get_root_node_same_owner_document
by blast
then show ?thesis
using disc_nodes tree_order disconnected_tree_orders sc
by(auto simp add: get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
qed
qed
lemma get_scdom_component_ok:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_scdom_component ptr)"
using assms
apply(auto simp add: get_scdom_component_def intro!: bind_is_OK_pure_I map_M_pure_I map_M_ok_I)[1]
using get_owner_document_ok
apply blast
apply (simp add: local.get_disconnected_nodes_ok local.get_owner_document_owner_document_in_heap)
apply (simp add: local.get_owner_document_owner_document_in_heap local.to_tree_order_ok)
using local.heap_is_wellformed_disc_nodes_in_heap local.to_tree_order_ok node_ptr_kinds_commutes
by blast
lemma get_scdom_component_ptr_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
shows "ptr' |\<in>| object_ptr_kinds h"
apply(insert assms )
apply(auto simp add: get_scdom_component_def elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
using local.to_tree_order_ptrs_in_heap apply blast
by (metis (no_types, lifting) assms(4) assms(5) bind_returns_result_E
get_scdom_component_ptrs_same_scope_component is_OK_returns_result_I get_scdom_component_def
local.get_owner_document_ptr_in_heap)
lemma get_scdom_component_contains_get_dom_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
obtains c where "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c" and "set c \<subseteq> set sc"
proof -
have "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
using assms(1) assms(2) assms(3) assms(4) assms(5) get_scdom_component_ptrs_same_scope_component
by blast
then show ?thesis
by (meson assms(1) assms(2) assms(3) assms(5) get_scdom_component_ptr_in_heap
get_scdom_component_subset_get_dom_component is_OK_returns_result_E local.get_dom_component_ok that)
qed
lemma get_scdom_component_owner_document_same:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
obtains owner_document where "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document" and "cast owner_document \<in> set sc"
using assms
apply(auto simp add: get_scdom_component_def elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
apply (metis (no_types, lifting) assms(4) assms(5) document_ptr_casts_commute3
document_ptr_document_ptr_cast get_scdom_component_contains_get_dom_component
local.get_dom_component_ptr local.get_dom_component_root_node_same local.get_dom_component_to_tree_order
local.get_root_node_document local.get_root_node_not_node_same local.to_tree_order_ptr_in_result
local.to_tree_order_ptrs_in_heap node_ptr_no_document_ptr_cast)
apply(rule map_M_pure_E2)
apply(simp)
apply(simp)
apply(simp)
using assms(4) assms(5) get_scdom_component_ptrs_same_owner_document local.to_tree_order_ptr_in_result
by blast
lemma get_scdom_component_different_owner_documents:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
assumes "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document'"
assumes "owner_document \<noteq> owner_document'"
shows "set |h \<turnstile> get_scdom_component ptr|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r = {}"
using assms get_scdom_component_ptrs_same_owner_document
by (smt (verit) disjoint_iff_not_equal get_scdom_component_ok is_OK_returns_result_I
local.get_owner_document_ptr_in_heap returns_result_eq returns_result_select_result)
lemma get_scdom_component_ptr:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r c"
shows "ptr \<in> set c"
using assms
by (meson get_scdom_component_ptr_in_heap2 get_scdom_component_subset_get_dom_component
is_OK_returns_result_E is_OK_returns_result_I local.get_dom_component_ok local.get_dom_component_ptr
subsetD)
end
locale l_get_dom_component_get_scdom_component = l_get_owner_document_defs + l_heap_is_wellformed_defs +
l_type_wf + l_known_ptrs + l_get_scdom_component_defs + l_get_dom_component_defs +
assumes get_scdom_component_subset_get_dom_component:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow>
h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c \<Longrightarrow> set c \<subseteq> set sc"
assumes get_scdom_component_ptrs_same_scope_component:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow>
ptr' \<in> set sc \<Longrightarrow> h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
assumes get_scdom_component_ptrs_same_owner_document:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow>
ptr' \<in> set sc \<Longrightarrow> h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<Longrightarrow> h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document"
assumes get_scdom_component_ok:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> ptr |\<in>| object_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (get_scdom_component ptr)"
assumes get_scdom_component_ptr_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow>
ptr' \<in> set sc \<Longrightarrow> ptr' |\<in>| object_ptr_kinds h"
assumes get_scdom_component_contains_get_dom_component:
"(\<And>c. h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c \<Longrightarrow> set c \<subseteq> set sc \<Longrightarrow> thesis) \<Longrightarrow> heap_is_wellformed h \<Longrightarrow>
type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow> ptr' \<in> set sc \<Longrightarrow> thesis"
assumes get_scdom_component_owner_document_same:
"(\<And>owner_document. h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document \<Longrightarrow> cast owner_document \<in> set sc \<Longrightarrow> thesis) \<Longrightarrow>
heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc \<Longrightarrow>
ptr' \<in> set sc \<Longrightarrow> thesis"
assumes get_scdom_component_different_owner_documents:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<Longrightarrow>
h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document' \<Longrightarrow> owner_document \<noteq> owner_document' \<Longrightarrow>
set |h \<turnstile> get_scdom_component ptr|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r = {}"
interpretation i_get_dom_component_get_scdom_component?: l_get_dom_component_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_owner_document
get_disconnected_nodes get_disconnected_nodes_locs to_tree_order heap_is_wellformed parent_child_rel
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors
get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
by(auto simp add: l_get_dom_component_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_dom_component_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_dom_component_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_dom_component_get_scdom_component_is_l_get_dom_component_get_scdom_component [instances]:
"l_get_dom_component_get_scdom_component get_owner_document heap_is_wellformed type_wf known_ptr
known_ptrs get_scdom_component get_dom_component"
apply(auto simp add: l_get_dom_component_get_scdom_component_def l_get_dom_component_get_scdom_component_axioms_def instances)[1]
using get_scdom_component_subset_get_dom_component apply fast
using get_scdom_component_ptrs_same_scope_component apply fast
using get_scdom_component_ptrs_same_owner_document apply fast
using get_scdom_component_ok apply fast
using get_scdom_component_ptr_in_heap apply fast
using get_scdom_component_contains_get_dom_component apply blast
using get_scdom_component_owner_document_same apply blast
using get_scdom_component_different_owner_documents apply fast
done
subsubsection \<open>get\_child\_nodes\<close>
locale l_get_scdom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "cast child \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
apply(auto)[1]
apply (meson assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) contra_subsetD
get_scdom_component_ptrs_same_scope_component get_scdom_component_subset_get_dom_component
is_OK_returns_result_E local.get_child_nodes_is_strongly_dom_component_safe local.get_dom_component_ok
local.get_dom_component_ptr local.heap_is_wellformed_children_in_heap node_ptr_kinds_commutes)
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) assms(6)
get_scdom_component_contains_get_dom_component is_OK_returns_result_E is_OK_returns_result_I
get_child_nodes_is_strongly_dom_component_safe local.get_child_nodes_ptr_in_heap
local.get_dom_component_ok local.get_dom_component_ptr set_rev_mp)
lemma get_child_nodes_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} (cast ` set children) h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_child_nodes_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def)[1]
by (smt (verit, del_insts) IntI finite_set_in
get_child_nodes_is_strongly_scdom_component_safe_step is_OK_returns_result_I
local.get_child_nodes_ptr_in_heap local.get_dom_component_ok local.get_dom_component_ptr
local.get_scdom_component_impl local.get_scdom_component_ok
local.get_scdom_component_subset_get_dom_component returns_result_select_result subsetD)
qed
end
interpretation i_get_scdom_component_get_child_nodes?: l_get_scdom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs get_child_nodes
get_child_nodes_locs get_root_node get_root_node_locs get_ancestors get_ancestors_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_parent\<close>
locale l_get_scdom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_parent_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_parent ptr' \<rightarrow>\<^sub>r Some parent"
shows "parent \<in> set sc \<longleftrightarrow> cast ptr' \<in> set sc"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) contra_subsetD
get_scdom_component_contains_get_dom_component local.get_dom_component_ptr
local.get_parent_is_strongly_dom_component_safe_step)
lemma get_parent_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some parent"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {cast node_ptr} {parent} h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_parent_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def)[1]
by (smt (verit) Int_iff get_parent_is_strongly_scdom_component_safe_step in_mono
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_dom_component_ptr local.get_dom_component_ok
local.get_parent_parent_in_heap local.get_scdom_component_impl local.get_scdom_component_ok
local.get_scdom_component_ptr_in_heap local.get_scdom_component_ptrs_same_scope_component
local.get_scdom_component_subset_get_dom_component
local.l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms notin_fset returns_result_eq
returns_result_select_result)
qed
end
interpretation i_get_scdom_component_get_parent?: l_get_scdom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_root_node get_root_node_locs get_ancestors get_ancestors_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_root\_node\<close>
locale l_get_scdom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_root_node_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r root"
shows "root \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) contra_subsetD
get_scdom_component_contains_get_dom_component local.get_dom_component_ptr
local.get_root_node_is_strongly_dom_component_safe_step)
lemma get_root_node_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} {root} h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_root_node_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def)[1]
by (smt (verit) Int_iff finite_set_in is_OK_returns_result_I local.get_dom_component_ok
local.get_dom_component_ptr local.get_root_node_is_strongly_dom_component_safe_step
local.get_root_node_ptr_in_heap local.get_scdom_component_impl local.get_scdom_component_ok
local.get_scdom_component_subset_get_dom_component returns_result_select_result subset_eq)
qed
end
interpretation i_get_scdom_component_get_root_node?: l_get_scdom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs get_child_nodes
get_child_nodes_locs get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name first_in_tree_order
get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_element\_by\_id\<close>
locale l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_element_by_id_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_element_by_id ptr' idd \<rightarrow>\<^sub>r Some result"
shows "cast result \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
by (meson assms(1) assms(2) assms(3) assms(4) assms(5) contra_subsetD
get_element_by_id_is_strongly_dom_component_safe_step get_scdom_component_contains_get_dom_component
local.get_dom_component_ptr)
lemma get_element_by_id_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_element_by_id ptr idd \<rightarrow>\<^sub>r Some result"
assumes "h \<turnstile> get_element_by_id ptr idd \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} {cast result} h h'"
proof -
have "h = h'"
using assms(5)
by(auto simp add: preserved_def get_element_by_id_def first_in_tree_order_def
elim!: bind_returns_heap_E2 intro!: map_filter_M_pure bind_pure_I
split: option.splits list.splits)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_element_by_id_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast result \<in> set to"
using assms(4) local.get_element_by_id_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_scdom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_scdom_component_impl
local.get_scdom_component_ok
by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def
get_element_by_id_def first_in_tree_order_def elim!: bind_returns_result_E2
intro!: map_filter_M_pure bind_pure_I split: option.splits list.splits)[1]
by (smt (verit) IntI \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(4) finite_set_in
get_element_by_id_is_strongly_scdom_component_safe_step local.get_dom_component_ok
local.get_dom_component_ptr local.get_scdom_component_impl
local.get_scdom_component_subset_get_dom_component returns_result_select_result select_result_I2
subsetD)
qed
end
interpretation i_get_scdom_component_get_element_by_id?: l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs get_child_nodes
get_child_nodes_locs get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name first_in_tree_order
get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_elements\_by\_class\_name\<close>
locale l_get_scdom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_elements_by_class_name_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_elements_by_class_name ptr' idd \<rightarrow>\<^sub>r results"
assumes "result \<in> set results"
shows "cast result \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
by (meson assms local.get_dom_component_ptr
local.get_elements_by_class_name_is_strongly_dom_component_safe_step
local.get_scdom_component_contains_get_dom_component subsetD)
lemma get_elements_by_class_name_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_elements_by_class_name ptr idd \<rightarrow>\<^sub>r results"
assumes "h \<turnstile> get_elements_by_class_name ptr idd \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} (cast ` set results) h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_elements_by_class_name_pure pure_returns_heap_eq)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_elements_by_class_name_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast ` set results \<subseteq> set to"
using assms(4) local.get_elements_by_class_name_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_scdom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_scdom_component_impl
local.get_scdom_component_ok by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def
get_element_by_id_def first_in_tree_order_def elim!: bind_returns_result_E2 intro!: map_filter_M_pure
bind_pure_I split: option.splits list.splits)[1]
by (smt (verit) IntI \<open>ptr |\<in>| object_ptr_kinds h\<close> finite_set_in
get_elements_by_class_name_is_strongly_scdom_component_safe_step local.get_dom_component_ok
local.get_dom_component_ptr local.get_scdom_component_impl
local.get_scdom_component_subset_get_dom_component returns_result_select_result select_result_I2 subsetD)
qed
end
interpretation i_get_scdom_component_get_elements_by_class_name?: l_get_scdom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_root_node get_root_node_locs get_ancestors get_ancestors_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_elements_by_class_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_elements\_by\_tag\_name\<close>
locale l_get_scdom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_elements_by_tag_name_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_elements_by_tag_name ptr' idd \<rightarrow>\<^sub>r results"
assumes "result \<in> set results"
shows "cast result \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
by (meson assms local.get_dom_component_ptr
local.get_elements_by_tag_name_is_strongly_dom_component_safe_step
local.get_scdom_component_contains_get_dom_component subsetD)
lemma get_elements_by_tag_name_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_elements_by_tag_name ptr idd \<rightarrow>\<^sub>r results"
assumes "h \<turnstile> get_elements_by_tag_name ptr idd \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} (cast ` set results) h h'"
proof -
have "h = h'"
using assms(5)
by (meson local.get_elements_by_tag_name_pure pure_returns_heap_eq)
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
apply(auto simp add: get_elements_by_tag_name_def)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) bind_is_OK_E is_OK_returns_result_I
local.first_in_tree_order_def local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap)
obtain to where to: "h \<turnstile> to_tree_order ptr \<rightarrow>\<^sub>r to"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.to_tree_order_ok)
then have "cast ` set results \<subseteq> set to"
using assms(4) local.get_elements_by_tag_name_result_in_tree_order by auto
obtain c where c: "h \<turnstile> a_get_scdom_component ptr \<rightarrow>\<^sub>r c"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) local.get_scdom_component_impl
local.get_scdom_component_ok by blast
then show ?thesis
using assms \<open>h = h'\<close>
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def
get_element_by_id_def first_in_tree_order_def elim!: bind_returns_result_E2 intro!:
map_filter_M_pure bind_pure_I split: option.splits list.splits)[1]
by (smt (verit) IntI \<open>ptr |\<in>| object_ptr_kinds h\<close> finite_set_in
get_elements_by_tag_name_is_strongly_scdom_component_safe_step local.get_dom_component_ok
local.get_dom_component_ptr local.get_scdom_component_impl
local.get_scdom_component_subset_get_dom_component returns_result_select_result select_result_I2
subsetD)
qed
end
interpretation i_get_scdom_component_get_elements_by_tag_name?:
l_get_scdom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe
get_disconnected_nodes get_disconnected_nodes_locs to_tree_order get_parent get_parent_locs
get_child_nodes get_child_nodes_locs get_root_node get_root_node_locs get_ancestors
get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
first_in_tree_order get_attribute get_attribute_locs
by(auto simp add: l_get_scdom_component_get_elements_by_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_element_by_id\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>remove\_child\<close>
locale l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf +
l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs
get_parent get_parent_locs get_owner_document get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf
known_ptr known_ptrs heap_is_wellformed parent_child_rel
begin
lemma remove_child_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component ptr'|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)|\<^sub>r)|\<^sub>r"
(* assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast child)|\<^sub>r" *)
shows "preserved (get_M ptr getter) h h'"
proof -
have "ptr \<noteq> ptr'"
using assms(5)
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) is_OK_returns_heap_I
is_OK_returns_result_E local.get_dom_component_ok local.get_dom_component_ptr
local.remove_child_ptr_in_heap select_result_I2)
obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document"
by (meson assms(1) assms(2) assms(3) assms(4) is_OK_returns_result_E local.get_owner_document_ok
local.remove_child_child_in_heap node_ptr_kinds_commutes)
then
obtain c where "h \<turnstile> get_dom_component (cast owner_document) \<rightarrow>\<^sub>r c"
using get_dom_component_ok owner_document assms(1) assms(2) assms(3)
by (meson document_ptr_kinds_commutes get_owner_document_owner_document_in_heap select_result_I)
then
have "ptr \<noteq> cast owner_document"
using assms(6) assms(1) assms(2) assms(3) local.get_dom_component_ptr owner_document
by auto
show ?thesis
using remove_child_writes assms(4)
apply(rule reads_writes_preserved2)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: option.splits)[1]
apply (metis \<open>ptr \<noteq> ptr'\<close> document_ptr_casts_commute3 get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> ptr'\<close> element_ptr_casts_commute3 get_M_Element_preserved8)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
done
qed
lemma remove_child_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r"
(* assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)|\<^sub>r)|\<^sub>r" *)
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast child)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain sc where sc: "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) assms(4) is_OK_returns_heap_I local.remove_child_ptr_in_heap
returns_result_select_result)
have "child |\<in>| node_ptr_kinds h"
using assms(4) remove_child_child_in_heap by blast
then
obtain child_sc where child_sc: "h \<turnstile> get_scdom_component (cast child) \<rightarrow>\<^sub>r child_sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) node_ptr_kinds_commutes select_result_I)
then obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document"
by (meson \<open>child |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) contra_subsetD
get_scdom_component_owner_document_same is_OK_returns_result_E
get_scdom_component_subset_get_dom_component local.get_dom_component_ok local.get_dom_component_ptr
node_ptr_kinds_commutes)
then have "h \<turnstile> get_scdom_component (cast owner_document) \<rightarrow>\<^sub>r child_sc"
using child_sc
by (smt (verit) \<open>child |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) contra_subsetD
get_scdom_component_subset_get_dom_component get_scdom_component_owner_document_same
get_scdom_component_ptrs_same_scope_component local.get_dom_component_ok local.get_dom_component_ptr
node_ptr_kinds_commutes returns_result_select_result select_result_I2)
have "ptr \<notin> set |h \<turnstile> get_dom_component ptr'|\<^sub>r"
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) assms(5) contra_subsetD
get_scdom_component_subset_get_dom_component is_OK_returns_heap_I local.get_dom_component_ok
local.remove_child_ptr_in_heap returns_result_select_result sc select_result_I2)
moreover have "ptr \<notin> set |h \<turnstile> get_scdom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)|\<^sub>r)|\<^sub>r"
using get_scdom_component_owner_document_same get_scdom_component_ptrs_same_scope_component
by (metis (no_types, lifting)
\<open>h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document) \<rightarrow>\<^sub>r child_sc\<close> assms(6) child_sc
owner_document select_result_I2)
have "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)|\<^sub>r)|\<^sub>r"
using get_scdom_component_owner_document_same
by (metis (no_types, lifting)
\<open>h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document) \<rightarrow>\<^sub>r child_sc\<close>
\<open>ptr \<notin> set |h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)|\<^sub>r)|\<^sub>r\<close>
assms(1) assms(2) assms(3) contra_subsetD document_ptr_kinds_commutes get_scdom_component_subset_get_dom_component
is_OK_returns_result_E local.get_dom_component_ok local.get_owner_document_owner_document_in_heap owner_document
select_result_I2)
ultimately show ?thesis
using assms(1) assms(2) assms(3) assms(4) remove_child_is_component_unsafe by blast
qed
lemma remove_child_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr, cast child} {} h h'"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(4)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure] split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_eq: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq2: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
using select_result_eq by force
then have node_ptr_kinds_eq2: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by auto
then have node_ptr_kinds_eq3: "node_ptr_kinds h = node_ptr_kinds h'"
using node_ptr_kinds_M_eq by auto
have document_ptr_kinds_eq2: "|h \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3: "document_ptr_kinds h = document_ptr_kinds h'"
using document_ptr_kinds_M_eq by auto
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq: "\<And>document_ptr disconnected_nodes. document_ptr \<noteq> owner_document
\<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes
= h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disconnected_nodes"
apply(rule reads_writes_preserved[OF get_disconnected_nodes_reads remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_child_nodes_get_disconnected_nodes set_disconnected_nodes_get_disconnected_nodes_different_pointers
by (metis (no_types, lifting) Un_iff owner_document select_result_I2)
then have disconnected_nodes_eq2:
"\<And>document_ptr. document_ptr \<noteq> owner_document
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads set_disconnected_nodes_writes h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
have "known_ptrs h'"
using object_ptr_kinds_eq3 known_ptrs_preserved \<open>known_ptrs h\<close> by blast
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved assms(2)
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_child_nodes_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(4) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply simp
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
have disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using owner_document assms(4) h2 disconnected_nodes_h
apply (auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E2)
apply(auto split: if_splits)[1]
apply(simp)
by(auto simp add: local.set_disconnected_nodes_get_disconnected_nodes split: if_splits)
then have disconnected_nodes_h': "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
apply(rule reads_writes_separate_forwards[OF get_disconnected_nodes_reads set_child_nodes_writes h'])
by (simp add: set_child_nodes_get_disconnected_nodes)
moreover have "a_acyclic_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
proof (standard, safe)
fix parent child
assume a1: "(parent, child) \<in> parent_child_rel h'"
then show "(parent, child) \<in> parent_child_rel h"
proof (cases "parent = ptr")
case True
then show ?thesis
using a1 remove_child_removes_parent[OF assms(1) assms(4)] children_h children_h'
get_child_nodes_ptr_in_heap
apply(auto simp add: parent_child_rel_def object_ptr_kinds_eq )[1]
by (metis imageI notin_set_remove1)
next
case False
then show ?thesis
using a1
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq3 children_eq2)
qed
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3 disconnected_nodes_eq)[1]
apply (metis (no_types, lifting) \<open>type_wf h'\<close> assms local.get_child_nodes_ok local.known_ptrs_known_ptr
local.remove_child_children_subset notin_fset object_ptr_kinds_eq3 returns_result_select_result subset_code(1))
apply (metis (no_types, lifting) assms(4) disconnected_nodes_eq2 disconnected_nodes_h disconnected_nodes_h'
document_ptr_kinds_eq3 finite_set_in local.remove_child_child_in_heap node_ptr_kinds_eq3 select_result_I2
set_ConsD subset_code(1))
done
moreover have "a_owner_document_valid h"
using assms(1) by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(auto simp add: a_owner_document_valid_def object_ptr_kinds_eq3 document_ptr_kinds_eq3
node_ptr_kinds_eq3)[1]
proof -
fix node_ptr
assume 0: "\<forall>node_ptr\<in>fset (node_ptr_kinds h'). (\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h' \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or> (\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<and>
node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
and 1: "node_ptr |\<in>| node_ptr_kinds h'"
and 2: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<longrightarrow> node_ptr \<notin> set |h' \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
then show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h'
\<and> node_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
proof (cases "node_ptr = child")
case True
show ?thesis
apply(rule exI[where x=owner_document])
using children_eq2 disconnected_nodes_eq2 children_h children_h' disconnected_nodes_h' True
by (metis (no_types, lifting) get_disconnected_nodes_ptr_in_heap is_OK_returns_result_I
list.set_intros(1) select_result_I2)
next
case False
then show ?thesis
using 0 1 2 children_eq2 children_h children_h' disconnected_nodes_eq2 disconnected_nodes_h
disconnected_nodes_h'
apply(auto simp add: children_eq2 disconnected_nodes_eq2 dest!: select_result_I2)[1]
by (metis children_eq2 disconnected_nodes_eq2 finite_set_in in_set_remove1 list.set_intros(2))
qed
qed
moreover
{
have h0: "a_distinct_lists h"
using assms(1) by (simp add: heap_is_wellformed_def)
moreover have ha1: "(\<Union>x\<in>set |h \<turnstile> object_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r. set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
using \<open>a_distinct_lists h\<close>
unfolding a_distinct_lists_def
by(auto)
have ha2: "ptr |\<in>| object_ptr_kinds h"
using children_h get_child_nodes_ptr_in_heap by blast
have ha3: "child \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
using child_in_children_h children_h
by(simp)
have child_not_in: "\<And>document_ptr. document_ptr |\<in>| document_ptr_kinds h
\<Longrightarrow> child \<notin> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using ha1 ha2 ha3
apply(simp)
using IntI by fastforce
moreover have "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: object_ptr_kinds_M_defs)
moreover have "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
apply(rule select_result_I)
by(auto simp add: document_ptr_kinds_M_defs)
ultimately have "a_distinct_lists h'"
proof(simp (no_asm) add: a_distinct_lists_def, safe)
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
assume 1: "a_distinct_lists h"
and 3: "distinct |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
have 4: "distinct (concat ((map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r)))"
using 1 by(auto simp add: a_distinct_lists_def)
show "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 3[unfolded object_ptr_kinds_eq2], simplified])
fix x
assume 5: "x |\<in>| object_ptr_kinds h'"
then have 6: "distinct |h \<turnstile> get_child_nodes x|\<^sub>r"
using 4 distinct_concat_map_E object_ptr_kinds_eq2 by fastforce
obtain children where children: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children"
and distinct_children: "distinct children"
by (metis "5" "6" assms get_child_nodes_ok local.known_ptrs_known_ptr
object_ptr_kinds_eq3 select_result_I)
obtain children' where children': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
then have "distinct children'"
proof (cases "ptr = x")
case True
then show ?thesis
using children distinct_children children_h children_h'
by (metis children' distinct_remove1 returns_result_eq)
next
case False
then show ?thesis
using children distinct_children children_eq[OF False]
using children' distinct_lists_children h0
using select_result_I2 by fastforce
qed
then show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
using children' by(auto simp add: )
next
fix x y
assume 5: "x |\<in>| object_ptr_kinds h'" and 6: "y |\<in>| object_ptr_kinds h'" and 7: "x \<noteq> y"
obtain children_x where children_x: "h \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x"
by (metis "5" assms get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_y where children_y: "h \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y"
by (metis "6" assms get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children_x' where children_x': "h' \<turnstile> get_child_nodes x \<rightarrow>\<^sub>r children_x'"
using children_eq children_h' children_x by fastforce
obtain children_y' where children_y': "h' \<turnstile> get_child_nodes y \<rightarrow>\<^sub>r children_y'"
using children_eq children_h' children_y by fastforce
have "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r) |h \<turnstile> object_ptr_kinds_M|\<^sub>r))"
using h0 by(auto simp add: a_distinct_lists_def)
then have 8: "set children_x \<inter> set children_y = {}"
using "7" assms(1) children_x children_y local.heap_is_wellformed_one_parent by blast
have "set children_x' \<inter> set children_y' = {}"
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
by(simp add: 7)
have "children_x' = remove1 child children_x"
using children_h children_h' children_x children_x' True returns_result_eq by fastforce
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
have "children_y' = remove1 child children_y"
using children_h children_h' children_y children_y' True returns_result_eq by fastforce
moreover have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
ultimately show ?thesis
using 8 set_remove1_subset by fastforce
next
case False
have "children_x' = children_x"
using children_x children_x' children_eq[OF \<open>ptr \<noteq> x\<close>] by auto
moreover have "children_y' = children_y"
using children_y children_y' children_eq[OF \<open>ptr \<noteq> y\<close>] by auto
ultimately show ?thesis
using 8 by simp
qed
qed
then show "set |h' \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_child_nodes y|\<^sub>r = {}"
using children_x' children_y'
by (metis (no_types, lifting) select_result_I2)
qed
next
assume 2: "distinct |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
then have 4: "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by simp
have 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
using h0
by(simp add: a_distinct_lists_def document_ptr_kinds_eq3)
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I[OF 4[unfolded document_ptr_kinds_eq3]])
fix x
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 5: "distinct |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_lists_disconnected_nodes[OF h0] 4 get_disconnected_nodes_ok
by (simp add: assms document_ptr_kinds_eq3 select_result_I)
show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "x = owner_document")
case True
have "child \<notin> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using child_not_in document_ptr_kinds_eq2 "4" by fastforce
moreover have "|h' \<turnstile> get_disconnected_nodes x|\<^sub>r = child # |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using disconnected_nodes_h' disconnected_nodes_h unfolding True
by(simp)
ultimately show ?thesis
using 5 unfolding True
by simp
next
case False
show ?thesis
using "5" False disconnected_nodes_eq2 by auto
qed
next
fix x y
assume 4: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and 5: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))" and "x \<noteq> y"
obtain disc_nodes_x where disc_nodes_x: "h \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y where disc_nodes_y: "h \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of y] document_ptr_kinds_eq2
by auto
obtain disc_nodes_x' where disc_nodes_x': "h' \<turnstile> get_disconnected_nodes x \<rightarrow>\<^sub>r disc_nodes_x'"
using 4 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of x] document_ptr_kinds_eq2
by auto
obtain disc_nodes_y' where disc_nodes_y': "h' \<turnstile> get_disconnected_nodes y \<rightarrow>\<^sub>r disc_nodes_y'"
using 5 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of y] document_ptr_kinds_eq2
by auto
have "distinct
(concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h \<turnstile> document_ptr_kinds_M|\<^sub>r))"
using h0 by (simp add: a_distinct_lists_def)
then have 6: "set disc_nodes_x \<inter> set disc_nodes_y = {}"
using \<open>x \<noteq> y\<close> assms(1) disc_nodes_x disc_nodes_y local.heap_is_wellformed_one_disc_parent
by blast
have "set disc_nodes_x' \<inter> set disc_nodes_y' = {}"
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using \<open>x \<noteq> y\<close> by simp
then have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y'
by auto
have "disc_nodes_x' = child # disc_nodes_x"
using disconnected_nodes_h' disc_nodes_x disc_nodes_x' True disconnected_nodes_h returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_y"
using child_not_in disc_nodes_y 5
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_x' = child # disc_nodes_x\<close> \<open>disc_nodes_y' = disc_nodes_y\<close>)
using 6 by auto
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x' by auto
have "disc_nodes_y' = child # disc_nodes_y"
using disconnected_nodes_h' disc_nodes_y disc_nodes_y' True disconnected_nodes_h returns_result_eq
by fastforce
have "child \<notin> set disc_nodes_x"
using child_not_in disc_nodes_x 4
using document_ptr_kinds_eq2 by fastforce
then show ?thesis
apply(unfold \<open>disc_nodes_y' = child # disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
next
case False
have "disc_nodes_x' = disc_nodes_x"
using disconnected_nodes_eq[OF \<open>x \<noteq> owner_document\<close>] disc_nodes_x disc_nodes_x' by auto
have "disc_nodes_y' = disc_nodes_y"
using disconnected_nodes_eq[OF \<open>y \<noteq> owner_document\<close>] disc_nodes_y disc_nodes_y' by auto
then show ?thesis
apply(unfold \<open>disc_nodes_y' = disc_nodes_y\<close> \<open>disc_nodes_x' = disc_nodes_x\<close>)
using 6 by auto
qed
qed
then show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using disc_nodes_x' disc_nodes_y' by auto
qed
next
fix x xa xb
assume 1: "xa \<in> fset (object_ptr_kinds h')"
and 2: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 3: "xb \<in> fset (document_ptr_kinds h')"
and 4: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
obtain disc_nodes where disc_nodes: "h \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain disc_nodes' where disc_nodes': "h' \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r disc_nodes'"
using 3 get_disconnected_nodes_ok[OF \<open>type_wf h'\<close>, of xb] document_ptr_kinds_eq2 by auto
obtain children where children: "h \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children"
by (metis "1" assms finite_set_in get_child_nodes_ok is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
obtain children' where children': "h' \<turnstile> get_child_nodes xa \<rightarrow>\<^sub>r children'"
using children children_eq children_h' by fastforce
have "\<And>x. x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r \<Longrightarrow> x \<in> set |h \<turnstile> get_disconnected_nodes xb|\<^sub>r \<Longrightarrow> False"
using 1 3
apply(fold \<open> object_ptr_kinds h = object_ptr_kinds h'\<close>)
apply(fold \<open> document_ptr_kinds h = document_ptr_kinds h'\<close>)
using children disc_nodes h0 apply(auto simp add: a_distinct_lists_def)[1]
by (metis (no_types, lifting) h0 local.distinct_lists_no_parent select_result_I2)
then have 5: "\<And>x. x \<in> set children \<Longrightarrow> x \<in> set disc_nodes \<Longrightarrow> False"
using children disc_nodes by fastforce
have 6: "|h' \<turnstile> get_child_nodes xa|\<^sub>r = children'"
using children' by simp
have 7: "|h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = disc_nodes'"
using disc_nodes' by simp
have "False"
proof (cases "xa = ptr")
case True
have "distinct children_h"
using children_h distinct_lists_children h0 \<open>known_ptr ptr\<close> by blast
have "|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h"
using children_h'
by simp
have "children = children_h"
using True children children_h by auto
show ?thesis
using disc_nodes' children' 5 2 4 children_h \<open>distinct children_h\<close> disconnected_nodes_h'
apply(auto simp add: 6 7
\<open>xa = ptr\<close> \<open>|h' \<turnstile> get_child_nodes ptr|\<^sub>r = remove1 child children_h\<close> \<open>children = children_h\<close>)[1]
by (metis (no_types, lifting) disc_nodes disconnected_nodes_eq2 disconnected_nodes_h
select_result_I2 set_ConsD)
next
case False
have "children' = children"
using children' children children_eq[OF False[symmetric]]
by auto
then show ?thesis
proof (cases "xb = owner_document")
case True
then show ?thesis
using disc_nodes disconnected_nodes_h disconnected_nodes_h'
using "2" "4" "5" "6" "7" False \<open>children' = children\<close> assms(1) child_in_children_h
child_parent_dual children children_h disc_nodes' get_child_nodes_ptr_in_heap
list.set_cases list.simps(3) option.simps(1) returns_result_eq set_ConsD
by (metis (no_types, opaque_lifting) assms)
next
case False
then show ?thesis
using "2" "4" "5" "6" "7" \<open>children' = children\<close> disc_nodes disc_nodes'
disconnected_nodes_eq returns_result_eq
by metis
qed
qed
then show "x \<in> {}"
by simp
qed
}
ultimately have "heap_is_wellformed h'"
using heap_is_wellformed_def by blast
show ?thesis
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def object_ptr_kinds_eq3)[1]
using assms(1) assms(2) assms(3) assms(4) local.get_scdom_component_impl
remove_child_is_strongly_dom_component_safe_step
by blast
qed
end
interpretation i_get_scdom_component_remove_child?: l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_root_node get_root_node_locs get_ancestors
get_ancestors_locs get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id
get_elements_by_class_name get_elements_by_tag_name set_child_nodes set_child_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove
by(auto simp add: l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>adopt\_node\<close>
locale l_get_scdom_component_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_wf +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> adopt_node document_ptr node_ptr \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast node_ptr)|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)|\<^sub>r)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr) \<rightarrow>\<^sub>r owner_document"
using assms(4) local.adopt_node_def by auto
then
obtain c where "h \<turnstile> get_dom_component (cast owner_document) \<rightarrow>\<^sub>r c"
using get_dom_component_ok assms(1) assms(2) assms(3) get_owner_document_owner_document_in_heap
by (meson document_ptr_kinds_commutes select_result_I)
then
have "ptr \<noteq> cast owner_document"
using assms(6) assms(1) assms(2) assms(3) local.get_dom_component_ptr owner_document
by (metis (no_types, lifting) assms(7) select_result_I2)
have "document_ptr |\<in>| document_ptr_kinds h"
using adopt_node_document_in_heap assms(1) assms(2) assms(3) assms(4) by auto
then
have "ptr \<noteq> cast document_ptr"
using assms(5)
using assms(1) assms(2) assms(3) local.get_dom_component_ptr get_dom_component_ok
by (meson document_ptr_kinds_commutes returns_result_select_result)
have "\<And>parent. |h \<turnstile> get_parent node_ptr|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr"
by (metis assms(1) assms(2) assms(3) assms(6) is_OK_returns_result_I local.get_dom_component_ok
local.get_dom_component_parent_inside local.get_dom_component_ptr local.get_owner_document_ptr_in_heap
local.get_parent_ok node_ptr_kinds_commutes owner_document returns_result_select_result)
show ?thesis
using adopt_node_writes assms(4)
apply(rule reads_writes_preserved2)
apply(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_locs_def set_disconnected_nodes_locs_def all_args_def)[1]
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(drule \<open>\<And>parent. |h \<turnstile> get_parent node_ptr|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>)[1] apply (metis element_ptr_casts_commute3 get_M_Element_preserved8 is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(drule \<open>\<And>parent. |h \<turnstile> get_parent node_ptr|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>)[1] apply (metis document_ptr_casts_commute3 get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(drule \<open>\<And>parent. |h \<turnstile> get_parent node_ptr|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>)[1]
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr\<close> get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> get_M_Mdocument_preserved3 owner_document select_result_I2)
done
qed
lemma adopt_node_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> adopt_node document_ptr node_ptr \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast node_ptr)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
have "document_ptr |\<in>| document_ptr_kinds h"
by (meson assms(1) assms(2) assms(3) assms(4) is_OK_returns_heap_I local.adopt_node_document_in_heap)
then
obtain sc where sc: "h \<turnstile> get_scdom_component (cast document_ptr) \<rightarrow>\<^sub>r sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) document_ptr_kinds_commutes returns_result_select_result)
have "node_ptr |\<in>| node_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_heap_I local.adopt_node_child_in_heap)
then
obtain child_sc where child_sc: "h \<turnstile> get_scdom_component (cast node_ptr) \<rightarrow>\<^sub>r child_sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) is_OK_returns_result_E node_ptr_kinds_commutes)
then obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document"
by (meson \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) contra_subsetD
get_scdom_component_owner_document_same is_OK_returns_result_E
get_scdom_component_subset_get_dom_component local.get_dom_component_ok local.get_dom_component_ptr
node_ptr_kinds_commutes)
then have "h \<turnstile> get_scdom_component (cast owner_document) \<rightarrow>\<^sub>r child_sc"
using child_sc
by (metis (no_types, lifting) \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3)
get_scdom_component_owner_document_same get_scdom_component_ptrs_same_scope_component
get_scdom_component_subset_get_dom_component is_OK_returns_result_E local.get_dom_component_ok
local.get_dom_component_ptr node_ptr_kinds_commutes select_result_I2 subset_code(1))
have "ptr \<notin> set |h \<turnstile> get_dom_component (cast document_ptr)|\<^sub>r"
by (metis (no_types, lifting) \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3)
assms(5) contra_subsetD document_ptr_kinds_commutes get_scdom_component_subset_get_dom_component
local.get_dom_component_ok returns_result_select_result sc select_result_I2)
moreover have "ptr \<notin> set |h \<turnstile> get_dom_component (cast node_ptr)|\<^sub>r"
by (metis (no_types, lifting) \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) assms(6)
child_sc contra_subsetD get_scdom_component_subset_get_dom_component local.get_dom_component_ok
node_ptr_kinds_commutes returns_result_select_result select_result_I2)
moreover have "ptr \<notin> set |h \<turnstile> get_scdom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)|\<^sub>r)|\<^sub>r"
using get_scdom_component_owner_document_same get_scdom_component_ptrs_same_scope_component
by (metis (no_types, lifting)
\<open>h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document) \<rightarrow>\<^sub>r child_sc\<close> assms(6) child_sc
owner_document select_result_I2)
have "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)|\<^sub>r)|\<^sub>r"
using get_scdom_component_owner_document_same
by (metis (no_types, opaque_lifting)
\<open>\<And>thesis. (\<And>owner_document. h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr) \<rightarrow>\<^sub>r owner_document \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
\<open>h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document) \<rightarrow>\<^sub>r child_sc\<close>
\<open>ptr \<notin> set |h \<turnstile> get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)|\<^sub>r)|\<^sub>r\<close>
assms(1) assms(2) assms(3) contra_subsetD document_ptr_kinds_commutes get_scdom_component_subset_get_dom_component
is_OK_returns_result_E local.get_dom_component_ok local.get_owner_document_owner_document_in_heap owner_document
returns_result_eq select_result_I2)
ultimately show ?thesis
using assms(1) assms(2) assms(3) assms(4) adopt_node_is_component_unsafe
by blast
qed
lemma adopt_node_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and type_wf: "type_wf h" and known_ptrs: "known_ptrs h"
assumes "h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {cast document_ptr, cast child} {} h h'"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document"
and
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt"
and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2"
and
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have object_ptr_kinds_h_eq3: "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "type_wf h2"
using h2 remove_child_preserves_type_wf known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "known_ptrs h2"
using h2 remove_child_preserves_known_ptrs known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
proof(cases "document_ptr = old_document")
case True
then show ?thesis
using h' wellformed_h2 \<open>type_wf h2\<close> \<open>known_ptrs h2\<close> by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes_document_ptr_h3 where
docs_neq: "document_ptr \<noteq> old_document" and
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3" and
disc_nodes_document_ptr_h3:
"h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes_document_ptr_h3) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2:
"\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h3_eq3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h3: "node_ptr_kinds h3 = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
have children_eq_h3:
"\<And>ptr children. h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. old_document \<noteq> doc_ptr
\<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
obtain disc_nodes_old_document_h2 where disc_nodes_old_document_h2:
"h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
using old_disc_nodes by blast
then have disc_nodes_old_document_h3:
"h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
using h3 old_disc_nodes returns_result_eq set_disconnected_nodes_get_disconnected_nodes
by fastforce
have "distinct disc_nodes_old_document_h2"
using disc_nodes_old_document_h2 local.heap_is_wellformed_disconnected_nodes_distinct wellformed_h2
by blast
have "type_wf h2"
proof (insert h2, induct parent_opt)
case None
then show ?case
using type_wf by simp
next
case (Some option)
then show ?case
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes]
type_wf remove_child_types_preserved
by (simp add: reflp_def transp_def)
qed
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have "known_ptrs h3"
using known_ptrs local.known_ptrs_preserved object_ptr_kinds_h2_eq3 object_ptr_kinds_h_eq3 by blast
then have "known_ptrs h'"
using local.known_ptrs_preserved object_ptr_kinds_h3_eq3 by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2:
"h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
using disconnected_nodes_eq_h2 docs_neq disc_nodes_document_ptr_h3 by auto
have disc_nodes_document_ptr_h': "
h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
using h' disc_nodes_document_ptr_h3
using set_disconnected_nodes_get_disconnected_nodes by blast
have document_ptr_in_heap: "document_ptr |\<in>| document_ptr_kinds h2"
using disc_nodes_document_ptr_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using disc_nodes_document_ptr_h2 get_disconnected_nodes_ptr_in_heap by blast
have old_document_in_heap: "old_document |\<in>| document_ptr_kinds h2"
using disc_nodes_old_document_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using get_disconnected_nodes_ptr_in_heap old_disc_nodes by blast
have "child \<in> set disc_nodes_old_document_h2"
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h2"
by(auto)
moreover have "a_owner_document_valid h"
using assms(1) heap_is_wellformed_def by(simp add: heap_is_wellformed_def)
ultimately show ?case
using old_document disc_nodes_old_document_h2 None(1) child_parent_dual[OF assms(1)]
in_disconnected_nodes_no_parent assms(1) known_ptrs type_wf by blast
next
case (Some option)
then show ?case
apply(simp split: option.splits)
using assms(1) disc_nodes_old_document_h2 old_document remove_child_in_disconnected_nodes known_ptrs
by blast
qed
have "child \<notin> set (remove1 child disc_nodes_old_document_h2)"
using disc_nodes_old_document_h3 h3 known_ptrs wellformed_h2 \<open>distinct disc_nodes_old_document_h2\<close>
by auto
have "child \<notin> set disc_nodes_document_ptr_h3"
proof -
have "a_distinct_lists h2"
using heap_is_wellformed_def wellformed_h2 by blast
then have 0: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r))"
by(simp add: a_distinct_lists_def)
show ?thesis
using distinct_concat_map_E(1)[OF 0] \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h2 disc_nodes_document_ptr_h2
by (meson \<open>type_wf h2\<close> docs_neq known_ptrs local.get_owner_document_disconnected_nodes
local.known_ptrs_preserved object_ptr_kinds_h_eq3 returns_result_eq wellformed_h2)
qed
have child_in_heap: "child |\<in>| node_ptr_kinds h"
using get_owner_document_ptr_in_heap[OF is_OK_returns_result_I[OF old_document]]
node_ptr_kinds_commutes by blast
have "a_acyclic_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h2"
using object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 children_eq2_h2 children_eq2_h3
mem_Collect_eq object_ptr_kinds_M_eq_h3 select_result_eq split_cong
unfolding parent_child_rel_def
by(simp)
qed
then have "a_acyclic_heap h'"
using \<open>a_acyclic_heap h2\<close> acyclic_heap_def acyclic_subset by blast
moreover have "a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h2 children_eq_h2)[1]
apply (simp add: children_eq2_h2 object_ptr_kinds_h2_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> \<open>type_wf h2\<close>
disc_nodes_old_document_h2 disc_nodes_old_document_h3 disconnected_nodes_eq2_h2 document_ptr_kinds_eq3_h2
in_set_remove1 local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2
returns_result_select_result select_result_I2 wellformed_h2)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h3 children_eq_h3)[1]
apply (simp add: children_eq2_h3 object_ptr_kinds_h3_eq3 subset_code(1))
by (metis (no_types, lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq3_h3
finite_set_in local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
select_result_I2 set_ConsD subset_code(1) wellformed_h2)
moreover have "a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_owner_document_valid h'"
apply(simp add: a_owner_document_valid_def node_ptr_kinds_eq_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 children_eq2_h2 children_eq2_h3 )
by (smt (verit) disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2
disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_in_heap
document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 in_set_remove1
list.set_intros(1) node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 select_result_I2
set_subset_Cons subset_code(1))
have a_distinct_lists_h2: "a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def object_ptr_kinds_eq_h3 object_ptr_kinds_eq_h2
children_eq2_h2 children_eq2_h3)[1]
proof -
assume 1: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 3: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I)
show "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by(auto simp add: document_ptr_kinds_M_def )
next
fix x
assume a1: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 4: "distinct |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a_distinct_lists_h2 "2" a1 concat_map_all_distinct document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3
by fastforce
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "old_document \<noteq> x")
case True
then show ?thesis
proof (cases "document_ptr \<noteq> x")
case True
then show ?thesis
using disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>]
disconnected_nodes_eq2_h3[OF \<open>document_ptr \<noteq> x\<close>] 4
by(auto)
next
case False
then show ?thesis
using disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' 4
\<open>child \<notin> set disc_nodes_document_ptr_h3\<close>
by(auto simp add: disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>] )
qed
next
case False
then show ?thesis
by (metis (no_types, opaque_lifting) \<open>distinct disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h3 disconnected_nodes_eq2_h3
distinct_remove1 docs_neq select_result_I2)
qed
next
fix x y
assume a0: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a1: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a2: "x \<noteq> y"
moreover have 5: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using 2 calculation
by (auto simp add: document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 dest: distinct_concat_map_E(1))
ultimately show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
proof(cases "old_document = x")
case True
have "old_document \<noteq> y"
using \<open>x \<noteq> y\<close> \<open>old_document = x\<close> by simp
have "document_ptr \<noteq> x"
using docs_neq \<open>old_document = x\<close> by auto
show ?thesis
proof(cases "document_ptr = y")
case True
then show ?thesis
using 5 True select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document = x\<close>
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
\<open>document_ptr \<noteq> x\<close> disconnected_nodes_eq2_h3 disjoint_iff_not_equal
notin_set_remove1 set_ConsD)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 \<open>old_document = x\<close>
docs_neq \<open>old_document \<noteq> y\<close>
by (metis (no_types, lifting) disjoint_iff_not_equal notin_set_remove1)
qed
next
case False
then show ?thesis
proof(cases "old_document = y")
case True
then show ?thesis
proof(cases "document_ptr = x")
case True
show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr = x\<close>
apply(simp)
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr \<noteq> x\<close>
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal docs_neq notin_set_remove1)
qed
next
case False
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
by (metis DocumentMonad.ptr_kinds_M_ok DocumentMonad.ptr_kinds_M_ptr_kinds False
\<open>type_wf h2\<close> a1 disc_nodes_old_document_h2 document_ptr_kinds_M_def
document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result
wellformed_h2)
then show ?thesis
proof(cases "document_ptr = x")
case True
then have "document_ptr \<noteq> y"
using \<open>x \<noteq> y\<close> by auto
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
using \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by blast
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document \<noteq> y\<close> \<open>document_ptr = x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
\<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by(auto)
next
case False
then show ?thesis
proof(cases "document_ptr = y")
case True
have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set disc_nodes_document_ptr_h3 = {}"
using 2 a1 document_ptr_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>document_ptr \<noteq> x\<close> select_result_I2[OF disc_nodes_document_ptr_h3, symmetric]
disconnected_nodes_eq2_h2[OF docs_neq[symmetric], symmetric]
by (simp add: "5" True)
moreover have f1:
"set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = {}"
using 2 a1 old_document_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>old_document \<noteq> x\<close>
by (metis (no_types, lifting) a0 distinct_concat_map_E(1) document_ptr_kinds_eq3_h2
- document_ptr_kinds_eq3_h3 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ document_ptr_kinds_eq3_h3 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
ultimately show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr = y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by auto
next
case False
then show ?thesis
using 5
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close>
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
by (metis \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
empty_iff inf.idem)
qed
qed
qed
qed
qed
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show False
using \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 old_document_in_heap
apply(auto)[1]
apply(cases "xb = old_document")
proof -
assume a1: "xb = old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a3: "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
assume a4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a5: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f6: "old_document |\<in>| document_ptr_kinds h'"
using a1 \<open>xb |\<in>| document_ptr_kinds h'\<close> by blast
have f7: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a2 by simp
have "x \<in> set disc_nodes_old_document_h2"
using f6 a3 a1 by (metis (no_types) \<open>type_wf h'\<close> \<open>x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close>
disconnected_nodes_eq_h3 docs_neq get_disconnected_nodes_ok returns_result_eq
returns_result_select_result set_remove1_subset subsetCE)
then have "set |h' \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using f7 f6 a5 a4 \<open>xa |\<in>| object_ptr_kinds h'\<close>
by fastforce
then show ?thesis
using \<open>x \<in> set disc_nodes_old_document_h2\<close> a1 a4 f7 by blast
next
assume a1: "xb \<noteq> old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
assume a3: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a4: "xa |\<in>| object_ptr_kinds h'"
assume a5: "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
assume a6: "old_document |\<in>| document_ptr_kinds h'"
assume a7: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume a8: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume a9: "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a10: "\<And>doc_ptr. old_document \<noteq> doc_ptr
\<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a11: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a12: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f13: "\<And>d. d \<notin> set |h' \<turnstile> document_ptr_kinds_M|\<^sub>r \<or> h2 \<turnstile> ok get_disconnected_nodes d"
using a9 \<open>type_wf h2\<close> get_disconnected_nodes_ok
by simp
then have f14: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a6 a3 by simp
have "x \<notin> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
using a12 a8 a4 \<open>xb |\<in>| document_ptr_kinds h'\<close>
- by (meson UN_I disjoint_iff_not_equal fmember.rep_eq)
+ by (meson UN_I disjoint_iff_not_equal fmember_iff_member_fset)
then have "x = child"
using f13 a11 a10 a7 a5 a2 a1
by (metis (no_types, lifting) select_result_I2 set_ConsD)
then have "child \<notin> set disc_nodes_old_document_h2"
using f14 a12 a8 a6 a4
by (metis \<open>type_wf h'\<close> adopt_node_removes_child assms type_wf
get_child_nodes_ok known_ptrs local.known_ptrs_known_ptr object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3 returns_result_select_result)
then show ?thesis
using \<open>child \<in> set disc_nodes_old_document_h2\<close> by fastforce
qed
qed
ultimately show ?thesis
using \<open>type_wf h'\<close> \<open>known_ptrs h'\<close> \<open>a_owner_document_valid h'\<close> heap_is_wellformed_def by blast
qed
then have "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
by auto
have object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes assms(4)])
unfolding adopt_node_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
show ?thesis
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def object_ptr_kinds_eq3 )[1]
using adopt_node_is_strongly_dom_component_safe_step get_scdom_component_impl assms by blast
qed
end
interpretation i_get_scdom_component_adopt_node?: l_get_scdom_component_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_parent get_parent_locs remove_child
remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs adopt_node adopt_node_locs get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs remove to_tree_order get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
by(auto simp add: l_get_scdom_component_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_element\<close>
locale l_get_scdom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_dom_component_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma create_element_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<noteq> cast |h \<turnstile> create_element document_ptr tag|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile>set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: create_element_def elim!: bind_returns_heap_E bind_returns_heap_E2[rotated,
OF get_disconnected_nodes_pure, rotated])
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h", OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "heap_is_wellformed h'"
using assms(4)
using assms(1) assms(2) assms(3) local.create_element_preserves_wellformedness(1) by blast
have "type_wf h'"
using assms(1) assms(2) assms(3) assms(4) local.create_element_preserves_wellformedness(2) by blast
have "known_ptrs h'"
using assms(1) assms(2) assms(3) assms(4) local.create_element_preserves_wellformedness(3) by blast
have "document_ptr |\<in>| document_ptr_kinds h"
by (meson assms(4) is_OK_returns_heap_I local.create_element_document_in_heap)
then
obtain sc where sc: "h \<turnstile> get_scdom_component (cast document_ptr) \<rightarrow>\<^sub>r sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) document_ptr_kinds_commutes returns_result_select_result)
have "document_ptr |\<in>| document_ptr_kinds h'"
using \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h
using document_ptr_kinds_eq_h2 document_ptr_kinds_eq_h3 by blast
then
obtain sc' where sc': "h' \<turnstile> get_scdom_component (cast document_ptr) \<rightarrow>\<^sub>r sc'"
using get_scdom_component_ok
by (meson \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> document_ptr_kinds_commutes
returns_result_select_result)
obtain c where c: "h \<turnstile> get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r c"
by (meson \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3)
document_ptr_kinds_commutes is_OK_returns_result_E local.get_dom_component_ok)
have "set c \<subseteq> set sc"
using assms(1) assms(2) assms(3) c get_scdom_component_subset_get_dom_component sc by blast
have "ptr \<notin> set c"
using \<open>set c \<subseteq> set sc\<close> assms(5) sc
by auto
then
show ?thesis
using create_element_is_weakly_dom_component_safe
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) assms(6) c
local.create_element_is_weakly_dom_component_safe_step select_result_I2)
qed
lemma create_element_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {cast document_ptr} {cast result} h h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: create_element_def returns_result_heap_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
then have "result = new_element_ptr"
using assms(4) by auto
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h", OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
have "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>ptr' children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "parent_child_rel h = parent_child_rel h'"
proof -
have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally show ?thesis
by simp
qed
have "document_ptr |\<in>| document_ptr_kinds h'"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h
document_ptr_kinds_eq_h2 document_ptr_kinds_eq_h3)
have "known_ptr (cast document_ptr)"
using \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(3) document_ptr_kinds_commutes
local.known_ptrs_known_ptr by blast
have "h \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr"
using \<open>known_ptr (cast document_ptr)\<close> \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I split: option.splits)
have "h' \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr"
using \<open>known_ptr (cast document_ptr)\<close> \<open>document_ptr |\<in>| document_ptr_kinds h'\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I split: option.splits)
obtain to where to: "h \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to"
by (meson \<open>h \<turnstile> get_owner_document (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r document_ptr\<close> assms(1)
assms(2) assms(3) is_OK_returns_result_E is_OK_returns_result_I local.get_owner_document_ptr_in_heap
local.to_tree_order_ok)
obtain to' where to': "h' \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to'"
by (metis \<open>document_ptr |\<in>| document_ptr_kinds h\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> assms(1) assms(2)
assms(3) assms(5) document_ptr_kinds_commutes document_ptr_kinds_eq_h document_ptr_kinds_eq_h2
document_ptr_kinds_eq_h3 is_OK_returns_result_E local.create_element_preserves_wellformedness(1)
local.to_tree_order_ok)
have "set to = set to'"
proof safe
fix x
assume "x \<in> set to"
show "x \<in> set to'"
using to to'
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to\<close> assms(1) assms(2) assms(3) assms(5)
local.create_element_preserves_wellformedness(1))
next
fix x
assume "x \<in> set to'"
show "x \<in> set to"
using to to'
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to'\<close> assms(1) assms(2) assms(3) assms(5)
local.create_element_preserves_wellformedness(1))
qed
have "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_element_ptr # disc_nodes_h3"
using h' local.set_disconnected_nodes_get_disconnected_nodes by auto
obtain disc_nodes_h' where disc_nodes_h': "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h'"
and "cast new_element_ptr \<in> set disc_nodes_h'"
and "disc_nodes_h' = cast new_element_ptr # disc_nodes_h3"
by (simp add: \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3\<close>)
have "\<And>disc_ptr to to'. disc_ptr \<in> set disc_nodes_h3 \<Longrightarrow> h \<turnstile> to_tree_order (cast disc_ptr) \<rightarrow>\<^sub>r to \<Longrightarrow>
h' \<turnstile> to_tree_order (cast disc_ptr) \<rightarrow>\<^sub>r to' \<Longrightarrow> set to = set to'"
proof safe
fix disc_ptr to to' x
assume "disc_ptr \<in> set disc_nodes_h3"
assume "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to"
assume "h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'"
assume "x \<in> set to"
show "x \<in> set to'"
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to\<close>
\<open>h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to\<close>
assms(1) assms(2) assms(3) assms(5) local.create_element_preserves_wellformedness(1))
next
fix disc_ptr to to' x
assume "disc_ptr \<in> set disc_nodes_h3"
assume "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to"
assume "h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'"
assume "x \<in> set to'"
show "x \<in> set to"
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to\<close>
\<open>h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to'\<close>
assms(1) assms(2) assms(3) assms(5) local.create_element_preserves_wellformedness(1))
qed
have "heap_is_wellformed h'"
using assms(1) assms(2) assms(3) assms(5) local.create_element_preserves_wellformedness(1)
by blast
have "cast new_element_ptr |\<in>| object_ptr_kinds h'"
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<in> set disc_nodes_h'\<close> \<open>heap_is_wellformed h'\<close> disc_nodes_h'
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_commutes by blast
then
have "new_element_ptr |\<in>| element_ptr_kinds h'"
by simp
have "\<And>node_ptr. node_ptr \<in> set disc_nodes_h3 \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h'"
by (meson \<open>heap_is_wellformed h'\<close> h' local.heap_is_wellformed_disc_nodes_in_heap
local.set_disconnected_nodes_get_disconnected_nodes set_subset_Cons subset_code(1))
have "h \<turnstile> ok (map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h3)"
using assms(1) assms(2) assms(3) to_tree_order_ok
apply(auto intro!: map_M_ok_I)[1]
using disc_nodes_document_ptr_h local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_commutes
by blast
then
obtain disc_tree_orders where disc_tree_orders:
"h \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h3 \<rightarrow>\<^sub>r disc_tree_orders"
by auto
have "h' \<turnstile> ok (map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h')"
apply(auto intro!: map_M_ok_I)[1]
apply(simp add: \<open>disc_nodes_h' = cast new_element_ptr # disc_nodes_h3\<close>)
using \<open>\<And>node_ptr. node_ptr \<in> set disc_nodes_h3 \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h'\<close>
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<in> set disc_nodes_h'\<close> \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close>
\<open>type_wf h'\<close> disc_nodes_h' local.heap_is_wellformed_disc_nodes_in_heap local.to_tree_order_ok
node_ptr_kinds_commutes by blast
then
obtain disc_tree_orders' where disc_tree_orders':
"h' \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h' \<rightarrow>\<^sub>r disc_tree_orders'"
by auto
have "h' \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> children_eq_h2
children_eq_h3 by auto
obtain new_tree_order where new_tree_order:
"h' \<turnstile> to_tree_order (cast new_element_ptr) \<rightarrow>\<^sub>r new_tree_order" and
"new_tree_order \<in> set disc_tree_orders'"
using map_M_pure_E[OF disc_tree_orders' \<open>cast new_element_ptr \<in> set disc_nodes_h'\<close>]
by auto
then have "new_tree_order = [cast new_element_ptr]"
using \<open>h' \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto simp add: to_tree_order_def
dest!: bind_returns_result_E3[rotated, OF \<open>h' \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>, rotated])
obtain foo where foo: "h' \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r)
(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>r [cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr] # foo"
apply(auto intro!: bind_pure_returns_result_I map_M_pure_I)[1]
using \<open>new_tree_order = [cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr]\<close> new_tree_order apply auto[1]
by (smt (verit) \<open>disc_nodes_h' = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3\<close>
bind_pure_returns_result_I bind_returns_result_E2 comp_apply disc_tree_orders'
local.to_tree_order_pure map_M.simps(2) map_M_pure_I return_returns_result returns_result_eq)
then have "set (concat foo) = set (concat disc_tree_orders)"
apply(auto elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
apply (smt (verit) \<open>\<And>to' toa disc_ptr. \<lbrakk>disc_ptr \<in> set disc_nodes_h3; h \<turnstile> to_tree_order
(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r toa; h' \<turnstile> to_tree_order
(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<rbrakk> \<Longrightarrow> set toa = set to'\<close>
comp_eq_dest_lhs disc_tree_orders local.to_tree_order_pure map_M_pure_E map_M_pure_E2)
by (smt (verit) \<open>\<And>to' toa disc_ptr. \<lbrakk>disc_ptr \<in> set disc_nodes_h3; h \<turnstile> to_tree_order
(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r toa; h' \<turnstile> to_tree_order
(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<rbrakk> \<Longrightarrow> set toa = set to'\<close>
comp_eq_dest_lhs disc_tree_orders local.to_tree_order_pure map_M_pure_E map_M_pure_E2)
have "disc_tree_orders' = [cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr] # foo"
using foo disc_tree_orders'
by (simp add: \<open>disc_nodes_h' = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3\<close> returns_result_eq)
have "set (concat disc_tree_orders') = {cast new_element_ptr} \<union> set (concat disc_tree_orders)"
apply(auto simp add: \<open>disc_tree_orders' = [cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr] # foo\<close>)[1]
using \<open>set (concat foo) = set (concat disc_tree_orders)\<close> by auto
have "h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to' @ concat disc_tree_orders'"
using \<open>h' \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr\<close> disc_nodes_h' to' disc_tree_orders'
by(auto simp add: a_get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
then
have "set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to' \<union> set (concat disc_tree_orders')"
by auto
have "h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to @ concat disc_tree_orders"
using \<open>h \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr\<close> disc_nodes_document_ptr_h
to disc_tree_orders
by(auto simp add: a_get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
then
have "set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r = set to \<union> set (concat disc_tree_orders)"
by auto
have "{cast new_element_ptr} \<union> set |h \<turnstile> local.a_get_scdom_component (cast document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_scdom_component (cast document_ptr)|\<^sub>r"
proof(safe)
show "cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr
\<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
using \<open>h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to' @ concat disc_tree_orders'\<close>
apply(auto simp add: a_get_scdom_component_def)[1]
by (meson \<open>\<And>thesis. (\<And>new_tree_order. \<lbrakk>h' \<turnstile> to_tree_order (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r new_tree_order;
new_tree_order \<in> set disc_tree_orders'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> local.to_tree_order_ptr_in_result)
next
fix x
assume " x \<in> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
then
show "x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
using \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union>set (concat disc_tree_orders)\<close>
using \<open>set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to' \<union> set (concat disc_tree_orders')\<close>
using \<open>set to = set to'\<close>
using \<open>set (concat disc_tree_orders') = {cast new_element_ptr} \<union> set (concat disc_tree_orders)\<close>
by(auto)
next
fix x
assume " x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
assume "x \<notin> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
show "x = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr"
using \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close>
using \<open>set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to' \<union> set (concat disc_tree_orders')\<close>
using \<open>set to = set to'\<close>
using \<open>set (concat disc_tree_orders') = {cast new_element_ptr} \<union> set (concat disc_tree_orders)\<close>
using \<open>x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
\<open>x \<notin> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
by auto
qed
have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using object_ptr_kinds_eq_h object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 by auto
then
show ?thesis
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def)[1]
apply(rule bexI[where x="cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr"])
using \<open>{cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr} \<union>
set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
apply auto[2]
using \<open>set to = set to'\<close> \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close> local.to_tree_order_ptr_in_result to'
apply auto[1]
using \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply blast
apply(rule bexI[where x="cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr"])
using \<open>result = new_element_ptr\<close>
\<open>{cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr} \<union> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close> apply auto[1]
apply(auto)[1]
using \<open>set to = set to'\<close> \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close> local.to_tree_order_ptr_in_result to' apply auto[1]
apply (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close>)
using \<open>\<And>thesis. (\<And>new_element_ptr h2 h3 disc_nodes_h3. \<lbrakk>h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr;
h \<turnstile> new_element \<rightarrow>\<^sub>h h2; h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3;
h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3;
h3 \<turnstile> set_disconnected_nodes document_ptr (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
new_element_ptr new_element_ptr_not_in_heap
apply auto[1]
using create_element_is_strongly_scdom_component_safe_step
by (smt (verit, best) ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile>
object_ptr_kinds_M|\<^sub>r\<close> \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> assms(1)
assms(2) assms(3) assms(5) local.get_scdom_component_impl select_result_I2)
qed
end
interpretation i_get_scdom_component_remove_child?: l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs get_scdom_component
is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_root_node get_root_node_locs get_ancestors get_ancestors_locs get_disconnected_nodes get_disconnected_nodes_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name set_child_nodes set_child_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove
by(auto simp add: l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_character\_data\<close>
locale l_get_scdom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_dom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_create_character_data_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma create_character_data_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast document_ptr)|\<^sub>r"
assumes "ptr \<noteq> cast |h \<turnstile> create_character_data document_ptr text|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
have "document_ptr |\<in>| document_ptr_kinds h"
by (meson assms(4) is_OK_returns_heap_I local.create_character_data_document_in_heap)
then
obtain sc where sc: "h \<turnstile> get_scdom_component (cast document_ptr) \<rightarrow>\<^sub>r sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) document_ptr_kinds_commutes returns_result_select_result)
obtain c where c: "h \<turnstile> get_dom_component (cast document_ptr) \<rightarrow>\<^sub>r c"
by (meson \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3)
document_ptr_kinds_commutes is_OK_returns_result_E local.get_dom_component_ok)
have "set c \<subseteq> set sc"
using assms(1) assms(2) assms(3) c get_scdom_component_subset_get_dom_component sc by blast
have "ptr \<notin> set c"
using \<open>set c \<subseteq> set sc\<close> assms(5) sc
by auto
then
show ?thesis
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) assms(6) c
local.create_character_data_is_weakly_dom_component_safe_step select_result_I2)
qed
lemma create_character_data_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {cast document_ptr} {cast result} h h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
then have "result = new_character_data_ptr"
using assms(4) by auto
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>ptr' children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_val_writes h3])
using set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>ptr' children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "parent_child_rel h = parent_child_rel h'"
proof -
have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally show ?thesis
by simp
qed
have "known_ptr (cast new_character_data_ptr)"
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
create_character_data_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
have "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h'"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h
document_ptr_kinds_eq_h2 document_ptr_kinds_eq_h3)
have "known_ptr (cast document_ptr)"
using \<open>document_ptr |\<in>| document_ptr_kinds h\<close> assms(3) document_ptr_kinds_commutes
local.known_ptrs_known_ptr by blast
have "h \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr"
using \<open>known_ptr (cast document_ptr)\<close> \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I split: option.splits)
have "h' \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr"
using \<open>known_ptr (cast document_ptr)\<close> \<open>document_ptr |\<in>| document_ptr_kinds h'\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
by(auto simp add: known_ptr_impl known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I split: option.splits)
obtain to where to: "h \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to"
by (meson \<open>h \<turnstile> get_owner_document (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r document_ptr\<close>
assms(1) assms(2) assms(3) is_OK_returns_result_E is_OK_returns_result_I
local.get_owner_document_ptr_in_heap local.to_tree_order_ok)
obtain to' where to': "h' \<turnstile> to_tree_order (cast document_ptr) \<rightarrow>\<^sub>r to'"
by (metis \<open>document_ptr |\<in>| document_ptr_kinds h\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> assms(1) assms(2)
assms(3) assms(5) document_ptr_kinds_commutes document_ptr_kinds_eq_h document_ptr_kinds_eq_h2
document_ptr_kinds_eq_h3 is_OK_returns_result_E local.create_character_data_preserves_wellformedness(1)
local.to_tree_order_ok)
have "set to = set to'"
proof safe
fix x
assume "x \<in> set to"
show "x \<in> set to'"
using to to'
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to\<close> assms(1) assms(2) assms(3) assms(5)
local.create_character_data_preserves_wellformedness(1))
next
fix x
assume "x \<in> set to'"
show "x \<in> set to"
using to to'
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to'\<close> assms(1) assms(2) assms(3) assms(5)
local.create_character_data_preserves_wellformedness(1))
qed
have "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3"
using h' local.set_disconnected_nodes_get_disconnected_nodes by auto
obtain disc_nodes_h' where disc_nodes_h': "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h'"
and "cast new_character_data_ptr \<in> set disc_nodes_h'"
and "disc_nodes_h' = cast new_character_data_ptr # disc_nodes_h3"
by (simp add: \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3\<close>)
have "\<And>disc_ptr to to'. disc_ptr \<in> set disc_nodes_h3 \<Longrightarrow> h \<turnstile> to_tree_order (cast disc_ptr) \<rightarrow>\<^sub>r to \<Longrightarrow>
h' \<turnstile> to_tree_order (cast disc_ptr) \<rightarrow>\<^sub>r to' \<Longrightarrow> set to = set to'"
proof safe
fix disc_ptr to to' x
assume "disc_ptr \<in> set disc_nodes_h3"
assume "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to"
assume "h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'"
assume "x \<in> set to"
show "x \<in> set to'"
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to\<close>
\<open>h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to\<close>
assms(1) assms(2) assms(3) assms(5) local.create_character_data_preserves_wellformedness(1))
next
fix disc_ptr to to' x
assume "disc_ptr \<in> set disc_nodes_h3"
assume "h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to"
assume "h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'"
assume "x \<in> set to'"
show "x \<in> set to"
using to_tree_order_parent_child_rel \<open>parent_child_rel h = parent_child_rel h'\<close>
by (metis \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to\<close>
\<open>h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> \<open>x \<in> set to'\<close>
assms(1) assms(2) assms(3) assms(5) local.create_character_data_preserves_wellformedness(1))
qed
have "heap_is_wellformed h'"
using assms(1) assms(2) assms(3) assms(5) local.create_character_data_preserves_wellformedness(1)
by blast
have "cast new_character_data_ptr |\<in>| object_ptr_kinds h'"
using \<open>cast new_character_data_ptr \<in> set disc_nodes_h'\<close> \<open>heap_is_wellformed h'\<close> disc_nodes_h'
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_commutes by blast
then
have "new_character_data_ptr |\<in>| character_data_ptr_kinds h'"
by simp
have "\<And>node_ptr. node_ptr \<in> set disc_nodes_h3 \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h'"
by (meson \<open>heap_is_wellformed h'\<close> h' local.heap_is_wellformed_disc_nodes_in_heap
local.set_disconnected_nodes_get_disconnected_nodes set_subset_Cons subset_code(1))
have "h \<turnstile> ok (map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h3)"
using assms(1) assms(2) assms(3) to_tree_order_ok
apply(auto intro!: map_M_ok_I)[1]
using disc_nodes_document_ptr_h local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_commutes
by blast
then
obtain disc_tree_orders where disc_tree_orders:
"h \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h3 \<rightarrow>\<^sub>r disc_tree_orders"
by auto
have "h' \<turnstile> ok (map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h')"
apply(auto intro!: map_M_ok_I)[1]
apply(simp add: \<open>disc_nodes_h' = cast new_character_data_ptr # disc_nodes_h3\<close>)
using \<open>\<And>node_ptr. node_ptr \<in> set disc_nodes_h3 \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h'\<close>
\<open>cast new_character_data_ptr \<in> set disc_nodes_h'\<close> \<open>heap_is_wellformed h'\<close> \<open>known_ptrs h'\<close>
\<open>type_wf h'\<close> disc_nodes_h' local.heap_is_wellformed_disc_nodes_in_heap local.to_tree_order_ok
node_ptr_kinds_commutes by blast
then
obtain disc_tree_orders' where disc_tree_orders':
"h' \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) disc_nodes_h' \<rightarrow>\<^sub>r disc_tree_orders'"
by auto
have "h' \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> children_eq_h2 children_eq_h3 by auto
obtain new_tree_order where new_tree_order:
"h' \<turnstile> to_tree_order (cast new_character_data_ptr) \<rightarrow>\<^sub>r new_tree_order" and
"new_tree_order \<in> set disc_tree_orders'"
using map_M_pure_E[OF disc_tree_orders' \<open>cast new_character_data_ptr \<in> set disc_nodes_h'\<close>]
by auto
then have "new_tree_order = [cast new_character_data_ptr]"
using \<open>h' \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto simp add: to_tree_order_def
dest!: bind_returns_result_E3[rotated, OF \<open>h' \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>, rotated])
obtain foo where foo: "h' \<turnstile> map_M (to_tree_order \<circ> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r)
(cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>r [cast new_character_data_ptr] # foo"
apply(auto intro!: bind_pure_returns_result_I map_M_pure_I)[1]
using \<open>new_tree_order = [cast new_character_data_ptr]\<close> new_tree_order apply auto[1]
using \<open>disc_nodes_h' = cast new_character_data_ptr # disc_nodes_h3\<close> bind_pure_returns_result_I
bind_returns_result_E2 comp_apply disc_tree_orders' local.to_tree_order_pure map_M.simps(2)
map_M_pure_I return_returns_result returns_result_eq
apply simp
by (smt (verit) \<open>disc_nodes_h' = cast new_character_data_ptr # disc_nodes_h3\<close> bind_pure_returns_result_I
bind_returns_result_E2 comp_apply disc_tree_orders' local.to_tree_order_pure map_M.simps(2) map_M_pure_I
return_returns_result returns_result_eq)
then have "set (concat foo) = set (concat disc_tree_orders)"
apply(auto elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
apply (smt (verit) \<open>\<And>to' toa disc_ptr. \<lbrakk>disc_ptr \<in> set disc_nodes_h3;
h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r toa; h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<rbrakk> \<Longrightarrow>
set toa = set to'\<close> comp_apply disc_tree_orders local.to_tree_order_pure map_M_pure_E map_M_pure_E2)
by (smt (verit) \<open>\<And>to' toa disc_ptr. \<lbrakk>disc_ptr \<in> set disc_nodes_h3; h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r toa;
h' \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_ptr) \<rightarrow>\<^sub>r to'\<rbrakk> \<Longrightarrow> set toa = set to'\<close> comp_apply disc_tree_orders
local.to_tree_order_pure map_M_pure_E map_M_pure_E2)
have "disc_tree_orders' = [cast new_character_data_ptr] # foo"
using foo disc_tree_orders'
by (simp add: \<open>disc_nodes_h' = cast new_character_data_ptr # disc_nodes_h3\<close> returns_result_eq)
have "set (concat disc_tree_orders') = {cast new_character_data_ptr} \<union> set (concat disc_tree_orders)"
apply(auto simp add: \<open>disc_tree_orders' = [cast new_character_data_ptr] # foo\<close>)[1]
using \<open>set (concat foo) = set (concat disc_tree_orders)\<close> by auto
have "h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to' @ concat disc_tree_orders'"
using \<open>h' \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr\<close> disc_nodes_h' to' disc_tree_orders'
by(auto simp add: a_get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
then
have "set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r = set to' \<union> set (concat disc_tree_orders')"
by auto
have "h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to @ concat disc_tree_orders"
using \<open>h \<turnstile> get_owner_document (cast document_ptr) \<rightarrow>\<^sub>r document_ptr\<close> disc_nodes_document_ptr_h to disc_tree_orders
by(auto simp add: a_get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
then
have "set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r = set to \<union> set (concat disc_tree_orders)"
by auto
have "{cast new_character_data_ptr} \<union> set |h \<turnstile> local.a_get_scdom_component (cast document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_scdom_component (cast document_ptr)|\<^sub>r"
proof(safe)
show "cast new_character_data_ptr
\<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
using \<open>h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr) \<rightarrow>\<^sub>r to' @ concat disc_tree_orders'\<close>
apply(auto simp add: a_get_scdom_component_def)[1]
by (meson \<open>\<And>thesis. (\<And>new_tree_order. \<lbrakk>h' \<turnstile> to_tree_order (cast new_character_data_ptr) \<rightarrow>\<^sub>r new_tree_order;
new_tree_order \<in> set disc_tree_orders'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> local.to_tree_order_ptr_in_result)
next
fix x
assume " x \<in> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
then
show "x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
using \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close>
using \<open>set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to' \<union> set (concat disc_tree_orders')\<close>
using \<open>set to = set to'\<close>
using \<open>set (concat disc_tree_orders') = {cast new_character_data_ptr} \<union> set (concat disc_tree_orders)\<close>
by(auto)
next
fix x
assume " x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
assume "x \<notin> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r"
show "x = cast new_character_data_ptr"
using \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close>
using \<open>set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to' \<union> set (concat disc_tree_orders')\<close>
using \<open>set to = set to'\<close>
using \<open>set (concat disc_tree_orders') = {cast new_character_data_ptr} \<union> set (concat disc_tree_orders)\<close>
using \<open>x \<in> set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
\<open>x \<notin> set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
by auto
qed
have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using object_ptr_kinds_eq_h object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 by auto
then
show ?thesis
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def)[1]
apply(rule bexI[where x="cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr"])
using \<open>{cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr} \<union> set |h \<turnstile> local.a_get_scdom_component
(cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r = set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
apply auto[2]
using \<open>set to = set to'\<close> \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close> local.to_tree_order_ptr_in_result to'
apply auto[1]
using \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply blast
apply(rule bexI[where x="cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr"])
using \<open>result = new_character_data_ptr\<close> \<open>{cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr} \<union>
set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set |h' \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r\<close>
apply auto[1]
apply(auto)[1]
using \<open>set to = set to'\<close> \<open>set |h \<turnstile> local.a_get_scdom_component (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr)|\<^sub>r =
set to \<union> set (concat disc_tree_orders)\<close> local.to_tree_order_ptr_in_result to' apply auto[1]
apply (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close>)
using \<open>\<And>thesis. (\<And>new_character_data_ptr h2 h3 disc_nodes_h3. \<lbrakk>h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr;
h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2; h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3;
h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3;
h3 \<turnstile> set_disconnected_nodes document_ptr (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
new_character_data_ptr new_character_data_ptr_not_in_heap
apply auto[1]
using create_character_data_is_strongly_dom_component_safe_step
by (smt (verit) ObjectMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>result = new_character_data_ptr\<close> assms(1) assms(2) assms(3) assms(4) assms(5) local.get_scdom_component_impl select_result_I2)
qed
end
interpretation i_get_scdom_component_create_character_data?: l_get_scdom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs get_scdom_component
is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe to_tree_order get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_root_node get_root_node_locs get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs create_character_data
by(auto simp add: l_get_scdom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_document\<close>
lemma create_document_not_strongly_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap" and
h' and new_document_ptr where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> create_document \<rightarrow>\<^sub>r new_document_ptr \<rightarrow>\<^sub>h h'" and
"\<not> is_strongly_scdom_component_safe {} {cast new_document_ptr} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder}) heap"
let ?P = "create_document"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?document_ptr = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1"])
by code_simp+
qed
locale l_get_scdom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_dom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma create_document_is_weakly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> create_document \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
shows "is_weakly_scdom_component_safe {} {cast result} h h'"
proof -
have "object_ptr_kinds h' = {|cast result|} |\<union>| object_ptr_kinds h"
using assms(4) assms(5) local.create_document_def new_document_new_ptr by blast
have "result |\<notin>| document_ptr_kinds h"
using assms(4) assms(5) local.create_document_def new_document_ptr_not_in_heap by auto
show ?thesis
using assms
apply(auto simp add: is_weakly_scdom_component_safe_def Let_def)[1]
using \<open>object_ptr_kinds h' = {|cast result|} |\<union>| object_ptr_kinds h\<close> apply(auto)[1]
apply (simp add: local.create_document_def new_document_ptr_in_heap)
using \<open>result |\<notin>| document_ptr_kinds h\<close> apply auto[1]
apply (metis (no_types, lifting) \<open>result |\<notin>| document_ptr_kinds h\<close> document_ptr_kinds_commutes
local.create_document_is_weakly_dom_component_safe_step select_result_I2)
done
qed
end
interpretation i_get_scdom_component_create_document?: l_get_scdom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe to_tree_order get_parent get_parent_locs
get_child_nodes get_child_nodes_locs get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_element_by_id get_elements_by_class_name get_elements_by_tag_name create_document
get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_get_scdom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>insert\_before\<close>
locale l_get_dom_component_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf +
l_get_dom_component_get_scdom_component +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_disconnected_nodes +
l_remove_child +
l_get_root_node_wf +
l_set_disconnected_nodes_get_disconnected_nodes_wf +
l_set_disconnected_nodes_get_ancestors +
l_get_ancestors_wf +
l_get_owner_document +
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma insert_before_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> insert_before ptr' child ref \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component ptr'|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast child)|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document ptr'|\<^sub>r)|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast child)|\<^sub>r)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document"
using assms(4)
by(auto simp add: local.adopt_node_def insert_before_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF ensure_pre_insertion_validity_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated] bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated] split: if_splits)
then
obtain c where "h \<turnstile> get_dom_component (cast owner_document) \<rightarrow>\<^sub>r c"
using get_dom_component_ok assms(1) assms(2) assms(3) get_owner_document_owner_document_in_heap
by (meson document_ptr_kinds_commutes select_result_I)
then
have "ptr \<noteq> cast owner_document"
using assms(6) assms(1) assms(2) assms(3) local.get_dom_component_ptr owner_document
by (metis (no_types, lifting) assms(8) select_result_I2)
obtain owner_document' where owner_document': "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document'"
using assms(4)
by(auto simp add: local.adopt_node_def insert_before_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF ensure_pre_insertion_validity_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated] split: if_splits)
then
obtain c where "h \<turnstile> get_dom_component (cast owner_document') \<rightarrow>\<^sub>r c"
using get_dom_component_ok assms(1) assms(2) assms(3) get_owner_document_owner_document_in_heap
by (meson document_ptr_kinds_commutes select_result_I)
then
have "ptr \<noteq> cast owner_document'"
using assms(1) assms(2) assms(3) assms(7) local.get_dom_component_ptr owner_document' by auto
then
have "ptr \<noteq> cast |h \<turnstile> get_owner_document ptr'|\<^sub>r"
using owner_document' by auto
have "ptr \<noteq> ptr'"
by (metis (mono_tags, opaque_lifting) assms(1) assms(2) assms(3) assms(5) assms(7) is_OK_returns_result_I
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_dom_component_ok l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_dom_component_ptr
l_get_owner_document.get_owner_document_ptr_in_heap local.l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
local.l_get_owner_document_axioms owner_document' return_returns_result returns_result_select_result)
have "\<And>parent. h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent \<Longrightarrow> parent \<noteq> ptr"
by (meson assms(1) assms(2) assms(3) assms(6) l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_dom_component_ptr
local.get_dom_component_ok local.get_dom_component_to_tree_order local.get_parent_parent_in_heap
local.l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms local.to_tree_order_ok local.to_tree_order_parent
local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap returns_result_select_result)
then
have "\<And>parent. |h \<turnstile> get_parent child|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr"
by (metis assms(2) assms(3) assms(4) is_OK_returns_heap_I local.get_parent_ok
local.insert_before_child_in_heap select_result_I)
show ?thesis
using insert_before_writes assms(4)
apply(rule reads_writes_preserved2)
apply(auto simp add: insert_before_locs_def adopt_node_locs_def all_args_def)[1]
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document ptr'|\<^sub>r\<close>
get_M_Mdocument_preserved3)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis \<open>ptr \<noteq> ptr'\<close> document_ptr_casts_commute3 get_M_Mdocument_preserved3)
apply(auto split: option.splits)[1]
apply (metis \<open>ptr \<noteq> ptr'\<close> element_ptr_casts_commute3 get_M_Element_preserved8)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def set_disconnected_nodes_locs_def
all_args_def split: if_splits)[1]
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document ptr'|\<^sub>r\<close> get_M_Mdocument_preserved3)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis (no_types, lifting) \<open>\<And>parent. |h \<turnstile> get_parent child|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>
element_ptr_casts_commute3 get_M_Element_preserved8 node_ptr_casts_commute option.case_eq_if option.collapse)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis \<open>\<And>parent. |h \<turnstile> get_parent child|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>
document_ptr_casts_commute3 get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document ptr'|\<^sub>r\<close>
get_M_Mdocument_preserved3)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis (no_types, lifting) \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close>
get_M_Mdocument_preserved3 owner_document select_result_I2)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
apply (metis \<open>ptr \<noteq> ptr'\<close> document_ptr_casts_commute3 get_M_Mdocument_preserved3)
apply (metis (no_types, lifting) \<open>ptr \<noteq> ptr'\<close> element_ptr_casts_commute3
get_M_Element_preserved8 node_ptr_casts_commute option.case_eq_if option.collapse)
apply(auto simp add: remove_child_locs_def set_child_nodes_locs_def
set_disconnected_nodes_locs_def all_args_def split: if_splits)[1]
by (metis \<open>ptr \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r |h \<turnstile> get_owner_document ptr'|\<^sub>r\<close> get_M_Mdocument_preserved3)
qed
lemma insert_before_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> insert_before ptr' child ref \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast child)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
proof -
have "ptr' |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_heap_I local.insert_before_ptr_in_heap)
then
obtain sc' where sc': "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc'"
by (meson assms(1) assms(2) assms(3) get_scdom_component_ok is_OK_returns_result_E)
moreover
obtain c' where c': "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c'"
by (meson \<open>ptr' |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_dom_component_ok)
ultimately have "set c' \<subseteq> set sc'"
using assms(1) assms(2) assms(3) get_scdom_component_subset_get_dom_component by blast
have "child |\<in>| node_ptr_kinds h"
by (meson assms(4) is_OK_returns_heap_I local.insert_before_child_in_heap)
then
obtain child_sc where child_sc: "h \<turnstile> get_scdom_component (cast child) \<rightarrow>\<^sub>r child_sc"
by (meson assms(1) assms(2) assms(3) get_scdom_component_ok is_OK_returns_result_E
node_ptr_kinds_commutes)
moreover
obtain child_c where child_c: "h \<turnstile> get_dom_component (cast child) \<rightarrow>\<^sub>r child_c"
by (meson \<open>child |\<in>| node_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_dom_component_ok node_ptr_kinds_commutes)
ultimately have "set child_c \<subseteq> set child_sc"
using assms(1) assms(2) assms(3) get_scdom_component_subset_get_dom_component by blast
obtain ptr'_owner_document where ptr'_owner_document: "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r ptr'_owner_document"
by (meson \<open>set c' \<subseteq> set sc'\<close> assms(1) assms(2) assms(3) c' get_scdom_component_owner_document_same
local.get_dom_component_ptr sc' subset_code(1))
then
have "h \<turnstile> get_scdom_component (cast ptr'_owner_document) \<rightarrow>\<^sub>r sc'"
by (metis (no_types, lifting) \<open>set c' \<subseteq> set sc'\<close> assms(1) assms(2) assms(3) c'
get_scdom_component_owner_document_same get_scdom_component_ptrs_same_scope_component
local.get_dom_component_ptr sc' select_result_I2 subset_code(1))
moreover
obtain ptr'_owner_document_c where ptr'_owner_document_c:
"h \<turnstile> get_dom_component (cast ptr'_owner_document) \<rightarrow>\<^sub>r ptr'_owner_document_c"
by (meson assms(1) assms(2) assms(3) document_ptr_kinds_commutes is_OK_returns_result_E
local.get_dom_component_ok local.get_owner_document_owner_document_in_heap ptr'_owner_document)
ultimately have "set ptr'_owner_document_c \<subseteq> set sc'"
using assms(1) assms(2) assms(3) get_scdom_component_subset_get_dom_component by blast
obtain child_owner_document where child_owner_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r child_owner_document"
by (meson \<open>set child_c \<subseteq> set child_sc\<close> assms(1) assms(2) assms(3) child_c child_sc
get_scdom_component_owner_document_same local.get_dom_component_ptr subset_code(1))
have "child_owner_document |\<in>| document_ptr_kinds h"
using assms(1) assms(2) assms(3) child_owner_document local.get_owner_document_owner_document_in_heap
by blast
then
have "h \<turnstile> get_scdom_component (cast child_owner_document) \<rightarrow>\<^sub>r child_sc"
using get_scdom_component_ok assms(1) assms(2) assms(3) child_sc
by (metis (no_types, lifting) \<open>set child_c \<subseteq> set child_sc\<close> child_c child_owner_document
get_scdom_component_owner_document_same get_scdom_component_ptrs_same_scope_component
local.get_dom_component_ptr returns_result_eq set_mp)
moreover
obtain child_owner_document_c where child_owner_document_c:
"h \<turnstile> get_dom_component (cast child_owner_document) \<rightarrow>\<^sub>r child_owner_document_c"
by (meson assms(1) assms(2) assms(3) child_owner_document document_ptr_kinds_commutes
is_OK_returns_result_E local.get_dom_component_ok local.get_owner_document_owner_document_in_heap)
ultimately have "set child_owner_document_c \<subseteq> set child_sc"
using assms(1) assms(2) assms(3) get_scdom_component_subset_get_dom_component by blast
have "ptr \<notin> set |h \<turnstile> get_dom_component ptr'|\<^sub>r"
using \<open>set c' \<subseteq> set sc'\<close> assms(5) c' sc' by auto
moreover have "ptr \<notin> set |h \<turnstile> get_dom_component (cast child)|\<^sub>r"
using \<open>set child_c \<subseteq> set child_sc\<close> assms(6) child_c child_sc by auto
moreover have "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document ptr'|\<^sub>r)|\<^sub>r"
using \<open>set ptr'_owner_document_c \<subseteq> set sc'\<close> assms(5) ptr'_owner_document ptr'_owner_document_c sc'
by auto
moreover have "ptr \<notin> set |h \<turnstile> get_dom_component (cast |h \<turnstile> get_owner_document (cast child)|\<^sub>r)|\<^sub>r"
using \<open>set child_owner_document_c \<subseteq> set child_sc\<close> assms(6) child_owner_document child_owner_document_c
child_sc by auto
ultimately show ?thesis
using assms insert_before_is_component_unsafe
by blast
qed
lemma insert_before_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe ({ptr, cast node} \<union> (case child of Some ref \<Rightarrow> {cast ref} | None \<Rightarrow> {} )) {} h h'"
proof -
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have "known_ptrs h2"
using assms(3) object_ptr_kinds_M_eq3_h known_ptrs_preserved by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF assms(1) h2] assms(3) assms(2) .
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have "known_ptrs h3"
using object_ptr_kinds_M_eq3_h2 known_ptrs_preserved \<open>known_ptrs h2\<close> by blast
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3:
"|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
have "object_ptr_kinds h = object_ptr_kinds h'"
by (simp add: object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h' object_ptr_kinds_M_eq3_h2)
then
show ?thesis
using assms
apply(auto simp add: is_strongly_scdom_component_safe_def)[1]
using insert_before_is_strongly_dom_component_safe_step local.get_scdom_component_impl by blast
qed
lemma append_child_is_strongly_dom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> append_child ptr' child \<rightarrow>\<^sub>h h'"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast child)|\<^sub>r"
shows "preserved (get_M ptr getter) h h'"
by (metis assms(1) assms(2) assms(3) assms(4) assms(5) assms(6)
insert_before_is_strongly_dom_component_safe_step local.append_child_def)
lemma append_child_is_strongly_dom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> append_child ptr child \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr, cast child} {} h h'"
using assms unfolding append_child_def
using insert_before_is_strongly_dom_component_safe
by fastforce
end
interpretation i_get_dom_component_insert_before?: l_get_dom_component_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs to_tree_order get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_dom_component is_strongly_dom_component_safe
is_weakly_dom_component_safe get_root_node get_root_node_locs get_ancestors get_ancestors_locs
get_disconnected_nodes get_disconnected_nodes_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name set_child_nodes set_child_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
get_owner_document remove_child remove_child_locs remove adopt_node adopt_node_locs insert_before
insert_before_locs append_child get_scdom_component is_strongly_scdom_component_safe
is_weakly_scdom_component_safe
by(auto simp add: l_get_dom_component_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_dom_component_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_owner\_document\<close>
locale l_get_owner_document_scope_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_scdom_component +
l_get_owner_document_wf_get_root_node_wf
begin
lemma get_owner_document_is_strongly_scdom_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document"
shows "cast owner_document \<in> set sc \<longleftrightarrow> ptr' \<in> set sc"
proof -
have "h \<turnstile> get_owner_document (cast owner_document) \<rightarrow>\<^sub>r owner_document"
by (metis assms(1) assms(2) assms(3) assms(5) cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject
document_ptr_casts_commute3 document_ptr_document_ptr_cast document_ptr_kinds_commutes
local.get_owner_document_owner_document_in_heap local.get_root_node_document
local.get_root_node_not_node_same node_ptr_no_document_ptr_cast)
then show ?thesis
using assms
using bind_returns_result_E contra_subsetD get_scdom_component_ok
get_scdom_component_ptrs_same_scope_component get_scdom_component_subset_get_dom_component
is_OK_returns_result_E is_OK_returns_result_I local.get_dom_component_ok local.get_dom_component_ptr
local.get_owner_document_ptr_in_heap local.get_owner_document_pure local.get_scdom_component_def
pure_returns_heap_eq returns_result_eq
by (smt (verit) local.get_scdom_component_ptrs_same_owner_document subsetD)
qed
lemma get_owner_document_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>h h'"
shows "is_strongly_scdom_component_safe {ptr} {cast owner_document} h h'"
proof -
have "h = h'"
by (meson assms(5) local.get_owner_document_pure pure_returns_heap_eq)
then show ?thesis
using assms
apply(auto simp add: is_strongly_scdom_component_safe_def Let_def preserved_def)[1]
by (smt (verit) get_owner_document_is_strongly_scdom_component_safe_step inf.orderE is_OK_returns_result_I
local.get_dom_component_ok local.get_dom_component_to_tree_order_subset local.get_owner_document_ptr_in_heap
local.get_scdom_component_impl local.get_scdom_component_ok local.get_scdom_component_ptr_in_heap
local.get_scdom_component_subset_get_dom_component local.to_tree_order_ok
local.to_tree_order_ptr_in_result notin_fset returns_result_select_result subset_eq)
qed
end
interpretation i_get_owner_document_scope_component?: l_get_owner_document_scope_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_owner_document get_disconnected_nodes get_disconnected_nodes_locs to_tree_order known_ptr
known_ptrs type_wf heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_parent get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe get_element_by_id
get_elements_by_class_name get_elements_by_tag_name
by(auto simp add: l_get_owner_document_scope_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_owner_document_scope_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/SC_DOM_Components/Shadow_DOM_SC_DOM_Components.thy b/thys/SC_DOM_Components/Shadow_DOM_SC_DOM_Components.thy
--- a/thys/SC_DOM_Components/Shadow_DOM_SC_DOM_Components.thy
+++ b/thys/SC_DOM_Components/Shadow_DOM_SC_DOM_Components.thy
@@ -1,1005 +1,1005 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section \<open>Shadow SC DOM Components II\<close>
theory Shadow_DOM_SC_DOM_Components
imports
Core_DOM_SC_DOM_Components
Shadow_DOM_DOM_Components
begin
section \<open>Shadow root scope components\<close>
subsection \<open>get\_scope\_component\<close>
global_interpretation l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_disconnected_nodes
get_disconnected_nodes_locs to_tree_order
defines get_scdom_component = a_get_scdom_component
and is_strongly_scdom_component_safe = a_is_strongly_scdom_component_safe
and is_weakly_scdom_component_safe = a_is_weakly_scdom_component_safe
.
interpretation i_get_scdom_component?: l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_owner_document get_disconnected_nodes get_disconnected_nodes_locs to_tree_order
by(auto simp add: l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def get_scdom_component_def
is_strongly_scdom_component_safe_def is_weakly_scdom_component_safe_def instances)
declare l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_component\<close>
locale l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_get_owner_document +
l_get_owner_document_wf +
l_get_disconnected_nodes +
l_to_tree_order +
l_known_ptr +
l_known_ptrs +
l_get_owner_document_wf_get_root_node_wf +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
begin
lemma known_ptr_node_or_document: "known_ptr ptr \<Longrightarrow> is_node_ptr_kind ptr \<or> is_document_ptr_kind ptr"
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
lemma get_scdom_component_subset_get_dom_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_dom_component ptr \<rightarrow>\<^sub>r c"
shows "set c \<subseteq> set sc"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
obtain root_ptr where root_ptr: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root_ptr"
and c: "h \<turnstile> to_tree_order root_ptr \<rightarrow>\<^sub>r c"
using assms(5)
by(auto simp add: get_dom_component_def elim!: bind_returns_result_E2[rotated, OF get_root_node_pure, rotated])
show ?thesis
proof (cases "is_document_ptr_kind root_ptr")
case True
then have "cast document = root_ptr"
using get_root_node_document assms(1) assms(2) assms(3) root_ptr document
by (metis document_ptr_casts_commute3 returns_result_eq)
then have "c = tree_order"
using tree_order c
by auto
then show ?thesis
by(simp add: sc)
next
case False
moreover have "root_ptr |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) local.get_root_node_root_in_heap root_ptr by blast
ultimately have "is_node_ptr_kind root_ptr"
using assms(3) known_ptrs_known_ptr known_ptr_node_or_document
by auto
then obtain root_node_ptr where root_node_ptr: "root_ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> get_owner_document root_ptr \<rightarrow>\<^sub>r document"
using get_root_node_same_owner_document
using assms(1) assms(2) assms(3) document root_ptr by blast
then have "root_node_ptr \<in> set disc_nodes"
using assms(1) assms(2) assms(3) disc_nodes in_disconnected_nodes_no_parent root_node_ptr
using local.get_root_node_same_no_parent root_ptr by blast
then have "c \<in> set disconnected_tree_orders"
using c root_node_ptr
using map_M_pure_E[OF disconnected_tree_orders]
by (metis (mono_tags, lifting) comp_apply local.to_tree_order_pure select_result_I2)
then show ?thesis
by(auto simp add: sc)
qed
qed
lemma get_scdom_component_ptrs_same_owner_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
show ?thesis
proof (cases "ptr' \<in> set tree_order")
case True
have "owner_document = document"
using assms(6) document by fastforce
then show ?thesis
by (metis (no_types) True assms(1) assms(2) assms(3) cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject document
document_ptr_casts_commute3 document_ptr_document_ptr_cast document_ptr_kinds_commutes
local.get_owner_document_owner_document_in_heap local.get_root_node_document
local.get_root_node_not_node_same local.to_tree_order_same_root node_ptr_no_document_ptr_cast
tree_order)
next
case False
then obtain disconnected_tree_order where disconnected_tree_order:
"ptr' \<in> set disconnected_tree_order" and "disconnected_tree_order \<in> set disconnected_tree_orders"
using sc \<open>ptr' \<in> set sc\<close>
by auto
obtain root_ptr' where
root_ptr': "root_ptr' \<in> set disc_nodes" and
"h \<turnstile> to_tree_order (cast root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order"
using map_M_pure_E2[OF disconnected_tree_orders \<open>disconnected_tree_order \<in> set disconnected_tree_orders\<close>]
by (metis comp_apply local.to_tree_order_pure)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). root_ptr' \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
using disc_nodes
by (meson assms(1) assms(2) assms(3) disjoint_iff_not_equal local.get_child_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr notin_fset
returns_result_select_result root_ptr')
then
have "h \<turnstile> get_parent root_ptr' \<rightarrow>\<^sub>r None"
using disc_nodes
- by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember.rep_eq local.get_parent_child_dual
+ by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember_iff_member_fset local.get_parent_child_dual
local.get_parent_ok local.get_parent_parent_in_heap local.heap_is_wellformed_disc_nodes_in_heap
returns_result_select_result root_ptr' select_result_I2 split_option_ex)
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast root_ptr'"
using \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order\<close> assms(1)
assms(2) assms(3) disconnected_tree_order local.get_root_node_no_parent local.to_tree_order_get_root_node
local.to_tree_order_ptr_in_result
by blast
then have "h \<turnstile> get_owner_document (cast root_ptr') \<rightarrow>\<^sub>r document"
using assms(1) assms(2) assms(3) disc_nodes local.get_owner_document_disconnected_nodes root_ptr'
by blast
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr'\<close> assms(1) assms(2) assms(3)
local.get_root_node_same_owner_document
by blast
then show ?thesis
using assms(6) document returns_result_eq by force
qed
qed
lemma get_scdom_component_ptrs_same_scope_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
shows "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
proof -
obtain document disc_nodes tree_order disconnected_tree_orders where document:
"h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r document"
and disc_nodes: "h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes"
and tree_order: "h \<turnstile> to_tree_order (cast document) \<rightarrow>\<^sub>r tree_order"
and disconnected_tree_orders: "h \<turnstile> map_M (to_tree_order \<circ> cast) disc_nodes \<rightarrow>\<^sub>r disconnected_tree_orders"
and sc: "sc = tree_order @ (concat disconnected_tree_orders)"
using assms(4)
by(auto simp add: get_scdom_component_def elim!: bind_returns_result_E
elim!: bind_returns_result_E2[rotated, OF get_owner_document_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF get_disconnected_nodes_pure, rotated]
elim!: bind_returns_result_E2[rotated, OF to_tree_order_pure, rotated]
)
show ?thesis
proof (cases "ptr' \<in> set tree_order")
case True
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
by (metis assms(1) assms(2) assms(3) cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_inject document document_ptr_casts_commute3
document_ptr_kinds_commutes known_ptr_node_or_document local.get_owner_document_owner_document_in_heap
local.get_root_node_document local.get_root_node_not_node_same local.known_ptrs_known_ptr
local.to_tree_order_get_root_node local.to_tree_order_ptr_in_result node_ptr_no_document_ptr_cast tree_order)
then show ?thesis
using disc_nodes tree_order disconnected_tree_orders sc
by(auto simp add: get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
next
case False
then obtain disconnected_tree_order where disconnected_tree_order:
"ptr' \<in> set disconnected_tree_order" and "disconnected_tree_order \<in> set disconnected_tree_orders"
using sc \<open>ptr' \<in> set sc\<close>
by auto
obtain root_ptr' where
root_ptr': "root_ptr' \<in> set disc_nodes" and
"h \<turnstile> to_tree_order (cast root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order"
using map_M_pure_E2[OF disconnected_tree_orders \<open>disconnected_tree_order \<in> set disconnected_tree_orders\<close>]
by (metis comp_apply local.to_tree_order_pure)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). root_ptr' \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
using disc_nodes
by (meson assms(1) assms(2) assms(3) disjoint_iff_not_equal local.get_child_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr notin_fset
returns_result_select_result root_ptr')
then
have "h \<turnstile> get_parent root_ptr' \<rightarrow>\<^sub>r None"
using disc_nodes
- by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember.rep_eq local.get_parent_child_dual
+ by (metis (no_types, lifting) assms(1) assms(2) assms(3) fmember_iff_member_fset local.get_parent_child_dual
local.get_parent_ok local.get_parent_parent_in_heap local.heap_is_wellformed_disc_nodes_in_heap
returns_result_select_result root_ptr' select_result_I2 split_option_ex)
then have "h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast root_ptr'"
using \<open>h \<turnstile> to_tree_order (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr') \<rightarrow>\<^sub>r disconnected_tree_order\<close> assms(1)
assms(2) assms(3) disconnected_tree_order local.get_root_node_no_parent local.to_tree_order_get_root_node
local.to_tree_order_ptr_in_result
by blast
then have "h \<turnstile> get_owner_document (cast root_ptr') \<rightarrow>\<^sub>r document"
using assms(1) assms(2) assms(3) disc_nodes local.get_owner_document_disconnected_nodes root_ptr'
by blast
then have "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r document"
using \<open>h \<turnstile> get_root_node ptr' \<rightarrow>\<^sub>r cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_ptr'\<close> assms(1) assms(2) assms(3)
local.get_root_node_same_owner_document
by blast
then show ?thesis
using disc_nodes tree_order disconnected_tree_orders sc
by(auto simp add: get_scdom_component_def intro!: bind_pure_returns_result_I map_M_pure_I)
qed
qed
lemma get_scdom_component_ok:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_scdom_component ptr)"
using assms
apply(auto simp add: get_scdom_component_def intro!: bind_is_OK_pure_I map_M_pure_I map_M_ok_I)[1]
using get_owner_document_ok
apply blast
apply (simp add: local.get_disconnected_nodes_ok local.get_owner_document_owner_document_in_heap)
apply (simp add: local.get_owner_document_owner_document_in_heap local.to_tree_order_ok)
using local.heap_is_wellformed_disc_nodes_in_heap local.to_tree_order_ok node_ptr_kinds_commutes
by blast
lemma get_scdom_component_ptr_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
shows "ptr' |\<in>| object_ptr_kinds h"
using assms
apply(auto simp add: get_scdom_component_def elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
using local.to_tree_order_ptrs_in_heap apply blast
by (metis (no_types, lifting) assms(4) assms(5) bind_returns_result_E get_scdom_component_impl
get_scdom_component_ptrs_same_scope_component is_OK_returns_result_I
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_scdom_component_def local.get_owner_document_ptr_in_heap)
lemma get_scdom_component_contains_get_dom_component:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
obtains c where "h \<turnstile> get_dom_component ptr' \<rightarrow>\<^sub>r c" and "set c \<subseteq> set sc"
proof -
have "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
using assms(1) assms(2) assms(3) assms(4) assms(5) get_scdom_component_ptrs_same_scope_component
by blast
then show ?thesis
by (meson assms(1) assms(2) assms(3) assms(5) get_scdom_component_ptr_in_heap
get_scdom_component_subset_get_dom_component is_OK_returns_result_E local.get_dom_component_ok that)
qed
lemma get_scdom_component_owner_document_same:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "ptr' \<in> set sc"
obtains owner_document where "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document" and "cast owner_document \<in> set sc"
using assms
apply(auto simp add: get_scdom_component_def elim!: bind_returns_result_E2 intro!: map_M_pure_I)[1]
apply (metis (no_types, lifting) assms(4) assms(5) document_ptr_casts_commute3
document_ptr_document_ptr_cast get_scdom_component_contains_get_dom_component local.get_dom_component_ptr
local.get_dom_component_root_node_same local.get_dom_component_to_tree_order local.get_root_node_document
local.get_root_node_not_node_same local.to_tree_order_ptr_in_result local.to_tree_order_ptrs_in_heap
node_ptr_no_document_ptr_cast)
apply(rule map_M_pure_E2)
apply(simp)
apply(simp)
apply(simp)
by (smt (verit) assms(4) assms(5) comp_apply get_scdom_component_ptr_in_heap is_OK_returns_result_E
local.get_owner_document_disconnected_nodes local.get_root_node_ok local.get_root_node_same_owner_document
local.to_tree_order_get_root_node local.to_tree_order_ptr_in_result)
lemma get_scdom_component_different_owner_documents:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
assumes "h \<turnstile> get_owner_document ptr' \<rightarrow>\<^sub>r owner_document'"
assumes "owner_document \<noteq> owner_document'"
shows "set |h \<turnstile> get_scdom_component ptr|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component ptr'|\<^sub>r = {}"
using assms get_scdom_component_ptrs_same_owner_document
by (smt (verit) disjoint_iff_not_equal get_scdom_component_ok is_OK_returns_result_I
local.get_owner_document_ptr_in_heap returns_result_eq returns_result_select_result)
end
interpretation i_get_dom_component_get_scdom_component?: l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_owner_document
get_disconnected_nodes get_disconnected_nodes_locs to_tree_order heap_is_wellformed parent_child_rel
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node
get_root_node_locs get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name
by(auto simp add: l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_dom_component_get_scdom_component_is_l_get_dom_component_get_scdom_component [instances]:
"l_get_dom_component_get_scdom_component get_owner_document heap_is_wellformed type_wf known_ptr known_ptrs get_scdom_component get_dom_component"
apply(auto simp add: l_get_dom_component_get_scdom_component_def
l_get_dom_component_get_scdom_component_axioms_def instances)[1]
using get_scdom_component_subset_get_dom_component apply fast
using get_scdom_component_ptrs_same_scope_component apply fast
using get_scdom_component_ptrs_same_owner_document apply fast
using get_scdom_component_ok apply fast
using get_scdom_component_ptr_in_heap apply fast
using get_scdom_component_contains_get_dom_component apply blast
using get_scdom_component_owner_document_same apply blast
using get_scdom_component_different_owner_documents apply fast
done
subsection \<open>attach\_shadow\_root\<close>
lemma attach_shadow_root_not_strongly_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'ShadowRoot::{equal,linorder}) heap" and
h' and host and new_shadow_root_ptr where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> attach_shadow_root host m \<rightarrow>\<^sub>r new_shadow_root_ptr \<rightarrow>\<^sub>h h'" and
"\<not> is_strongly_scdom_component_safe {cast host} {cast new_shadow_root_ptr} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder},
'ShadowRoot::{equal,linorder}) heap"
let ?P = "do {
doc \<leftarrow> create_document;
create_element doc ''div''
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e1 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and host="?e1"])
by code_simp+
qed
locale l_get_scdom_component_attach_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_dom_component_attach_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_scdom_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma attach_shadow_root_is_weakly_component_safe_step:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>h h'"
assumes "ptr \<noteq> cast |h \<turnstile> attach_shadow_root element_ptr shadow_root_mode|\<^sub>r"
assumes "ptr \<notin> set |h \<turnstile> get_scdom_component (cast element_ptr)|\<^sub>r"
shows "preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
proof -
have "element_ptr |\<in>| element_ptr_kinds h"
by (meson assms(4) is_OK_returns_heap_I local.attach_shadow_root_element_ptr_in_heap)
obtain sc where sc: "h \<turnstile> get_scdom_component (cast element_ptr) \<rightarrow>\<^sub>r sc"
using get_scdom_component_ok
by (meson assms(1) assms(2) assms(3) assms(4) element_ptr_kinds_commutes is_OK_returns_heap_I
local.attach_shadow_root_element_ptr_in_heap node_ptr_kinds_commutes select_result_I)
then have "ptr \<notin> set |h \<turnstile> get_dom_component (cast element_ptr)|\<^sub>r"
by (metis (no_types, lifting) \<open>element_ptr |\<in>| element_ptr_kinds h\<close> assms(1) assms(2) assms(3)
assms(6) element_ptr_kinds_commutes local.get_dom_component_ok
local.get_scdom_component_subset_get_dom_component node_ptr_kinds_commutes
returns_result_select_result select_result_I2 set_rev_mp)
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) assms(5) local.attach_shadow_root_is_weakly_dom_component_safe
by blast
qed
lemma attach_shadow_root_is_weakly_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>r result"
assumes "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>h h'"
shows "is_weakly_scdom_component_safe {cast element_ptr} {cast result} h h'"
proof -
obtain h2 h3 new_shadow_root_ptr where
h2: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2" and
new_shadow_root_ptr: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr" and
h3: "h2 \<turnstile> set_mode new_shadow_root_ptr shadow_root_mode \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: attach_shadow_root_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
have "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>r new_shadow_root_ptr"
using new_shadow_root_ptr h2 h3 h'
using assms(5)
by(auto simp add: attach_shadow_root_def intro!: bind_returns_result_I
bind_pure_returns_result_I[OF get_tag_name_pure] bind_pure_returns_result_I[OF get_shadow_root_pure]
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
then
have "object_ptr_kinds h2 = {|cast result|} |\<union>| object_ptr_kinds h"
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr
using new_shadow_root_ptr
using assms(4) by auto
moreover
have object_ptr_kinds_eq_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_mode_writes h3])
using set_mode_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
moreover
have object_ptr_kinds_eq_h3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_shadow_root_writes h'])
using set_shadow_root_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
ultimately have "object_ptr_kinds h' = {|cast result|} |\<union>| object_ptr_kinds h"
by simp
moreover
have "result |\<notin>| shadow_root_ptr_kinds h"
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap new_shadow_root_ptr
using \<open>h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>r new_shadow_root_ptr\<close> assms(4)
returns_result_eq by metis
ultimately
show ?thesis
using assms
apply(auto simp add: is_weakly_scdom_component_safe_def Let_def)[1]
using attach_shadow_root_is_weakly_component_safe_step
by (smt (verit) document_ptr_kinds_commutes local.get_scdom_component_impl select_result_I2
shadow_root_ptr_kinds_commutes)
qed
end
interpretation i_get_scdom_component_attach_shadow_root?: l_get_scdom_component_attach_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe to_tree_order
get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
set_shadow_root set_shadow_root_locs set_mode set_mode_locs attach_shadow_root get_disconnected_nodes
get_disconnected_nodes_locs get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs
by(auto simp add: l_get_scdom_component_attach_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_attach_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>get\_shadow\_root\<close>
lemma get_shadow_root_not_weakly_scdom_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder}, 'CharacterData::{equal,linorder},
'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap" and
element_ptr and shadow_root_ptr_opt and h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> get_shadow_root_safe element_ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_scdom_component_safe {cast element_ptr} (cast ` set_option shadow_root_ptr_opt) h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder}, 'CharacterData::{equal,linorder},
'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
html \<leftarrow> create_element document_ptr ''html'';
append_child (cast document_ptr) (cast html);
head \<leftarrow> create_element document_ptr ''head'';
append_child (cast html) (cast head);
body \<leftarrow> create_element document_ptr ''body'';
append_child (cast html) (cast body);
e1 \<leftarrow> create_element document_ptr ''div'';
append_child (cast body) (cast e1);
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
s1 \<leftarrow> attach_shadow_root e1 Open;
e3 \<leftarrow> create_element document_ptr ''slot'';
append_child (cast s1) (cast e3);
return e1
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e1 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and element_ptr="?e1"])
by code_simp+
qed
locale l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_scdom_component +
l_get_shadow_root_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_create_document +
l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_mode +
l_get_scdom_component\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
assumes known_ptrs_impl: "known_ptrs = a_known_ptrs"
begin
lemma get_shadow_root_components_disjunct:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
shows "set |h \<turnstile> get_scdom_component (cast host)|\<^sub>r \<inter> set | h \<turnstile> get_scdom_component (cast shadow_root_ptr)|\<^sub>r = {}"
proof -
obtain owner_document where owner_document: "h \<turnstile> get_owner_document (cast host) \<rightarrow>\<^sub>r owner_document"
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(5) element_ptr_kinds_commutes
is_OK_returns_result_E is_OK_returns_result_I local.get_dom_component_ok local.get_dom_component_ptr
local.get_scdom_component_ok local.get_scdom_component_owner_document_same
local.get_scdom_component_subset_get_dom_component local.get_shadow_root_ptr_in_heap node_ptr_kinds_commutes
subset_code(1))
have "owner_document \<noteq> cast shadow_root_ptr"
proof
assume "owner_document = cast shadow_root_ptr"
then have "(cast owner_document, cast host) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using get_owner_document_rel owner_document
by (metis (no_types, lifting) assms(1) assms(2) assms(3) cast_document_ptr_not_node_ptr(2)
in_rtrancl_UnI inf_sup_aci(6) inf_sup_aci(7))
then have "(cast shadow_root_ptr, cast host) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
by (simp add: \<open>owner_document = cast shadow_root_ptr\<close>)
moreover have "(cast host, cast shadow_root_ptr) \<in> a_host_shadow_root_rel h"
by (metis (mono_tags, lifting) assms(5) is_OK_returns_result_I local.get_shadow_root_ptr_in_heap
local.a_host_shadow_root_rel_def mem_Collect_eq pair_imageI prod.simps(2) select_result_I2)
then have "(cast host, cast shadow_root_ptr) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
by (simp)
ultimately show False
using assms(1)
unfolding heap_is_wellformed_def \<open>owner_document = cast shadow_root_ptr\<close> acyclic_def
by (meson rtrancl_into_trancl1)
qed
moreover
have "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms(1) assms(5) local.get_shadow_root_shadow_root_ptr_in_heap by blast
then
have "cast shadow_root_ptr \<in> fset (object_ptr_kinds h)"
by auto
have "is_shadow_root_ptr shadow_root_ptr"
using assms(3)[unfolded known_ptrs_impl ShadowRootClass.known_ptrs_defs
ShadowRootClass.known_ptr_defs DocumentClass.known_ptr_defs CharacterDataClass.known_ptr_defs
ElementClass.known_ptr_defs NodeClass.known_ptr_defs, simplified, rule_format, OF
\<open>cast shadow_root_ptr \<in> fset (object_ptr_kinds h)\<close>]
by(auto simp add: is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
split: option.splits document_ptr.splits)
then
have "h \<turnstile> get_owner_document (cast shadow_root_ptr) \<rightarrow>\<^sub>r cast shadow_root_ptr"
using \<open>shadow_root_ptr |\<in>| shadow_root_ptr_kinds h\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
by(auto simp add: is_node_ptr_kind_none a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)
ultimately show ?thesis
using assms(1) assms(2) assms(3) get_scdom_component_different_owner_documents owner_document
by blast
qed
lemma get_shadow_root_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_shadow_root_safe element_ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt \<rightarrow>\<^sub>h h'"
assumes "\<forall>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h). h \<turnstile> get_mode shadow_root_ptr \<rightarrow>\<^sub>r Closed"
shows "is_strongly_scdom_component_safe {cast element_ptr} (cast ` set_option shadow_root_ptr_opt) h h'"
proof -
have "h = h'"
using assms(4)
by(auto simp add: returns_result_heap_def pure_returns_heap_eq)
moreover have "shadow_root_ptr_opt = None"
using assms(4)
apply(auto simp add: returns_result_heap_def get_shadow_root_safe_def elim!: bind_returns_result_E2
split: option.splits if_splits)[1]
using get_shadow_root_shadow_root_ptr_in_heap
by (meson assms(5) is_OK_returns_result_I local.get_mode_ptr_in_heap notin_fset returns_result_eq
shadow_root_mode.distinct(1))
ultimately show ?thesis
by(simp add: is_strongly_scdom_component_safe_def preserved_def)
qed
end
interpretation i_get_shadow_root_scope_component?: l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe get_dom_component
is_strongly_dom_component_safe is_weakly_dom_component_safe get_shadow_root get_shadow_root_locs
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_tag_name
get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs to_tree_order get_parent get_parent_locs get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
remove_shadow_root remove_shadow_root_locs create_document DocumentClass.known_ptr DocumentClass.type_wf
CD.a_get_owner_document get_mode get_mode_locs get_shadow_root_safe get_shadow_root_safe_locs
by(auto simp add: l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>get\_host\<close>
lemma get_host_not_weakly_scdom_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap" and
shadow_root_ptr and element_ptr and h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r element_ptr \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_scdom_component_safe {cast shadow_root_ptr} {cast element_ptr} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder},
'Shadowroot::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
html \<leftarrow> create_element document_ptr ''html'';
append_child (cast document_ptr) (cast html);
head \<leftarrow> create_element document_ptr ''head'';
append_child (cast html) (cast head);
body \<leftarrow> create_element document_ptr ''body'';
append_child (cast html) (cast body);
e1 \<leftarrow> create_element document_ptr ''div'';
append_child (cast body) (cast e1);
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
s1 \<leftarrow> attach_shadow_root e1 Open;
e3 \<leftarrow> create_element document_ptr ''slot'';
append_child (cast s1) (cast e3);
return s1
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?s1 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and shadow_root_ptr="?s1"])
by code_simp+
qed
locale l_get_host_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_host_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_host_components_disjunct:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_scdom_component ptr \<rightarrow>\<^sub>r sc"
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
shows "set |h \<turnstile> get_scdom_component (cast host)|\<^sub>r \<inter> set | h \<turnstile> get_scdom_component (cast shadow_root_ptr)|\<^sub>r = {}"
using assms get_shadow_root_components_disjunct local.shadow_root_host_dual
by blast
end
interpretation i_get_host_scope_component?: l_get_host_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document heap_is_wellformed parent_child_rel type_wf known_ptr
known_ptrs get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe get_shadow_root
get_shadow_root_locs get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_tag_name get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs to_tree_order get_parent get_parent_locs get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
remove_shadow_root remove_shadow_root_locs create_document DocumentClass.known_ptr DocumentClass.type_wf
CD.a_get_owner_document get_mode get_mode_locs get_shadow_root_safe get_shadow_root_safe_locs
by(auto simp add: l_get_host_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_host_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>get\_root\_node\_si\<close>
lemma get_composed_root_node_not_weakly_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap" and
ptr and root and h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_scdom_component_safe {ptr} {root} h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder},
'Shadowroot::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
html \<leftarrow> create_element document_ptr ''html'';
append_child (cast document_ptr) (cast html);
head \<leftarrow> create_element document_ptr ''head'';
append_child (cast html) (cast head);
body \<leftarrow> create_element document_ptr ''body'';
append_child (cast html) (cast body);
e1 \<leftarrow> create_element document_ptr ''div'';
append_child (cast body) (cast e1);
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
s1 \<leftarrow> attach_shadow_root e1 Closed;
e3 \<leftarrow> create_element document_ptr ''slot'';
append_child (cast s1) (cast e3);
return e3
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e3 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and ptr="cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ?e3"])
by code_simp+
qed
locale l_get_scdom_component_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_dom_component_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_dom_component_get_scdom_component
begin
lemma get_root_node_si_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node_si ptr' \<rightarrow>\<^sub>r root"
shows "set |h \<turnstile> get_scdom_component ptr'|\<^sub>r = set |h \<turnstile> get_scdom_component root|\<^sub>r \<or>
set |h \<turnstile> get_scdom_component ptr'|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component root|\<^sub>r = {}"
proof -
have "ptr' |\<in>| object_ptr_kinds h"
using get_ancestors_si_ptr_in_heap assms(4)
by(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)
then
obtain sc where "h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc"
by (meson assms(1) assms(2) assms(3) local.get_scdom_component_ok select_result_I)
moreover
have "root |\<in>| object_ptr_kinds h"
using get_ancestors_si_ptr assms(4)
apply(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)[1]
by (metis (no_types, lifting) assms(1) assms(2) assms(3) empty_iff empty_set
get_ancestors_si_ptrs_in_heap last_in_set)
then
obtain sc' where "h \<turnstile> get_scdom_component root \<rightarrow>\<^sub>r sc'"
by (meson assms(1) assms(2) assms(3) local.get_scdom_component_ok select_result_I)
ultimately show ?thesis
by (metis (no_types, opaque_lifting) IntE \<open>\<And>thesis. (\<And>sc'. h \<turnstile> get_scdom_component root \<rightarrow>\<^sub>r sc' \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
\<open>\<And>thesis. (\<And>sc. h \<turnstile> get_scdom_component ptr' \<rightarrow>\<^sub>r sc \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> assms(1) assms(2) assms(3) empty_subsetI
local.get_scdom_component_ptrs_same_scope_component returns_result_eq select_result_I2 subsetI subset_antisym)
qed
end
interpretation i_get_scdom_component_get_root_node_si?: l_get_scdom_component_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_host
get_host_locs get_ancestors_si get_ancestors_si_locs get_root_node_si get_root_node_si_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document get_disconnected_document_locs to_tree_order
get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe get_root_node get_root_node_locs
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
get_owner_document get_scdom_component is_strongly_scdom_component_safe
by(auto simp add: l_get_scdom_component_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_scdom_component_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsection \<open>get\_assigned\_nodes\<close>
lemma assigned_nodes_not_weakly_scdom_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap" and
node_ptr and nodes and h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> assigned_nodes node_ptr \<rightarrow>\<^sub>r nodes \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_scdom_component_safe {cast node_ptr} (cast ` set nodes) h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
html \<leftarrow> create_element document_ptr ''html'';
append_child (cast document_ptr) (cast html);
head \<leftarrow> create_element document_ptr ''head'';
append_child (cast html) (cast head);
body \<leftarrow> create_element document_ptr ''body'';
append_child (cast html) (cast body);
e1 \<leftarrow> create_element document_ptr ''div'';
append_child (cast body) (cast e1);
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
s1 \<leftarrow> attach_shadow_root e1 Closed;
e3 \<leftarrow> create_element document_ptr ''slot'';
append_child (cast s1) (cast e3);
return e3
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e3 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and node_ptr="?e3"])
by code_simp+
qed
lemma assigned_slot_not_weakly_component_safe:
obtains
h :: "('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder}, 'element_ptr::{equal,linorder},
'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder}, 'shadow_root_ptr::{equal,linorder},
'Object::{equal,linorder}, 'Node::{equal,linorder}, 'Element::{equal,linorder},
'CharacterData::{equal,linorder}, 'Document::{equal,linorder}, 'Shadowroot::{equal,linorder}) heap" and
node_ptr and slot_opt and h' where
"heap_is_wellformed h" and "type_wf h" and "known_ptrs h" and
"h \<turnstile> assigned_slot node_ptr \<rightarrow>\<^sub>r slot_opt \<rightarrow>\<^sub>h h'" and
"\<not> is_weakly_scdom_component_safe {cast node_ptr} (cast ` set_option slot_opt) h h'"
proof -
let ?h0 = "Heap fmempty ::('object_ptr::{equal,linorder}, 'node_ptr::{equal,linorder},
'element_ptr::{equal,linorder}, 'character_data_ptr::{equal,linorder}, 'document_ptr::{equal,linorder},
'shadow_root_ptr::{equal,linorder}, 'Object::{equal,linorder}, 'Node::{equal,linorder},
'Element::{equal,linorder}, 'CharacterData::{equal,linorder}, 'Document::{equal,linorder},
'Shadowroot::{equal,linorder}) heap"
let ?P = "do {
document_ptr \<leftarrow> create_document;
html \<leftarrow> create_element document_ptr ''html'';
append_child (cast document_ptr) (cast html);
head \<leftarrow> create_element document_ptr ''head'';
append_child (cast html) (cast head);
body \<leftarrow> create_element document_ptr ''body'';
append_child (cast html) (cast body);
e1 \<leftarrow> create_element document_ptr ''div'';
append_child (cast body) (cast e1);
e2 \<leftarrow> create_element document_ptr ''div'';
append_child (cast e1) (cast e2);
s1 \<leftarrow> attach_shadow_root e1 Open;
e3 \<leftarrow> create_element document_ptr ''slot'';
append_child (cast s1) (cast e3);
return e2
}"
let ?h1 = "|?h0 \<turnstile> ?P|\<^sub>h"
let ?e2 = "|?h0 \<turnstile> ?P|\<^sub>r"
show thesis
apply(rule that[where h="?h1" and node_ptr="cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ?e2"])
by code_simp+
qed
locale l_assigned_nodes_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_assigned_nodes_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma find_slot_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> find_slot open_flag node_ptr \<rightarrow>\<^sub>r Some slot"
shows "set |h \<turnstile> get_scdom_component (cast node_ptr)|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component (cast slot)|\<^sub>r = {}"
proof -
obtain host shadow_root_ptr to where
"h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some (cast host)" and
"h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr" and
"h \<turnstile> to_tree_order (cast shadow_root_ptr) \<rightarrow>\<^sub>r to" and
"cast slot \<in> set to"
using assms(4)
apply(auto simp add: find_slot_def first_in_tree_order_def elim!: bind_returns_result_E2
map_filter_M_pure_E[where y=slot] split: option.splits if_splits list.splits
intro!: map_filter_M_pure bind_pure_I)[1]
by (metis element_ptr_casts_commute3)+
have "node_ptr |\<in>| node_ptr_kinds h"
using assms(4) find_slot_ptr_in_heap by blast
then obtain node_ptr_c where node_ptr_c: "h \<turnstile> get_scdom_component (cast node_ptr) \<rightarrow>\<^sub>r node_ptr_c"
using assms(1) assms(2) assms(3) get_scdom_component_ok is_OK_returns_result_E
node_ptr_kinds_commutes[symmetric]
by metis
then have "cast host \<in> set node_ptr_c"
using \<open>h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some (cast host)\<close> assms(1) assms(2) assms(3)
by (meson assms(4) is_OK_returns_result_E local.find_slot_ptr_in_heap local.get_dom_component_ok
local.get_dom_component_parent_inside local.get_dom_component_ptr
local.get_scdom_component_subset_get_dom_component node_ptr_kinds_commutes subsetCE)
then have "h \<turnstile> get_scdom_component (cast host) \<rightarrow>\<^sub>r node_ptr_c"
using \<open>h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r Some (cast host)\<close> a_heap_is_wellformed_def assms(1) assms(2)
assms(3) node_ptr_c
using local.get_scdom_component_ptrs_same_scope_component by blast
moreover have "slot |\<in>| element_ptr_kinds h"
using assms(4) find_slot_slot_in_heap by blast
then obtain slot_c where slot_c: "h \<turnstile> get_scdom_component (cast slot) \<rightarrow>\<^sub>r slot_c"
using a_heap_is_wellformed_def assms(1) assms(2) assms(3) get_scdom_component_ok
is_OK_returns_result_E node_ptr_kinds_commutes[symmetric] element_ptr_kinds_commutes[symmetric]
by (smt (verit, best))
then have "cast shadow_root_ptr \<in> set slot_c"
using \<open>h \<turnstile> to_tree_order (cast shadow_root_ptr) \<rightarrow>\<^sub>r to\<close> \<open>cast slot \<in> set to\<close> assms(1) assms(2) assms(3)
by (meson is_OK_returns_result_E local.get_dom_component_ok local.get_dom_component_ptr
local.get_dom_component_to_tree_order local.get_scdom_component_subset_get_dom_component local.to_tree_order_ptrs_in_heap subsetCE)
then have "h \<turnstile> get_scdom_component (cast shadow_root_ptr) \<rightarrow>\<^sub>r slot_c"
using \<open>h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1) assms(2) assms(3) slot_c
using local.get_scdom_component_ptrs_same_scope_component by blast
ultimately show ?thesis
using get_shadow_root_components_disjunct assms \<open>h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr\<close>
node_ptr_c slot_c
by (metis (no_types, lifting) select_result_I2)
qed
lemma assigned_nodes_is_component_unsafe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> assigned_nodes element_ptr \<rightarrow>\<^sub>r nodes"
assumes "node_ptr \<in> set nodes"
shows "set |h \<turnstile> get_scdom_component (cast element_ptr)|\<^sub>r \<inter> set |h \<turnstile> get_scdom_component (cast node_ptr)|\<^sub>r = {}"
using assms
proof -
have "h \<turnstile> find_slot False node_ptr \<rightarrow>\<^sub>r Some element_ptr"
using assms(4) assms(5)
by(auto simp add: assigned_nodes_def elim!: bind_returns_result_E2
dest!: filter_M_holds_for_result[where x=node_ptr] intro!: bind_pure_I split: if_splits)
then show ?thesis
using assms find_slot_is_component_unsafe
by blast
qed
lemma assigned_slot_is_strongly_scdom_component_safe:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> assigned_slot element_ptr \<rightarrow>\<^sub>r slot_opt \<rightarrow>\<^sub>h h'"
assumes "\<forall>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h). h \<turnstile> get_mode shadow_root_ptr \<rightarrow>\<^sub>r Closed"
shows "is_strongly_scdom_component_safe {cast element_ptr} (cast ` set_option slot_opt) h h'"
proof -
have "h = h'"
using assms(4) find_slot_pure
by(auto simp add: assigned_slot_def returns_result_heap_def pure_returns_heap_eq find_slot_impl)
moreover have "slot_opt = None"
using assms(4) assms(5)
apply(auto simp add: returns_result_heap_def assigned_slot_def a_find_slot_def
elim!: bind_returns_result_E2 split: option.splits if_splits
dest!: get_shadow_root_shadow_root_ptr_in_heap[OF assms(1)])[1]
apply (meson finite_set_in returns_result_eq shadow_root_mode.distinct(1))
apply (meson finite_set_in returns_result_eq shadow_root_mode.distinct(1))
done
ultimately show ?thesis
by(auto simp add: is_strongly_scdom_component_safe_def preserved_def)
qed
end
interpretation i_assigned_nodes_scope_component?: l_assigned_nodes_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_tag_name get_tag_name_locs known_ptr get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs
get_disconnected_document get_disconnected_document_locs get_parent get_parent_locs
get_mode get_mode_locs get_attribute get_attribute_locs first_in_tree_order find_slot
assigned_slot known_ptrs to_tree_order assigned_nodes assigned_nodes_flatten flatten_dom
get_root_node get_root_node_locs remove insert_before insert_before_locs append_child
remove_shadow_root remove_shadow_root_locs set_shadow_root set_shadow_root_locs remove_child
remove_child_locs get_dom_component is_strongly_dom_component_safe is_weakly_dom_component_safe
get_ancestors get_ancestors_locs get_element_by_id get_elements_by_class_name get_elements_by_tag_name
get_owner_document set_disconnected_nodes set_disconnected_nodes_locs get_ancestors_di get_ancestors_di_locs
adopt_node adopt_node_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes set_child_nodes_locs
get_scdom_component is_strongly_scdom_component_safe is_weakly_scdom_component_safe create_document
DocumentClass.known_ptr DocumentClass.type_wf CD.a_get_owner_document get_shadow_root_safe
get_shadow_root_safe_locs
by(auto simp add: l_assigned_nodes_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_assigned_nodes_scope_component\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/Safe_OCL/Finite_Map_Ext.thy b/thys/Safe_OCL/Finite_Map_Ext.thy
--- a/thys/Safe_OCL/Finite_Map_Ext.thy
+++ b/thys/Safe_OCL/Finite_Map_Ext.thy
@@ -1,445 +1,445 @@
(* Title: Safe OCL
Author: Denis Nikiforov, March 2019
Maintainer: Denis Nikiforov <denis.nikif at gmail.com>
License: LGPL
*)
section \<open>Finite Maps\<close>
theory Finite_Map_Ext
imports "HOL-Library.Finite_Map"
begin
type_notation fmap ("(_ \<rightharpoonup>\<^sub>f /_)" [22, 21] 21)
nonterminal fmaplets and fmaplet
syntax
"_fmaplet" :: "['a, 'a] \<Rightarrow> fmaplet" ("_ /\<mapsto>\<^sub>f/ _")
"_fmaplets" :: "['a, 'a] \<Rightarrow> fmaplet" ("_ /[\<mapsto>\<^sub>f]/ _")
"" :: "fmaplet \<Rightarrow> fmaplets" ("_")
"_FMaplets" :: "[fmaplet, fmaplets] \<Rightarrow> fmaplets" ("_,/ _")
"_FMapUpd" :: "['a \<rightharpoonup> 'b, fmaplets] \<Rightarrow> 'a \<rightharpoonup> 'b" ("_/'(_')" [900, 0] 900)
"_FMap" :: "fmaplets \<Rightarrow> 'a \<rightharpoonup> 'b" ("(1[_])")
syntax (ASCII)
"_fmaplet" :: "['a, 'a] \<Rightarrow> fmaplet" ("_ /|->f/ _")
"_fmaplets" :: "['a, 'a] \<Rightarrow> fmaplet" ("_ /[|->f]/ _")
translations
"_FMapUpd m (_FMaplets xy ms)" \<rightleftharpoons> "_FMapUpd (_FMapUpd m xy) ms"
"_FMapUpd m (_fmaplet x y)" \<rightleftharpoons> "CONST fmupd x y m"
"_FMap ms" \<rightleftharpoons> "_FMapUpd (CONST fmempty) ms"
"_FMap (_FMaplets ms1 ms2)" \<leftharpoondown> "_FMapUpd (_FMap ms1) ms2"
"_FMaplets ms1 (_FMaplets ms2 ms3)" \<leftharpoondown> "_FMaplets (_FMaplets ms1 ms2) ms3"
(*** Helper Lemmas **********************************************************)
subsection \<open>Helper Lemmas\<close>
lemma fmrel_on_fset_fmdom:
"fmrel_on_fset (fmdom ym) f xm ym \<Longrightarrow>
k |\<in>| fmdom ym \<Longrightarrow>
k |\<in>| fmdom xm"
by (metis fmdom_notD fmdom_notI fmrel_on_fsetD option.rel_sel)
(*** Finite Map Merge *******************************************************)
subsection \<open>Merge Operation\<close>
definition "fmmerge f xm ym \<equiv>
fmap_of_list (map
(\<lambda>k. (k, f (the (fmlookup xm k)) (the (fmlookup ym k))))
(sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)))"
lemma fmdom_fmmerge [simp]:
"fmdom (fmmerge g xm ym) = fmdom xm |\<inter>| fmdom ym"
by (auto simp add: fmmerge_def fmdom_of_list)
lemma fmmerge_commut:
assumes "\<And>x y. x \<in> fmran' xm \<Longrightarrow> f x y = f y x"
shows "fmmerge f xm ym = fmmerge f ym xm"
proof -
obtain zm where zm: "zm = sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)"
by auto
with assms have
"map (\<lambda>k. (k, f (the (fmlookup xm k)) (the (fmlookup ym k)))) zm =
map (\<lambda>k. (k, f (the (fmlookup ym k)) (the (fmlookup xm k)))) zm"
by (auto) (metis fmdom_notI fmran'I notin_fset option.collapse)
thus ?thesis
unfolding fmmerge_def zm
by (metis (no_types, lifting) inf_commute)
qed
lemma fmrel_on_fset_fmmerge1 [intro]:
assumes "\<And>x y z. z \<in> fmran' zm \<Longrightarrow> f x z \<Longrightarrow> f y z \<Longrightarrow> f (g x y) z"
assumes "fmrel_on_fset (fmdom zm) f xm zm"
assumes "fmrel_on_fset (fmdom zm) f ym zm"
shows "fmrel_on_fset (fmdom zm) f (fmmerge g xm ym) zm"
proof -
{
fix x a b c
assume "x |\<in>| fmdom zm"
moreover hence "x |\<in>| fmdom xm |\<inter>| fmdom ym"
by (meson assms(2) assms(3) finterI fmrel_on_fset_fmdom)
moreover assume "fmlookup xm x = Some a"
and "fmlookup ym x = Some b"
and "fmlookup zm x = Some c"
moreover from assms calculation have "f (g a b) c"
by (metis fmran'I fmrel_on_fsetD option.rel_inject(2))
ultimately have
"rel_option f (fmlookup (fmmerge g xm ym) x) (fmlookup zm x)"
unfolding fmmerge_def fmlookup_of_list apply auto
unfolding option_rel_Some2 apply (rule_tac ?x="g a b" in exI)
unfolding map_of_map_restrict restrict_map_def
- by (auto simp: fmember.rep_eq)
+ by (auto simp: fmember_iff_member_fset)
}
with assms(2) assms(3) show ?thesis
by (meson fmdomE fmrel_on_fsetI fmrel_on_fset_fmdom)
qed
lemma fmrel_on_fset_fmmerge2 [intro]:
assumes "\<And>x y. x \<in> fmran' xm \<Longrightarrow> f x (g x y)"
shows "fmrel_on_fset (fmdom ym) f xm (fmmerge g xm ym)"
proof -
{
fix x a b
assume "x |\<in>| fmdom xm |\<inter>| fmdom ym"
and "fmlookup xm x = Some a"
and "fmlookup ym x = Some b"
hence "rel_option f (fmlookup xm x) (fmlookup (fmmerge g xm ym) x)"
unfolding fmmerge_def fmlookup_of_list apply auto
unfolding option_rel_Some1 apply (rule_tac ?x="g a b" in exI)
- by (auto simp add: map_of_map_restrict fmember.rep_eq assms fmran'I)
+ by (auto simp add: map_of_map_restrict fmember_iff_member_fset assms fmran'I)
}
with assms show ?thesis
apply auto
apply (rule fmrel_on_fsetI)
by (metis (full_types) finterD1 fmdomE fmdom_fmmerge fmdom_notD rel_option_None2)
qed
(*** Acyclicity *************************************************************)
subsection \<open>Acyclicity\<close>
abbreviation "acyclic_on xs r \<equiv> (\<forall>x. x \<in> xs \<longrightarrow> (x, x) \<notin> r\<^sup>+)"
abbreviation "acyclicP_on xs r \<equiv> acyclic_on xs {(x, y). r x y}"
lemma fmrel_acyclic:
"acyclicP_on (fmran' xm) R \<Longrightarrow>
fmrel R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
fmrel R ym xm \<Longrightarrow>
xm = ym"
by (metis (full_types) fmap_ext fmran'I fmrel_cases option.sel
tranclp.trancl_into_trancl tranclp_unfold)
lemma fmrel_acyclic':
assumes "acyclicP_on (fmran' ym) R"
assumes "fmrel R\<^sup>+\<^sup>+ xm ym"
assumes "fmrel R ym xm"
shows "xm = ym"
proof -
{
fix x
from assms(1) have
"rel_option R\<^sup>+\<^sup>+ (fmlookup xm x) (fmlookup ym x) \<Longrightarrow>
rel_option R (fmlookup ym x) (fmlookup xm x) \<Longrightarrow>
rel_option R (fmlookup xm x) (fmlookup ym x)"
by (metis (full_types) fmdom'_notD fmlookup_dom'_iff
fmran'I option.rel_sel option.sel
tranclp_into_tranclp2 tranclp_unfold)
}
with assms show ?thesis
unfolding fmrel_iff
by (metis fmap.rel_mono_strong fmrelI fmrel_acyclic tranclp.simps)
qed
lemma fmrel_on_fset_acyclic:
"acyclicP_on (fmran' xm) R \<Longrightarrow>
fmrel_on_fset (fmdom ym) R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
fmrel_on_fset (fmdom xm) R ym xm \<Longrightarrow>
xm = ym"
unfolding fmrel_on_fset_fmrel_restrict
by (metis (no_types, lifting) fmdom_filter fmfilter_alt_defs(5)
fmfilter_cong fmlookup_filter fmrel_acyclic fmrel_fmdom_eq
fmrestrict_fset_dom option.simps(3))
lemma fmrel_on_fset_acyclic':
"acyclicP_on (fmran' ym) R \<Longrightarrow>
fmrel_on_fset (fmdom ym) R\<^sup>+\<^sup>+ xm ym \<Longrightarrow>
fmrel_on_fset (fmdom xm) R ym xm \<Longrightarrow>
xm = ym"
unfolding fmrel_on_fset_fmrel_restrict
by (metis (no_types, lifting) ffmember_filter fmdom_filter
fmfilter_alt_defs(5) fmfilter_cong fmrel_acyclic'
fmrel_fmdom_eq fmrestrict_fset_dom)
(*** Transitive Closures ****************************************************)
subsection \<open>Transitive Closures\<close>
lemma fmrel_trans:
"(\<And>x y z. x \<in> fmran' xm \<Longrightarrow> P x y \<Longrightarrow> Q y z \<Longrightarrow> R x z) \<Longrightarrow>
fmrel P xm ym \<Longrightarrow> fmrel Q ym zm \<Longrightarrow> fmrel R xm zm"
unfolding fmrel_iff
by (metis fmdomE fmdom_notD fmran'I option.rel_inject(2) option.rel_sel)
lemma fmrel_on_fset_trans:
"(\<And>x y z. x \<in> fmran' xm \<Longrightarrow> P x y \<Longrightarrow> Q y z \<Longrightarrow> R x z) \<Longrightarrow>
fmrel_on_fset (fmdom ym) P xm ym \<Longrightarrow>
fmrel_on_fset (fmdom zm) Q ym zm \<Longrightarrow>
fmrel_on_fset (fmdom zm) R xm zm"
apply (rule fmrel_on_fsetI)
unfolding option.rel_sel apply auto
apply (meson fmdom_notI fmrel_on_fset_fmdom)
by (metis fmdom_notI fmran'I fmrel_on_fsetD fmrel_on_fset_fmdom
option.rel_sel option.sel)
lemma trancl_to_fmrel:
"(fmrel f)\<^sup>+\<^sup>+ xm ym \<Longrightarrow> fmrel f\<^sup>+\<^sup>+ xm ym"
apply (induct rule: tranclp_induct)
apply (simp add: fmap.rel_mono_strong)
by (rule fmrel_trans; auto)
lemma fmrel_trancl_fmdom_eq:
"(fmrel f)\<^sup>+\<^sup>+ xm ym \<Longrightarrow> fmdom xm = fmdom ym"
by (induct rule: tranclp_induct; simp add: fmrel_fmdom_eq)
text \<open>
The proof was derived from the accepted answer on the website
Stack Overflow that is available at
@{url "https://stackoverflow.com/a/53585232/632199"}
and provided with the permission of the author of the answer.\<close>
lemma fmupd_fmdrop:
"fmlookup xm k = Some x \<Longrightarrow>
xm = fmupd k x (fmdrop k xm)"
apply (rule fmap_ext)
unfolding fmlookup_drop fmupd_lookup
by auto
lemma fmap_eqdom_Cons1:
assumes "fmlookup xm i = None"
and "fmdom (fmupd i x xm) = fmdom ym"
and "fmrel R (fmupd i x xm) ym"
shows "(\<exists>z zm. fmlookup zm i = None \<and> ym = (fmupd i z zm) \<and>
R x z \<and> fmrel R xm zm)"
proof -
from assms(2) obtain y where "fmlookup ym i = Some y" by force
then obtain z zm where z_zm: "ym = fmupd i z zm \<and> fmlookup zm i = None"
using fmupd_fmdrop by force
{
assume "\<not> R x z"
with z_zm have "\<not> fmrel R (fmupd i x xm) ym"
by (metis fmrel_iff fmupd_lookup option.simps(11))
}
with assms(3) moreover have "R x z" by auto
{
assume "\<not> fmrel R xm zm"
with assms(1) have "\<not> fmrel R (fmupd i x xm) ym"
by (metis fmrel_iff fmupd_lookup option.rel_sel z_zm)
}
with assms(3) moreover have "fmrel R xm zm" by auto
ultimately show ?thesis using z_zm by blast
qed
text \<open>
The proof was derived from the accepted answer on the website
Stack Overflow that is available at
@{url "https://stackoverflow.com/a/53585232/632199"}
and provided with the permission of the author of the answer.\<close>
lemma fmap_eqdom_induct [consumes 2, case_names nil step]:
assumes R: "fmrel R xm ym"
and dom_eq: "fmdom xm = fmdom ym"
and nil: "P (fmap_of_list []) (fmap_of_list [])"
and step:
"\<And>x xm y ym i.
\<lbrakk>R x y; fmrel R xm ym; fmdom xm = fmdom ym; P xm ym\<rbrakk> \<Longrightarrow>
P (fmupd i x xm) (fmupd i y ym)"
shows "P xm ym"
using R dom_eq
proof (induct xm arbitrary: ym)
case fmempty thus ?case
by (metis fempty_iff fmdom_empty fmempty_of_list fmfilter_alt_defs(5)
fmfilter_false fmrestrict_fset_dom local.nil)
next
case (fmupd i x xm) show ?case
proof -
obtain y where "fmlookup ym i = Some y"
by (metis fmupd.prems(1) fmrel_cases fmupd_lookup option.discI)
from fmupd.hyps(2) fmupd.prems(1) fmupd.prems(2) obtain z zm where
"fmlookup zm i = None" and
ym_eq_z_zm: "ym = (fmupd i z zm)" and
R_x_z: "R x z" and
R_xm_zm: "fmrel R xm zm"
using fmap_eqdom_Cons1 by metis
hence dom_xm_eq_dom_zm: "fmdom xm = fmdom zm"
using fmrel_fmdom_eq by blast
with R_xm_zm fmupd.hyps(1) have "P xm zm" by blast
with R_x_z R_xm_zm dom_xm_eq_dom_zm have
"P (fmupd i x xm) (fmupd i z zm)"
by (rule step)
thus ?thesis by (simp add: ym_eq_z_zm)
qed
qed
text \<open>
The proof was derived from the accepted answer on the website
Stack Overflow that is available at
@{url "https://stackoverflow.com/a/53585232/632199"}
and provided with the permission of the author of the answer.\<close>
lemma fmrel_to_rtrancl:
assumes as_r: "reflp r"
and rel_rpp_xm_ym: "fmrel r\<^sup>*\<^sup>* xm ym"
shows "(fmrel r)\<^sup>*\<^sup>* xm ym"
proof -
from rel_rpp_xm_ym have "fmdom xm = fmdom ym"
using fmrel_fmdom_eq by blast
with rel_rpp_xm_ym show "(fmrel r)\<^sup>*\<^sup>* xm ym"
proof (induct rule: fmap_eqdom_induct)
case nil show ?case by auto
next
case (step x xm y ym i) show ?case
proof -
from step.hyps(1) have "(fmrel r)\<^sup>*\<^sup>* (fmupd i x xm) (fmupd i y xm)"
proof (induct rule: rtranclp_induct)
case base show ?case by simp
next
case (step y z) show ?case
proof -
from as_r have "fmrel r xm xm"
by (simp add: fmap.rel_reflp reflpD)
with step.hyps(2) have "(fmrel r)\<^sup>*\<^sup>* (fmupd i y xm) (fmupd i z xm)"
by (simp add: fmrel_upd r_into_rtranclp)
with step.hyps(3) show ?thesis by simp
qed
qed
also from step.hyps(4) have "(fmrel r)\<^sup>*\<^sup>* (fmupd i y xm) (fmupd i y ym)"
proof (induct rule: rtranclp_induct)
case base show ?case by simp
next
case (step ya za) show ?case
proof -
from step.hyps(2) as_r have "(fmrel r)\<^sup>*\<^sup>* (fmupd i y ya) (fmupd i y za)"
by (simp add: fmrel_upd r_into_rtranclp reflp_def)
with step.hyps(3) show ?thesis by simp
qed
qed
finally show ?thesis by simp
qed
qed
qed
text \<open>
The proof was derived from the accepted answer on the website
Stack Overflow that is available at
@{url "https://stackoverflow.com/a/53585232/632199"}
and provided with the permission of the author of the answer.\<close>
lemma fmrel_to_trancl:
assumes "reflp r"
and "fmrel r\<^sup>+\<^sup>+ xm ym"
shows "(fmrel r)\<^sup>+\<^sup>+ xm ym"
proof -
from assms(2) have "fmrel r\<^sup>*\<^sup>* xm ym"
by (drule_tac ?Ra="r\<^sup>*\<^sup>*" in fmap.rel_mono_strong; auto)
with assms(1) have "(fmrel r)\<^sup>*\<^sup>* xm ym"
by (simp add: fmrel_to_rtrancl)
with assms(1) show ?thesis
by (metis fmap.rel_reflp reflpD rtranclpD tranclp.r_into_trancl)
qed
lemma fmrel_tranclp_induct:
"fmrel r\<^sup>+\<^sup>+ a b \<Longrightarrow>
reflp r \<Longrightarrow>
(\<And>y. fmrel r a y \<Longrightarrow> P y) \<Longrightarrow>
(\<And>y z. (fmrel r)\<^sup>+\<^sup>+ a y \<Longrightarrow> fmrel r y z \<Longrightarrow> P y \<Longrightarrow> P z) \<Longrightarrow> P b"
apply (drule fmrel_to_trancl, simp)
by (erule tranclp_induct; simp)
lemma fmrel_converse_tranclp_induct:
"fmrel r\<^sup>+\<^sup>+ a b \<Longrightarrow>
reflp r \<Longrightarrow>
(\<And>y. fmrel r y b \<Longrightarrow> P y) \<Longrightarrow>
(\<And>y z. fmrel r y z \<Longrightarrow> fmrel r\<^sup>+\<^sup>+ z b \<Longrightarrow> P z \<Longrightarrow> P y) \<Longrightarrow> P a"
apply (drule fmrel_to_trancl, simp)
by (erule converse_tranclp_induct; simp add: trancl_to_fmrel)
lemma fmrel_tranclp_trans_induct:
"fmrel r\<^sup>+\<^sup>+ a b \<Longrightarrow>
reflp r \<Longrightarrow>
(\<And>x y. fmrel r x y \<Longrightarrow> P x y) \<Longrightarrow>
(\<And>x y z. fmrel r\<^sup>+\<^sup>+ x y \<Longrightarrow> P x y \<Longrightarrow> fmrel r\<^sup>+\<^sup>+ y z \<Longrightarrow> P y z \<Longrightarrow> P x z) \<Longrightarrow>
P a b"
apply (drule fmrel_to_trancl, simp)
apply (erule tranclp_trans_induct, simp)
using trancl_to_fmrel by blast
(*** Finite Map Size Calculation ********************************************)
subsection \<open>Size Calculation\<close>
text \<open>
The contents of the subsection was derived from the accepted answer
on the website Stack Overflow that is available at
@{url "https://stackoverflow.com/a/53244203/632199"}
and provided with the permission of the author of the answer.\<close>
abbreviation "tcf \<equiv> (\<lambda> v::('a \<times> nat). (\<lambda> r::nat. snd v + r))"
interpretation tcf: comp_fun_commute tcf
proof
fix x y :: "'a \<times> nat"
show "tcf y \<circ> tcf x = tcf x \<circ> tcf y"
proof -
fix z
have "(tcf y \<circ> tcf x) z = snd y + snd x + z" by auto
also have "(tcf x \<circ> tcf y) z = snd y + snd x + z" by auto
finally have "(tcf y \<circ> tcf x) z = (tcf x \<circ> tcf y) z" by auto
thus "(tcf y \<circ> tcf x) = (tcf x \<circ> tcf y)" by auto
qed
qed
lemma ffold_rec_exp:
assumes "k |\<in>| fmdom x"
and "ky = (k, the (fmlookup (fmmap f x) k))"
shows "ffold tcf 0 (fset_of_fmap (fmmap f x)) =
tcf ky (ffold tcf 0 ((fset_of_fmap (fmmap f x)) |-| {|ky|}))"
proof -
have "ky |\<in>| (fset_of_fmap (fmmap f x))"
using assms by auto
thus ?thesis
by (simp add: tcf.ffold_rec)
qed
lemma elem_le_ffold [intro]:
"k |\<in>| fmdom x \<Longrightarrow>
f (the (fmlookup x k)) < Suc (ffold tcf 0 (fset_of_fmap (fmmap f x)))"
by (subst ffold_rec_exp, auto)
lemma elem_le_ffold' [intro]:
"z \<in> fmran' x \<Longrightarrow>
f z < Suc (ffold tcf 0 (fset_of_fmap (fmmap f x)))"
apply (erule fmran'E)
apply (frule fmdomI)
by (subst ffold_rec_exp, auto)
(*** Code Setup *************************************************************)
subsection \<open>Code Setup\<close>
abbreviation "fmmerge_fun f xm ym \<equiv>
fmap_of_list (map
(\<lambda>k. if k |\<in>| fmdom xm \<and> k |\<in>| fmdom ym
then (k, f (the (fmlookup xm k)) (the (fmlookup ym k)))
else (k, undefined))
(sorted_list_of_fset (fmdom xm |\<inter>| fmdom ym)))"
lemma fmmerge_fun_simp [code_abbrev, simp]:
"fmmerge_fun f xm ym = fmmerge f xm ym"
unfolding fmmerge_def
apply (rule_tac ?f="fmap_of_list" in HOL.arg_cong)
by (simp add: notin_fset)
end
diff --git a/thys/Safe_OCL/Object_Model.thy b/thys/Safe_OCL/Object_Model.thy
--- a/thys/Safe_OCL/Object_Model.thy
+++ b/thys/Safe_OCL/Object_Model.thy
@@ -1,489 +1,489 @@
(* Title: Safe OCL
Author: Denis Nikiforov, March 2019
Maintainer: Denis Nikiforov <denis.nikif at gmail.com>
License: LGPL
*)
section \<open>Object Model\<close>
theory Object_Model
imports "HOL-Library.Extended_Nat" Finite_Map_Ext
begin
text \<open>
The section defines a generic object model.\<close>
(*** Type Synonyms **********************************************************)
subsection \<open>Type Synonyms\<close>
type_synonym attr = String.literal
type_synonym assoc = String.literal
type_synonym role = String.literal
type_synonym oper = String.literal
type_synonym param = String.literal
type_synonym elit = String.literal
datatype param_dir = In | Out | InOut
type_synonym 'c assoc_end = "'c \<times> nat \<times> enat \<times> bool \<times> bool"
type_synonym 't param_spec = "param \<times> 't \<times> param_dir"
type_synonym ('t, 'e) oper_spec =
"oper \<times> 't \<times> 't param_spec list \<times> 't \<times> bool \<times> 'e option"
definition "assoc_end_class :: 'c assoc_end \<Rightarrow> 'c \<equiv> fst"
definition "assoc_end_min :: 'c assoc_end \<Rightarrow> nat \<equiv> fst \<circ> snd"
definition "assoc_end_max :: 'c assoc_end \<Rightarrow> enat \<equiv> fst \<circ> snd \<circ> snd"
definition "assoc_end_ordered :: 'c assoc_end \<Rightarrow> bool \<equiv> fst \<circ> snd \<circ> snd \<circ> snd"
definition "assoc_end_unique :: 'c assoc_end \<Rightarrow> bool \<equiv> snd \<circ> snd \<circ> snd \<circ> snd"
definition "oper_name :: ('t, 'e) oper_spec \<Rightarrow> oper \<equiv> fst"
definition "oper_context :: ('t, 'e) oper_spec \<Rightarrow> 't \<equiv> fst \<circ> snd"
definition "oper_params :: ('t, 'e) oper_spec \<Rightarrow> 't param_spec list \<equiv> fst \<circ> snd \<circ> snd"
definition "oper_result :: ('t, 'e) oper_spec \<Rightarrow> 't \<equiv> fst \<circ> snd \<circ> snd \<circ> snd"
definition "oper_static :: ('t, 'e) oper_spec \<Rightarrow> bool \<equiv> fst \<circ> snd \<circ> snd \<circ> snd \<circ> snd"
definition "oper_body :: ('t, 'e) oper_spec \<Rightarrow> 'e option \<equiv> snd \<circ> snd \<circ> snd \<circ> snd \<circ> snd"
definition "param_name ::'t param_spec \<Rightarrow> param \<equiv> fst"
definition "param_type ::'t param_spec \<Rightarrow> 't \<equiv> fst \<circ> snd"
definition "param_dir ::'t param_spec \<Rightarrow> param_dir \<equiv> snd \<circ> snd"
definition "oper_in_params op \<equiv>
filter (\<lambda>p. param_dir p = In \<or> param_dir p = InOut) (oper_params op)"
definition "oper_out_params op \<equiv>
filter (\<lambda>p. param_dir p = Out \<or> param_dir p = InOut) (oper_params op)"
subsection \<open>Attributes\<close>
inductive owned_attribute' where
"\<C> |\<in>| fmdom attributes \<Longrightarrow>
fmlookup attributes \<C> = Some attrs\<^sub>\<C> \<Longrightarrow>
fmlookup attrs\<^sub>\<C> attr = Some \<tau> \<Longrightarrow>
owned_attribute' attributes \<C> attr \<tau>"
inductive attribute_not_closest where
"owned_attribute' attributes \<D>' attr \<tau>' \<Longrightarrow>
\<C> \<le> \<D>' \<Longrightarrow>
\<D>' < \<D> \<Longrightarrow>
attribute_not_closest attributes \<C> attr \<D> \<tau>"
inductive closest_attribute where
"owned_attribute' attributes \<D> attr \<tau> \<Longrightarrow>
\<C> \<le> \<D> \<Longrightarrow>
\<not> attribute_not_closest attributes \<C> attr \<D> \<tau> \<Longrightarrow>
closest_attribute attributes \<C> attr \<D> \<tau>"
inductive closest_attribute_not_unique where
"closest_attribute attributes \<C> attr \<D>' \<tau>' \<Longrightarrow>
\<D> \<noteq> \<D>' \<or> \<tau> \<noteq> \<tau>' \<Longrightarrow>
closest_attribute_not_unique attributes \<C> attr \<D> \<tau>"
inductive unique_closest_attribute where
"closest_attribute attributes \<C> attr \<D> \<tau> \<Longrightarrow>
\<not> closest_attribute_not_unique attributes \<C> attr \<D> \<tau> \<Longrightarrow>
unique_closest_attribute attributes \<C> attr \<D> \<tau>"
subsection \<open>Association Ends\<close>
inductive role_refer_class where
"role |\<in>| fmdom ends \<Longrightarrow>
fmlookup ends role = Some end \<Longrightarrow>
assoc_end_class end = \<C> \<Longrightarrow>
role_refer_class ends \<C> role"
inductive association_ends' where
"\<C> |\<in>| classes \<Longrightarrow>
assoc |\<in>| fmdom associations \<Longrightarrow>
fmlookup associations assoc = Some ends \<Longrightarrow>
role_refer_class ends \<C> from \<Longrightarrow>
role |\<in>| fmdom ends \<Longrightarrow>
fmlookup ends role = Some end \<Longrightarrow>
role \<noteq> from \<Longrightarrow>
association_ends' classes associations \<C> from role end"
inductive association_ends_not_unique' where
"association_ends' classes associations \<C> from role end\<^sub>1 \<Longrightarrow>
association_ends' classes associations \<C> from role end\<^sub>2 \<Longrightarrow>
end\<^sub>1 \<noteq> end\<^sub>2 \<Longrightarrow>
association_ends_not_unique' classes associations"
inductive owned_association_end' where
"association_ends' classes associations \<C> from role end \<Longrightarrow>
owned_association_end' classes associations \<C> None role end"
| "association_ends' classes associations \<C> from role end \<Longrightarrow>
owned_association_end' classes associations \<C> (Some from) role end"
inductive association_end_not_closest where
"owned_association_end' classes associations \<D>' from role end' \<Longrightarrow>
\<C> \<le> \<D>' \<Longrightarrow>
\<D>' < \<D> \<Longrightarrow>
association_end_not_closest classes associations \<C> from role \<D> end"
inductive closest_association_end where
"owned_association_end' classes associations \<D> from role end \<Longrightarrow>
\<C> \<le> \<D> \<Longrightarrow>
\<not> association_end_not_closest classes associations \<C> from role \<D> end \<Longrightarrow>
closest_association_end classes associations \<C> from role \<D> end"
inductive closest_association_end_not_unique where
"closest_association_end classes associations \<C> from role \<D>' end' \<Longrightarrow>
\<D> \<noteq> \<D>' \<or> end \<noteq> end' \<Longrightarrow>
closest_association_end_not_unique classes associations \<C> from role \<D> end"
inductive unique_closest_association_end where
"closest_association_end classes associations \<C> from role \<D> end \<Longrightarrow>
\<not> closest_association_end_not_unique classes associations \<C> from role \<D> end \<Longrightarrow>
unique_closest_association_end classes associations \<C> from role \<D> end"
subsection \<open>Association Classes\<close>
inductive referred_by_association_class'' where
"fmlookup association_classes \<A> = Some assoc \<Longrightarrow>
fmlookup associations assoc = Some ends \<Longrightarrow>
role_refer_class ends \<C> from \<Longrightarrow>
referred_by_association_class'' association_classes associations \<C> from \<A>"
inductive referred_by_association_class' where
"referred_by_association_class'' association_classes associations \<C> from \<A> \<Longrightarrow>
referred_by_association_class' association_classes associations \<C> None \<A>"
| "referred_by_association_class'' association_classes associations \<C> from \<A> \<Longrightarrow>
referred_by_association_class' association_classes associations \<C> (Some from) \<A>"
inductive association_class_not_closest where
"referred_by_association_class' association_classes associations \<D>' from \<A> \<Longrightarrow>
\<C> \<le> \<D>' \<Longrightarrow>
\<D>' < \<D> \<Longrightarrow>
association_class_not_closest association_classes associations \<C> from \<A> \<D>"
inductive closest_association_class where
"referred_by_association_class' association_classes associations \<D> from \<A> \<Longrightarrow>
\<C> \<le> \<D> \<Longrightarrow>
\<not> association_class_not_closest association_classes associations \<C> from \<A> \<D> \<Longrightarrow>
closest_association_class association_classes associations \<C> from \<A> \<D>"
inductive closest_association_class_not_unique where
"closest_association_class association_classes associations \<C> from \<A> \<D>' \<Longrightarrow>
\<D> \<noteq> \<D>' \<Longrightarrow>
closest_association_class_not_unique
association_classes associations \<C> from \<A> \<D>"
inductive unique_closest_association_class where
"closest_association_class association_classes associations \<C> from \<A> \<D> \<Longrightarrow>
\<not> closest_association_class_not_unique
association_classes associations \<C> from \<A> \<D> \<Longrightarrow>
unique_closest_association_class association_classes associations \<C> from \<A> \<D>"
subsection \<open>Association Class Ends\<close>
inductive association_class_end' where
"fmlookup association_classes \<A> = Some assoc \<Longrightarrow>
fmlookup associations assoc = Some ends \<Longrightarrow>
fmlookup ends role = Some end \<Longrightarrow>
association_class_end' association_classes associations \<A> role end"
inductive association_class_end_not_unique where
"association_class_end' association_classes associations \<A> role end' \<Longrightarrow>
end \<noteq> end' \<Longrightarrow>
association_class_end_not_unique association_classes associations \<A> role end"
inductive unique_association_class_end where
"association_class_end' association_classes associations \<A> role end \<Longrightarrow>
\<not> association_class_end_not_unique
association_classes associations \<A> role end \<Longrightarrow>
unique_association_class_end association_classes associations \<A> role end"
subsection \<open>Operations\<close>
inductive any_operation' where
"op |\<in>| fset_of_list operations \<Longrightarrow>
oper_name op = name \<Longrightarrow>
\<tau> \<le> oper_context op \<Longrightarrow>
list_all2 (\<lambda>\<sigma> param. \<sigma> \<le> param_type param) \<pi> (oper_in_params op) \<Longrightarrow>
any_operation' operations \<tau> name \<pi> op"
inductive operation' where
"any_operation' operations \<tau> name \<pi> op \<Longrightarrow>
\<not> oper_static op \<Longrightarrow>
operation' operations \<tau> name \<pi> op"
inductive operation_not_unique where
"operation' operations \<tau> name \<pi> oper' \<Longrightarrow>
oper \<noteq> oper' \<Longrightarrow>
operation_not_unique operations \<tau> name \<pi> oper"
inductive unique_operation where
"operation' operations \<tau> name \<pi> oper \<Longrightarrow>
\<not> operation_not_unique operations \<tau> name \<pi> oper \<Longrightarrow>
unique_operation operations \<tau> name \<pi> oper"
inductive operation_defined' where
"unique_operation operations \<tau> name \<pi> oper \<Longrightarrow>
operation_defined' operations \<tau> name \<pi>"
inductive static_operation' where
"any_operation' operations \<tau> name \<pi> op \<Longrightarrow>
oper_static op \<Longrightarrow>
static_operation' operations \<tau> name \<pi> op"
inductive static_operation_not_unique where
"static_operation' operations \<tau> name \<pi> oper' \<Longrightarrow>
oper \<noteq> oper' \<Longrightarrow>
static_operation_not_unique operations \<tau> name \<pi> oper"
inductive unique_static_operation where
"static_operation' operations \<tau> name \<pi> oper \<Longrightarrow>
\<not> static_operation_not_unique operations \<tau> name \<pi> oper \<Longrightarrow>
unique_static_operation operations \<tau> name \<pi> oper"
inductive static_operation_defined' where
"unique_static_operation operations \<tau> name \<pi> oper \<Longrightarrow>
static_operation_defined' operations \<tau> name \<pi>"
subsection \<open>Literals\<close>
inductive has_literal' where
"fmlookup literals e = Some lits \<Longrightarrow>
lit |\<in>| lits \<Longrightarrow>
has_literal' literals e lit"
(*** Definition *************************************************************)
subsection \<open>Definition\<close>
locale object_model =
fixes classes :: "'a :: semilattice_sup fset"
and attributes :: "'a \<rightharpoonup>\<^sub>f attr \<rightharpoonup>\<^sub>f 't :: order"
and associations :: "assoc \<rightharpoonup>\<^sub>f role \<rightharpoonup>\<^sub>f 'a assoc_end"
and association_classes :: "'a \<rightharpoonup>\<^sub>f assoc"
and operations :: "('t, 'e) oper_spec list"
and literals :: "'n \<rightharpoonup>\<^sub>f elit fset"
assumes assoc_end_min_less_eq_max:
"assoc |\<in>| fmdom associations \<Longrightarrow>
fmlookup associations assoc = Some ends \<Longrightarrow>
role |\<in>| fmdom ends \<Longrightarrow>
fmlookup ends role = Some end \<Longrightarrow>
assoc_end_min end \<le> assoc_end_max end"
assumes association_ends_unique:
"association_ends' classes associations \<C> from role end\<^sub>1 \<Longrightarrow>
association_ends' classes associations \<C> from role end\<^sub>2 \<Longrightarrow> end\<^sub>1 = end\<^sub>2"
begin
abbreviation "owned_attribute \<equiv>
owned_attribute' attributes"
abbreviation "attribute \<equiv>
unique_closest_attribute attributes"
abbreviation "association_ends \<equiv>
association_ends' classes associations"
abbreviation "owned_association_end \<equiv>
owned_association_end' classes associations"
abbreviation "association_end \<equiv>
unique_closest_association_end classes associations"
abbreviation "referred_by_association_class \<equiv>
unique_closest_association_class association_classes associations"
abbreviation "association_class_end \<equiv>
unique_association_class_end association_classes associations"
abbreviation "operation \<equiv>
unique_operation operations"
abbreviation "operation_defined \<equiv>
operation_defined' operations"
abbreviation "static_operation \<equiv>
unique_static_operation operations"
abbreviation "static_operation_defined \<equiv>
static_operation_defined' operations"
abbreviation "has_literal \<equiv>
has_literal' literals"
end
declare operation_defined'.simps [simp]
declare static_operation_defined'.simps [simp]
declare has_literal'.simps [simp]
(*** Properties *************************************************************)
subsection \<open>Properties\<close>
lemma (in object_model) attribute_det:
"attribute \<C> attr \<D>\<^sub>1 \<tau>\<^sub>1 \<Longrightarrow>
attribute \<C> attr \<D>\<^sub>2 \<tau>\<^sub>2 \<Longrightarrow> \<D>\<^sub>1 = \<D>\<^sub>2 \<and> \<tau>\<^sub>1 = \<tau>\<^sub>2"
by (meson closest_attribute_not_unique.intros unique_closest_attribute.cases)
lemma (in object_model) attribute_self_or_inherited:
"attribute \<C> attr \<D> \<tau> \<Longrightarrow> \<C> \<le> \<D>"
by (meson closest_attribute.cases unique_closest_attribute.cases)
lemma (in object_model) attribute_closest:
"attribute \<C> attr \<D> \<tau> \<Longrightarrow>
owned_attribute \<D>' attr \<tau> \<Longrightarrow>
\<C> \<le> \<D>' \<Longrightarrow> \<not> \<D>' < \<D>"
by (meson attribute_not_closest.intros closest_attribute.cases
unique_closest_attribute.cases)
lemma (in object_model) association_end_det:
"association_end \<C> from role \<D>\<^sub>1 end\<^sub>1 \<Longrightarrow>
association_end \<C> from role \<D>\<^sub>2 end\<^sub>2 \<Longrightarrow> \<D>\<^sub>1 = \<D>\<^sub>2 \<and> end\<^sub>1 = end\<^sub>2"
by (meson closest_association_end_not_unique.intros
unique_closest_association_end.cases)
lemma (in object_model) association_end_self_or_inherited:
"association_end \<C> from role \<D> end \<Longrightarrow> \<C> \<le> \<D>"
by (meson closest_association_end.cases unique_closest_association_end.cases)
lemma (in object_model) association_end_closest:
"association_end \<C> from role \<D> end \<Longrightarrow>
owned_association_end \<D>' from role end \<Longrightarrow>
\<C> \<le> \<D>' \<Longrightarrow> \<not> \<D>' < \<D>"
by (meson association_end_not_closest.intros closest_association_end.cases
unique_closest_association_end.cases)
lemma (in object_model) association_class_end_det:
"association_class_end \<A> role end\<^sub>1 \<Longrightarrow>
association_class_end \<A> role end\<^sub>2 \<Longrightarrow> end\<^sub>1 = end\<^sub>2"
by (meson association_class_end_not_unique.intros unique_association_class_end.cases)
lemma (in object_model) operation_det:
"operation \<tau> name \<pi> oper\<^sub>1 \<Longrightarrow>
operation \<tau> name \<pi> oper\<^sub>2 \<Longrightarrow> oper\<^sub>1 = oper\<^sub>2"
by (meson operation_not_unique.intros unique_operation.cases)
lemma (in object_model) static_operation_det:
"static_operation \<tau> name \<pi> oper\<^sub>1 \<Longrightarrow>
static_operation \<tau> name \<pi> oper\<^sub>2 \<Longrightarrow> oper\<^sub>1 = oper\<^sub>2"
by (meson static_operation_not_unique.intros unique_static_operation.cases)
(*** Code Setup *************************************************************)
subsection \<open>Code Setup\<close>
lemma fmember_code_predI [code_pred_intro]:
"x |\<in>| xs" if "Predicate_Compile.contains (fset xs) x"
- using that by (simp add: Predicate_Compile.contains_def fmember.rep_eq)
+ using that by (simp add: Predicate_Compile.contains_def fmember_iff_member_fset)
code_pred fmember
- by (simp add: Predicate_Compile.contains_def fmember.rep_eq)
+ by (simp add: Predicate_Compile.contains_def fmember_iff_member_fset)
code_pred unique_closest_attribute .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool) association_ends' .
code_pred association_ends_not_unique' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool) owned_association_end' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool) closest_association_end .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool ) closest_association_end_not_unique .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool) unique_closest_association_end .
code_pred unique_closest_association_class .
code_pred association_class_end' .
code_pred association_class_end_not_unique .
code_pred unique_association_class_end .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) any_operation' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) operation' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool) operation_not_unique .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) unique_operation .
code_pred operation_defined' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) static_operation' .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool) static_operation_not_unique .
code_pred (modes:
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool,
i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool) unique_static_operation .
code_pred static_operation_defined' .
code_pred has_literal' .
end
diff --git a/thys/Shadow_DOM/Shadow_DOM.thy b/thys/Shadow_DOM/Shadow_DOM.thy
--- a/thys/Shadow_DOM/Shadow_DOM.thy
+++ b/thys/Shadow_DOM/Shadow_DOM.thy
@@ -1,10462 +1,10462 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>The Shadow DOM\<close>
theory Shadow_DOM
imports
"monads/ShadowRootMonad"
Core_DOM.Core_DOM
begin
abbreviation "safe_shadow_root_element_types \<equiv> {''article'', ''aside'', ''blockquote'', ''body'',
''div'', ''footer'', ''h1'', ''h2'', ''h3'', ''h4'', ''h5'', ''h6'', ''header'', ''main'',
''nav'', ''p'', ''section'', ''span''}"
subsection \<open>Function Definitions\<close>
subsubsection \<open>get\_child\_nodes\<close>
locale l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) shadow_root_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) node_ptr list) dom_prog" where
"get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr _ = get_M shadow_root_ptr RShadowRoot.child_nodes"
definition a_get_child_nodes_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) node_ptr list) dom_prog)) list" where
"a_get_child_nodes_tups \<equiv> [(is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r, get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_get_child_nodes :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog" where
"a_get_child_nodes ptr = invoke (CD.a_get_child_nodes_tups @ a_get_child_nodes_tups) ptr ()"
definition a_get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" where
"a_get_child_nodes_locs ptr \<equiv>
(if is_shadow_root_ptr_kind ptr
then {preserved (get_M (the (cast ptr)) RShadowRoot.child_nodes)} else {}) \<union>
CD.a_get_child_nodes_locs ptr"
definition first_child :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr option) dom_prog"
where
"first_child ptr = do {
children \<leftarrow> a_get_child_nodes ptr;
return (case children of [] \<Rightarrow> None | child#_ \<Rightarrow> Some child)}"
end
global_interpretation l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines
get_child_nodes = l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes and
get_child_nodes_locs = l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes_locs
.
locale l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_known_ptr known_ptr +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
CD: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_child_nodes_impl: "get_child_nodes = a_get_child_nodes"
assumes get_child_nodes_locs_impl: "get_child_nodes_locs = a_get_child_nodes_locs"
begin
lemmas get_child_nodes_def = get_child_nodes_impl[unfolded a_get_child_nodes_def get_child_nodes_def]
lemmas get_child_nodes_locs_def = get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def
get_child_nodes_locs_def, folded CD.get_child_nodes_locs_impl]
lemma get_child_nodes_ok:
assumes "known_ptr ptr"
assumes "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_child_nodes ptr)"
using assms[unfolded known_ptr_impl type_wf_impl]
apply(auto simp add: get_child_nodes_def)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t CD.get_child_nodes_ok CD.known_ptr_impl CD.type_wf_impl
apply blast
apply(auto simp add: CD.known_ptr_impl a_get_child_nodes_tups_def get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok
dest!: known_ptr_new_shadow_root_ptr intro!: bind_is_OK_I2)[1]
by (metis is_shadow_root_ptr_kind_none l_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas.get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok
l_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas_axioms option.case_eq_if shadow_root_ptr_casts_commute3
shadow_root_ptr_kinds_commutes)
lemma get_child_nodes_ptr_in_heap:
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_child_nodes_def invoke_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_child_nodes_pure [simp]:
"pure (get_child_nodes ptr) h"
unfolding get_child_nodes_def a_get_child_nodes_tups_def
proof(split CD.get_child_nodes_splits, rule conjI; clarify)
assume "known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ptr"
then show "pure (get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ptr) h"
by simp
next
assume "\<not> known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ptr"
then show "pure (invoke [(is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r,
get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r)]
ptr ()) h"
by(auto simp add: get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro: bind_pure_I split: invoke_splits)
qed
lemma get_child_nodes_reads: "reads (get_child_nodes_locs ptr) (get_child_nodes ptr) h h'"
apply (simp add: get_child_nodes_def a_get_child_nodes_tups_def get_child_nodes_locs_def
CD.get_child_nodes_locs_def)
apply(split CD.get_child_nodes_splits, rule conjI)+
apply(auto intro!: reads_subset[OF CD.get_child_nodes_reads[unfolded CD.get_child_nodes_locs_def]]
split: if_splits)[1]
apply(split invoke_splits, rule conjI)+
apply(auto)[1]
apply(auto simp add: get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro: reads_subset[OF reads_singleton] reads_subset[OF check_in_heap_reads]
intro!: reads_bind_pure reads_subset[OF return_reads] split: option.splits)[1]
done
end
interpretation i_get_child_nodes?: l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(simp add: l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_child_nodes_is_l_get_child_nodes [instances]: "l_get_child_nodes type_wf known_ptr
get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_get_child_nodes_def instances)[1]
using get_child_nodes_reads get_child_nodes_ok get_child_nodes_ptr_in_heap get_child_nodes_pure
by blast+
paragraph \<open>new\_document\<close>
locale l_new_document_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_child_nodes_new_document:
"ptr' \<noteq> cast new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
apply(auto simp add: get_child_nodes_locs_def)[1]
using CD.get_child_nodes_new_document
apply (metis document_ptr_casts_commute3 empty_iff is_document_ptr_kind_none
new_document_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t option.case_eq_if shadow_root_ptr_casts_commute3
singletonD)
by (simp add: CD.get_child_nodes_new_document)
lemma new_document_no_child_nodes:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using CD.new_document_no_child_nodes apply auto[1]
by(auto simp add: DocumentClass.a_known_ptr_def CD.known_ptr_impl known_ptr_def
dest!: new_document_is_document_ptr)
end
interpretation i_new_document_get_child_nodes?:
l_new_document_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs
DocumentClass.type_wf DocumentClass.known_ptr Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma new_document_get_child_nodes_is_l_new_document_get_child_nodes [instances]:
"l_new_document_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
using new_document_is_l_new_document get_child_nodes_is_l_get_child_nodes
apply(simp add: l_new_document_get_child_nodes_def l_new_document_get_child_nodes_axioms_def)
using get_child_nodes_new_document new_document_no_child_nodes
by fast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_child_nodes_new_shadow_root:
"ptr' \<noteq> cast new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
apply(auto simp add: get_child_nodes_locs_def)[1]
apply (metis document_ptr_casts_commute3 insert_absorb insert_not_empty is_document_ptr_kind_none
new_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t option.case_eq_if shadow_root_ptr_casts_commute3 singletonD)
apply(auto simp add: CD.get_child_nodes_locs_def)[1]
using new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t apply blast
apply (metis empty_iff insertE new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
apply (metis empty_iff new_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t singletonD)
done
lemma new_shadow_root_no_child_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def )[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
apply(auto simp add: CD.get_child_nodes_def CD.a_get_child_nodes_tups_def)[1]
apply(split invoke_splits, rule conjI)+
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_element_ptr local.CD.known_ptr_impl apply blast
apply(auto simp add: is_document_ptr_def split: option.splits document_ptr.splits)[1]
apply(auto simp add: is_character_data_ptr_def split: option.splits document_ptr.splits)[1]
apply(auto simp add: is_element_ptr_def split: option.splits document_ptr.splits)[1]
apply(auto simp add: a_get_child_nodes_tups_def)[1]
apply(split invoke_splits, rule conjI)+
apply(auto simp add: is_shadow_root_ptr_def split: shadow_root_ptr.splits
dest!: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_is_shadow_root_ptr)[1]
apply(auto intro!: bind_pure_returns_result_I)[1]
apply(drule(1) new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap)
apply(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)[1]
apply (metis check_in_heap_ptr_in_heap is_OK_returns_result_E old.unit.exhaust)
using new_shadow_root_children
by (simp add: new_shadow_root_children get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)
end
interpretation i_new_shadow_root_get_child_nodes?:
l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs
DocumentClass.type_wf DocumentClass.known_ptr Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
locale l_new_shadow_root_get_child_nodes = l_get_child_nodes +
assumes get_child_nodes_new_shadow_root:
"ptr' \<noteq> cast new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
assumes new_shadow_root_no_child_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
lemma new_shadow_root_get_child_nodes_is_l_new_shadow_root_get_child_nodes [instances]:
"l_new_shadow_root_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
apply(simp add: l_new_shadow_root_get_child_nodes_def l_new_shadow_root_get_child_nodes_axioms_def
instances)
using get_child_nodes_new_shadow_root new_shadow_root_no_child_nodes
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_new_element_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_new_element:
"ptr' \<noteq> cast new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t new_element_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E
intro: is_element_ptr_kind_obtains)
lemma new_element_no_child_nodes:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def
split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using local.new_element_no_child_nodes apply auto[1]
apply(auto simp add: invoke_def)[1]
apply(auto simp add: new_element_ptr_in_heap get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def check_in_heap_def
new_element_child_nodes intro!: bind_pure_returns_result_I
intro: new_element_is_element_ptr elim!: new_element_ptr_in_heap)[1]
proof -
assume " h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr"
assume "h \<turnstile> new_element \<rightarrow>\<^sub>h h'"
assume "\<not> known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr)"
moreover
have "known_ptr (cast new_element_ptr)"
using new_element_is_element_ptr \<open>h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr\<close>
by(auto simp add: known_ptr_impl ShadowRootClass.a_known_ptr_def DocumentClass.a_known_ptr_def
CharacterDataClass.a_known_ptr_def ElementClass.a_known_ptr_def)
ultimately show "False"
by(simp add: known_ptr_impl CD.known_ptr_impl ShadowRootClass.a_known_ptr_def
is_document_ptr_kind_none)
qed
end
interpretation i_new_element_get_child_nodes?:
l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma new_element_get_child_nodes_is_l_new_element_get_child_nodes [instances]:
"l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
using new_element_is_l_new_element get_child_nodes_is_l_get_child_nodes
apply(auto simp add: l_new_element_get_child_nodes_def l_new_element_get_child_nodes_axioms_def)[1]
using get_child_nodes_new_element new_element_no_child_nodes
by fast+
subsubsection \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_delete_shadow_root:
"ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def
delete_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: if_splits option.splits
intro: is_shadow_root_ptr_kind_obtains)
end
locale l_delete_shadow_root_get_child_nodes = l_get_child_nodes_defs +
assumes get_child_nodes_delete_shadow_root:
"ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(auto simp add: l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_child_nodes_get_child_nodes_locs [instances]: "l_delete_shadow_root_get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_delete_shadow_root_get_child_nodes_def)[1]
using get_child_nodes_delete_shadow_root apply fast
done
subsubsection \<open>set\_child\_nodes\<close>
locale l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) shadow_root_ptr \<Rightarrow> (_) node_ptr list
\<Rightarrow> (_, unit) dom_prog" where
"set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr = put_M shadow_root_ptr RShadowRoot.child_nodes_update"
definition a_set_child_nodes_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> (_) node_ptr list
\<Rightarrow> (_, unit) dom_prog)) list" where
"a_set_child_nodes_tups \<equiv> [(is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r, set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog" where
"a_set_child_nodes ptr children = invoke (CD.a_set_child_nodes_tups @ a_set_child_nodes_tups)
ptr children"
definition a_set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set"
where
"a_set_child_nodes_locs ptr \<equiv>
(if is_shadow_root_ptr_kind ptr
then all_args (put_M (the (cast ptr)) RShadowRoot.child_nodes_update)
else {}) \<union> CD.a_set_child_nodes_locs ptr"
end
global_interpretation l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines
set_child_nodes = l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes and
set_child_nodes_locs = l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes_locs
.
locale l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_known_ptr known_ptr +
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_set_child_nodes_defs set_child_nodes set_child_nodes_locs +
CD: l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_child_nodes_impl: "set_child_nodes = a_set_child_nodes"
assumes set_child_nodes_locs_impl: "set_child_nodes_locs = a_set_child_nodes_locs"
begin
lemmas set_child_nodes_def = set_child_nodes_impl[unfolded a_set_child_nodes_def set_child_nodes_def]
lemmas set_child_nodes_locs_def = set_child_nodes_locs_impl[unfolded a_set_child_nodes_locs_def
set_child_nodes_locs_def, folded CD.set_child_nodes_locs_impl]
lemma set_child_nodes_writes: "writes (set_child_nodes_locs ptr) (set_child_nodes ptr children) h h'"
apply (simp add: set_child_nodes_def a_set_child_nodes_tups_def set_child_nodes_locs_def)
apply(split CD.set_child_nodes_splits, rule conjI)+
apply (simp add: CD.set_child_nodes_writes writes_union_right_I)
apply(split invoke_splits, rule conjI)+
apply(auto simp add: a_set_child_nodes_def)[1]
apply(auto simp add: set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: writes_bind_pure
intro: writes_union_right_I writes_union_left_I
split: list.splits)[1]
by (simp add: is_shadow_root_ptr_kind_none)
lemma set_child_nodes_pointers_preserved:
assumes "w \<in> set_child_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_child_nodes_locs_def CD.set_child_nodes_locs_def
split: if_splits)
lemma set_child_nodes_types_preserved:
assumes "w \<in> set_child_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def type_wf_impl a_set_child_nodes_tups_def set_child_nodes_locs_def
CD.set_child_nodes_locs_def
split: if_splits option.splits)
end
interpretation
i_set_child_nodes?: l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr set_child_nodes set_child_nodes_locs Core_DOM_Functions.set_child_nodes
Core_DOM_Functions.set_child_nodes_locs
apply(unfold_locales)
by (auto simp add: set_child_nodes_def set_child_nodes_locs_def)
declare l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_is_l_set_child_nodes [instances]: "l_set_child_nodes type_wf set_child_nodes
set_child_nodes_locs"
using instances Shadow_DOM.i_set_child_nodes.set_child_nodes_pointers_preserved Shadow_DOM.i_set_child_nodes.set_child_nodes_writes i_set_child_nodes.set_child_nodes_types_preserved
unfolding l_set_child_nodes_def
by blast
paragraph \<open>get\_child\_nodes\<close>
locale l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes set_child_nodes_locs
set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ CD: l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
begin
lemma set_child_nodes_get_child_nodes:
assumes "known_ptr ptr"
assumes "type_wf h"
assumes "h \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
have "h \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()"
using assms set_child_nodes_def invoke_ptr_in_heap
by (metis (full_types) check_in_heap_ptr_in_heap is_OK_returns_heap_I is_OK_returns_result_E
old.unit.exhaust)
then have ptr_in_h: "ptr |\<in>| object_ptr_kinds h"
by (simp add: check_in_heap_ptr_in_heap is_OK_returns_result_I)
have "type_wf h'"
apply(unfold type_wf_impl)
apply(rule subst[where P=id, OF type_wf_preserved[OF set_child_nodes_writes assms(3),
unfolded all_args_def], simplified])
by(auto simp add: all_args_def assms(2)[unfolded type_wf_impl] set_child_nodes_locs_def
CD.set_child_nodes_locs_def
split: if_splits)
have "h' \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()"
using check_in_heap_reads set_child_nodes_writes assms(3) \<open>h \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()\<close>
apply(rule reads_writes_separate_forwards)
apply(auto simp add: all_args_def set_child_nodes_locs_def CD.set_child_nodes_locs_def)[1]
done
then have "ptr |\<in>| object_ptr_kinds h'"
using check_in_heap_ptr_in_heap by blast
with assms ptr_in_h \<open>type_wf h'\<close> show ?thesis
apply(auto simp add: type_wf_impl known_ptr_impl get_child_nodes_def a_get_child_nodes_tups_def
set_child_nodes_def a_set_child_nodes_tups_def
del: bind_pure_returns_result_I2
intro!: bind_pure_returns_result_I2)[1]
apply(split CD.get_child_nodes_splits, (rule conjI impI)+)+
apply(split CD.set_child_nodes_splits)+
apply(auto simp add: CD.set_child_nodes_get_child_nodes type_wf_impl CD.type_wf_impl
dest: ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)[1]
apply(auto simp add: CD.set_child_nodes_get_child_nodes type_wf_impl CD.type_wf_impl
dest: ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)[1]
apply(split CD.set_child_nodes_splits)+
by(auto simp add: known_ptr_impl CD.known_ptr_impl set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
dest: known_ptr_new_shadow_root_ptr)[2]
qed
lemma set_child_nodes_get_child_nodes_different_pointers:
assumes "ptr \<noteq> ptr'"
assumes "w \<in> set_child_nodes_locs ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_child_nodes_locs ptr'"
shows "r h h'"
using assms
apply(auto simp add: set_child_nodes_locs_def CD.set_child_nodes_locs_def
get_child_nodes_locs_def CD.get_child_nodes_locs_def)[1]
by(auto simp add: all_args_def
elim!: is_document_ptr_kind_obtains is_shadow_root_ptr_kind_obtains
is_element_ptr_kind_obtains
split: if_splits option.splits)
end
interpretation
i_set_child_nodes_get_child_nodes?: l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes get_child_nodes_locs
Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs set_child_nodes
set_child_nodes_locs Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs
using instances
by(auto simp add: l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def )
declare l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_child_nodes_is_l_set_child_nodes_get_child_nodes [instances]:
"l_set_child_nodes_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs"
apply(auto simp add: instances l_set_child_nodes_get_child_nodes_def
l_set_child_nodes_get_child_nodes_axioms_def)[1]
using set_child_nodes_get_child_nodes apply fast
using set_child_nodes_get_child_nodes_different_pointers apply fast
done
subsubsection \<open>set\_tag\_type\<close>
locale l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_tag_name set_tag_name_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_tag_name :: "(_) element_ptr \<Rightarrow> tag_name \<Rightarrow> (_, unit) dom_prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemmas set_tag_name_def = CD.set_tag_name_impl[unfolded CD.a_set_tag_name_def set_tag_name_def]
lemmas set_tag_name_locs_def = CD.set_tag_name_locs_impl[unfolded CD.a_set_tag_name_locs_def
set_tag_name_locs_def]
lemma set_tag_name_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_tag_name element_ptr tag)"
apply(unfold type_wf_impl)
unfolding set_tag_name_impl[unfolded a_set_tag_name_def] using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok
using CD.set_tag_name_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
lemma set_tag_name_writes:
"writes (set_tag_name_locs element_ptr) (set_tag_name element_ptr tag) h h'"
using CD.set_tag_name_writes .
lemma set_tag_name_pointers_preserved:
assumes "w \<in> set_tag_name_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms
by(simp add: CD.set_tag_name_pointers_preserved)
lemma set_tag_name_typess_preserved:
assumes "w \<in> set_tag_name_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
apply(rule type_wf_preserved[OF writes_singleton2 assms(2)])
using assms(1) set_tag_name_locs_def
by(auto simp add: all_args_def set_tag_name_locs_def
split: if_splits)
end
interpretation i_set_tag_name?: l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_tag_name
set_tag_name_locs
by(auto simp add: l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_tag_name_is_l_set_tag_name [instances]:
"l_set_tag_name type_wf set_tag_name set_tag_name_locs"
apply(auto simp add: l_set_tag_name_def)[1]
using set_tag_name_writes apply fast
using set_tag_name_ok apply fast
using set_tag_name_pointers_preserved apply (fast, fast)
using set_tag_name_typess_preserved apply (fast, fast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
CD: l_set_tag_name_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_tag_name set_tag_name_locs
known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_child_nodes:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
apply(auto simp add: get_child_nodes_locs_def)[1]
apply(auto simp add: set_tag_name_locs_def all_args_def)[1]
using CD.set_tag_name_get_child_nodes apply(blast)
using CD.set_tag_name_get_child_nodes apply(blast)
done
end
interpretation
i_set_tag_name_get_child_nodes?: l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf set_tag_name set_tag_name_locs known_ptr DocumentClass.known_ptr
get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by unfold_locales
declare l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_child_nodes_is_l_set_tag_name_get_child_nodes [instances]:
"l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr get_child_nodes
get_child_nodes_locs"
using set_tag_name_is_l_set_tag_name get_child_nodes_is_l_get_child_nodes
apply(simp add: l_set_tag_name_get_child_nodes_def
l_set_tag_name_get_child_nodes_axioms_def)
using set_tag_name_get_child_nodes
by fast
subsubsection \<open>get\_shadow\_root\<close>
locale l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
where
"a_get_shadow_root element_ptr = get_M element_ptr shadow_root_opt"
definition a_get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
where
"a_get_shadow_root_locs element_ptr \<equiv> {preserved (get_M element_ptr shadow_root_opt)}"
end
global_interpretation l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines get_shadow_root = a_get_shadow_root
and get_shadow_root_locs = a_get_shadow_root_locs
.
locale l_get_shadow_root_defs =
fixes get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
fixes get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_shadow_root_impl: "get_shadow_root = a_get_shadow_root"
assumes get_shadow_root_locs_impl: "get_shadow_root_locs = a_get_shadow_root_locs"
begin
lemmas get_shadow_root_def = get_shadow_root_impl[unfolded get_shadow_root_def a_get_shadow_root_def]
lemmas get_shadow_root_locs_def = get_shadow_root_locs_impl[unfolded get_shadow_root_locs_def
a_get_shadow_root_locs_def]
lemma get_shadow_root_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_shadow_root element_ptr)"
unfolding get_shadow_root_def type_wf_impl
using ShadowRootMonad.get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok by blast
lemma get_shadow_root_pure [simp]: "pure (get_shadow_root element_ptr) h"
unfolding get_shadow_root_def by simp
lemma get_shadow_root_ptr_in_heap:
assumes "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r children"
shows "element_ptr |\<in>| element_ptr_kinds h"
using assms
by(auto simp add: get_shadow_root_def get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_shadow_root_reads:
"reads (get_shadow_root_locs element_ptr) (get_shadow_root element_ptr) h h'"
by(simp add: get_shadow_root_def get_shadow_root_locs_def reads_bind_pure
reads_insert_writes_set_right)
end
interpretation i_get_shadow_root?: l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root
get_shadow_root_locs
using instances
by (auto simp add: l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_shadow_root = l_type_wf + l_get_shadow_root_defs +
assumes get_shadow_root_reads:
"reads (get_shadow_root_locs element_ptr) (get_shadow_root element_ptr) h h'"
assumes get_shadow_root_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_shadow_root element_ptr)"
assumes get_shadow_root_ptr_in_heap:
"h \<turnstile> ok (get_shadow_root element_ptr) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
assumes get_shadow_root_pure [simp]:
"pure (get_shadow_root element_ptr) h"
lemma get_shadow_root_is_l_get_shadow_root [instances]:
"l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using instances
unfolding l_get_shadow_root_def
by (metis (no_types, lifting) ElementClass.l_type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_axioms get_shadow_root_ok get_shadow_root_pure get_shadow_root_reads l_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas.get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap l_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_lemmas.intro l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_shadow_root_def)
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes
:: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_disconnected_nodes_get_shadow_root:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_disconnected_nodes_locs_def get_shadow_root_locs_def all_args_def)
end
locale l_set_disconnected_nodes_get_shadow_root =
l_set_disconnected_nodes_defs +
l_get_shadow_root_defs +
assumes set_disconnected_nodes_get_shadow_root:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_disconnected_nodes_get_shadow_root?: l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs
by(auto simp add: l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_shadow_root_is_l_set_disconnected_nodes_get_shadow_root [instances]:
"l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes_locs get_shadow_root_locs"
apply(auto simp add: l_set_disconnected_nodes_get_shadow_root_def)[1]
using set_disconnected_nodes_get_shadow_root apply fast
done
paragraph \<open>set\_tag\_type\<close>
locale l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_shadow_root:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_tag_name_locs_def
get_shadow_root_locs_def all_args_def
intro: element_put_get_preserved[where setter=tag_name_update and getter=shadow_root_opt])
end
locale l_set_tag_name_get_shadow_root = l_set_tag_name + l_get_shadow_root +
assumes set_tag_name_get_shadow_root:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_tag_name_get_shadow_root?: l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_tag_name set_tag_name_locs
get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
using l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by unfold_locales
declare l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_shadow_root_is_l_set_tag_name_get_shadow_root [instances]:
"l_set_tag_name_get_shadow_root type_wf set_tag_name set_tag_name_locs get_shadow_root
get_shadow_root_locs"
using set_tag_name_is_l_set_tag_name get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_tag_name_get_shadow_root_def l_set_tag_name_get_shadow_root_axioms_def)
using set_tag_name_get_shadow_root
by fast
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes
set_child_nodes_locs set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_child_nodes_get_shadow_root: "\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow>
(\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
apply(auto simp add: set_child_nodes_locs_def get_shadow_root_locs_def CD.set_child_nodes_locs_def
all_args_def)[1]
by(auto intro!: element_put_get_preserved[where getter=shadow_root_opt and
setter=RElement.child_nodes_update])
end
locale l_set_child_nodes_get_shadow_root = l_set_child_nodes_defs + l_get_shadow_root_defs +
assumes set_child_nodes_get_shadow_root:
"\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_child_nodes_get_shadow_root?: l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_shadow_root
get_shadow_root_locs
by(auto simp add: l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_shadow_root_is_l_set_child_nodes_get_shadow_root [instances]:
"l_set_child_nodes_get_shadow_root set_child_nodes_locs get_shadow_root_locs"
apply(auto simp add: l_set_child_nodes_get_shadow_root_def)[1]
using set_child_nodes_get_shadow_root apply fast
done
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_shadow_root_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: get_shadow_root_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_shadow_root = l_get_shadow_root_defs +
assumes get_shadow_root_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root
get_shadow_root_locs
by(auto simp add: l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_shadow_root_get_shadow_root_locs [instances]: "l_delete_shadow_root_get_shadow_root get_shadow_root_locs"
apply(auto simp add: l_delete_shadow_root_get_shadow_root_def)[1]
using get_shadow_root_delete_shadow_root apply fast
done
paragraph \<open>new\_character\_data\<close>
locale l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_character_data_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E
intro: is_element_ptr_kind_obtains)
end
locale l_new_character_data_get_shadow_root = l_new_character_data + l_get_shadow_root +
assumes get_shadow_root_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr
\<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_character_data_get_shadow_root?:
l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_character_data_get_shadow_root_is_l_new_character_data_get_shadow_root [instances]:
"l_new_character_data_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_character_data_is_l_new_character_data get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_character_data_get_shadow_root_def
l_new_character_data_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_character_data
by fast
paragraph \<open>new\_document\<close>
locale l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_document_get_shadow_root = l_new_document + l_get_shadow_root +
assumes get_shadow_root_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_document_get_shadow_root?:
l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_document_get_shadow_root_is_l_new_document_get_shadow_root [instances]:
"l_new_document_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_document_is_l_new_document get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_document_get_shadow_root_def l_new_document_get_shadow_root_axioms_def
instances)[1]
using get_shadow_root_new_document
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
lemma new_element_no_shadow_root:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_shadow_root new_element_ptr \<rightarrow>\<^sub>r None"
by(simp add: get_shadow_root_def new_element_shadow_root_opt)
end
locale l_new_element_get_shadow_root = l_new_element + l_get_shadow_root +
assumes get_shadow_root_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr
\<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
assumes new_element_no_shadow_root:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_shadow_root new_element_ptr \<rightarrow>\<^sub>r None"
interpretation i_new_element_get_shadow_root?:
l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_element_get_shadow_root_is_l_new_element_get_shadow_root [instances]:
"l_new_element_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_element_is_l_new_element get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_element_get_shadow_root_def l_new_element_get_shadow_root_axioms_def
instances)[1]
using get_shadow_root_new_element new_element_no_shadow_root
by fast+
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_shadow_root_get_shadow_root = l_get_shadow_root +
assumes get_shadow_root_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_shadow_root_get_shadow_root?:
l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_shadow_root_get_shadow_root_is_l_new_shadow_root_get_shadow_root [instances]:
"l_new_shadow_root_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_shadow_root_get_shadow_root_def
l_new_shadow_root_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_shadow_root
by fast
subsubsection \<open>set\_shadow\_root\<close>
locale l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
where
"a_set_shadow_root element_ptr = put_M element_ptr shadow_root_opt_update"
definition a_set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_set_shadow_root_locs element_ptr \<equiv> all_args (put_M element_ptr shadow_root_opt_update)"
end
global_interpretation l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines set_shadow_root = a_set_shadow_root
and set_shadow_root_locs = a_set_shadow_root_locs
.
locale l_set_shadow_root_defs =
fixes set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
fixes set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set"
locale l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_shadow_root_impl: "set_shadow_root = a_set_shadow_root"
assumes set_shadow_root_locs_impl: "set_shadow_root_locs = a_set_shadow_root_locs"
begin
lemmas set_shadow_root_def = set_shadow_root_impl[unfolded set_shadow_root_def
a_set_shadow_root_def]
lemmas set_shadow_root_locs_def = set_shadow_root_locs_impl[unfolded set_shadow_root_locs_def
a_set_shadow_root_locs_def]
lemma set_shadow_root_ok: "type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_shadow_root element_ptr tag)"
apply(unfold type_wf_impl)
unfolding set_shadow_root_def using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok
by (simp add: ShadowRootMonad.put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok)
lemma set_shadow_root_ptr_in_heap:
"h \<turnstile> ok (set_shadow_root element_ptr shadow_root) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
by(simp add: set_shadow_root_def ElementMonad.put_M_ptr_in_heap)
lemma set_shadow_root_writes:
"writes (set_shadow_root_locs element_ptr) (set_shadow_root element_ptr tag) h h'"
by(auto simp add: set_shadow_root_def set_shadow_root_locs_def intro: writes_bind_pure)
lemma set_shadow_root_pointers_preserved:
assumes "w \<in> set_shadow_root_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_shadow_root_locs_def split: if_splits)
lemma set_shadow_root_types_preserved:
assumes "w \<in> set_shadow_root_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_shadow_root_locs_def split: if_splits)
end
interpretation i_set_shadow_root?: l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root
set_shadow_root_locs
by (auto simp add: l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_shadow_root = l_type_wf +l_set_shadow_root_defs +
assumes set_shadow_root_writes:
"writes (set_shadow_root_locs element_ptr) (set_shadow_root element_ptr disc_nodes) h h'"
assumes set_shadow_root_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_shadow_root element_ptr shadow_root)"
assumes set_shadow_root_ptr_in_heap:
"h \<turnstile> ok (set_shadow_root element_ptr shadow_root) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
assumes set_shadow_root_pointers_preserved:
"w \<in> set_shadow_root_locs element_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
object_ptr_kinds h = object_ptr_kinds h'"
assumes set_shadow_root_types_preserved:
"w \<in> set_shadow_root_locs element_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma set_shadow_root_is_l_set_shadow_root [instances]:
"l_set_shadow_root type_wf set_shadow_root set_shadow_root_locs"
apply(auto simp add: l_set_shadow_root_def instances)[1]
using set_shadow_root_writes apply blast
using set_shadow_root_ok apply (blast)
using set_shadow_root_ptr_in_heap apply blast
using set_shadow_root_pointers_preserved apply(blast, blast)
using set_shadow_root_types_preserved apply(blast, blast)
done
paragraph \<open>get\_shadow\_root\<close>
locale l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_shadow_root:
"type_wf h \<Longrightarrow> h \<turnstile> set_shadow_root ptr shadow_root_ptr_opt \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt"
by(auto simp add: set_shadow_root_def get_shadow_root_def)
lemma set_shadow_root_get_shadow_root_different_pointers: "ptr \<noteq> ptr' \<Longrightarrow>
\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def get_shadow_root_locs_def all_args_def)
end
interpretation i_set_shadow_root_get_shadow_root?: l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_shadow_root set_shadow_root_locs get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_shadow_root =
l_type_wf +
l_set_shadow_root_defs +
l_get_shadow_root_defs +
assumes set_shadow_root_get_shadow_root:
"type_wf h \<Longrightarrow> h \<turnstile> set_shadow_root ptr shadow_root_ptr_opt \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt"
assumes set_shadow_root_get_shadow_root_different_pointers:
"ptr \<noteq> ptr' \<Longrightarrow> w \<in> set_shadow_root_locs ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
lemma set_shadow_root_get_shadow_root_is_l_set_shadow_root_get_shadow_root [instances]:
"l_set_shadow_root_get_shadow_root type_wf set_shadow_root set_shadow_root_locs get_shadow_root
get_shadow_root_locs"
apply(auto simp add: l_set_shadow_root_get_shadow_root_def instances)[1]
using set_shadow_root_get_shadow_root apply fast
using set_shadow_root_get_shadow_root_different_pointers apply fast
done
subsubsection \<open>set\_mode\<close>
locale l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
where
"a_set_mode shadow_root_ptr = put_M shadow_root_ptr mode_update"
definition a_set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_set_mode_locs shadow_root_ptr \<equiv> all_args (put_M shadow_root_ptr mode_update)"
end
global_interpretation l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines set_mode = a_set_mode
and set_mode_locs = a_set_mode_locs
.
locale l_set_mode_defs =
fixes set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
fixes set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set"
locale l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_set_mode_defs set_mode set_mode_locs +
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_mode_impl: "set_mode = a_set_mode"
assumes set_mode_locs_impl: "set_mode_locs = a_set_mode_locs"
begin
lemmas set_mode_def = set_mode_impl[unfolded set_mode_def a_set_mode_def]
lemmas set_mode_locs_def = set_mode_locs_impl[unfolded set_mode_locs_def a_set_mode_locs_def]
lemma set_mode_ok:
"type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode)"
apply(unfold type_wf_impl)
unfolding set_mode_def using get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok
by (simp add: ShadowRootMonad.put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok)
lemma set_mode_ptr_in_heap:
"h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode) \<Longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
by(simp add: set_mode_def put_M_ptr_in_heap)
lemma set_mode_writes:
"writes (set_mode_locs shadow_root_ptr) (set_mode shadow_root_ptr shadow_root_mode) h h'"
by(auto simp add: set_mode_def set_mode_locs_def intro: writes_bind_pure)
lemma set_mode_pointers_preserved:
assumes "w \<in> set_mode_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_mode_locs_def split: if_splits)
lemma set_mode_types_preserved:
assumes "w \<in> set_mode_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_mode_locs_def split: if_splits)
end
interpretation i_set_mode?: l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_mode set_mode_locs
by (auto simp add: l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_mode = l_type_wf +l_set_mode_defs +
assumes set_mode_writes:
"writes (set_mode_locs shadow_root_ptr) (set_mode shadow_root_ptr shadow_root_mode) h h'"
assumes set_mode_ok:
"type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode)"
assumes set_mode_ptr_in_heap:
"h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode) \<Longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
assumes set_mode_pointers_preserved:
"w \<in> set_mode_locs shadow_root_ptr \<Longrightarrow>
h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h'"
assumes set_mode_types_preserved:
"w \<in> set_mode_locs shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma set_mode_is_l_set_mode [instances]: "l_set_mode type_wf set_mode set_mode_locs"
apply(auto simp add: l_set_mode_def instances)[1]
using set_mode_writes apply blast
using set_mode_ok apply (blast)
using set_mode_ptr_in_heap apply blast
using set_mode_pointers_preserved apply(blast, blast)
using set_mode_types_preserved apply(blast, blast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_child_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: get_child_nodes_locs_def set_shadow_root_locs_def CD.get_child_nodes_locs_def
all_args_def
intro: element_put_get_preserved[where setter=shadow_root_opt_update])
end
interpretation i_set_shadow_root_get_child_nodes?: l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
known_ptr DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes get_child_nodes_locs
Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs set_shadow_root
set_shadow_root_locs
by(unfold_locales)
declare l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_child_nodes = l_set_shadow_root + l_get_child_nodes +
assumes set_shadow_root_get_child_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
lemma set_shadow_root_get_child_nodes_is_l_set_shadow_root_get_child_nodes [instances]:
"l_set_shadow_root_get_child_nodes type_wf set_shadow_root set_shadow_root_locs known_ptr
get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_set_shadow_root_get_child_nodes_def
l_set_shadow_root_get_child_nodes_axioms_def instances)[1]
using set_shadow_root_get_child_nodes apply blast
done
paragraph \<open>get\_shadow\_root\<close>
locale l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_shadow_root:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def get_shadow_root_locs_def all_args_def)
end
interpretation
i_set_mode_get_shadow_root?: l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs get_shadow_root
get_shadow_root_locs
by unfold_locales
declare l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_shadow_root = l_set_mode + l_get_shadow_root +
assumes set_mode_get_shadow_root:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
lemma set_mode_get_shadow_root_is_l_set_mode_get_shadow_root [instances]:
"l_set_mode_get_shadow_root type_wf set_mode set_mode_locs get_shadow_root
get_shadow_root_locs"
using set_mode_is_l_set_mode get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_mode_get_shadow_root_def
l_set_mode_get_shadow_root_axioms_def)
using set_mode_get_shadow_root
by fast
paragraph \<open>get\_child\_nodes\<close>
locale l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_child_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def set_mode_locs_def
all_args_def)[1]
end
interpretation i_set_mode_get_child_nodes?: l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_mode
set_mode_locs known_ptr DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes
get_child_nodes_locs Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs
by unfold_locales
declare l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_child_nodes = l_set_mode + l_get_child_nodes +
assumes set_mode_get_child_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
lemma set_mode_get_child_nodes_is_l_set_mode_get_child_nodes [instances]:
"l_set_mode_get_child_nodes type_wf set_mode set_mode_locs known_ptr get_child_nodes
get_child_nodes_locs"
using set_mode_is_l_set_mode get_child_nodes_is_l_get_child_nodes
apply(simp add: l_set_mode_get_child_nodes_def
l_set_mode_get_child_nodes_axioms_def)
using set_mode_get_child_nodes
by fast
subsubsection \<open>get\_host\<close>
locale l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for get_shadow_root
:: "(_::linorder) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_host :: "(_) shadow_root_ptr \<Rightarrow> (_, (_) element_ptr) dom_prog" where
"a_get_host shadow_root_ptr = do {
host_ptrs \<leftarrow> element_ptr_kinds_M \<bind> filter_M (\<lambda>element_ptr. do {
shadow_root_opt \<leftarrow> get_shadow_root element_ptr;
return (shadow_root_opt = Some shadow_root_ptr)
});
(case host_ptrs of host_ptr#[] \<Rightarrow> return host_ptr | _ \<Rightarrow> error HierarchyRequestError)
}"
definition "a_get_host_locs \<equiv> (\<Union>element_ptr. (get_shadow_root_locs element_ptr)) \<union>
(\<Union>ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing)})"
end
global_interpretation l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs
defines get_host = "a_get_host"
and get_host_locs = "a_get_host_locs"
.
locale l_get_host_defs =
fixes get_host :: "(_) shadow_root_ptr \<Rightarrow> (_, (_) element_ptr) dom_prog"
fixes get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_host_defs +
l_get_shadow_root +
assumes get_host_impl: "get_host = a_get_host"
assumes get_host_locs_impl: "get_host_locs = a_get_host_locs"
begin
lemmas get_host_def = get_host_impl[unfolded a_get_host_def]
lemmas get_host_locs_def = get_host_locs_impl[unfolded a_get_host_locs_def]
lemma get_host_pure [simp]: "pure (get_host element_ptr) h"
by(auto simp add: get_host_def intro!: bind_pure_I filter_M_pure_I split: list.splits)
lemma get_host_reads: "reads get_host_locs (get_host element_ptr) h h'"
using get_shadow_root_reads[unfolded reads_def]
by(auto simp add: get_host_def get_host_locs_def
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads] reads_subset[OF error_reads]
reads_subset[OF get_shadow_root_reads] reads_subset[OF return_reads]
reads_subset[OF element_ptr_kinds_M_reads] filter_M_reads filter_M_pure_I
bind_pure_I
split: list.splits)
end
locale l_get_host = l_get_host_defs +
assumes get_host_pure [simp]: "pure (get_host element_ptr) h"
assumes get_host_reads: "reads get_host_locs (get_host node_ptr) h h'"
interpretation i_get_host?: l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_shadow_root get_shadow_root_locs get_host
get_host_locs type_wf
using instances
by (simp add: l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_host_def get_host_locs_def)
declare l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_host_is_l_get_host [instances]: "l_get_host get_host get_host_locs"
apply(auto simp add: l_get_host_def)[1]
using get_host_reads apply fast
done
subsubsection \<open>get\_mode\<close>
locale l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
where
"a_get_mode shadow_root_ptr = get_M shadow_root_ptr mode"
definition a_get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
where
"a_get_mode_locs shadow_root_ptr \<equiv> {preserved (get_M shadow_root_ptr mode)}"
end
global_interpretation l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines get_mode = a_get_mode
and get_mode_locs = a_get_mode_locs
.
locale l_get_mode_defs =
fixes get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
fixes get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_mode_defs get_mode get_mode_locs +
l_type_wf type_wf
for get_mode :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, shadow_root_mode) prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf :: "(_) heap \<Rightarrow> bool" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_mode_impl: "get_mode = a_get_mode"
assumes get_mode_locs_impl: "get_mode_locs = a_get_mode_locs"
begin
lemmas get_mode_def = get_mode_impl[unfolded get_mode_def a_get_mode_def]
lemmas get_mode_locs_def = get_mode_locs_impl[unfolded get_mode_locs_def a_get_mode_locs_def]
lemma get_mode_ok: "type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (get_mode shadow_root_ptr)"
unfolding get_mode_def type_wf_impl
using ShadowRootMonad.get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok by blast
lemma get_mode_pure [simp]: "pure (get_mode element_ptr) h"
unfolding get_mode_def by simp
lemma get_mode_ptr_in_heap:
assumes "h \<turnstile> get_mode shadow_root_ptr \<rightarrow>\<^sub>r children"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms
by(auto simp add: get_mode_def get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_mode_reads: "reads (get_mode_locs element_ptr) (get_mode element_ptr) h h'"
by(simp add: get_mode_def get_mode_locs_def reads_bind_pure reads_insert_writes_set_right)
end
interpretation i_get_mode?: l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_mode get_mode_locs type_wf
using instances
by (auto simp add: l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_mode = l_type_wf + l_get_mode_defs +
assumes get_mode_reads: "reads (get_mode_locs shadow_root_ptr) (get_mode shadow_root_ptr) h h'"
assumes get_mode_ok:
"type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_mode shadow_root_ptr)"
assumes get_mode_ptr_in_heap:
"h \<turnstile> ok (get_mode shadow_root_ptr) \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
assumes get_mode_pure [simp]: "pure (get_mode shadow_root_ptr) h"
lemma get_mode_is_l_get_mode [instances]: "l_get_mode type_wf get_mode get_mode_locs"
apply(auto simp add: l_get_mode_def instances)[1]
using get_mode_reads apply blast
using get_mode_ok apply blast
using get_mode_ptr_in_heap apply blast
done
subsubsection \<open>get\_shadow\_root\_safe\<close>
locale l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_mode_defs get_mode get_mode_locs
for get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
where
"a_get_shadow_root_safe element_ptr = do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
mode \<leftarrow> get_mode shadow_root_ptr;
(if mode = Open then
return (Some shadow_root_ptr)
else
return None
)
} | None \<Rightarrow> return None)
}"
definition a_get_shadow_root_safe_locs
:: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" where
"a_get_shadow_root_safe_locs element_ptr shadow_root_ptr \<equiv>
(get_shadow_root_locs element_ptr) \<union> (get_mode_locs shadow_root_ptr)"
end
global_interpretation l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs
get_mode get_mode_locs
defines get_shadow_root_safe = a_get_shadow_root_safe
and get_shadow_root_safe_locs = a_get_shadow_root_safe_locs
.
locale l_get_shadow_root_safe_defs =
fixes get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
fixes get_shadow_root_safe_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs get_mode get_mode_locs +
l_get_shadow_root_safe_defs get_shadow_root_safe get_shadow_root_safe_locs +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_get_mode type_wf get_mode get_mode_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root_safe ::
"(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_safe_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_shadow_root_safe_impl: "get_shadow_root_safe = a_get_shadow_root_safe"
assumes get_shadow_root_safe_locs_impl: "get_shadow_root_safe_locs = a_get_shadow_root_safe_locs"
begin
lemmas get_shadow_root_safe_def =
get_shadow_root_safe_impl[unfolded get_shadow_root_safe_def a_get_shadow_root_safe_def]
lemmas get_shadow_root_safe_locs_def =
get_shadow_root_safe_locs_impl[unfolded get_shadow_root_safe_locs_def a_get_shadow_root_safe_locs_def]
lemma get_shadow_root_safe_pure [simp]: "pure (get_shadow_root_safe element_ptr) h"
by (auto simp add: get_shadow_root_safe_def bind_pure_I option.case_eq_if)
end
interpretation i_get_shadow_root_safe?: l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root_safe
get_shadow_root_safe_locs get_shadow_root get_shadow_root_locs get_mode get_mode_locs
using instances
by (auto simp add: l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_shadow_root_safe_def get_shadow_root_safe_locs_def)
declare l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_shadow_root_safe = l_get_shadow_root_safe_defs +
assumes get_shadow_root_safe_pure [simp]: "pure (get_shadow_root_safe element_ptr) h"
lemma get_shadow_root_safe_is_l_get_shadow_root_safe [instances]:
"l_get_shadow_root_safe get_shadow_root_safe"
using instances
apply(auto simp add: l_get_shadow_root_safe_def)[1]
done
subsubsection \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma set_disconnected_nodes_ok:
"type_wf h \<Longrightarrow> document_ptr |\<in>| document_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_disconnected_nodes document_ptr node_ptrs)"
using CD.set_disconnected_nodes_ok CD.type_wf_impl ShadowRootClass.type_wf_defs local.type_wf_impl
by blast
lemma set_disconnected_nodes_typess_preserved:
assumes "w \<in> set_disconnected_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
apply(unfold type_wf_impl)
by(auto simp add: all_args_def CD.set_disconnected_nodes_locs_def split: if_splits)
end
interpretation i_set_disconnected_nodes?: l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs
by(auto simp add: l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_disconnected_nodes_is_l_set_disconnected_nodes [instances]:
"l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_def)[1]
apply (simp add: i_set_disconnected_nodes.set_disconnected_nodes_writes)
using set_disconnected_nodes_ok apply blast
apply (simp add: i_set_disconnected_nodes.set_disconnected_nodes_ptr_in_heap)
using i_set_disconnected_nodes.set_disconnected_nodes_pointers_preserved apply (blast, blast)
using set_disconnected_nodes_typess_preserved apply(blast, blast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit)
prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_disconnected_nodes_get_child_nodes:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: set_disconnected_nodes_locs_def get_child_nodes_locs_def
CD.get_child_nodes_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_child_nodes?:
l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_disconnected_nodes
set_disconnected_nodes_locs known_ptr DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes
get_child_nodes_locs Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs
by(auto simp add: l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_child_nodes_is_l_set_disconnected_nodes_get_child_nodes [instances]:
"l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes_locs get_child_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_child_nodes_def)[1]
using set_disconnected_nodes_get_child_nodes apply fast
done
paragraph \<open>get\_host\<close>
locale l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_host:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_host_locs. r h h'))"
by(auto simp add: CD.set_disconnected_nodes_locs_def get_shadow_root_locs_def get_host_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_host?: l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_host get_host_locs
by(auto simp add: l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_disconnected_nodes_get_host = l_set_disconnected_nodes_defs + l_get_host_defs +
assumes set_disconnected_nodes_get_host:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_host_locs. r h h'))"
lemma set_disconnected_nodes_get_host_is_l_set_disconnected_nodes_get_host [instances]:
"l_set_disconnected_nodes_get_host set_disconnected_nodes_locs get_host_locs"
apply(auto simp add: l_set_disconnected_nodes_get_host_def instances)[1]
using set_disconnected_nodes_get_host
by fast
subsubsection \<open>get\_tag\_name\<close>
locale l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, tag_name) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma get_tag_name_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_tag_name element_ptr)"
apply(unfold type_wf_impl get_tag_name_impl[unfolded a_get_tag_name_def])
using CD.get_tag_name_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
by blast
end
interpretation i_get_tag_name?: l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by(auto simp add: l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_tag_name_is_l_get_tag_name [instances]: "l_get_tag_name type_wf get_tag_name
get_tag_name_locs"
apply(auto simp add: l_get_tag_name_def)[1]
using get_tag_name_reads apply fast
using get_tag_name_ok apply fast
done
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_tag_name:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_disconnected_nodes_locs_def CD.get_tag_name_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_tag_name?: l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_tag_name
get_tag_name_locs
by(auto simp add: l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_disconnected_nodes_get_tag_name_is_l_set_disconnected_nodes_get_tag_name [instances]:
"l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs"
apply(auto simp add: l_set_disconnected_nodes_get_tag_name_def
l_set_disconnected_nodes_get_tag_name_axioms_def instances)[1]
using set_disconnected_nodes_get_tag_name
by fast
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_child_nodes_get_tag_name:
"\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_child_nodes_locs_def set_child_nodes_locs_def CD.get_tag_name_locs_def
all_args_def
intro: element_put_get_preserved[where getter=tag_name and
setter=RElement.child_nodes_update])
end
interpretation i_set_child_nodes_get_tag_name?: l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
known_ptr DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_tag_name
get_tag_name_locs
by(auto simp add: l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_child_nodes_get_tag_name_is_l_set_child_nodes_get_tag_name [instances]:
"l_set_child_nodes_get_tag_name type_wf set_child_nodes set_child_nodes_locs get_tag_name
get_tag_name_locs"
apply(auto simp add: l_set_child_nodes_get_tag_name_def l_set_child_nodes_get_tag_name_axioms_def
instances)[1]
using set_child_nodes_get_tag_name
by fast
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_tag_name_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by(auto simp add: l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_tag_name_get_tag_name_locs [instances]: "l_delete_shadow_root_get_tag_name get_tag_name_locs"
apply(auto simp add: l_delete_shadow_root_get_tag_name_def)[1]
using get_tag_name_delete_shadow_root apply fast
done
paragraph \<open>set\_shadow\_root\<close>
locale l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_tag_name:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def CD.get_tag_name_locs_def all_args_def
element_put_get_preserved[where setter=shadow_root_opt_update])
end
interpretation i_set_shadow_root_get_tag_name?: l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_shadow_root set_shadow_root_locs DocumentClass.type_wf get_tag_name get_tag_name_locs
apply(auto simp add: l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_tag_name = l_set_shadow_root_defs + l_get_tag_name_defs +
assumes set_shadow_root_get_tag_name:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
lemma set_shadow_root_get_tag_name_is_l_set_shadow_root_get_tag_name [instances]:
"l_set_shadow_root_get_tag_name set_shadow_root_locs get_tag_name_locs"
using set_shadow_root_is_l_set_shadow_root get_tag_name_is_l_get_tag_name
apply(simp add: l_set_shadow_root_get_tag_name_def )
using set_shadow_root_get_tag_name
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, tag_name) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: CD.get_tag_name_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
lemma new_element_empty_tag_name:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
by(simp add: CD.get_tag_name_def new_element_tag_name)
end
locale l_new_element_get_tag_name = l_new_element + l_get_tag_name +
assumes get_tag_name_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr
\<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
assumes new_element_empty_tag_name:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
interpretation i_new_element_get_tag_name?:
l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name get_tag_name_locs
by(auto simp add: l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_element_get_tag_name_is_l_new_element_get_tag_name [instances]:
"l_new_element_get_tag_name type_wf get_tag_name get_tag_name_locs"
using new_element_is_l_new_element get_tag_name_is_l_get_tag_name
apply(auto simp add: l_new_element_get_tag_name_def l_new_element_get_tag_name_axioms_def
instances)[1]
using get_tag_name_new_element new_element_empty_tag_name
by fast+
paragraph \<open>get\_shadow\_root\<close>
locale l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_tag_name:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def CD.get_tag_name_locs_def all_args_def)
end
interpretation
i_set_mode_get_tag_name?: l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_tag_name = l_set_mode + l_get_tag_name +
assumes set_mode_get_tag_name:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
lemma set_mode_get_tag_name_is_l_set_mode_get_tag_name [instances]:
"l_set_mode_get_tag_name type_wf set_mode set_mode_locs get_tag_name
get_tag_name_locs"
using set_mode_is_l_set_mode get_tag_name_is_l_get_tag_name
apply(simp add: l_set_mode_get_tag_name_def
l_set_mode_get_tag_name_axioms_def)
using set_mode_get_tag_name
by fast
paragraph \<open>new\_document\<close>
locale l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, tag_name) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_new_document_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_document_get_tag_name?:
l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
lemma new_document_get_tag_name_is_l_new_document_get_tag_name [instances]:
"l_new_document_get_tag_name get_tag_name_locs"
unfolding l_new_document_get_tag_name_def
unfolding get_tag_name_locs_def
using new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_tag_name_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: CD.get_tag_name_locs_def new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_shadow_root_get_tag_name = l_get_tag_name +
assumes get_tag_name_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_shadow_root_get_tag_name?:
l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name get_tag_name_locs
by(unfold_locales)
declare l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_shadow_root_get_tag_name_is_l_new_shadow_root_get_tag_name [instances]:
"l_new_shadow_root_get_tag_name type_wf get_tag_name get_tag_name_locs"
using get_tag_name_is_l_get_tag_name
apply(auto simp add: l_new_shadow_root_get_tag_name_def l_new_shadow_root_get_tag_name_axioms_def
instances)[1]
using get_tag_name_new_shadow_root
by fast
paragraph \<open>new\_character\_data\<close>
locale l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, tag_name) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_new_character_data_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_character_data_get_tag_name?:
l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
lemma new_character_data_get_tag_name_is_l_new_character_data_get_tag_name [instances]:
"l_new_character_data_get_tag_name get_tag_name_locs"
unfolding l_new_character_data_get_tag_name_def
unfolding get_tag_name_locs_def
using new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
paragraph \<open>get\_tag\_type\<close>
locale l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M = l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_tag_name:
assumes "h \<turnstile> CD.a_set_tag_name element_ptr tag \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> CD.a_get_tag_name element_ptr \<rightarrow>\<^sub>r tag"
using assms
by(auto simp add: CD.a_get_tag_name_def CD.a_set_tag_name_def)
lemma set_tag_name_get_tag_name_different_pointers:
assumes "ptr \<noteq> ptr'"
assumes "w \<in> CD.a_set_tag_name_locs ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> CD.a_get_tag_name_locs ptr'"
shows "r h h'"
using assms
by(auto simp add: all_args_def CD.a_set_tag_name_locs_def CD.a_get_tag_name_locs_def
split: if_splits option.splits )
end
interpretation i_set_tag_name_get_tag_name?:
l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs set_tag_name set_tag_name_locs
by unfold_locales
declare l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_tag_name_is_l_set_tag_name_get_tag_name [instances]:
"l_set_tag_name_get_tag_name type_wf get_tag_name get_tag_name_locs
set_tag_name set_tag_name_locs"
using set_tag_name_is_l_set_tag_name get_tag_name_is_l_get_tag_name
apply(simp add: l_set_tag_name_get_tag_name_def
l_set_tag_name_get_tag_name_axioms_def)
using set_tag_name_get_tag_name
set_tag_name_get_tag_name_different_pointers
by fast+
subsubsection \<open>attach\_shadow\_root\<close>
locale l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_set_mode_defs set_mode set_mode_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for set_shadow_root ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, unit) prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, char list) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_attach_shadow_root ::
"(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
where
"a_attach_shadow_root element_ptr shadow_root_mode = do {
tag \<leftarrow> get_tag_name element_ptr;
(if tag \<notin> safe_shadow_root_element_types then error NotSupportedError else return ());
prev_shadow_root \<leftarrow> get_shadow_root element_ptr;
(if prev_shadow_root \<noteq> None then error NotSupportedError else return ());
new_shadow_root_ptr \<leftarrow> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M;
set_mode new_shadow_root_ptr shadow_root_mode;
set_shadow_root element_ptr (Some new_shadow_root_ptr);
return new_shadow_root_ptr
}"
end
locale l_attach_shadow_root_defs =
fixes attach_shadow_root ::
"(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
global_interpretation l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_shadow_root set_shadow_root_locs
set_mode set_mode_locs get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs
defines attach_shadow_root = a_attach_shadow_root
.
locale l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_shadow_root set_shadow_root_locs set_mode set_mode_locs
get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs +
l_attach_shadow_root_defs attach_shadow_root +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root set_shadow_root_locs +
l_set_mode type_wf set_mode set_mode_locs +
l_get_tag_name type_wf get_tag_name get_tag_name_locs +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_known_ptr known_ptr
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and set_shadow_root ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, unit) prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and attach_shadow_root ::
"(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr) prog"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, char list) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
assumes attach_shadow_root_impl: "attach_shadow_root = a_attach_shadow_root"
begin
lemmas attach_shadow_root_def = a_attach_shadow_root_def[folded attach_shadow_root_impl]
lemma attach_shadow_root_element_ptr_in_heap:
assumes "h \<turnstile> ok (attach_shadow_root element_ptr shadow_root_mode)"
shows "element_ptr |\<in>| element_ptr_kinds h"
proof -
obtain h' where "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>h h'"
using assms by auto
then
obtain h2 h3 new_shadow_root_ptr where
h2: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2" and
new_shadow_root_ptr: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr" and
h3: "h2 \<turnstile> set_mode new_shadow_root_ptr shadow_root_mode \<rightarrow>\<^sub>h h3" and
"h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'"
by(auto simp add: attach_shadow_root_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
then have "element_ptr |\<in>| element_ptr_kinds h3"
using set_shadow_root_ptr_in_heap by blast
moreover
have "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr new_shadow_root_ptr by auto
moreover
have "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_mode_writes h3])
using set_mode_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
ultimately
show ?thesis
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
qed
lemma create_shadow_root_known_ptr:
assumes "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "known_ptr (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr)"
using assms
by(auto simp add: attach_shadow_root_def known_ptr_impl ShadowRootClass.a_known_ptr_def
new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def
elim!: bind_returns_result_E)
end
locale l_attach_shadow_root = l_attach_shadow_root_defs
interpretation
i_attach_shadow_root?: l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr set_shadow_root set_shadow_root_locs
set_mode set_mode_locs attach_shadow_root type_wf get_tag_name get_tag_name_locs get_shadow_root
get_shadow_root_locs
by(auto simp add: l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
attach_shadow_root_def instances)
declare l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_parent\<close>
global_interpretation l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
defines get_parent = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent get_child_nodes"
and get_parent_locs = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent_locs get_child_nodes_locs"
.
interpretation i_get_parent?: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs
by(simp add: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_parent_def
get_parent_locs_def instances)
declare l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_parent_is_l_get_parent [instances]: "l_get_parent type_wf known_ptr known_ptrs get_parent
get_parent_locs get_child_nodes get_child_nodes_locs"
apply(simp add: l_get_parent_def l_get_parent_axioms_def instances)
using get_parent_reads get_parent_ok get_parent_ptr_in_heap get_parent_pure
get_parent_parent_in_heap get_parent_child_dual get_parent_reads_pointers
by blast
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_child_nodes
+ l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_parent [simp]:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_parent_locs. r h h'))"
by(auto simp add: get_parent_locs_def CD.set_disconnected_nodes_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_parent?: l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs type_wf
DocumentClass.type_wf known_ptr known_ptrs get_parent get_parent_locs
by (simp add: l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_parent_is_l_set_disconnected_nodes_get_parent [instances]:
"l_set_disconnected_nodes_get_parent set_disconnected_nodes_locs get_parent_locs"
by(simp add: l_set_disconnected_nodes_get_parent_def)
subsubsection \<open>get\_root\_node\<close>
global_interpretation l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs
defines get_root_node = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node get_parent"
and get_root_node_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node_locs get_parent_locs"
and get_ancestors = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors get_parent"
and get_ancestors_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors_locs get_parent_locs"
.
declare a_get_ancestors.simps [code]
interpretation i_get_root_node?: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_ancestors get_ancestors_locs
get_root_node get_root_node_locs
by(simp add: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_root_node_def
get_root_node_locs_def get_ancestors_def get_ancestors_locs_def instances)
declare l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_ancestors_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors"
apply(auto simp add: l_get_ancestors_def)[1]
using get_ancestors_ptr_in_heap apply fast
using get_ancestors_ptr apply fast
done
lemma get_root_node_is_l_get_root_node [instances]: "l_get_root_node get_root_node get_parent"
by (simp add: l_get_root_node_def Shadow_DOM.i_get_root_node.get_root_node_no_parent)
subsubsection \<open>get\_root\_node\_si\<close>
locale l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_parent_defs get_parent get_parent_locs +
l_get_host_defs get_host get_host_locs
for get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_::linorder) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
partial_function (dom_prog) a_get_ancestors_si ::
"(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_get_ancestors_si ptr = do {
check_in_heap ptr;
ancestors \<leftarrow> (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of
Some node_ptr \<Rightarrow> do {
parent_ptr_opt \<leftarrow> get_parent node_ptr;
(case parent_ptr_opt of
Some parent_ptr \<Rightarrow> a_get_ancestors_si parent_ptr
| None \<Rightarrow> return [])
}
| None \<Rightarrow> (case cast ptr of
Some shadow_root_ptr \<Rightarrow> do {
host \<leftarrow> get_host shadow_root_ptr;
a_get_ancestors_si (cast host)
} |
None \<Rightarrow> return []));
return (ptr # ancestors)
}"
definition "a_get_ancestors_si_locs = get_parent_locs \<union> get_host_locs"
definition a_get_root_node_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr) dom_prog"
where
"a_get_root_node_si ptr = do {
ancestors \<leftarrow> a_get_ancestors_si ptr;
return (last ancestors)
}"
definition "a_get_root_node_si_locs = a_get_ancestors_si_locs"
end
locale l_get_ancestors_si_defs =
fixes get_ancestors_si :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
fixes get_ancestors_si_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_root_node_si_defs =
fixes get_root_node_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr) dom_prog"
fixes get_root_node_si_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent +
l_get_host +
l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_ancestors_si_defs +
l_get_root_node_si_defs +
assumes get_ancestors_si_impl: "get_ancestors_si = a_get_ancestors_si"
assumes get_ancestors_si_locs_impl: "get_ancestors_si_locs = a_get_ancestors_si_locs"
assumes get_root_node_si_impl: "get_root_node_si = a_get_root_node_si"
assumes get_root_node_si_locs_impl: "get_root_node_si_locs = a_get_root_node_si_locs"
begin
lemmas get_ancestors_si_def = a_get_ancestors_si.simps[folded get_ancestors_si_impl]
lemmas get_ancestors_si_locs_def = a_get_ancestors_si_locs_def[folded get_ancestors_si_locs_impl]
lemmas get_root_node_si_def =
a_get_root_node_si_def[folded get_root_node_si_impl get_ancestors_si_impl]
lemmas get_root_node_si_locs_def =
a_get_root_node_si_locs_def[folded get_root_node_si_locs_impl get_ancestors_si_locs_impl]
lemma get_ancestors_si_pure [simp]:
"pure (get_ancestors_si ptr) h"
proof -
have "\<forall>ptr h h' x. h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r x \<longrightarrow> h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>h h' \<longrightarrow> h = h'"
proof (induct rule: a_get_ancestors_si.fixp_induct[folded get_ancestors_si_impl])
case 1
then show ?case
by(rule admissible_dom_prog)
next
case 2
then show ?case
by simp
next
case (3 f)
then show ?case
using get_parent_pure get_host_pure
apply(auto simp add: pure_returns_heap_eq pure_def
split: option.splits
elim!: bind_returns_heap_E bind_returns_result_E
dest!: pure_returns_heap_eq[rotated, OF check_in_heap_pure])[1]
apply (meson option.simps(3) returns_result_eq)
apply(metis get_parent_pure pure_returns_heap_eq)
apply(metis get_host_pure pure_returns_heap_eq)
done
qed
then show ?thesis
by (meson pure_eq_iff)
qed
lemma get_root_node_si_pure [simp]: "pure (get_root_node_si ptr) h"
by(auto simp add: get_root_node_si_def bind_pure_I)
lemma get_ancestors_si_ptr_in_heap:
assumes "h \<turnstile> ok (get_ancestors_si ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_ancestors_si_def check_in_heap_ptr_in_heap elim!: bind_is_OK_E
dest: is_OK_returns_result_I)
lemma get_ancestors_si_ptr:
assumes "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
shows "ptr \<in> set ancestors"
using assms
by(simp add: get_ancestors_si_def)
(auto elim!: bind_returns_result_E2
split: option.splits
intro!: bind_pure_I)
lemma get_ancestors_si_never_empty:
assumes "h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors"
shows "ancestors \<noteq> []"
using assms
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
lemma get_root_node_si_no_parent:
"h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None \<Longrightarrow> h \<turnstile> get_root_node_si (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
apply(auto simp add: check_in_heap_def get_root_node_si_def get_ancestors_si_def
intro!: bind_pure_returns_result_I )[1]
using get_parent_ptr_in_heap by blast
lemma get_root_node_si_root_not_shadow_root:
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root"
shows "\<not> is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root"
using assms
proof(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)
fix y
assume "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r y"
and "is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (last y)"
and "root = last y"
then
show False
proof(induct y arbitrary: ptr)
case Nil
then show ?case
using assms(1) get_ancestors_si_never_empty by blast
next
case (Cons a x)
then show ?case
apply(auto simp add: get_ancestors_si_def[of ptr]
elim!: bind_returns_result_E2
split: option.splits if_splits)[1]
using get_ancestors_si_never_empty apply blast
using Cons.prems(2) apply auto[1]
using \<open>is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (last y)\<close> \<open>root = last y\<close> by auto
qed
qed
end
global_interpretation l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_host get_host_locs
defines get_root_node_si = a_get_root_node_si
and get_root_node_si_locs = a_get_root_node_si_locs
and get_ancestors_si = a_get_ancestors_si
and get_ancestors_si_locs = a_get_ancestors_si_locs
.
declare a_get_ancestors_si.simps [code]
interpretation i_get_root_node_si?: l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs
get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_host get_host_locs
get_ancestors_si get_ancestors_si_locs get_root_node_si get_root_node_si_locs
apply(auto simp add: l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
instances)[1]
by(auto simp add: get_root_node_si_def get_root_node_si_locs_def get_ancestors_si_def
get_ancestors_si_locs_def)
declare l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_si_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors_si"
unfolding l_get_ancestors_def
using get_ancestors_si_pure get_ancestors_si_ptr get_ancestors_si_ptr_in_heap
by blast
lemma get_root_node_si_is_l_get_root_node [instances]: "l_get_root_node get_root_node_si get_parent"
apply(simp add: l_get_root_node_def)
using get_root_node_si_no_parent
by fast
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_parent
+ l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_disconnected_nodes_get_host
begin
lemma set_disconnected_nodes_get_ancestors_si:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_ancestors_si_locs. r h h'))"
by(auto simp add: get_parent_locs_def set_disconnected_nodes_locs_def
set_disconnected_nodes_get_host get_ancestors_si_locs_def all_args_def)
end
locale l_set_disconnected_nodes_get_ancestors_si =
l_set_disconnected_nodes_defs +
l_get_ancestors_si_defs +
assumes set_disconnected_nodes_get_ancestors_si:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_ancestors_si_locs. r h h'))"
interpretation i_set_disconnected_nodes_get_ancestors_si?:
l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs
get_parent get_parent_locs type_wf known_ptr known_ptrs get_child_nodes get_child_nodes_locs
get_host get_host_locs get_ancestors_si get_ancestors_si_locs get_root_node_si
get_root_node_si_locs DocumentClass.type_wf
by (auto simp add: l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_ancestors_si_is_l_set_disconnected_nodes_get_ancestors_si [instances]:
"l_set_disconnected_nodes_get_ancestors_si set_disconnected_nodes_locs get_ancestors_si_locs"
using instances
apply(simp add: l_set_disconnected_nodes_get_ancestors_si_def)
using set_disconnected_nodes_get_ancestors_si
by fast
subsubsection \<open>get\_attribute\<close>
lemma get_attribute_is_l_get_attribute [instances]:
"l_get_attribute type_wf get_attribute get_attribute_locs"
apply(auto simp add: l_get_attribute_def)[1]
using i_get_attribute.get_attribute_reads apply fast
using type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t i_get_attribute.get_attribute_ok apply blast
using i_get_attribute.get_attribute_ptr_in_heap apply fast
done
subsubsection \<open>to\_tree\_order\<close>
global_interpretation l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs defines
to_tree_order = "l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_to_tree_order get_child_nodes" .
declare a_to_tree_order.simps [code]
interpretation i_to_tree_order?: l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ShadowRootClass.known_ptr
ShadowRootClass.type_wf Shadow_DOM.get_child_nodes Shadow_DOM.get_child_nodes_locs to_tree_order
by(auto simp add: l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def to_tree_order_def
instances)
declare l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>to\_tree\_order\_si\<close>
locale l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
partial_function (dom_prog) a_to_tree_order_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_to_tree_order_si ptr = (do {
children \<leftarrow> get_child_nodes ptr;
shadow_root_part \<leftarrow> (case cast ptr of
Some element_ptr \<Rightarrow> do {
shadow_root_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_opt of
Some shadow_root_ptr \<Rightarrow> return [cast shadow_root_ptr]
| None \<Rightarrow> return [])
} |
None \<Rightarrow> return []);
treeorders \<leftarrow> map_M a_to_tree_order_si ((map (cast) children) @ shadow_root_part);
return (ptr # concat treeorders)
})"
end
locale l_to_tree_order_si_defs =
fixes to_tree_order_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
global_interpretation l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs
defines to_tree_order_si = "a_to_tree_order_si" .
declare a_to_tree_order_si.simps [code]
locale l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_to_tree_order_si_defs +
l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_child_nodes +
l_get_shadow_root +
assumes to_tree_order_si_impl: "to_tree_order_si = a_to_tree_order_si"
begin
lemmas to_tree_order_si_def = a_to_tree_order_si.simps[folded to_tree_order_si_impl]
lemma to_tree_order_si_pure [simp]: "pure (to_tree_order_si ptr) h"
proof -
have "\<forall>ptr h h' x. h \<turnstile> to_tree_order_si ptr \<rightarrow>\<^sub>r x \<longrightarrow> h \<turnstile> to_tree_order_si ptr \<rightarrow>\<^sub>h h' \<longrightarrow> h = h'"
proof (induct rule: a_to_tree_order_si.fixp_induct[folded to_tree_order_si_impl])
case 1
then show ?case
by (rule admissible_dom_prog)
next
case 2
then show ?case
by simp
next
case (3 f)
then have "\<And>x h. pure (f x) h"
by (metis is_OK_returns_heap_E is_OK_returns_result_E pure_def)
then have "\<And>xs h. pure (map_M f xs) h"
by(rule map_M_pure_I)
then show ?case
by(auto elim!: bind_returns_heap_E2 split: option.splits)
qed
then show ?thesis
unfolding pure_def
by (metis is_OK_returns_heap_E is_OK_returns_result_E)
qed
end
interpretation i_to_tree_order_si?: l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order_si get_child_nodes
get_child_nodes_locs get_shadow_root get_shadow_root_locs type_wf known_ptr
by(auto simp add: l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
to_tree_order_si_def instances)
declare l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>first\_in\_tree\_order\<close>
global_interpretation l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order defines
first_in_tree_order = "l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_first_in_tree_order to_tree_order" .
interpretation i_first_in_tree_order?: l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order
by(auto simp add: l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def first_in_tree_order_def)
declare l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_is_l_to_tree_order [instances]: "l_to_tree_order to_tree_order"
by(auto simp add: l_to_tree_order_def)
subsubsection \<open>first\_in\_tree\_order\<close>
global_interpretation l_dummy defines
first_in_tree_order_si = "l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_first_in_tree_order to_tree_order_si"
.
subsubsection \<open>get\_element\_by\<close>
global_interpretation l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order first_in_tree_order get_attribute
get_attribute_locs
defines
get_element_by_id =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_element_by_id first_in_tree_order get_attribute" and
get_elements_by_class_name =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_class_name to_tree_order get_attribute" and
get_elements_by_tag_name =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_tag_name to_tree_order" .
interpretation i_get_element_by?: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order
get_attribute get_attribute_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name type_wf
by(auto simp add: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_element_by_id_def get_elements_by_class_name_def get_elements_by_tag_name_def
instances)
declare l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_element_by_is_l_get_element_by [instances]:
"l_get_element_by get_element_by_id get_elements_by_tag_name to_tree_order"
apply(auto simp add: l_get_element_by_def)[1]
using get_element_by_id_result_in_tree_order apply fast
done
subsubsection \<open>get\_element\_by\_si\<close>
global_interpretation l_dummy defines
get_element_by_id_si =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_element_by_id first_in_tree_order_si get_attribute" and
get_elements_by_class_name_si =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_class_name to_tree_order_si get_attribute" and
get_elements_by_tag_name_si =
"l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_tag_name to_tree_order_si"
.
subsubsection \<open>find\_slot\<close>
locale l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_parent_defs get_parent get_parent_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_mode_defs get_mode get_mode_locs +
l_get_attribute_defs get_attribute get_attribute_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_first_in_tree_order_defs first_in_tree_order
for get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_::linorder) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, shadow_root_mode) prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_attribute :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, char list option) prog"
and get_attribute_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and first_in_tree_order ::
"(_) object_ptr \<Rightarrow> ((_) object_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog) \<Rightarrow>
((_) heap, exception, (_) element_ptr option) prog"
begin
definition a_find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
where
"a_find_slot open_flag slotable = do {
parent_opt \<leftarrow> get_parent slotable;
(case parent_opt of
Some parent \<Rightarrow>
if is_element_ptr_kind parent
then do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root (the (cast parent));
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
shadow_root_mode \<leftarrow> get_mode shadow_root_ptr;
if open_flag \<and> shadow_root_mode \<noteq> Open
then return None
else first_in_tree_order (cast shadow_root_ptr) (\<lambda>ptr. if is_element_ptr_kind ptr
then do {
tag \<leftarrow> get_tag_name (the (cast ptr));
name_attr \<leftarrow> get_attribute (the (cast ptr)) ''name'';
slotable_name_attr \<leftarrow> (if is_element_ptr_kind slotable
then get_attribute (the (cast slotable)) ''slot''
else return None);
(if (tag = ''slot'' \<and> (name_attr = slotable_name_attr \<or>
(name_attr = None \<and> slotable_name_attr = Some '''') \<or>
(name_attr = Some '''' \<and> slotable_name_attr = None)))
then return (Some (the (cast ptr)))
else return None)}
else return None)}
| None \<Rightarrow> return None)}
else return None
| _ \<Rightarrow> return None)}"
definition a_assigned_slot :: "(_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
where
"a_assigned_slot = a_find_slot True"
end
global_interpretation l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_shadow_root
get_shadow_root_locs get_mode get_mode_locs get_attribute get_attribute_locs get_tag_name
get_tag_name_locs first_in_tree_order
defines find_slot = a_find_slot
and assigned_slot = a_assigned_slot
.
locale l_find_slot_defs =
fixes find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
locale l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_find_slot_defs +
l_get_parent +
l_get_shadow_root +
l_get_mode +
l_get_attribute +
l_get_tag_name +
l_to_tree_order +
l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
assumes find_slot_impl: "find_slot = a_find_slot"
assumes assigned_slot_impl: "assigned_slot = a_assigned_slot"
begin
lemmas find_slot_def = find_slot_impl[unfolded a_find_slot_def]
lemmas assigned_slot_def = assigned_slot_impl[unfolded a_assigned_slot_def]
lemma find_slot_ptr_in_heap:
assumes "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r slot_opt"
shows "slotable |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: find_slot_def elim!: bind_returns_result_E2)[1]
using get_parent_ptr_in_heap by blast
lemma find_slot_slot_in_heap:
assumes "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r Some slot"
shows "slot |\<in>| element_ptr_kinds h"
using assms
apply(auto simp add: find_slot_def first_in_tree_order_def
elim!: bind_returns_result_E2 map_filter_M_pure_E[where y=slot]
split: option.splits if_splits list.splits
intro!: map_filter_M_pure bind_pure_I)[1]
using get_tag_name_ptr_in_heap by blast+
lemma find_slot_pure [simp]: "pure (find_slot open_flag slotable) h"
by(auto simp add: find_slot_def first_in_tree_order_def
intro!: bind_pure_I map_filter_M_pure
split: option.splits list.splits)
end
interpretation i_find_slot?: l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_shadow_root
get_shadow_root_locs get_mode get_mode_locs get_attribute get_attribute_locs get_tag_name
get_tag_name_locs first_in_tree_order find_slot assigned_slot type_wf known_ptr known_ptrs
get_child_nodes get_child_nodes_locs to_tree_order
by (auto simp add: find_slot_def assigned_slot_def l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_find_slot = l_find_slot_defs +
assumes find_slot_ptr_in_heap:
"h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r slot_opt \<Longrightarrow> slotable |\<in>| node_ptr_kinds h"
assumes find_slot_slot_in_heap:
"h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r Some slot \<Longrightarrow> slot |\<in>| element_ptr_kinds h"
assumes find_slot_pure [simp]:
"pure (find_slot open_flag slotable) h"
lemma find_slot_is_l_find_slot [instances]: "l_find_slot find_slot"
apply(auto simp add: l_find_slot_def)[1]
using find_slot_ptr_in_heap apply fast
using find_slot_slot_in_heap apply fast
done
subsubsection \<open>get\_disconnected\_nodes\<close>
locale l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma get_disconnected_nodes_ok:
"type_wf h \<Longrightarrow> document_ptr |\<in>| document_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (get_disconnected_nodes document_ptr)"
apply(unfold type_wf_impl get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def])
using CD.get_disconnected_nodes_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
by blast
end
interpretation i_get_disconnected_nodes?: l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
instances)
declare l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_disconnected_nodes_is_l_get_disconnected_nodes [instances]:
"l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs"
apply(auto simp add: l_get_disconnected_nodes_def)[1]
using i_get_disconnected_nodes.get_disconnected_nodes_reads apply fast
using get_disconnected_nodes_ok apply fast
using i_get_disconnected_nodes.get_disconnected_nodes_ptr_in_heap apply fast
done
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_child_nodes_get_disconnected_nodes:
"\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_child_nodes_locs_def CD.set_child_nodes_locs_def
CD.get_disconnected_nodes_locs_def all_args_def)
end
interpretation
i_set_child_nodes_get_disconnected_nodes?: l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
known_ptr DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs
apply(auto simp add: l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_disconnected_nodes_is_l_set_child_nodes_get_disconnected_nodes [instances]:
"l_set_child_nodes_get_disconnected_nodes type_wf set_child_nodes set_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs"
using set_child_nodes_is_l_set_child_nodes get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_child_nodes_get_disconnected_nodes_def
l_set_child_nodes_get_disconnected_nodes_axioms_def)
using set_child_nodes_get_disconnected_nodes
by fast
paragraph \<open>set\_disconnected\_nodes\<close>
lemma set_disconnected_nodes_get_disconnected_nodes_l_set_disconnected_nodes_get_disconnected_nodes
[instances]:
"l_set_disconnected_nodes_get_disconnected_nodes ShadowRootClass.type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_def
l_set_disconnected_nodes_get_disconnected_nodes_axioms_def instances)[1]
using i_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
apply fast
using i_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes_different_pointers
apply fast
done
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_disconnected_nodes_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_disconnected_nodes_locs_def delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_disconnected_nodes = l_get_disconnected_nodes_defs +
assumes get_disconnected_nodes_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_disconnected_nodes_get_disconnected_nodes_locs [instances]: "l_delete_shadow_root_get_disconnected_nodes get_disconnected_nodes_locs"
apply(auto simp add: l_delete_shadow_root_get_disconnected_nodes_def)[1]
using get_disconnected_nodes_delete_shadow_root apply fast
done
paragraph \<open>set\_shadow\_root\<close>
locale l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_disconnected_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def CD.get_disconnected_nodes_locs_def all_args_def)
end
interpretation i_set_shadow_root_get_disconnected_nodes?:
l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root set_shadow_root_locs
DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs
apply(auto simp add: l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_disconnected_nodes =
l_set_shadow_root_defs +
l_get_disconnected_nodes_defs +
assumes set_shadow_root_get_disconnected_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
lemma set_shadow_root_get_disconnected_nodes_is_l_set_shadow_root_get_disconnected_nodes [instances]:
"l_set_shadow_root_get_disconnected_nodes set_shadow_root_locs get_disconnected_nodes_locs"
using set_shadow_root_is_l_set_shadow_root get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_shadow_root_get_disconnected_nodes_def )
using set_shadow_root_get_disconnected_nodes
by fast
paragraph \<open>set\_mode\<close>
locale l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_disconnected_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def
CD.get_disconnected_nodes_locs_impl[unfolded CD.a_get_disconnected_nodes_locs_def]
all_args_def)
end
interpretation i_set_mode_get_disconnected_nodes?: l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs
by unfold_locales
declare l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_disconnected_nodes = l_set_mode + l_get_disconnected_nodes +
assumes set_mode_get_disconnected_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
lemma set_mode_get_disconnected_nodes_is_l_set_mode_get_disconnected_nodes [instances]:
"l_set_mode_get_disconnected_nodes type_wf set_mode set_mode_locs get_disconnected_nodes
get_disconnected_nodes_locs"
using set_mode_is_l_set_mode get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_mode_get_disconnected_nodes_def
l_set_mode_get_disconnected_nodes_axioms_def)
using set_mode_get_disconnected_nodes
by fast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_disconnected_nodes_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_disconnected_nodes_locs_def new_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
interpretation i_new_shadow_root_get_disconnected_nodes?:
l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
get_disconnected_nodes get_disconnected_nodes_locs
by unfold_locales
declare l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_new_shadow_root_get_disconnected_nodes = l_get_disconnected_nodes_defs +
assumes get_disconnected_nodes_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
lemma new_shadow_root_get_disconnected_nodes_is_l_new_shadow_root_get_disconnected_nodes [instances]:
"l_new_shadow_root_get_disconnected_nodes get_disconnected_nodes_locs"
apply (auto simp add: l_new_shadow_root_get_disconnected_nodes_def)[1]
using get_disconnected_nodes_new_shadow_root apply fast
done
subsubsection \<open>remove\_shadow\_root\<close>
locale l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_shadow_root ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_remove_shadow_root :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog" where
"a_remove_shadow_root element_ptr = do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
children \<leftarrow> get_child_nodes (cast shadow_root_ptr);
(if children = []
then do {
set_shadow_root element_ptr None;
delete_M shadow_root_ptr
} else do {
error HierarchyRequestError
})
} |
None \<Rightarrow> error HierarchyRequestError)
}"
definition a_remove_shadow_root_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_remove_shadow_root_locs element_ptr shadow_root_ptr \<equiv>
set_shadow_root_locs element_ptr \<union> {delete_M shadow_root_ptr}"
end
global_interpretation l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs
defines remove_shadow_root = "a_remove_shadow_root"
and remove_shadow_root_locs = a_remove_shadow_root_locs
.
locale l_remove_shadow_root_defs =
fixes remove_shadow_root :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog"
fixes remove_shadow_root_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
locale l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_remove_shadow_root_defs +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes +
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
assumes remove_shadow_root_impl: "remove_shadow_root = a_remove_shadow_root"
assumes remove_shadow_root_locs_impl: "remove_shadow_root_locs = a_remove_shadow_root_locs"
begin
lemmas remove_shadow_root_def =
remove_shadow_root_impl[unfolded remove_shadow_root_def a_remove_shadow_root_def]
lemmas remove_shadow_root_locs_def =
remove_shadow_root_locs_impl[unfolded remove_shadow_root_locs_def a_remove_shadow_root_locs_def]
lemma remove_shadow_root_writes:
"writes (remove_shadow_root_locs element_ptr (the |h \<turnstile> get_shadow_root element_ptr|\<^sub>r))
(remove_shadow_root element_ptr) h h'"
apply(auto simp add: remove_shadow_root_locs_def remove_shadow_root_def all_args_def
writes_union_right_I writes_union_left_I set_shadow_root_writes
intro!: writes_bind writes_bind_pure[OF get_shadow_root_pure]
writes_bind_pure[OF get_child_nodes_pure]
intro: writes_subset[OF set_shadow_root_writes] writes_subset[OF writes_singleton2]
split: option.splits)[1]
using writes_union_left_I[OF set_shadow_root_writes]
apply (metis inf_sup_aci(5) insert_is_Un)
using writes_union_right_I[OF writes_singleton[of delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M]]
by (smt (verit, best) insert_is_Un writes_singleton2 writes_union_left_I)
end
interpretation i_remove_shadow_root?: l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs
get_disconnected_nodes get_disconnected_nodes_locs remove_shadow_root remove_shadow_root_locs
type_wf known_ptr
by(auto simp add: l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
remove_shadow_root_def remove_shadow_root_locs_def instances)
declare l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
paragraph \<open>get\_child\_nodes\<close>
locale l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_get_child_nodes_different_pointers:
assumes "ptr \<noteq> cast shadow_root_ptr"
assumes "w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_child_nodes_locs ptr"
shows "r h h'"
using assms
apply(auto simp add: all_args_def get_child_nodes_locs_def CD.get_child_nodes_locs_def
remove_shadow_root_locs_def set_shadow_root_locs_def
delete_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t[rotated]
element_put_get_preserved[where setter=shadow_root_opt_update]
intro: is_shadow_root_ptr_kind_obtains
elim: is_document_ptr_kind_obtains is_shadow_root_ptr_kind_obtains
split: if_splits option.splits)[1]
done
end
locale l_remove_shadow_root_get_child_nodes = l_get_child_nodes_defs + l_remove_shadow_root_defs +
assumes remove_shadow_root_get_child_nodes_different_pointers:
"ptr \<noteq> cast shadow_root_ptr \<Longrightarrow> w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr \<Longrightarrow>
h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr \<Longrightarrow> r h h'"
interpretation i_remove_shadow_root_get_child_nodes?: l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes
get_child_nodes_locs Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs remove_shadow_root remove_shadow_root_locs
by(auto simp add: l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma remove_shadow_root_get_child_nodes_is_l_remove_shadow_root_get_child_nodes [instances]:
"l_remove_shadow_root_get_child_nodes get_child_nodes_locs remove_shadow_root_locs"
apply(auto simp add: l_remove_shadow_root_get_child_nodes_def instances )[1]
using remove_shadow_root_get_child_nodes_different_pointers apply fast
done
paragraph \<open>get\_tag\_name\<close>
locale l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_get_tag_name:
assumes "w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_tag_name_locs ptr"
shows "r h h'"
using assms
by(auto simp add: all_args_def remove_shadow_root_locs_def set_shadow_root_locs_def
CD.get_tag_name_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
element_put_get_preserved[where setter=shadow_root_opt_update]
split: if_splits option.splits)
end
locale l_remove_shadow_root_get_tag_name = l_get_tag_name_defs + l_remove_shadow_root_defs +
assumes remove_shadow_root_get_tag_name:
"w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_tag_name_locs ptr \<Longrightarrow> r h h'"
interpretation i_remove_shadow_root_get_tag_name?: l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf get_tag_name get_tag_name_locs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs remove_shadow_root remove_shadow_root_locs known_ptr
by(auto simp add: l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma remove_shadow_root_get_tag_name_is_l_remove_shadow_root_get_tag_name [instances]:
"l_remove_shadow_root_get_tag_name get_tag_name_locs remove_shadow_root_locs"
apply(auto simp add: l_remove_shadow_root_get_tag_name_def instances )[1]
using remove_shadow_root_get_tag_name apply fast
done
subsubsection \<open>get\_owner\_document\<close>
locale l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_host_defs get_host get_host_locs +
CD: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs get_disconnected_nodes
get_disconnected_nodes_locs
for get_root_node :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ::
"(_) shadow_root_ptr \<Rightarrow> unit \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr _ = do {
host \<leftarrow> get_host shadow_root_ptr;
CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast host) ()
}"
definition a_get_owner_document_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) document_ptr) dom_prog)) list"
where
"a_get_owner_document_tups = [(is_shadow_root_ptr, a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_get_owner_document :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_owner_document ptr = invoke (CD.a_get_owner_document_tups @ a_get_owner_document_tups) ptr ()"
end
global_interpretation l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node_si get_root_node_si_locs
get_disconnected_nodes get_disconnected_nodes_locs get_host get_host_locs
defines get_owner_document_tups = a_get_owner_document_tups
and get_owner_document = a_get_owner_document
and get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r = a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r
and get_owner_document_tups\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
"l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document_tups
get_root_node_si get_disconnected_nodes"
and get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r =
"l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r
get_root_node_si get_disconnected_nodes"
.
locale l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_known_ptr known_ptr +
l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node_si get_root_node_si_locs get_disconnected_nodes
get_disconnected_nodes_locs get_host get_host_locs +
l_get_owner_document_defs get_owner_document +
l_get_host get_host get_host_locs +
CD: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_parent get_parent_locs known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_disconnected_nodes
get_disconnected_nodes_locs get_root_node_si get_root_node_si_locs get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node_si :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_si_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_owner_document :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
assumes get_owner_document_impl: "get_owner_document = a_get_owner_document"
begin
lemmas known_ptr_def = known_ptr_impl[unfolded a_known_ptr_def]
lemmas get_owner_document_def = a_get_owner_document_def[folded get_owner_document_impl]
lemma get_owner_document_pure [simp]:
"pure (get_owner_document ptr) h"
proof -
have "\<And>shadow_root_ptr. pure (a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr ()) h"
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_I filter_M_pure_I
split: option.splits)[1]
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_I filter_M_pure_I
split: option.splits)
then show ?thesis
apply(auto simp add: get_owner_document_def)[1]
apply(split CD.get_owner_document_splits, rule conjI)+
apply(simp)
apply(auto simp add: a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
apply simp
by(auto intro!: bind_pure_I)
qed
lemma get_owner_document_ptr_in_heap:
assumes "h \<turnstile> ok (get_owner_document ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_owner_document_def invoke_ptr_in_heap dest: is_OK_returns_heap_I)
end
interpretation i_get_owner_document?: l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr DocumentClass.known_ptr
get_parent get_parent_locs type_wf get_disconnected_nodes get_disconnected_nodes_locs
get_root_node_si get_root_node_si_locs CD.a_get_owner_document get_host get_host_locs
get_owner_document
by(auto simp add: instances l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_owner_document_def Core_DOM_Functions.get_owner_document_def)
declare l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_is_l_get_owner_document [instances]:
"l_get_owner_document get_owner_document"
apply(auto simp add: l_get_owner_document_def)[1]
using get_owner_document_ptr_in_heap apply fast
done
subsubsection \<open>remove\_child\<close>
global_interpretation l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_parent get_parent_locs get_owner_document get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
defines remove = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove get_child_nodes set_child_nodes get_parent
get_owner_document get_disconnected_nodes set_disconnected_nodes"
and remove_child = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child get_child_nodes set_child_nodes
get_owner_document get_disconnected_nodes set_disconnected_nodes"
and remove_child_locs = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child_locs set_child_nodes_locs
set_disconnected_nodes_locs"
.
interpretation i_remove_child?: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M Shadow_DOM.get_child_nodes
Shadow_DOM.get_child_nodes_locs Shadow_DOM.set_child_nodes Shadow_DOM.set_child_nodes_locs
Shadow_DOM.get_parent Shadow_DOM.get_parent_locs Shadow_DOM.get_owner_document
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs remove_child remove_child_locs remove ShadowRootClass.type_wf
ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
by(auto simp add: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def remove_child_def
remove_child_locs_def remove_def instances)
declare l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_disconnected\_document\<close>
locale l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_disconnected_nodes ::
"(_::linorder) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_disconnected_document :: "(_) node_ptr \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_disconnected_document node_ptr = do {
check_in_heap (cast node_ptr);
ptrs \<leftarrow> document_ptr_kinds_M;
candidates \<leftarrow> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (node_ptr \<in> set disconnected_nodes)
}) ptrs;
(case candidates of
Cons document_ptr [] \<Rightarrow> return document_ptr |
_ \<Rightarrow> error HierarchyRequestError
)
}"
definition "a_get_disconnected_document_locs =
(\<Union>document_ptr. get_disconnected_nodes_locs document_ptr) \<union>
(\<Union>ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing)})"
end
locale l_get_disconnected_document_defs =
fixes get_disconnected_document :: "(_) node_ptr \<Rightarrow> (_, (_::linorder) document_ptr) dom_prog"
fixes get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_disconnected_document_defs +
l_get_disconnected_nodes +
assumes get_disconnected_document_impl:
"get_disconnected_document = a_get_disconnected_document"
assumes get_disconnected_document_locs_impl:
"get_disconnected_document_locs = a_get_disconnected_document_locs"
begin
lemmas get_disconnected_document_def =
get_disconnected_document_impl[unfolded a_get_disconnected_document_def]
lemmas get_disconnected_document_locs_def =
get_disconnected_document_locs_impl[unfolded a_get_disconnected_document_locs_def]
lemma get_disconnected_document_pure [simp]: "pure (get_disconnected_document ptr) h"
using get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def
intro!: bind_pure_I filter_M_pure_I
split: list.splits)
lemma get_disconnected_document_ptr_in_heap [simp]:
"h \<turnstile> ok (get_disconnected_document node_ptr) \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h"
using get_disconnected_document_def is_OK_returns_result_I check_in_heap_ptr_in_heap
by (metis (no_types, lifting) bind_returns_heap_E get_disconnected_document_pure
node_ptr_kinds_commutes pure_pure)
lemma get_disconnected_document_disconnected_document_in_heap:
assumes "h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disconnected_document"
shows "disconnected_document |\<in>| document_ptr_kinds h"
using assms get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def elim!: bind_returns_result_E2
dest!: filter_M_not_more_elements[where x=disconnected_document]
intro!: filter_M_pure_I bind_pure_I
split: if_splits list.splits)
lemma get_disconnected_document_reads:
"reads get_disconnected_document_locs (get_disconnected_document node_ptr) h h'"
using get_disconnected_nodes_reads[unfolded reads_def]
by(auto simp add: get_disconnected_document_def get_disconnected_document_locs_def
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads]
reads_subset[OF error_reads]
reads_subset[OF get_disconnected_nodes_reads] reads_subset[OF return_reads]
reads_subset[OF document_ptr_kinds_M_reads] filter_M_reads filter_M_pure_I
bind_pure_I
split: list.splits)
end
locale l_get_disconnected_document = l_get_disconnected_document_defs +
assumes get_disconnected_document_reads:
"reads get_disconnected_document_locs (get_disconnected_document node_ptr) h h'"
assumes get_disconnected_document_ptr_in_heap:
"h \<turnstile> ok (get_disconnected_document node_ptr) \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h"
assumes get_disconnected_document_pure [simp]:
"pure (get_disconnected_document node_ptr) h"
assumes get_disconnected_document_disconnected_document_in_heap:
"h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disconnected_document \<Longrightarrow>
disconnected_document |\<in>| document_ptr_kinds h"
global_interpretation l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_disconnected_nodes
get_disconnected_nodes_locs defines
get_disconnected_document = a_get_disconnected_document and
get_disconnected_document_locs = a_get_disconnected_document_locs .
interpretation i_get_disconnected_document?: l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_nodes get_disconnected_nodes_locs get_disconnected_document
get_disconnected_document_locs type_wf
by(auto simp add: l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_disconnected_document_def get_disconnected_document_locs_def instances)
declare l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_disconnected_document_is_l_get_disconnected_document [instances]:
"l_get_disconnected_document get_disconnected_document get_disconnected_document_locs"
apply(auto simp add: l_get_disconnected_document_def instances)[1]
using get_disconnected_document_ptr_in_heap get_disconnected_document_pure
get_disconnected_document_disconnected_document_in_heap get_disconnected_document_reads
by blast+
paragraph \<open>get\_disconnected\_nodes\<close>
locale l_set_tag_name_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_disconnected_nodes:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: CD.set_tag_name_locs_impl[unfolded CD.a_set_tag_name_locs_def]
CD.get_disconnected_nodes_locs_impl[unfolded CD.a_get_disconnected_nodes_locs_def]
all_args_def)
end
interpretation
i_set_tag_name_get_disconnected_nodes?: l_set_tag_name_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf set_tag_name set_tag_name_locs get_disconnected_nodes
get_disconnected_nodes_locs
by unfold_locales
declare l_set_tag_name_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_disconnected_nodes_is_l_set_tag_name_get_disconnected_nodes [instances]:
"l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs
get_disconnected_nodes get_disconnected_nodes_locs"
using set_tag_name_is_l_set_tag_name get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_tag_name_get_disconnected_nodes_def
l_set_tag_name_get_disconnected_nodes_axioms_def)
using set_tag_name_get_disconnected_nodes
by fast
subsubsection \<open>adopt\_node\<close>
global_interpretation l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs
defines adopt_node = a_adopt_node
and adopt_node_locs = a_adopt_node_locs
.
interpretation i_adopt_node?: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node adopt_node_locs known_ptr type_wf
get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs remove
by(auto simp add: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def adopt_node_def
adopt_node_locs_def instances)
declare l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma adopt_node_is_l_adopt_node [instances]: "l_adopt_node type_wf known_ptr known_ptrs get_parent
adopt_node adopt_node_locs get_child_nodes get_owner_document"
apply(auto simp add: l_adopt_node_def l_adopt_node_axioms_def instances)[1]
using adopt_node_writes apply fast
using adopt_node_pointers_preserved apply (fast, fast)
using adopt_node_types_preserved apply (fast, fast)
using adopt_node_child_in_heap apply fast
using adopt_node_children_subset apply fast
done
paragraph \<open>get\_shadow\_root\<close>
locale l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_get_shadow_root:
"\<forall>w \<in> adopt_node_locs parent owner_document document_ptr.
(h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: adopt_node_locs_def remove_child_locs_def all_args_def
set_disconnected_nodes_get_shadow_root set_child_nodes_get_shadow_root)
end
locale l_adopt_node_get_shadow_root = l_adopt_node_defs + l_get_shadow_root_defs +
assumes adopt_node_get_shadow_root:
"\<forall>w \<in> adopt_node_locs parent owner_document document_ptr.
(h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation i_adopt_node_get_shadow_root?: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_shadow_root
get_shadow_root_locs set_disconnected_nodes set_disconnected_nodes_locs get_owner_document
get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs adopt_node adopt_node_locs get_child_nodes get_child_nodes_locs
known_ptrs remove
by(auto simp add: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma adopt_node_get_shadow_root_is_l_adopt_node_get_shadow_root [instances]:
"l_adopt_node_get_shadow_root adopt_node_locs get_shadow_root_locs"
apply(auto simp add: l_adopt_node_get_shadow_root_def)[1]
using adopt_node_get_shadow_root apply fast
done
subsubsection \<open>insert\_before\<close>
global_interpretation l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_child_nodes
get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_si get_ancestors_si_locs
adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_owner_document
defines
next_sibling = a_next_sibling and
insert_node = a_insert_node and
ensure_pre_insertion_validity = a_ensure_pre_insertion_validity and
insert_before = a_insert_before and
insert_before_locs = a_insert_before_locs
.
global_interpretation l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs insert_before
defines append_child = "l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_append_child insert_before"
.
interpretation i_insert_before?: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_child_nodes
get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_si get_ancestors_si_locs
adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before insert_before_locs append_child type_wf
known_ptr known_ptrs
by(auto simp add: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def insert_before_def
insert_before_locs_def instances)
declare l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_append_child?: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M append_child insert_before insert_before_locs
by(simp add: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances append_child_def)
declare l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
subsubsection \<open>get\_assigned\_nodes\<close>
fun map_filter_M2 :: "('x \<Rightarrow> ('heap, 'e, 'y option) prog) \<Rightarrow> 'x list
\<Rightarrow> ('heap, 'e, 'y list) prog"
where
"map_filter_M2 f [] = return []" |
"map_filter_M2 f (x # xs) = do {
res \<leftarrow> f x;
remainder \<leftarrow> map_filter_M2 f xs;
return ((case res of Some r \<Rightarrow> [r] | None \<Rightarrow> []) @ remainder)
}"
lemma map_filter_M2_pure [simp]:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
shows "pure (map_filter_M2 f xs) h"
using assms
apply(induct xs arbitrary: h)
by(auto elim!: bind_returns_result_E2 intro!: bind_pure_I)
lemma map_filter_pure_no_monad:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
assumes "h \<turnstile> map_filter_M2 f xs \<rightarrow>\<^sub>r ys"
shows
"ys = map the (filter (\<lambda>x. x \<noteq> None) (map (\<lambda>x. |h \<turnstile> f x|\<^sub>r) xs))" and
"\<And>x. x \<in> set xs \<Longrightarrow> h \<turnstile> ok (f x)"
using assms
apply(induct xs arbitrary: h ys)
by(auto elim!: bind_returns_result_E2)
lemma map_filter_pure_foo:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
assumes "h \<turnstile> map_filter_M2 f xs \<rightarrow>\<^sub>r ys"
assumes "y \<in> set ys"
obtains x where "h \<turnstile> f x \<rightarrow>\<^sub>r Some y" and "x \<in> set xs"
using assms
apply(induct xs arbitrary: ys)
by(auto elim!: bind_returns_result_E2)
lemma map_filter_M2_in_result:
assumes "h \<turnstile> map_filter_M2 P xs \<rightarrow>\<^sub>r ys"
assumes "a \<in> set xs"
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (P x) h"
assumes "h \<turnstile> P a \<rightarrow>\<^sub>r Some b"
shows "b \<in> set ys"
using assms
apply(induct xs arbitrary: h ys)
by(auto elim!: bind_returns_result_E2 )
locale l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_get_root_node_defs get_root_node get_root_node_locs +
l_get_host_defs get_host get_host_locs +
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_find_slot_defs find_slot assigned_slot +
l_remove_defs remove +
l_insert_before_defs insert_before insert_before_locs +
l_append_child_defs append_child +
l_remove_shadow_root_defs remove_shadow_root remove_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and remove :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before ::
"(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> (_) node_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before_locs :: "(_) object_ptr \<Rightarrow> (_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow>
(_) document_ptr \<Rightarrow> (_, unit) dom_prog set"
and append_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow>
((_) heap, exception, unit) prog set"
begin
definition a_assigned_nodes :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
where
"a_assigned_nodes slot = do {
tag \<leftarrow> get_tag_name slot;
(if tag \<noteq> ''slot''
then error HierarchyRequestError
else return ());
root \<leftarrow> get_root_node (cast slot);
if is_shadow_root_ptr_kind root
then do {
host \<leftarrow> get_host (the (cast root));
children \<leftarrow> get_child_nodes (cast host);
filter_M (\<lambda>slotable. do {
found_slot \<leftarrow> find_slot False slotable;
return (found_slot = Some slot)}) children}
else return []}"
partial_function (dom_prog) a_assigned_nodes_flatten ::
"(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
where
"a_assigned_nodes_flatten slot = do {
tag \<leftarrow> get_tag_name slot;
(if tag \<noteq> ''slot''
then error HierarchyRequestError
else return ());
root \<leftarrow> get_root_node (cast slot);
(if is_shadow_root_ptr_kind root
then do {
slotables \<leftarrow> a_assigned_nodes slot;
slotables_or_child_nodes \<leftarrow> (if slotables = []
then do {
get_child_nodes (cast slot)
} else do {
return slotables
});
list_of_lists \<leftarrow> map_M (\<lambda>node_ptr. do {
(case cast node_ptr of
Some element_ptr \<Rightarrow> do {
tag \<leftarrow> get_tag_name element_ptr;
(if tag = ''slot''
then do {
root \<leftarrow> get_root_node (cast element_ptr);
(if is_shadow_root_ptr_kind root
then do {
a_assigned_nodes_flatten element_ptr
} else do {
return [node_ptr]
})
} else do {
return [node_ptr]
})
}
| None \<Rightarrow> return [node_ptr])
}) slotables_or_child_nodes;
return (concat list_of_lists)
} else return [])
}"
definition a_flatten_dom :: "(_, unit) dom_prog" where
"a_flatten_dom = do {
tups \<leftarrow> element_ptr_kinds_M \<bind> map_filter_M2 (\<lambda>element_ptr. do {
tag \<leftarrow> get_tag_name element_ptr;
assigned_nodes \<leftarrow> a_assigned_nodes element_ptr;
(if tag = ''slot'' \<and> assigned_nodes \<noteq> []
then return (Some (element_ptr, assigned_nodes))
else return None)});
forall_M (\<lambda>(slot, assigned_nodes). do {
get_child_nodes (cast slot) \<bind> forall_M remove;
forall_M (append_child (cast slot)) assigned_nodes
}) tups;
shadow_root_ptr_kinds_M \<bind> forall_M (\<lambda>shadow_root_ptr. do {
host \<leftarrow> get_host shadow_root_ptr;
get_child_nodes (cast host) \<bind> forall_M remove;
get_child_nodes (cast shadow_root_ptr) \<bind> forall_M (append_child (cast host));
remove_shadow_root host
});
return ()
}"
end
global_interpretation l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_tag_name get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs find_slot
assigned_slot remove insert_before insert_before_locs append_child remove_shadow_root
remove_shadow_root_locs
defines assigned_nodes = a_assigned_nodes
and assigned_nodes_flatten = a_assigned_nodes_flatten
and flatten_dom = a_flatten_dom
.
declare a_assigned_nodes_flatten.simps [code]
locale l_assigned_nodes_defs =
fixes assigned_nodes :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
fixes assigned_nodes_flatten :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
fixes flatten_dom :: "(_, unit) dom_prog"
locale l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_assigned_nodes_defs
assigned_nodes assigned_nodes_flatten flatten_dom
+ l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
get_child_nodes get_child_nodes_locs get_tag_name get_tag_name_locs get_root_node
get_root_node_locs get_host get_host_locs find_slot assigned_slot remove insert_before
insert_before_locs append_child remove_shadow_root remove_shadow_root_locs
+ l_get_shadow_root
type_wf get_shadow_root get_shadow_root_locs
+ l_set_shadow_root
type_wf set_shadow_root set_shadow_root_locs
+ l_remove
+ l_insert_before
insert_before insert_before_locs
+ l_find_slot
find_slot assigned_slot
+ l_get_tag_name
type_wf get_tag_name get_tag_name_locs
+ l_get_root_node
get_root_node get_root_node_locs get_parent get_parent_locs
+ l_get_host
get_host get_host_locs
+ l_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_to_tree_order
to_tree_order
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and assigned_nodes :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and assigned_nodes_flatten :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and flatten_dom :: "((_) heap, exception, unit) prog"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and remove :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before ::
"(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> (_) node_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before_locs :: "(_) object_ptr \<Rightarrow> (_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow>
(_) document_ptr \<Rightarrow> (_, unit) dom_prog set"
and append_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow>
((_) heap, exception, unit) prog set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root ::
"(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_shadow_root ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog" +
assumes assigned_nodes_impl: "assigned_nodes = a_assigned_nodes"
assumes flatten_dom_impl: "flatten_dom = a_flatten_dom"
begin
lemmas assigned_nodes_def = assigned_nodes_impl[unfolded a_assigned_nodes_def]
lemmas flatten_dom_def = flatten_dom_impl[unfolded a_flatten_dom_def, folded assigned_nodes_impl]
lemma assigned_nodes_pure [simp]: "pure (assigned_nodes slot) h"
by(auto simp add: assigned_nodes_def intro!: bind_pure_I filter_M_pure_I)
lemma assigned_nodes_ptr_in_heap:
assumes "h \<turnstile> ok (assigned_nodes slot)"
shows "slot |\<in>| element_ptr_kinds h"
using assms
apply(auto simp add: assigned_nodes_def)[1]
by (meson bind_is_OK_E is_OK_returns_result_I local.get_tag_name_ptr_in_heap)
lemma assigned_nodes_slot_is_slot:
assumes "h \<turnstile> ok (assigned_nodes slot)"
shows "h \<turnstile> get_tag_name slot \<rightarrow>\<^sub>r ''slot''"
using assms
by(auto simp add: assigned_nodes_def elim!: bind_is_OK_E split: if_splits)
lemma assigned_nodes_different_ptr:
assumes "h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> assigned_nodes slot' \<rightarrow>\<^sub>r nodes'"
assumes "slot \<noteq> slot'"
shows "set nodes \<inter> set nodes' = {}"
proof (rule ccontr)
assume "set nodes \<inter> set nodes' \<noteq> {} "
then obtain common_ptr where "common_ptr \<in> set nodes" and "common_ptr \<in> set nodes'"
by auto
have "h \<turnstile> find_slot False common_ptr \<rightarrow>\<^sub>r Some slot"
using \<open>common_ptr \<in> set nodes\<close>
using assms(1)
by(auto simp add: assigned_nodes_def
elim!: bind_returns_result_E2
split: if_splits
dest!: filter_M_holds_for_result[where x=common_ptr]
intro!: bind_pure_I)
moreover
have "h \<turnstile> find_slot False common_ptr \<rightarrow>\<^sub>r Some slot'"
using \<open>common_ptr \<in> set nodes'\<close>
using assms(2)
by(auto simp add: assigned_nodes_def
elim!: bind_returns_result_E2
split: if_splits
dest!: filter_M_holds_for_result[where x=common_ptr]
intro!: bind_pure_I)
ultimately
show False
using assms(3)
by (meson option.inject returns_result_eq)
qed
end
interpretation i_assigned_nodes?: l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr assigned_nodes
assigned_nodes_flatten flatten_dom get_child_nodes get_child_nodes_locs get_tag_name
get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs find_slot
assigned_slot remove insert_before insert_before_locs append_child remove_shadow_root
remove_shadow_root_locs type_wf get_shadow_root get_shadow_root_locs set_shadow_root
set_shadow_root_locs get_parent get_parent_locs to_tree_order
by(auto simp add: instances l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
assigned_nodes_def flatten_dom_def)
declare l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_assigned_nodes = l_assigned_nodes_defs +
assumes assigned_nodes_pure [simp]: "pure (assigned_nodes slot) h"
assumes assigned_nodes_ptr_in_heap:
"h \<turnstile> ok (assigned_nodes slot) \<Longrightarrow> slot |\<in>| element_ptr_kinds h"
assumes assigned_nodes_slot_is_slot:
"h \<turnstile> ok (assigned_nodes slot) \<Longrightarrow> h \<turnstile> get_tag_name slot \<rightarrow>\<^sub>r ''slot''"
assumes assigned_nodes_different_ptr:
"h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes \<Longrightarrow> h \<turnstile> assigned_nodes slot' \<rightarrow>\<^sub>r nodes' \<Longrightarrow>
slot \<noteq> slot' \<Longrightarrow> set nodes \<inter> set nodes' = {}"
lemma assigned_nodes_is_l_assigned_nodes [instances]: "l_assigned_nodes assigned_nodes"
apply(auto simp add: l_assigned_nodes_def)[1]
using assigned_nodes_ptr_in_heap apply fast
using assigned_nodes_slot_is_slot apply fast
using assigned_nodes_different_ptr apply fast
done
subsubsection \<open>set\_val\<close>
locale l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_val set_val_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> (_, unit) dom_prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma set_val_ok:
"type_wf h \<Longrightarrow> character_data_ptr |\<in>| character_data_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_val character_data_ptr tag)"
using CD.set_val_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t local.type_wf_impl by blast
lemma set_val_writes:
"writes (set_val_locs character_data_ptr) (set_val character_data_ptr tag) h h'"
using CD.set_val_writes .
lemma set_val_pointers_preserved:
assumes "w \<in> set_val_locs character_data_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms CD.set_val_pointers_preserved by simp
lemma set_val_typess_preserved:
assumes "w \<in> set_val_locs character_data_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def]
split: if_splits)
end
interpretation
i_set_val?: l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_val set_val_locs
apply(unfold_locales)
by (auto simp add: set_val_def set_val_locs_def)
declare l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_is_l_set_val [instances]: "l_set_val type_wf set_val set_val_locs"
apply(simp add: l_set_val_def)
using set_val_ok set_val_writes set_val_pointers_preserved set_val_typess_preserved
by blast
paragraph \<open>get\_shadow\_root\<close>
locale l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_val_get_shadow_root:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def]
get_shadow_root_locs_def all_args_def)
end
locale l_set_val_get_shadow_root = l_set_val + l_get_shadow_root +
assumes set_val_get_shadow_root:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_val_get_shadow_root?: l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_val set_val_locs
get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
using l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by unfold_locales
declare l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_get_shadow_root_is_l_set_val_get_shadow_root [instances]:
"l_set_val_get_shadow_root type_wf set_val set_val_locs get_shadow_root
get_shadow_root_locs"
using set_val_is_l_set_val get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_val_get_shadow_root_def l_set_val_get_shadow_root_axioms_def)
using set_val_get_shadow_root
by fast
paragraph \<open>get\_tag\_type\<close>
locale l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_val_get_tag_name:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def]
CD.get_tag_name_locs_impl[unfolded CD.a_get_tag_name_locs_def]
all_args_def)
end
locale l_set_val_get_tag_name = l_set_val + l_get_tag_name +
assumes set_val_get_tag_name:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
interpretation
i_set_val_get_tag_name?: l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_val
set_val_locs get_tag_name get_tag_name_locs
by unfold_locales
declare l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_get_tag_name_is_l_set_val_get_tag_name [instances]:
"l_set_val_get_tag_name type_wf set_val set_val_locs get_tag_name get_tag_name_locs"
using set_val_is_l_set_val get_tag_name_is_l_get_tag_name
apply(simp add: l_set_val_get_tag_name_def l_set_val_get_tag_name_axioms_def)
using set_val_get_tag_name
by fast
subsubsection \<open>create\_character\_data\<close>
locale l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_known_ptr known_ptr
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
begin
lemma create_character_data_document_in_heap:
assumes "h \<turnstile> ok (create_character_data document_ptr text)"
shows "document_ptr |\<in>| document_ptr_kinds h"
using assms CD.create_character_data_document_in_heap by simp
lemma create_character_data_known_ptr:
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
shows "known_ptr (cast new_character_data_ptr)"
using assms CD.create_character_data_known_ptr
by(simp add: known_ptr_impl CD.known_ptr_impl ShadowRootClass.a_known_ptr_def)
end
locale l_create_character_data = l_create_character_data_defs
interpretation i_create_character_data?: l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_val set_val_locs
create_character_data known_ptr DocumentClass.type_wf DocumentClass.known_ptr
by(auto simp add: l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
instances)
declare l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_element\<close>
locale l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M create_element
known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_known_ptr known_ptr
for get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and create_element ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
begin
lemmas create_element_def = CD.create_element_def
lemma create_element_document_in_heap:
assumes "h \<turnstile> ok (create_element document_ptr tag)"
shows "document_ptr |\<in>| document_ptr_kinds h"
using CD.create_element_document_in_heap assms .
lemma create_element_known_ptr:
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
shows "known_ptr (cast new_element_ptr)"
proof -
have "is_element_ptr new_element_ptr"
using assms
apply(auto simp add: create_element_def elim!: bind_returns_result_E)[1]
using new_element_is_element_ptr
by blast
then show ?thesis
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs)
qed
end
interpretation i_create_element?: l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_tag_name
set_tag_name_locs type_wf create_element known_ptr DocumentClass.type_wf DocumentClass.known_ptr
by(auto simp add: l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
subsection \<open>A wellformed heap (Core DOM)\<close>
subsubsection \<open>wellformed\_heap\<close>
locale l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_host_shadow_root_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
where
"a_host_shadow_root_rel h = (\<lambda>(x, y). (cast x, cast y)) ` {(host, shadow_root).
host |\<in>| element_ptr_kinds h \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root}"
lemma a_host_shadow_root_rel_code [code]: "a_host_shadow_root_rel h = set (concat (map
(\<lambda>host. (case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> [(cast host, cast shadow_root)] |
None \<Rightarrow> []))
(sorted_list_of_fset (element_ptr_kinds h)))
)"
by(auto simp add: a_host_shadow_root_rel_def)
definition a_all_ptrs_in_heap :: "(_) heap \<Rightarrow> bool" where
"a_all_ptrs_in_heap h = ((\<forall>host shadow_root_ptr.
(h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr) \<longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h))"
definition a_distinct_lists :: "(_) heap \<Rightarrow> bool"
where
"a_distinct_lists h = distinct (concat (
map (\<lambda>element_ptr. (case |h \<turnstile> get_shadow_root element_ptr|\<^sub>r of
Some shadow_root_ptr \<Rightarrow> [shadow_root_ptr] | None \<Rightarrow> []))
|h \<turnstile> element_ptr_kinds_M|\<^sub>r
))"
definition a_shadow_root_valid :: "(_) heap \<Rightarrow> bool" where
"a_shadow_root_valid h = (\<forall>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h).
(\<exists>host \<in> fset(element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr))"
definition a_heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
where
"a_heap_is_wellformed h \<longleftrightarrow> CD.a_heap_is_wellformed h \<and>
acyclic (CD.a_parent_child_rel h \<union> a_host_shadow_root_rel h) \<and>
a_all_ptrs_in_heap h \<and>
a_distinct_lists h \<and>
a_shadow_root_valid h"
end
global_interpretation l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
get_tag_name get_tag_name_locs
defines heap_is_wellformed = a_heap_is_wellformed
and parent_child_rel = CD.a_parent_child_rel
and host_shadow_root_rel = a_host_shadow_root_rel
and all_ptrs_in_heap = a_all_ptrs_in_heap
and distinct_lists = a_distinct_lists
and shadow_root_valid = a_shadow_root_valid
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_heap_is_wellformed
and parent_child_rel\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_parent_child_rel
and acyclic_heap\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_acyclic_heap
and all_ptrs_in_heap\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_all_ptrs_in_heap
and distinct_lists\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_distinct_lists
and owner_document_valid\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_owner_document_valid
.
interpretation i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
by (auto simp add: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def parent_child_rel_def instances)
declare i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_heap_is_wellformed [instances]:
"l_heap_is_wellformed type_wf known_ptr heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def)[1]
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_disc_nodes_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_one_parent apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_one_disc_parent apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_disc_nodes_different apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_disconnected_nodes_distinct apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_distinct apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_disc_nodes apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child apply (blast, blast)
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_finite apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_acyclic apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_node_ptr apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child_in_heap apply blast
done
locale l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
+ CD: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
+ l_heap_is_wellformed_defs
heap_is_wellformed parent_child_rel
+ l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_shadow_root get_shadow_root_locs get_host get_host_locs type_wf
+ l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
get_disconnected_document get_disconnected_document_locs type_wf
+ l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes heap_is_wellformed_impl: "heap_is_wellformed = a_heap_is_wellformed"
begin
lemmas heap_is_wellformed_def =
heap_is_wellformed_impl[unfolded a_heap_is_wellformed_def,
folded CD.heap_is_wellformed_impl CD.parent_child_rel_impl]
lemma a_distinct_lists_code [code]:
"a_all_ptrs_in_heap h = ((\<forall>host \<in> fset (element_ptr_kinds h).
h \<turnstile> ok (get_shadow_root host) \<longrightarrow> (case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root_ptr \<Rightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h |
None \<Rightarrow> True)))"
apply(auto simp add: a_all_ptrs_in_heap_def split: option.splits)[1]
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap notin_fset select_result_I2)
lemma get_shadow_root_shadow_root_ptr_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms
by(auto simp add: heap_is_wellformed_def a_all_ptrs_in_heap_def)
lemma get_host_ptr_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms get_shadow_root_shadow_root_ptr_in_heap
by(auto simp add: get_host_def
elim!: bind_returns_result_E2
dest!: filter_M_holds_for_result
intro!: bind_pure_I
split: list.splits)
lemma shadow_root_same_host:
assumes "heap_is_wellformed h" and "type_wf h"
assumes "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
assumes "h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr"
shows "host = host'"
proof (rule ccontr)
assume " host \<noteq> host'"
have "host |\<in>| element_ptr_kinds h"
using assms(3)
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap)
moreover
have "host' |\<in>| element_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap)
ultimately show False
using assms
apply(auto simp add: heap_is_wellformed_def a_distinct_lists_def)[1]
apply(drule distinct_concat_map_E(1)[where x=host and y=host'])
apply(simp)
apply(simp)
using \<open>host \<noteq> host'\<close> apply(simp)
apply(auto)[1]
done
qed
lemma shadow_root_host_dual:
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
shows "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms
by(auto simp add: get_host_def
dest: filter_M_holds_for_result
elim!: bind_returns_result_E2
intro!: bind_pure_I split: list.splits)
lemma disc_doc_disc_node_dual:
assumes "h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disc_doc"
obtains disc_nodes where
"h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes" and
"disc_node \<in> set disc_nodes"
using assms get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def bind_pure_I
dest!: filter_M_holds_for_result
elim!: bind_returns_result_E2
intro!: filter_M_pure_I
split: if_splits list.splits)
lemma get_host_valid_tag_name:
assumes "heap_is_wellformed h" and "type_wf h"
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
assumes "h \<turnstile> get_tag_name host \<rightarrow>\<^sub>r tag"
shows "tag \<in> safe_shadow_root_element_types"
proof -
obtain host' where
"host' |\<in>| element_ptr_kinds h" and
"|h \<turnstile> get_tag_name host'|\<^sub>r \<in> safe_shadow_root_element_types"
and "h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms
by (metis finite_set_in get_host_ptr_in_heap local.a_shadow_root_valid_def
local.get_shadow_root_ok local.heap_is_wellformed_def returns_result_select_result)
then have "host = host'"
by (meson assms(1) assms(2) assms(3) shadow_root_host_dual shadow_root_same_host)
then show ?thesis
using \<open>|h \<turnstile> get_tag_name host'|\<^sub>r \<in> safe_shadow_root_element_types\<close> assms(4) by auto
qed
lemma a_host_shadow_root_rel_finite: "finite (a_host_shadow_root_rel h)"
proof -
have "a_host_shadow_root_rel h = (\<Union>host \<in> fset (element_ptr_kinds h).
(case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> {(cast host, cast shadow_root)} | None \<Rightarrow> {}))"
by(auto simp add: a_host_shadow_root_rel_def split: option.splits)
moreover have "finite (\<Union>host \<in> fset (element_ptr_kinds h).
(case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> {(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host, cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root)} |
None \<Rightarrow> {}))"
by(auto split: option.splits)
ultimately show ?thesis
by auto
qed
lemma heap_is_wellformed_children_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children \<Longrightarrow>
child |\<in>| node_ptr_kinds h"
using CD.heap_is_wellformed_children_in_heap local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
using CD.heap_is_wellformed_disc_nodes_in_heap local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_one_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow>
h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow> set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr'"
using CD.heap_is_wellformed_one_parent local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_one_disc_parent:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes' \<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {}
\<Longrightarrow> document_ptr = document_ptr'"
using CD.heap_is_wellformed_one_disc_parent local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_disc_nodes_different:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> set children \<inter> set disc_nodes = {}"
using CD.heap_is_wellformed_children_disc_nodes_different local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_disconnected_nodes_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
distinct disc_nodes"
using CD.heap_is_wellformed_disconnected_nodes_distinct local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_distinct:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
using CD.heap_is_wellformed_children_distinct local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_disc_nodes:
"heap_is_wellformed h \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h \<Longrightarrow>
\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r) \<Longrightarrow>
(\<exists>document_ptr \<in> fset (document_ptr_kinds h).
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using CD.heap_is_wellformed_children_disc_nodes local.heap_is_wellformed_def by blast
lemma parent_child_rel_finite: "heap_is_wellformed h \<Longrightarrow> finite (parent_child_rel h)"
using CD.parent_child_rel_finite by blast
lemma parent_child_rel_acyclic: "heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
using CD.parent_child_rel_acyclic heap_is_wellformed_def by blast
lemma parent_child_rel_child_in_heap:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent \<Longrightarrow>
(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_child_in_heap local.heap_is_wellformed_def by blast
end
interpretation i_heap_is_wellformed?: l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs
by(auto simp add: l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def parent_child_rel_def heap_is_wellformed_def
instances)
declare l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma heap_is_wellformed_is_l_heap_is_wellformed [instances]:
"l_heap_is_wellformed ShadowRootClass.type_wf ShadowRootClass.known_ptr
Shadow_DOM.heap_is_wellformed Shadow_DOM.parent_child_rel Shadow_DOM.get_child_nodes
get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def instances)[1]
using heap_is_wellformed_children_in_heap apply metis
using heap_is_wellformed_disc_nodes_in_heap apply metis
using heap_is_wellformed_one_parent apply blast
using heap_is_wellformed_one_disc_parent apply blast
using heap_is_wellformed_children_disc_nodes_different apply blast
using heap_is_wellformed_disconnected_nodes_distinct apply metis
using heap_is_wellformed_children_distinct apply metis
using heap_is_wellformed_children_disc_nodes apply metis
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child apply(blast, blast)
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_finite apply blast
using parent_child_rel_acyclic apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_node_ptr apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent_in_heap apply blast
using parent_child_rel_child_in_heap apply metis
done
subsubsection \<open>get\_parent\<close>
interpretation i_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_disconnected_nodes
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
interpretation i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_parent_wf [instances]: "l_get_parent_wf type_wf known_ptr
known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes get_parent"
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def instances)[1]
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.child_parent_dual apply fast
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_wellformed_induct apply metis
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_wellformed_induct_rev apply metis
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent apply fast
done
subsubsection \<open>get\_disconnected\_nodes\<close>
subsubsection \<open>set\_disconnected\_nodes\<close>
paragraph \<open>get\_disconnected\_nodes\<close>
interpretation i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M:
l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
by (simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]:
"l_set_disconnected_nodes_get_disconnected_nodes_wf type_wf known_ptr heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_child_nodes get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def
l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
using i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_from_disconnected_nodes_removes
apply fast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M:l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_parent get_parent_locs get_ancestors get_ancestors_locs
get_root_node get_root_node_locs
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel known_ptr known_ptrs type_wf
get_ancestors get_ancestors_locs get_child_nodes get_parent"
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def instances)[1]
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_never_empty apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_ok apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_reads apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_ptrs_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_remains_not_in_ancestors apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_also_parent apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_obtains_children apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_parent_child_rel apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_root_node type_wf known_ptr known_ptrs
get_ancestors get_parent"
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def instances)[1]
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_ok apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_ptr_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_root_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_same_root_node apply(blast, blast)
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_same_no_parent apply blast
(* using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_not_node_same apply blast *)
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_parent_same apply (blast, blast)
done
subsubsection \<open>to\_tree\_order\<close>
interpretation i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
apply(simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
done
declare i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def instances)[1]
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ok apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ptrs_in_heap apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_parent_child_rel apply(blast, blast)
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_child2 apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_node_ptrs apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_child apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ptr_in_result apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_parent apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_subset apply blast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs to_tree_order
by(auto simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf type_wf known_ptr known_ptrs to_tree_order get_root_node
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M"
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def
l_to_tree_order_wf_get_root_node_wf_axioms_def instances)[1]
using i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_get_root_node apply blast
using i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_same_root apply blast
done
subsubsection \<open>remove\_child\<close>
interpretation i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs get_parent
get_parent_locs get_owner_document get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf
known_ptr known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
by unfold_locales
declare i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_remove_child_wf2 [instances]: "l_remove_child_wf2 type_wf known_ptr
known_ptrs remove_child heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_heap_is_wellformed_preserved apply(fast, fast, fast)
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_heap_is_wellformed_preserved apply(fast, fast, fast)
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_removes_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_removes_first_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_removes_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_for_all_empty_children apply fast
done
subsection \<open>A wellformed heap\<close>
subsubsection \<open>get\_parent\<close>
interpretation i_get_parent_wf?: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed parent_child_rel
get_disconnected_nodes
using instances
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_parent_wf_is_l_get_parent_wf [instances]:
"l_get_parent_wf ShadowRootClass.type_wf ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
heap_is_wellformed parent_child_rel Shadow_DOM.get_child_nodes Shadow_DOM.get_parent"
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def instances)[1]
using child_parent_dual apply blast
using heap_wellformed_induct apply metis
using heap_wellformed_induct_rev apply metis
using parent_child_rel_parent apply metis
done
subsubsection \<open>remove\_shadow\_root\<close>
locale l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name +
l_get_disconnected_nodes +
l_set_shadow_root_get_tag_name +
l_get_child_nodes +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_delete_shadow_root_get_disconnected_nodes +
l_delete_shadow_root_get_child_nodes +
l_set_shadow_root_get_disconnected_nodes +
l_set_shadow_root_get_child_nodes +
l_delete_shadow_root_get_tag_name +
l_set_shadow_root_get_shadow_root +
l_delete_shadow_root_get_shadow_root +
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_shadow_root ptr \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'" and "type_wf h'" "heap_is_wellformed h'"
proof -
obtain shadow_root_ptr h2 where
"h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr" and
"h \<turnstile> get_child_nodes (cast shadow_root_ptr) \<rightarrow>\<^sub>r []" and
h2: "h \<turnstile> set_shadow_root ptr None \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> delete_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: remove_shadow_root_def
elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
split: option.splits if_splits)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_shadow_root_writes h2]
using \<open>type_wf h\<close> set_shadow_root_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using h' delete_shadow_root_type_wf_preserved local.type_wf_impl
by blast
have object_ptr_kinds_eq_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_shadow_root_writes h2])
using set_shadow_root_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
have node_ptr_kinds_eq_h: "node_ptr_kinds h = node_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: node_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h = element_ptr_kinds h2"
using node_ptr_kinds_eq_h
by (simp add: element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h = document_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: shadow_root_ptr_kinds_def)
have "known_ptrs h2"
using \<open>known_ptrs h\<close> object_ptr_kinds_eq_h known_ptrs_subset
by blast
have object_ptr_kinds_eq_h2: "object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h2"
using h' delete_shadow_root_pointers
by auto
have object_ptr_kinds_eq2_h2:
"object_ptr_kinds h2 = object_ptr_kinds h' |\<union>| {|cast shadow_root_ptr|}"
using h' delete_shadow_root_pointers
by auto
have node_ptr_kinds_eq_h2: "node_ptr_kinds h2 = node_ptr_kinds h'"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def delete_shadow_root_pointers[OF h'])
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h'"
using node_ptr_kinds_eq_h2
by (simp add: element_ptr_kinds_def)
have document_ptr_kinds_eq_h2: "document_ptr_kinds h2 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h2
by(auto simp add: document_ptr_kinds_def delete_shadow_root_pointers[OF h'])
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h' |\<subseteq>| shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by (auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq2_h2:
"shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h' |\<union>| {|shadow_root_ptr|}"
using object_ptr_kinds_eq2_h2
apply (auto simp add: shadow_root_ptr_kinds_def)[1]
by (metis \<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1)
fset.map_comp local.get_shadow_root_shadow_root_ptr_in_heap object_ptr_kinds_eq_h
shadow_root_ptr_kinds_def)
show "known_ptrs h'"
using object_ptr_kinds_eq_h2 \<open>known_ptrs h2\<close> known_ptrs_subset
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_shadow_root_writes h2 set_shadow_root_get_disconnected_nodes
by(rule reads_writes_preserved)
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads get_disconnected_nodes_delete_shadow_root[OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h2 \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_shadow_root_writes h2 set_shadow_root_get_tag_name
by(rule reads_writes_preserved)
then have tag_name_eq2_h: "\<And>doc_ptr. |h \<turnstile> get_tag_name doc_ptr|\<^sub>r = |h2 \<turnstile> get_tag_name doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads get_tag_name_delete_shadow_root[OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h2: "\<And>doc_ptr. |h2 \<turnstile> get_tag_name doc_ptr|\<^sub>r = |h' \<turnstile> get_tag_name doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h:
"\<And>ptr' children. h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_shadow_root_writes h2 set_shadow_root_get_child_nodes
by(rule reads_writes_preserved)
then have children_eq2_h: "\<And>ptr'. |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children =
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h' get_child_nodes_delete_shadow_root
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h2:
"\<And>ptr'. ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r =
|h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "cast shadow_root_ptr |\<notin>| object_ptr_kinds h'"
using h' delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap
by auto
have get_shadow_root_eq_h:
"\<And>shadow_root_opt ptr'. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads set_shadow_root_writes h2
apply(rule reads_writes_preserved)
using set_shadow_root_get_shadow_root_different_pointers
by fast
have get_shadow_root_eq_h2:
"\<And>shadow_root_opt ptr'. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads get_shadow_root_delete_shadow_root[OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then
have get_shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r =
|h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
moreover
have "parent_child_rel h = parent_child_rel h2"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h children_eq2_h)
moreover
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
using object_ptr_kinds_eq_h2
apply(auto simp add: CD.parent_child_rel_def)[1]
by (metis \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> children_eq2_h2)
ultimately
have "CD.a_acyclic_heap h'"
using acyclic_subset
by (auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
moreover
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
by(auto simp add: children_eq2_h disconnected_nodes_eq2_h document_ptr_kinds_eq_h
CD.a_all_ptrs_in_heap_def object_ptr_kinds_eq_h node_ptr_kinds_def
children_eq_h disconnected_nodes_eq_h)
then have "CD.a_all_ptrs_in_heap h'"
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 children_eq_h2
disconnected_nodes_eq_h2)[1]
apply(case_tac "ptr = cast shadow_root_ptr")
using object_ptr_kinds_eq_h2 children_eq_h2
apply (meson \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close>
is_OK_returns_result_I local.get_child_nodes_ptr_in_heap)
apply (metis (no_types, lifting) children_eq2_h2 fin_mono finite_set_in object_ptr_kinds_eq_h2
subsetD)
by (metis (full_types) assms(1) assms(2) disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h node_ptr_kinds_eq_h2
returns_result_select_result)
moreover
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
by(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
children_eq2_h disconnected_nodes_eq2_h)
then have "CD.a_distinct_lists h'"
apply(auto simp add: CD.a_distinct_lists_def document_ptr_kinds_eq_h2
disconnected_nodes_eq2_h2)[1]
apply(auto simp add: intro!: distinct_concat_map_I)[1]
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
using children_eq_h2 concat_map_all_distinct[of "(\<lambda>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r)"]
- apply (metis (no_types, lifting) children_eq2_h2 finite_fset fmember.rep_eq fset_mp
+ apply (metis (no_types, lifting) children_eq2_h2 finite_fset fmember_iff_member_fset fset_mp
object_ptr_kinds_eq_h2 set_sorted_list_of_set)
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
apply(case_tac "y = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
using children_eq_h2 distinct_concat_map_E(1)[of "(\<lambda>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r)"]
apply (metis (no_types, lifting) IntI \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> children_eq2_h2 empty_iff
finite_fset finite_set_in is_OK_returns_result_I l_get_child_nodes.get_child_nodes_ptr_in_heap
local.get_child_nodes_ok local.known_ptrs_known_ptr local.l_get_child_nodes_axioms
returns_result_select_result sorted_list_of_set.set_sorted_key_list_of_set)
apply(case_tac "xa = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
by (metis (mono_tags, lifting) CD.distinct_lists_no_parent \<open>known_ptrs h'\<close>
\<open>local.CD.a_distinct_lists h2\<close> \<open>type_wf h'\<close> children_eq2_h2 children_eq_h2
disconnected_nodes_eq_h2 is_OK_returns_result_I l_get_child_nodes.get_child_nodes_ptr_in_heap
local.get_child_nodes_ok local.get_disconnected_nodes_ok local.known_ptrs_known_ptr
local.l_get_child_nodes_axioms returns_result_select_result)
moreover
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h2"
by(auto simp add: CD.a_owner_document_valid_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
node_ptr_kinds_eq_h children_eq2_h disconnected_nodes_eq2_h)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def document_ptr_kinds_eq_h2 node_ptr_kinds_eq_h2
disconnected_nodes_eq2_h2)[1]
proof -
fix node_ptr
assume 0: "\<forall>node_ptr\<in>fset (node_ptr_kinds h').
(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h' \<and>
node_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h2 \<and>
node_ptr \<in> set |h2 \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
and 1: "node_ptr |\<in>| node_ptr_kinds h'"
and 2: "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h' \<longrightarrow>
node_ptr \<notin> set |h' \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
then have "\<forall>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h2 \<longrightarrow>
node_ptr \<notin> set |h2 \<turnstile> get_child_nodes parent_ptr|\<^sub>r"
apply(auto)[1]
apply(case_tac "parent_ptr = cast shadow_root_ptr")
using \<open>h \<turnstile> get_child_nodes (cast shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> children_eq_h
apply auto[1]
using children_eq2_h2 object_ptr_kinds_eq_h2 h' delete_shadow_root_pointers
by (metis fempty_iff finsert_iff funionE)
then show "\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h' \<and>
node_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using 0 1
by auto
qed
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
by(simp add: CD.heap_is_wellformed_def)
moreover
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "acyclic (parent_child_rel h2 \<union> a_host_shadow_root_rel h2)"
proof -
have "a_host_shadow_root_rel h2 \<subseteq> a_host_shadow_root_rel h"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h)[1]
apply(case_tac "aa = ptr")
apply(simp)
apply (metis (no_types, lifting) \<open>type_wf h2\<close> assms(2) h2 local.get_shadow_root_ok
local.type_wf_impl option.distinct(1) returns_result_eq
returns_result_select_result set_shadow_root_get_shadow_root)
using get_shadow_root_eq_h
by (metis (mono_tags, lifting) \<open>type_wf h2\<close> image_eqI is_OK_returns_result_E
local.get_shadow_root_ok mem_Collect_eq prod.simps(2) select_result_I2)
then show ?thesis
using \<open>parent_child_rel h = parent_child_rel h2\<close>
by (metis (no_types, opaque_lifting) \<open>acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)\<close>
acyclic_subset order_refl sup_mono)
qed
then
have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
proof -
have "a_host_shadow_root_rel h' \<subseteq> a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 get_shadow_root_eq2_h2)
then show ?thesis
using \<open>parent_child_rel h' \<subseteq> parent_child_rel h2\<close>
\<open>acyclic (parent_child_rel h2 \<union> a_host_shadow_root_rel h2)\<close>
using acyclic_subset sup_mono
by (metis (no_types, opaque_lifting))
qed
moreover
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
apply(case_tac "host = ptr")
apply(simp)
apply (metis assms(2) h2 local.type_wf_impl option.distinct(1) returns_result_eq
set_shadow_root_get_shadow_root)
using get_shadow_root_eq_h
by fastforce
then
have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def get_shadow_root_eq_h2)[1]
apply(auto simp add: shadow_root_ptr_kinds_eq2_h2)[1]
by (metis (no_types, lifting) \<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1)
assms(2) get_shadow_root_eq_h get_shadow_root_eq_h2 h2 local.shadow_root_same_host
local.type_wf_impl option.distinct(1) select_result_I2 set_shadow_root_get_shadow_root)
moreover
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h)[1]
apply(auto intro!: distinct_concat_map_I split: option.splits)[1]
apply(case_tac "x = ptr")
apply(simp)
apply (metis (no_types, opaque_lifting) assms(2) h2 is_OK_returns_result_I
l_set_shadow_root_get_shadow_root.set_shadow_root_get_shadow_root
l_set_shadow_root_get_shadow_root_axioms local.type_wf_impl option.discI
returns_result_eq returns_result_select_result)
apply(case_tac "y = ptr")
apply(simp)
apply (metis (no_types, opaque_lifting) assms(2) h2 is_OK_returns_result_I
l_set_shadow_root_get_shadow_root.set_shadow_root_get_shadow_root
l_set_shadow_root_get_shadow_root_axioms local.type_wf_impl option.discI
returns_result_eq returns_result_select_result)
by (metis \<open>type_wf h2\<close> assms(1) assms(2) get_shadow_root_eq_h local.get_shadow_root_ok
local.shadow_root_same_host returns_result_select_result)
then
have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 get_shadow_root_eq2_h2)
moreover
have "a_shadow_root_valid h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_shadow_root_valid h'"
by (smt (verit) \<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(2)
delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap element_ptr_kinds_eq_h element_ptr_kinds_eq_h2
finite_set_in finsert_iff funion_finsert_right get_shadow_root_eq2_h2 get_shadow_root_eq_h h'
local.a_shadow_root_valid_def local.get_shadow_root_ok object_ptr_kinds_eq2_h2
object_ptr_kinds_eq_h option.sel returns_result_select_result select_result_I2
shadow_root_ptr_kinds_commutes sup_bot.right_neutral tag_name_eq2_h tag_name_eq2_h2)
ultimately show "heap_is_wellformed h'"
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_remove_shadow_root_wf?: l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_tag_name get_tag_name_locs get_disconnected_nodes get_disconnected_nodes_locs
set_shadow_root set_shadow_root_locs known_ptr get_child_nodes get_child_nodes_locs get_shadow_root
get_shadow_root_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host
get_host_locs get_disconnected_document get_disconnected_document_locs remove_shadow_root
remove_shadow_root_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_root\_node\<close>
interpretation i_get_root_node_wf?: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs
heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_parent get_parent_locs get_ancestors get_ancestors_locs
get_root_node get_root_node_locs
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed parent_child_rel known_ptr known_ptrs type_wf get_ancestors
get_ancestors_locs get_child_nodes get_parent"
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def instances)[1]
using get_ancestors_never_empty apply blast
using get_ancestors_ok apply blast
using get_ancestors_reads apply blast
using get_ancestors_ptrs_in_heap apply blast
using get_ancestors_remains_not_in_ancestors apply blast
using get_ancestors_also_parent apply blast
using get_ancestors_obtains_children apply blast
using get_ancestors_parent_child_rel apply blast
using get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed get_root_node type_wf known_ptr known_ptrs get_ancestors
get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def)[1]
using get_root_node_ok apply blast
using get_root_node_ptr_in_heap apply blast
using get_root_node_root_in_heap apply blast
using get_ancestors_same_root_node apply(blast, blast)
using get_root_node_same_no_parent apply blast
(* using get_root_node_not_node_same apply blast *)
using get_root_node_parent_same apply (blast, blast)
done
subsubsection \<open>get\_parent\_get\_host\<close>
locale l_get_parent_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_shadow_root +
l_get_host +
l_get_child_nodes
begin
lemma host_shadow_root_rel_finite: "finite (a_host_shadow_root_rel h)"
proof -
have "a_host_shadow_root_rel h = (\<Union>host \<in> fset (element_ptr_kinds h).
(case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> {(cast host, cast shadow_root)} | None \<Rightarrow> {}))"
by(auto simp add: a_host_shadow_root_rel_def split: option.splits)
moreover have "finite (\<Union>host \<in> fset (element_ptr_kinds h).
(case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> {(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host, cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root)} |
None \<Rightarrow> {}))"
by(auto split: option.splits)
ultimately show ?thesis
by auto
qed
lemma host_shadow_root_rel_shadow_root:
"h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r shadow_root_option \<Longrightarrow>
shadow_root_option = Some shadow_root \<longleftrightarrow> ((cast host, cast shadow_root) \<in> a_host_shadow_root_rel h)"
apply(auto simp add: a_host_shadow_root_rel_def)[1]
by(metis (mono_tags, lifting) case_prodI is_OK_returns_result_I
l_get_shadow_root.get_shadow_root_ptr_in_heap local.l_get_shadow_root_axioms
mem_Collect_eq pair_imageI select_result_I2)
lemma host_shadow_root_rel_host:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host \<Longrightarrow>
(cast host, cast shadow_root) \<in> a_host_shadow_root_rel h"
apply(auto simp add: a_host_shadow_root_rel_def)[1]
using shadow_root_host_dual
by (metis (no_types, lifting) Collect_cong host_shadow_root_rel_shadow_root
local.a_host_shadow_root_rel_def split_cong)
lemma heap_wellformed_induct_si [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
assumes "\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> P (cast child)) \<Longrightarrow> (\<And>shadow_root host. parent = cast host \<Longrightarrow>
h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root \<Longrightarrow> P (cast shadow_root)) \<Longrightarrow> P parent"
shows "P ptr"
proof -
fix ptr
have "finite (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using host_shadow_root_rel_finite
using local.CD.parent_child_rel_finite local.CD.parent_child_rel_impl
by auto
then
have "wf ((parent_child_rel h \<union> a_host_shadow_root_rel h)\<inverse>)"
using assms(1)
apply(simp add: heap_is_wellformed_def)
by (simp add: finite_acyclic_wf_converse local.CD.parent_child_rel_impl)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
apply(auto)[1]
using assms host_shadow_root_rel_shadow_root local.CD.parent_child_rel_child
by blast
qed
qed
lemma heap_wellformed_induct_rev_si [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
assumes "\<And>child. (\<And>parent child_node. child = cast child_node \<Longrightarrow>
h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent) \<Longrightarrow>
(\<And>host shadow_root. child = cast shadow_root \<Longrightarrow> h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host \<Longrightarrow>
P (cast host)) \<Longrightarrow> P child"
shows "P ptr"
proof -
fix ptr
have "finite (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using host_shadow_root_rel_finite
using local.CD.parent_child_rel_finite local.CD.parent_child_rel_impl
by auto
then
have "wf (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using assms(1)
apply(simp add: heap_is_wellformed_def)
by (simp add: finite_acyclic_wf)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
apply(auto)[1]
using parent_child_rel_parent host_shadow_root_rel_host
using assms(1) assms(2) by auto
qed
qed
end
interpretation i_get_parent_get_host_wf?: l_get_parent_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs
get_disconnected_document get_disconnected_document_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_get_parent_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_parent_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_parent_get_host_wf =
l_heap_is_wellformed_defs +
l_get_parent_defs +
l_get_shadow_root_defs +
l_get_host_defs +
l_get_child_nodes_defs +
assumes heap_wellformed_induct_si [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children
\<Longrightarrow> P (cast child))
\<Longrightarrow> (\<And>shadow_root host. parent = cast host \<Longrightarrow> h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root
\<Longrightarrow> P (cast shadow_root))
\<Longrightarrow> P parent)
\<Longrightarrow> P ptr"
assumes heap_wellformed_induct_rev_si [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>child. (\<And>parent child_node. child = cast child_node \<Longrightarrow>
h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent)
\<Longrightarrow> (\<And>host shadow_root. child = cast shadow_root \<Longrightarrow> h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host
\<Longrightarrow> P (cast host))
\<Longrightarrow> P child)
\<Longrightarrow> P ptr"
lemma l_get_parent_get_host_wf_is_get_parent_get_host_wf [instances]:
"l_get_parent_get_host_wf heap_is_wellformed get_parent get_shadow_root get_host get_child_nodes"
apply(auto simp add: l_get_parent_get_host_wf_def instances)[1]
using heap_wellformed_induct_si apply metis
using heap_wellformed_induct_rev_si apply blast
done
subsubsection \<open>get\_host\<close>
locale l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host
get_host_locs +
l_type_wf type_wf +
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_shadow_root get_shadow_root_locs get_host get_host_locs type_wf +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma get_host_ok [simp]:
assumes "heap_is_wellformed h"
assumes "type_wf h"
assumes "known_ptrs h"
assumes "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
shows "h \<turnstile> ok (get_host shadow_root_ptr)"
proof -
obtain host where host: "host |\<in>| element_ptr_kinds h"
and "|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types"
and shadow_root: "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms(1) assms(4) get_shadow_root_ok assms(2)
apply(auto simp add: heap_is_wellformed_def a_shadow_root_valid_def)[1]
by (smt finite_set_in returns_result_select_result)
obtain host_candidates where
host_candidates: "h \<turnstile> filter_M (\<lambda>element_ptr. Heap_Error_Monad.bind (get_shadow_root element_ptr)
(\<lambda>shadow_root_opt. return (shadow_root_opt = Some shadow_root_ptr)))
(sorted_list_of_set (fset (element_ptr_kinds h)))
\<rightarrow>\<^sub>r host_candidates"
apply(drule is_OK_returns_result_E[rotated])
using get_shadow_root_ok assms(2)
by(auto intro!: filter_M_is_OK_I bind_pure_I bind_is_OK_I2)
then have "host_candidates = [host]"
apply(rule filter_M_ex1)
apply (simp add: host)
apply (smt (verit) assms(1) assms(2) bind_pure_returns_result_I2 finite_fset finite_set_in
host local.get_shadow_root_ok local.get_shadow_root_pure local.shadow_root_same_host
return_returns_result returns_result_eq shadow_root sorted_list_of_set(1))
by (simp_all add: assms(2) bind_pure_I bind_pure_returns_result_I2 host local.get_shadow_root_ok
returns_result_eq shadow_root)
then
show ?thesis
using host_candidates host assms(1) get_shadow_root_ok
apply(auto simp add: get_host_def known_ptrs_known_ptr
intro!: bind_is_OK_pure_I filter_M_pure_I filter_M_is_OK_I bind_pure_I split: list.splits)[1]
using assms(2) apply blast
apply (meson list.distinct(1) returns_result_eq)
by (meson list.distinct(1) list.inject returns_result_eq)
qed
end
interpretation i_get_host_wf?: l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document
get_disconnected_document_locs known_ptr known_ptrs type_wf get_host get_host_locs get_shadow_root
get_shadow_root_locs get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_host_wf = l_heap_is_wellformed_defs + l_known_ptrs + l_type_wf + l_get_host_defs +
assumes get_host_ok:
"heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_host shadow_root_ptr)"
lemma get_host_wf_is_l_get_host_wf [instances]:
"l_get_host_wf heap_is_wellformed known_ptr known_ptrs type_wf get_host"
by(auto simp add: l_get_host_wf_def l_get_host_wf_axioms_def instances)
subsubsection \<open>get\_root\_node\_si\<close>
locale l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_parent_get_host_wf +
l_get_host_wf
begin
lemma get_root_node_si_ptr_in_heap:
assumes "h \<turnstile> ok (get_root_node_si ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
unfolding get_root_node_si_def
using get_ancestors_si_ptr_in_heap
by auto
lemma get_ancestors_si_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_ancestors_si ptr)"
proof (insert assms(1) assms(4), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using assms(2) assms(3)
apply(auto simp add: get_ancestors_si_def[of child] assms(1) get_parent_parent_in_heap
intro!: bind_is_OK_pure_I
split: option.splits)[1]
using local.get_parent_ok apply blast
using get_host_ok assms(1) apply blast
by (meson assms(1) is_OK_returns_result_I local.get_shadow_root_ptr_in_heap
local.shadow_root_host_dual)
qed
lemma get_ancestors_si_remains_not_in_ancestors:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
and "h' \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors'"
and "\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children' \<Longrightarrow> set children' \<subseteq> set children"
and "\<And>p shadow_root_option shadow_root_option'. h \<turnstile> get_shadow_root p \<rightarrow>\<^sub>r shadow_root_option \<Longrightarrow>
h' \<turnstile> get_shadow_root p \<rightarrow>\<^sub>r shadow_root_option' \<Longrightarrow> (if shadow_root_option = None
then shadow_root_option' = None else shadow_root_option' = None \<or>
shadow_root_option' = shadow_root_option)"
and "node \<notin> set ancestors"
and object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "node \<notin> set ancestors'"
proof -
have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
using object_ptr_kinds_eq3
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
show ?thesis
proof (insert assms(1) assms(3) assms(4) assms(7), induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev_si)
case (step child)
obtain ancestors_remains where ancestors_remains:
"ancestors = child # ancestors_remains"
using \<open>h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors\<close> get_ancestors_si_never_empty
by(auto simp add: get_ancestors_si_def[of child]
elim!: bind_returns_result_E2
split: option.splits)
obtain ancestors_remains' where ancestors_remains':
"ancestors' = child # ancestors_remains'"
using \<open>h' \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors'\<close> get_ancestors_si_never_empty
by(auto simp add: get_ancestors_si_def[of child]
elim!: bind_returns_result_E2
split: option.splits)
have "child |\<in>| object_ptr_kinds h"
using local.get_ancestors_si_ptr_in_heap object_ptr_kinds_eq3 step.prems(2) by fastforce
have "node \<noteq> child"
using ancestors_remains step.prems(3) by auto
have 1: "\<And>p parent. h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent \<Longrightarrow> h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
proof -
fix p parent
assume "h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
then obtain children' where
children': "h' \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'" and
p_in_children': "p \<in> set children'"
using get_parent_child_dual by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(1) get_child_nodes_ptr_in_heap object_ptr_kinds_eq children'
known_ptrs
using type_wf type_wf'
by (metis \<open>h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent\<close> get_parent_parent_in_heap is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
have "p \<in> set children"
using assms(5) children children' p_in_children'
by blast
then show "h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
using child_parent_dual assms(1) children known_ptrs type_wf by blast
qed
have 2: "\<And>p host. h' \<turnstile> get_host p \<rightarrow>\<^sub>r host \<Longrightarrow> h \<turnstile> get_host p \<rightarrow>\<^sub>r host"
proof -
fix p host
assume "h' \<turnstile> get_host p \<rightarrow>\<^sub>r host"
then have "h' \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some p"
using local.shadow_root_host_dual by blast
then have "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some p"
by (metis assms(6) element_ptr_kinds_commutes is_OK_returns_result_I local.get_shadow_root_ok
local.get_shadow_root_ptr_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq3
option.distinct(1) returns_result_select_result type_wf)
then show "h \<turnstile> get_host p \<rightarrow>\<^sub>r host"
by (metis assms(1) is_OK_returns_result_E known_ptrs local.get_host_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.shadow_root_host_dual
local.shadow_root_same_host type_wf)
qed
show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?thesis
using step(3) step(4) \<open>node \<noteq> child\<close>
apply(auto simp add: get_ancestors_si_def[of child]
elim!: bind_returns_result_E2
split: option.splits)[1]
by (metis "2" assms(1) l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.shadow_root_same_host list.set_intros(2)
local.l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms local.shadow_root_host_dual step.hyps(2)
step.prems(3) type_wf)
next
case (Some node_child)
then
show ?thesis
using step(3) step(4) \<open>node \<noteq> child\<close>
apply(auto simp add: get_ancestors_si_def[of child]
elim!: bind_returns_result_E2
split: option.splits)[1]
apply (meson "1" option.distinct(1) returns_result_eq)
by (metis "1" list.set_intros(2) option.inject returns_result_eq step.hyps(1) step.prems(3))
qed
qed
qed
lemma get_ancestors_si_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
shows "ptr' |\<in>| object_ptr_kinds h"
proof (insert assms(4) assms(5), induct ancestors arbitrary: ptr)
case Nil
then show ?case
by(auto)
next
case (Cons a ancestors)
then obtain x where x: "h \<turnstile> get_ancestors_si x \<rightarrow>\<^sub>r a # ancestors"
by(auto simp add: get_ancestors_si_def[of a] elim!: bind_returns_result_E2 split: option.splits)
then have "x = a"
by(auto simp add: get_ancestors_si_def[of x] elim!: bind_returns_result_E2 split: option.splits)
then show ?case
proof (cases "ptr' = a")
case True
then show ?thesis
using Cons.hyps Cons.prems(2) get_ancestors_si_ptr_in_heap x
using \<open>x = a\<close> by blast
next
case False
obtain ptr'' where ptr'': "h \<turnstile> get_ancestors_si ptr'' \<rightarrow>\<^sub>r ancestors"
using \<open> h \<turnstile> get_ancestors_si x \<rightarrow>\<^sub>r a # ancestors\<close> Cons.prems(2) False
by(auto simp add: get_ancestors_si_def[of x] elim!: bind_returns_result_E2 split: option.splits)
then show ?thesis
using Cons.hyps Cons.prems(2) False by auto
qed
qed
lemma get_ancestors_si_reads:
assumes "heap_is_wellformed h"
shows "reads get_ancestors_si_locs (get_ancestors_si node_ptr) h h'"
proof (insert assms(1), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using [[simproc del: Product_Type.unit_eq]] get_parent_reads[unfolded reads_def]
get_host_reads[unfolded reads_def]
apply(simp (no_asm) add: get_ancestors_si_def)
by(auto simp add: get_ancestors_si_locs_def get_parent_reads_pointers
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads]
reads_subset[OF return_reads] reads_subset[OF get_parent_reads]
reads_subset[OF get_child_nodes_reads] reads_subset[OF get_host_reads]
split: option.splits)
qed
lemma get_ancestors_si_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors_si ancestor \<rightarrow>\<^sub>r ancestor_ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "set ancestor_ancestors \<subseteq> set ancestors"
proof (insert assms(1) assms(2) assms(3), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev_si)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_si_ptr_in_heap step(3) by auto
(* then have "h \<turnstile> check_in_heap child \<rightarrow>\<^sub>r ()"
using returns_result_select_result by force *)
obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using step(3)
by(auto simp add: get_ancestors_si_def[of child] intro!: bind_pure_I
elim!: bind_returns_result_E2 split: option.splits)
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?case
using step(3) \<open>None = cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child\<close>
apply(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2)[1]
by (metis (no_types, lifting) assms(4) empty_iff empty_set select_result_I2 set_ConsD
step.prems(1) step.prems(2))
next
case (Some shadow_root_child)
then
have "shadow_root_child |\<in>| shadow_root_ptr_kinds h"
using \<open>child |\<in>| object_ptr_kinds h\<close>
by (metis (no_types, lifting) shadow_root_ptr_casts_commute shadow_root_ptr_kinds_commutes)
obtain host where host: "h \<turnstile> get_host shadow_root_child \<rightarrow>\<^sub>r host"
using get_host_ok assms
by (meson \<open>shadow_root_child |\<in>| shadow_root_ptr_kinds h\<close> is_OK_returns_result_E)
then
have "h \<turnstile> get_ancestors_si (cast host) \<rightarrow>\<^sub>r tl_ancestors"
using Some step(3) tl_ancestors None
by(auto simp add: get_ancestors_si_def[of child] intro!: bind_pure_returns_result_I
elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
then
show ?case
using step(2) Some host step(4) tl_ancestors
by (metis (no_types, lifting) assms(4) dual_order.trans eq_iff returns_result_eq set_ConsD
set_subset_Cons shadow_root_ptr_casts_commute step.prems(1))
qed
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric]
get_parent_ok[OF type_wf known_ptrs]
by (metis (no_types, lifting) is_OK_returns_result_E known_ptrs get_parent_ok
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(3) s1
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(3) step(4)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some parent)
then
have "h \<turnstile> get_ancestors_si parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 tl_ancestors step(3)
by(auto simp add: get_ancestors_si_def[of child]
elim!: bind_returns_result_E2
split: option.splits dest: returns_result_eq)
show ?case
by (metis (no_types, lifting) Some.prems \<open>h \<turnstile> get_ancestors_si parent \<rightarrow>\<^sub>r tl_ancestors\<close>
assms(4) eq_iff node_ptr_casts_commute order_trans s1 select_result_I2 set_ConsD
set_subset_Cons step.hyps(1) step.prems(1) step.prems(2) tl_ancestors)
qed
qed
qed
lemma get_ancestors_si_also_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast child \<in> set ancestors"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "parent \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors:
"h \<turnstile> get_ancestors_si (cast child) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(4) get_ancestors_si_ok is_OK_returns_result_I known_ptrs
local.get_parent_ptr_in_heap node_ptr_kinds_commutes returns_result_select_result
type_wf)
then have "parent \<in> set child_ancestors"
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_si_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_si_subset by blast
qed
lemma get_ancestors_si_also_host:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast shadow_root \<in> set ancestors"
and "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "cast host \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors:
"h \<turnstile> get_ancestors_si (cast shadow_root) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_si_ok get_ancestors_si_ptrs_in_heap
is_OK_returns_result_E known_ptrs type_wf)
then have "cast host \<in> set child_ancestors"
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_si_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_si_subset by blast
qed
lemma get_ancestors_si_parent_child_rel:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors"
assumes "((ptr, child) \<in> (parent_child_rel h)\<^sup>*)"
shows "ptr \<in> set ancestors"
proof (insert assms(5), induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4) local.get_ancestors_si_ptr by blast
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h) \<and> (ptr_child, child) \<in> (parent_child_rel h)\<^sup>*"
using converse_rtranclE[OF 1(3)] \<open>ptr \<noteq> child\<close>
by metis
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 CD.parent_child_rel_node_ptr
by (metis )
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_parent_in_heap ptr_child by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis calculation \<open>known_ptrs h\<close> local.get_child_nodes_ok local.known_ptrs_known_ptr
CD.parent_child_rel_child ptr_child ptr_child_ptr_child_node
returns_result_select_result \<open>type_wf h\<close>)
ultimately show ?thesis
using a1 get_child_nodes_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h)\<^sup>*"
using ptr_child ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> by blast
ultimately show ?thesis
using get_ancestors_si_also_parent assms \<open>type_wf h\<close> by blast
qed
qed
lemma get_ancestors_si_parent_child_host_shadow_root_rel:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors"
assumes "((ptr, child) \<in> (parent_child_rel h \<union> a_host_shadow_root_rel h)\<^sup>*)"
shows "ptr \<in> set ancestors"
proof (insert assms(5), induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4) local.get_ancestors_si_ptr by blast
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h) \<and>
(ptr_child, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using converse_rtranclE[OF 1(3)] \<open>ptr \<noteq> child\<close>
by metis
then show ?thesis
proof(cases "(ptr, ptr_child) \<in> parent_child_rel h")
case True
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 CD.parent_child_rel_node_ptr
by (metis)
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_parent_in_heap True by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis True assms(2) assms(3) calculation local.CD.parent_child_rel_child
local.get_child_nodes_ok local.known_ptrs_known_ptr ptr_child_ptr_child_node
returns_result_select_result)
ultimately show ?thesis
using a1 get_child_nodes_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using ptr_child True ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> by blast
ultimately show ?thesis
using get_ancestors_si_also_parent assms \<open>type_wf h\<close> by blast
next
case False
then
obtain host where host: "ptr = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host"
using ptr_child
by(auto simp add: a_host_shadow_root_rel_def)
then obtain shadow_root where shadow_root: "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root"
and ptr_child_shadow_root: "ptr_child = cast shadow_root"
using ptr_child False
apply(auto simp add: a_host_shadow_root_rel_def)[1]
by (metis (no_types, lifting) assms(3) local.get_shadow_root_ok select_result_I)
moreover have "(cast shadow_root, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using ptr_child ptr_child_shadow_root by blast
ultimately have "cast shadow_root \<in> set ancestors"
using "1.hyps"(2) host by blast
moreover have "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
by (metis assms(1) assms(2) assms(3) is_OK_returns_result_E local.get_host_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.shadow_root_host_dual
local.shadow_root_same_host shadow_root)
ultimately show ?thesis
using get_ancestors_si_also_host assms(1) assms(2) assms(3) assms(4) host
by blast
qed
qed
qed
lemma get_root_node_si_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_root_node_si ptr)"
using assms get_ancestors_si_ok
by(auto simp add: get_root_node_si_def)
lemma get_root_node_si_root_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root"
shows "root |\<in>| object_ptr_kinds h"
using assms
apply(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)[1]
by (simp add: get_ancestors_si_never_empty get_ancestors_si_ptrs_in_heap)
lemma get_root_node_si_same_no_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r cast child"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof (insert assms(1) assms(4), induct ptr rule: heap_wellformed_induct_rev_si)
case (step c)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r c")
case None
then show ?thesis
using step(3)
by(auto simp add: get_root_node_si_def get_ancestors_si_def[of c]
elim!: bind_returns_result_E2
split: if_splits option.splits
intro!: step(2) bind_pure_returns_result_I)
next
case (Some child_node)
note s = this
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using step(3)
apply(auto simp add: get_root_node_si_def get_ancestors_si_def
intro!: bind_pure_I
elim!: bind_returns_result_E2)[1]
by(auto split: option.splits)
then show ?thesis
proof(induct parent_opt)
case None
then show ?case
using Some get_root_node_si_no_parent returns_result_eq step.prems by fastforce
next
case (Some parent)
then show ?case
using step(3) s
apply(auto simp add: get_root_node_si_def get_ancestors_si_def[of c]
elim!: bind_returns_result_E2 split: option.splits list.splits if_splits)[1]
using assms(1) get_ancestors_si_never_empty apply blast
by(auto simp add: get_root_node_si_def
dest: returns_result_eq
intro!: step(1) bind_pure_returns_result_I)
qed
qed
qed
end
interpretation i_get_root_node_si_wf?: l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs
get_parent get_parent_locs get_child_nodes get_child_nodes_locs get_host get_host_locs
get_ancestors_si get_ancestors_si_locs get_root_node_si get_root_node_si_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_document get_disconnected_document_locs
by(auto simp add: instances l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_disconnected\_document\<close>
locale l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_parent
begin
lemma get_disconnected_document_ok:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
shows "h \<turnstile> ok (get_disconnected_document node_ptr)"
proof -
have "node_ptr |\<in>| node_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_parent_ptr_in_heap)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
apply(auto)[1]
using assms(4) child_parent_dual[OF assms(1)]
assms(1) assms(2) assms(3) known_ptrs_known_ptr option.simps(3)
returns_result_eq returns_result_select_result
by (metis (no_types, lifting) CD.get_child_nodes_ok)
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in>
set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using heap_is_wellformed_children_disc_nodes
using \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) by blast
then obtain some_owner_document where
"some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))" and
"node_ptr \<in> set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
have h5: "\<exists>!x. x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h))) \<and>
h \<turnstile> Heap_Error_Monad.bind (get_disconnected_nodes x)
(\<lambda>children. return (node_ptr \<in> set children)) \<rightarrow>\<^sub>r True"
apply(auto intro!: bind_pure_returns_result_I)[1]
apply (smt (verit, best) CD.get_disconnected_nodes_ok CD.get_disconnected_nodes_pure
\<open>\<exists>document_ptr\<in>fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes
document_ptr|\<^sub>r\<close> assms(2) bind_pure_returns_result_I finite_set_in return_returns_result
returns_result_select_result)
apply(auto elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I)[1]
using heap_is_wellformed_one_disc_parent assms(1)
by blast
let ?filter_M = "filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (node_ptr \<in> set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))"
have "h \<turnstile> ok (?filter_M)"
using CD.get_disconnected_nodes_ok
by (smt (verit) CD.get_disconnected_nodes_pure DocumentMonad.ptr_kinds_M_ptr_kinds
DocumentMonad.ptr_kinds_ptr_kinds_M assms(2) bind_is_OK_pure_I bind_pure_I
document_ptr_kinds_M_def filter_M_is_OK_I l_ptr_kinds_M.ptr_kinds_M_ok return_ok
return_pure returns_result_select_result)
then
obtain candidates where candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (node_ptr \<in> set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by auto
have "candidates = [some_owner_document]"
apply(rule filter_M_ex1[OF candidates \<open>some_owner_document \<in>
set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close> h5])
using \<open>node_ptr \<in> set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
\<open>some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close>
by(auto simp add: CD.get_disconnected_nodes_ok assms(2)
intro!: bind_pure_I
intro!: bind_pure_returns_result_I)
then show ?thesis
using candidates \<open>node_ptr |\<in>| node_ptr_kinds h\<close>
apply(auto simp add: get_disconnected_document_def
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
split: list.splits)[1]
apply (meson not_Cons_self2 returns_result_eq)
by (meson list.distinct(1) list.inject returns_result_eq)
qed
end
interpretation i_get_disconnected_document_wf?: l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs
get_disconnected_document get_disconnected_document_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_owner\_document\<close>
locale l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes +
l_get_child_nodes +
l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_known_ptrs +
l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
begin
lemma get_owner_document_disconnected_nodes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
assumes known_ptrs: "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
proof -
have 2: "node_ptr |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.a_all_ptrs_in_heap_def)[1]
using assms(1) local.heap_is_wellformed_disc_nodes_in_heap by blast
have 3: "document_ptr |\<in>| document_ptr_kinds h"
using assms(2) get_disconnected_nodes_ptr_in_heap by blast
then have 4: "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using CD.distinct_lists_no_parent assms
unfolding heap_is_wellformed_def CD.heap_is_wellformed_def by simp
moreover have "(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using assms(1) 2 "3" assms(2) assms(3) by auto
ultimately have 0: "\<exists>!document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r.
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
by (meson DocumentMonad.ptr_kinds_ptr_kinds_M assms(1) disjoint_iff
local.get_disconnected_nodes_ok local.heap_is_wellformed_one_disc_parent
returns_result_select_result type_wf)
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
by (metis (mono_tags, lifting) "2" "4" known_ptrs local.get_parent_child_dual
local.get_parent_ok local.get_parent_parent_in_heap returns_result_select_result
select_result_I2 split_option_ex type_wf)
then have 4: "h \<turnstile> get_root_node_si (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using get_root_node_si_no_parent
by simp
obtain document_ptrs where document_ptrs: "h \<turnstile> document_ptr_kinds_M \<rightarrow>\<^sub>r document_ptrs"
by simp
then have "h \<turnstile> ok (filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs)"
using assms(1) get_disconnected_nodes_ok type_wf
by(auto intro!: bind_is_OK_I2 filter_M_is_OK_I bind_pure_I)
then obtain candidates where
candidates: "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r candidates"
by auto
have filter: "filter (\<lambda>document_ptr. |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \<in> cast ` set disconnected_nodes)
}|\<^sub>r) document_ptrs = [document_ptr]"
apply(rule filter_ex1)
using 0 document_ptrs
apply (smt (verit) DocumentMonad.ptr_kinds_ptr_kinds_M bind_pure_returns_result_I2
local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure node_ptr_inclusion
return_returns_result select_result_I2 type_wf)
using assms(2) assms(3)
apply (metis (no_types, lifting) bind_pure_returns_result_I2 is_OK_returns_result_I
local.get_disconnected_nodes_pure node_ptr_inclusion return_returns_result select_result_I2)
using document_ptrs 3 apply(simp)
using document_ptrs
by simp
have "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r [document_ptr]"
apply(rule filter_M_filter2)
using get_disconnected_nodes_ok document_ptrs 3 assms(1) type_wf filter
by(auto intro: bind_pure_I bind_is_OK_I2)
with 4 document_ptrs have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r document_ptr"
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)
moreover have "known_ptr (cast node_ptr)"
using known_ptrs_known_ptr[OF known_ptrs, where ptr="cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"] 2
known_ptrs_implies
by(simp)
ultimately show ?thesis
using 2
apply(auto simp add: CD.a_get_owner_document_tups_def get_owner_document_def
a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_shadow_root_ptr)
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto split: option.splits intro!: bind_pure_returns_result_I)
qed
lemma in_disconnected_nodes_no_parent:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
assumes "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document"
assumes "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assumes "known_ptrs h"
assumes "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
have "\<And>parent. parent |\<in>| object_ptr_kinds h \<Longrightarrow> node_ptr \<notin> set |h \<turnstile> get_child_nodes parent|\<^sub>r"
using assms(2)
by (meson get_child_nodes_ok assms(1) assms(5) assms(6) local.child_parent_dual
local.known_ptrs_known_ptr option.distinct(1) returns_result_eq returns_result_select_result)
then show ?thesis
by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) assms(5) assms(6)
finite_set_in is_OK_returns_result_I local.get_disconnected_nodes_ok
local.get_owner_document_disconnected_nodes local.get_parent_ptr_in_heap
local.heap_is_wellformed_children_disc_nodes returns_result_eq returns_result_select_result)
qed
lemma get_owner_document_owner_document_in_heap_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
proof -
obtain root where
root: "h \<turnstile> get_root_node_si (cast node_ptr) \<rightarrow>\<^sub>r root"
using assms(4)
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2
split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using assms(4) root
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using assms document_ptr_kinds_commutes get_root_node_si_root_in_heap
by blast
next
case False
have "known_ptr root"
using assms local.get_root_node_si_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using assms local.get_root_node_si_root_in_heap
by blast
have "\<not>is_shadow_root_ptr root"
using root
using local.get_root_node_si_root_not_shadow_root by blast
then have "is_node_ptr_kind root"
using False \<open>known_ptr root\<close> \<open>root |\<in>| object_ptr_kinds h\<close>
apply(simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h).
root \<in> cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using local.child_parent_dual local.get_child_nodes_ok local.get_root_node_si_same_no_parent
local.heap_is_wellformed_children_disc_nodes local.known_ptrs_known_ptr node_ptr_casts_commute3
node_ptr_inclusion node_ptr_kinds_commutes notin_fset option.distinct(1) returns_result_eq
returns_result_select_result root
by (metis (no_types, lifting) assms \<open>root |\<in>| object_ptr_kinds h\<close>)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) assms bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure
notin_fset return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto simp add: assms local.get_disconnected_nodes_ok
intro!: bind_pure_I bind_pure_returns_result_I)[1]
done
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using assms(4) root
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
qed
lemma get_owner_document_owner_document_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
using assms
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_split_asm)+
proof -
assume "h \<turnstile> invoke [] ptr () \<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by (meson invoke_empty is_OK_returns_result_I)
next
assume "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())
\<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2
split: if_splits)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then show ?thesis
by (metis bind_returns_result_E2 check_in_heap_pure comp_apply
get_owner_document_owner_document_in_heap_node)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then show ?thesis
by (metis bind_returns_result_E2 check_in_heap_pure comp_apply
get_owner_document_owner_document_in_heap_node)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "\<not> is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 6: "is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 7: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())
\<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
apply(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: filter_M_pure_I bind_pure_I
elim!: bind_returns_result_E2
split: if_splits option.splits)[1]
using get_owner_document_owner_document_in_heap_node by blast
qed
lemma get_owner_document_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_owner_document ptr)"
proof -
have "known_ptr ptr"
using assms(2) assms(4) local.known_ptrs_known_ptr
by blast
then show ?thesis
apply(simp add: get_owner_document_def a_get_owner_document_tups_def CD.a_get_owner_document_tups_def)
apply(split invoke_splits, (rule conjI | rule impI)+)+
proof -
assume 0: "known_ptr ptr"
and 1: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 2: "\<not> is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 3: "\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "\<not> is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
then show "h \<turnstile> ok invoke [] ptr ()"
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_shadow_root_ptr known_ptr_not_element_ptr known_ptr_impl
by blast
next
assume 0: "known_ptr ptr"
and 1: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 2: "\<not> is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 3: "\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
then show "is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \<longrightarrow> h \<turnstile> ok Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())"
using assms(1) assms(2) assms(3) assms(4)
by(auto simp add: local.get_host_ok get_root_node_def
CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I get_root_node_si_ok
get_disconnected_nodes_ok
intro!: local.get_shadow_root_ptr_in_heap local.shadow_root_host_dual
split: option.splits)
next
show "is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \<longrightarrow> h \<turnstile> ok Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())"
using assms(4)
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def split: option.splits)
next
show "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \<longrightarrow> h \<turnstile> ok Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())"
using assms(1) assms(2) assms(3) assms(4)
by(auto simp add: local.get_host_ok get_root_node_def
CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I get_root_node_si_ok
get_disconnected_nodes_ok
intro!: local.get_shadow_root_ptr_in_heap local.shadow_root_host_dual split: option.splits)
next
show "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr \<longrightarrow> h \<turnstile> ok Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())"
using assms(1) assms(2) assms(3) assms(4)
by(auto simp add: local.get_host_ok get_root_node_def
CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I get_root_node_si_ok
get_disconnected_nodes_ok
intro!: local.get_shadow_root_ptr_in_heap local.shadow_root_host_dual
split: option.splits)
qed
qed
end
interpretation i_get_owner_document_wf?: l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_disconnected_nodes get_disconnected_nodes_locs known_ptr
get_child_nodes get_child_nodes_locs DocumentClass.known_ptr get_parent get_parent_locs
get_root_node_si get_root_node_si_locs CD.a_get_owner_document get_host get_host_locs
get_owner_document get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document
get_disconnected_document_locs known_ptrs get_ancestors_si get_ancestors_si_locs
by(auto simp add: l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
instances)
declare l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_wf_is_l_get_owner_document_wf [instances]: "l_get_owner_document_wf
heap_is_wellformed type_wf known_ptr known_ptrs get_disconnected_nodes get_owner_document
get_parent"
apply(auto simp add: l_get_owner_document_wf_def l_get_owner_document_wf_axioms_def instances)[1]
using get_owner_document_disconnected_nodes apply fast
using in_disconnected_nodes_no_parent apply fast
using get_owner_document_owner_document_in_heap apply fast
using get_owner_document_ok apply fast
done
subsubsection \<open>remove\_child\<close>
locale l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_disconnected_nodes +
l_get_child_nodes +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
CD: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_child_preserves_type_wf:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "type_wf h'"
using CD.remove_child_heap_is_wellformed_preserved(1) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_child_preserves_known_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'"
using CD.remove_child_heap_is_wellformed_preserved(2) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_child_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
proof -
have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
using CD.remove_child_heap_is_wellformed_preserved(3) assms
unfolding heap_is_wellformed_def
by auto
have shadow_root_eq: "\<And>ptr' shadow_root_ptr_opt. h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads remove_child_writes assms(4)
apply(rule reads_writes_preserved)
by(auto simp add: remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2: "\<And>ptr'. |h \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq: "\<And>ptr' tag. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads remove_child_writes assms(4)
apply(rule reads_writes_preserved)
by(auto simp add: remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
have shadow_root_ptr_kinds_eq: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq
by(auto simp add: shadow_root_ptr_kinds_def)
have element_ptr_kinds_eq: "element_ptr_kinds h = element_ptr_kinds h'"
using object_ptr_kinds_eq
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
using \<open>heap_is_wellformed h\<close> heap_is_wellformed_def
using CD.remove_child_parent_child_rel_subset
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> assms(4)
by simp
show ?thesis
using \<open>heap_is_wellformed h\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close> \<open>parent_child_rel h' \<subseteq> parent_child_rel h\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
a_host_shadow_root_rel_def a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def
object_ptr_kinds_eq element_ptr_kinds_eq shadow_root_ptr_kinds_eq shadow_root_eq shadow_root_eq2
tag_name_eq tag_name_eq2)[1]
by (meson acyclic_subset order_refl sup_mono)
qed
lemma remove_preserves_type_wf:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "type_wf h'"
using CD.remove_heap_is_wellformed_preserved(1) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_preserves_known_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'"
using CD.remove_heap_is_wellformed_preserved(2) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
using assms
by(auto simp add: remove_def elim!: bind_returns_heap_E2
intro: remove_child_heap_is_wellformed_preserved
split: option.splits)
lemma remove_child_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> child \<notin> set children"
using CD.remove_child_removes_child local.heap_is_wellformed_def by blast
lemma remove_child_removes_first_child: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children \<Longrightarrow> h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using CD.remove_child_removes_first_child local.heap_is_wellformed_def by blast
lemma remove_removes_child: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children \<Longrightarrow> h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using CD.remove_removes_child local.heap_is_wellformed_def by blast
lemma remove_for_all_empty_children: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using CD.remove_for_all_empty_children local.heap_is_wellformed_def by blast
end
interpretation i_remove_child_wf2?: l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs known_ptr get_child_nodes get_child_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs DocumentClass.known_ptr get_parent get_parent_locs get_root_node_si
get_root_node_si_locs CD.a_get_owner_document get_owner_document known_ptrs get_ancestors_si
get_ancestors_si_locs set_child_nodes set_child_nodes_locs remove_child remove_child_locs remove
by(auto simp add: l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma remove_child_wf2_is_l_remove_child_wf2 [instances]:
"l_remove_child_wf2 type_wf known_ptr known_ptrs remove_child heap_is_wellformed get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using remove_child_preserves_type_wf apply fast
using remove_child_preserves_known_ptrs apply fast
using remove_child_heap_is_wellformed_preserved apply (fast)
using remove_preserves_type_wf apply fast
using remove_preserves_known_ptrs apply fast
using remove_heap_is_wellformed_preserved apply (fast)
using remove_child_removes_child apply fast
using remove_child_removes_first_child apply fast
using remove_removes_child apply fast
using remove_for_all_empty_children apply fast
done
subsubsection \<open>adopt\_node\<close>
locale l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_disconnected_nodes +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node +
l_set_disconnected_nodes_get_child_nodes +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_removes_child:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2"
and children: "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<notin> set children"
proof -
obtain old_document parent_opt h' where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h': "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return () ) \<rightarrow>\<^sub>h h'"
using adopt_node
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E bind_returns_heap_E2[rotated,
OF get_owner_document_pure, rotated] bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] split: if_splits)
then have "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using adopt_node
apply(auto simp add: adopt_node_def dest!: bind_returns_heap_E3[rotated, OF old_document, rotated]
bind_returns_heap_E3[rotated, OF parent_opt, rotated] elim!: bind_returns_heap_E4[rotated, OF h', rotated])[1]
apply(auto split: if_splits elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
apply (simp add: set_disconnected_nodes_get_child_nodes children
reads_writes_preserved[OF get_child_nodes_reads set_disconnected_nodes_writes])
using children by blast
show ?thesis
proof(insert parent_opt h', induct parent_opt)
case None
then show ?case
using child_parent_dual wellformed known_ptrs type_wf
\<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> returns_result_eq by fastforce
next
case (Some option)
then show ?case
using remove_child_removes_child \<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> known_ptrs type_wf
wellformed
by auto
qed
qed
lemma adopt_node_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have object_ptr_kinds_h_eq3: "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "type_wf h2"
using h2 remove_child_preserves_type_wf assms
by(auto split: option.splits)
have "known_ptrs h2"
using h2 remove_child_preserves_known_ptrs assms
by(auto split: option.splits)
then have "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
proof(cases "document_ptr = old_document")
case True
then show "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
using h' wellformed_h2 \<open>known_ptrs h2\<close> \<open>type_wf h2\<close> by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes_document_ptr_h3 where
docs_neq: "document_ptr \<noteq> old_document" and
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3" and
disc_nodes_document_ptr_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes_document_ptr_h3) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2:
"\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h3_eq3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h3: "node_ptr_kinds h3 = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
have children_eq_h3:
"\<And>ptr children. h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2: "\<And>doc_ptr disc_nodes. old_document \<noteq> doc_ptr \<Longrightarrow>
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2: "\<And>doc_ptr. old_document \<noteq> doc_ptr \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
obtain disc_nodes_old_document_h2 where disc_nodes_old_document_h2:
"h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
using old_disc_nodes by blast
then have disc_nodes_old_document_h3:
"h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
using h3 old_disc_nodes returns_result_eq set_disconnected_nodes_get_disconnected_nodes
by fastforce
have "distinct disc_nodes_old_document_h2"
using disc_nodes_old_document_h2 local.heap_is_wellformed_disconnected_nodes_distinct
wellformed_h2 by blast
have "type_wf h2"
proof (insert h2, induct parent_opt)
case None
then show ?case
using type_wf by simp
next
case (Some option)
then show ?case
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes]
type_wf remove_child_types_preserved
by (simp add: reflp_def transp_def)
qed
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr \<Longrightarrow>
h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr \<Longrightarrow>
|h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2:
"h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
using disconnected_nodes_eq_h2 docs_neq disc_nodes_document_ptr_h3 by auto
have disc_nodes_document_ptr_h':
"h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
using h' disc_nodes_document_ptr_h3
using set_disconnected_nodes_get_disconnected_nodes by blast
have document_ptr_in_heap: "document_ptr |\<in>| document_ptr_kinds h2"
using disc_nodes_document_ptr_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using disc_nodes_document_ptr_h2 get_disconnected_nodes_ptr_in_heap by blast
have old_document_in_heap: "old_document |\<in>| document_ptr_kinds h2"
using disc_nodes_old_document_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using get_disconnected_nodes_ptr_in_heap old_disc_nodes by blast
have "child \<in> set disc_nodes_old_document_h2"
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h2"
by(auto)
moreover have "CD.a_owner_document_valid h"
using assms(1) by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
ultimately show ?case
using old_document disc_nodes_old_document_h2 None(1) child_parent_dual[OF assms(1)]
in_disconnected_nodes_no_parent assms(1) known_ptrs type_wf by blast
next
case (Some option)
then show ?case
apply(simp split: option.splits)
using assms(1) disc_nodes_old_document_h2 old_document remove_child_in_disconnected_nodes
known_ptrs by blast
qed
have "child \<notin> set (remove1 child disc_nodes_old_document_h2)"
using disc_nodes_old_document_h3 h3 known_ptrs wellformed_h2
\<open>distinct disc_nodes_old_document_h2\<close> by auto
have "child \<notin> set disc_nodes_document_ptr_h3"
proof -
have "CD.a_distinct_lists h2"
using heap_is_wellformed_def CD.heap_is_wellformed_def wellformed_h2 by blast
then have 0: "distinct (concat (map (\<lambda>document_ptr.
|h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) |h2 \<turnstile> document_ptr_kinds_M|\<^sub>r))"
by(simp add: CD.a_distinct_lists_def)
show ?thesis
using distinct_concat_map_E(1)[OF 0] \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h2 disc_nodes_document_ptr_h2
by (meson \<open>type_wf h2\<close> docs_neq known_ptrs local.get_owner_document_disconnected_nodes
local.known_ptrs_preserved object_ptr_kinds_h_eq3 returns_result_eq wellformed_h2)
qed
have child_in_heap: "child |\<in>| node_ptr_kinds h"
using get_owner_document_ptr_in_heap[OF is_OK_returns_result_I[OF old_document]]
node_ptr_kinds_commutes by blast
have "CD.a_acyclic_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h2"
using object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 children_eq2_h2 children_eq2_h3
mem_Collect_eq object_ptr_kinds_M_eq_h3 select_result_eq split_cong
unfolding CD.parent_child_rel_def
by(simp)
qed
then have " CD.a_acyclic_heap h'"
using \<open> CD.a_acyclic_heap h2\<close> CD.acyclic_heap_def acyclic_subset by blast
moreover have " CD.a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h3"
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h2 children_eq_h2)[1]
apply (metis \<open>type_wf h'\<close> children_eq2_h3 children_eq_h2 children_eq_h3 known_ptrs
l_heap_is_wellformed.heap_is_wellformed_children_in_heap local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_heap_is_wellformed_axioms node_ptr_kinds_eq3_h2
object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3
returns_result_select_result wellformed_h2)
by (metis (no_types, opaque_lifting) disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 document_ptr_kinds_eq3_h2 finite_set_in select_result_I2
set_remove1_subset subsetD)
then have "CD.a_all_ptrs_in_heap h'"
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h3 children_eq_h3)[1]
apply (metis (no_types, opaque_lifting) children_eq2_h3 finite_set_in object_ptr_kinds_h3_eq3
subsetD)
by (metis (no_types, opaque_lifting) \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_eq3_h3 finite_set_in local.heap_is_wellformed_disc_nodes_in_heap
node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3 select_result_I2 set_ConsD subsetD wellformed_h2)
moreover have "CD.a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(simp add: CD.a_owner_document_valid_def node_ptr_kinds_eq_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
children_eq2_h2 children_eq2_h3 )
by (metis (no_types) disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2
disc_nodes_old_document_h2 disc_nodes_old_document_h3 disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_in_heap document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3
in_set_remove1 list.set_intros(1) list.set_intros(2) node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 select_result_I2)
have a_distinct_lists_h2: "CD.a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h'"
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h3 object_ptr_kinds_eq_h2
children_eq2_h2 children_eq2_h3)[1]
proof -
assume 1: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 3: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I)
show "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by(auto simp add: document_ptr_kinds_M_def )
next
fix x
assume a1: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 4: "distinct |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a_distinct_lists_h2 "2" a1 concat_map_all_distinct document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 by fastforce
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "old_document \<noteq> x")
case True
then show ?thesis
proof (cases "document_ptr \<noteq> x")
case True
then show ?thesis
using disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>]
disconnected_nodes_eq2_h3[OF \<open>document_ptr \<noteq> x\<close>] 4
by(auto)
next
case False
then show ?thesis
using disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' 4
\<open>child \<notin> set disc_nodes_document_ptr_h3\<close>
by(auto simp add: disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>] )
qed
next
case False
then show ?thesis
by (metis (no_types, opaque_lifting) \<open>distinct disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h3 disconnected_nodes_eq2_h3 distinct_remove1 docs_neq select_result_I2)
qed
next
fix x y
assume a0: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a1: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a2: "x \<noteq> y"
moreover have 5: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter>
set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using 2 calculation
by (auto simp add: document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3
dest: distinct_concat_map_E(1))
ultimately show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter>
set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
proof(cases "old_document = x")
case True
have "old_document \<noteq> y"
using \<open>x \<noteq> y\<close> \<open>old_document = x\<close> by simp
have "document_ptr \<noteq> x"
using docs_neq \<open>old_document = x\<close> by auto
show ?thesis
proof(cases "document_ptr = y")
case True
then show ?thesis
using 5 True select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document = x\<close>
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
\<open>document_ptr \<noteq> x\<close> disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1 set_ConsD)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 \<open>old_document = x\<close> docs_neq
\<open>old_document \<noteq> y\<close>
by (metis (no_types, lifting) disjoint_iff_not_equal notin_set_remove1)
qed
next
case False
then show ?thesis
proof(cases "old_document = y")
case True
then show ?thesis
proof(cases "document_ptr = x")
case True
show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr = x\<close>
apply(simp)
by (metis (no_types, lifting)
\<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document \<noteq> x\<close>
\<open>old_document = y\<close> \<open>document_ptr \<noteq> x\<close>
by (metis (no_types, lifting) disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 disjoint_iff_not_equal docs_neq notin_set_remove1)
qed
next
case False
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
by (metis DocumentMonad.ptr_kinds_M_ok DocumentMonad.ptr_kinds_M_ptr_kinds False
\<open>type_wf h2\<close> a1 disc_nodes_old_document_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result wellformed_h2)
then show ?thesis
proof(cases "document_ptr = x")
case True
then have "document_ptr \<noteq> y"
using \<open>x \<noteq> y\<close> by auto
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
using \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by blast
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document \<noteq> x\<close>
\<open>old_document \<noteq> y\<close> \<open>document_ptr = x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by(auto)
next
case False
then show ?thesis
proof(cases "document_ptr = y")
case True
have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set disc_nodes_document_ptr_h3 = {}"
using 2 a1 document_ptr_in_heap document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 \<open>document_ptr \<noteq> x\<close>
select_result_I2[OF disc_nodes_document_ptr_h3, symmetric]
disconnected_nodes_eq2_h2[OF docs_neq[symmetric], symmetric]
by (simp add: "5" True)
moreover have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter>
set |h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = {}"
using 2 a1 old_document_in_heap document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 \<open>old_document \<noteq> x\<close>
by (metis (no_types, lifting) a0 distinct_concat_map_E(1)
- document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 finite_fset fmember.rep_eq
+ document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3 finite_fset fmember_iff_member_fset
set_sorted_list_of_set)
ultimately show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr = y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by auto
next
case False
then show ?thesis
using 5
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by (metis \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter>
set disc_nodes_old_document_h2 = {}\<close> empty_iff inf.idem)
qed
qed
qed
qed
qed
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show False
using \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 old_document_in_heap
apply(auto)[1]
apply(cases "xb = old_document")
proof -
assume a1: "xb = old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a3: "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
assume a4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a5: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f6: "old_document |\<in>| document_ptr_kinds h'"
using a1 \<open>xb |\<in>| document_ptr_kinds h'\<close> by blast
have f7: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a2 by simp
have "x \<in> set disc_nodes_old_document_h2"
using f6 a3 a1 by (metis (no_types) \<open>type_wf h'\<close>
\<open>x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close> disconnected_nodes_eq_h3 docs_neq
get_disconnected_nodes_ok returns_result_eq returns_result_select_result set_remove1_subset subsetCE)
then have "set |h' \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using f7 f6 a5 a4 \<open>xa |\<in>| object_ptr_kinds h'\<close>
by fastforce
then show ?thesis
using \<open>x \<in> set disc_nodes_old_document_h2\<close> a1 a4 f7 by blast
next
assume a1: "xb \<noteq> old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
assume a3: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a4: "xa |\<in>| object_ptr_kinds h'"
assume a5: "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
assume a6: "old_document |\<in>| document_ptr_kinds h'"
assume a7: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume a8: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume a9: "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a10: "\<And>doc_ptr. old_document \<noteq> doc_ptr \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a11: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr \<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r =
|h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a12: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f13: "\<And>d. d \<notin> set |h' \<turnstile> document_ptr_kinds_M|\<^sub>r \<or> h2 \<turnstile> ok get_disconnected_nodes d"
using a9 \<open>type_wf h2\<close> get_disconnected_nodes_ok
by simp
then have f14: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a6 a3 by simp
have "x \<notin> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
using a12 a8 a4 \<open>xb |\<in>| document_ptr_kinds h'\<close>
- by (meson UN_I disjoint_iff_not_equal fmember.rep_eq)
+ by (meson UN_I disjoint_iff_not_equal fmember_iff_member_fset)
then have "x = child"
using f13 a11 a10 a7 a5 a2 a1
by (metis (no_types, lifting) select_result_I2 set_ConsD)
then have "child \<notin> set disc_nodes_old_document_h2"
using f14 a12 a8 a6 a4
by (metis \<open>type_wf h'\<close> adopt_node_removes_child assms(1) assms(2) type_wf
get_child_nodes_ok known_ptrs local.known_ptrs_known_ptr object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3 returns_result_select_result)
then show ?thesis
using \<open>child \<in> set disc_nodes_old_document_h2\<close> by fastforce
qed
qed
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
using \<open>CD.a_owner_document_valid h'\<close> CD.heap_is_wellformed_def
by simp
have shadow_root_eq_h2:
"\<And>ptr' shadow_root_ptr_opt. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have shadow_root_eq_h3:
"\<And>ptr' shadow_root_ptr_opt. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h2: "\<And>ptr' tag. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h3: "\<And>ptr' tag. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h3 = element_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have "known_ptrs h3"
using known_ptrs local.known_ptrs_preserved object_ptr_kinds_h2_eq3 object_ptr_kinds_h_eq3
by blast
then have "known_ptrs h'"
using local.known_ptrs_preserved object_ptr_kinds_h3_eq3 by blast
show "heap_is_wellformed h' \<and> known_ptrs h' \<and> type_wf h'"
using \<open>heap_is_wellformed h2\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close> \<open>known_ptrs h'\<close> \<open>type_wf h'\<close>
using \<open>parent_child_rel h' \<subseteq> parent_child_rel h2\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
a_host_shadow_root_rel_def a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2 element_ptr_kinds_eq_h3
shadow_root_ptr_kinds_eq_h2 shadow_root_ptr_kinds_eq_h3 shadow_root_eq_h2 shadow_root_eq_h3
shadow_root_eq2_h2 shadow_root_eq2_h3 tag_name_eq_h2 tag_name_eq_h3 tag_name_eq2_h2
tag_name_eq2_h3 CD.parent_child_rel_def children_eq2_h2 children_eq2_h3 object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3)[1]
done
qed
then show "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
by auto
qed
lemma adopt_node_node_in_disconnected_nodes:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
and "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node_ptr old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node_ptr # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: adopt_node_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h'"
using h2 h' by(auto)
then show ?case
using in_disconnected_nodes_no_parent assms None old_document by blast
next
case (Some parent)
then show ?case
using remove_child_in_disconnected_nodes known_ptrs True h' assms(3) old_document
by auto
qed
next
case False
then show ?thesis
using assms(3) h' list.set_intros(1) select_result_I2
set_disconnected_nodes_get_disconnected_nodes
apply(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
proof -
fix x and h'a and xb
assume a1: "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assume a2: "\<And>h document_ptr disc_nodes h'.
h \<turnstile> set_disconnected_nodes document_ptr disc_nodes \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume "h'a \<turnstile> set_disconnected_nodes owner_document (node_ptr # xb) \<rightarrow>\<^sub>h h'"
then have "node_ptr # xb = disc_nodes"
using a2 a1 by (meson returns_result_eq)
then show ?thesis
by (meson list.set_intros(1))
qed
qed
qed
end
interpretation l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M Shadow_DOM.get_owner_document Shadow_DOM.get_parent
Shadow_DOM.get_parent_locs Shadow_DOM.remove_child Shadow_DOM.remove_child_locs
get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs Shadow_DOM.adopt_node Shadow_DOM.adopt_node_locs
ShadowRootClass.known_ptr ShadowRootClass.type_wf Shadow_DOM.get_child_nodes
Shadow_DOM.get_child_nodes_locs
ShadowRootClass.known_ptrs Shadow_DOM.set_child_nodes Shadow_DOM.set_child_nodes_locs
Shadow_DOM.remove Shadow_DOM.heap_is_wellformed Shadow_DOM.parent_child_rel
by(auto simp add: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_adopt_node_wf2?: l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs set_child_nodes set_child_nodes_locs get_shadow_root get_shadow_root_locs
set_disconnected_nodes set_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs get_root_node get_root_node_locs get_parent get_parent_locs known_ptrs
get_owner_document remove_child remove_child_locs remove adopt_node adopt_node_locs
by(auto simp add: l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma adopt_node_wf_is_l_adopt_node_wf [instances]:
"l_adopt_node_wf type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes known_ptrs adopt_node"
apply(auto simp add: l_adopt_node_wf_def l_adopt_node_wf_axioms_def instances)[1]
using adopt_node_preserves_wellformedness apply blast
using adopt_node_removes_child apply blast
using adopt_node_node_in_disconnected_nodes apply blast
using adopt_node_removes_first_child apply blast
using adopt_node_document_in_heap apply blast
using adopt_node_preserves_wellformedness apply blast
using adopt_node_preserves_wellformedness apply blast
done
subsubsection \<open>insert\_before\<close>
locale l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_disconnected_nodes +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
l_set_disconnected_nodes_get_disconnected_nodes +
l_set_child_nodes_get_disconnected_nodes +
l_set_disconnected_nodes_get_disconnected_nodes_wf +
l_set_disconnected_nodes_get_ancestors_si +
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ get_ancestors_si get_ancestors_si_locs +
l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document +
l_adopt_node +
l_adopt_node_wf +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_get_shadow_root
begin
lemma insert_before_child_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child:
"h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
(* children: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and *)
(* h': "h3 \<turnstile> set_child_nodes ptr (insert_before_list node reference_child children) \<rightarrow>\<^sub>h h'" *)
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "type_wf h2"
using \<open>type_wf h\<close>
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using adopt_node_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have "object_ptr_kinds h = object_ptr_kinds h2"
using adopt_node_writes h2
apply(rule writes_small_big)
using adopt_node_pointers_preserved
by(auto simp add: reflp_def transp_def)
moreover have "\<dots> = object_ptr_kinds h3"
using set_disconnected_nodes_writes h3
apply(rule writes_small_big)
using set_disconnected_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
moreover have "\<dots> = object_ptr_kinds h'"
using insert_node_writes h'
apply(rule writes_small_big)
using set_child_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
ultimately
show "known_ptrs h'"
using \<open>known_ptrs h\<close> known_ptrs_preserved
by blast
have "known_ptrs h2"
using \<open>known_ptrs h\<close> known_ptrs_preserved \<open>object_ptr_kinds h = object_ptr_kinds h2\<close>
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved \<open>object_ptr_kinds h2 = object_ptr_kinds h3\<close>
by blast
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I \<open>known_ptrs h\<close>
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF \<open>heap_is_wellformed h\<close> h2] \<open>known_ptrs h\<close>
\<open>type_wf h\<close>
.
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2:
"\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h']) unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3:
"\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
have shadow_root_eq_h2:
"\<And>ptr' shadow_root. h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root =
h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root"
using get_shadow_root_reads adopt_node_writes h2
apply(rule reads_writes_preserved)
using local.adopt_node_get_shadow_root by blast
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr \<Longrightarrow>
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> owner_document \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r =
|h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3:
"h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow>
h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3:
"\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children:
"\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using \<open>heap_is_wellformed h\<close> h2 adopt_node_removes_child \<open>type_wf h\<close> \<open>known_ptrs h\<close> by auto
have "node \<in> set disconnected_nodes_h2"
using disconnected_nodes_h2 h2 adopt_node_node_in_disconnected_nodes assms(1)
\<open>type_wf h\<close> \<open>known_ptrs h\<close> by blast
have node_not_in_disconnected_nodes:
"\<And>d. d |\<in>| document_ptr_kinds h3 \<Longrightarrow> node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof -
fix d
assume "d |\<in>| document_ptr_kinds h3"
show "node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof (cases "d = owner_document")
case True
then show ?thesis
using disconnected_nodes_h2 wellformed_h2 h3 remove_from_disconnected_nodes_removes
wellformed_h2 \<open>d |\<in>| document_ptr_kinds h3\<close> disconnected_nodes_h3
by fastforce
next
case False
then have "set |h2 \<turnstile> get_disconnected_nodes d|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes owner_document|\<^sub>r = {}"
using distinct_concat_map_E(1) wellformed_h2
by (metis (no_types, lifting) \<open>d |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h2\<close>
disconnected_nodes_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result select_result_I2)
then show ?thesis
using disconnected_nodes_eq2_h2[OF False] \<open>node \<in> set disconnected_nodes_h2\<close>
disconnected_nodes_h2 by fastforce
qed
qed
have "cast node \<noteq> ptr"
using ancestors node_not_in_ancestors get_ancestors_ptr
by fast
obtain ancestors_h2 where ancestors_h2: "h2 \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_si_ok
by (metis \<open>known_ptrs h2\<close> \<open>type_wf h2\<close> is_OK_returns_result_E
object_ptr_kinds_M_eq3_h2 ptr_in_heap wellformed_h2)
have ancestors_h3: "h3 \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors_h2"
using get_ancestors_si_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_separate_forwards)
using \<open>heap_is_wellformed h2\<close> apply simp
using ancestors_h2 apply simp
apply(auto simp add: get_ancestors_si_locs_def get_parent_locs_def)[1]
apply (simp add: local.get_ancestors_si_locs_def local.get_parent_reads_pointers
local.set_disconnected_nodes_get_ancestors_si)
using local.get_ancestors_si_locs_def local.set_disconnected_nodes_get_ancestors_si by blast
have node_not_in_ancestors_h2: "cast node \<notin> set ancestors_h2"
using \<open>heap_is_wellformed h\<close> \<open>heap_is_wellformed h2\<close> ancestors ancestors_h2
apply(rule get_ancestors_si_remains_not_in_ancestors)
using assms(2) assms(3) h2 local.adopt_node_children_subset apply blast
using shadow_root_eq_h2 node_not_in_ancestors object_ptr_kinds_M_eq2_h assms(2) assms(3)
\<open>type_wf h2\<close>
by(auto dest: returns_result_eq)
moreover
have "parent_child_rel h2 = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
have "parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))"
using children_h3 children_h' ptr_in_heap
apply(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h' children_eq2_h3
insert_before_list_node_in_set)[1]
apply (metis (no_types, lifting) children_eq2_h3 insert_before_list_in_set select_result_I2)
by (metis (no_types, lifting) children_eq2_h3 imageI insert_before_list_in_set select_result_I2)
have "CD.a_acyclic_heap h'"
proof -
have "acyclic (parent_child_rel h2)"
using wellformed_h2
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
then have "acyclic (parent_child_rel h3)"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h2)\<^sup>*}"
using get_ancestors_si_parent_child_rel
using \<open>known_ptrs h2\<close> \<open>type_wf h2\<close> ancestors_h2 node_not_in_ancestors_h2 wellformed_h2
by blast
then have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3)\<^sup>*}"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
ultimately show ?thesis
using \<open>parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))\<close>
by(auto simp add: CD.acyclic_heap_def)
qed
moreover have "CD.a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
have "CD.a_all_ptrs_in_heap h'"
proof -
have "CD.a_all_ptrs_in_heap h3"
using \<open>CD.a_all_ptrs_in_heap h2\<close>
apply(auto simp add: CD.a_all_ptrs_in_heap_def object_ptr_kinds_M_eq2_h2
node_ptr_kinds_eq2_h2 children_eq_h2)[1]
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
using node_ptr_kinds_eq2_h2 apply auto[1]
apply (metis (no_types, lifting) children_eq2_h2 in_mono notin_fset object_ptr_kinds_M_eq3_h2)
by (metis (no_types, opaque_lifting) NodeMonad.ptr_kinds_ptr_kinds_M disconnected_nodes_eq2_h2
disconnected_nodes_h2 disconnected_nodes_h3 document_ptr_kinds_commutes finite_set_in
node_ptr_kinds_eq2_h2 object_ptr_kinds_M_eq3_h2 select_result_I2 set_remove1_subset subsetD)
have "set children_h3 \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using children_h3 \<open>CD.a_all_ptrs_in_heap h3\<close>
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq2_h3)[1]
using CD.parent_child_rel_child_nodes2 \<open>known_ptr ptr\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> \<open>type_wf h2\<close>
local.parent_child_rel_child_in_heap node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h'
object_ptr_kinds_M_eq3_h2 wellformed_h2 by blast
then have "set (insert_before_list node reference_child children_h3) \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_in_heap
apply(auto simp add: node_ptr_kinds_eq2_h node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3)[1]
by (metis (no_types, opaque_lifting) contra_subsetD finite_set_in insert_before_list_in_set
node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h' object_ptr_kinds_M_eq3_h2)
then show ?thesis
using \<open>CD.a_all_ptrs_in_heap h3\<close>
apply(auto simp add: object_ptr_kinds_M_eq3_h' CD.a_all_ptrs_in_heap_def node_ptr_kinds_def
node_ptr_kinds_eq2_h3 disconnected_nodes_eq_h3)[1]
using children_eq_h3 children_h'
apply (metis (no_types, lifting) children_eq2_h3 finite_set_in select_result_I2 subsetD)
by (metis (no_types, lifting) DocumentMonad.ptr_kinds_ptr_kinds_M disconnected_nodes_eq2_h3
document_ptr_kinds_eq2_h3 finite_set_in subsetD)
qed
moreover have "CD.a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def )
then have "CD.a_distinct_lists h3"
proof(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_M_eq2_h2 document_ptr_kinds_eq2_h2
children_eq2_h2 intro!: distinct_concat_map_I)
fix x
assume 1: "x |\<in>| document_ptr_kinds h3"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
show "distinct |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_concat_map_E(2)[OF 2] select_result_I2[OF disconnected_nodes_h3]
disconnected_nodes_eq2_h2 select_result_I2[OF disconnected_nodes_h2] 1
- by (metis (full_types) distinct_remove1 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ by (metis (full_types) distinct_remove1 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and 2: "x |\<in>| document_ptr_kinds h3"
and 3: "y |\<in>| document_ptr_kinds h3"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
and 6: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r"
show False
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using 4 by simp
show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3]
select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>y \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal
notin_set_remove1)
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3]
select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>x \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal
notin_set_remove1)
next
case False
then show ?thesis
using distinct_concat_map_E(1)[OF 1, simplified, OF 2 3 4] 5 6
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
- disjoint_iff_not_equal finite_fset fmember.rep_eq notin_set_remove1 select_result_I2
+ disjoint_iff_not_equal finite_fset fmember_iff_member_fset notin_set_remove1 select_result_I2
set_sorted_list_of_set
by (metis (no_types, lifting))
qed
qed
next
fix x xa xb
assume 1: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h3 \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h3). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 2: "xa |\<in>| object_ptr_kinds h3"
and 3: "x \<in> set |h3 \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h3"
and 5: "x \<in> set |h3 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 4
by (metis \<open>type_wf h2\<close> children_eq2_h2 document_ptr_kinds_commutes \<open>known_ptrs h\<close>
local.get_child_nodes_ok local.get_disconnected_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h2 returns_result_select_result wellformed_h2)
show False
proof (cases "xb = owner_document")
case True
then show ?thesis
using select_result_I2[OF disconnected_nodes_h3,folded select_result_I2[OF disconnected_nodes_h2]]
by (metis (no_types, lifting) "3" "5" "6" disjoint_iff_not_equal notin_set_remove1)
next
case False
show ?thesis
using 2 3 4 5 6 unfolding disconnected_nodes_eq2_h2[OF False] by auto
qed
qed
then have "CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def document_ptr_kinds_eq2_h3 object_ptr_kinds_M_eq2_h3
disconnected_nodes_eq2_h3 intro!: distinct_concat_map_I)
fix x
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))" and
2: "x |\<in>| object_ptr_kinds h'"
have 3: "\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> distinct |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using 1 by (auto elim: distinct_concat_map_E)
show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
proof(cases "ptr = x")
case True
show ?thesis
using 3[OF 2] children_h3 children_h'
by(auto simp add: True insert_before_list_distinct
dest: child_not_in_any_children[unfolded children_eq_h2])
next
case False
show ?thesis
using children_eq2_h3[OF False] 3[OF 2] by auto
qed
next
fix x y xa
assume 1:"distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "x |\<in>| object_ptr_kinds h'"
and 3: "y |\<in>| object_ptr_kinds h'"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h' \<turnstile> get_child_nodes x|\<^sub>r"
and 6: "xa \<in> set |h' \<turnstile> get_child_nodes y|\<^sub>r"
have 7:"set |h3 \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_child_nodes y|\<^sub>r = {}"
using distinct_concat_map_E(1)[OF 1] 2 3 4 by auto
show False
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
using 4 by simp
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> y\<close>])[1]
by (metis (no_types, opaque_lifting) "3" "7" \<open>type_wf h3\<close> children_eq2_h3 disjoint_iff_not_equal
get_child_nodes_ok insert_before_list_in_set \<open>known_ptrs h\<close> local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h' object_ptr_kinds_M_eq3_h2
returns_result_select_result select_result_I2)
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> x\<close>])[1]
by (metis (no_types, opaque_lifting) "2" "4" "7" IntI \<open>known_ptrs h3\<close> \<open>type_wf h'\<close>
children_eq_h3 empty_iff insert_before_list_in_set local.get_child_nodes_ok
local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h' returns_result_select_result select_result_I2)
next
case False
then show ?thesis
using children_eq2_h3[OF \<open>ptr \<noteq> x\<close>] children_eq2_h3[OF \<open>ptr \<noteq> y\<close>] 5 6 7 by auto
qed
qed
next
fix x xa xb
assume 1: " (\<Union>x\<in>fset (object_ptr_kinds h'). set |h3 \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h'). set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r) = {} "
and 2: "xa |\<in>| object_ptr_kinds h'"
and 3: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h'"
and 5: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 3 4 5
proof -
have "\<forall>h d. \<not> type_wf h \<or> d |\<notin>| document_ptr_kinds h \<or> h \<turnstile> ok get_disconnected_nodes d"
using local.get_disconnected_nodes_ok by satx
then have "h' \<turnstile> ok get_disconnected_nodes xb"
using "4" \<open>type_wf h'\<close> by fastforce
then have f1: "h3 \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
by (simp add: disconnected_nodes_eq_h3)
have "xa |\<in>| object_ptr_kinds h3"
using "2" object_ptr_kinds_M_eq3_h' by blast
then show ?thesis
using f1 \<open>local.CD.a_distinct_lists h3\<close> CD.distinct_lists_no_parent by fastforce
qed
show False
proof (cases "ptr = xa")
case True
show ?thesis
using 6 node_not_in_disconnected_nodes 3 4 5 select_result_I2[OF children_h']
select_result_I2[OF children_h3] True disconnected_nodes_eq2_h3
by (metis (no_types, lifting) "2" DocumentMonad.ptr_kinds_ptr_kinds_M
\<open>CD.a_distinct_lists h3\<close> \<open>type_wf h'\<close> disconnected_nodes_eq_h3 CD.distinct_lists_no_parent
document_ptr_kinds_eq2_h3 get_disconnected_nodes_ok insert_before_list_in_set
object_ptr_kinds_M_eq3_h' returns_result_select_result)
next
case False
then show ?thesis
using 1 2 3 4 5 children_eq2_h3[OF False] by fastforce
qed
qed
moreover have "CD.a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def object_ptr_kinds_M_eq2_h2
object_ptr_kinds_M_eq2_h3 node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3 document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 children_eq2_h2 )[1] thm children_eq2_h3
apply(auto simp add: document_ptr_kinds_eq2_h2[simplified] document_ptr_kinds_eq2_h3[simplified]
object_ptr_kinds_M_eq2_h2[simplified] object_ptr_kinds_M_eq2_h3[simplified]
node_ptr_kinds_eq2_h2[simplified] node_ptr_kinds_eq2_h3[simplified])[1]
apply(auto simp add: disconnected_nodes_eq2_h3[symmetric])[1]
by (metis (no_types, lifting) Core_DOM_Functions.i_insert_before.insert_before_list_in_set
children_eq2_h3 children_h' children_h3 disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 finite_set_in in_set_remove1 is_OK_returns_result_I object_ptr_kinds_M_eq3_h'
ptr_in_heap returns_result_eq returns_result_select_result)
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
by (simp add: CD.heap_is_wellformed_def)
have shadow_root_eq_h2:
"\<And>ptr' shadow_root_ptr_opt. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have shadow_root_eq_h3:
"\<And>ptr' shadow_root_ptr_opt. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h2: "\<And>ptr' tag. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h3: "\<And>ptr' tag. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF insert_node_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h3 = element_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq2_h2)
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3 shadow_root_eq2_h3)
have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)\<^sup>*}"
using get_ancestors_si_parent_child_host_shadow_root_rel
using \<open>known_ptrs h2\<close> \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> \<open>type_wf h2\<close> ancestors_h2 node_not_in_ancestors_h2
wellformed_h2
by auto
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)"
using \<open>heap_is_wellformed h2\<close>
by(auto simp add: heap_is_wellformed_def \<open>parent_child_rel h2 = parent_child_rel h3\<close>
\<open>a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3\<close>)
then
have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
apply(auto simp add: \<open>a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'\<close>
\<open>parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))\<close>)[1]
using \<open>cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)\<^sup>*}\<close>
by (simp add: \<open>local.a_host_shadow_root_rel h3 = local.a_host_shadow_root_rel h'\<close>)
then
show "heap_is_wellformed h'"
using \<open>heap_is_wellformed h2\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def)[1]
by(auto simp add: object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3 shadow_root_ptr_kinds_eq_h2 shadow_root_ptr_kinds_eq_h3 shadow_root_eq_h2
shadow_root_eq_h3 shadow_root_eq2_h2 shadow_root_eq2_h3 tag_name_eq_h2 tag_name_eq_h3
tag_name_eq2_h2 tag_name_eq2_h3)
qed
end
interpretation i_insert_before_wf?: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs
get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_si
get_ancestors_si_locs adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_owner_document insert_before
insert_before_locs append_child type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel
by(simp add: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf_is_l_insert_before_wf [instances]:
"l_insert_before_wf Shadow_DOM.heap_is_wellformed ShadowRootClass.type_wf
ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
Shadow_DOM.insert_before Shadow_DOM.get_child_nodes"
apply(auto simp add: l_insert_before_wf_def l_insert_before_wf_axioms_def instances)[1]
using insert_before_removes_child apply fast
done
lemma l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]: "l_set_disconnected_nodes_get_disconnected_nodes_wf ShadowRootClass.type_wf
ShadowRootClass.known_ptr Shadow_DOM.heap_is_wellformed Shadow_DOM.parent_child_rel Shadow_DOM.get_child_nodes
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def
l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
by (metis Diff_iff Shadow_DOM.i_heap_is_wellformed.heap_is_wellformed_disconnected_nodes_distinct
Shadow_DOM.i_remove_child.set_disconnected_nodes_get_disconnected_nodes insert_iff
returns_result_eq set_remove1_eq)
interpretation l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_host get_host_locs get_ancestors_si get_ancestors_si_locs get_root_node_si get_root_node_si_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_document get_disconnected_document_locs
by(auto simp add: l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_insert_before_wf2?: l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs set_child_nodes set_child_nodes_locs get_shadow_root get_shadow_root_locs set_disconnected_nodes set_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel get_ancestors_si get_ancestors_si_locs get_parent get_parent_locs adopt_node adopt_node_locs get_owner_document insert_before insert_before_locs append_child known_ptrs get_host get_host_locs get_root_node_si get_root_node_si_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document get_disconnected_document_locs
by(auto simp add: l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf2_is_l_insert_before_wf2 [instances]:
"l_insert_before_wf2 ShadowRootClass.type_wf ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
Shadow_DOM.insert_before
Shadow_DOM.heap_is_wellformed"
apply(auto simp add: l_insert_before_wf2_def l_insert_before_wf2_axioms_def instances)[1]
using insert_before_child_preserves apply(fast, fast, fast)
done
subsubsection \<open>append\_child\<close>
interpretation i_append_child_wf?: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent
get_parent_locs remove_child remove_child_locs
get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs
adopt_node adopt_node_locs known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs set_child_nodes
set_child_nodes_locs remove get_ancestors_si get_ancestors_si_locs
insert_before insert_before_locs append_child heap_is_wellformed
parent_child_rel
by(auto simp add: l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_append_child_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma append_child_wf_is_l_append_child_wf [instances]:
"l_append_child_wf type_wf known_ptr known_ptrs append_child heap_is_wellformed"
apply(auto simp add: l_append_child_wf_def l_append_child_wf_axioms_def instances)[1]
using append_child_heap_is_wellformed_preserved by fast+
subsubsection \<open>to\_tree\_order\<close>
interpretation i_to_tree_order_wf?: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent get_parent_locs heap_is_wellformed
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
apply(auto simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
done
declare l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def instances)[1]
using to_tree_order_ok apply fast
using to_tree_order_ptrs_in_heap apply fast
using to_tree_order_parent_child_rel apply(fast, fast)
using to_tree_order_child2 apply blast
using to_tree_order_node_ptrs apply fast
using to_tree_order_child apply fast
using to_tree_order_ptr_in_result apply fast
using to_tree_order_parent apply fast
using to_tree_order_subset apply fast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_to_tree_order_wf_get_root_node_wf?: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_parent get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
to_tree_order
by(auto simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_get_root_node_wf_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf ShadowRootClass.type_wf ShadowRootClass.known_ptr
ShadowRootClass.known_ptrs to_tree_order Shadow_DOM.get_root_node
Shadow_DOM.heap_is_wellformed"
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def
l_to_tree_order_wf_get_root_node_wf_axioms_def instances)[1]
using to_tree_order_get_root_node apply fast
using to_tree_order_same_root apply fast
done
subsubsection \<open>to\_tree\_order\_si\<close>
locale l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_parent_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma to_tree_order_si_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (to_tree_order_si ptr)"
proof(insert assms(1) assms(4), induct rule: heap_wellformed_induct_si)
case (step parent)
have "known_ptr parent"
using assms(2) local.known_ptrs_known_ptr step.prems
by blast
then show ?case
using step
using assms(1) assms(2) assms(3)
using local.heap_is_wellformed_children_in_heap local.get_shadow_root_shadow_root_ptr_in_heap
by(auto simp add: to_tree_order_si_def[of parent] intro: get_child_nodes_ok get_shadow_root_ok
intro!: bind_is_OK_pure_I map_M_pure_I bind_pure_I map_M_ok_I split: option.splits)
qed
end
interpretation i_to_tree_order_si_wf?: l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_host get_host_locs get_disconnected_document get_disconnected_document_locs
known_ptrs get_parent get_parent_locs to_tree_order_si
by(auto simp add: l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_assigned\_nodes\<close>
lemma forall_M_small_big: "h \<turnstile> forall_M f xs \<rightarrow>\<^sub>h h' \<Longrightarrow> P h \<Longrightarrow>
(\<And>h h' x. x \<in> set xs \<Longrightarrow> h \<turnstile> f x \<rightarrow>\<^sub>h h' \<Longrightarrow> P h \<Longrightarrow> P h') \<Longrightarrow> P h'"
by(induct xs arbitrary: h) (auto elim!: bind_returns_heap_E)
locale l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_remove_child_wf2 +
l_append_child_wf +
l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma assigned_nodes_distinct:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes"
shows "distinct nodes"
proof -
have "\<And>ptr children. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
using assms(1) local.heap_is_wellformed_children_distinct by blast
then show ?thesis
using assms
apply(auto simp add: assigned_nodes_def elim!: bind_returns_result_E2 split: if_splits)[1]
by (simp add: filter_M_distinct)
qed
lemma flatten_dom_preserves:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> flatten_dom \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
proof -
obtain tups h2 element_ptrs shadow_root_ptrs where
"h \<turnstile> element_ptr_kinds_M \<rightarrow>\<^sub>r element_ptrs" and
tups: "h \<turnstile> map_filter_M2 (\<lambda>element_ptr. do {
tag \<leftarrow> get_tag_name element_ptr;
assigned_nodes \<leftarrow> assigned_nodes element_ptr;
(if tag = ''slot'' \<and> assigned_nodes \<noteq> [] then
return (Some (element_ptr, assigned_nodes)) else return None)}) element_ptrs \<rightarrow>\<^sub>r tups"
(is "h \<turnstile> map_filter_M2 ?f element_ptrs \<rightarrow>\<^sub>r tups") and
h2: "h \<turnstile> forall_M (\<lambda>(slot, assigned_nodes). do {
get_child_nodes (cast slot) \<bind> forall_M remove;
forall_M (append_child (cast slot)) assigned_nodes
}) tups \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> shadow_root_ptr_kinds_M \<rightarrow>\<^sub>r shadow_root_ptrs" and
h': "h2 \<turnstile> forall_M (\<lambda>shadow_root_ptr. do {
host \<leftarrow> get_host shadow_root_ptr;
get_child_nodes (cast host) \<bind> forall_M remove;
get_child_nodes (cast shadow_root_ptr) \<bind> forall_M (append_child (cast host));
remove_shadow_root host
}) shadow_root_ptrs \<rightarrow>\<^sub>h h'"
using \<open>h \<turnstile> flatten_dom \<rightarrow>\<^sub>h h'\<close>
apply(auto simp add: flatten_dom_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF ElementMonad.ptr_kinds_M_pure, rotated]
bind_returns_heap_E2[rotated, OF ShadowRootMonad.ptr_kinds_M_pure, rotated])[1]
apply(drule pure_returns_heap_eq)
by(auto intro!: map_filter_M2_pure bind_pure_I)
have "heap_is_wellformed h2 \<and> known_ptrs h2 \<and> type_wf h2"
using h2 \<open>heap_is_wellformed h\<close> \<open>known_ptrs h\<close> \<open>type_wf h\<close>
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated,
OF get_child_nodes_pure, rotated]
elim!: forall_M_small_big[where P = "\<lambda>h. heap_is_wellformed h \<and> known_ptrs h \<and> type_wf h",
simplified]
intro: remove_preserves_known_ptrs remove_heap_is_wellformed_preserved
remove_preserves_type_wf
append_child_preserves_known_ptrs append_child_heap_is_wellformed_preserved
append_child_preserves_type_wf)
then
show "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
using h'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_host_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
dest!: forall_M_small_big[where P = "\<lambda>h. heap_is_wellformed h \<and> known_ptrs h \<and> type_wf h",
simplified]
intro: remove_preserves_known_ptrs remove_heap_is_wellformed_preserved
remove_preserves_type_wf
append_child_preserves_known_ptrs append_child_heap_is_wellformed_preserved
append_child_preserves_type_wf
remove_shadow_root_preserves
)
qed
end
interpretation i_assigned_nodes_wf?: l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr assigned_nodes assigned_nodes_flatten flatten_dom get_child_nodes get_child_nodes_locs
get_tag_name get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs find_slot
assigned_slot remove insert_before insert_before_locs append_child remove_shadow_root
remove_shadow_root_locs type_wf get_shadow_root get_shadow_root_locs set_shadow_root
set_shadow_root_locs get_parent get_parent_locs to_tree_order heap_is_wellformed parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs known_ptrs remove_child remove_child_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document get_disconnected_document_locs
by(auto simp add: l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_shadow\_root\_safe\<close>
locale l_get_shadow_root_safe_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host
get_host_locs +
l_type_wf type_wf +
l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root_safe get_shadow_root_safe_locs
get_shadow_root get_shadow_root_locs get_mode get_mode_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root ::
"(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root_safe ::
"(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_safe_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, shadow_root_mode) prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
end
subsubsection \<open>create\_element\<close>
locale l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name type_wf set_tag_name set_tag_name_locs +
l_create_element_defs create_element +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs +
l_new_element_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs
get_disconnected_nodes get_disconnected_nodes_locs +
l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf create_element known_ptr
type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr
get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_tag_name type_wf get_tag_name get_tag_name_locs set_tag_name set_tag_name_locs +
l_new_element_get_tag_name type_wf get_tag_name get_tag_name_locs +
l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes set_disconnected_nodes_locs
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes set_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs +
l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs +
l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_disconnected_nodes_get_disconnected_nodes type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs +
l_new_element_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_set_tag_name_get_shadow_root type_wf set_tag_name set_tag_name_locs get_shadow_root
get_shadow_root_locs +
l_new_element type_wf +
l_known_ptrs known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma create_element_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF CD.get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I CD.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
by(simp add: element_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have tag_name_eq_h:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2 get_tag_name_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by(blast)+
then have tag_name_eq2_h: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_empty_tag_name
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_tag_name_writes h3])
by (metis local.set_tag_name_get_tag_name_different_pointers)
then have tag_name_eq2_h2: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_empty_tag_name
by blast
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_tag_name_writes h3])
by (metis local.set_tag_name_get_tag_name_different_pointers)
then have tag_name_eq2_h2: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_disconnected_nodes_writes h'])
using set_disconnected_nodes_get_tag_name
by blast
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
apply (metis \<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1)
assms(3) funion_iff CD.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child_in_heap CD.parent_child_rel_child_nodes2 node_ptr_kinds_commutes
node_ptr_kinds_eq_h returns_result_select_result)
by (metis (no_types, lifting) CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> assms(3) assms(4)
children_eq_h disconnected_nodes_eq2_h document_ptr_kinds_eq_h finite_set_in is_OK_returns_result_I
local.known_ptrs_known_ptr node_ptr_kinds_commutes returns_result_select_result subsetD)
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (smt (verit) children_eq2_h3 disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3 finite_set_in finsertCI funion_finsert_right
h' insert_iff list.simps(15) local.CD.a_all_ptrs_in_heap_def
local.set_disconnected_nodes_get_disconnected_nodes node_ptr_kinds_eq_h node_ptr_kinds_eq_h2
node_ptr_kinds_eq_h3 object_ptr_kinds_eq_h3 select_result_I2 subsetD subsetI)
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_element_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M CD.a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem CD.get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_element_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_element_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_element_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: CD.heap_is_wellformed_def heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_element_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff CD.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open> CD.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
then have " CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)
then have " CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3
intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h'
set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set disc_nodes_h3\<close>
\<open> CD.a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
CD.distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
by (smt (verit) NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r
new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> \<open>local.CD.a_all_ptrs_in_heap h\<close>
disc_nodes_document_ptr_h disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 disjoint_iff document_ptr_kinds_eq_h document_ptr_kinds_eq_h2
finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.CD.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply -
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3
\<Longrightarrow> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open> CD.a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 CD.distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open> CD.a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: CD.a_owner_document_valid_def)[1]
apply(auto simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )[1]
apply(auto simp add: object_ptr_kinds_eq_h2)[1]
apply(auto simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )[1]
apply(auto simp add: document_ptr_kinds_eq_h2)[1]
apply(auto simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )[1]
apply(auto simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )[1]
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by(metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> children_eq2_h children_eq2_h2
children_eq2_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_eq_h finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
node_ptr_kinds_commutes select_result_I2)
have "CD.a_heap_is_wellformed h'"
using \<open>CD.a_acyclic_heap h'\<close> \<open>CD.a_all_ptrs_in_heap h'\<close> \<open>CD.a_distinct_lists h'\<close>
\<open>CD.a_owner_document_valid h'\<close>
by(simp add: CD.a_heap_is_wellformed_def)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_eq_h: "\<And>element_ptr shadow_root_opt. element_ptr \<noteq> new_element_ptr
\<Longrightarrow> h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt"
proof -
fix element_ptr shadow_root_opt
assume "element_ptr \<noteq> new_element_ptr "
have "\<forall>P \<in> get_shadow_root_locs element_ptr. P h h2"
using get_shadow_root_new_element new_element_ptr h2
using \<open>element_ptr \<noteq> new_element_ptr\<close> by blast
then
have "preserved (get_shadow_root element_ptr) h h2"
using get_shadow_root_new_element[rotated, OF new_element_ptr h2]
using get_shadow_root_reads
by(simp add: reads_def)
then show "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt"
by (simp add: preserved_def)
qed
have shadow_root_none: "h2 \<turnstile> get_shadow_root (new_element_ptr) \<rightarrow>\<^sub>r None"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_shadow_root
by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
using set_disconnected_nodes_get_shadow_root
by(auto simp add: set_disconnected_nodes_get_shadow_root)
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h shadow_root_none by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
by (simp add: shadow_root_eq_h3)
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
apply(case_tac "x = new_element_ptr")
using shadow_root_none apply auto[1]
using shadow_root_eq_h
by (smt (verit) Diff_empty Diff_insert0 ElementMonad.ptr_kinds_M_ptr_kinds
ElementMonad.ptr_kinds_ptr_kinds_M assms(1) assms(3) finite_set_in h2 insort_split
local.get_shadow_root_ok local.shadow_root_same_host new_element_ptr new_element_ptr_not_in_heap
option.distinct(1) returns_result_select_result select_result_I2 shadow_root_none)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3 select_result_eq[OF shadow_root_eq_h3])
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h2"
proof (unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h2)"
obtain previous_host where
"previous_host \<in> fset (element_ptr_kinds h)" and
"|h \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
by (metis \<open>local.a_shadow_root_valid h\<close> \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h2)\<close>
local.a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h)
moreover have "previous_host \<noteq> new_element_ptr"
using calculation(1) h2 new_element_ptr new_element_ptr_not_in_heap by auto
ultimately have "|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
using shadow_root_eq_h
apply (simp add: tag_name_eq2_h)
by (metis \<open>previous_host \<noteq> new_element_ptr\<close>
\<open>|h \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr\<close>
select_result_eq shadow_root_eq_h)
then
show "\<exists>host\<in>fset (element_ptr_kinds h2).
|h2 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h2 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
by (meson \<open>previous_host \<in> fset (element_ptr_kinds h)\<close> \<open>previous_host \<noteq> new_element_ptr\<close>
assms(3) local.get_shadow_root_ok local.get_shadow_root_ptr_in_heap notin_fset
returns_result_select_result shadow_root_eq_h)
qed
then have "a_shadow_root_valid h3"
proof (unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h2). \<exists>host\<in>fset (element_ptr_kinds h2).
|h2 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h2 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h3)"
obtain previous_host where
"previous_host \<in> fset (element_ptr_kinds h2)" and
"|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
by (metis \<open>local.a_shadow_root_valid h2\<close> \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h3)\<close>
local.a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h2)
moreover have "previous_host \<noteq> new_element_ptr"
using calculation(1) h3 new_element_ptr new_element_ptr_not_in_heap
using calculation(3) shadow_root_none by auto
ultimately have "|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
using shadow_root_eq_h2
apply (simp add: tag_name_eq2_h2)
by (metis \<open>previous_host \<noteq> new_element_ptr\<close>
\<open>|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr\<close> select_result_eq
shadow_root_eq_h)
then
show "\<exists>host\<in>fset (element_ptr_kinds h3).
|h3 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h3 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
by (metis \<open>previous_host \<in> fset (element_ptr_kinds h2)\<close> \<open>previous_host \<noteq> new_element_ptr\<close>
element_ptr_kinds_eq_h2 select_result_eq shadow_root_eq_h2 tag_name_eq2_h2)
qed
then have "a_shadow_root_valid h'"
by (smt (verit) \<open>type_wf h3\<close> element_ptr_kinds_eq_h3 finite_set_in local.a_shadow_root_valid_def
local.get_shadow_root_ok returns_result_select_result select_result_I2 shadow_root_eq_h3
shadow_root_ptr_kinds_eq_h3 tag_name_eq2_h3)
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h shadow_root_eq_h)[1]
apply (smt (verit, del_insts) assms(3) case_prodI h2 local.get_shadow_root_ok mem_Collect_eq
new_element_ptr new_element_ptr_not_in_heap pair_imageI returns_result_select_result
select_result_I2 shadow_root_eq_h)
using shadow_root_none apply auto[1]
by (metis (no_types, lifting) assms(3) h2 host_shadow_root_rel_def
host_shadow_root_rel_shadow_root local.a_host_shadow_root_rel_def local.get_shadow_root_impl
local.get_shadow_root_ok local.new_element_no_shadow_root new_element_ptr option.distinct(1)
returns_result_select_result select_result_I2 shadow_root_eq_h)
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq_h2)[1]
apply (metis (mono_tags, lifting) \<open>type_wf h2\<close> case_prodI local.get_shadow_root_ok
mem_Collect_eq pair_imageI returns_result_select_result select_result_I2 shadow_root_eq_h2)
apply (metis (mono_tags, lifting) case_prodI mem_Collect_eq pair_imageI select_result_eq shadow_root_eq_h2)
done
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq_h2)[1]
apply (metis (mono_tags, lifting) \<open>type_wf h'\<close> case_prodI element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3 local.get_shadow_root_ok mem_Collect_eq pair_imageI
returns_result_select_result select_result_I2 shadow_root_eq_h3)
apply (metis (mono_tags, lifting) \<open>type_wf h'\<close> case_prodI element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3 local.get_shadow_root_ok mem_Collect_eq pair_imageI
returns_result_select_result select_result_I2 shadow_root_eq_h3)
done
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>parent_child_rel h = parent_child_rel h2\<close> by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h3 = local.a_host_shadow_root_rel h'\<close>
\<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h =
parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2\<close>
\<open>parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 =
parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3\<close>
by auto
then have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3\<close>)
show " heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl
\<open>local.CD.a_heap_is_wellformed h'\<close> \<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close>
\<open>local.a_shadow_root_valid h'\<close>)
qed
end
interpretation i_create_element_wf?: l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel set_tag_name set_tag_name_locs set_disconnected_nodes
set_disconnected_nodes_locs create_element get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs DocumentClass.known_ptr DocumentClass.type_wf
by(auto simp add: l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_character\_data\<close>
locale l_create_character_data_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs +
l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs set_val set_val_locs create_character_data
known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_new_character_data_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_val_get_disconnected_nodes
type_wf set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_new_character_data_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_set_val_get_child_nodes
type_wf set_val set_val_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes_get_child_nodes
set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes
type_wf set_disconnected_nodes set_disconnected_nodes_locs
+ l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_set_val_get_shadow_root type_wf set_val set_val_locs get_shadow_root get_shadow_root_locs
+ l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes set_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs
+ l_new_character_data_get_tag_name
get_tag_name get_tag_name_locs
+ l_set_val_get_tag_name type_wf set_val set_val_locs get_tag_name get_tag_name_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs
+ l_new_character_data
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma create_character_data_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: CD.create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF CD.get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: CD.create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.CD.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF CD.set_val_writes h3])
using CD.set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_character_data_ptr)"
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
local.create_character_data_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2
get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF CD.set_val_writes h3])
using CD.set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h2: "character_data_ptr_kinds h3 = character_data_ptr_kinds h2"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
using node_ptr_kinds_eq_h2
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h3: "character_data_ptr_kinds h' = character_data_ptr_kinds h3"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
using node_ptr_kinds_eq_h3
by(simp add: element_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2
get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2
get_tag_name_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_tag_name)
then have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF CD.set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_tag_name)
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>parent_child_rel h = parent_child_rel h2\<close>
children_eq2_h finite_set_in finsert_iff funion_finsert_right CD.parent_child_rel_child
CD.parent_child_rel_parent_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq_h
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> assms(3) assms(4)
children_eq_h disconnected_nodes_eq2_h document_ptr_kinds_eq_h finite_set_in
is_OK_returns_result_I local.known_ptrs_known_ptr node_ptr_kinds_commutes
returns_result_select_result subset_code(1))
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (smt (verit) children_eq2_h3 disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3 finite_set_in finsertCI funion_finsert_right
h' local.CD.a_all_ptrs_in_heap_def local.set_disconnected_nodes_get_disconnected_nodes
node_ptr_kinds_eq_h node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3 object_ptr_kinds_eq_h3
select_result_I2 set_ConsD subsetD subsetI)
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_character_data_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M CD.a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem CD.get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow>
cast new_character_data_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow>
cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_character_data_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_character_data_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_character_data_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff CD.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr
returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
thm children_eq2_h
using \<open>CD.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result
by metis
then have "CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h'
set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, opaque_lifting)
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set disc_nodes_h3\<close> \<open>type_wf h2\<close> assms(1)
disc_nodes_document_ptr_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disconnected_nodes_eq_h distinct.simps(2) document_ptr_kinds_eq_h2 local.get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct returns_result_select_result select_result_I2)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
using NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
by (smt (verit) \<open>local.CD.a_all_ptrs_in_heap h\<close> disc_nodes_document_ptr_h
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 disjoint_iff
document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.CD.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply(cases "document_ptr = xb")
apply (metis (no_types, lifting) "3" "4" "5" "6" CD.distinct_lists_no_parent
\<open>local.CD.a_distinct_lists h2\<close> \<open>type_wf h'\<close> children_eq2_h2 children_eq2_h3
disc_nodes_document_ptr_h2 document_ptr_kinds_eq_h3 h' local.get_disconnected_nodes_ok
local.set_disconnected_nodes_get_disconnected_nodes new_character_data_ptr_not_in_any_children
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 returns_result_eq returns_result_select_result
set_ConsD)
by (metis "3" "4" "5" "6" CD.distinct_lists_no_parent \<open>local.CD.a_distinct_lists h3\<close>
\<open>type_wf h3\<close> children_eq2_h3 local.get_disconnected_nodes_ok returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(simp add: CD.a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by (metis (mono_tags, lifting)
\<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
children_eq2_h disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h'
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
object_ptr_kinds_M_def
select_result_I2)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_eq_h:
"\<And>character_data_ptr shadow_root_opt. h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads h2 get_shadow_root_new_character_data[rotated, OF h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_character_data_ptr apply blast
using local.get_shadow_root_locs_impl new_character_data_ptr by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
using set_disconnected_nodes_get_shadow_root
by(auto simp add: set_disconnected_nodes_get_shadow_root)
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
by (simp add: shadow_root_eq_h3)
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h2\<close> assms(1) assms(3) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3
select_result_eq[OF shadow_root_eq_h3])
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h2"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h element_ptr_kinds_eq_h
select_result_eq[OF shadow_root_eq_h] tag_name_eq2_h)
then have "a_shadow_root_valid h3"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h2 element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2] tag_name_eq2_h2)
then have "a_shadow_root_valid h'"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h3 element_ptr_kinds_eq_h3
select_result_eq[OF shadow_root_eq_h3] tag_name_eq2_h3)
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h
select_result_eq[OF shadow_root_eq_h])
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2])
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3
select_result_eq[OF shadow_root_eq_h3])
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>parent_child_rel h = parent_child_rel h2\<close> by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h3 = local.a_host_shadow_root_rel h'\<close>
\<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h = parent_child_rel h2 \<union>
local.a_host_shadow_root_rel h2\<close> \<open>parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 =
parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3\<close> by auto
then have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3\<close>)
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close>
\<open>local.CD.a_distinct_lists h'\<close> \<open>local.CD.a_owner_document_valid h'\<close>)
show "heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl
\<open>local.CD.a_heap_is_wellformed h'\<close> \<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close>
\<open>local.a_shadow_root_valid h'\<close>)
qed
end
subsubsection \<open>create\_document\<close>
locale l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs
+ l_new_document_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
create_document
+ l_new_document_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_new_document_get_tag_name get_tag_name get_tag_name_locs
+ l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs
+ l_new_document
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes ::
"(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_document :: "((_) heap, exception, (_) document_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_document_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'"
proof -
obtain new_document_ptr where
new_document_ptr: "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr" and
h': "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
using assms(2)
apply(simp add: create_document_def)
using new_document_ok by blast
have "new_document_ptr \<notin> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have "new_document_ptr |\<notin>| document_ptr_kinds h"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr |\<notin>| object_ptr_kinds h"
by simp
have object_ptr_kinds_eq: "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using new_document_new_ptr h' new_document_ptr by blast
then have node_ptr_kinds_eq: "node_ptr_kinds h' = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h' = character_data_ptr_kinds h"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h' = element_ptr_kinds h"
using object_ptr_kinds_eq
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h' = document_ptr_kinds h |\<union>| {|new_document_ptr|}"
using object_ptr_kinds_eq
apply(auto simp add: document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_kinds_commutes document_ptr_kinds_def finsertI1
fset.map_comp)
have shadow_root_ptr_kinds_eq: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h"
using object_ptr_kinds_eq
apply(simp add: shadow_root_ptr_kinds_def)
by force
have children_eq:
"\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h' get_child_nodes_new_document[rotated, OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2: "\<And>ptr'. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
using new_document_ptr h' new_document_ptr_in_heap[OF h' new_document_ptr]
new_document_is_document_ptr[OF new_document_ptr] new_document_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h' get_disconnected_nodes_new_document_different_pointers
new_document_ptr
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis(full_types) \<open>\<And>thesis. (\<And>new_document_ptr.
\<lbrakk>h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr; h \<turnstile> new_document \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
local.get_disconnected_nodes_new_document_different_pointers new_document_ptr)+
then have disconnected_nodes_eq2_h: "\<And>doc_ptr. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
using h' local.new_document_no_disconnected_nodes new_document_ptr by blast
have "type_wf h'"
using \<open>type_wf h\<close> new_document_types_preserved h' by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h'"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h'"
by (simp add: object_ptr_kinds_eq)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 empty_iff empty_set image_eqI select_result_I2)
qed
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def )
then have "CD.a_all_ptrs_in_heap h'"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> assms(1) children_eq fset_of_list_elem
local.heap_is_wellformed_children_in_heap CD.parent_child_rel_child
CD.parent_child_rel_parent_in_heap node_ptr_kinds_eq
apply (metis (no_types, lifting)
\<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 finite_set_in finsert_iff funion_finsert_right object_ptr_kinds_eq
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close> \<open>type_wf h'\<close>
assms(1) disconnected_nodes_eq_h empty_iff empty_set local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq returns_result_select_result
select_result_I2)
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h'"
using \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: children_eq2[symmetric] CD.a_distinct_lists_def insort_split
object_ptr_kinds_eq
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(auto simp add: dest: distinct_concat_map_E)[1]
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close>
apply(auto simp add: distinct_insort dest: distinct_concat_map_E)[1]
apply (metis assms(1) assms(3) disconnected_nodes_eq2_h get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct
returns_result_select_result)
proof -
fix x :: "(_) document_ptr" and y :: "(_) document_ptr" and xa :: "(_) node_ptr"
assume a1: "x \<noteq> y"
assume a2: "x |\<in>| document_ptr_kinds h"
assume a3: "x \<noteq> new_document_ptr"
assume a4: "y |\<in>| document_ptr_kinds h"
assume a5: "y \<noteq> new_document_ptr"
assume a6: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
assume a7: "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a8: "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
have f9: "xa \<in> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a7 a3 disconnected_nodes_eq2_h by presburger
have f10: "xa \<in> set |h \<turnstile> get_disconnected_nodes y|\<^sub>r"
using a8 a5 disconnected_nodes_eq2_h by presburger
have f11: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a4 by simp
have "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a2 by simp
then show False
using f11 f10 f9 a6 a1 by (meson disjoint_iff_not_equal distinct_concat_map_E(1))
next
fix x xa xb
assume 0: "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
and 1: "h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []"
and 2: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
and 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
and 4: "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h). set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 5: "x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
and 7: "xa |\<in>| object_ptr_kinds h"
and 8: "xa \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr"
and 9: "xb |\<in>| document_ptr_kinds h"
and 10: "xb \<noteq> new_document_ptr"
then show "False"
by (metis \<open>CD.a_distinct_lists h\<close> assms(3) disconnected_nodes_eq2_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok
returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def)[1]
by (metis \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
children_eq2 disconnected_nodes_eq2_h document_ptr_kinds_commutes finite_set_in funion_iff
node_ptr_kinds_eq object_ptr_kinds_eq)
have shadow_root_eq_h: "\<And>character_data_ptr shadow_root_opt.
h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h' \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads assms(2) get_shadow_root_new_document[rotated, OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_document_ptr apply blast
using local.get_shadow_root_locs_impl new_document_ptr by blast
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq document_ptr_kinds_eq_h)[1]
using shadow_root_eq_h by fastforce
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h'\<close> assms(1) assms(3) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h'
get_tag_name_new_document[OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h'"
using new_document_is_document_ptr[OF new_document_ptr]
by(auto simp add: a_shadow_root_valid_def element_ptr_kinds_eq_h document_ptr_kinds_eq_h
shadow_root_ptr_kinds_eq select_result_eq[OF shadow_root_eq_h] select_result_eq[OF tag_name_eq_h])
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h
select_result_eq[OF shadow_root_eq_h])
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
moreover
have "parent_child_rel h \<union> a_host_shadow_root_rel h =
parent_child_rel h' \<union> a_host_shadow_root_rel h'"
by (simp add: \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h'\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close>)
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
by simp
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close>
\<open>local.CD.a_distinct_lists h'\<close> \<open>local.CD.a_owner_document_valid h'\<close>)
show "heap_is_wellformed h'"
using CD.heap_is_wellformed_impl \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h')\<close>
\<open>local.CD.a_heap_is_wellformed h'\<close> \<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close>
\<open>local.a_shadow_root_valid h'\<close> local.heap_is_wellformed_def by auto
qed
end
interpretation l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf DocumentClass.type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs heap_is_wellformed parent_child_rel set_val set_val_locs
set_disconnected_nodes set_disconnected_nodes_locs create_document known_ptrs
by(auto simp add: l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
subsubsection \<open>attach\_shadow\_root\<close>
locale l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs
+ l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs
+ l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr set_shadow_root set_shadow_root_locs set_mode
set_mode_locs attach_shadow_root type_wf get_tag_name get_tag_name_locs get_shadow_root
get_shadow_root_locs
+ l_new_shadow_root_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_mode_get_disconnected_nodes
type_wf set_mode set_mode_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_new_shadow_root_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_new_shadow_root_get_tag_name
type_wf get_tag_name get_tag_name_locs
+ l_set_mode_get_child_nodes
type_wf set_mode set_mode_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_shadow_root_get_child_nodes
type_wf set_shadow_root set_shadow_root_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_shadow_root
type_wf set_shadow_root set_shadow_root_locs
+ l_set_shadow_root_get_disconnected_nodes
set_shadow_root set_shadow_root_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_mode_get_shadow_root type_wf set_mode set_mode_locs get_shadow_root get_shadow_root_locs
+ l_set_shadow_root_get_shadow_root type_wf set_shadow_root set_shadow_root_locs
get_shadow_root get_shadow_root_locs
+ l_new_character_data_get_tag_name
get_tag_name get_tag_name_locs
+ l_set_mode_get_tag_name type_wf set_mode set_mode_locs get_tag_name get_tag_name_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_set_shadow_root_get_tag_name set_shadow_root set_shadow_root_locs get_tag_name get_tag_name_locs
+ l_new_shadow_root
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set"
and attach_shadow_root :: "(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
begin
lemma attach_shadow_root_child_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>h h'"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain h2 h3 new_shadow_root_ptr element_tag_name where
element_tag_name: "h \<turnstile> get_tag_name element_ptr \<rightarrow>\<^sub>r element_tag_name" and
"element_tag_name \<in> safe_shadow_root_element_types" and
prev_shadow_root: "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r None" and
h2: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2" and
new_shadow_root_ptr: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr" and
h3: "h2 \<turnstile> set_mode new_shadow_root_ptr new_mode \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: attach_shadow_root_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
have "h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr"
thm bind_pure_returns_result_I[OF get_tag_name_pure]
apply(unfold attach_shadow_root_def)[1]
using element_tag_name
apply(rule bind_pure_returns_result_I[OF get_tag_name_pure])
apply(rule bind_pure_returns_result_I)
using \<open>element_tag_name \<in> safe_shadow_root_element_types\<close> apply(simp)
using \<open>element_tag_name \<in> safe_shadow_root_element_types\<close> apply(simp)
using prev_shadow_root
apply(rule bind_pure_returns_result_I[OF get_shadow_root_pure])
apply(rule bind_pure_returns_result_I)
apply(simp)
apply(simp)
using h2 new_shadow_root_ptr h3 h'
by(auto intro!: bind_returns_result_I
intro: is_OK_returns_result_E[OF is_OK_returns_heap_I[OF h3]]
is_OK_returns_result_E[OF is_OK_returns_heap_I[OF h']])
have "new_shadow_root_ptr \<notin> set |h \<turnstile> shadow_root_ptr_kinds_M|\<^sub>r"
using new_shadow_root_ptr ShadowRootMonad.ptr_kinds_ptr_kinds_M h2
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap by blast
then have "cast new_shadow_root_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr h2 new_shadow_root_ptr by blast
then have document_ptr_kinds_eq_h:
"document_ptr_kinds h2 = document_ptr_kinds h"
apply(simp add: document_ptr_kinds_def)
by force
have shadow_root_ptr_kinds_eq_h:
"shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h |\<union>| {|new_shadow_root_ptr|}"
using object_ptr_kinds_eq_h
apply(simp add: shadow_root_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_mode_writes h3])
using set_mode_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by (auto simp add: shadow_root_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_shadow_root_writes h'])
using set_shadow_root_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by (auto simp add: shadow_root_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_shadow_root_ptr)"
using \<open>h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr\<close>
create_shadow_root_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "element_ptr |\<in>| element_ptr_kinds h"
by (meson \<open>h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr\<close>
is_OK_returns_result_I local.attach_shadow_root_element_ptr_in_heap)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_shadow_root[rotated, OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_new_ptr h2 new_shadow_root_ptr object_ptr_kinds_eq_h by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h"
apply(simp add: character_data_ptr_kinds_def)
done
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_mode_writes h3])
using set_mode_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h2: "character_data_ptr_kinds h3 = character_data_ptr_kinds h2"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
using node_ptr_kinds_eq_h2
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_shadow_root_writes h'])
using set_shadow_root_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h3: "character_data_ptr_kinds h' = character_data_ptr_kinds h3"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
using node_ptr_kinds_eq_h3
by(simp add: element_ptr_kinds_def)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_shadow_root[rotated, OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
using h2 local.new_shadow_root_no_child_nodes new_shadow_root_ptr by auto
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_shadow_root[rotated, OF h2,rotated,OF new_shadow_root_ptr]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis (no_types, lifting))+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2
get_tag_name_new_shadow_root[OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_tag_name)
then have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_shadow_root_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_mode_writes h3]
using set_mode_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_shadow_root_writes h']
using set_shadow_root_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_disconnected_nodes)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_tag_name)
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_shadow_root_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h
\<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) CD.get_child_nodes_ok CD.l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
\<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1) assms(2)
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child local.known_ptrs_known_ptr
local.parent_child_rel_child_in_heap node_ptr_kinds_commutes returns_result_select_result)
by (metis assms(1) assms(2) disconnected_nodes_eq2_h document_ptr_kinds_eq_h
local.get_disconnected_nodes_ok local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h
returns_result_select_result)
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (simp add: children_eq2_h3 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h3 object_ptr_kinds_eq_h3)
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> children_eq2_h
apply(auto simp add: select_result_eq[OF disconnected_nodes_eq_h] CD.a_distinct_lists_def
insort_split object_ptr_kinds_eq_h
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I
dest: distinct_concat_map_E)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(case_tac "x = cast new_shadow_root_ptr")
using \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> children_eq2_h apply blast
apply(case_tac "y = cast new_shadow_root_ptr")
using \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> children_eq2_h apply blast
proof -
fix x y :: "(_) object_ptr"
fix xa :: "(_) node_ptr"
assume a1: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
assume "x \<noteq> y"
assume "xa \<in> set |h2 \<turnstile> get_child_nodes x|\<^sub>r"
assume "xa \<in> set |h2 \<turnstile> get_child_nodes y|\<^sub>r"
assume "x |\<in>| object_ptr_kinds h"
assume "x \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr"
assume "y |\<in>| object_ptr_kinds h"
assume "y \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr"
show False
using distinct_concat_map_E(1)[OF a1, of x y]
using \<open>x |\<in>| object_ptr_kinds h\<close> \<open>y |\<in>| object_ptr_kinds h\<close>
using \<open>xa \<in> set |h2 \<turnstile> get_child_nodes x|\<^sub>r\<close> \<open>xa \<in> set |h2 \<turnstile> get_child_nodes y|\<^sub>r\<close>
using \<open>x \<noteq> y\<close>
by(auto simp add: children_eq2_h[OF \<open>x \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr\<close>]
children_eq2_h[OF \<open>y \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr\<close>])
next
fix x :: "(_) node_ptr"
fix xa :: "(_) object_ptr"
fix xb :: "(_) document_ptr"
assume "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
assume "x \<in> set |h2 \<turnstile> get_child_nodes xa|\<^sub>r"
assume "xb |\<in>| document_ptr_kinds h"
assume "x \<in> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume "xa |\<in>| object_ptr_kinds h"
assume "xa \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr"
have "set |h \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
by (metis (no_types, lifting) CD.get_child_nodes_ok \<open>xa |\<in>| object_ptr_kinds h\<close>
\<open>xb |\<in>| document_ptr_kinds h\<close> assms(1) assms(2) assms(3) disconnected_nodes_eq2_h
is_OK_returns_result_E local.get_disconnected_nodes_ok
local.heap_is_wellformed_children_disc_nodes_different local.known_ptrs_known_ptr select_result_I2)
then
show "False"
using \<open>x \<in> set |h2 \<turnstile> get_child_nodes xa|\<^sub>r\<close> \<open>x \<in> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close>
\<open>xa \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr\<close> children_eq2_h by auto
qed
then have "CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "CD.a_distinct_lists h'"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
(* using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close> *)
apply(simp add: CD.a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
by (metis CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> assms(2) assms(3)
children_eq2_h children_eq_h document_ptr_kinds_eq_h finite_set_in is_OK_returns_result_I
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.known_ptrs_known_ptr object_ptr_kinds_M_def
returns_result_select_result)
have shadow_root_eq_h:
"\<And>character_data_ptr shadow_root_opt. h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads h2 get_shadow_root_new_shadow_root[rotated, OF h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_shadow_root_ptr apply blast
using local.get_shadow_root_locs_impl new_shadow_root_ptr by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. element_ptr \<noteq> ptr' \<Longrightarrow> h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_shadow_root_different_pointers)
have shadow_root_h3: "h' \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r Some new_shadow_root_ptr"
using \<open>type_wf h3\<close> h' local.set_shadow_root_get_shadow_root by blast
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
apply(case_tac "shadow_root_ptr = new_shadow_root_ptr")
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap new_shadow_root_ptr shadow_root_ptr_kinds_eq_h2 apply blast
using \<open>type_wf h3\<close> h' local.set_shadow_root_get_shadow_root returns_result_eq shadow_root_eq_h3
apply fastforce
done
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h2\<close> assms(1) assms(2) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3
select_result_eq[OF shadow_root_eq_h3])[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (smt (verit, best) ShadowRootMonad.ptr_kinds_ptr_kinds_M \<open>new_shadow_root_ptr \<notin> set |h \<turnstile>
shadow_root_ptr_kinds_M|\<^sub>r\<close> \<open>type_wf h'\<close> assms(1) assms(2) element_ptr_kinds_eq_h3
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.shadow_root_same_host local.get_shadow_root_ok
local.get_shadow_root_shadow_root_ptr_in_heap
local.l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms returns_result_select_result
select_result_I2 shadow_root_eq_h shadow_root_eq_h2 shadow_root_eq_h3 shadow_root_h3)
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then
have "a_shadow_root_valid h'"
proof(unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "a_shadow_root_valid h"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h')"
show "\<exists>host\<in>fset (element_ptr_kinds h').
|h' \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h' \<turnstile> get_shadow_root host|\<^sub>r =
Some shadow_root_ptr"
proof (cases "shadow_root_ptr = new_shadow_root_ptr")
case True
have "element_ptr \<in> fset (element_ptr_kinds h')"
by (simp add: \<open>element_ptr |\<in>| element_ptr_kinds h\<close> element_ptr_kinds_eq_h
element_ptr_kinds_eq_h2 element_ptr_kinds_eq_h3)
moreover have "|h' \<turnstile> get_tag_name element_ptr|\<^sub>r \<in> safe_shadow_root_element_types"
by (smt (verit, best) \<open>\<And>thesis. (\<And>h2 h3 new_shadow_root_ptr element_tag_name. \<lbrakk>h \<turnstile>
get_tag_name element_ptr \<rightarrow>\<^sub>r element_tag_name; element_tag_name \<in>
safe_shadow_root_element_types; h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r None; h \<turnstile>
new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2; h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr; h2
\<turnstile> set_mode new_shadow_root_ptr new_mode \<rightarrow>\<^sub>h h3; h3 \<turnstile> set_shadow_root element_ptr (Some
new_shadow_root_ptr) \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> select_result_I2 tag_name_eq2_h2
tag_name_eq2_h3 tag_name_eq_h)
moreover have "|h' \<turnstile> get_shadow_root element_ptr|\<^sub>r = Some shadow_root_ptr"
using shadow_root_h3
by (simp add: True)
ultimately
show ?thesis
by meson
next
case False
then obtain host where host: "host \<in> fset (element_ptr_kinds h)" and
"|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
using \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h')\<close>
using \<open>\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr\<close>
apply(simp add: shadow_root_ptr_kinds_eq_h3 shadow_root_ptr_kinds_eq_h2
shadow_root_ptr_kinds_eq_h)
by (meson finite_set_in)
moreover have "host \<noteq> element_ptr"
using calculation(3) prev_shadow_root by auto
ultimately show ?thesis
using element_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2 element_ptr_kinds_eq_h
by (metis (no_types, lifting) assms(2)
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_shadow_root_ok
local.l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms notin_fset returns_result_select_result
select_result_I2 shadow_root_eq_h shadow_root_eq_h2 shadow_root_eq_h3 tag_name_eq2_h
tag_name_eq2_h2 tag_name_eq2_h3)
qed
qed
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h
select_result_eq[OF shadow_root_eq_h])
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2])
have "a_host_shadow_root_rel h' = {(cast element_ptr, cast new_shadow_root_ptr)} \<union>
a_host_shadow_root_rel h3"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3 )[1]
apply(case_tac "element_ptr \<noteq> aa")
using select_result_eq[OF shadow_root_eq_h3] apply (simp add: image_iff)
using select_result_eq[OF shadow_root_eq_h3]
apply (metis (no_types, lifting)
\<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close> \<open>type_wf h3\<close>
host_shadow_root_rel_def local.get_shadow_root_impl local.get_shadow_root_ok
option.distinct(1) prev_shadow_root returns_result_select_result)
apply (metis (mono_tags, lifting) \<open>\<And>ptr'. (\<And>x. element_ptr \<noteq> ptr') \<Longrightarrow>
|h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r\<close> case_prod_conv image_iff
is_OK_returns_result_I mem_Collect_eq option.inject returns_result_eq
returns_result_select_result shadow_root_h3)
using element_ptr_kinds_eq_h3 local.get_shadow_root_ptr_in_heap shadow_root_h3 apply fastforce
using Shadow_DOM.a_host_shadow_root_rel_def \<open>\<And>ptr'. (\<And>x. element_ptr \<noteq> ptr') \<Longrightarrow>
|h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r\<close> \<open>type_wf h3\<close> case_prodE case_prodI
host_shadow_root_rel_shadow_root image_iff local.get_shadow_root_impl local.get_shadow_root_ok
mem_Collect_eq option.discI prev_shadow_root returns_result_select_result select_result_I2
shadow_root_eq_h shadow_root_eq_h2
by (smt (verit))
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>parent_child_rel h = parent_child_rel h2\<close> by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' =
{(cast element_ptr, cast new_shadow_root_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h' =
{(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr, cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr)} \<union>
local.a_host_shadow_root_rel h3\<close> \<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "\<And>a b. (a, b) \<in> parent_child_rel h3 \<Longrightarrow> a \<noteq> cast new_shadow_root_ptr"
using CD.parent_child_rel_parent_in_heap \<open>parent_child_rel h = parent_child_rel h2\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> document_ptr_kinds_commutes
by (metis h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap new_shadow_root_ptr shadow_root_ptr_kinds_commutes)
moreover
have "\<And>a b. (a, b) \<in> a_host_shadow_root_rel h3 \<Longrightarrow> a \<noteq> cast new_shadow_root_ptr"
using shadow_root_eq_h2
by(auto simp add: a_host_shadow_root_rel_def)
moreover
have "cast new_shadow_root_ptr \<notin> {x. (x, cast element_ptr) \<in> (parent_child_rel h3 \<union>
a_host_shadow_root_rel h3)\<^sup>*}"
by (metis (no_types, lifting) UnE calculation(1) calculation(2)
cast_shadow_root_ptr_not_node_ptr(1) converse_rtranclE mem_Collect_eq)
moreover
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h =
parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2\<close> \<open>parent_child_rel h2 \<union>
local.a_host_shadow_root_rel h2 = parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3\<close>
by auto
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' =
{(cast element_ptr, cast new_shadow_root_ptr)} \<union> parent_child_rel h3 \<union>
a_host_shadow_root_rel h3\<close>)
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close>
\<open>local.CD.a_distinct_lists h'\<close> \<open>local.CD.a_owner_document_valid h'\<close>)
show "heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl \<open>local.CD.a_heap_is_wellformed h'\<close>
\<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close> \<open>local.a_shadow_root_valid h'\<close>)
qed
end
interpretation l_attach_shadow_root_wf?: l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel set_tag_name set_tag_name_locs set_disconnected_nodes
set_disconnected_nodes_locs create_element get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs set_val set_val_locs create_character_data DocumentClass.known_ptr
DocumentClass.type_wf set_shadow_root set_shadow_root_locs set_mode set_mode_locs attach_shadow_root
by(auto simp add: l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/Shadow_DOM/monads/ShadowRootMonad.thy b/thys/Shadow_DOM/monads/ShadowRootMonad.thy
--- a/thys/Shadow_DOM/monads/ShadowRootMonad.thy
+++ b/thys/Shadow_DOM/monads/ShadowRootMonad.thy
@@ -1,711 +1,711 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>Shadow Root Monad\<close>
theory ShadowRootMonad
imports
"Core_DOM.DocumentMonad"
"../classes/ShadowRootClass"
begin
type_synonym ('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'ShadowRoot, 'result) dom_prog
= "((_) heap, exception, 'result) prog"
register_default_tvars "('object_ptr, 'node_ptr, 'element_ptr, 'character_data_ptr, 'document_ptr,
'shadow_root_ptr, 'Object, 'Node, 'Element, 'CharacterData, 'Document, 'ShadowRoot, 'result) dom_prog"
global_interpretation l_ptr_kinds_M shadow_root_ptr_kinds defines shadow_root_ptr_kinds_M = a_ptr_kinds_M .
lemmas shadow_root_ptr_kinds_M_defs = a_ptr_kinds_M_def
lemma shadow_root_ptr_kinds_M_eq:
assumes "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
shows "|h \<turnstile> shadow_root_ptr_kinds_M|\<^sub>r = |h' \<turnstile> shadow_root_ptr_kinds_M|\<^sub>r"
using assms
by(auto simp add: shadow_root_ptr_kinds_M_defs object_ptr_kinds_M_defs shadow_root_ptr_kinds_def)
global_interpretation l_dummy defines get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t = "l_get_M.a_get_M get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t" .
lemma get_M_is_l_get_M: "l_get_M get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t type_wf shadow_root_ptr_kinds"
apply(simp add: get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_type_wf l_get_M_def)
by (metis ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf ObjectClass.type_wf_defs bind_eq_None_conv
shadow_root_ptr_kinds_commutes get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def option.simps(3))
lemmas get_M_defs = get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def[unfolded l_get_M.a_get_M_def[OF get_M_is_l_get_M]]
adhoc_overloading get_M get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
locale l_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas = l_type_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
begin
sublocale l_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_get_M get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t type_wf shadow_root_ptr_kinds
apply(unfold_locales)
apply (simp add: get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_type_wf local.type_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t)
by (meson ShadowRootMonad.get_M_is_l_get_M l_get_M_def)
lemmas get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok = get_M_ok[folded get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def]
lemmas get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_in_heap = get_M_ptr_in_heap[folded get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def]
end
global_interpretation l_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas type_wf by unfold_locales
global_interpretation l_put_M type_wf shadow_root_ptr_kinds get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t rewrites
"a_get_M = get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t" defines put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t = a_put_M
apply (simp add: get_M_is_l_get_M l_put_M_def)
by (simp add: get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def)
lemmas put_M_defs = a_put_M_def
adhoc_overloading put_M put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
locale l_put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas = l_type_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
begin
sublocale l_put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_lemmas by unfold_locales
interpretation l_put_M type_wf shadow_root_ptr_kinds get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
apply(unfold_locales)
apply (simp add: get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_type_wf local.type_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t)
by (meson ShadowRootMonad.get_M_is_l_get_M l_get_M_def)
lemmas put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok = put_M_ok[folded put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def]
end
global_interpretation l_put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_lemmas type_wf by unfold_locales
lemma shadow_root_put_get [simp]: "h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = v)
\<Longrightarrow> h' \<turnstile> get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter \<rightarrow>\<^sub>r v"
by(auto simp add: put_M_defs get_M_defs split: option.splits)
lemma get_M_Mshadow_root_preserved1 [simp]:
"shadow_root_ptr \<noteq> shadow_root_ptr'
\<Longrightarrow> h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr' getter) h h'"
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma shadow_root_put_get_preserved [simp]:
"h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (setter (\<lambda>_. v) x) = getter x)
\<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr' getter) h h'"
apply(cases "shadow_root_ptr = shadow_root_ptr'")
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved2 [simp]:
"h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs NodeMonad.get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved3 [simp]:
"cast shadow_root_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
by(auto simp add: put_M_defs get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved4 [simp]:
"h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> (\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast shadow_root_ptr \<noteq> object_ptr")[1]
by(auto simp add: put_M_defs get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
ObjectMonad.get_M_defs preserved_def
split: option.splits bind_splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved5 [simp]:
"cast shadow_root_ptr \<noteq> object_ptr
\<Longrightarrow> h \<turnstile> put_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: ObjectMonad.put_M_defs get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def ObjectMonad.get_M_defs
preserved_def split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved6 [simp]:
"h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'"
by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved7 [simp]:
"h \<turnstile> put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved8 [simp]:
"h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'"
by(auto simp add: put_M_defs CharacterDataMonad.get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved9 [simp]:
"h \<turnstile> put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \<rightarrow>\<^sub>h h'
\<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: CharacterDataMonad.put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma get_M_Mshadow_root_preserved10 [simp]:
"(\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x))
\<Longrightarrow> h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
apply(cases "cast shadow_root_ptr = object_ptr")
by(auto simp add: put_M_defs get_M_defs ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv
split: option.splits)
lemma new_element_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t:
"h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t ptr getter) h h'"
by(auto simp add: new_element_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_character_data_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t ptr getter) h h'"
by(auto simp add: new_character_data_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_document_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t:
"h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t ptr getter) h h'"
by(auto simp add: new_document_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
definition delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog" where
"delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr = do {
h \<leftarrow> get_heap;
(case delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr h of
Some h \<Rightarrow> return_heap h |
None \<Rightarrow> error HierarchyRequestError)
}"
adhoc_overloading delete_M delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M
lemma delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ok [simp]:
assumes "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
shows "h \<turnstile> ok (delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr)"
using assms
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: prod.splits)
lemma delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap:
assumes "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: if_splits)
lemma delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap:
assumes "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
shows "shadow_root_ptr |\<notin>| shadow_root_ptr_kinds h'"
using assms
apply(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: if_splits)[1]
by (metis comp_apply fmdom_notI fmdrop_lookup heap.sel object_ptr_kinds_def shadow_root_ptr_kinds_commutes)
lemma delete_shadow_root_pointers:
assumes "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h' |\<union>| {|cast shadow_root_ptr|}"
using assms
apply(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def split: option.splits)[1]
apply (metis (no_types, lifting) ObjectClass.a_type_wf_def ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def
delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_pointer_ptr_in_heap fmlookup_drop get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def heap.sel option.sel
shadow_root_ptr_kinds_commutes)
using delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_pointer_ptr_in_heap apply blast
by (metis (no_types, lifting) ObjectClass.a_type_wf_def ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def
delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_pointer_ptr_in_heap fmlookup_drop get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def heap.sel option.sel
shadow_root_ptr_kinds_commutes)
lemma delete_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
ptr \<noteq> cast shadow_root_ptr \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def ObjectMonad.get_M_defs preserved_def
split: prod.splits option.splits if_splits elim!: bind_returns_heap_E)
lemma delete_shadow_root_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def NodeMonad.get_M_defs ObjectMonad.get_M_defs
preserved_def split: prod.splits option.splits if_splits elim!: bind_returns_heap_E)
lemma delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def ElementMonad.get_M_defs NodeMonad.get_M_defs
ObjectMonad.get_M_defs preserved_def split: prod.splits option.splits if_splits elim!: bind_returns_heap_E)
lemma delete_shadow_root_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def CharacterDataMonad.get_M_defs
NodeMonad.get_M_defs ObjectMonad.get_M_defs preserved_def split: prod.splits option.splits if_splits
elim!: bind_returns_heap_E)
lemma delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def DocumentMonad.get_M_defs ObjectMonad.get_M_defs
preserved_def split: prod.splits option.splits if_splits elim!: bind_returns_heap_E)
lemma delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
shadow_root_ptr \<noteq> shadow_root_ptr' \<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr' getter) h h'"
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def get_M_defs ObjectMonad.get_M_defs
preserved_def split: prod.splits option.splits if_splits elim!: bind_returns_heap_E)
lemma shadow_root_put_get_1 [simp]: "shadow_root_ptr \<noteq> shadow_root_ptr' \<Longrightarrow>
h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr' getter) h h'"
by(auto simp add: put_M_defs get_M_defs preserved_def split: option.splits dest: get_heap_E)
lemma shadow_root_put_get_2 [simp]: "(\<And>x. getter (setter (\<lambda>_. v) x) = getter x) \<Longrightarrow>
h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr' getter) h h'"
by (cases "shadow_root_ptr = shadow_root_ptr'") (auto simp add: put_M_defs get_M_defs preserved_def
split: option.splits dest: get_heap_E)
lemma shadow_root_put_get_3 [simp]: "h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr getter) h h'"
by(auto simp add: put_M_defs ElementMonad.get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_4 [simp]: "h \<turnstile> put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: ElementMonad.put_M_defs get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_5 [simp]: "h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr getter) h h'"
by(auto simp add: put_M_defs CharacterDataMonad.get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_6 [simp]: "h \<turnstile> put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: CharacterDataMonad.put_M_defs get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_7 [simp]: "h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr getter) h h'"
by(auto simp add: put_M_defs DocumentMonad.get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_8 [simp]: "h \<turnstile> put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow>
preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr getter) h h'"
by(auto simp add: DocumentMonad.put_M_defs get_M_defs preserved_def split: option.splits
dest: get_heap_E)
lemma shadow_root_put_get_9 [simp]: "(\<And>x. getter (cast (setter (\<lambda>_. v) x)) = getter (cast x)) \<Longrightarrow>
h \<turnstile> put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr setter v \<rightarrow>\<^sub>h h' \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr getter) h h'"
by (cases "cast shadow_root_ptr = object_ptr") (auto simp add: put_M_defs get_M_defs
ObjectMonad.get_M_defs NodeMonad.get_M_defs get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def get\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def preserved_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
put\<^sub>N\<^sub>o\<^sub>d\<^sub>e_def bind_eq_Some_conv split: option.splits)
subsection \<open>new\_M\<close>
definition new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M :: "(_, (_) shadow_root_ptr) dom_prog"
where
"new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M = do {
h \<leftarrow> get_heap;
(new_ptr, h') \<leftarrow> return (new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t h);
return_heap h';
return new_ptr
}"
lemma new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ok [simp]:
"h \<turnstile> ok new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def split: prod.splits)
lemma new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "new_shadow_root_ptr |\<in>| shadow_root_ptr_kinds h'"
using assms
unfolding new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_in_heap is_OK_returns_result_I
elim!: bind_returns_result_E bind_returns_heap_E)
lemma new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "new_shadow_root_ptr |\<notin>| shadow_root_ptr_kinds h"
using assms new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_not_in_heap
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'"
and "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using assms new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_new_ptr
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_is_shadow_root_ptr:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "is_shadow_root_ptr new_shadow_root_ptr"
using assms new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_is_shadow_root_ptr
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def elim!: bind_returns_result_E split: prod.splits)
lemma new_shadow_root_mode:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "h' \<turnstile> get_M new_shadow_root_ptr mode \<rightarrow>\<^sub>r Open"
using assms
by(auto simp add: get_M_defs new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_children:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'"
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "h' \<turnstile> get_M new_shadow_root_ptr child_nodes \<rightarrow>\<^sub>r []"
using assms
by(auto simp add: get_M_defs new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def
split: option.splits prod.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> ptr \<noteq> cast new_shadow_root_ptr \<Longrightarrow> preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def ObjectMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def NodeMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def ElementMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def CharacterDataMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def DocumentMonad.get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
lemma new_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> ptr \<noteq> new_shadow_root_ptr
\<Longrightarrow> preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t ptr getter) h h'"
by(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def get_M_defs preserved_def
split: prod.splits option.splits elim!: bind_returns_result_E bind_returns_heap_E)
subsection \<open>modified heaps\<close>
lemma shadow_root_get_put_1 [simp]: "get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = (if ptr = cast shadow_root_ptr
then cast obj else get shadow_root_ptr h)"
by(auto simp add: get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def split: option.splits Option.bind_splits)
lemma shadow_root_ptr_kinds_new[simp]: "shadow_root_ptr_kinds (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h) = shadow_root_ptr_kinds h |\<union>|
(if is_shadow_root_ptr_kind ptr then {|the (cast ptr)|} else {||})"
by(auto simp add: shadow_root_ptr_kinds_def split: option.splits)
lemma type_wf_put_I:
assumes "type_wf h"
assumes "DocumentClass.type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "is_shadow_root_ptr_kind ptr \<Longrightarrow> is_shadow_root_kind obj"
shows "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
using assms
by(auto simp add: type_wf_defs is_shadow_root_kind_def split: option.splits)
lemma type_wf_put_ptr_not_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<notin>| object_ptr_kinds h"
shows "type_wf h"
using assms
by(auto simp add: type_wf_defs elim!: DocumentMonad.type_wf_put_ptr_not_in_heap_E
split: option.splits if_splits)
lemma type_wf_put_ptr_in_heap_E:
assumes "type_wf (put\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr obj h)"
assumes "ptr |\<in>| object_ptr_kinds h"
assumes "DocumentClass.type_wf h"
assumes "is_shadow_root_ptr_kind ptr \<Longrightarrow> is_shadow_root_kind (the (get ptr h))"
shows "type_wf h"
using assms
apply(auto simp add: type_wf_defs elim!: DocumentMonad.type_wf_put_ptr_in_heap_E
split: option.splits if_splits)[1]
by (metis (no_types, opaque_lifting) ObjectClass.a_type_wf_def ObjectClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf
bind.bind_lunit finite_set_in get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def is_shadow_root_kind_def option.exhaust_sel)
subsection \<open>type\_wf\<close>
lemma new_element_type_wf_preserved [simp]:
assumes "h \<turnstile> new_element \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
obtain new_element_ptr where "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr"
using assms
by (meson is_OK_returns_heap_I is_OK_returns_result_E)
with assms have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr by auto
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by auto
with assms show ?thesis
by(auto simp add: ElementMonad.new_element_def type_wf_defs Let_def elim!: bind_returns_heap_E
split: prod.splits)
qed
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_tag_name_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M element_ptr tag_name_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: ElementMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_child_nodes_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M element_ptr RElement.child_nodes_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: ElementMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_attrs_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M element_ptr attrs_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: ElementMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_shadow_root_opt_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M element_ptr shadow_root_opt_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: ElementMonad.put_M_defs type_wf_defs)
qed
lemma new_character_data_type_wf_preserved [simp]:
assumes "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
obtain new_character_data_ptr where "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr"
using assms
by (meson is_OK_returns_heap_I is_OK_returns_result_E)
with assms have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr by auto
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by auto
with assms show ?thesis
by(auto simp add: CharacterDataMonad.new_character_data_def type_wf_defs Let_def
elim!: bind_returns_heap_E split: prod.splits)
qed
lemma put_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a_val_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M character_data_ptr val_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: CharacterDataMonad.put_M_defs type_wf_defs)
qed
lemma new_document_type_wf_preserved [simp]:
assumes "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
obtain new_document_ptr where "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr"
using assms
by (meson is_OK_returns_heap_I is_OK_returns_result_E)
with assms have "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using new_document_new_ptr by auto
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by auto
with assms show ?thesis
by(auto simp add: DocumentMonad.new_document_def type_wf_defs Let_def elim!: bind_returns_heap_E
split: prod.splits)
qed
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_doctype_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M document_ptr doctype_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: DocumentMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_document_element_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M document_ptr document_element_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: DocumentMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_disconnected_nodes_type_wf_preserved [simp]:
assumes "h \<turnstile> put_M document_ptr disconnected_nodes_update v \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
proof -
have "object_ptr_kinds h = object_ptr_kinds h'"
using writes_singleton assms object_ptr_kinds_preserved unfolding all_args_def by fastforce
then have "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
unfolding shadow_root_ptr_kinds_def by simp
with assms show ?thesis
by(auto simp add: DocumentMonad.put_M_defs type_wf_defs)
qed
lemma put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_mode_type_wf_preserved [simp]:
"h \<turnstile> put_M shadow_root_ptr mode_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
by(auto simp add: get_M_defs is_shadow_root_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs DocumentClass.type_wf_defs put_M_defs
put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I DocumentMonad.type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: option.splits)
lemma put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_child_nodes_type_wf_preserved [simp]:
"h \<turnstile> put_M shadow_root_ptr RShadowRoot.child_nodes_update v \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
by(auto simp add: get_M_defs is_shadow_root_kind_def type_wf_defs ElementClass.type_wf_defs
NodeClass.type_wf_defs ElementMonad.get_M_defs ObjectClass.type_wf_defs
CharacterDataClass.type_wf_defs DocumentClass.type_wf_defs put_M_defs
put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
dest!: get_heap_E
elim!: bind_returns_heap_E2
intro!: type_wf_put_I DocumentMonad.type_wf_put_I CharacterDataMonad.type_wf_put_I
ElementMonad.type_wf_put_I NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: option.splits)
lemma shadow_root_ptr_kinds_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
shows "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
by(simp add: shadow_root_ptr_kinds_def preserved_def object_ptr_kinds_preserved_small[OF assms])
lemma shadow_root_ptr_kinds_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h'. \<forall>w \<in> SW. h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow>
(\<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h')"
shows "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
using writes_small_big[OF assms]
apply(simp add: reflp_def transp_def preserved_def shadow_root_ptr_kinds_def)
by (metis assms object_ptr_kinds_preserved)
lemma new_shadow_root_known_ptr:
assumes "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "known_ptr (cast new_shadow_root_ptr)"
using assms
apply(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def a_known_ptr_def
elim!: bind_returns_result_E2 split: prod.splits)[1]
using assms new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_is_shadow_root_ptr by blast
lemma new_shadow_root_type_wf_preserved [simp]: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
apply(auto simp add: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def put\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def put\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_def
ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t ShadowRootClass.type_wf\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a ShadowRootClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
ShadowRootClass.type_wf\<^sub>N\<^sub>o\<^sub>d\<^sub>e ShadowRootClass.type_wf\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
is_node_ptr_kind_none new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_not_in_heap
elim!: bind_returns_heap_E type_wf_put_ptr_not_in_heap_E
intro!: type_wf_put_I DocumentMonad.type_wf_put_I ElementMonad.type_wf_put_I
CharacterDataMonad.type_wf_put_I
NodeMonad.type_wf_put_I ObjectMonad.type_wf_put_I
split: if_splits)[1]
by(auto simp add: type_wf_defs DocumentClass.type_wf_defs ElementClass.type_wf_defs
CharacterDataClass.type_wf_defs
NodeClass.type_wf_defs ObjectClass.type_wf_defs is_shadow_root_kind_def is_document_kind_def
split: option.splits)[1]
locale l_new_shadow_root = l_type_wf +
assumes new_shadow_root_types_preserved: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma new_shadow_root_is_l_new_shadow_root [instances]: "l_new_shadow_root type_wf"
using l_new_shadow_root.intro new_shadow_root_type_wf_preserved
by blast
lemma type_wf_preserved_small:
assumes "\<And>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>character_data_ptr. preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
assumes "\<And>shadow_root_ptr. preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr RShadowRoot.nothing) h h'"
shows "type_wf h = type_wf h'"
using type_wf_preserved_small[OF assms(1) assms(2) assms(3) assms(4) assms(5)]
allI[OF assms(6), of id, simplified] shadow_root_ptr_kinds_small[OF assms(1)]
apply(auto simp add: type_wf_defs preserved_def get_M_defs shadow_root_ptr_kinds_small[OF assms(1)]
split: option.splits)[1]
apply(force)
apply(force)
done
lemma new_element_is_l_new_element [instances]:
"l_new_element type_wf"
using l_new_element.intro new_element_type_wf_preserved
by blast
lemma new_character_data_is_l_new_character_data [instances]:
"l_new_character_data type_wf"
using l_new_character_data.intro new_character_data_type_wf_preserved
by blast
lemma new_document_is_l_new_document [instances]:
"l_new_document type_wf"
using l_new_document.intro new_document_type_wf_preserved
by blast
lemma type_wf_preserved:
assumes "writes SW setter h h'"
assumes "h \<turnstile> setter \<rightarrow>\<^sub>h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>object_ptr. preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t object_ptr RObject.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>node_ptr. preserved (get_M\<^sub>N\<^sub>o\<^sub>d\<^sub>e node_ptr RNode.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>element_ptr. preserved (get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t element_ptr RElement.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>character_data_ptr. preserved (get_M\<^sub>C\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>D\<^sub>a\<^sub>t\<^sub>a character_data_ptr RCharacterData.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>document_ptr. preserved (get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t document_ptr RDocument.nothing) h h'"
assumes "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
\<forall>shadow_root_ptr. preserved (get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t shadow_root_ptr RShadowRoot.nothing) h h'"
shows "type_wf h = type_wf h'"
proof -
have "\<And>h h' w. w \<in> SW \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
using assms type_wf_preserved_small by fast
with assms(1) assms(2) show ?thesis
apply(rule writes_small_big)
by(auto simp add: reflp_def transp_def)
qed
lemma type_wf_drop: "type_wf h \<Longrightarrow> type_wf (Heap (fmdrop ptr (the_heap h)))"
apply(auto simp add: type_wf_defs)[1]
using type_wf_drop
apply blast
by (metis (no_types, lifting) DocumentClass.type_wf\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t ElementClass.get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_type_wf
- ElementMonad.type_wf_drop fmember.rep_eq fmlookup_drop get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
+ ElementMonad.type_wf_drop fmember_iff_member_fset fmlookup_drop get\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def get\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def
object_ptr_kinds_code5 shadow_root_ptr_kinds_commutes)
lemma delete_shadow_root_type_wf_preserved [simp]:
assumes "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
assumes "type_wf h"
shows "type_wf h'"
using assms
using type_wf_drop
by(auto simp add: delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def delete\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t_def split: if_splits)
end
diff --git a/thys/Shadow_SC_DOM/Shadow_DOM.thy b/thys/Shadow_SC_DOM/Shadow_DOM.thy
--- a/thys/Shadow_SC_DOM/Shadow_DOM.thy
+++ b/thys/Shadow_SC_DOM/Shadow_DOM.thy
@@ -1,12913 +1,12913 @@
(***********************************************************************************
* Copyright (c) 2016-2020 The University of Sheffield, UK
* 2019-2020 University of Exeter, UK
*
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are met:
*
* * Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
*
* * Redistributions in binary form must reproduce the above copyright notice,
* this list of conditions and the following disclaimer in the documentation
* and/or other materials provided with the distribution.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
* DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
* FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
* DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
* CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
* OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
* OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* SPDX-License-Identifier: BSD-2-Clause
***********************************************************************************)
section\<open>The Shadow DOM\<close>
theory Shadow_DOM
imports
"monads/ShadowRootMonad"
Core_SC_DOM.Core_DOM
begin
abbreviation "safe_shadow_root_element_types \<equiv> {''article'', ''aside'', ''blockquote'', ''body'',
''div'', ''footer'', ''h1'', ''h2'', ''h3'', ''h4'', ''h5'', ''h6'', ''header'', ''main'',
''nav'', ''p'', ''section'', ''span''}"
subsection \<open>Function Definitions\<close>
subsubsection \<open>get\_child\_nodes\<close>
locale l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) shadow_root_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) node_ptr list) dom_prog" where
"get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr _ = get_M shadow_root_ptr RShadowRoot.child_nodes"
definition a_get_child_nodes_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) node_ptr list) dom_prog)) list" where
"a_get_child_nodes_tups \<equiv> [(is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r, get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_get_child_nodes :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog" where
"a_get_child_nodes ptr = invoke (CD.a_get_child_nodes_tups @ a_get_child_nodes_tups) ptr ()"
definition a_get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" where
"a_get_child_nodes_locs ptr \<equiv>
(if is_shadow_root_ptr_kind ptr
then {preserved (get_M (the (cast ptr)) RShadowRoot.child_nodes)} else {}) \<union>
CD.a_get_child_nodes_locs ptr"
definition first_child :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr option) dom_prog"
where
"first_child ptr = do {
children \<leftarrow> a_get_child_nodes ptr;
return (case children of [] \<Rightarrow> None | child#_ \<Rightarrow> Some child)}"
end
global_interpretation l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines
get_child_nodes = l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes and
get_child_nodes_locs = l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_child_nodes_locs
.
locale l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_known_ptr known_ptr +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
CD: l_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_child_nodes_impl: "get_child_nodes = a_get_child_nodes"
assumes get_child_nodes_locs_impl: "get_child_nodes_locs = a_get_child_nodes_locs"
begin
lemmas get_child_nodes_def = get_child_nodes_impl[unfolded a_get_child_nodes_def get_child_nodes_def]
lemmas get_child_nodes_locs_def = get_child_nodes_locs_impl[unfolded a_get_child_nodes_locs_def
get_child_nodes_locs_def, folded CD.get_child_nodes_locs_impl]
lemma get_child_nodes_ok:
assumes "known_ptr ptr"
assumes "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_child_nodes ptr)"
using assms[unfolded known_ptr_impl type_wf_impl]
apply(auto simp add: get_child_nodes_def)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t CD.get_child_nodes_ok CD.known_ptr_impl CD.type_wf_impl
apply blast
apply(auto simp add: CD.known_ptr_impl a_get_child_nodes_tups_def get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok
dest!: known_ptr_new_shadow_root_ptr intro!: bind_is_OK_I2)[1]
by(auto dest: get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok split: option.splits)
lemma get_child_nodes_ptr_in_heap:
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_child_nodes_def invoke_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_child_nodes_pure [simp]:
"pure (get_child_nodes ptr) h"
apply (auto simp add: get_child_nodes_def a_get_child_nodes_tups_def)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
apply(simp)
apply(split invoke_splits, rule conjI)+
apply(simp)
by(auto simp add: get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_I)
lemma get_child_nodes_reads: "reads (get_child_nodes_locs ptr) (get_child_nodes ptr) h h'"
apply (simp add: get_child_nodes_def a_get_child_nodes_tups_def get_child_nodes_locs_def
CD.get_child_nodes_locs_def)
apply(split CD.get_child_nodes_splits, rule conjI)+
apply(auto intro!: reads_subset[OF CD.get_child_nodes_reads[unfolded CD.get_child_nodes_locs_def]]
split: if_splits)[1]
apply(split invoke_splits, rule conjI)+
apply(auto)[1]
apply(auto simp add: get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro: reads_subset[OF reads_singleton] reads_subset[OF check_in_heap_reads]
intro!: reads_bind_pure reads_subset[OF return_reads] split: option.splits)[1]
done
end
interpretation i_get_child_nodes?: l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(simp add: l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_child_nodes_is_l_get_child_nodes [instances]: "l_get_child_nodes type_wf known_ptr
get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_get_child_nodes_def instances)[1]
using get_child_nodes_reads get_child_nodes_ok get_child_nodes_ptr_in_heap get_child_nodes_pure
by blast+
paragraph \<open>new\_document\<close>
locale l_new_document_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_child_nodes_new_document:
"ptr' \<noteq> cast new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
apply(auto simp add: get_child_nodes_locs_def)[1]
using CD.get_child_nodes_new_document
apply (metis document_ptr_casts_commute3 empty_iff is_document_ptr_kind_none
new_document_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t option.case_eq_if shadow_root_ptr_casts_commute3 singletonD)
by (simp add: CD.get_child_nodes_new_document)
lemma new_document_no_child_nodes:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using CD.new_document_no_child_nodes apply auto[1]
by(auto simp add: DocumentClass.a_known_ptr_def CD.known_ptr_impl known_ptr_def
dest!: new_document_is_document_ptr)
end
interpretation i_new_document_get_child_nodes?:
l_new_document_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs
DocumentClass.type_wf DocumentClass.known_ptr Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_document_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma new_document_get_child_nodes_is_l_new_document_get_child_nodes [instances]:
"l_new_document_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
using new_document_is_l_new_document get_child_nodes_is_l_get_child_nodes
apply(simp add: l_new_document_get_child_nodes_def l_new_document_get_child_nodes_axioms_def)
using get_child_nodes_new_document new_document_no_child_nodes
by fast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_child_nodes_new_shadow_root:
"ptr' \<noteq> cast new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
apply(auto simp add: get_child_nodes_locs_def)[1]
apply (metis document_ptr_casts_commute3 insert_absorb insert_not_empty is_document_ptr_kind_none
new_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t option.case_eq_if shadow_root_ptr_casts_commute3 singletonD)
apply(auto simp add: CD.get_child_nodes_locs_def)[1]
using new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t apply blast
apply (smt insertCI new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t singleton_iff)
apply (metis document_ptr_casts_commute3 empty_iff new_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t singletonD)
done
lemma new_shadow_root_no_child_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def )[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
apply(auto simp add: CD.get_child_nodes_def CD.a_get_child_nodes_tups_def)[1]
apply(split invoke_splits, rule conjI)+
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_element_ptr local.CD.known_ptr_impl apply blast
apply(auto simp add: is_document_ptr_def cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
split: option.splits document_ptr.splits)[1]
apply(auto simp add: is_character_data_ptr_def cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
split: option.splits document_ptr.splits)[1]
apply(auto simp add: is_element_ptr_def cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
split: option.splits document_ptr.splits)[1]
apply(auto simp add: a_get_child_nodes_tups_def)[1]
apply(split invoke_splits, rule conjI)+
apply(auto simp add: is_shadow_root_ptr_def split: shadow_root_ptr.splits
dest!: new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_is_shadow_root_ptr)[1]
apply(auto intro!: bind_pure_returns_result_I)[1]
apply(drule(1) new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap)
apply(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)[1]
apply (metis check_in_heap_ptr_in_heap is_OK_returns_result_E old.unit.exhaust)
using new_shadow_root_children
by (simp add: new_shadow_root_children get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def)
end
interpretation i_new_shadow_root_get_child_nodes?:
l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr get_child_nodes get_child_nodes_locs
DocumentClass.type_wf DocumentClass.known_ptr Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
locale l_new_shadow_root_get_child_nodes = l_get_child_nodes +
assumes get_child_nodes_new_shadow_root:
"ptr' \<noteq> cast new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
assumes new_shadow_root_no_child_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
lemma new_shadow_root_get_child_nodes_is_l_new_shadow_root_get_child_nodes [instances]:
"l_new_shadow_root_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
apply(simp add: l_new_shadow_root_get_child_nodes_def l_new_shadow_root_get_child_nodes_axioms_def instances)
using get_child_nodes_new_shadow_root new_shadow_root_no_child_nodes
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_new_element_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_new_element:
"ptr' \<noteq> cast new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t new_element_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
lemma new_element_no_child_nodes:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
apply(auto simp add: get_child_nodes_def a_get_child_nodes_tups_def
split: prod.splits elim!: bind_returns_result_E bind_returns_heap_E)[1]
apply(split CD.get_child_nodes_splits, rule conjI)+
using local.new_element_no_child_nodes apply auto[1]
apply(auto simp add: invoke_def)[1]
using case_optionE apply fastforce
apply(auto simp add: new_element_ptr_in_heap get_child_nodes\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def check_in_heap_def
new_element_child_nodes intro!: bind_pure_returns_result_I
intro: new_element_is_element_ptr elim!: new_element_ptr_in_heap)[1]
proof -
assume " h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr"
assume "h \<turnstile> new_element \<rightarrow>\<^sub>h h'"
assume "\<not> is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr)"
assume "\<not> known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr)"
moreover
have "known_ptr (cast new_element_ptr)"
using new_element_is_element_ptr \<open>h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr\<close>
by(auto simp add: known_ptr_impl ShadowRootClass.a_known_ptr_def DocumentClass.a_known_ptr_def
CharacterDataClass.a_known_ptr_def ElementClass.a_known_ptr_def)
ultimately show "False"
by(simp add: known_ptr_impl CD.known_ptr_impl ShadowRootClass.a_known_ptr_def is_document_ptr_kind_none)
qed
end
interpretation i_new_element_get_child_nodes?:
l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(unfold_locales)
declare l_new_element_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma new_element_get_child_nodes_is_l_new_element_get_child_nodes [instances]:
"l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs"
using new_element_is_l_new_element get_child_nodes_is_l_get_child_nodes
apply(auto simp add: l_new_element_get_child_nodes_def l_new_element_get_child_nodes_axioms_def)[1]
using get_child_nodes_new_element new_element_no_child_nodes
by fast+
subsubsection \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_child_nodes_delete_shadow_root:
"ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def delete_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t
delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: if_splits intro: is_shadow_root_ptr_kind_obtains
intro: is_shadow_root_ptr_kind_obtains delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
simp add: shadow_root_ptr_casts_commute3 delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
intro!: delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t dest: document_ptr_casts_commute3
split: option.splits)
end
locale l_delete_shadow_root_get_child_nodes = l_get_child_nodes_defs +
assumes get_child_nodes_delete_shadow_root:
"ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_child_nodes_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(auto simp add: l_delete_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_child_nodes_get_child_nodes_locs [instances]: "l_delete_shadow_root_get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_delete_shadow_root_get_child_nodes_def)[1]
using get_child_nodes_delete_shadow_root apply fast
done
subsubsection \<open>set\_child\_nodes\<close>
locale l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) shadow_root_ptr \<Rightarrow> (_) node_ptr list
\<Rightarrow> (_, unit) dom_prog" where
"set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr = put_M shadow_root_ptr RShadowRoot.child_nodes_update"
definition a_set_child_nodes_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> (_) node_ptr list
\<Rightarrow> (_, unit) dom_prog)) list" where
"a_set_child_nodes_tups \<equiv> [(is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r, set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog"
where
"a_set_child_nodes ptr children = invoke (CD.a_set_child_nodes_tups @ a_set_child_nodes_tups) ptr children"
definition a_set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set"
where
"a_set_child_nodes_locs ptr \<equiv>
(if is_shadow_root_ptr_kind ptr then all_args (put_M (the (cast ptr)) RShadowRoot.child_nodes_update) else {}) \<union>
CD.a_set_child_nodes_locs ptr"
end
global_interpretation l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs defines
set_child_nodes = l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes and
set_child_nodes_locs = l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_set_child_nodes_locs
.
locale l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_known_ptr known_ptr +
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_set_child_nodes_defs set_child_nodes set_child_nodes_locs +
CD: l_set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> (_, unit) dom_prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_child_nodes_impl: "set_child_nodes = a_set_child_nodes"
assumes set_child_nodes_locs_impl: "set_child_nodes_locs = a_set_child_nodes_locs"
begin
lemmas set_child_nodes_def = set_child_nodes_impl[unfolded a_set_child_nodes_def set_child_nodes_def]
lemmas set_child_nodes_locs_def =set_child_nodes_locs_impl[unfolded a_set_child_nodes_locs_def
set_child_nodes_locs_def, folded CD.set_child_nodes_locs_impl]
lemma set_child_nodes_writes: "writes (set_child_nodes_locs ptr) (set_child_nodes ptr children) h h'"
apply (simp add: set_child_nodes_def a_set_child_nodes_tups_def set_child_nodes_locs_def)
apply(split CD.set_child_nodes_splits, rule conjI)+
apply (simp add: CD.set_child_nodes_writes writes_union_right_I)
apply(split invoke_splits, rule conjI)+
apply(auto simp add: a_set_child_nodes_def)[1]
apply(auto simp add: set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: writes_bind_pure
intro: writes_union_right_I writes_union_left_I split: list.splits)[1]
by (metis is_shadow_root_ptr_implies_kind option.case_eq_if)
lemma set_child_nodes_pointers_preserved:
assumes "w \<in> set_child_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_child_nodes_locs_def CD.set_child_nodes_locs_def split: if_splits)
lemma set_child_nodes_types_preserved:
assumes "w \<in> set_child_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)] type_wf_impl
by(auto simp add: all_args_def a_set_child_nodes_tups_def set_child_nodes_locs_def CD.set_child_nodes_locs_def
split: if_splits option.splits)
end
interpretation
i_set_child_nodes?: l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr set_child_nodes set_child_nodes_locs Core_DOM_Functions.set_child_nodes
Core_DOM_Functions.set_child_nodes_locs
apply(unfold_locales)
by (auto simp add: set_child_nodes_def set_child_nodes_locs_def)
declare l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_is_l_set_child_nodes [instances]: "l_set_child_nodes type_wf
set_child_nodes set_child_nodes_locs"
apply(auto simp add: l_set_child_nodes_def instances)[1]
using set_child_nodes_writes apply fast
using set_child_nodes_pointers_preserved apply(fast, fast)
using set_child_nodes_types_preserved apply(fast, fast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes set_child_nodes_locs
set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ CD: l_set_child_nodes_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
begin
lemma set_child_nodes_get_child_nodes:
assumes "known_ptr ptr"
assumes "type_wf h"
assumes "h \<turnstile> set_child_nodes ptr children \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
proof -
have "h \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()"
using assms set_child_nodes_def invoke_ptr_in_heap
by (metis (full_types) check_in_heap_ptr_in_heap is_OK_returns_heap_I is_OK_returns_result_E
old.unit.exhaust)
then have ptr_in_h: "ptr |\<in>| object_ptr_kinds h"
by (simp add: check_in_heap_ptr_in_heap is_OK_returns_result_I)
have "type_wf h'"
apply(unfold type_wf_impl)
apply(rule subst[where P=id, OF type_wf_preserved[OF set_child_nodes_writes assms(3),
unfolded all_args_def], simplified])
by(auto simp add: all_args_def assms(2)[unfolded type_wf_impl] set_child_nodes_locs_def
CD.set_child_nodes_locs_def split: if_splits)
have "h' \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()"
using check_in_heap_reads set_child_nodes_writes assms(3) \<open>h \<turnstile> check_in_heap ptr \<rightarrow>\<^sub>r ()\<close>
apply(rule reads_writes_separate_forwards)
apply(auto simp add: all_args_def set_child_nodes_locs_def CD.set_child_nodes_locs_def)[1]
done
then have "ptr |\<in>| object_ptr_kinds h'"
using check_in_heap_ptr_in_heap by blast
with assms ptr_in_h \<open>type_wf h'\<close> show ?thesis
apply(auto simp add: type_wf_impl known_ptr_impl get_child_nodes_def a_get_child_nodes_tups_def
set_child_nodes_def a_set_child_nodes_tups_def del: bind_pure_returns_result_I2 intro!: bind_pure_returns_result_I2)[1]
apply(split CD.get_child_nodes_splits, (rule conjI impI)+)+
apply(split CD.set_child_nodes_splits)+
apply(auto simp add: CD.set_child_nodes_get_child_nodes type_wf_impl CD.type_wf_impl
dest: ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)[1]
apply(auto simp add: CD.set_child_nodes_get_child_nodes type_wf_impl CD.type_wf_impl
dest: ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)[1]
apply(split CD.set_child_nodes_splits)+
by(auto simp add: known_ptr_impl CD.known_ptr_impl set_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
get_child_nodes\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t dest: known_ptr_new_shadow_root_ptr)[2]
qed
lemma set_child_nodes_get_child_nodes_different_pointers:
assumes "ptr \<noteq> ptr'"
assumes "w \<in> set_child_nodes_locs ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_child_nodes_locs ptr'"
shows "r h h'"
using assms
apply(auto simp add: set_child_nodes_locs_def CD.set_child_nodes_locs_def
get_child_nodes_locs_def CD.get_child_nodes_locs_def)[1]
by(auto simp add: all_args_def elim!: is_document_ptr_kind_obtains is_shadow_root_ptr_kind_obtains
is_element_ptr_kind_obtains split: if_splits option.splits)
end
interpretation
i_set_child_nodes_get_child_nodes?: l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes get_child_nodes_locs
Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs set_child_nodes
set_child_nodes_locs Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs
using instances
by(auto simp add: l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def )
declare l_set_child_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_child_nodes_is_l_set_child_nodes_get_child_nodes [instances]:
"l_set_child_nodes_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs set_child_nodes set_child_nodes_locs"
apply(auto simp add: instances l_set_child_nodes_get_child_nodes_def l_set_child_nodes_get_child_nodes_axioms_def)[1]
using set_child_nodes_get_child_nodes apply fast
using set_child_nodes_get_child_nodes_different_pointers apply fast
done
subsubsection \<open>set\_tag\_type\<close>
locale l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_tag_name set_tag_name_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_tag_name :: "(_) element_ptr \<Rightarrow> tag_name \<Rightarrow> (_, unit) dom_prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemmas set_tag_name_def = CD.set_tag_name_impl[unfolded CD.a_set_tag_name_def set_tag_name_def]
lemmas set_tag_name_locs_def = CD.set_tag_name_locs_impl[unfolded CD.a_set_tag_name_locs_def
set_tag_name_locs_def]
lemma set_tag_name_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_tag_name element_ptr tag)"
apply(unfold type_wf_impl)
unfolding set_tag_name_impl[unfolded a_set_tag_name_def] using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok
using CD.set_tag_name_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
lemma set_tag_name_writes:
"writes (set_tag_name_locs element_ptr) (set_tag_name element_ptr tag) h h'"
using CD.set_tag_name_writes .
lemma set_tag_name_pointers_preserved:
assumes "w \<in> set_tag_name_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms
by(simp add: CD.set_tag_name_pointers_preserved)
lemma set_tag_name_typess_preserved:
assumes "w \<in> set_tag_name_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
apply(rule type_wf_preserved[OF writes_singleton2 assms(2)])
using assms(1) set_tag_name_locs_def
by(auto simp add: all_args_def set_tag_name_locs_def
split: if_splits)
end
interpretation i_set_tag_name?: l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_tag_name
set_tag_name_locs
by(auto simp add: l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_tag_name_is_l_set_tag_name [instances]: "l_set_tag_name type_wf set_tag_name set_tag_name_locs"
apply(auto simp add: l_set_tag_name_def)[1]
using set_tag_name_writes apply fast
using set_tag_name_ok apply fast
using set_tag_name_pointers_preserved apply (fast, fast)
using set_tag_name_typess_preserved apply (fast, fast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
CD: l_set_tag_name_get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_tag_name set_tag_name_locs
known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_child_nodes:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
apply(auto simp add: get_child_nodes_locs_def)[1]
apply(auto simp add: set_tag_name_locs_def all_args_def)[1]
using CD.set_tag_name_get_child_nodes apply(blast)
using CD.set_tag_name_get_child_nodes apply(blast)
done
end
interpretation
i_set_tag_name_get_child_nodes?: l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_tag_name set_tag_name_locs known_ptr DocumentClass.known_ptr get_child_nodes
get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by unfold_locales
declare l_set_tag_name_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_child_nodes_is_l_set_tag_name_get_child_nodes [instances]:
"l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr get_child_nodes
get_child_nodes_locs"
using set_tag_name_is_l_set_tag_name get_child_nodes_is_l_get_child_nodes
apply(simp add: l_set_tag_name_get_child_nodes_def
l_set_tag_name_get_child_nodes_axioms_def)
using set_tag_name_get_child_nodes
by fast
subsubsection \<open>get\_shadow\_root\<close>
locale l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
where
"a_get_shadow_root element_ptr = get_M element_ptr shadow_root_opt"
definition a_get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
where
"a_get_shadow_root_locs element_ptr \<equiv> {preserved (get_M element_ptr shadow_root_opt)}"
end
global_interpretation l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines get_shadow_root = a_get_shadow_root
and get_shadow_root_locs = a_get_shadow_root_locs
.
locale l_get_shadow_root_defs =
fixes get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
fixes get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_shadow_root_impl: "get_shadow_root = a_get_shadow_root"
assumes get_shadow_root_locs_impl: "get_shadow_root_locs = a_get_shadow_root_locs"
begin
lemmas get_shadow_root_def = get_shadow_root_impl[unfolded get_shadow_root_def a_get_shadow_root_def]
lemmas get_shadow_root_locs_def = get_shadow_root_locs_impl[unfolded get_shadow_root_locs_def a_get_shadow_root_locs_def]
lemma get_shadow_root_ok: "type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_shadow_root element_ptr)"
unfolding get_shadow_root_def type_wf_impl
using ShadowRootMonad.get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok by blast
lemma get_shadow_root_pure [simp]: "pure (get_shadow_root element_ptr) h"
unfolding get_shadow_root_def by simp
lemma get_shadow_root_ptr_in_heap:
assumes "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r children"
shows "element_ptr |\<in>| element_ptr_kinds h"
using assms
by(auto simp add: get_shadow_root_def get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_shadow_root_reads: "reads (get_shadow_root_locs element_ptr) (get_shadow_root element_ptr) h h'"
by(simp add: get_shadow_root_def get_shadow_root_locs_def reads_bind_pure reads_insert_writes_set_right)
end
interpretation i_get_shadow_root?: l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
using instances
by (auto simp add: l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_shadow_root = l_type_wf + l_get_shadow_root_defs +
assumes get_shadow_root_reads: "reads (get_shadow_root_locs element_ptr) (get_shadow_root element_ptr) h h'"
assumes get_shadow_root_ok: "type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_shadow_root element_ptr)"
assumes get_shadow_root_ptr_in_heap: "h \<turnstile> ok (get_shadow_root element_ptr) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
assumes get_shadow_root_pure [simp]: "pure (get_shadow_root element_ptr) h"
lemma get_shadow_root_is_l_get_shadow_root [instances]: "l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using instances
apply(auto simp add: l_get_shadow_root_def)[1]
using get_shadow_root_reads apply blast
using get_shadow_root_ok apply blast
using get_shadow_root_ptr_in_heap apply blast
done
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_disconnected_nodes_get_shadow_root:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_disconnected_nodes_locs_def get_shadow_root_locs_def all_args_def)
end
locale l_set_disconnected_nodes_get_shadow_root = l_set_disconnected_nodes_defs + l_get_shadow_root_defs +
assumes set_disconnected_nodes_get_shadow_root: "\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_disconnected_nodes_get_shadow_root?: l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
by(auto simp add: l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_shadow_root_is_l_set_disconnected_nodes_get_shadow_root [instances]:
"l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes_locs get_shadow_root_locs"
apply(auto simp add: l_set_disconnected_nodes_get_shadow_root_def)[1]
using set_disconnected_nodes_get_shadow_root apply fast
done
paragraph \<open>set\_tag\_type\<close>
locale l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_shadow_root:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_tag_name_locs_def
get_shadow_root_locs_def all_args_def
intro: element_put_get_preserved[where setter=tag_name_update and getter=shadow_root_opt])
end
locale l_set_tag_name_get_shadow_root = l_set_tag_name + l_get_shadow_root +
assumes set_tag_name_get_shadow_root:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_tag_name_get_shadow_root?: l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_tag_name set_tag_name_locs
get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
using l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by unfold_locales
declare l_set_tag_name_get_shadow_root\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_shadow_root_is_l_set_tag_name_get_shadow_root [instances]:
"l_set_tag_name_get_shadow_root type_wf set_tag_name set_tag_name_locs get_shadow_root
get_shadow_root_locs"
using set_tag_name_is_l_set_tag_name get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_tag_name_get_shadow_root_def l_set_tag_name_get_shadow_root_axioms_def)
using set_tag_name_get_shadow_root
by fast
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes
set_child_nodes_locs set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_child_nodes_get_shadow_root: "\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
apply(auto simp add: set_child_nodes_locs_def get_shadow_root_locs_def CD.set_child_nodes_locs_def all_args_def)[1]
by(auto intro!: element_put_get_preserved[where getter=shadow_root_opt and setter=RElement.child_nodes_update])
end
locale l_set_child_nodes_get_shadow_root = l_set_child_nodes_defs + l_get_shadow_root_defs +
assumes set_child_nodes_get_shadow_root: "\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_child_nodes_get_shadow_root?: l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_shadow_root
get_shadow_root_locs
by(auto simp add: l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_shadow_root_is_l_set_child_nodes_get_shadow_root [instances]:
"l_set_child_nodes_get_shadow_root set_child_nodes_locs get_shadow_root_locs"
apply(auto simp add: l_set_child_nodes_get_shadow_root_def)[1]
using set_child_nodes_get_shadow_root apply fast
done
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_shadow_root_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: get_shadow_root_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_shadow_root = l_get_shadow_root_defs +
assumes get_shadow_root_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(auto simp add: l_delete_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_shadow_root_get_shadow_root_locs [instances]: "l_delete_shadow_root_get_shadow_root get_shadow_root_locs"
apply(auto simp add: l_delete_shadow_root_get_shadow_root_def)[1]
using get_shadow_root_delete_shadow_root apply fast
done
paragraph \<open>new\_character\_data\<close>
locale l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_character_data_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_character_data_get_shadow_root = l_new_character_data + l_get_shadow_root +
assumes get_shadow_root_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr
\<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_character_data_get_shadow_root?:
l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_character_data_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_character_data_get_shadow_root_is_l_new_character_data_get_shadow_root [instances]:
"l_new_character_data_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_character_data_is_l_new_character_data get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_character_data_get_shadow_root_def
l_new_character_data_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_character_data
by fast
paragraph \<open>new\_document\<close>
locale l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_document_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_document_get_shadow_root = l_new_document + l_get_shadow_root +
assumes get_shadow_root_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr
\<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_document_get_shadow_root?:
l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_document_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_document_get_shadow_root_is_l_new_document_get_shadow_root [instances]:
"l_new_document_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_document_is_l_new_document get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_document_get_shadow_root_def l_new_document_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_document
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
lemma new_element_no_shadow_root:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_shadow_root new_element_ptr \<rightarrow>\<^sub>r None"
by(simp add: get_shadow_root_def new_element_shadow_root_opt)
end
locale l_new_element_get_shadow_root = l_new_element + l_get_shadow_root +
assumes get_shadow_root_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr
\<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
assumes new_element_no_shadow_root:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_shadow_root new_element_ptr \<rightarrow>\<^sub>r None"
interpretation i_new_element_get_shadow_root?:
l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_element_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_element_get_shadow_root_is_l_new_element_get_shadow_root [instances]:
"l_new_element_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using new_element_is_l_new_element get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_element_get_shadow_root_def l_new_element_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_element new_element_no_shadow_root
by fast+
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_shadow_root_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: get_shadow_root_locs_def new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_shadow_root_get_shadow_root = l_get_shadow_root +
assumes get_shadow_root_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_shadow_root_get_shadow_root?:
l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
by(unfold_locales)
declare l_new_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_shadow_root_get_shadow_root_is_l_new_shadow_root_get_shadow_root [instances]:
"l_new_shadow_root_get_shadow_root type_wf get_shadow_root get_shadow_root_locs"
using get_shadow_root_is_l_get_shadow_root
apply(auto simp add: l_new_shadow_root_get_shadow_root_def l_new_shadow_root_get_shadow_root_axioms_def instances)[1]
using get_shadow_root_new_shadow_root
by fast
subsubsection \<open>set\_shadow\_root\<close>
locale l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
where
"a_set_shadow_root element_ptr = put_M element_ptr shadow_root_opt_update"
definition a_set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_set_shadow_root_locs element_ptr \<equiv> all_args (put_M element_ptr shadow_root_opt_update)"
end
global_interpretation l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines set_shadow_root = a_set_shadow_root
and set_shadow_root_locs = a_set_shadow_root_locs
.
locale l_set_shadow_root_defs =
fixes set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
fixes set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set"
locale l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_shadow_root_impl: "set_shadow_root = a_set_shadow_root"
assumes set_shadow_root_locs_impl: "set_shadow_root_locs = a_set_shadow_root_locs"
begin
lemmas set_shadow_root_def = set_shadow_root_impl[unfolded set_shadow_root_def a_set_shadow_root_def]
lemmas set_shadow_root_locs_def = set_shadow_root_locs_impl[unfolded set_shadow_root_locs_def a_set_shadow_root_locs_def]
lemma set_shadow_root_ok: "type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_shadow_root element_ptr tag)"
apply(unfold type_wf_impl)
unfolding set_shadow_root_def using get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok
by (simp add: ShadowRootMonad.put_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t_ok)
lemma set_shadow_root_ptr_in_heap:
"h \<turnstile> ok (set_shadow_root element_ptr shadow_root) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
by(simp add: set_shadow_root_def ElementMonad.put_M_ptr_in_heap)
lemma set_shadow_root_writes: "writes (set_shadow_root_locs element_ptr) (set_shadow_root element_ptr tag) h h'"
by(auto simp add: set_shadow_root_def set_shadow_root_locs_def intro: writes_bind_pure)
lemma set_shadow_root_pointers_preserved:
assumes "w \<in> set_shadow_root_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_shadow_root_locs_def split: if_splits)
lemma set_shadow_root_types_preserved:
assumes "w \<in> set_shadow_root_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_shadow_root_locs_def split: if_splits)
end
interpretation i_set_shadow_root?: l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root set_shadow_root_locs
by (auto simp add: l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_shadow_root = l_type_wf +l_set_shadow_root_defs +
assumes set_shadow_root_writes:
"writes (set_shadow_root_locs element_ptr) (set_shadow_root element_ptr disc_nodes) h h'"
assumes set_shadow_root_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_shadow_root element_ptr shadow_root)"
assumes set_shadow_root_ptr_in_heap:
"h \<turnstile> ok (set_shadow_root element_ptr shadow_root) \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h"
assumes set_shadow_root_pointers_preserved:
"w \<in> set_shadow_root_locs element_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h'"
assumes set_shadow_root_types_preserved:
"w \<in> set_shadow_root_locs element_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma set_shadow_root_is_l_set_shadow_root [instances]: "l_set_shadow_root type_wf set_shadow_root set_shadow_root_locs"
apply(auto simp add: l_set_shadow_root_def instances)[1]
using set_shadow_root_writes apply blast
using set_shadow_root_ok apply (blast)
using set_shadow_root_ptr_in_heap apply blast
using set_shadow_root_pointers_preserved apply(blast, blast)
using set_shadow_root_types_preserved apply(blast, blast)
done
paragraph \<open>get\_shadow\_root\<close>
locale l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_shadow_root:
"type_wf h \<Longrightarrow> h \<turnstile> set_shadow_root ptr shadow_root_ptr_opt \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt"
by(auto simp add: set_shadow_root_def get_shadow_root_def)
lemma set_shadow_root_get_shadow_root_different_pointers:
"ptr \<noteq> ptr' \<Longrightarrow> \<forall>w \<in> set_shadow_root_locs ptr.
(h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def get_shadow_root_locs_def all_args_def)
end
interpretation
i_set_shadow_root_get_shadow_root?: l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_shadow_root set_shadow_root_locs get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_shadow_root = l_type_wf + l_set_shadow_root_defs + l_get_shadow_root_defs +
assumes set_shadow_root_get_shadow_root:
"type_wf h \<Longrightarrow> h \<turnstile> set_shadow_root ptr shadow_root_ptr_opt \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root_ptr_opt"
assumes set_shadow_root_get_shadow_root_different_pointers:
"ptr \<noteq> ptr' \<Longrightarrow> w \<in> set_shadow_root_locs ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_shadow_root_locs ptr' \<Longrightarrow>
r h h'"
lemma set_shadow_root_get_shadow_root_is_l_set_shadow_root_get_shadow_root [instances]:
"l_set_shadow_root_get_shadow_root type_wf set_shadow_root set_shadow_root_locs get_shadow_root
get_shadow_root_locs"
apply(auto simp add: l_set_shadow_root_get_shadow_root_def instances)[1]
using set_shadow_root_get_shadow_root apply fast
using set_shadow_root_get_shadow_root_different_pointers apply fast
done
subsubsection \<open>set\_mode\<close>
locale l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
where
"a_set_mode shadow_root_ptr = put_M shadow_root_ptr mode_update"
definition a_set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_set_mode_locs shadow_root_ptr \<equiv> all_args (put_M shadow_root_ptr mode_update)"
end
global_interpretation l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines set_mode = a_set_mode
and set_mode_locs = a_set_mode_locs
.
locale l_set_mode_defs =
fixes set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
fixes set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set"
locale l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_type_wf type_wf +
l_set_mode_defs set_mode set_mode_locs +
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes set_mode_impl: "set_mode = a_set_mode"
assumes set_mode_locs_impl: "set_mode_locs = a_set_mode_locs"
begin
lemmas set_mode_def = set_mode_impl[unfolded set_mode_def a_set_mode_def]
lemmas set_mode_locs_def = set_mode_locs_impl[unfolded set_mode_locs_def a_set_mode_locs_def]
lemma set_mode_ok: "type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode)"
apply(unfold type_wf_impl)
unfolding set_mode_def using get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok
by (simp add: ShadowRootMonad.put_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok)
lemma set_mode_ptr_in_heap:
"h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode) \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
by(simp add: set_mode_def put_M_ptr_in_heap)
lemma set_mode_writes: "writes (set_mode_locs shadow_root_ptr) (set_mode shadow_root_ptr shadow_root_mode) h h'"
by(auto simp add: set_mode_def set_mode_locs_def intro: writes_bind_pure)
lemma set_mode_pointers_preserved:
assumes "w \<in> set_mode_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms(1) object_ptr_kinds_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_mode_locs_def split: if_splits)
lemma set_mode_types_preserved:
assumes "w \<in> set_mode_locs element_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def set_mode_locs_def split: if_splits)
end
interpretation i_set_mode?: l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_mode set_mode_locs
by (auto simp add: l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_mode = l_type_wf +l_set_mode_defs +
assumes set_mode_writes:
"writes (set_mode_locs shadow_root_ptr) (set_mode shadow_root_ptr shadow_root_mode) h h'"
assumes set_mode_ok:
"type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode)"
assumes set_mode_ptr_in_heap:
"h \<turnstile> ok (set_mode shadow_root_ptr shadow_root_mode) \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
assumes set_mode_pointers_preserved:
"w \<in> set_mode_locs shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h'"
assumes set_mode_types_preserved:
"w \<in> set_mode_locs shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
lemma set_mode_is_l_set_mode [instances]: "l_set_mode type_wf set_mode set_mode_locs"
apply(auto simp add: l_set_mode_def instances)[1]
using set_mode_writes apply blast
using set_mode_ok apply (blast)
using set_mode_ptr_in_heap apply blast
using set_mode_pointers_preserved apply(blast, blast)
using set_mode_types_preserved apply(blast, blast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_child_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: get_child_nodes_locs_def set_shadow_root_locs_def CD.get_child_nodes_locs_def
all_args_def intro: element_put_get_preserved[where setter=shadow_root_opt_update])
end
interpretation i_set_shadow_root_get_child_nodes?:
l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs set_shadow_root set_shadow_root_locs
by(unfold_locales)
declare l_set_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_child_nodes = l_set_shadow_root + l_get_child_nodes +
assumes set_shadow_root_get_child_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
lemma set_shadow_root_get_child_nodes_is_l_set_shadow_root_get_child_nodes [instances]:
"l_set_shadow_root_get_child_nodes type_wf set_shadow_root set_shadow_root_locs known_ptr
get_child_nodes get_child_nodes_locs"
apply(auto simp add: l_set_shadow_root_get_child_nodes_def l_set_shadow_root_get_child_nodes_axioms_def
instances)[1]
using set_shadow_root_get_child_nodes apply blast
done
paragraph \<open>get\_shadow\_root\<close>
locale l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_shadow_root:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def get_shadow_root_locs_def all_args_def)
end
interpretation
i_set_mode_get_shadow_root?: l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs get_shadow_root
get_shadow_root_locs
by unfold_locales
declare l_set_mode_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_shadow_root = l_set_mode + l_get_shadow_root +
assumes set_mode_get_shadow_root:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
lemma set_mode_get_shadow_root_is_l_set_mode_get_shadow_root [instances]:
"l_set_mode_get_shadow_root type_wf set_mode set_mode_locs get_shadow_root
get_shadow_root_locs"
using set_mode_is_l_set_mode get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_mode_get_shadow_root_def
l_set_mode_get_shadow_root_axioms_def)
using set_mode_get_shadow_root
by fast
paragraph \<open>get\_child\_nodes\<close>
locale l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_child_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: get_child_nodes_locs_def CD.get_child_nodes_locs_def set_mode_locs_def all_args_def)[1]
end
interpretation
i_set_mode_get_child_nodes?: l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_mode set_mode_locs known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes
get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by unfold_locales
declare l_set_mode_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_child_nodes = l_set_mode + l_get_child_nodes +
assumes set_mode_get_child_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
lemma set_mode_get_child_nodes_is_l_set_mode_get_child_nodes [instances]:
"l_set_mode_get_child_nodes type_wf set_mode set_mode_locs known_ptr get_child_nodes
get_child_nodes_locs"
using set_mode_is_l_set_mode get_child_nodes_is_l_get_child_nodes
apply(simp add: l_set_mode_get_child_nodes_def
l_set_mode_get_child_nodes_axioms_def)
using set_mode_get_child_nodes
by fast
subsubsection \<open>get\_host\<close>
locale l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for get_shadow_root :: "(_::linorder) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_host :: "(_) shadow_root_ptr \<Rightarrow> (_, (_) element_ptr) dom_prog"
where
"a_get_host shadow_root_ptr = do {
host_ptrs \<leftarrow> element_ptr_kinds_M \<bind> filter_M (\<lambda>element_ptr. do {
shadow_root_opt \<leftarrow> get_shadow_root element_ptr;
return (shadow_root_opt = Some shadow_root_ptr)
});
(case host_ptrs of host_ptr#[] \<Rightarrow> return host_ptr | _ \<Rightarrow> error HierarchyRequestError)
}"
definition "a_get_host_locs \<equiv> (\<Union>element_ptr. (get_shadow_root_locs element_ptr)) \<union>
(\<Union>ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing)})"
end
global_interpretation l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs
defines get_host = "a_get_host"
and get_host_locs = "a_get_host_locs"
.
locale l_get_host_defs =
fixes get_host :: "(_) shadow_root_ptr \<Rightarrow> (_, (_) element_ptr) dom_prog"
fixes get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_host_defs +
l_get_shadow_root +
assumes get_host_impl: "get_host = a_get_host"
assumes get_host_locs_impl: "get_host_locs = a_get_host_locs"
begin
lemmas get_host_def = get_host_impl[unfolded a_get_host_def]
lemmas get_host_locs_def = get_host_locs_impl[unfolded a_get_host_locs_def]
lemma get_host_pure [simp]: "pure (get_host element_ptr) h"
by(auto simp add: get_host_def intro!: bind_pure_I filter_M_pure_I split: list.splits)
lemma get_host_reads: "reads get_host_locs (get_host element_ptr) h h'"
using get_shadow_root_reads[unfolded reads_def]
by(auto simp add: get_host_def get_host_locs_def intro!: reads_bind_pure
reads_subset[OF check_in_heap_reads] reads_subset[OF error_reads] reads_subset[OF get_shadow_root_reads]
reads_subset[OF return_reads] reads_subset[OF element_ptr_kinds_M_reads] filter_M_reads filter_M_pure_I
bind_pure_I split: list.splits)
end
locale l_get_host = l_get_host_defs +
assumes get_host_pure [simp]: "pure (get_host element_ptr) h"
assumes get_host_reads: "reads get_host_locs (get_host node_ptr) h h'"
interpretation i_get_host?: l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_shadow_root get_shadow_root_locs get_host
get_host_locs type_wf
using instances
by (simp add: l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_host_def get_host_locs_def)
declare l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_host_is_l_get_host [instances]: "l_get_host get_host get_host_locs"
apply(auto simp add: l_get_host_def)[1]
using get_host_reads apply fast
done
subsubsection \<open>get\_mode\<close>
locale l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
begin
definition a_get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
where
"a_get_mode shadow_root_ptr = get_M shadow_root_ptr mode"
definition a_get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
where
"a_get_mode_locs shadow_root_ptr \<equiv> {preserved (get_M shadow_root_ptr mode)}"
end
global_interpretation l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
defines get_mode = a_get_mode
and get_mode_locs = a_get_mode_locs
.
locale l_get_mode_defs =
fixes get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
fixes get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_mode_defs get_mode get_mode_locs +
l_type_wf type_wf
for get_mode :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, shadow_root_mode) prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf :: "(_) heap \<Rightarrow> bool" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_mode_impl: "get_mode = a_get_mode"
assumes get_mode_locs_impl: "get_mode_locs = a_get_mode_locs"
begin
lemmas get_mode_def = get_mode_impl[unfolded get_mode_def a_get_mode_def]
lemmas get_mode_locs_def = get_mode_locs_impl[unfolded get_mode_locs_def a_get_mode_locs_def]
lemma get_mode_ok: "type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (get_mode shadow_root_ptr)"
unfolding get_mode_def type_wf_impl
using ShadowRootMonad.get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ok by blast
lemma get_mode_pure [simp]: "pure (get_mode element_ptr) h"
unfolding get_mode_def by simp
lemma get_mode_ptr_in_heap:
assumes "h \<turnstile> get_mode shadow_root_ptr \<rightarrow>\<^sub>r children"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms
by(auto simp add: get_mode_def get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_ptr_in_heap dest: is_OK_returns_result_I)
lemma get_mode_reads: "reads (get_mode_locs element_ptr) (get_mode element_ptr) h h'"
by(simp add: get_mode_def get_mode_locs_def reads_bind_pure reads_insert_writes_set_right)
end
interpretation i_get_mode?: l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_mode get_mode_locs type_wf
using instances
by (auto simp add: l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_mode = l_type_wf + l_get_mode_defs +
assumes get_mode_reads: "reads (get_mode_locs shadow_root_ptr) (get_mode shadow_root_ptr) h h'"
assumes get_mode_ok: "type_wf h \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (get_mode shadow_root_ptr)"
assumes get_mode_ptr_in_heap: "h \<turnstile> ok (get_mode shadow_root_ptr) \<Longrightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
assumes get_mode_pure [simp]: "pure (get_mode shadow_root_ptr) h"
lemma get_mode_is_l_get_mode [instances]: "l_get_mode type_wf get_mode get_mode_locs"
apply(auto simp add: l_get_mode_def instances)[1]
using get_mode_reads apply blast
using get_mode_ok apply blast
using get_mode_ptr_in_heap apply blast
done
subsubsection \<open>get\_shadow\_root\_safe\<close>
locale l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_mode_defs get_mode get_mode_locs
for get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
where
"a_get_shadow_root_safe element_ptr = do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
mode \<leftarrow> get_mode shadow_root_ptr;
(if mode = Open then
return (Some shadow_root_ptr)
else
return None
)
} | None \<Rightarrow> return None)
}"
definition a_get_shadow_root_safe_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
where
"a_get_shadow_root_safe_locs element_ptr shadow_root_ptr \<equiv>
(get_shadow_root_locs element_ptr) \<union> (get_mode_locs shadow_root_ptr)"
end
global_interpretation l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs get_mode get_mode_locs
defines get_shadow_root_safe = a_get_shadow_root_safe
and get_shadow_root_safe_locs = a_get_shadow_root_safe_locs
.
locale l_get_shadow_root_safe_defs =
fixes get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
fixes get_shadow_root_safe_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_shadow_root get_shadow_root_locs get_mode get_mode_locs +
l_get_shadow_root_safe_defs get_shadow_root_safe get_shadow_root_safe_locs +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_get_mode type_wf get_mode get_mode_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_safe_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> (_, (_) shadow_root_ptr option) dom_prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> (_, shadow_root_mode) dom_prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
assumes get_shadow_root_safe_impl: "get_shadow_root_safe = a_get_shadow_root_safe"
assumes get_shadow_root_safe_locs_impl: "get_shadow_root_safe_locs = a_get_shadow_root_safe_locs"
begin
lemmas get_shadow_root_safe_def = get_shadow_root_safe_impl[unfolded get_shadow_root_safe_def
a_get_shadow_root_safe_def]
lemmas get_shadow_root_safe_locs_def = get_shadow_root_safe_locs_impl[unfolded get_shadow_root_safe_locs_def
a_get_shadow_root_safe_locs_def]
lemma get_shadow_root_safe_pure [simp]: "pure (get_shadow_root_safe element_ptr) h"
apply(auto simp add: get_shadow_root_safe_def)[1]
by (smt bind_returns_heap_E is_OK_returns_heap_E local.get_mode_pure local.get_shadow_root_pure
option.case_eq_if pure_def pure_returns_heap_eq return_pure)
end
interpretation i_get_shadow_root_safe?: l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root_safe
get_shadow_root_safe_locs get_shadow_root get_shadow_root_locs get_mode get_mode_locs
using instances
by (auto simp add: l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_shadow_root_safe_def get_shadow_root_safe_locs_def)
declare l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_shadow_root_safe = l_get_shadow_root_safe_defs +
assumes get_shadow_root_safe_pure [simp]: "pure (get_shadow_root_safe element_ptr) h"
lemma get_shadow_root_safe_is_l_get_shadow_root_safe [instances]: "l_get_shadow_root_safe get_shadow_root_safe"
using instances
apply(auto simp add: l_get_shadow_root_safe_def)[1]
done
subsubsection \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma set_disconnected_nodes_ok:
"type_wf h \<Longrightarrow> document_ptr |\<in>| document_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (set_disconnected_nodes document_ptr node_ptrs)"
using CD.set_disconnected_nodes_ok CD.type_wf_impl ShadowRootClass.type_wf_defs local.type_wf_impl
by blast
lemma set_disconnected_nodes_typess_preserved:
assumes "w \<in> set_disconnected_nodes_locs object_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
apply(unfold type_wf_impl)
by(auto simp add: all_args_def CD.set_disconnected_nodes_locs_def
intro: put_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t_disconnected_nodes_type_wf_preserved split: if_splits)
end
interpretation i_set_disconnected_nodes?: l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_disconnected_nodes set_disconnected_nodes_locs
by(auto simp add: l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_disconnected_nodes_is_l_set_disconnected_nodes [instances]:
"l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_def)[1]
apply (simp add: i_set_disconnected_nodes.set_disconnected_nodes_writes)
using set_disconnected_nodes_ok apply blast
apply (simp add: i_set_disconnected_nodes.set_disconnected_nodes_ptr_in_heap)
using i_set_disconnected_nodes.set_disconnected_nodes_pointers_preserved apply (blast, blast)
using set_disconnected_nodes_typess_preserved apply(blast, blast)
done
paragraph \<open>get\_child\_nodes\<close>
locale l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs +
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes
get_child_nodes_locs get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for type_wf :: "(_) heap \<Rightarrow> bool"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma set_disconnected_nodes_get_child_nodes:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_child_nodes_locs ptr'. r h h'))"
by(auto simp add: set_disconnected_nodes_locs_def get_child_nodes_locs_def CD.get_child_nodes_locs_def
all_args_def)
end
interpretation i_set_disconnected_nodes_get_child_nodes?: l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf set_disconnected_nodes set_disconnected_nodes_locs known_ptr DocumentClass.type_wf
DocumentClass.known_ptr get_child_nodes get_child_nodes_locs Core_DOM_Functions.get_child_nodes
Core_DOM_Functions.get_child_nodes_locs
by(auto simp add: l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_child_nodes_is_l_set_disconnected_nodes_get_child_nodes [instances]:
"l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes_locs get_child_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_child_nodes_def)[1]
using set_disconnected_nodes_get_child_nodes apply fast
done
paragraph \<open>get\_host\<close>
locale l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_host:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_host_locs. r h h'))"
by(auto simp add: CD.set_disconnected_nodes_locs_def get_shadow_root_locs_def get_host_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_host?: l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_host get_host_locs
by(auto simp add: l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_set_disconnected_nodes_get_host = l_set_disconnected_nodes_defs + l_get_host_defs +
assumes set_disconnected_nodes_get_host:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_host_locs. r h h'))"
lemma set_disconnected_nodes_get_host_is_l_set_disconnected_nodes_get_host [instances]:
"l_set_disconnected_nodes_get_host set_disconnected_nodes_locs get_host_locs"
apply(auto simp add: l_set_disconnected_nodes_get_host_def instances)[1]
using set_disconnected_nodes_get_host
by fast
subsubsection \<open>get\_tag\_name\<close>
locale l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_get_tag_name\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, tag_name) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma get_tag_name_ok:
"type_wf h \<Longrightarrow> element_ptr |\<in>| element_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_tag_name element_ptr)"
apply(unfold type_wf_impl get_tag_name_impl[unfolded a_get_tag_name_def])
using CD.get_tag_name_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
by blast
end
interpretation i_get_tag_name?: l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name get_tag_name_locs
by(auto simp add: l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_tag_name_is_l_get_tag_name [instances]: "l_get_tag_name type_wf get_tag_name get_tag_name_locs"
apply(auto simp add: l_get_tag_name_def)[1]
using get_tag_name_reads apply fast
using get_tag_name_ok apply fast
done
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_tag_name:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_disconnected_nodes_locs_def CD.get_tag_name_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_tag_name?: l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf DocumentClass.type_wf set_disconnected_nodes set_disconnected_nodes_locs get_tag_name
get_tag_name_locs
by(auto simp add: l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_disconnected_nodes_get_tag_name_is_l_set_disconnected_nodes_get_tag_name [instances]:
"l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs"
apply(auto simp add: l_set_disconnected_nodes_get_tag_name_def
l_set_disconnected_nodes_get_tag_name_axioms_def instances)[1]
using set_disconnected_nodes_get_tag_name
by fast
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_child_nodes_get_tag_name:
"\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_child_nodes_locs_def set_child_nodes_locs_def CD.get_tag_name_locs_def
all_args_def intro: element_put_get_preserved[where getter=tag_name and setter=RElement.child_nodes_update])
end
interpretation i_set_child_nodes_get_tag_name?: l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr
DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_tag_name get_tag_name_locs
by(auto simp add: l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_child_nodes_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma set_child_nodes_get_tag_name_is_l_set_child_nodes_get_tag_name [instances]:
"l_set_child_nodes_get_tag_name type_wf set_child_nodes set_child_nodes_locs get_tag_name get_tag_name_locs"
apply(auto simp add: l_set_child_nodes_get_tag_name_def l_set_child_nodes_get_tag_name_axioms_def instances)[1]
using set_child_nodes_get_tag_name
by fast
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_tag_name_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_delete_shadow_root: "h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by(auto simp add: l_delete_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_tag_name_get_tag_name_locs [instances]: "l_delete_shadow_root_get_tag_name get_tag_name_locs"
apply(auto simp add: l_delete_shadow_root_get_tag_name_def)[1]
using get_tag_name_delete_shadow_root apply fast
done
paragraph \<open>set\_shadow\_root\<close>
locale l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_tag_name:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def CD.get_tag_name_locs_def all_args_def element_put_get_preserved[where setter=shadow_root_opt_update])
end
interpretation
i_set_shadow_root_get_tag_name?: l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root
set_shadow_root_locs DocumentClass.type_wf get_tag_name get_tag_name_locs
apply(auto simp add: l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_tag_name = l_set_shadow_root_defs + l_get_tag_name_defs +
assumes set_shadow_root_get_tag_name: "\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
lemma set_shadow_root_get_tag_name_is_l_set_shadow_root_get_tag_name [instances]:
"l_set_shadow_root_get_tag_name set_shadow_root_locs get_tag_name_locs"
using set_shadow_root_is_l_set_shadow_root get_tag_name_is_l_get_tag_name
apply(simp add: l_set_shadow_root_get_tag_name_def )
using set_shadow_root_get_tag_name
by fast
paragraph \<open>new\_element\<close>
locale l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, tag_name) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: CD.get_tag_name_locs_def new_element_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_element_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
new_element_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
lemma new_element_empty_tag_name:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
by(simp add: CD.get_tag_name_def new_element_tag_name)
end
locale l_new_element_get_tag_name = l_new_element + l_get_tag_name +
assumes get_tag_name_new_element:
"ptr' \<noteq> new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr
\<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
assumes new_element_empty_tag_name:
"h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr \<Longrightarrow> h \<turnstile> new_element \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
interpretation i_new_element_get_tag_name?:
l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name get_tag_name_locs
by(auto simp add: l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_new_element_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_element_get_tag_name_is_l_new_element_get_tag_name [instances]:
"l_new_element_get_tag_name type_wf get_tag_name get_tag_name_locs"
using new_element_is_l_new_element get_tag_name_is_l_get_tag_name
apply(auto simp add: l_new_element_get_tag_name_def l_new_element_get_tag_name_axioms_def instances)[1]
using get_tag_name_new_element new_element_empty_tag_name
by fast+
paragraph \<open>get\_shadow\_root\<close>
locale l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_tag_name:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def CD.get_tag_name_locs_def all_args_def)
end
interpretation
i_set_mode_get_tag_name?: l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_set_mode_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_tag_name = l_set_mode + l_get_tag_name +
assumes set_mode_get_tag_name:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
lemma set_mode_get_tag_name_is_l_set_mode_get_tag_name [instances]:
"l_set_mode_get_tag_name type_wf set_mode set_mode_locs get_tag_name
get_tag_name_locs"
using set_mode_is_l_set_mode get_tag_name_is_l_get_tag_name
apply(simp add: l_set_mode_get_tag_name_def
l_set_mode_get_tag_name_axioms_def)
using set_mode_get_tag_name
by fast
paragraph \<open>new\_document\<close>
locale l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, tag_name) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_new_document_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_new_document:
"h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr \<Longrightarrow> h \<turnstile> new_document \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_document_get_tag_name?:
l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_new_document_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
lemma new_document_get_tag_name_is_l_new_document_get_tag_name [instances]:
"l_new_document_get_tag_name get_tag_name_locs"
unfolding l_new_document_get_tag_name_def
unfolding get_tag_name_locs_def
using new_document_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_tag_name_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by (auto simp add: CD.get_tag_name_locs_def new_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t new_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
split: prod.splits if_splits option.splits
elim!: bind_returns_result_E bind_returns_heap_E intro: is_element_ptr_kind_obtains)
end
locale l_new_shadow_root_get_tag_name = l_get_tag_name +
assumes get_tag_name_new_shadow_root:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_shadow_root_get_tag_name?:
l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name get_tag_name_locs
by(unfold_locales)
declare l_new_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma new_shadow_root_get_tag_name_is_l_new_shadow_root_get_tag_name [instances]:
"l_new_shadow_root_get_tag_name type_wf get_tag_name get_tag_name_locs"
using get_tag_name_is_l_get_tag_name
apply(auto simp add: l_new_shadow_root_get_tag_name_def l_new_shadow_root_get_tag_name_axioms_def instances)[1]
using get_tag_name_new_shadow_root
by fast
paragraph \<open>new\_character\_data\<close>
locale l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_tag_name get_tag_name_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, tag_name) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_tag_name_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_tag_name_locs_def new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_new_character_data_get_tag_name = l_get_tag_name_defs +
assumes get_tag_name_new_character_data:
"h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr \<Longrightarrow> h \<turnstile> new_character_data \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_tag_name_locs ptr' \<Longrightarrow> r h h'"
interpretation i_new_character_data_get_tag_name?:
l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs
by unfold_locales
declare l_new_character_data_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def[instances]
lemma new_character_data_get_tag_name_is_l_new_character_data_get_tag_name [instances]:
"l_new_character_data_get_tag_name get_tag_name_locs"
unfolding l_new_character_data_get_tag_name_def
unfolding get_tag_name_locs_def
using new_character_data_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t by blast
paragraph \<open>get\_tag\_type\<close>
locale l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M = l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_tag_name:
assumes "h \<turnstile> CD.a_set_tag_name element_ptr tag \<rightarrow>\<^sub>h h'"
shows "h' \<turnstile> CD.a_get_tag_name element_ptr \<rightarrow>\<^sub>r tag"
using assms
by(auto simp add: CD.a_get_tag_name_def CD.a_set_tag_name_def)
lemma set_tag_name_get_tag_name_different_pointers:
assumes "ptr \<noteq> ptr'"
assumes "w \<in> CD.a_set_tag_name_locs ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> CD.a_get_tag_name_locs ptr'"
shows "r h h'"
using assms
by(auto simp add: all_args_def CD.a_set_tag_name_locs_def CD.a_get_tag_name_locs_def
split: if_splits option.splits )
end
interpretation i_set_tag_name_get_tag_name?:
l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_tag_name
get_tag_name_locs set_tag_name set_tag_name_locs
by unfold_locales
declare l_set_tag_name_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_tag_name_is_l_set_tag_name_get_tag_name [instances]:
"l_set_tag_name_get_tag_name type_wf get_tag_name get_tag_name_locs
set_tag_name set_tag_name_locs"
using set_tag_name_is_l_set_tag_name get_tag_name_is_l_get_tag_name
apply(simp add: l_set_tag_name_get_tag_name_def
l_set_tag_name_get_tag_name_axioms_def)
using set_tag_name_get_tag_name
set_tag_name_get_tag_name_different_pointers
by fast+
subsubsection \<open>attach\_shadow\_root\<close>
locale l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_set_mode_defs set_mode set_mode_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, unit) prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, char list) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_attach_shadow_root :: "(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
where
"a_attach_shadow_root element_ptr shadow_root_mode = do {
tag \<leftarrow> get_tag_name element_ptr;
(if tag \<notin> safe_shadow_root_element_types then error HierarchyRequestError else return ());
prev_shadow_root \<leftarrow> get_shadow_root element_ptr;
(if prev_shadow_root \<noteq> None then error HierarchyRequestError else return ());
new_shadow_root_ptr \<leftarrow> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M;
set_mode new_shadow_root_ptr shadow_root_mode;
set_shadow_root element_ptr (Some new_shadow_root_ptr);
return new_shadow_root_ptr
}"
end
locale l_attach_shadow_root_defs =
fixes attach_shadow_root :: "(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
global_interpretation l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_shadow_root set_shadow_root_locs set_mode
set_mode_locs get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs
defines attach_shadow_root = a_attach_shadow_root
.
locale l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs set_shadow_root set_shadow_root_locs set_mode set_mode_locs get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs +
l_attach_shadow_root_defs attach_shadow_root +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf set_shadow_root set_shadow_root_locs +
l_set_mode type_wf set_mode set_mode_locs +
l_get_tag_name type_wf get_tag_name get_tag_name_locs +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_known_ptr known_ptr
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, unit) prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and attach_shadow_root :: "(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr) prog"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_tag_name :: "(_) element_ptr \<Rightarrow> (_, char list) dom_prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
assumes attach_shadow_root_impl: "attach_shadow_root = a_attach_shadow_root"
begin
lemmas attach_shadow_root_def = a_attach_shadow_root_def[folded attach_shadow_root_impl]
lemma attach_shadow_root_element_ptr_in_heap:
assumes "h \<turnstile> ok (attach_shadow_root element_ptr shadow_root_mode)"
shows "element_ptr |\<in>| element_ptr_kinds h"
proof -
obtain h' where "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>h h'"
using assms by auto
then
obtain h2 h3 new_shadow_root_ptr where
h2: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2" and
new_shadow_root_ptr: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr" and
h3: "h2 \<turnstile> set_mode new_shadow_root_ptr shadow_root_mode \<rightarrow>\<^sub>h h3" and
"h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'"
by(auto simp add: attach_shadow_root_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
then have "element_ptr |\<in>| element_ptr_kinds h3"
using set_shadow_root_ptr_in_heap by blast
moreover
have "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr new_shadow_root_ptr by auto
moreover
have "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_mode_writes h3])
using set_mode_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
ultimately
show ?thesis
by (metis (no_types, lifting) cast_document_ptr_not_node_ptr(2) element_ptr_kinds_commutes
finsertE funion_finsert_right node_ptr_kinds_commutes sup_bot.right_neutral)
qed
lemma create_shadow_root_known_ptr:
assumes "h \<turnstile> attach_shadow_root element_ptr shadow_root_mode \<rightarrow>\<^sub>r new_shadow_root_ptr"
shows "known_ptr (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr)"
using assms
by(auto simp add: attach_shadow_root_def known_ptr_impl ShadowRootClass.a_known_ptr_def
new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_def new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_def Let_def elim!: bind_returns_result_E)
end
locale l_attach_shadow_root = l_attach_shadow_root_defs
interpretation
i_attach_shadow_root?: l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr set_shadow_root set_shadow_root_locs
set_mode set_mode_locs attach_shadow_root type_wf get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs
by(auto simp add: l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
attach_shadow_root_def instances)
declare l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_parent\<close>
global_interpretation l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
defines get_parent = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent get_child_nodes"
and get_parent_locs = "l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_parent_locs get_child_nodes_locs"
.
interpretation i_get_parent?: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs
by(simp add: l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_parent_def
get_parent_locs_def instances)
declare l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_parent_is_l_get_parent [instances]: "l_get_parent type_wf known_ptr known_ptrs get_parent
get_parent_locs get_child_nodes get_child_nodes_locs"
apply(simp add: l_get_parent_def l_get_parent_axioms_def instances)
using get_parent_reads get_parent_ok get_parent_ptr_in_heap get_parent_pure get_parent_parent_in_heap get_parent_child_dual
using get_parent_reads_pointers
by blast
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_child_nodes
+ l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_disconnected_nodes_get_parent [simp]: "\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_parent_locs. r h h'))"
by(auto simp add: get_parent_locs_def CD.set_disconnected_nodes_locs_def all_args_def)
end
interpretation i_set_disconnected_nodes_get_parent?:
l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_disconnected_nodes set_disconnected_nodes_locs
get_child_nodes get_child_nodes_locs type_wf DocumentClass.type_wf known_ptr known_ptrs get_parent
get_parent_locs
by (simp add: l_set_disconnected_nodes_get_parent\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_parent_is_l_set_disconnected_nodes_get_parent [instances]:
"l_set_disconnected_nodes_get_parent set_disconnected_nodes_locs get_parent_locs"
by(simp add: l_set_disconnected_nodes_get_parent_def)
subsubsection \<open>get\_root\_node\<close>
global_interpretation l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs
defines get_root_node = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node get_parent"
and get_root_node_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_root_node_locs get_parent_locs"
and get_ancestors = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors get_parent"
and get_ancestors_locs = "l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_ancestors_locs get_parent_locs"
.
declare a_get_ancestors.simps [code]
interpretation i_get_root_node?: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_ancestors get_ancestors_locs get_root_node
get_root_node_locs
by(simp add: l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_root_node_def
get_root_node_locs_def get_ancestors_def get_ancestors_locs_def instances)
declare l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_ancestors_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors"
apply(auto simp add: l_get_ancestors_def)[1]
using get_ancestors_ptr_in_heap apply fast
using get_ancestors_ptr apply fast
done
lemma get_root_node_is_l_get_root_node [instances]: "l_get_root_node get_root_node get_parent"
by (simp add: l_get_root_node_def Shadow_DOM.i_get_root_node.get_root_node_no_parent)
subsubsection \<open>get\_root\_node\_si\<close>
locale l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_parent_defs get_parent get_parent_locs +
l_get_host_defs get_host get_host_locs
for get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_::linorder) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
partial_function (dom_prog) a_get_ancestors_si :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_get_ancestors_si ptr = do {
check_in_heap ptr;
ancestors \<leftarrow> (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of
Some node_ptr \<Rightarrow> do {
parent_ptr_opt \<leftarrow> get_parent node_ptr;
(case parent_ptr_opt of
Some parent_ptr \<Rightarrow> a_get_ancestors_si parent_ptr
| None \<Rightarrow> return [])
}
| None \<Rightarrow> (case cast ptr of
Some shadow_root_ptr \<Rightarrow> do {
host \<leftarrow> get_host shadow_root_ptr;
a_get_ancestors_si (cast host)
} |
None \<Rightarrow> return []));
return (ptr # ancestors)
}"
definition "a_get_ancestors_si_locs = get_parent_locs \<union> get_host_locs"
definition a_get_root_node_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr) dom_prog"
where
"a_get_root_node_si ptr = do {
ancestors \<leftarrow> a_get_ancestors_si ptr;
return (last ancestors)
}"
definition "a_get_root_node_si_locs = a_get_ancestors_si_locs"
end
locale l_get_ancestors_si_defs =
fixes get_ancestors_si :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
fixes get_ancestors_si_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_root_node_si_defs =
fixes get_root_node_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr) dom_prog"
fixes get_root_node_si_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent +
l_get_host +
l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_ancestors_si_defs +
l_get_root_node_si_defs +
assumes get_ancestors_si_impl: "get_ancestors_si = a_get_ancestors_si"
assumes get_ancestors_si_locs_impl: "get_ancestors_si_locs = a_get_ancestors_si_locs"
assumes get_root_node_si_impl: "get_root_node_si = a_get_root_node_si"
assumes get_root_node_si_locs_impl: "get_root_node_si_locs = a_get_root_node_si_locs"
begin
lemmas get_ancestors_si_def = a_get_ancestors_si.simps[folded get_ancestors_si_impl]
lemmas get_ancestors_si_locs_def = a_get_ancestors_si_locs_def[folded get_ancestors_si_locs_impl]
lemmas get_root_node_si_def = a_get_root_node_si_def[folded get_root_node_si_impl get_ancestors_si_impl]
lemmas get_root_node_si_locs_def =
a_get_root_node_si_locs_def[folded get_root_node_si_locs_impl get_ancestors_si_locs_impl]
lemma get_ancestors_si_pure [simp]:
"pure (get_ancestors_si ptr) h"
proof -
have "\<forall>ptr h h' x. h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r x \<longrightarrow> h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>h h' \<longrightarrow> h = h'"
proof (induct rule: a_get_ancestors_si.fixp_induct[folded get_ancestors_si_impl])
case 1
then show ?case
by(rule admissible_dom_prog)
next
case 2
then show ?case
by simp
next
case (3 f)
then show ?case
using get_parent_pure get_host_pure
apply(auto simp add: pure_returns_heap_eq pure_def split: option.splits
elim!: bind_returns_heap_E bind_returns_result_E
dest!: pure_returns_heap_eq[rotated, OF check_in_heap_pure])[1]
apply (meson option.simps(3) returns_result_eq)
apply(metis get_parent_pure pure_returns_heap_eq)
apply(metis get_host_pure pure_returns_heap_eq)
done
qed
then show ?thesis
by (meson pure_eq_iff)
qed
lemma get_root_node_si_pure [simp]: "pure (get_root_node_si ptr) h"
by(auto simp add: get_root_node_si_def bind_pure_I)
lemma get_ancestors_si_ptr_in_heap:
assumes "h \<turnstile> ok (get_ancestors_si ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_ancestors_si_def check_in_heap_ptr_in_heap elim!: bind_is_OK_E
dest: is_OK_returns_result_I)
lemma get_ancestors_si_ptr:
assumes "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
shows "ptr \<in> set ancestors"
using assms
by(simp add: get_ancestors_si_def) (auto elim!: bind_returns_result_E2 split: option.splits
intro!: bind_pure_I)
lemma get_ancestors_si_never_empty:
assumes "h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors"
shows "ancestors \<noteq> []"
using assms
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits)
(*
lemma get_ancestors_si_not_node:
assumes "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
assumes "\<not>is_node_ptr_kind ptr"
shows "ancestors = [ptr]"
using assms
by (simp add: get_ancestors_si_def) (auto elim!: bind_returns_result_E2 split: option.splits)
*)
lemma get_root_node_si_no_parent:
"h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None \<Longrightarrow> h \<turnstile> get_root_node_si (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
apply(auto simp add: check_in_heap_def get_root_node_si_def get_ancestors_si_def
intro!: bind_pure_returns_result_I )[1]
using get_parent_ptr_in_heap by blast
lemma get_root_node_si_root_not_shadow_root:
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root"
shows "\<not> is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root"
using assms
proof(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)
fix y
assume "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r y"
and "is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (last y)"
and "root = last y"
then
show False
proof(induct y arbitrary: ptr)
case Nil
then show ?case
using assms(1) get_ancestors_si_never_empty by blast
next
case (Cons a x)
then show ?case
apply(auto simp add: get_ancestors_si_def[of ptr] elim!: bind_returns_result_E2
split: option.splits if_splits)[1]
using get_ancestors_si_never_empty apply blast
using Cons.prems(2) apply auto[1]
using \<open>is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (last y)\<close> \<open>root = last y\<close> by auto
qed
qed
end
global_interpretation l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_host get_host_locs
defines get_root_node_si = a_get_root_node_si
and get_root_node_si_locs = a_get_root_node_si_locs
and get_ancestors_si = a_get_ancestors_si
and get_ancestors_si_locs = a_get_ancestors_si_locs
.
declare a_get_ancestors_si.simps [code]
interpretation
i_get_root_node_si?: l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs get_parent
get_parent_locs get_child_nodes get_child_nodes_locs get_host get_host_locs get_ancestors_si
get_ancestors_si_locs get_root_node_si get_root_node_si_locs
apply(auto simp add: l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)[1]
by(auto simp add: get_root_node_si_def get_root_node_si_locs_def get_ancestors_si_def get_ancestors_si_locs_def)
declare l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_si_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors_si"
unfolding l_get_ancestors_def
using get_ancestors_si_pure get_ancestors_si_ptr get_ancestors_si_ptr_in_heap
by blast
lemma get_root_node_si_is_l_get_root_node [instances]: "l_get_root_node get_root_node_si get_parent"
apply(simp add: l_get_root_node_def)
using get_root_node_si_no_parent
by fast
paragraph \<open>set\_disconnected\_nodes\<close>
locale l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_parent
+ l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_set_disconnected_nodes_get_host
begin
lemma set_disconnected_nodes_get_ancestors_si:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_ancestors_si_locs. r h h'))"
by(auto simp add: get_parent_locs_def set_disconnected_nodes_locs_def
set_disconnected_nodes_get_host get_ancestors_si_locs_def all_args_def)
end
locale l_set_disconnected_nodes_get_ancestors_si = l_set_disconnected_nodes_defs + l_get_ancestors_si_defs +
assumes set_disconnected_nodes_get_ancestors_si:
"\<forall>w \<in> set_disconnected_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_ancestors_si_locs. r h h'))"
interpretation
i_set_disconnected_nodes_get_ancestors_si?: l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
set_disconnected_nodes set_disconnected_nodes_locs get_parent get_parent_locs type_wf known_ptr
known_ptrs get_child_nodes get_child_nodes_locs get_host get_host_locs get_ancestors_si
get_ancestors_si_locs get_root_node_si get_root_node_si_locs DocumentClass.type_wf
by (auto simp add: l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_set_disconnected_nodes_get_ancestors_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_ancestors_si_is_l_set_disconnected_nodes_get_ancestors_si [instances]:
"l_set_disconnected_nodes_get_ancestors_si set_disconnected_nodes_locs get_ancestors_si_locs"
using instances
apply(simp add: l_set_disconnected_nodes_get_ancestors_si_def)
using set_disconnected_nodes_get_ancestors_si
by fast
subsubsection \<open>get\_attribute\<close>
lemma get_attribute_is_l_get_attribute [instances]: "l_get_attribute type_wf get_attribute get_attribute_locs"
apply(auto simp add: l_get_attribute_def)[1]
using i_get_attribute.get_attribute_reads apply fast
using type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t i_get_attribute.get_attribute_ok apply blast
using i_get_attribute.get_attribute_ptr_in_heap apply fast
done
subsubsection \<open>to\_tree\_order\<close>
global_interpretation l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs defines
to_tree_order = "l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_to_tree_order get_child_nodes" .
declare a_to_tree_order.simps [code]
interpretation i_to_tree_order?: l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ShadowRootClass.known_ptr
ShadowRootClass.type_wf Shadow_DOM.get_child_nodes Shadow_DOM.get_child_nodes_locs to_tree_order
by(auto simp add: l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def to_tree_order_def instances)
declare l_to_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>to\_tree\_order\_si\<close>
locale l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
partial_function (dom_prog) a_to_tree_order_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_to_tree_order_si ptr = (do {
children \<leftarrow> get_child_nodes ptr;
shadow_root_part \<leftarrow> (case cast ptr of
Some element_ptr \<Rightarrow> do {
shadow_root_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_opt of
Some shadow_root_ptr \<Rightarrow> return [cast shadow_root_ptr]
| None \<Rightarrow> return [])
} |
None \<Rightarrow> return []);
treeorders \<leftarrow> map_M a_to_tree_order_si ((map (cast) children) @ shadow_root_part);
return (ptr # concat treeorders)
})"
end
locale l_to_tree_order_si_defs =
fixes to_tree_order_si :: "(_) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
global_interpretation l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs
defines to_tree_order_si = "a_to_tree_order_si" .
declare a_to_tree_order_si.simps [code]
locale l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_to_tree_order_si_defs +
l_to_tree_order_si\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_child_nodes +
l_get_shadow_root +
assumes to_tree_order_si_impl: "to_tree_order_si = a_to_tree_order_si"
begin
lemmas to_tree_order_si_def = a_to_tree_order_si.simps[folded to_tree_order_si_impl]
lemma to_tree_order_si_pure [simp]: "pure (to_tree_order_si ptr) h"
proof -
have "\<forall>ptr h h' x. h \<turnstile> to_tree_order_si ptr \<rightarrow>\<^sub>r x \<longrightarrow> h \<turnstile> to_tree_order_si ptr \<rightarrow>\<^sub>h h' \<longrightarrow> h = h'"
proof (induct rule: a_to_tree_order_si.fixp_induct[folded to_tree_order_si_impl])
case 1
then show ?case
by (rule admissible_dom_prog)
next
case 2
then show ?case
by simp
next
case (3 f)
then have "\<And>x h. pure (f x) h"
by (metis is_OK_returns_heap_E is_OK_returns_result_E pure_def)
then have "\<And>xs h. pure (map_M f xs) h"
by(rule map_M_pure_I)
then show ?case
by(auto elim!: bind_returns_heap_E2 split: option.splits)
qed
then show ?thesis
unfolding pure_def
by (metis is_OK_returns_heap_E is_OK_returns_result_E)
qed
end
interpretation i_to_tree_order_si?: l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order_si get_child_nodes
get_child_nodes_locs get_shadow_root get_shadow_root_locs type_wf known_ptr
by(auto simp add: l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
to_tree_order_si_def instances)
declare l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>first\_in\_tree\_order\<close>
global_interpretation l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order defines
first_in_tree_order = "l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_first_in_tree_order to_tree_order" .
interpretation i_first_in_tree_order?: l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order
by(auto simp add: l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def first_in_tree_order_def)
declare l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_is_l_to_tree_order [instances]: "l_to_tree_order to_tree_order"
by(auto simp add: l_to_tree_order_def)
subsubsection \<open>first\_in\_tree\_order\<close>
global_interpretation l_dummy defines
first_in_tree_order_si = "l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_first_in_tree_order to_tree_order_si"
.
subsubsection \<open>get\_element\_by\<close>
global_interpretation l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs to_tree_order first_in_tree_order get_attribute get_attribute_locs defines
get_element_by_id = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_element_by_id first_in_tree_order get_attribute" and
get_elements_by_class_name = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_class_name to_tree_order get_attribute" and
get_elements_by_tag_name = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_tag_name to_tree_order" .
interpretation
i_get_element_by?: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M to_tree_order first_in_tree_order get_attribute
get_attribute_locs get_element_by_id get_elements_by_class_name
get_elements_by_tag_name type_wf
by(auto simp add: l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_element_by_id_def
get_elements_by_class_name_def get_elements_by_tag_name_def instances)
declare l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_element_by_is_l_get_element_by [instances]: "l_get_element_by get_element_by_id get_elements_by_tag_name to_tree_order"
apply(auto simp add: l_get_element_by_def)[1]
using get_element_by_id_result_in_tree_order apply fast
done
subsubsection \<open>get\_element\_by\_si\<close>
global_interpretation l_dummy defines
get_element_by_id_si = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_element_by_id first_in_tree_order_si get_attribute" and
get_elements_by_class_name_si = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_class_name to_tree_order_si get_attribute" and
get_elements_by_tag_name_si = "l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_elements_by_tag_name to_tree_order_si"
.
subsubsection \<open>find\_slot\<close>
locale l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_parent_defs get_parent get_parent_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_mode_defs get_mode get_mode_locs +
l_get_attribute_defs get_attribute get_attribute_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_first_in_tree_order_defs first_in_tree_order
for get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_::linorder) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_mode :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, shadow_root_mode) prog"
and get_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_attribute :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, char list option) prog"
and get_attribute_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and first_in_tree_order ::
"(_) object_ptr \<Rightarrow> ((_) object_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog) \<Rightarrow>
((_) heap, exception, (_) element_ptr option) prog"
begin
definition a_find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
where
"a_find_slot open_flag slotable = do {
parent_opt \<leftarrow> get_parent slotable;
(case parent_opt of
Some parent \<Rightarrow>
if is_element_ptr_kind parent
then do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root (the (cast parent));
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
shadow_root_mode \<leftarrow> get_mode shadow_root_ptr;
if open_flag \<and> shadow_root_mode \<noteq> Open
then return None
else first_in_tree_order (cast shadow_root_ptr) (\<lambda>ptr. if is_element_ptr_kind ptr
then do {
tag \<leftarrow> get_tag_name (the (cast ptr));
name_attr \<leftarrow> get_attribute (the (cast ptr)) ''name'';
slotable_name_attr \<leftarrow> (if is_element_ptr_kind slotable
then get_attribute (the (cast slotable)) ''slot'' else return None);
(if (tag = ''slot'' \<and> (name_attr = slotable_name_attr \<or>
(name_attr = None \<and> slotable_name_attr = Some '''') \<or>
(name_attr = Some '''' \<and> slotable_name_attr = None)))
then return (Some (the (cast ptr)))
else return None)}
else return None)}
| None \<Rightarrow> return None)}
else return None
| _ \<Rightarrow> return None)}"
definition a_assigned_slot :: "(_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
where
"a_assigned_slot = a_find_slot True"
end
global_interpretation l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_shadow_root
get_shadow_root_locs get_mode get_mode_locs get_attribute get_attribute_locs get_tag_name
get_tag_name_locs first_in_tree_order
defines find_slot = a_find_slot
and assigned_slot = a_assigned_slot
.
locale l_find_slot_defs =
fixes find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> (_, (_) element_ptr option) dom_prog"
locale l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_find_slot_defs +
l_get_parent +
l_get_shadow_root +
l_get_mode +
l_get_attribute +
l_get_tag_name +
l_to_tree_order +
l_first_in_tree_order\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
assumes find_slot_impl: "find_slot = a_find_slot"
assumes assigned_slot_impl: "assigned_slot = a_assigned_slot"
begin
lemmas find_slot_def = find_slot_impl[unfolded a_find_slot_def]
lemmas assigned_slot_def = assigned_slot_impl[unfolded a_assigned_slot_def]
lemma find_slot_ptr_in_heap:
assumes "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r slot_opt"
shows "slotable |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: find_slot_def elim!: bind_returns_result_E2)[1]
using get_parent_ptr_in_heap by blast
lemma find_slot_slot_in_heap:
assumes "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r Some slot"
shows "slot |\<in>| element_ptr_kinds h"
using assms
apply(auto simp add: find_slot_def first_in_tree_order_def elim!: bind_returns_result_E2
map_filter_M_pure_E[where y=slot] split: option.splits if_splits list.splits intro!: map_filter_M_pure
bind_pure_I)[1]
using get_tag_name_ptr_in_heap by blast+
lemma find_slot_pure [simp]: "pure (find_slot open_flag slotable) h"
by(auto simp add: find_slot_def first_in_tree_order_def intro!: bind_pure_I map_filter_M_pure
split: option.splits list.splits)
end
interpretation i_find_slot?: l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_shadow_root
get_shadow_root_locs get_mode get_mode_locs get_attribute get_attribute_locs get_tag_name
get_tag_name_locs first_in_tree_order find_slot assigned_slot type_wf known_ptr known_ptrs
get_child_nodes get_child_nodes_locs to_tree_order
by (auto simp add: find_slot_def assigned_slot_def l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_find_slot\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_find_slot = l_find_slot_defs +
assumes find_slot_ptr_in_heap: "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r slot_opt \<Longrightarrow> slotable |\<in>| node_ptr_kinds h"
assumes find_slot_slot_in_heap: "h \<turnstile> find_slot open_flag slotable \<rightarrow>\<^sub>r Some slot \<Longrightarrow> slot |\<in>| element_ptr_kinds h"
assumes find_slot_pure [simp]: "pure (find_slot open_flag slotable) h"
lemma find_slot_is_l_find_slot [instances]: "l_find_slot find_slot"
apply(auto simp add: l_find_slot_def)[1]
using find_slot_ptr_in_heap apply fast
using find_slot_slot_in_heap apply fast
done
subsubsection \<open>get\_disconnected\_nodes\<close>
locale l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma get_disconnected_nodes_ok:
"type_wf h \<Longrightarrow> document_ptr |\<in>| document_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_disconnected_nodes document_ptr)"
apply(unfold type_wf_impl get_disconnected_nodes_impl[unfolded a_get_disconnected_nodes_def])
using CD.get_disconnected_nodes_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t
by blast
end
interpretation i_get_disconnected_nodes?: l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_disconnected_nodes_is_l_get_disconnected_nodes [instances]:
"l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs"
apply(auto simp add: l_get_disconnected_nodes_def)[1]
using i_get_disconnected_nodes.get_disconnected_nodes_reads apply fast
using get_disconnected_nodes_ok apply fast
using i_get_disconnected_nodes.get_disconnected_nodes_ptr_in_heap apply fast
done
paragraph \<open>set\_child\_nodes\<close>
locale l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_child_nodes_get_disconnected_nodes:
"\<forall>w \<in> set_child_nodes_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_child_nodes_locs_def CD.set_child_nodes_locs_def
CD.get_disconnected_nodes_locs_def all_args_def elim: get_M_document_put_M_shadow_root
split: option.splits)
end
interpretation
i_set_child_nodes_get_disconnected_nodes?: l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
known_ptr DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
apply(auto simp add: l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_child_nodes_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_child_nodes_get_disconnected_nodes_is_l_set_child_nodes_get_disconnected_nodes [instances]:
"l_set_child_nodes_get_disconnected_nodes type_wf set_child_nodes set_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs"
using set_child_nodes_is_l_set_child_nodes get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_child_nodes_get_disconnected_nodes_def l_set_child_nodes_get_disconnected_nodes_axioms_def )
using set_child_nodes_get_disconnected_nodes
by fast
paragraph \<open>set\_disconnected\_nodes\<close>
lemma set_disconnected_nodes_get_disconnected_nodes_l_set_disconnected_nodes_get_disconnected_nodes [instances]:
"l_set_disconnected_nodes_get_disconnected_nodes ShadowRootClass.type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_def
l_set_disconnected_nodes_get_disconnected_nodes_axioms_def instances)[1]
using i_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
apply fast
using i_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes_different_pointers
apply fast
done
paragraph \<open>delete\_shadow\_root\<close>
locale l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_disconnected_nodes_delete_shadow_root:
"cast shadow_root_ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_disconnected_nodes_locs_def delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
end
locale l_delete_shadow_root_get_disconnected_nodes = l_get_disconnected_nodes_defs +
assumes get_disconnected_nodes_delete_shadow_root:
"cast shadow_root_ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M shadow_root_ptr \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
interpretation l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_delete_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
lemma l_delete_shadow_root_get_disconnected_nodes_get_disconnected_nodes_locs [instances]: "l_delete_shadow_root_get_disconnected_nodes get_disconnected_nodes_locs"
apply(auto simp add: l_delete_shadow_root_get_disconnected_nodes_def)[1]
using get_disconnected_nodes_delete_shadow_root apply fast
done
paragraph \<open>set\_shadow\_root\<close>
locale l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_shadow_root_get_disconnected_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_shadow_root_locs_def CD.get_disconnected_nodes_locs_def all_args_def)
end
interpretation
i_set_shadow_root_get_disconnected_nodes?: l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_shadow_root set_shadow_root_locs DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs
apply(auto simp add: l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
by(unfold_locales)
declare l_set_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_shadow_root_get_disconnected_nodes = l_set_shadow_root_defs + l_get_disconnected_nodes_defs +
assumes set_shadow_root_get_disconnected_nodes:
"\<forall>w \<in> set_shadow_root_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
lemma set_shadow_root_get_disconnected_nodes_is_l_set_shadow_root_get_disconnected_nodes [instances]:
"l_set_shadow_root_get_disconnected_nodes set_shadow_root_locs get_disconnected_nodes_locs"
using set_shadow_root_is_l_set_shadow_root get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_shadow_root_get_disconnected_nodes_def )
using set_shadow_root_get_disconnected_nodes
by fast
paragraph \<open>set\_mode\<close>
locale l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_mode\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_mode_get_disconnected_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: set_mode_locs_def
CD.get_disconnected_nodes_locs_impl[unfolded CD.a_get_disconnected_nodes_locs_def]
all_args_def)
end
interpretation
i_set_mode_get_disconnected_nodes?: l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
set_mode set_mode_locs DocumentClass.type_wf get_disconnected_nodes
get_disconnected_nodes_locs
by unfold_locales
declare l_set_mode_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_set_mode_get_disconnected_nodes = l_set_mode + l_get_disconnected_nodes +
assumes set_mode_get_disconnected_nodes:
"\<forall>w \<in> set_mode_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
lemma set_mode_get_disconnected_nodes_is_l_set_mode_get_disconnected_nodes [instances]:
"l_set_mode_get_disconnected_nodes type_wf set_mode set_mode_locs get_disconnected_nodes
get_disconnected_nodes_locs"
using set_mode_is_l_set_mode get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_mode_get_disconnected_nodes_def
l_set_mode_get_disconnected_nodes_axioms_def)
using set_mode_get_disconnected_nodes
by fast
paragraph \<open>new\_shadow\_root\<close>
locale l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma get_disconnected_nodes_new_shadow_root_different_pointers:
"cast new_shadow_root_ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
by(auto simp add: CD.get_disconnected_nodes_locs_def new_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t)
lemma new_shadow_root_no_disconnected_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
by(simp add: CD.get_disconnected_nodes_def new_shadow_root_disconnected_nodes)
end
interpretation i_new_shadow_root_get_disconnected_nodes?:
l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf get_disconnected_nodes
get_disconnected_nodes_locs
by unfold_locales
declare l_new_shadow_root_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
locale l_new_shadow_root_get_disconnected_nodes = l_get_disconnected_nodes_defs +
assumes get_disconnected_nodes_new_shadow_root_different_pointers:
"cast new_shadow_root_ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> r \<in> get_disconnected_nodes_locs ptr' \<Longrightarrow> r h h'"
assumes new_shadow_root_no_disconnected_nodes:
"h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr \<Longrightarrow> h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h'
\<Longrightarrow> h' \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
lemma new_shadow_root_get_disconnected_nodes_is_l_new_shadow_root_get_disconnected_nodes [instances]:
"l_new_shadow_root_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs"
apply (auto simp add: l_new_shadow_root_get_disconnected_nodes_def)[1]
using get_disconnected_nodes_new_shadow_root_different_pointers apply fast
using new_shadow_root_no_disconnected_nodes apply blast
done
subsubsection \<open>remove\_shadow\_root\<close>
locale l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_set_shadow_root_defs set_shadow_root set_shadow_root_locs +
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_remove_shadow_root :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog" where
"a_remove_shadow_root element_ptr = do {
shadow_root_ptr_opt \<leftarrow> get_shadow_root element_ptr;
(case shadow_root_ptr_opt of
Some shadow_root_ptr \<Rightarrow> do {
children \<leftarrow> get_child_nodes (cast shadow_root_ptr);
disconnected_nodes \<leftarrow> get_disconnected_nodes (cast shadow_root_ptr);
(if children = [] \<and> disconnected_nodes = []
then do {
set_shadow_root element_ptr None;
delete_M shadow_root_ptr
} else do {
error HierarchyRequestError
})
} |
None \<Rightarrow> error HierarchyRequestError)
}"
definition a_remove_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
where
"a_remove_shadow_root_locs element_ptr shadow_root_ptr \<equiv> set_shadow_root_locs element_ptr \<union> {delete_M shadow_root_ptr}"
end
global_interpretation l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs
defines remove_shadow_root = "a_remove_shadow_root"
and remove_shadow_root_locs = a_remove_shadow_root_locs
.
locale l_remove_shadow_root_defs =
fixes remove_shadow_root :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog"
fixes remove_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_, unit) dom_prog) set"
locale l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_remove_shadow_root_defs +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_child_nodes +
l_get_disconnected_nodes +
assumes remove_shadow_root_impl: "remove_shadow_root = a_remove_shadow_root"
assumes remove_shadow_root_locs_impl: "remove_shadow_root_locs = a_remove_shadow_root_locs"
begin
lemmas remove_shadow_root_def =
remove_shadow_root_impl[unfolded remove_shadow_root_def a_remove_shadow_root_def]
lemmas remove_shadow_root_locs_def =
remove_shadow_root_locs_impl[unfolded remove_shadow_root_locs_def a_remove_shadow_root_locs_def]
lemma remove_shadow_root_writes:
"writes (remove_shadow_root_locs element_ptr (the |h \<turnstile> get_shadow_root element_ptr|\<^sub>r))
(remove_shadow_root element_ptr) h h'"
apply(auto simp add: remove_shadow_root_locs_def remove_shadow_root_def all_args_def
writes_union_right_I writes_union_left_I set_shadow_root_writes
intro!: writes_bind writes_bind_pure[OF get_shadow_root_pure] writes_bind_pure[OF get_child_nodes_pure]
intro: writes_subset[OF set_shadow_root_writes] writes_subset[OF writes_singleton2] split: option.splits)[1]
using writes_union_left_I[OF set_shadow_root_writes]
apply (metis inf_sup_aci(5) insert_is_Un)
using writes_union_right_I[OF writes_singleton[of delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M]]
by (smt insert_is_Un writes_singleton2 writes_union_left_I)
end
interpretation i_remove_shadow_root?: l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs remove_shadow_root remove_shadow_root_locs type_wf known_ptr
by(auto simp add: l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
remove_shadow_root_def remove_shadow_root_locs_def instances)
declare l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
paragraph \<open>get\_child\_nodes\<close>
locale l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_get_child_nodes_different_pointers:
assumes "ptr \<noteq> cast shadow_root_ptr"
assumes "w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_child_nodes_locs ptr"
shows "r h h'"
using assms
by(auto simp add: all_args_def get_child_nodes_locs_def CD.get_child_nodes_locs_def
remove_shadow_root_locs_def set_shadow_root_locs_def
delete_shadow_root_get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t
intro: is_shadow_root_ptr_kind_obtains
simp add: delete_shadow_root_get_M\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
delete_shadow_root_get_M\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t[rotated] element_put_get_preserved[where setter=shadow_root_opt_update]
elim: is_document_ptr_kind_obtains is_shadow_root_ptr_kind_obtains
split: if_splits option.splits)[1]
end
locale l_remove_shadow_root_get_child_nodes = l_get_child_nodes_defs + l_remove_shadow_root_defs +
assumes remove_shadow_root_get_child_nodes_different_pointers:
"ptr \<noteq> cast shadow_root_ptr \<Longrightarrow> w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow>
r \<in> get_child_nodes_locs ptr \<Longrightarrow> r h h'"
interpretation
i_remove_shadow_root_get_child_nodes?: l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
known_ptr DocumentClass.type_wf DocumentClass.known_ptr get_child_nodes get_child_nodes_locs
Core_DOM_Functions.get_child_nodes Core_DOM_Functions.get_child_nodes_locs get_shadow_root
get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes get_disconnected_nodes_locs
remove_shadow_root remove_shadow_root_locs
by(auto simp add: l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_get_child_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma remove_shadow_root_get_child_nodes_is_l_remove_shadow_root_get_child_nodes [instances]:
"l_remove_shadow_root_get_child_nodes get_child_nodes_locs remove_shadow_root_locs"
apply(auto simp add: l_remove_shadow_root_get_child_nodes_def instances )[1]
using remove_shadow_root_get_child_nodes_different_pointers apply fast
done
paragraph \<open>get\_tag\_name\<close>
locale l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_get_tag_name:
assumes "w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
assumes "r \<in> get_tag_name_locs ptr"
shows "r h h'"
using assms
by(auto simp add: all_args_def remove_shadow_root_locs_def set_shadow_root_locs_def
CD.get_tag_name_locs_def delete_shadow_root_get_M\<^sub>E\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t
element_put_get_preserved[where setter=shadow_root_opt_update] split: if_splits option.splits)
end
locale l_remove_shadow_root_get_tag_name = l_get_tag_name_defs + l_remove_shadow_root_defs +
assumes remove_shadow_root_get_tag_name:
"w \<in> remove_shadow_root_locs element_ptr shadow_root_ptr \<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> r \<in> get_tag_name_locs ptr \<Longrightarrow>
r h h'"
interpretation
i_remove_shadow_root_get_tag_name?: l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf
DocumentClass.type_wf get_tag_name get_tag_name_locs get_child_nodes get_child_nodes_locs
get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_disconnected_nodes
get_disconnected_nodes_locs remove_shadow_root remove_shadow_root_locs known_ptr
by(auto simp add: l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma remove_shadow_root_get_tag_name_is_l_remove_shadow_root_get_tag_name [instances]:
"l_remove_shadow_root_get_tag_name get_tag_name_locs remove_shadow_root_locs"
apply(auto simp add: l_remove_shadow_root_get_tag_name_def instances )[1]
using remove_shadow_root_get_tag_name apply fast
done
subsubsection \<open>get\_owner\_document\<close>
locale l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_host_defs get_host get_host_locs +
CD: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs get_disconnected_nodes get_disconnected_nodes_locs
for get_root_node :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r :: "(_) shadow_root_ptr \<Rightarrow> unit \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr = CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast shadow_root_ptr)"
definition a_get_owner_document_tups :: "(((_) object_ptr \<Rightarrow> bool) \<times> ((_) object_ptr \<Rightarrow> unit
\<Rightarrow> (_, (_) document_ptr) dom_prog)) list"
where
"a_get_owner_document_tups = [(is_shadow_root_ptr, a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast)]"
definition a_get_owner_document :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_owner_document ptr = invoke (CD.a_get_owner_document_tups @ a_get_owner_document_tups) ptr ()"
end
global_interpretation l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs
get_disconnected_nodes get_disconnected_nodes_locs get_host get_host_locs
defines get_owner_document_tups = "l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document_tups"
and get_owner_document =
"l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document get_root_node get_disconnected_nodes"
and get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r =
"l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r"
and get_owner_document_tups\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
"l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document_tups get_root_node get_disconnected_nodes"
and get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r =
"l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r get_root_node get_disconnected_nodes"
.
locale l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_root_node get_root_node_locs get_disconnected_nodes
get_disconnected_nodes_locs get_host get_host_locs +
l_get_owner_document_defs get_owner_document +
l_get_host get_host get_host_locs +
CD: l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_parent get_parent_locs known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs get_root_node get_root_node_locs get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
for known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_owner_document :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes get_owner_document_impl: "get_owner_document = a_get_owner_document"
begin
lemmas get_owner_document_def = a_get_owner_document_def[folded get_owner_document_impl]
lemma get_owner_document_pure [simp]:
"pure (get_owner_document ptr) h"
proof -
have "\<And>shadow_root_ptr. pure (a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr ()) h"
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_I filter_M_pure_I
split: option.splits)[1]
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_I filter_M_pure_I
split: option.splits)
then show ?thesis
apply(auto simp add: get_owner_document_def)[1]
apply(split CD.get_owner_document_splits, rule conjI)+
apply(simp)
apply(auto simp add: a_get_owner_document_tups_def)[1]
apply(split invoke_splits, rule conjI)+
apply simp
by(auto intro!: bind_pure_I)
qed
lemma get_owner_document_ptr_in_heap:
assumes "h \<turnstile> ok (get_owner_document ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_owner_document_def invoke_ptr_in_heap dest: is_OK_returns_heap_I)
end
interpretation
i_get_owner_document?: l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M DocumentClass.known_ptr get_parent get_parent_locs
DocumentClass.type_wf get_disconnected_nodes get_disconnected_nodes_locs get_root_node get_root_node_locs CD.a_get_owner_document get_host get_host_locs get_owner_document get_child_nodes get_child_nodes_locs
using get_child_nodes_is_l_get_child_nodes[unfolded ShadowRootClass.known_ptr_defs]
by(auto simp add: instances l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def get_owner_document_def Core_DOM_Functions.get_owner_document_def)
declare l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_is_l_get_owner_document [instances]: "l_get_owner_document get_owner_document"
apply(auto simp add: l_get_owner_document_def)[1]
using get_owner_document_ptr_in_heap apply fast
done
subsubsection \<open>remove\_child\<close>
global_interpretation l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs set_child_nodes
set_child_nodes_locs get_parent get_parent_locs get_owner_document get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
defines remove = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove get_child_nodes set_child_nodes get_parent
get_owner_document get_disconnected_nodes set_disconnected_nodes"
and remove_child = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child get_child_nodes set_child_nodes
get_owner_document get_disconnected_nodes set_disconnected_nodes"
and remove_child_locs = "l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_remove_child_locs set_child_nodes_locs
set_disconnected_nodes_locs"
.
interpretation i_remove_child?: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M Shadow_DOM.get_child_nodes
Shadow_DOM.get_child_nodes_locs Shadow_DOM.set_child_nodes Shadow_DOM.set_child_nodes_locs
Shadow_DOM.get_parent Shadow_DOM.get_parent_locs
Shadow_DOM.get_owner_document get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs remove_child remove_child_locs remove
ShadowRootClass.type_wf
ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
by(auto simp add: l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def remove_child_def
remove_child_locs_def remove_def instances)
declare l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_disconnected\_document\<close>
locale l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_disconnected_nodes_defs get_disconnected_nodes get_disconnected_nodes_locs
for get_disconnected_nodes :: "(_::linorder) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_get_disconnected_document :: "(_) node_ptr \<Rightarrow> (_, (_) document_ptr) dom_prog"
where
"a_get_disconnected_document node_ptr = do {
check_in_heap (cast node_ptr);
ptrs \<leftarrow> document_ptr_kinds_M;
candidates \<leftarrow> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (node_ptr \<in> set disconnected_nodes)
}) ptrs;
(case candidates of
Cons document_ptr [] \<Rightarrow> return document_ptr |
_ \<Rightarrow> error HierarchyRequestError
)
}"
definition "a_get_disconnected_document_locs =
(\<Union>document_ptr. get_disconnected_nodes_locs document_ptr) \<union> (\<Union>ptr. {preserved (get_M\<^sub>O\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t ptr RObject.nothing)})"
end
locale l_get_disconnected_document_defs =
fixes get_disconnected_document :: "(_) node_ptr \<Rightarrow> (_, (_::linorder) document_ptr) dom_prog"
fixes get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_disconnected_document_defs +
l_get_disconnected_nodes +
assumes get_disconnected_document_impl: "get_disconnected_document = a_get_disconnected_document"
assumes get_disconnected_document_locs_impl: "get_disconnected_document_locs = a_get_disconnected_document_locs"
begin
lemmas get_disconnected_document_def =
get_disconnected_document_impl[unfolded a_get_disconnected_document_def]
lemmas get_disconnected_document_locs_def =
get_disconnected_document_locs_impl[unfolded a_get_disconnected_document_locs_def]
lemma get_disconnected_document_pure [simp]: "pure (get_disconnected_document ptr) h"
using get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def intro!: bind_pure_I filter_M_pure_I split: list.splits)
lemma get_disconnected_document_ptr_in_heap [simp]:
"h \<turnstile> ok (get_disconnected_document node_ptr) \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h"
using get_disconnected_document_def is_OK_returns_result_I check_in_heap_ptr_in_heap
by (metis (no_types, lifting) bind_returns_heap_E get_disconnected_document_pure
node_ptr_kinds_commutes pure_pure)
lemma get_disconnected_document_disconnected_document_in_heap:
assumes "h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disconnected_document"
shows "disconnected_document |\<in>| document_ptr_kinds h"
using assms get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def elim!: bind_returns_result_E2
dest!: filter_M_not_more_elements[where x=disconnected_document]
intro!: filter_M_pure_I bind_pure_I
split: if_splits list.splits)
lemma get_disconnected_document_reads:
"reads get_disconnected_document_locs (get_disconnected_document node_ptr) h h'"
using get_disconnected_nodes_reads[unfolded reads_def]
by(auto simp add: get_disconnected_document_def get_disconnected_document_locs_def
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads]
reads_subset[OF error_reads]
reads_subset[OF get_disconnected_nodes_reads] reads_subset[OF return_reads]
reads_subset[OF document_ptr_kinds_M_reads] filter_M_reads filter_M_pure_I bind_pure_I
split: list.splits)
end
locale l_get_disconnected_document = l_get_disconnected_document_defs +
assumes get_disconnected_document_reads:
"reads get_disconnected_document_locs (get_disconnected_document node_ptr) h h'"
assumes get_disconnected_document_ptr_in_heap:
"h \<turnstile> ok (get_disconnected_document node_ptr) \<Longrightarrow> node_ptr |\<in>| node_ptr_kinds h"
assumes get_disconnected_document_pure [simp]:
"pure (get_disconnected_document node_ptr) h"
assumes get_disconnected_document_disconnected_document_in_heap:
"h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disconnected_document \<Longrightarrow>
disconnected_document |\<in>| document_ptr_kinds h"
global_interpretation l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_disconnected_nodes
get_disconnected_nodes_locs defines
get_disconnected_document = "l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_disconnected_document
get_disconnected_nodes" and
get_disconnected_document_locs = "l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_get_disconnected_document_locs
get_disconnected_nodes_locs" .
interpretation i_get_disconnected_document?: l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_nodes get_disconnected_nodes_locs get_disconnected_document get_disconnected_document_locs type_wf
by(auto simp add: l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_disconnected_document_def get_disconnected_document_locs_def instances)
declare l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_disconnected_document_is_l_get_disconnected_document [instances]:
"l_get_disconnected_document get_disconnected_document get_disconnected_document_locs"
apply(auto simp add: l_get_disconnected_document_def instances)[1]
using get_disconnected_document_ptr_in_heap get_disconnected_document_pure
get_disconnected_document_disconnected_document_in_heap get_disconnected_document_reads
by blast+
paragraph \<open>get\_disconnected\_nodes\<close>
locale l_set_tag_name_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_tag_name_get_disconnected_nodes:
"\<forall>w \<in> set_tag_name_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_disconnected_nodes_locs ptr'. r h h'))"
by(auto simp add: CD.set_tag_name_locs_impl[unfolded CD.a_set_tag_name_locs_def]
CD.get_disconnected_nodes_locs_impl[unfolded CD.a_get_disconnected_nodes_locs_def]
all_args_def)
end
interpretation
i_set_tag_name_get_disconnected_nodes?: l_set_tag_name_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_tag_name set_tag_name_locs get_disconnected_nodes
get_disconnected_nodes_locs
by unfold_locales
declare l_set_tag_name_get_disconnected_nodes\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_tag_name_get_disconnected_nodes_is_l_set_tag_name_get_disconnected_nodes [instances]:
"l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs get_disconnected_nodes
get_disconnected_nodes_locs"
using set_tag_name_is_l_set_tag_name get_disconnected_nodes_is_l_get_disconnected_nodes
apply(simp add: l_set_tag_name_get_disconnected_nodes_def
l_set_tag_name_get_disconnected_nodes_axioms_def)
using set_tag_name_get_disconnected_nodes
by fast
subsubsection \<open>get\_ancestors\_di\<close>
locale l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_parent_defs get_parent get_parent_locs +
l_get_host_defs get_host get_host_locs +
l_get_disconnected_document_defs get_disconnected_document get_disconnected_document_locs
for get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_::linorder) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
partial_function (dom_prog) a_get_ancestors_di :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
where
"a_get_ancestors_di ptr = do {
check_in_heap ptr;
ancestors \<leftarrow> (case cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr of
Some node_ptr \<Rightarrow> do {
parent_ptr_opt \<leftarrow> get_parent node_ptr;
(case parent_ptr_opt of
Some parent_ptr \<Rightarrow> a_get_ancestors_di parent_ptr
| None \<Rightarrow> do {
document_ptr \<leftarrow> get_disconnected_document node_ptr;
a_get_ancestors_di (cast document_ptr)
})
}
| None \<Rightarrow> (case cast ptr of
Some shadow_root_ptr \<Rightarrow> do {
host \<leftarrow> get_host shadow_root_ptr;
a_get_ancestors_di (cast host)
} |
None \<Rightarrow> return []));
return (ptr # ancestors)
}"
definition "a_get_ancestors_di_locs = get_parent_locs \<union> get_host_locs \<union> get_disconnected_document_locs"
end
locale l_get_ancestors_di_defs =
fixes get_ancestors_di :: "(_::linorder) object_ptr \<Rightarrow> (_, (_) object_ptr list) dom_prog"
fixes get_ancestors_di_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
locale l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_parent +
l_get_host +
l_get_disconnected_document +
l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs +
l_get_ancestors_di_defs +
assumes get_ancestors_di_impl: "get_ancestors_di = a_get_ancestors_di"
assumes get_ancestors_di_locs_impl: "get_ancestors_di_locs = a_get_ancestors_di_locs"
begin
lemmas get_ancestors_di_def = a_get_ancestors_di.simps[folded get_ancestors_di_impl]
lemmas get_ancestors_di_locs_def = a_get_ancestors_di_locs_def[folded get_ancestors_di_locs_impl]
lemma get_ancestors_di_pure [simp]:
"pure (get_ancestors_di ptr) h"
proof -
have "\<forall>ptr h h' x. h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r x \<longrightarrow> h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>h h' \<longrightarrow> h = h'"
proof (induct rule: a_get_ancestors_di.fixp_induct[folded get_ancestors_di_impl])
case 1
then show ?case
by(rule admissible_dom_prog)
next
case 2
then show ?case
by simp
next
case (3 f)
then show ?case
using get_parent_pure get_host_pure get_disconnected_document_pure
apply(auto simp add: pure_returns_heap_eq pure_def split: option.splits elim!: bind_returns_heap_E
bind_returns_result_E dest!: pure_returns_heap_eq[rotated, OF check_in_heap_pure])[1]
apply (metis is_OK_returns_result_I returns_heap_eq returns_result_eq)
apply (meson option.simps(3) returns_result_eq)
apply (meson option.simps(3) returns_result_eq)
apply(metis get_parent_pure pure_returns_heap_eq)
apply(metis get_host_pure pure_returns_heap_eq)
done
qed
then show ?thesis
by (meson pure_eq_iff)
qed
lemma get_ancestors_di_ptr:
assumes "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors"
shows "ptr \<in> set ancestors"
using assms
by(simp add: get_ancestors_di_def) (auto elim!: bind_returns_result_E2 split: option.splits
intro!: bind_pure_I)
lemma get_ancestors_di_ptr_in_heap:
assumes "h \<turnstile> ok (get_ancestors_di ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
by(auto simp add: get_ancestors_di_def check_in_heap_ptr_in_heap elim!: bind_is_OK_E
dest: is_OK_returns_result_I)
lemma get_ancestors_di_never_empty:
assumes "h \<turnstile> get_ancestors_di child \<rightarrow>\<^sub>r ancestors"
shows "ancestors \<noteq> []"
using assms
apply(simp add: get_ancestors_di_def)
by(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I)
end
global_interpretation l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_host get_host_locs
get_disconnected_document get_disconnected_document_locs
defines get_ancestors_di = a_get_ancestors_di
and get_ancestors_di_locs = a_get_ancestors_di_locs .
declare a_get_ancestors_di.simps [code]
interpretation i_get_ancestors_di?: l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_host get_host_locs get_disconnected_document get_disconnected_document_locs get_ancestors_di get_ancestors_di_locs
by(auto simp add: l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
get_ancestors_di_def get_ancestors_di_locs_def instances)
declare l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_ancestors_di_is_l_get_ancestors [instances]: "l_get_ancestors get_ancestors_di"
apply(auto simp add: l_get_ancestors_def)[1]
using get_ancestors_di_ptr_in_heap apply fast
using get_ancestors_di_ptr apply fast
done
subsubsection \<open>adopt\_node\<close>
locale l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_parent get_parent_locs remove_child
remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs +
l_get_ancestors_di_defs get_ancestors_di get_ancestors_di_locs
for get_owner_document :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and remove_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_child_locs :: "(_) object_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_ancestors_di :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_di_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_adopt_node :: "(_) document_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> (_, unit) dom_prog"
where
"a_adopt_node document node = do {
ancestors \<leftarrow> get_ancestors_di (cast document);
(if cast node \<in> set ancestors
then error HierarchyRequestError
else CD.a_adopt_node document node)}"
definition a_adopt_node_locs ::
"(_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> (_, unit) dom_prog set"
where "a_adopt_node_locs = CD.a_adopt_node_locs"
end
locale l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_parent get_parent_locs remove_child
remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs get_ancestors_di get_ancestors_di_locs +
l_adopt_node_defs adopt_node adopt_node_locs +
l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf known_ptr known_ptrs get_parent get_parent_locs
get_child_nodes get_child_nodes_locs get_host get_host_locs get_disconnected_document
get_disconnected_document_locs get_ancestors_di get_ancestors_di_locs +
CD: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_owner_document get_parent get_parent_locs remove_child
remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes
set_child_nodes_locs remove
for get_owner_document :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and remove_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_child_locs :: "(_) object_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_ancestors_di :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog"
and get_ancestors_di_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and adopt_node :: "(_) document_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and adopt_node_locs ::
"(_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) document_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M ::
"(_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and set_child_nodes :: "(_) object_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and remove :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog" +
assumes adopt_node_impl: "adopt_node = a_adopt_node"
assumes adopt_node_locs_impl: "adopt_node_locs = a_adopt_node_locs"
begin
lemmas adopt_node_def = a_adopt_node_def[folded adopt_node_impl CD.adopt_node_impl]
lemmas adopt_node_locs_def = a_adopt_node_locs_def[folded adopt_node_locs_impl CD.adopt_node_locs_impl]
lemma adopt_node_writes:
"writes (adopt_node_locs |h \<turnstile> get_parent node|\<^sub>r
|h \<turnstile> get_owner_document (cast node)|\<^sub>r document_ptr) (adopt_node document_ptr node) h h'"
by(auto simp add: CD.adopt_node_writes adopt_node_def CD.adopt_node_impl[symmetric]
adopt_node_locs_def CD.adopt_node_locs_impl[symmetric]
intro!: writes_bind_pure[OF get_ancestors_di_pure])
lemma adopt_node_pointers_preserved:
"w \<in> adopt_node_locs parent owner_document document_ptr
\<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> object_ptr_kinds h = object_ptr_kinds h'"
using CD.adopt_node_locs_impl CD.adopt_node_pointers_preserved local.adopt_node_locs_def by blast
lemma adopt_node_types_preserved:
"w \<in> adopt_node_locs parent owner_document document_ptr
\<Longrightarrow> h \<turnstile> w \<rightarrow>\<^sub>h h' \<Longrightarrow> type_wf h = type_wf h'"
using CD.adopt_node_locs_impl CD.adopt_node_types_preserved local.adopt_node_locs_def by blast
lemma adopt_node_child_in_heap:
"h \<turnstile> ok (adopt_node document_ptr child) \<Longrightarrow> child |\<in>| node_ptr_kinds h"
by (smt CD.adopt_node_child_in_heap CD.adopt_node_impl bind_is_OK_E error_returns_heap
is_OK_returns_heap_E l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.adopt_node_def l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
local.get_ancestors_di_pure pure_returns_heap_eq)
lemma adopt_node_children_subset:
"h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h' \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children'
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow> set children' \<subseteq> set children"
by (smt CD.adopt_node_children_subset CD.adopt_node_impl bind_returns_heap_E error_returns_heap
local.adopt_node_def local.get_ancestors_di_pure pure_returns_heap_eq)
end
global_interpretation l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w_\<^sub>D\<^sub>O\<^sub>M_defs get_owner_document get_parent get_parent_locs
remove_child remove_child_locs get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs get_ancestors_di get_ancestors_di_locs
defines adopt_node = "a_adopt_node"
and adopt_node_locs = "a_adopt_node_locs"
and adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = "CD.a_adopt_node"
and adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = "CD.a_adopt_node_locs"
.
interpretation i_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document get_parent get_parent_locs remove_child remove_child_locs
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs
known_ptrs set_child_nodes set_child_nodes_locs remove
by(auto simp add: l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_adopt_node?: l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs get_ancestors_di
get_ancestors_di_locs adopt_node adopt_node_locs CD.a_adopt_node CD.a_adopt_node_locs known_ptr
type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs
get_host get_host_locs get_disconnected_document get_disconnected_document_locs remove
by(auto simp add: l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def adopt_node_def
adopt_node_locs_def instances)
declare l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma adopt_node_is_l_adopt_node [instances]: "l_adopt_node type_wf known_ptr known_ptrs get_parent
adopt_node adopt_node_locs get_child_nodes get_owner_document"
apply(auto simp add: l_adopt_node_def l_adopt_node_axioms_def instances)[1]
using adopt_node_writes apply fast
using adopt_node_pointers_preserved apply (fast, fast)
using adopt_node_types_preserved apply (fast, fast)
using adopt_node_child_in_heap apply fast
using adopt_node_children_subset apply fast
done
paragraph \<open>get\_shadow\_root\<close>
locale l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_child_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_disconnected_nodes_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_get_shadow_root:
"\<forall>w \<in> adopt_node_locs parent owner_document document_ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow>
(\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: adopt_node_locs_def CD.adopt_node_locs_def CD.remove_child_locs_def
all_args_def set_disconnected_nodes_get_shadow_root set_child_nodes_get_shadow_root)
end
locale l_adopt_node_get_shadow_root = l_adopt_node_defs + l_get_shadow_root_defs +
assumes adopt_node_get_shadow_root:
"\<forall>w \<in> adopt_node_locs parent owner_document document_ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow>
(\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation i_adopt_node_get_shadow_root?: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes set_child_nodes_locs
Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs get_shadow_root
get_shadow_root_locs set_disconnected_nodes set_disconnected_nodes_locs get_owner_document
get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs get_ancestors_di get_ancestors_di_locs adopt_node adopt_node_locs
adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs known_ptrs get_host
get_host_locs get_disconnected_document get_disconnected_document_locs remove
by(auto simp add: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_adopt_node_get_shadow_root?: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr DocumentClass.type_wf DocumentClass.known_ptr set_child_nodes
set_child_nodes_locs Core_DOM_Functions.set_child_nodes Core_DOM_Functions.set_child_nodes_locs
get_shadow_root get_shadow_root_locs set_disconnected_nodes set_disconnected_nodes_locs
get_owner_document get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs get_ancestors_di get_ancestors_di_locs adopt_node adopt_node_locs
adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs known_ptrs get_host
get_host_locs get_disconnected_document get_disconnected_document_locs remove
by(auto simp add: l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma adopt_node_get_shadow_root_is_l_adopt_node_get_shadow_root [instances]:
"l_adopt_node_get_shadow_root adopt_node_locs get_shadow_root_locs"
apply(auto simp add: l_adopt_node_get_shadow_root_def)[1]
using adopt_node_get_shadow_root apply fast
done
subsubsection \<open>insert\_before\<close>
global_interpretation l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_parent get_parent_locs get_child_nodes
get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_di get_ancestors_di_locs
adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document
defines
next_sibling = a_next_sibling and
insert_node = a_insert_node and
ensure_pre_insertion_validity = a_ensure_pre_insertion_validity and
insert_before = a_insert_before and
insert_before_locs = a_insert_before_locs
.
global_interpretation l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs insert_before
defines append_child = "l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_append_child insert_before"
.
interpretation i_insert_before?: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_child_nodes
get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_di get_ancestors_di_locs
adopt_node adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_owner_document insert_before insert_before_locs append_child type_wf
known_ptr known_ptrs
by(auto simp add: l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def insert_before_def
insert_before_locs_def instances)
declare l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_append_child?: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M append_child insert_before insert_before_locs
by(simp add: l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances append_child_def)
declare l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
subsubsection \<open>get\_assigned\_nodes\<close>
fun map_filter_M2 :: "('x \<Rightarrow> ('heap, 'e, 'y option) prog) \<Rightarrow> 'x list
\<Rightarrow> ('heap, 'e, 'y list) prog"
where
"map_filter_M2 f [] = return []" |
"map_filter_M2 f (x # xs) = do {
res \<leftarrow> f x;
remainder \<leftarrow> map_filter_M2 f xs;
return ((case res of Some r \<Rightarrow> [r] | None \<Rightarrow> []) @ remainder)
}"
lemma map_filter_M2_pure [simp]:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
shows "pure (map_filter_M2 f xs) h"
using assms
apply(induct xs arbitrary: h)
by(auto elim!: bind_returns_result_E2 intro!: bind_pure_I)
lemma map_filter_pure_no_monad:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
assumes "h \<turnstile> map_filter_M2 f xs \<rightarrow>\<^sub>r ys"
shows
"ys = map the (filter (\<lambda>x. x \<noteq> None) (map (\<lambda>x. |h \<turnstile> f x|\<^sub>r) xs))" and
"\<And>x. x \<in> set xs \<Longrightarrow> h \<turnstile> ok (f x)"
using assms
apply(induct xs arbitrary: h ys)
by(auto elim!: bind_returns_result_E2)
lemma map_filter_pure_foo:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (f x) h"
assumes "h \<turnstile> map_filter_M2 f xs \<rightarrow>\<^sub>r ys"
assumes "y \<in> set ys"
obtains x where "h \<turnstile> f x \<rightarrow>\<^sub>r Some y" and "x \<in> set xs"
using assms
apply(induct xs arbitrary: ys)
by(auto elim!: bind_returns_result_E2)
lemma map_filter_M2_in_result:
assumes "h \<turnstile> map_filter_M2 P xs \<rightarrow>\<^sub>r ys"
assumes "a \<in> set xs"
assumes "\<And>x. x \<in> set xs \<Longrightarrow> pure (P x) h"
assumes "h \<turnstile> P a \<rightarrow>\<^sub>r Some b"
shows "b \<in> set ys"
using assms
apply(induct xs arbitrary: h ys)
by(auto elim!: bind_returns_result_E2 )
locale l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
l_get_tag_name_defs get_tag_name get_tag_name_locs +
l_get_root_node_defs get_root_node get_root_node_locs +
l_get_host_defs get_host get_host_locs +
l_get_child_nodes_defs get_child_nodes get_child_nodes_locs +
l_find_slot_defs find_slot assigned_slot +
l_remove_defs remove +
l_insert_before_defs insert_before insert_before_locs +
l_append_child_defs append_child +
l_remove_shadow_root_defs remove_shadow_root remove_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and remove :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before ::
"(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> (_) node_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before_locs ::
"(_) object_ptr \<Rightarrow> (_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> (_, unit) dom_prog set"
and append_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root_locs ::
"(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
begin
definition a_assigned_nodes :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
where
"a_assigned_nodes slot = do {
tag \<leftarrow> get_tag_name slot;
(if tag \<noteq> ''slot''
then error HierarchyRequestError
else return ());
root \<leftarrow> get_root_node (cast slot);
if is_shadow_root_ptr_kind root
then do {
host \<leftarrow> get_host (the (cast root));
children \<leftarrow> get_child_nodes (cast host);
filter_M (\<lambda>slotable. do {
found_slot \<leftarrow> find_slot False slotable;
return (found_slot = Some slot)}) children}
else return []}"
partial_function (dom_prog) a_assigned_nodes_flatten ::
"(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
where
"a_assigned_nodes_flatten slot = do {
tag \<leftarrow> get_tag_name slot;
(if tag \<noteq> ''slot''
then error HierarchyRequestError
else return ());
root \<leftarrow> get_root_node (cast slot);
(if is_shadow_root_ptr_kind root
then do {
slotables \<leftarrow> a_assigned_nodes slot;
slotables_or_child_nodes \<leftarrow> (if slotables = []
then do {
get_child_nodes (cast slot)
} else do {
return slotables
});
list_of_lists \<leftarrow> map_M (\<lambda>node_ptr. do {
(case cast node_ptr of
Some element_ptr \<Rightarrow> do {
tag \<leftarrow> get_tag_name element_ptr;
(if tag = ''slot''
then do {
root \<leftarrow> get_root_node (cast element_ptr);
(if is_shadow_root_ptr_kind root
then do {
a_assigned_nodes_flatten element_ptr
} else do {
return [node_ptr]
})
} else do {
return [node_ptr]
})
}
| None \<Rightarrow> return [node_ptr])
}) slotables_or_child_nodes;
return (concat list_of_lists)
} else return [])
}"
definition a_flatten_dom :: "(_, unit) dom_prog" where
"a_flatten_dom = do {
tups \<leftarrow> element_ptr_kinds_M \<bind> map_filter_M2 (\<lambda>element_ptr. do {
tag \<leftarrow> get_tag_name element_ptr;
assigned_nodes \<leftarrow> a_assigned_nodes element_ptr;
(if tag = ''slot'' \<and> assigned_nodes \<noteq> []
then return (Some (element_ptr, assigned_nodes)) else return None)});
forall_M (\<lambda>(slot, assigned_nodes). do {
get_child_nodes (cast slot) \<bind> forall_M remove;
forall_M (append_child (cast slot)) assigned_nodes
}) tups;
shadow_root_ptr_kinds_M \<bind> forall_M (\<lambda>shadow_root_ptr. do {
host \<leftarrow> get_host shadow_root_ptr;
get_child_nodes (cast host) \<bind> forall_M remove;
get_child_nodes (cast shadow_root_ptr) \<bind> forall_M (append_child (cast host));
remove_shadow_root host
});
return ()
}"
end
global_interpretation l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_tag_name get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs
find_slot assigned_slot remove insert_before insert_before_locs append_child remove_shadow_root
remove_shadow_root_locs
defines assigned_nodes =
"l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_assigned_nodes get_child_nodes get_tag_name get_root_node get_host
find_slot"
and assigned_nodes_flatten =
"l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_assigned_nodes_flatten get_child_nodes get_tag_name get_root_node
get_host find_slot"
and flatten_dom =
"l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_flatten_dom get_child_nodes get_tag_name get_root_node get_host
find_slot remove append_child remove_shadow_root"
.
declare a_assigned_nodes_flatten.simps [code]
locale l_assigned_nodes_defs =
fixes assigned_nodes :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
fixes assigned_nodes_flatten :: "(_) element_ptr \<Rightarrow> (_, (_) node_ptr list) dom_prog"
fixes flatten_dom :: "(_, unit) dom_prog"
locale l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_assigned_nodes_defs
assigned_nodes assigned_nodes_flatten flatten_dom
+ l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
get_child_nodes get_child_nodes_locs get_tag_name get_tag_name_locs get_root_node
get_root_node_locs get_host get_host_locs find_slot assigned_slot remove insert_before
insert_before_locs append_child remove_shadow_root remove_shadow_root_locs
(* + l_get_element_by\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M *)
+ l_get_shadow_root
type_wf get_shadow_root get_shadow_root_locs
+ l_set_shadow_root
type_wf set_shadow_root set_shadow_root_locs
+ l_remove
+ l_insert_before
insert_before insert_before_locs
+ l_find_slot
find_slot assigned_slot
+ l_get_tag_name
type_wf get_tag_name get_tag_name_locs
+ l_get_root_node
get_root_node get_root_node_locs get_parent get_parent_locs
+ l_get_host
get_host get_host_locs
+ l_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_to_tree_order
to_tree_order
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and assigned_nodes :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and assigned_nodes_flatten :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and flatten_dom :: "((_) heap, exception, unit) prog"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_root_node :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr) prog"
and get_root_node_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and find_slot :: "bool \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and assigned_slot :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr option) prog"
and remove :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> (_) node_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and insert_before_locs ::
"(_) object_ptr \<Rightarrow> (_) object_ptr option \<Rightarrow> (_) document_ptr \<Rightarrow> (_) document_ptr \<Rightarrow> (_, unit) dom_prog set"
and append_child :: "(_) object_ptr \<Rightarrow> (_) node_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog"
and remove_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> ((_) heap, exception, unit) prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and to_tree_order :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr list) prog" +
assumes assigned_nodes_impl: "assigned_nodes = a_assigned_nodes"
assumes flatten_dom_impl: "flatten_dom = a_flatten_dom"
begin
lemmas assigned_nodes_def = assigned_nodes_impl[unfolded a_assigned_nodes_def]
lemmas flatten_dom_def = flatten_dom_impl[unfolded a_flatten_dom_def, folded assigned_nodes_impl]
lemma assigned_nodes_pure [simp]: "pure (assigned_nodes slot) h"
by(auto simp add: assigned_nodes_def intro!: bind_pure_I filter_M_pure_I)
lemma assigned_nodes_ptr_in_heap:
assumes "h \<turnstile> ok (assigned_nodes slot)"
shows "slot |\<in>| element_ptr_kinds h"
using assms
apply(auto simp add: assigned_nodes_def)[1]
by (meson bind_is_OK_E is_OK_returns_result_I local.get_tag_name_ptr_in_heap)
lemma assigned_nodes_slot_is_slot:
assumes "h \<turnstile> ok (assigned_nodes slot)"
shows "h \<turnstile> get_tag_name slot \<rightarrow>\<^sub>r ''slot''"
using assms
by(auto simp add: assigned_nodes_def elim!: bind_is_OK_E split: if_splits)
lemma assigned_nodes_different_ptr:
assumes "h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes"
assumes "h \<turnstile> assigned_nodes slot' \<rightarrow>\<^sub>r nodes'"
assumes "slot \<noteq> slot'"
shows "set nodes \<inter> set nodes' = {}"
proof (rule ccontr)
assume "set nodes \<inter> set nodes' \<noteq> {} "
then obtain common_ptr where "common_ptr \<in> set nodes" and "common_ptr \<in> set nodes'"
by auto
have "h \<turnstile> find_slot False common_ptr \<rightarrow>\<^sub>r Some slot"
using \<open>common_ptr \<in> set nodes\<close>
using assms(1)
by(auto simp add: assigned_nodes_def elim!: bind_returns_result_E2 split: if_splits
dest!: filter_M_holds_for_result[where x=common_ptr] intro!: bind_pure_I)
moreover
have "h \<turnstile> find_slot False common_ptr \<rightarrow>\<^sub>r Some slot'"
using \<open>common_ptr \<in> set nodes'\<close>
using assms(2)
by(auto simp add: assigned_nodes_def elim!: bind_returns_result_E2 split: if_splits
dest!: filter_M_holds_for_result[where x=common_ptr] intro!: bind_pure_I)
ultimately
show False
using assms(3)
by (meson option.inject returns_result_eq)
qed
end
interpretation i_assigned_nodes?: l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr assigned_nodes
assigned_nodes_flatten flatten_dom get_child_nodes get_child_nodes_locs get_tag_name
get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs find_slot assigned_slot
remove insert_before insert_before_locs append_child remove_shadow_root remove_shadow_root_locs
type_wf get_shadow_root get_shadow_root_locs set_shadow_root set_shadow_root_locs get_parent
get_parent_locs to_tree_order
by(auto simp add: instances l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
assigned_nodes_def flatten_dom_def)
declare l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_assigned_nodes = l_assigned_nodes_defs +
assumes assigned_nodes_pure [simp]: "pure (assigned_nodes slot) h"
assumes assigned_nodes_ptr_in_heap: "h \<turnstile> ok (assigned_nodes slot) \<Longrightarrow> slot |\<in>| element_ptr_kinds h"
assumes assigned_nodes_slot_is_slot: "h \<turnstile> ok (assigned_nodes slot) \<Longrightarrow> h \<turnstile> get_tag_name slot \<rightarrow>\<^sub>r ''slot''"
assumes assigned_nodes_different_ptr:
"h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes \<Longrightarrow> h \<turnstile> assigned_nodes slot' \<rightarrow>\<^sub>r nodes' \<Longrightarrow> slot \<noteq> slot' \<Longrightarrow>
set nodes \<inter> set nodes' = {}"
lemma assigned_nodes_is_l_assigned_nodes [instances]: "l_assigned_nodes assigned_nodes"
apply(auto simp add: l_assigned_nodes_def)[1]
using assigned_nodes_ptr_in_heap apply fast
using assigned_nodes_slot_is_slot apply fast
using assigned_nodes_different_ptr apply fast
done
subsubsection \<open>set\_val\<close>
locale l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_set_val\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M set_val set_val_locs +
l_type_wf type_wf
for type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> (_, unit) dom_prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> (_, unit) dom_prog set" +
assumes type_wf_impl: "type_wf = ShadowRootClass.type_wf"
begin
lemma set_val_ok:
"type_wf h \<Longrightarrow> character_data_ptr |\<in>| character_data_ptr_kinds h \<Longrightarrow>
h \<turnstile> ok (set_val character_data_ptr tag)"
using CD.set_val_ok CD.type_wf_impl ShadowRootClass.type_wf\<^sub>D\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t local.type_wf_impl by blast
lemma set_val_writes: "writes (set_val_locs character_data_ptr) (set_val character_data_ptr tag) h h'"
using CD.set_val_writes .
lemma set_val_pointers_preserved:
assumes "w \<in> set_val_locs character_data_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "object_ptr_kinds h = object_ptr_kinds h'"
using assms CD.set_val_pointers_preserved by simp
lemma set_val_typess_preserved:
assumes "w \<in> set_val_locs character_data_ptr"
assumes "h \<turnstile> w \<rightarrow>\<^sub>h h'"
shows "type_wf h = type_wf h'"
apply(unfold type_wf_impl)
using assms(1) type_wf_preserved[OF writes_singleton2 assms(2)]
by(auto simp add: all_args_def CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def] split: if_splits)
end
interpretation
i_set_val?: l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_val set_val_locs
apply(unfold_locales)
by (auto simp add: set_val_def set_val_locs_def)
declare l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_is_l_set_val [instances]: "l_set_val type_wf set_val set_val_locs"
apply(simp add: l_set_val_def)
using set_val_ok set_val_writes set_val_pointers_preserved set_val_typess_preserved
by blast
paragraph \<open>get\_shadow\_root\<close>
locale l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_val_get_shadow_root:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
by(auto simp add: CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def]
get_shadow_root_locs_def all_args_def)
end
locale l_set_val_get_shadow_root = l_set_val + l_get_shadow_root +
assumes set_val_get_shadow_root:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_shadow_root_locs ptr'. r h h'))"
interpretation
i_set_val_get_shadow_root?: l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf
set_val set_val_locs
get_shadow_root get_shadow_root_locs
apply(auto simp add: l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
using l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
by unfold_locales
declare l_set_val_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_get_shadow_root_is_l_set_val_get_shadow_root [instances]:
"l_set_val_get_shadow_root type_wf set_val set_val_locs get_shadow_root
get_shadow_root_locs"
using set_val_is_l_set_val get_shadow_root_is_l_get_shadow_root
apply(simp add: l_set_val_get_shadow_root_def l_set_val_get_shadow_root_axioms_def)
using set_val_get_shadow_root
by fast
paragraph \<open>get\_tag\_type\<close>
locale l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_val\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma set_val_get_tag_name:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
by(auto simp add: CD.set_val_locs_impl[unfolded CD.a_set_val_locs_def]
CD.get_tag_name_locs_impl[unfolded CD.a_get_tag_name_locs_def]
all_args_def)
end
locale l_set_val_get_tag_name = l_set_val + l_get_tag_name +
assumes set_val_get_tag_name:
"\<forall>w \<in> set_val_locs ptr. (h \<turnstile> w \<rightarrow>\<^sub>h h' \<longrightarrow> (\<forall>r \<in> get_tag_name_locs ptr'. r h h'))"
interpretation
i_set_val_get_tag_name?: l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf DocumentClass.type_wf set_val
set_val_locs get_tag_name get_tag_name_locs
by unfold_locales
declare l_set_val_get_tag_name\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_val_get_tag_name_is_l_set_val_get_tag_name [instances]:
"l_set_val_get_tag_name type_wf set_val set_val_locs get_tag_name get_tag_name_locs"
using set_val_is_l_set_val get_tag_name_is_l_get_tag_name
apply(simp add: l_set_val_get_tag_name_def l_set_val_get_tag_name_axioms_def)
using set_val_get_tag_name
by fast
subsubsection \<open>create\_character\_data\<close>
locale l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_known_ptr known_ptr
for known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
begin
lemma create_character_data_document_in_heap:
assumes "h \<turnstile> ok (create_character_data document_ptr text)"
shows "document_ptr |\<in>| document_ptr_kinds h"
using assms CD.create_character_data_document_in_heap by simp
lemma create_character_data_known_ptr:
assumes "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
shows "known_ptr (cast new_character_data_ptr)"
using assms CD.create_character_data_known_ptr
by(simp add: known_ptr_impl CD.known_ptr_impl ShadowRootClass.a_known_ptr_def)
end
locale l_create_character_data = l_create_character_data_defs
interpretation
i_create_character_data?: l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs set_val
set_val_locs create_character_data known_ptr DocumentClass.type_wf DocumentClass.known_ptr
by(auto simp add: l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_create_character_data\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_element\<close>
locale l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
CD: l_create_element\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M create_element known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_known_ptr known_ptr
for get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and type_wf :: "(_) heap \<Rightarrow> bool"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) object_ptr \<Rightarrow> bool" +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
begin
lemmas create_element_def = CD.create_element_def
lemma create_element_document_in_heap:
assumes "h \<turnstile> ok (create_element document_ptr tag)"
shows "document_ptr |\<in>| document_ptr_kinds h"
using CD.create_element_document_in_heap assms .
lemma create_element_known_ptr:
assumes "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
shows "known_ptr (cast new_element_ptr)"
proof -
have "is_element_ptr new_element_ptr"
using assms
apply(auto simp add: create_element_def elim!: bind_returns_result_E)[1]
using new_element_is_element_ptr
by blast
then show ?thesis
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs)
qed
end
interpretation
i_create_element?: l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf
create_element known_ptr DocumentClass.type_wf DocumentClass.known_ptr
by(auto simp add: l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
subsection \<open>A wellformed heap (Core DOM)\<close>
subsubsection \<open>wellformed\_heap\<close>
locale l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs =
CD: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs +
l_get_shadow_root_defs get_shadow_root get_shadow_root_locs +
l_get_tag_name_defs get_tag_name get_tag_name_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
definition a_host_shadow_root_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
where
"a_host_shadow_root_rel h = (\<lambda>(x, y). (cast x, cast y)) ` {(host, shadow_root).
host |\<in>| element_ptr_kinds h \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root}"
lemma a_host_shadow_root_rel_code [code]: "a_host_shadow_root_rel h = set (concat (map
(\<lambda>host. (case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> [(cast host, cast shadow_root)] |
None \<Rightarrow> []))
(sorted_list_of_fset (element_ptr_kinds h)))
)"
by(auto simp add: a_host_shadow_root_rel_def)
definition a_ptr_disconnected_node_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
where
"a_ptr_disconnected_node_rel h = (\<lambda>(x, y). (cast x, cast y)) ` {(document_ptr, disconnected_node).
document_ptr |\<in>| document_ptr_kinds h \<and> disconnected_node \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r}"
lemma a_ptr_disconnected_node_rel_code [code]: "a_ptr_disconnected_node_rel h = set (concat (map
(\<lambda>ptr. map
(\<lambda>node. (cast ptr, cast node))
|h \<turnstile> get_disconnected_nodes ptr|\<^sub>r)
(sorted_list_of_fset (document_ptr_kinds h)))
)"
by(auto simp add: a_ptr_disconnected_node_rel_def)
definition a_all_ptrs_in_heap :: "(_) heap \<Rightarrow> bool" where
"a_all_ptrs_in_heap h = ((\<forall>host shadow_root_ptr.
(h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr) \<longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h))"
definition a_distinct_lists :: "(_) heap \<Rightarrow> bool"
where
"a_distinct_lists h = distinct (concat (
map (\<lambda>element_ptr. (case |h \<turnstile> get_shadow_root element_ptr|\<^sub>r of
Some shadow_root_ptr \<Rightarrow> [shadow_root_ptr] | None \<Rightarrow> []))
|h \<turnstile> element_ptr_kinds_M|\<^sub>r
))"
definition a_shadow_root_valid :: "(_) heap \<Rightarrow> bool" where
"a_shadow_root_valid h = (\<forall>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h).
(\<exists>host \<in> fset(element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr))"
definition a_heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
where
"a_heap_is_wellformed h \<longleftrightarrow> CD.a_heap_is_wellformed h \<and>
acyclic (CD.a_parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h) \<and>
a_all_ptrs_in_heap h \<and>
a_distinct_lists h \<and>
a_shadow_root_valid h"
end
global_interpretation l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs
get_tag_name get_tag_name_locs
defines heap_is_wellformed = a_heap_is_wellformed
and parent_child_rel = CD.a_parent_child_rel
and host_shadow_root_rel = a_host_shadow_root_rel
and ptr_disconnected_node_rel = a_ptr_disconnected_node_rel
and all_ptrs_in_heap = a_all_ptrs_in_heap
and distinct_lists = a_distinct_lists
and shadow_root_valid = a_shadow_root_valid
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_heap_is_wellformed
and parent_child_rel\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_parent_child_rel
and acyclic_heap\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_acyclic_heap
and all_ptrs_in_heap\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_all_ptrs_in_heap
and distinct_lists\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_distinct_lists
and owner_document_valid\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M = CD.a_owner_document_valid
.
interpretation i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
by (auto simp add: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def parent_child_rel_def instances)
declare i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_heap_is_wellformed [instances]:
"l_heap_is_wellformed type_wf known_ptr heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def)[1]
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_disc_nodes_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_one_parent apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_one_disc_parent apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_disc_nodes_different apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_disconnected_nodes_distinct apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_distinct apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_is_wellformed_children_disc_nodes apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child apply (blast, blast)
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_finite apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_acyclic apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_node_ptr apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent_in_heap apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child_in_heap apply blast
done
locale l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
+ CD: l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
+ l_heap_is_wellformed_defs
heap_is_wellformed parent_child_rel
+ l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_shadow_root get_shadow_root_locs get_host get_host_locs type_wf
+ l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
get_disconnected_document get_disconnected_document_locs type_wf
+ l_get_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root get_shadow_root_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set" +
assumes heap_is_wellformed_impl: "heap_is_wellformed = a_heap_is_wellformed"
begin
lemmas heap_is_wellformed_def = heap_is_wellformed_impl[unfolded a_heap_is_wellformed_def,
folded CD.heap_is_wellformed_impl CD.parent_child_rel_impl]
lemma a_distinct_lists_code [code]: "a_all_ptrs_in_heap h = ((\<forall>host \<in> fset (element_ptr_kinds h).
h \<turnstile> ok (get_shadow_root host) \<longrightarrow> (case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root_ptr \<Rightarrow> shadow_root_ptr |\<in>| shadow_root_ptr_kinds h |
None \<Rightarrow> True)))"
apply(auto simp add: a_all_ptrs_in_heap_def split: option.splits)[1]
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap notin_fset select_result_I2)
lemma get_shadow_root_shadow_root_ptr_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms
by(auto simp add: heap_is_wellformed_def a_all_ptrs_in_heap_def)
lemma get_host_ptr_in_heap:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
shows "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
using assms get_shadow_root_shadow_root_ptr_in_heap
by(auto simp add: get_host_def elim!: bind_returns_result_E2 dest!: filter_M_holds_for_result
intro!: bind_pure_I split: list.splits)
lemma shadow_root_same_host:
assumes "heap_is_wellformed h" and "type_wf h"
assumes "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
assumes "h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr"
shows "host = host'"
proof (rule ccontr)
assume " host \<noteq> host'"
have "host |\<in>| element_ptr_kinds h"
using assms(3)
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap)
moreover
have "host' |\<in>| element_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_result_I local.get_shadow_root_ptr_in_heap)
ultimately show False
using assms
apply(auto simp add: heap_is_wellformed_def a_distinct_lists_def)[1]
apply(drule distinct_concat_map_E(1)[where x=host and y=host'])
apply(simp)
apply(simp)
using \<open>host \<noteq> host'\<close> apply(simp)
apply(auto)[1]
done
qed
lemma shadow_root_host_dual:
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
shows "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms
by(auto simp add: get_host_def dest: filter_M_holds_for_result elim!: bind_returns_result_E2
intro!: bind_pure_I split: list.splits)
lemma disc_doc_disc_node_dual:
assumes "h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disc_doc"
obtains disc_nodes where "h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes" and
"disc_node \<in> set disc_nodes"
using assms get_disconnected_nodes_pure
by(auto simp add: get_disconnected_document_def bind_pure_I
dest!: filter_M_holds_for_result
elim!: bind_returns_result_E2
intro!: filter_M_pure_I
split: if_splits list.splits)
lemma get_host_valid_tag_name:
assumes "heap_is_wellformed h" and "type_wf h"
assumes "h \<turnstile> get_host shadow_root_ptr \<rightarrow>\<^sub>r host"
assumes "h \<turnstile> get_tag_name host \<rightarrow>\<^sub>r tag"
shows "tag \<in> safe_shadow_root_element_types"
proof -
obtain host' where "host' |\<in>| element_ptr_kinds h" and
"|h \<turnstile> get_tag_name host'|\<^sub>r \<in> safe_shadow_root_element_types"
and "h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms
apply(auto simp add: heap_is_wellformed_def a_shadow_root_valid_def)[1]
by (smt assms(1) finite_set_in get_host_ptr_in_heap local.get_shadow_root_ok returns_result_select_result)
then have "host = host'"
by (meson assms(1) assms(2) assms(3) shadow_root_host_dual shadow_root_same_host)
then show ?thesis
by (smt \<open>\<And>thesis. (\<And>host'. \<lbrakk>host' |\<in>| element_ptr_kinds h; |h \<turnstile> get_tag_name host'|\<^sub>r \<in>
safe_shadow_root_element_types; h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow>
thesis\<close> \<open>h \<turnstile> get_shadow_root host' \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1) assms(2) assms(4)
select_result_I2 shadow_root_same_host)
qed
lemma a_host_shadow_root_rel_finite: "finite (a_host_shadow_root_rel h)"
proof -
have "a_host_shadow_root_rel h = (\<Union>host \<in> fset (element_ptr_kinds h).
(case |h \<turnstile> get_shadow_root host|\<^sub>r of Some shadow_root \<Rightarrow> {(cast host, cast shadow_root)} | None \<Rightarrow> {}))"
by(auto simp add: a_host_shadow_root_rel_def split: option.splits)
moreover have "finite (\<Union>host \<in> fset (element_ptr_kinds h). (case |h \<turnstile> get_shadow_root host|\<^sub>r of
Some shadow_root \<Rightarrow> {(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host, cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root)} | None \<Rightarrow> {}))"
by(auto split: option.splits)
ultimately show ?thesis
by auto
qed
lemma a_ptr_disconnected_node_rel_finite: "finite (a_ptr_disconnected_node_rel h)"
proof -
have "a_ptr_disconnected_node_rel h = (\<Union>owner_document \<in> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r.
(\<Union>disconnected_node \<in> set |h \<turnstile> get_disconnected_nodes owner_document|\<^sub>r.
{(cast owner_document, cast disconnected_node)}))"
by(auto simp add: a_ptr_disconnected_node_rel_def)
moreover have "finite (\<Union>owner_document \<in> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r.
(\<Union>disconnected_node \<in> set |h \<turnstile> get_disconnected_nodes owner_document|\<^sub>r.
{(cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disconnected_node)}))"
by simp
ultimately show ?thesis
by simp
qed
lemma heap_is_wellformed_children_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children \<Longrightarrow>
child |\<in>| node_ptr_kinds h"
using CD.heap_is_wellformed_children_in_heap local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_disc_nodes_in_heap:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
node \<in> set disc_nodes \<Longrightarrow> node |\<in>| node_ptr_kinds h"
using CD.heap_is_wellformed_disc_nodes_in_heap local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_one_parent: "heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children' \<Longrightarrow>
set children \<inter> set children' \<noteq> {} \<Longrightarrow> ptr = ptr'"
using CD.heap_is_wellformed_one_parent local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_one_disc_parent: "heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr' \<rightarrow>\<^sub>r disc_nodes' \<Longrightarrow> set disc_nodes \<inter> set disc_nodes' \<noteq> {} \<Longrightarrow>
document_ptr = document_ptr'"
using CD.heap_is_wellformed_one_disc_parent local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_disc_nodes_different: "heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow>
set children \<inter> set disc_nodes = {}"
using CD.heap_is_wellformed_children_disc_nodes_different local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_disconnected_nodes_distinct: "heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> distinct disc_nodes"
using CD.heap_is_wellformed_disconnected_nodes_distinct local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_distinct: "heap_is_wellformed h \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
using CD.heap_is_wellformed_children_distinct local.heap_is_wellformed_def by blast
lemma heap_is_wellformed_children_disc_nodes: "heap_is_wellformed h \<Longrightarrow>
node_ptr |\<in>| node_ptr_kinds h \<Longrightarrow> \<not>(\<exists>parent \<in> fset (object_ptr_kinds h).
node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r) \<Longrightarrow> (\<exists>document_ptr \<in> fset (document_ptr_kinds h).
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using CD.heap_is_wellformed_children_disc_nodes local.heap_is_wellformed_def by blast
lemma parent_child_rel_finite: "heap_is_wellformed h \<Longrightarrow> finite (parent_child_rel h)"
using CD.parent_child_rel_finite by blast
lemma parent_child_rel_acyclic: "heap_is_wellformed h \<Longrightarrow> acyclic (parent_child_rel h)"
using CD.parent_child_rel_acyclic heap_is_wellformed_def by blast
lemma parent_child_rel_child_in_heap: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptr parent \<Longrightarrow>
(parent, child_ptr) \<in> parent_child_rel h \<Longrightarrow> child_ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_child_in_heap local.heap_is_wellformed_def by blast
end
interpretation i_heap_is_wellformed?: l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_host get_host_locs get_disconnected_document get_disconnected_document_locs
by(auto simp add: l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def
l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
parent_child_rel_def heap_is_wellformed_def instances)
declare l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma heap_is_wellformed_is_l_heap_is_wellformed [instances]: "l_heap_is_wellformed
ShadowRootClass.type_wf ShadowRootClass.known_ptr Shadow_DOM.heap_is_wellformed
Shadow_DOM.parent_child_rel Shadow_DOM.get_child_nodes get_disconnected_nodes"
apply(auto simp add: l_heap_is_wellformed_def instances)[1]
using heap_is_wellformed_children_in_heap apply metis
using heap_is_wellformed_disc_nodes_in_heap apply metis
using heap_is_wellformed_one_parent apply blast
using heap_is_wellformed_one_disc_parent apply blast
using heap_is_wellformed_children_disc_nodes_different apply blast
using heap_is_wellformed_disconnected_nodes_distinct apply metis
using heap_is_wellformed_children_distinct apply metis
using heap_is_wellformed_children_disc_nodes apply metis
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child apply(blast, blast)
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_finite apply blast
using parent_child_rel_acyclic apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_node_ptr apply blast
using i_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent_in_heap apply blast
using parent_child_rel_child_in_heap apply metis
done
subsubsection \<open>get\_parent\<close>
interpretation i_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
get_disconnected_nodes
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
interpretation i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs
by(auto simp add: l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_parent_wf [instances]: "l_get_parent_wf type_wf known_ptr
known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes get_parent"
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def instances)[1]
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.child_parent_dual apply fast
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_wellformed_induct apply metis
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.heap_wellformed_induct_rev apply metis
using i_get_parent_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_parent apply fast
done
subsubsection \<open>get\_disconnected\_nodes\<close>
subsubsection \<open>set\_disconnected\_nodes\<close>
paragraph \<open>get\_disconnected\_nodes\<close>
interpretation i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M:
l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
by (simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]:
"l_set_disconnected_nodes_get_disconnected_nodes_wf type_wf known_ptr heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_child_nodes get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def
l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
using i_set_disconnected_nodes_get_disconnected_nodes_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_from_disconnected_nodes_removes
apply fast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M:
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent
get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel known_ptr known_ptrs type_wf
get_ancestors get_ancestors_locs get_child_nodes get_parent"
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def instances)[1]
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_never_empty apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_ok apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_reads apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_ptrs_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_remains_not_in_ancestors apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_also_parent apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_obtains_children apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_parent_child_rel apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_root_node type_wf known_ptr known_ptrs
get_ancestors get_parent"
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def instances)[1]
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_ok apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_ptr_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_root_in_heap apply blast
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_same_root_node apply(blast, blast)
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_same_no_parent apply blast
(* using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_not_node_same apply blast *)
using i_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_root_node_parent_same apply (blast, blast)
done
subsubsection \<open>to\_tree\_order\<close>
interpretation i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent get_parent_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
apply(simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
done
declare i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def instances)[1]
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ok apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ptrs_in_heap apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_parent_child_rel apply(blast, blast)
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_child2 apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_node_ptrs apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_child apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_ptr_in_result apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_parent apply blast
using i_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_subset apply blast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M parent_child_rel get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs
get_ancestors get_ancestors_locs get_root_node get_root_node_locs to_tree_order
by(auto simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf type_wf known_ptr known_ptrs to_tree_order get_root_node heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M"
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def l_to_tree_order_wf_get_root_node_wf_axioms_def instances)[1]
using i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_get_root_node apply blast
using i_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.to_tree_order_same_root apply blast
done
subsubsection \<open>remove\_child\<close>
interpretation i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs
set_child_nodes set_child_nodes_locs get_parent
get_parent_locs get_owner_document get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes
set_disconnected_nodes_locs remove_child remove_child_locs remove type_wf known_ptr known_ptrs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
parent_child_rel
by unfold_locales
declare i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_is_l_remove_child_wf2 [instances]:
"l_remove_child_wf2 type_wf known_ptr known_ptrs remove_child heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_heap_is_wellformed_preserved apply(fast, fast, fast)
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_heap_is_wellformed_preserved apply(fast, fast, fast)
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_removes_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_child_removes_first_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_removes_child apply fast
using i_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.remove_for_all_empty_children apply fast
done
subsection \<open>A wellformed heap\<close>
subsubsection \<open>get\_parent\<close>
interpretation i_get_parent_wf?: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs known_ptrs get_parent get_parent_locs heap_is_wellformed parent_child_rel
get_disconnected_nodes
using instances
by(simp add: l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def)
declare l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_parent_wf_is_l_get_parent_wf [instances]: "l_get_parent_wf ShadowRootClass.type_wf
ShadowRootClass.known_ptr ShadowRootClass.known_ptrs heap_is_wellformed parent_child_rel
Shadow_DOM.get_child_nodes Shadow_DOM.get_parent"
apply(auto simp add: l_get_parent_wf_def l_get_parent_wf_axioms_def instances)[1]
using child_parent_dual apply blast
using heap_wellformed_induct apply metis
using heap_wellformed_induct_rev apply metis
using parent_child_rel_parent apply metis
done
subsubsection \<open>remove\_shadow\_root\<close>
locale l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_tag_name +
l_get_disconnected_nodes +
l_set_shadow_root_get_tag_name +
l_get_child_nodes +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_delete_shadow_root_get_disconnected_nodes +
l_delete_shadow_root_get_child_nodes +
l_set_shadow_root_get_disconnected_nodes +
l_set_shadow_root_get_child_nodes +
l_delete_shadow_root_get_tag_name +
l_set_shadow_root_get_shadow_root +
l_delete_shadow_root_get_shadow_root +
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_shadow_root_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_shadow_root ptr \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'" and "type_wf h'" "heap_is_wellformed h'"
proof -
obtain shadow_root_ptr h2 where
"h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr" and
"h \<turnstile> get_child_nodes (cast shadow_root_ptr) \<rightarrow>\<^sub>r []" and
"h \<turnstile> get_disconnected_nodes (cast shadow_root_ptr) \<rightarrow>\<^sub>r []" and
h2: "h \<turnstile> set_shadow_root ptr None \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> delete_M shadow_root_ptr \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: remove_shadow_root_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: option.splits if_splits)
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_shadow_root_writes h2]
using \<open>type_wf h\<close> set_shadow_root_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using h' delete_shadow_root_type_wf_preserved local.type_wf_impl
by blast
have object_ptr_kinds_eq_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_shadow_root_writes h2])
using set_shadow_root_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
have node_ptr_kinds_eq_h: "node_ptr_kinds h = node_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: node_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h = element_ptr_kinds h2"
using node_ptr_kinds_eq_h
by (simp add: element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h = document_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h
by (simp add: document_ptr_kinds_eq_h shadow_root_ptr_kinds_def)
have "known_ptrs h2"
using \<open>known_ptrs h\<close> object_ptr_kinds_eq_h known_ptrs_subset
by blast
have object_ptr_kinds_eq_h2: "object_ptr_kinds h' |\<subseteq>| object_ptr_kinds h2"
using h' delete_shadow_root_pointers
by auto
have object_ptr_kinds_eq2_h2: "object_ptr_kinds h2 = object_ptr_kinds h' |\<union>| {|cast shadow_root_ptr|}"
using h' delete_shadow_root_pointers
by auto
have node_ptr_kinds_eq_h2: "node_ptr_kinds h2 = node_ptr_kinds h'"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def delete_shadow_root_pointers[OF h'])
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h'"
using node_ptr_kinds_eq_h2
by (simp add: element_ptr_kinds_def)
have document_ptr_kinds_eq_h2: "document_ptr_kinds h2 = document_ptr_kinds h' |\<union>| {|cast shadow_root_ptr|}"
using object_ptr_kinds_eq_h2
apply(auto simp add: document_ptr_kinds_def delete_shadow_root_pointers[OF h'])[1]
using document_ptr_kinds_def by fastforce
then
have document_ptr_kinds_eq2_h2: "document_ptr_kinds h' |\<subseteq>| document_ptr_kinds h2"
using h' delete_shadow_root_pointers
by auto
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h' |\<subseteq>| shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h2
apply(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)[1]
by auto
have shadow_root_ptr_kinds_eq2_h2: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h' |\<union>| {|shadow_root_ptr|}"
using object_ptr_kinds_eq2_h2
apply (auto simp add: shadow_root_ptr_kinds_def)[1]
using document_ptr_kinds_eq_h2 apply auto[1]
apply (metis \<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1) document_ptr_kinds_eq_h
fset.map_comp local.get_shadow_root_shadow_root_ptr_in_heap shadow_root_ptr_kinds_def)
using document_ptr_kinds_eq_h2 by auto
show "known_ptrs h'"
using object_ptr_kinds_eq_h2 \<open>known_ptrs h2\<close> known_ptrs_subset
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_shadow_root_writes h2 set_shadow_root_get_disconnected_nodes
by(rule reads_writes_preserved)
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> cast shadow_root_ptr \<Longrightarrow> h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads get_disconnected_nodes_delete_shadow_root[rotated, OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by(metis (no_types, lifting))+
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. doc_ptr \<noteq> cast shadow_root_ptr \<Longrightarrow> |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r =
|h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes =
h2 \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_shadow_root_writes h2 set_shadow_root_get_tag_name
by(rule reads_writes_preserved)
then have tag_name_eq2_h: "\<And>doc_ptr. |h \<turnstile> get_tag_name doc_ptr|\<^sub>r = |h2 \<turnstile> get_tag_name doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_tag_name doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads get_tag_name_delete_shadow_root[OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h2: "\<And>doc_ptr. |h2 \<turnstile> get_tag_name doc_ptr|\<^sub>r = |h' \<turnstile> get_tag_name doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h:
"\<And>ptr' children. h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_shadow_root_writes h2 set_shadow_root_get_child_nodes
by(rule reads_writes_preserved)
then have children_eq2_h: "\<And>ptr'. |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children =
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads h' get_child_nodes_delete_shadow_root
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h2:
"\<And>ptr'. ptr' \<noteq> cast shadow_root_ptr \<Longrightarrow> |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "cast shadow_root_ptr |\<notin>| object_ptr_kinds h'"
using h' delete\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap
by auto
have get_shadow_root_eq_h:
"\<And>shadow_root_opt ptr'. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads set_shadow_root_writes h2
apply(rule reads_writes_preserved)
using set_shadow_root_get_shadow_root_different_pointers
by fast
have get_shadow_root_eq_h2:
"\<And>shadow_root_opt ptr'. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads get_shadow_root_delete_shadow_root[OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then
have get_shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
moreover
have "parent_child_rel h = parent_child_rel h2"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h children_eq2_h)
moreover
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
using object_ptr_kinds_eq_h2
apply(auto simp add: CD.parent_child_rel_def)[1]
by (metis \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> children_eq2_h2)
ultimately
have "CD.a_acyclic_heap h'"
using acyclic_subset
by (auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
moreover
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def object_ptr_kinds_eq_h node_ptr_kinds_def
children_eq_h disconnected_nodes_eq_h)[1]
apply (metis (no_types, lifting) children_eq2_h finite_set_in subsetD)
by (metis (no_types, lifting) disconnected_nodes_eq2_h document_ptr_kinds_eq_h
finite_set_in in_mono)
then have "CD.a_all_ptrs_in_heap h'"
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 children_eq_h2
disconnected_nodes_eq_h2)[1]
apply(case_tac "ptr = cast shadow_root_ptr")
using object_ptr_kinds_eq_h2 children_eq_h2
apply (meson \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close>
is_OK_returns_result_I local.get_child_nodes_ptr_in_heap)
apply(auto dest!: children_eq_h2)[1]
using assms(1) children_eq_h local.heap_is_wellformed_children_in_heap node_ptr_kinds_eq_h
node_ptr_kinds_eq_h2 apply blast
apply (meson \<open>known_ptrs h'\<close> \<open>type_wf h'\<close> local.get_child_nodes_ok local.known_ptrs_known_ptr
returns_result_select_result)
by (metis (no_types, lifting) \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close>
\<open>type_wf h2\<close> assms(1) disconnected_nodes_eq2_h2 disconnected_nodes_eq_h document_ptr_kinds_commutes
document_ptr_kinds_eq2_h2 fin_mono local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq_h node_ptr_kinds_eq_h2
returns_result_select_result)
moreover
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
by(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
children_eq2_h disconnected_nodes_eq2_h)
then have "CD.a_distinct_lists h'"
apply(auto simp add: CD.a_distinct_lists_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)[1]
apply(auto simp add: intro!: distinct_concat_map_I)[1]
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
using children_eq_h2 concat_map_all_distinct[of "(\<lambda>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r)"]
- apply (metis (no_types, lifting) children_eq2_h2 finite_fset fmember.rep_eq fset_mp
+ apply (metis (no_types, lifting) children_eq2_h2 finite_fset fmember_iff_member_fset fset_mp
object_ptr_kinds_eq_h2 set_sorted_list_of_set)
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
apply(case_tac "y = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
using children_eq_h2 distinct_concat_map_E(1)[of "(\<lambda>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r)"]
- apply (smt IntI children_eq2_h2 empty_iff finite_fset fmember.rep_eq fset_mp
+ apply (smt IntI children_eq2_h2 empty_iff finite_fset fmember_iff_member_fset fset_mp
object_ptr_kinds_eq_h2 set_sorted_list_of_set)
apply(auto simp add: intro!: distinct_concat_map_I)[1]
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> document_ptr_kinds_commutes
apply blast
apply (metis (mono_tags, lifting) \<open>local.CD.a_distinct_lists h2\<close> \<open>type_wf h'\<close>
disconnected_nodes_eq_h2 is_OK_returns_result_E local.CD.distinct_lists_disconnected_nodes
local.get_disconnected_nodes_ok select_result_I2)
apply(case_tac "x = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
apply(case_tac "y = cast shadow_root_ptr")
using \<open>cast shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply simp
proof -
fix x and y and xa
assume a1: "x |\<in>| document_ptr_kinds h'"
assume a2: "y |\<in>| document_ptr_kinds h'"
assume a3: "x \<noteq> y"
assume a4: "x \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr"
assume a5: "y \<noteq> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr"
assume a6: "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a7: "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
assume "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(insort (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) (sorted_list_of_set (fset (document_ptr_kinds h') -
{cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr})))))"
then show False
using a7 a6 a5 a4 a3 a2 a1 by (metis (no_types) IntI
distinct_concat_map_E(1)[of "(\<lambda>ptr. |h2 \<turnstile> get_disconnected_nodes ptr|\<^sub>r)"] disconnected_nodes_eq2_h2
- empty_iff finite_fset finsert.rep_eq fmember.rep_eq insert_iff set_sorted_list_of_set
+ empty_iff finite_fset finsert.rep_eq fmember_iff_member_fset insert_iff set_sorted_list_of_set
sorted_list_of_set_insert_remove)
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h2)))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(insort (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) (sorted_list_of_set (fset (document_ptr_kinds h') -
{cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr})))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h2). set |h2 \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>set (insort (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) (sorted_list_of_set (fset (document_ptr_kinds h') -
{cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr}))). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show "False"
apply(cases "xa = cast shadow_root_ptr")
using \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> apply blast
apply(cases "xb = cast shadow_root_ptr")
using \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close> document_ptr_kinds_commutes
apply blast
by (metis (no_types, opaque_lifting) \<open>local.CD.a_distinct_lists h2\<close> \<open>type_wf h'\<close> children_eq2_h2
disconnected_nodes_eq_h2 fset_rev_mp is_OK_returns_result_E local.CD.distinct_lists_no_parent
local.get_disconnected_nodes_ok object_ptr_kinds_eq_h2 select_result_I2)
qed
moreover
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h2"
by(auto simp add: CD.a_owner_document_valid_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
node_ptr_kinds_eq_h children_eq2_h disconnected_nodes_eq2_h)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def document_ptr_kinds_eq_h2 node_ptr_kinds_eq_h2
disconnected_nodes_eq2_h2)[1]
by (smt \<open>h \<turnstile> get_child_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>h \<turnstile> get_disconnected_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> \<open>local.CD.a_distinct_lists h\<close>
children_eq2_h children_eq2_h2 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 finite_set_in finsert_iff
funion_finsert_right local.CD.distinct_lists_no_parent object_ptr_kinds_eq2_h2 object_ptr_kinds_eq_h
select_result_I2 sup_bot.comm_neutral)
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
by(simp add: CD.heap_is_wellformed_def)
moreover
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "acyclic (parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2)"
proof -
have "a_host_shadow_root_rel h2 \<subseteq> a_host_shadow_root_rel h"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h)[1]
apply(case_tac "aa = ptr")
apply(simp)
apply (metis (no_types, lifting) \<open>type_wf h2\<close> assms(2) h2 local.get_shadow_root_ok
local.type_wf_impl option.distinct(1) returns_result_eq returns_result_select_result
set_shadow_root_get_shadow_root)
using get_shadow_root_eq_h
by (metis (mono_tags, lifting) \<open>type_wf h2\<close> image_eqI is_OK_returns_result_E
local.get_shadow_root_ok mem_Collect_eq prod.simps(2) select_result_I2)
moreover have "a_ptr_disconnected_node_rel h = a_ptr_disconnected_node_rel h2"
by (simp add: a_ptr_disconnected_node_rel_def disconnected_nodes_eq2_h document_ptr_kinds_eq_h)
ultimately show ?thesis
using \<open>parent_child_rel h = parent_child_rel h2\<close>
by (smt \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union>
local.a_ptr_disconnected_node_rel h)\<close> acyclic_subset subset_refl sup_mono)
qed
then
have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
proof -
have "a_host_shadow_root_rel h' \<subseteq> a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 get_shadow_root_eq2_h2)
moreover have "a_ptr_disconnected_node_rel h2 = a_ptr_disconnected_node_rel h'"
apply(simp add: a_ptr_disconnected_node_rel_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2)
by (metis (no_types, lifting) \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close>
\<open>h \<turnstile> get_child_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>h \<turnstile> get_disconnected_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr) \<rightarrow>\<^sub>r []\<close> \<open>local.CD.a_distinct_lists h\<close>
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 document_ptr_kinds_commutes is_OK_returns_result_I
local.CD.distinct_lists_no_parent local.get_disconnected_nodes_ptr_in_heap select_result_I2)
ultimately show ?thesis
using \<open>parent_child_rel h' \<subseteq> parent_child_rel h2\<close>
\<open>acyclic (parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2)\<close>
using acyclic_subset order_refl sup_mono
by (metis (no_types, opaque_lifting))
qed
moreover
have "a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
apply(case_tac "host = ptr")
apply(simp)
apply (metis assms(2) h2 local.type_wf_impl option.distinct(1) returns_result_eq
set_shadow_root_get_shadow_root)
using get_shadow_root_eq_h
by fastforce
then
have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def get_shadow_root_eq_h2)[1]
apply(auto simp add: shadow_root_ptr_kinds_eq2_h2)[1]
by (metis (no_types, lifting) \<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(1) assms(2)
get_shadow_root_eq_h get_shadow_root_eq_h2 h2 local.shadow_root_same_host local.type_wf_impl
option.distinct(1) select_result_I2 set_shadow_root_get_shadow_root)
moreover
have "a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h)[1]
apply(auto intro!: distinct_concat_map_I split: option.splits)[1]
apply(case_tac "x = ptr")
apply(simp)
apply (metis (no_types, opaque_lifting) assms(2) h2 is_OK_returns_result_I
l_set_shadow_root_get_shadow_root.set_shadow_root_get_shadow_root
l_set_shadow_root_get_shadow_root_axioms local.type_wf_impl option.discI returns_result_eq
returns_result_select_result)
apply(case_tac "y = ptr")
apply(simp)
apply (metis (no_types, opaque_lifting) assms(2) h2 is_OK_returns_result_I
l_set_shadow_root_get_shadow_root.set_shadow_root_get_shadow_root
l_set_shadow_root_get_shadow_root_axioms local.type_wf_impl option.discI returns_result_eq
returns_result_select_result)
by (metis \<open>type_wf h2\<close> assms(1) assms(2) get_shadow_root_eq_h local.get_shadow_root_ok
local.shadow_root_same_host returns_result_select_result)
then
have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 get_shadow_root_eq2_h2)
moreover
have "a_shadow_root_valid h"
using \<open>heap_is_wellformed h\<close>
by(simp add: heap_is_wellformed_def)
then
have "a_shadow_root_valid h'"
apply(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h element_ptr_kinds_eq_h
tag_name_eq2_h)[1]
apply(simp add: shadow_root_ptr_kinds_eq2_h2 element_ptr_kinds_eq_h2 tag_name_eq2_h2)
using get_shadow_root_eq_h get_shadow_root_eq_h2
by (smt \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr |\<notin>| object_ptr_kinds h'\<close>
\<open>h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r Some shadow_root_ptr\<close> assms(2) document_ptr_kinds_commutes
element_ptr_kinds_eq_h element_ptr_kinds_eq_h2 finite_set_in local.get_shadow_root_ok
option.inject returns_result_select_result select_result_I2 shadow_root_ptr_kinds_commutes)
ultimately show "heap_is_wellformed h'"
by(simp add: heap_is_wellformed_def)
qed
end
interpretation i_remove_shadow_root_wf?: l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_tag_name get_tag_name_locs get_disconnected_nodes get_disconnected_nodes_locs
set_shadow_root set_shadow_root_locs known_ptr get_child_nodes get_child_nodes_locs get_shadow_root
get_shadow_root_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host
get_host_locs get_disconnected_document get_disconnected_document_locs remove_shadow_root
remove_shadow_root_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_root\_node\<close>
interpretation i_get_root_node_wf?:
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_parent
get_parent_locs get_ancestors get_ancestors_locs get_root_node get_root_node_locs
by(simp add: l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms[instances]
lemma get_ancestors_wf_is_l_get_ancestors_wf [instances]:
"l_get_ancestors_wf heap_is_wellformed parent_child_rel known_ptr known_ptrs type_wf get_ancestors
get_ancestors_locs get_child_nodes get_parent"
apply(auto simp add: l_get_ancestors_wf_def l_get_ancestors_wf_axioms_def instances)[1]
using get_ancestors_never_empty apply blast
using get_ancestors_ok apply blast
using get_ancestors_reads apply blast
using get_ancestors_ptrs_in_heap apply blast
using get_ancestors_remains_not_in_ancestors apply blast
using get_ancestors_also_parent apply blast
using get_ancestors_obtains_children apply blast
using get_ancestors_parent_child_rel apply blast
using get_ancestors_parent_child_rel apply blast
done
lemma get_root_node_wf_is_l_get_root_node_wf [instances]:
"l_get_root_node_wf heap_is_wellformed get_root_node type_wf known_ptr known_ptrs get_ancestors get_parent"
using known_ptrs_is_l_known_ptrs
apply(auto simp add: l_get_root_node_wf_def l_get_root_node_wf_axioms_def)[1]
using get_root_node_ok apply blast
using get_root_node_ptr_in_heap apply blast
using get_root_node_root_in_heap apply blast
using get_ancestors_same_root_node apply(blast, blast)
using get_root_node_same_no_parent apply blast
(* using get_root_node_not_node_same apply blast *)
using get_root_node_parent_same apply (blast, blast)
done
subsubsection \<open>get\_parent\_get\_host\_get\_disconnected\_document\<close>
locale l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs
get_disconnected_document get_disconnected_document_locs +
l_get_disconnected_document get_disconnected_document get_disconnected_document_locs +
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_get_parent_wf type_wf known_ptr known_ptrs heap_is_wellformed parent_child_rel get_child_nodes
get_child_nodes_locs get_parent get_parent_locs +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_get_host get_host get_host_locs +
l_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs
for get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptr :: "(_) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and get_parent :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) object_ptr option) prog"
and get_parent_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
begin
lemma a_host_shadow_root_rel_shadow_root:
"h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r shadow_root_option \<Longrightarrow> shadow_root_option = Some shadow_root \<longleftrightarrow>
((cast host, cast shadow_root) \<in> a_host_shadow_root_rel h)"
apply(auto simp add: a_host_shadow_root_rel_def)[1]
by(metis (mono_tags, lifting) case_prodI is_OK_returns_result_I
l_get_shadow_root.get_shadow_root_ptr_in_heap local.l_get_shadow_root_axioms mem_Collect_eq
pair_imageI select_result_I2)
lemma a_host_shadow_root_rel_host:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host \<Longrightarrow>
((cast host, cast shadow_root) \<in> a_host_shadow_root_rel h)"
apply(auto simp add: a_host_shadow_root_rel_def)[1]
using shadow_root_host_dual
by (metis (no_types, lifting) Collect_cong a_host_shadow_root_rel_shadow_root
local.a_host_shadow_root_rel_def split_cong)
lemma a_ptr_disconnected_node_rel_disconnected_node:
"h \<turnstile> get_disconnected_nodes document \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> node_ptr \<in> set disc_nodes \<longleftrightarrow>
(cast document, cast node_ptr) \<in> a_ptr_disconnected_node_rel h"
apply(auto simp add: a_ptr_disconnected_node_rel_def)[1]
by (smt CD.get_disconnected_nodes_ptr_in_heap case_prodI is_OK_returns_result_I mem_Collect_eq
pair_imageI select_result_I2)
lemma a_ptr_disconnected_node_rel_document:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> get_disconnected_document node_ptr \<rightarrow>\<^sub>r document \<Longrightarrow>
(cast document, cast node_ptr) \<in> a_ptr_disconnected_node_rel h"
apply(auto simp add: a_ptr_disconnected_node_rel_def)[1]
using disc_doc_disc_node_dual
by (metis (no_types, lifting) local.a_ptr_disconnected_node_rel_def
a_ptr_disconnected_node_rel_disconnected_node)
lemma heap_wellformed_induct_si [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
assumes "\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow> child \<in> set children \<Longrightarrow>
P (cast child))
\<Longrightarrow> (\<And>shadow_root host. parent = cast host \<Longrightarrow> h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root \<Longrightarrow>
P (cast shadow_root))
\<Longrightarrow> (\<And>owner_document disc_nodes node_ptr. parent = cast owner_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> node_ptr \<in> set disc_nodes \<Longrightarrow> P (cast node_ptr))
\<Longrightarrow> P parent"
shows "P ptr"
proof -
fix ptr
have "finite (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using a_host_shadow_root_rel_finite a_ptr_disconnected_node_rel_finite
using local.CD.parent_child_rel_finite local.CD.parent_child_rel_impl
by auto
then
have "wf ((parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<inverse>)"
using assms(1)
apply(simp add: heap_is_wellformed_def)
by (simp add: finite_acyclic_wf_converse local.CD.parent_child_rel_impl)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
apply(auto)[1]
using assms a_ptr_disconnected_node_rel_disconnected_node a_host_shadow_root_rel_shadow_root
local.CD.parent_child_rel_child
by blast
qed
qed
lemma heap_wellformed_induct_rev_si [consumes 1, case_names step]:
assumes "heap_is_wellformed h"
assumes "\<And>child. (\<And>parent child_node. child = cast child_node \<Longrightarrow>
h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent)
\<Longrightarrow> (\<And>host shadow_root. child = cast shadow_root \<Longrightarrow> h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host \<Longrightarrow>
P (cast host))
\<Longrightarrow> (\<And>disc_doc disc_node. child = cast disc_node \<Longrightarrow>
h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disc_doc\<Longrightarrow> P (cast disc_doc))
\<Longrightarrow> P child"
shows "P ptr"
proof -
fix ptr
have "finite (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using a_host_shadow_root_rel_finite a_ptr_disconnected_node_rel_finite
using local.CD.parent_child_rel_finite local.CD.parent_child_rel_impl
by auto
then
have "wf (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using assms(1)
apply(simp add: heap_is_wellformed_def)
by (simp add: finite_acyclic_wf)
then show "?thesis"
proof (induct rule: wf_induct_rule)
case (less parent)
then show ?case
apply(auto)[1]
using parent_child_rel_parent a_host_shadow_root_rel_host a_ptr_disconnected_node_rel_document
using assms(1) assms(2) by auto
qed
qed
end
interpretation i_get_parent_get_host_get_disconnected_document_wf?:
l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_parent_get_host_wf =
l_heap_is_wellformed_defs +
l_get_parent_defs +
l_get_shadow_root_defs +
l_get_host_defs +
l_get_child_nodes_defs +
l_get_disconnected_document_defs +
l_get_disconnected_nodes_defs +
assumes heap_wellformed_induct_si [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>parent. (\<And>children child. h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children \<Longrightarrow>
child \<in> set children \<Longrightarrow> P (cast child))
\<Longrightarrow> (\<And>shadow_root host. parent = cast host \<Longrightarrow>
h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root \<Longrightarrow> P (cast shadow_root))
\<Longrightarrow> (\<And>owner_document disc_nodes node_ptr. parent = cast owner_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes \<Longrightarrow> node_ptr \<in> set disc_nodes \<Longrightarrow>
P (cast node_ptr))
\<Longrightarrow> P parent)
\<Longrightarrow> P ptr"
assumes heap_wellformed_induct_rev_si [consumes 1, case_names step]:
"heap_is_wellformed h
\<Longrightarrow> (\<And>child. (\<And>parent child_node. child = cast child_node \<Longrightarrow>
h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent \<Longrightarrow> P parent)
\<Longrightarrow> (\<And>host shadow_root. child = cast shadow_root \<Longrightarrow>
h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host \<Longrightarrow> P (cast host))
\<Longrightarrow> (\<And>disc_doc disc_node. child = cast disc_node \<Longrightarrow>
h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disc_doc \<Longrightarrow> P (cast disc_doc))
\<Longrightarrow> P child)
\<Longrightarrow> P ptr"
lemma l_get_parent_get_host_wf_is_get_parent_get_host_wf [instances]:
"l_get_parent_get_host_wf heap_is_wellformed get_parent get_shadow_root get_host get_child_nodes
get_disconnected_document get_disconnected_nodes"
using heap_wellformed_induct_si heap_wellformed_induct_rev_si
using l_get_parent_get_host_wf_def by blast
subsubsection \<open>get\_host\<close>
locale l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs +
l_type_wf type_wf +
l_get_host\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_shadow_root get_shadow_root_locs get_host get_host_locs type_wf +
l_get_shadow_root type_wf get_shadow_root get_shadow_root_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma get_host_ok [simp]:
assumes "heap_is_wellformed h"
assumes "type_wf h"
assumes "known_ptrs h"
assumes "shadow_root_ptr |\<in>| shadow_root_ptr_kinds h"
shows "h \<turnstile> ok (get_host shadow_root_ptr)"
proof -
obtain host where host: "host |\<in>| element_ptr_kinds h"
and "|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types"
and shadow_root: "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root_ptr"
using assms(1) assms(4) get_shadow_root_ok assms(2)
apply(auto simp add: heap_is_wellformed_def a_shadow_root_valid_def)[1]
by (smt finite_set_in returns_result_select_result)
obtain host_candidates where
host_candidates: "h \<turnstile> filter_M (\<lambda>element_ptr. Heap_Error_Monad.bind (get_shadow_root element_ptr)
(\<lambda>shadow_root_opt. return (shadow_root_opt = Some shadow_root_ptr)))
(sorted_list_of_set (fset (element_ptr_kinds h)))
\<rightarrow>\<^sub>r host_candidates"
apply(drule is_OK_returns_result_E[rotated])
using get_shadow_root_ok assms(2)
by(auto intro!: filter_M_is_OK_I bind_pure_I bind_is_OK_I2)
then have "host_candidates = [host]"
apply(rule filter_M_ex1)
using host apply(auto)[1]
apply (smt assms(1) assms(2) bind_pure_returns_result_I2 bind_returns_result_E finite_set_in host
local.get_shadow_root_ok local.get_shadow_root_pure local.shadow_root_same_host return_returns_result
returns_result_eq shadow_root sorted_list_of_fset.rep_eq sorted_list_of_fset_simps(1))
apply (simp add: bind_pure_I)
apply(auto intro!: bind_pure_returns_result_I)[1]
apply (smt assms(2) bind_pure_returns_result_I2 host local.get_shadow_root_ok
local.get_shadow_root_pure return_returns_result returns_result_eq shadow_root)
done
then
show ?thesis
using host_candidates host assms(1) get_shadow_root_ok
apply(auto simp add: get_host_def known_ptrs_known_ptr
intro!: bind_is_OK_pure_I filter_M_pure_I filter_M_is_OK_I bind_pure_I split: list.splits)[1]
using assms(2) apply blast
apply (meson list.distinct(1) returns_result_eq)
by (meson list.distinct(1) list.inject returns_result_eq)
qed
end
interpretation i_get_host_wf?: l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_disconnected_document get_disconnected_document_locs known_ptr known_ptrs type_wf get_host
get_host_locs get_shadow_root get_shadow_root_locs get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_host_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
locale l_get_host_wf = l_heap_is_wellformed_defs + l_known_ptrs + l_type_wf + l_get_host_defs +
assumes get_host_ok: "heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h \<Longrightarrow>
shadow_root_ptr |\<in>| shadow_root_ptr_kinds h \<Longrightarrow> h \<turnstile> ok (get_host shadow_root_ptr)"
lemma get_host_wf_is_l_get_host_wf [instances]: "l_get_host_wf heap_is_wellformed known_ptr
known_ptrs type_wf get_host"
by(auto simp add: l_get_host_wf_def l_get_host_wf_axioms_def instances)
subsubsection \<open>get\_root\_node\_si\<close>
locale l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_root_node_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_parent_get_host_wf +
l_get_host_wf
begin
lemma get_root_node_ptr_in_heap:
assumes "h \<turnstile> ok (get_root_node_si ptr)"
shows "ptr |\<in>| object_ptr_kinds h"
using assms
unfolding get_root_node_si_def
using get_ancestors_si_ptr_in_heap
by auto
lemma get_ancestors_si_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_ancestors_si ptr)"
proof (insert assms(1) assms(4), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using assms(2) assms(3)
apply(auto simp add: get_ancestors_si_def[of child] assms(1) get_parent_parent_in_heap
intro!: bind_is_OK_pure_I split: option.splits)[1]
using local.get_parent_ok apply blast
using get_host_ok assms(1) apply blast
by (meson assms(1) is_OK_returns_result_I local.get_shadow_root_ptr_in_heap
local.shadow_root_host_dual)
qed
lemma get_ancestors_si_remains_not_in_ancestors:
assumes "heap_is_wellformed h"
and "heap_is_wellformed h'"
and "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
and "h' \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors'"
and "\<And>p children children'. h \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children
\<Longrightarrow> h' \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children' \<Longrightarrow> set children' \<subseteq> set children"
and "\<And>p shadow_root_option shadow_root_option'. h \<turnstile> get_shadow_root p \<rightarrow>\<^sub>r shadow_root_option \<Longrightarrow>
h' \<turnstile> get_shadow_root p \<rightarrow>\<^sub>r shadow_root_option' \<Longrightarrow> (if shadow_root_option = None
then shadow_root_option' = None else shadow_root_option' = None \<or> shadow_root_option' = shadow_root_option)"
and "node \<notin> set ancestors"
and object_ptr_kinds_eq3: "object_ptr_kinds h = object_ptr_kinds h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
and type_wf': "type_wf h'"
shows "node \<notin> set ancestors'"
proof -
have object_ptr_kinds_M_eq:
"\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
using object_ptr_kinds_eq3
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
show ?thesis
proof (insert assms(1) assms(3) assms(4) assms(7), induct ptr arbitrary: ancestors ancestors'
rule: heap_wellformed_induct_rev_si)
case (step child)
obtain ancestors_remains where ancestors_remains:
"ancestors = child # ancestors_remains"
using \<open>h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors\<close> get_ancestors_si_never_empty
by(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2 split: option.splits)
obtain ancestors_remains' where ancestors_remains':
"ancestors' = child # ancestors_remains'"
using \<open>h' \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors'\<close> get_ancestors_si_never_empty
by(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2 split: option.splits)
have "child |\<in>| object_ptr_kinds h"
using local.get_ancestors_si_ptr_in_heap object_ptr_kinds_eq3 step.prems(2) by fastforce
have "node \<noteq> child"
using ancestors_remains step.prems(3) by auto
have 1: "\<And>p parent. h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent \<Longrightarrow> h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
proof -
fix p parent
assume "h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
then obtain children' where
children': "h' \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children'" and
p_in_children': "p \<in> set children'"
using get_parent_child_dual by blast
obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using get_child_nodes_ok assms(1) get_child_nodes_ptr_in_heap object_ptr_kinds_eq children'
known_ptrs
using type_wf type_wf'
by (metis \<open>h' \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent\<close> get_parent_parent_in_heap is_OK_returns_result_E
local.known_ptrs_known_ptr object_ptr_kinds_eq3)
have "p \<in> set children"
using assms(5) children children' p_in_children'
by blast
then show "h \<turnstile> get_parent p \<rightarrow>\<^sub>r Some parent"
using child_parent_dual assms(1) children known_ptrs type_wf by blast
qed
have 2: "\<And>p host. h' \<turnstile> get_host p \<rightarrow>\<^sub>r host \<Longrightarrow> h \<turnstile> get_host p \<rightarrow>\<^sub>r host"
proof -
fix p host
assume "h' \<turnstile> get_host p \<rightarrow>\<^sub>r host"
then have "h' \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some p"
using local.shadow_root_host_dual by blast
then have "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some p"
by (metis assms(6) element_ptr_kinds_commutes is_OK_returns_result_I local.get_shadow_root_ok
local.get_shadow_root_ptr_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq3 option.distinct(1)
returns_result_select_result type_wf)
then show "h \<turnstile> get_host p \<rightarrow>\<^sub>r host"
by (metis assms(1) is_OK_returns_result_E known_ptrs local.get_host_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.shadow_root_host_dual local.shadow_root_same_host
type_wf)
qed
show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?thesis
using step(4) step(5) \<open>node \<noteq> child\<close>
apply(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2
split: option.splits)[1]
by (metis "2" assms(1) shadow_root_same_host list.set_intros(2) shadow_root_host_dual
step.hyps(2) step.prems(3) type_wf)
next
case (Some node_child)
then
show ?thesis
using step(4) step(5) \<open>node \<noteq> child\<close>
apply(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2
split: option.splits)[1]
apply (meson "1" option.distinct(1) returns_result_eq)
by (metis "1" list.set_intros(2) option.inject returns_result_eq step.hyps(1) step.prems(3))
qed
qed
qed
lemma get_ancestors_si_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
shows "ptr' |\<in>| object_ptr_kinds h"
proof (insert assms(4) assms(5), induct ancestors arbitrary: ptr)
case Nil
then show ?case
by(auto)
next
case (Cons a ancestors)
then obtain x where x: "h \<turnstile> get_ancestors_si x \<rightarrow>\<^sub>r a # ancestors"
by(auto simp add: get_ancestors_si_def[of a] elim!: bind_returns_result_E2 split: option.splits)
then have "x = a"
by(auto simp add: get_ancestors_si_def[of x] elim!: bind_returns_result_E2 split: option.splits)
then show ?case
proof (cases "ptr' = a")
case True
then show ?thesis
using Cons.hyps Cons.prems(2) get_ancestors_si_ptr_in_heap x
using \<open>x = a\<close> by blast
next
case False
obtain ptr'' where ptr'': "h \<turnstile> get_ancestors_si ptr'' \<rightarrow>\<^sub>r ancestors"
using \<open> h \<turnstile> get_ancestors_si x \<rightarrow>\<^sub>r a # ancestors\<close> Cons.prems(2) False
apply(auto simp add: get_ancestors_si_def elim!: bind_returns_result_E2)[1]
apply(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I)[1]
apply(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I)[1]
apply (metis local.get_ancestors_si_def)
by (simp add: local.get_ancestors_si_def)
then show ?thesis
using Cons.hyps Cons.prems(2) False by auto
qed
qed
lemma get_ancestors_si_reads:
assumes "heap_is_wellformed h"
shows "reads get_ancestors_si_locs (get_ancestors_si node_ptr) h h'"
proof (insert assms(1), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using [[simproc del: Product_Type.unit_eq]] get_parent_reads[unfolded reads_def]
get_host_reads[unfolded reads_def]
apply(simp (no_asm) add: get_ancestors_si_def)
by(auto simp add: get_ancestors_si_locs_def get_parent_reads_pointers
intro!: reads_bind_pure reads_subset[OF check_in_heap_reads] reads_subset[OF return_reads]
reads_subset[OF get_parent_reads] reads_subset[OF get_child_nodes_reads]
reads_subset[OF get_host_reads]
split: option.splits)
qed
lemma get_ancestors_si_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors_si ancestor \<rightarrow>\<^sub>r ancestor_ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "set ancestor_ancestors \<subseteq> set ancestors"
proof (insert assms(1) assms(2) assms(3), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev_si)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_si_ptr_in_heap step(4) by auto
(* then have "h \<turnstile> check_in_heap child \<rightarrow>\<^sub>r ()"
using returns_result_select_result by force *)
obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using step(4)
by(auto simp add: get_ancestors_si_def[of child] intro!: bind_pure_I
elim!: bind_returns_result_E2 split: option.splits)
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?case
using step(4) \<open>None = cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child\<close>
apply(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2)[1]
by (metis (no_types, lifting) assms(4) empty_iff empty_set select_result_I2 set_ConsD
step.prems(1) step.prems(2))
next
case (Some shadow_root_child)
then
have "cast shadow_root_child |\<in>| document_ptr_kinds h"
using \<open>child |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: document_ptr_kinds_def split: option.splits)[1]
by (metis (mono_tags, lifting) document_ptr_casts_commute3 document_ptr_kinds_commutes
document_ptr_kinds_def fset.map_comp shadow_root_ptr_casts_commute)
then
have "shadow_root_child |\<in>| shadow_root_ptr_kinds h"
using shadow_root_ptr_kinds_commutes by blast
obtain host where host: "h \<turnstile> get_host shadow_root_child \<rightarrow>\<^sub>r host"
using get_host_ok assms
by (meson \<open>shadow_root_child |\<in>| shadow_root_ptr_kinds h\<close> is_OK_returns_result_E)
then
have "h \<turnstile> get_ancestors_si (cast host) \<rightarrow>\<^sub>r tl_ancestors"
using Some step(4) tl_ancestors None
by(auto simp add: get_ancestors_si_def[of child] intro!: bind_pure_returns_result_I
elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
then
show ?case
using step(2) Some host step(5) tl_ancestors
using assms(4) dual_order.trans eq_iff returns_result_eq set_ConsD set_subset_Cons
shadow_root_ptr_casts_commute document_ptr_casts_commute step.prems(1)
by (smt case_optionE local.shadow_root_host_dual option.case_distrib option.distinct(1))
qed
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric] get_parent_ok[OF type_wf known_ptrs]
by (metis (no_types, lifting) is_OK_returns_result_E known_ptrs get_parent_ok
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then have "ancestors = [child]"
using step(4) s1
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
show ?case
using step(4) step(5)
apply(auto simp add: \<open>ancestors = [child]\<close>)[1]
using assms(4) returns_result_eq by fastforce
next
case (Some parent)
then
have "h \<turnstile> get_ancestors_si parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 tl_ancestors step(4)
by(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2
split: option.splits dest: returns_result_eq)
show ?case
by (metis (no_types, lifting) Some.prems \<open>h \<turnstile> get_ancestors_si parent \<rightarrow>\<^sub>r tl_ancestors\<close>
assms(4) eq_iff node_ptr_casts_commute order_trans s1 select_result_I2 set_ConsD set_subset_Cons
step.hyps(1) step.prems(1) step.prems(2) tl_ancestors)
qed
qed
qed
lemma get_ancestors_si_also_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast child \<in> set ancestors"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "parent \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors_si (cast child) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(4) get_ancestors_si_ok is_OK_returns_result_I known_ptrs
local.get_parent_ptr_in_heap node_ptr_kinds_commutes returns_result_select_result
type_wf)
then have "parent \<in> set child_ancestors"
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_si_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_si_subset by blast
qed
lemma get_ancestors_si_also_host:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_si some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast shadow_root \<in> set ancestors"
and "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "cast host \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors_si (cast shadow_root) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_si_ok get_ancestors_si_ptrs_in_heap
is_OK_returns_result_E known_ptrs type_wf)
then have "cast host \<in> set child_ancestors"
apply(simp add: get_ancestors_si_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_si_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_si_subset by blast
qed
lemma get_ancestors_si_obtains_children_or_shadow_root:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "h \<turnstile> get_ancestors_si ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<noteq> ptr"
and "ancestor \<in> set ancestors"
shows "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>ancestor_element shadow_root. ancestor = cast ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow> cast shadow_root \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis)"
proof (insert assms(4) assms(5) assms(6), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev_si[OF assms(1)])
case (1 child)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then obtain shadow_root where shadow_root: "child = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root"
using 1(4) 1(5) 1(6)
by(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2
split: option.splits)
then obtain host where host: "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
by (metis "1.prems"(1) assms(1) assms(2) assms(3) document_ptr_kinds_commutes
get_ancestors_si_ptrs_in_heap is_OK_returns_result_E local.get_ancestors_si_ptr local.get_host_ok
shadow_root_ptr_kinds_commutes)
then obtain host_ancestors where host_ancestors: "h \<turnstile> get_ancestors_si (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host) \<rightarrow>\<^sub>r host_ancestors"
by (metis "1.prems"(1) assms(1) assms(2) assms(3) get_ancestors_si_also_host get_ancestors_si_ok
get_ancestors_si_ptrs_in_heap is_OK_returns_result_E local.get_ancestors_si_ptr shadow_root)
then have "ancestors = cast shadow_root # host_ancestors"
using 1(4) 1(5) 1(3) None shadow_root host
by(auto simp add: get_ancestors_si_def[of child, simplified shadow_root]
elim!: bind_returns_result_E2 dest!: returns_result_eq[OF host] split: option.splits)
then show ?thesis
proof (cases "ancestor = cast host")
case True
then show ?thesis
using "1.prems"(1) host local.get_ancestors_si_ptr local.shadow_root_host_dual shadow_root
by blast
next
case False
have "ancestor \<in> set ancestors"
using host host_ancestors 1(3) get_ancestors_si_also_host assms(1) assms(2) assms(3)
using "1.prems"(3) by blast
then have "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set host_ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis) \<or>
((\<forall>ancestor_element shadow_root. ancestor = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow>
cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set host_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.hyps"(2) "1.prems"(2) False \<open>ancestors = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root # host_ancestors\<close>
host host_ancestors shadow_root
by auto
then show ?thesis
using \<open>ancestors = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root # host_ancestors\<close> by auto
qed
next
case (Some child_node)
then obtain parent where parent: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
using 1(4) 1(5) 1(6)
by(auto simp add: get_ancestors_si_def[of child] elim!: bind_returns_result_E2
split: option.splits)
then obtain parent_ancestors where parent_ancestors: "h \<turnstile> get_ancestors_si parent \<rightarrow>\<^sub>r parent_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_si_ok is_OK_returns_result_E
local.get_parent_parent_in_heap)
then have "ancestors = cast child_node # parent_ancestors"
using 1(4) 1(5) 1(3) Some
by(auto simp add: get_ancestors_si_def[of child, simplified Some]
elim!: bind_returns_result_E2 dest!: returns_result_eq[OF parent] split: option.splits)
then show ?thesis
proof (cases "ancestor = parent")
case True
then show ?thesis
by (metis (no_types, lifting) "1.prems"(1) Some local.get_ancestors_si_ptr
local.get_parent_child_dual node_ptr_casts_commute parent)
next
case False
have "ancestor \<in> set ancestors"
by (simp add: "1.prems"(3))
then have "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis) \<or>
((\<forall>ancestor_element shadow_root. ancestor = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow>
cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.hyps"(1) "1.prems"(2) False Some \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close>
parent parent_ancestors
by auto
then show ?thesis
using \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close> by auto
qed
qed
qed
lemma a_host_shadow_root_rel_shadow_root:
"h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root \<Longrightarrow> (cast host, cast shadow_root) \<in> a_host_shadow_root_rel h"
by(auto simp add: is_OK_returns_result_I get_shadow_root_ptr_in_heap a_host_shadow_root_rel_def)
lemma get_ancestors_si_parent_child_a_host_shadow_root_rel:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_ancestors_si child \<rightarrow>\<^sub>r ancestors"
shows "(ptr, child) \<in> (parent_child_rel h \<union> a_host_shadow_root_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
proof
assume "(ptr, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>* "
then show "ptr \<in> set ancestors"
proof (induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4) local.get_ancestors_si_ptr by blast
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h) \<and>
(ptr_child, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using converse_rtranclE[OF 1(4)] \<open>ptr \<noteq> child\<close>
by metis
then show ?thesis
proof(cases "(ptr, ptr_child) \<in> parent_child_rel h")
case True
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 CD.parent_child_rel_node_ptr
by (metis)
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_parent_in_heap True by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis True assms(2) assms(3) calculation local.CD.parent_child_rel_child
local.get_child_nodes_ok local.known_ptrs_known_ptr ptr_child_ptr_child_node
returns_result_select_result)
ultimately show ?thesis
using a1 get_child_nodes_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using ptr_child True ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> by blast
ultimately show ?thesis
using get_ancestors_si_also_parent assms \<open>type_wf h\<close> by blast
next
case False
then
obtain host where host: "ptr = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host"
using ptr_child
by(auto simp add: a_host_shadow_root_rel_def)
then obtain shadow_root where shadow_root: "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root"
and ptr_child_shadow_root: "ptr_child = cast shadow_root"
using ptr_child False
apply(auto simp add: a_host_shadow_root_rel_def)[1]
by (metis (no_types, lifting) assms(3) local.get_shadow_root_ok select_result_I)
moreover have "(cast shadow_root, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
using ptr_child ptr_child_shadow_root by blast
ultimately have "cast shadow_root \<in> set ancestors"
using "1.hyps"(2) host by blast
moreover have "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
by (metis assms(1) assms(2) assms(3) is_OK_returns_result_E local.get_host_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.shadow_root_host_dual local.shadow_root_same_host
shadow_root)
ultimately show ?thesis
using get_ancestors_si_also_host assms(1) assms(2) assms(3) assms(4) host
by blast
qed
qed
qed
next
assume "ptr \<in> set ancestors"
then show "(ptr, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h)\<^sup>*"
proof (induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
have "\<And>thesis. ((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>ancestor_element shadow_root. ptr = cast ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow> cast shadow_root \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis)"
using "1.prems" False assms(1) assms(2) assms(3) assms(4) get_ancestors_si_obtains_children_or_shadow_root
by blast
then show ?thesis
proof (cases "\<forall>thesis. ((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)")
case True
then obtain children ancestor_child
where "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children"
and "cast ancestor_child \<in> set ancestors"
by blast
then show ?thesis
by (meson "1.hyps"(1) in_rtrancl_UnI local.CD.parent_child_rel_child r_into_rtrancl rtrancl_trans)
next
case False
obtain ancestor_element shadow_root
where "ptr = cast ancestor_element"
and "h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root"
and "cast shadow_root \<in> set ancestors"
using False \<open>\<And>thesis. ((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis) \<or>
((\<forall>ancestor_element shadow_root. ptr = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow>
cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)\<close>
by blast
then show ?thesis
using 1(2) a_host_shadow_root_rel_shadow_root
apply(simp)
by (meson Un_iff converse_rtrancl_into_rtrancl)
qed
qed
qed
qed
lemma get_root_node_si_root_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root"
shows "root |\<in>| object_ptr_kinds h"
using assms
apply(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2)[1]
by (simp add: get_ancestors_si_never_empty get_ancestors_si_ptrs_in_heap)
lemma get_root_node_si_same_no_parent:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r cast child"
shows "h \<turnstile> get_parent child \<rightarrow>\<^sub>r None"
proof (insert assms(1) assms(4), induct ptr rule: heap_wellformed_induct_rev_si)
case (step c)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r c")
case None
then show ?thesis
using step(4)
by(auto simp add: get_root_node_si_def get_ancestors_si_def[of c] elim!: bind_returns_result_E2
split: if_splits option.splits intro!: step(2) bind_pure_returns_result_I)
next
case (Some child_node)
note s = this
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using step(4)
apply(auto simp add: get_root_node_si_def get_ancestors_si_def intro!: bind_pure_I
elim!: bind_returns_result_E2)[1]
by(auto split: option.splits)
then show ?thesis
proof(induct parent_opt)
case None
then show ?case
using Some get_root_node_si_no_parent returns_result_eq step.prems by fastforce
next
case (Some parent)
then show ?case
using step(4) s
apply(auto simp add: get_root_node_si_def get_ancestors_si_def[of c]
elim!: bind_returns_result_E2 split: option.splits list.splits if_splits)[1]
using assms(1) get_ancestors_si_never_empty apply blast
by(auto simp add: get_root_node_si_def dest: returns_result_eq
intro!: step(1) bind_pure_returns_result_I)
qed
qed
qed
lemma get_root_node_si_parent_child_a_host_shadow_root_rel:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_root_node_si ptr \<rightarrow>\<^sub>r root"
shows "(root, ptr) \<in> (parent_child_rel h \<union> a_host_shadow_root_rel h)\<^sup>*"
using assms
using get_ancestors_si_parent_child_a_host_shadow_root_rel get_ancestors_si_never_empty
by(auto simp add: get_root_node_si_def elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I)
end
interpretation i_get_root_node_si_wf?: l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_host get_host_locs get_ancestors_si get_ancestors_si_locs get_root_node_si get_root_node_si_locs
get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document
get_disconnected_document_locs
by(auto simp add: l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_disconnected\_document\<close>
locale l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_parent
begin
lemma get_disconnected_document_ok:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
shows "h \<turnstile> ok (get_disconnected_document node_ptr)"
proof -
have "node_ptr |\<in>| node_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_parent_ptr_in_heap)
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
apply(auto)[1]
using assms(4) child_parent_dual[OF assms(1)]
assms(1) assms(2) assms(3) known_ptrs_known_ptr option.simps(3)
returns_result_eq returns_result_select_result
by (metis (no_types, lifting) CD.get_child_nodes_ok)
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using heap_is_wellformed_children_disc_nodes
using \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) by blast
then obtain some_owner_document where
"some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))" and
"node_ptr \<in> set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
have h5: "\<exists>!x. x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h))) \<and> h \<turnstile> Heap_Error_Monad.bind (get_disconnected_nodes x)
(\<lambda>children. return (node_ptr \<in> set children)) \<rightarrow>\<^sub>r True"
apply(auto intro!: bind_pure_returns_result_I)[1]
apply (smt CD.get_disconnected_nodes_ok CD.get_disconnected_nodes_pure
\<open>\<exists>document_ptr\<in>fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r\<close>
assms(2) bind_pure_returns_result_I2 notin_fset return_returns_result select_result_I2)
apply(auto elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I)[1]
using heap_is_wellformed_one_disc_parent assms(1)
by blast
let ?filter_M = "filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (node_ptr \<in> set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))"
have "h \<turnstile> ok (?filter_M)"
using CD.get_disconnected_nodes_ok
by (smt CD.get_disconnected_nodes_pure DocumentMonad.ptr_kinds_M_ptr_kinds
DocumentMonad.ptr_kinds_ptr_kinds_M assms(2) bind_is_OK_pure_I bind_pure_I document_ptr_kinds_M_def
filter_M_is_OK_I l_ptr_kinds_M.ptr_kinds_M_ok return_ok return_pure returns_result_select_result)
then
obtain candidates where candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (node_ptr \<in> set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by auto
have "candidates = [some_owner_document]"
apply(rule filter_M_ex1[OF candidates \<open>some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close> h5])
using \<open>node_ptr \<in> set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
\<open>some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close>
by(auto simp add: CD.get_disconnected_nodes_ok assms(2) intro!: bind_pure_I
intro!: bind_pure_returns_result_I)
then show ?thesis
using candidates \<open>node_ptr |\<in>| node_ptr_kinds h\<close>
apply(auto simp add: get_disconnected_document_def intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
split: list.splits)[1]
apply (meson not_Cons_self2 returns_result_eq)
by (meson list.distinct(1) list.inject returns_result_eq)
qed
end
interpretation i_get_disconnected_document_wf?: l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs
get_disconnected_document get_disconnected_document_locs known_ptrs get_parent get_parent_locs
by(auto simp add: l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_ancestors\_di\<close>
locale l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_get_parent_get_host_wf +
l_get_host_wf +
l_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma get_ancestors_di_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_ancestors_di ptr)"
proof (insert assms(1) assms(4), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using assms(2) assms(3)
apply(auto simp add: get_ancestors_di_def[of child] assms(1) get_parent_parent_in_heap
intro!: bind_is_OK_pure_I bind_pure_I split: option.splits)[1]
using local.get_parent_ok apply blast
using assms(1) get_disconnected_document_ok apply blast
apply(simp add: get_ancestors_di_def )
apply(auto intro!: bind_is_OK_pure_I split: option.splits)[1]
apply (metis (no_types, lifting) bind_is_OK_E document_ptr_kinds_commutes is_OK_returns_heap_I
local.get_ancestors_di_def local.get_disconnected_document_disconnected_document_in_heap step.hyps(3))
apply (metis (no_types, lifting) bind_is_OK_E document_ptr_kinds_commutes is_OK_returns_heap_I
local.get_ancestors_di_def local.get_disconnected_document_disconnected_document_in_heap step.hyps(3))
using assms(1) local.get_disconnected_document_disconnected_document_in_heap local.get_host_ok
shadow_root_ptr_kinds_commutes apply blast
apply (smt assms(1) bind_returns_heap_E document_ptr_casts_commute2 is_OK_returns_heap_E
is_OK_returns_heap_I l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.shadow_root_same_host
local.get_disconnected_document_disconnected_document_in_heap local.get_host_pure
local.l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms local.shadow_root_host_dual option.simps(4) option.simps(5)
pure_returns_heap_eq shadow_root_ptr_casts_commute2)
using get_host_ok assms(1) apply blast
by (meson assms(1) is_OK_returns_result_I local.get_shadow_root_ptr_in_heap local.shadow_root_host_dual)
qed
lemma get_ancestors_di_ptrs_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors"
assumes "ptr' \<in> set ancestors"
shows "ptr' |\<in>| object_ptr_kinds h"
proof (insert assms(4) assms(5), induct ancestors arbitrary: ptr)
case Nil
then show ?case
by(auto)
next
case (Cons a ancestors)
then obtain x where x: "h \<turnstile> get_ancestors_di x \<rightarrow>\<^sub>r a # ancestors"
by(auto simp add: get_ancestors_di_def[of a] elim!: bind_returns_result_E2 split: option.splits)
then have "x = a"
by(auto simp add: get_ancestors_di_def[of x] intro!: bind_pure_I elim!: bind_returns_result_E2
split: option.splits)
then show ?case
proof (cases "ptr' = a")
case True
then show ?thesis
using Cons.hyps Cons.prems(2) get_ancestors_di_ptr_in_heap x
using \<open>x = a\<close> by blast
next
case False
obtain ptr'' where ptr'': "h \<turnstile> get_ancestors_di ptr'' \<rightarrow>\<^sub>r ancestors"
using \<open> h \<turnstile> get_ancestors_di x \<rightarrow>\<^sub>r a # ancestors\<close> Cons.prems(2) False
apply(auto simp add: get_ancestors_di_def elim!: bind_returns_result_E2)[1]
apply(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I)[1]
apply(auto elim!: bind_returns_result_E2 split: option.splits intro!: bind_pure_I)[1]
apply (metis (no_types, lifting) local.get_ancestors_di_def)
apply (metis (no_types, lifting) local.get_ancestors_di_def)
by (simp add: local.get_ancestors_di_def)
then show ?thesis
using Cons.hyps Cons.prems(2) False by auto
qed
qed
lemma get_ancestors_di_reads:
assumes "heap_is_wellformed h"
shows "reads get_ancestors_di_locs (get_ancestors_di node_ptr) h h'"
proof (insert assms(1), induct rule: heap_wellformed_induct_rev_si)
case (step child)
then show ?case
using (* [[simproc del: Product_Type.unit_eq]] *) get_parent_reads[unfolded reads_def]
get_host_reads[unfolded reads_def] get_disconnected_document_reads[unfolded reads_def]
apply(auto simp add: get_ancestors_di_def[of child])[1]
by(auto simp add: get_ancestors_di_locs_def get_parent_reads_pointers
intro!: bind_pure_I reads_bind_pure reads_subset[OF check_in_heap_reads] reads_subset[OF return_reads]
reads_subset[OF get_parent_reads] reads_subset[OF get_child_nodes_reads]
reads_subset[OF get_host_reads] reads_subset[OF get_disconnected_document_reads]
split: option.splits list.splits
)
qed
lemma get_ancestors_di_subset:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<in> set ancestors"
and "h \<turnstile> get_ancestors_di ancestor \<rightarrow>\<^sub>r ancestor_ancestors"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "set ancestor_ancestors \<subseteq> set ancestors"
proof (insert assms(1) assms(2) assms(3), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev_si)
case (step child)
have "child |\<in>| object_ptr_kinds h"
using get_ancestors_di_ptr_in_heap step(4) by auto
(* then have "h \<turnstile> check_in_heap child \<rightarrow>\<^sub>r ()"
using returns_result_select_result by force *)
obtain tl_ancestors where tl_ancestors: "ancestors = child # tl_ancestors"
using step(4)
by(auto simp add: get_ancestors_di_def[of child] intro!: bind_pure_I
elim!: bind_returns_result_E2 split: option.splits)
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
show ?case
proof (induct "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then show ?case
using step(4) \<open>None = cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child\<close>
apply(auto simp add: get_ancestors_di_def[of child] elim!: bind_returns_result_E2)[1]
by (metis (no_types, lifting) assms(4) empty_iff empty_set select_result_I2 set_ConsD
step.prems(1) step.prems(2))
next
case (Some shadow_root_child)
then
have "cast shadow_root_child |\<in>| document_ptr_kinds h"
using \<open>child |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: document_ptr_kinds_def split: option.splits)[1]
by (metis (mono_tags, lifting) document_ptr_casts_commute3 document_ptr_kinds_commutes
document_ptr_kinds_def fset.map_comp shadow_root_ptr_casts_commute)
then
have "shadow_root_child |\<in>| shadow_root_ptr_kinds h"
using shadow_root_ptr_kinds_commutes by blast
obtain host where host: "h \<turnstile> get_host shadow_root_child \<rightarrow>\<^sub>r host"
using get_host_ok assms
by (meson \<open>shadow_root_child |\<in>| shadow_root_ptr_kinds h\<close> is_OK_returns_result_E)
then
have "h \<turnstile> get_ancestors_di (cast host) \<rightarrow>\<^sub>r tl_ancestors"
using Some step(4) tl_ancestors None
by(auto simp add: get_ancestors_di_def[of child] intro!: bind_pure_returns_result_I
elim!: bind_returns_result_E2 split: option.splits dest: returns_result_eq)
then
show ?case
using step(2) Some host step(5) tl_ancestors
using assms(4) dual_order.trans eq_iff returns_result_eq set_ConsD set_subset_Cons
shadow_root_ptr_casts_commute document_ptr_casts_commute step.prems(1)
by (smt case_optionE local.shadow_root_host_dual option.case_distrib option.distinct(1))
qed
next
case (Some child_node)
note s1 = Some
obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
using \<open>child |\<in>| object_ptr_kinds h\<close> assms(1) Some[symmetric] get_parent_ok[OF type_wf known_ptrs]
by (metis (no_types, lifting) is_OK_returns_result_E known_ptrs get_parent_ok
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?case
proof (induct parent_opt)
case None
then obtain disc_doc where disc_doc: "h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disc_doc"
and "h \<turnstile> get_ancestors_di (cast disc_doc) \<rightarrow>\<^sub>r tl_ancestors"
using step(4) s1 tl_ancestors
apply(simp add: get_ancestors_di_def[of child])
by(auto elim!: bind_returns_result_E2 intro!: bind_pure_I split: option.splits dest: returns_result_eq)
then show ?thesis
using step(3) step(4) step(5)
by (metis (no_types, lifting) assms(4) dual_order.trans eq_iff node_ptr_casts_commute s1
select_result_I2 set_ConsD set_subset_Cons tl_ancestors)
next
case (Some parent)
then
have "h \<turnstile> get_ancestors_di parent \<rightarrow>\<^sub>r tl_ancestors"
using s1 tl_ancestors step(4)
by(auto simp add: get_ancestors_di_def[of child] elim!: bind_returns_result_E2
split: option.splits dest: returns_result_eq)
show ?case
by (metis (no_types, lifting) Some.prems \<open>h \<turnstile> get_ancestors_di parent \<rightarrow>\<^sub>r tl_ancestors\<close>
assms(4) eq_iff node_ptr_casts_commute order_trans s1 select_result_I2 set_ConsD set_subset_Cons
step.hyps(1) step.prems(1) step.prems(2) tl_ancestors)
qed
qed
qed
lemma get_ancestors_di_also_parent:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_di some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast child \<in> set ancestors"
and "h \<turnstile> get_parent child \<rightarrow>\<^sub>r Some parent"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "parent \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors_di (cast child) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(4) get_ancestors_di_ok is_OK_returns_result_I known_ptrs
local.get_parent_ptr_in_heap node_ptr_kinds_commutes returns_result_select_result
type_wf)
then have "parent \<in> set child_ancestors"
apply(simp add: get_ancestors_di_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_di_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_di_subset by blast
qed
lemma get_ancestors_di_also_host:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_di some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast shadow_root \<in> set ancestors"
and "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
shows "cast host \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors_di (cast shadow_root) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_di_ok get_ancestors_di_ptrs_in_heap
is_OK_returns_result_E known_ptrs type_wf)
then have "cast host \<in> set child_ancestors"
apply(simp add: get_ancestors_di_def)
by(auto elim!: bind_returns_result_E2 split: option.splits dest!: returns_result_eq[OF assms(4)]
get_ancestors_di_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_di_subset by blast
qed
lemma get_ancestors_di_also_disconnected_document:
assumes "heap_is_wellformed h"
and "h \<turnstile> get_ancestors_di some_ptr \<rightarrow>\<^sub>r ancestors"
and "cast disc_node \<in> set ancestors"
and "h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disconnected_document"
and type_wf: "type_wf h"
and known_ptrs: "known_ptrs h"
and "h \<turnstile> get_parent disc_node \<rightarrow>\<^sub>r None"
shows "cast disconnected_document \<in> set ancestors"
proof -
obtain child_ancestors where child_ancestors: "h \<turnstile> get_ancestors_di (cast disc_node) \<rightarrow>\<^sub>r child_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_di_ok get_ancestors_di_ptrs_in_heap
is_OK_returns_result_E known_ptrs type_wf)
then have "cast disconnected_document \<in> set child_ancestors"
apply(simp add: get_ancestors_di_def)
by(auto elim!: bind_returns_result_E2 intro!: bind_pure_I split: option.splits
dest!: returns_result_eq[OF assms(4)] returns_result_eq[OF assms(7)]
get_ancestors_di_ptr)
then show ?thesis
using assms child_ancestors get_ancestors_di_subset by blast
qed
lemma disc_node_disc_doc_dual:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
assumes "h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
shows "h \<turnstile> get_disconnected_document node_ptr \<rightarrow>\<^sub>r disc_doc"
proof -
have "node_ptr |\<in>| node_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_parent_ptr_in_heap)
then
have "\<not>(\<exists>parent \<in> fset (object_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
apply(auto)[1]
using child_parent_dual[OF assms(1)]
assms known_ptrs_known_ptr option.simps(3)
returns_result_eq returns_result_select_result
by (metis (no_types, lifting) get_child_nodes_ok)
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using heap_is_wellformed_children_disc_nodes
using \<open>node_ptr |\<in>| node_ptr_kinds h\<close> assms(1) by blast
(* then obtain some_owner_document where
"some_owner_document \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))" and
"node_ptr \<in> set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto *)
then have "disc_doc \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))" and
"node_ptr \<in> set |h \<turnstile> get_disconnected_nodes disc_doc|\<^sub>r"
using CD.get_disconnected_nodes_ptr_in_heap assms(5)
assms(6) by auto
have h5: "\<exists>!x. x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h))) \<and>
h \<turnstile> Heap_Error_Monad.bind (get_disconnected_nodes x)
(\<lambda>children. return (node_ptr \<in> set children)) \<rightarrow>\<^sub>r True"
apply(auto intro!: bind_pure_returns_result_I)[1]
apply (smt CD.get_disconnected_nodes_ok CD.get_disconnected_nodes_pure
\<open>\<exists>document_ptr\<in>fset (document_ptr_kinds h). node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r\<close>
assms(2) bind_pure_returns_result_I2 notin_fset return_returns_result select_result_I2)
apply(auto elim!: bind_returns_result_E2 intro!: bind_pure_returns_result_I)[1]
using heap_is_wellformed_one_disc_parent assms(1)
by blast
let ?filter_M = "filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (node_ptr \<in> set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))"
have "h \<turnstile> ok (?filter_M)"
using CD.get_disconnected_nodes_ok
by (smt CD.get_disconnected_nodes_pure DocumentMonad.ptr_kinds_M_ptr_kinds
DocumentMonad.ptr_kinds_ptr_kinds_M assms(2) bind_is_OK_pure_I bind_pure_I document_ptr_kinds_M_def
filter_M_is_OK_I l_ptr_kinds_M.ptr_kinds_M_ok return_ok return_pure returns_result_select_result)
then
obtain candidates where candidates: "h \<turnstile> ?filter_M \<rightarrow>\<^sub>r candidates"
by auto
have "candidates = [disc_doc]"
apply(rule filter_M_ex1[OF candidates \<open>disc_doc \<in>
set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close> h5])
using \<open>node_ptr \<in> set |h \<turnstile> get_disconnected_nodes disc_doc|\<^sub>r\<close>
\<open>disc_doc \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))\<close>
by(auto simp add: CD.get_disconnected_nodes_ok assms(2) intro!: bind_pure_I
intro!: bind_pure_returns_result_I)
then
show ?thesis
using \<open>node_ptr |\<in>| node_ptr_kinds h\<close> candidates
by(auto simp add: bind_pure_I get_disconnected_document_def
elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I)
qed
lemma get_ancestors_di_obtains_children_or_shadow_root_or_disconnected_node:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors"
and "ancestor \<noteq> ptr"
and "ancestor \<in> set ancestors"
shows "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>ancestor_element shadow_root. ancestor = cast ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow> cast shadow_root \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis)
\<or> ((\<forall>disc_doc disc_nodes disc_node. ancestor = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
proof (insert assms(4) assms(5) assms(6), induct ptr arbitrary: ancestors
rule: heap_wellformed_induct_rev_si[OF assms(1)])
case (1 child)
then show ?case
proof (cases "cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child")
case None
then obtain shadow_root where shadow_root: "child = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root"
using 1(4) 1(5) 1(6)
by(auto simp add: get_ancestors_di_def[of child] elim!: bind_returns_result_E2
split: option.splits)
then obtain host where host: "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
by (metis "1.prems"(1) assms(1) assms(2) assms(3) document_ptr_kinds_commutes
get_ancestors_di_ptrs_in_heap is_OK_returns_result_E local.get_ancestors_di_ptr local.get_host_ok
shadow_root_ptr_kinds_commutes)
then obtain host_ancestors where host_ancestors:
"h \<turnstile> get_ancestors_di (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host) \<rightarrow>\<^sub>r host_ancestors"
by (metis "1.prems"(1) assms(1) assms(2) assms(3) get_ancestors_di_also_host get_ancestors_di_ok
get_ancestors_di_ptrs_in_heap is_OK_returns_result_E local.get_ancestors_di_ptr shadow_root)
then have "ancestors = cast shadow_root # host_ancestors"
using 1(4) 1(5) 1(3) None shadow_root host
by(auto simp add: get_ancestors_di_def[of child, simplified shadow_root]
elim!: bind_returns_result_E2 dest!: returns_result_eq[OF host] split: option.splits)
then show ?thesis
proof (cases "ancestor = cast host")
case True
then show ?thesis
using "1.prems"(1) host local.get_ancestors_di_ptr local.shadow_root_host_dual shadow_root
by blast
next
case False
have "ancestor \<in> set ancestors"
using host host_ancestors 1(3) get_ancestors_di_also_host assms(1) assms(2) assms(3)
using "1.prems"(3) by blast
then have "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set host_ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis) \<or>
((\<forall>ancestor_element shadow_root. ancestor = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow>
cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set host_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>disc_doc disc_nodes disc_node. ancestor = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set host_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.hyps"(2) "1.prems"(2) False \<open>ancestors = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root # host_ancestors\<close>
host host_ancestors shadow_root
by auto
then show ?thesis
using \<open>ancestors = cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root # host_ancestors\<close>
by auto
qed
next
case (Some child_node)
then obtain parent_opt where parent_opt: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r parent_opt"
by (metis (no_types, lifting) "1.prems"(1) assms(1) assms(2) assms(3)
get_ancestors_di_ptrs_in_heap is_OK_returns_result_E local.get_ancestors_di_ptr
local.get_parent_ok node_ptr_casts_commute node_ptr_kinds_commutes)
then show ?thesis
proof (induct parent_opt)
case None
then obtain disc_doc where disc_doc: "h \<turnstile> get_disconnected_document child_node \<rightarrow>\<^sub>r disc_doc"
by (meson assms(1) assms(2) assms(3) is_OK_returns_result_E local.get_disconnected_document_ok)
then obtain parent_ancestors where parent_ancestors: "h \<turnstile> get_ancestors_di (cast disc_doc) \<rightarrow>\<^sub>r parent_ancestors"
by (meson assms(1) assms(2) assms(3) document_ptr_kinds_commutes is_OK_returns_result_E
l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.get_ancestors_di_ok l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms
local.get_disconnected_document_disconnected_document_in_heap)
then have "ancestors = cast child_node # parent_ancestors"
using 1(4) 1(5) 1(6) Some \<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>
apply(auto simp add: get_ancestors_di_def[of child,
simplified \<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>] intro!: bind_pure_I
elim!: bind_returns_result_E2 dest!: returns_result_eq[OF disc_doc] split: option.splits)[1]
apply (simp add: returns_result_eq)
by (meson None.prems option.distinct(1) returns_result_eq)
then show ?thesis
proof (cases "ancestor = cast disc_doc")
case True
then show ?thesis
by (metis \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close> disc_doc
list.set_intros(1) local.disc_doc_disc_node_dual)
next
case False
have "ancestor \<in> set ancestors"
by (simp add: "1.prems"(3))
then have "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis) \<or>
((\<forall>ancestor_element shadow_root. ancestor = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow>
cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>disc_doc disc_nodes disc_node. ancestor = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.hyps"(3) "1.prems"(2) False Some \<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>
\<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close> disc_doc parent_ancestors
by auto
then show ?thesis
using \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close> by auto
qed
next
case (Some option)
then obtain parent where parent: "h \<turnstile> get_parent child_node \<rightarrow>\<^sub>r Some parent"
using 1(4) 1(5) 1(6)
by(auto simp add: get_ancestors_di_def[of child] intro!: bind_pure_I
elim!: bind_returns_result_E2 split: option.splits)
then obtain parent_ancestors where parent_ancestors:
"h \<turnstile> get_ancestors_di parent \<rightarrow>\<^sub>r parent_ancestors"
by (meson assms(1) assms(2) assms(3) get_ancestors_di_ok is_OK_returns_result_E
local.get_parent_parent_in_heap)
then have "ancestors = cast child_node # parent_ancestors"
using 1(4) 1(5) 1(6) Some \<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>
by(auto simp add: get_ancestors_di_def[of child, simplified
\<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>] dest!: elim!: bind_returns_result_E2
dest!: returns_result_eq[OF parent] split: option.splits)
then show ?thesis
proof (cases "ancestor = parent")
case True
then show ?thesis
by (metis \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close>
list.set_intros(1) local.get_parent_child_dual parent)
next
case False
have "ancestor \<in> set ancestors"
by (simp add: "1.prems"(3))
then have "((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ancestor \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_child \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis) \<or>
((\<forall>ancestor_element shadow_root. ancestor = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow> cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>disc_doc disc_nodes disc_node. ancestor = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set parent_ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.hyps"(1) "1.prems"(2) False Some \<open>cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child = Some child_node\<close>
\<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close> parent parent_ancestors
by auto
then show ?thesis
using \<open>ancestors = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child_node # parent_ancestors\<close>
by auto
qed
qed
qed
qed
lemma get_ancestors_di_parent_child_a_host_shadow_root_rel:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> get_ancestors_di child \<rightarrow>\<^sub>r ancestors"
shows "(ptr, child) \<in> (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>* \<longleftrightarrow> ptr \<in> set ancestors"
proof
assume "(ptr, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>* "
then show "ptr \<in> set ancestors"
proof (induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
using assms(4) get_ancestors_di_ptr by blast
next
case False
obtain ptr_child where
ptr_child: "(ptr, ptr_child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h) \<and>
(ptr_child, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using converse_rtranclE[OF 1(4)] \<open>ptr \<noteq> child\<close>
by metis
then show ?thesis
proof(cases "(ptr, ptr_child) \<in> parent_child_rel h")
case True
then obtain ptr_child_node
where ptr_child_ptr_child_node: "ptr_child = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node"
using ptr_child node_ptr_casts_commute3 CD.parent_child_rel_node_ptr
by (metis)
then obtain children where
children: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children" and
ptr_child_node: "ptr_child_node \<in> set children"
proof -
assume a1: "\<And>children. \<lbrakk>h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children; ptr_child_node \<in> set children\<rbrakk>
\<Longrightarrow> thesis"
have "ptr |\<in>| object_ptr_kinds h"
using CD.parent_child_rel_parent_in_heap True by blast
moreover have "ptr_child_node \<in> set |h \<turnstile> get_child_nodes ptr|\<^sub>r"
by (metis True assms(2) assms(3) calculation local.CD.parent_child_rel_child
local.get_child_nodes_ok local.known_ptrs_known_ptr ptr_child_ptr_child_node
returns_result_select_result)
ultimately show ?thesis
using a1 get_child_nodes_ok \<open>type_wf h\<close> \<open>known_ptrs h\<close>
by (meson local.known_ptrs_known_ptr returns_result_select_result)
qed
moreover have "(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node, child) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using ptr_child True ptr_child_ptr_child_node by auto
ultimately have "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr_child_node \<in> set ancestors"
using 1 by auto
moreover have "h \<turnstile> get_parent ptr_child_node \<rightarrow>\<^sub>r Some ptr"
using assms(1) children ptr_child_node child_parent_dual
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> by blast
ultimately show ?thesis
using get_ancestors_di_also_parent assms \<open>type_wf h\<close> by blast
next
case False
then show ?thesis
proof (cases "(ptr, ptr_child) \<in> a_host_shadow_root_rel h")
case True
then
obtain host where host: "ptr = cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r host"
using ptr_child
by(auto simp add: a_host_shadow_root_rel_def)
then obtain shadow_root where shadow_root: "h \<turnstile> get_shadow_root host \<rightarrow>\<^sub>r Some shadow_root"
and ptr_child_shadow_root: "ptr_child = cast shadow_root"
using False True
apply(auto simp add: a_host_shadow_root_rel_def)[1]
by (metis (no_types, lifting) assms(3) local.get_shadow_root_ok select_result_I)
moreover have "(cast shadow_root, child) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using ptr_child ptr_child_shadow_root by blast
ultimately have "cast shadow_root \<in> set ancestors"
using "1.hyps"(2) host by blast
moreover have "h \<turnstile> get_host shadow_root \<rightarrow>\<^sub>r host"
by (metis assms(1) assms(2) assms(3) is_OK_returns_result_E local.get_host_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.shadow_root_host_dual local.shadow_root_same_host
shadow_root)
ultimately show ?thesis
using get_ancestors_di_also_host assms(1) assms(2) assms(3) assms(4) host
by blast
next
case False
then
obtain disc_doc where disc_doc: "ptr = cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r disc_doc"
using ptr_child \<open>(ptr, ptr_child) \<notin> parent_child_rel h\<close>
by(auto simp add: a_ptr_disconnected_node_rel_def)
then obtain disc_node disc_nodes where disc_nodes:
"h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes"
and disc_node: "disc_node \<in> set disc_nodes"
and ptr_child_disc_node: "ptr_child = cast disc_node"
using False \<open>(ptr, ptr_child) \<notin> parent_child_rel h\<close> ptr_child
apply(auto simp add: a_ptr_disconnected_node_rel_def)[1]
by (metis (no_types, lifting) CD.get_disconnected_nodes_ok assms(3)
returns_result_select_result)
moreover have "(cast disc_node, child) \<in>
(parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using ptr_child ptr_child_disc_node by blast
ultimately have "cast disc_node \<in> set ancestors"
using "1.hyps"(3) disc_doc by blast
moreover have "h \<turnstile> get_parent disc_node \<rightarrow>\<^sub>r None"
using \<open>(ptr, ptr_child) \<notin> parent_child_rel h\<close>
apply(auto simp add: parent_child_rel_def ptr_child_disc_node)[1]
by (smt assms(1) assms(2) assms(3) assms(4) calculation disc_node disc_nodes
get_ancestors_di_ptrs_in_heap is_OK_returns_result_E local.CD.a_heap_is_wellformed_def
local.CD.distinct_lists_no_parent local.CD.heap_is_wellformed_impl local.get_parent_child_dual
local.get_parent_ok local.get_parent_parent_in_heap local.heap_is_wellformed_def
node_ptr_kinds_commutes select_result_I2 split_option_ex)
then
have "h \<turnstile> get_disconnected_document disc_node \<rightarrow>\<^sub>r disc_doc"
using disc_node_disc_doc_dual disc_nodes disc_node assms(1) assms(2) assms(3)
by blast
ultimately show ?thesis
using \<open>h \<turnstile> get_parent disc_node \<rightarrow>\<^sub>r None\<close> assms(1) assms(2) assms(3) assms(4)
disc_doc get_ancestors_di_also_disconnected_document
by blast
qed
qed
qed
qed
next
assume "ptr \<in> set ancestors"
then show "(ptr, child) \<in> (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
proof (induct ptr rule: heap_wellformed_induct_si[OF assms(1)])
case (1 ptr)
then show ?case
proof (cases "ptr = child")
case True
then show ?thesis
by simp
next
case False
have 2: "\<And>thesis. ((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)
\<or> ((\<forall>ancestor_element shadow_root. ptr = cast ancestor_element \<longrightarrow>
h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root \<longrightarrow> cast shadow_root \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow>
thesis)
\<or> ((\<forall>disc_doc disc_nodes disc_node. ptr = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)"
using "1.prems" False assms(1) assms(2) assms(3) assms(4)
get_ancestors_di_obtains_children_or_shadow_root_or_disconnected_node by blast
then show ?thesis
proof (cases "\<forall>thesis. ((\<forall>children ancestor_child. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<longrightarrow>
ancestor_child \<in> set children \<longrightarrow> cast ancestor_child \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)")
case True
then obtain children ancestor_child
where "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and "ancestor_child \<in> set children"
and "cast ancestor_child \<in> set ancestors"
by blast
then show ?thesis
by (meson "1.hyps"(1) in_rtrancl_UnI local.CD.parent_child_rel_child r_into_rtrancl
rtrancl_trans)
next
case False
note f1 = this
then show ?thesis
proof (cases "\<forall>thesis. ((\<forall>disc_doc disc_nodes disc_node. ptr = cast disc_doc \<longrightarrow>
h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes \<longrightarrow> disc_node \<in> set disc_nodes \<longrightarrow>
cast disc_node \<in> set ancestors \<longrightarrow> thesis) \<longrightarrow> thesis)")
case True
then obtain disc_doc disc_nodes disc_node
where "ptr = cast disc_doc"
and "h \<turnstile> get_disconnected_nodes disc_doc \<rightarrow>\<^sub>r disc_nodes"
and "disc_node \<in> set disc_nodes"
and "cast disc_node \<in> set ancestors"
by blast
then show ?thesis
by (meson "1.hyps"(3) in_rtrancl_UnI
local.a_ptr_disconnected_node_rel_disconnected_node r_into_rtrancl rtrancl_trans)
next
case False
then
obtain ancestor_element shadow_root
where "ptr = cast ancestor_element"
and "h \<turnstile> get_shadow_root ancestor_element \<rightarrow>\<^sub>r Some shadow_root"
and "cast shadow_root \<in> set ancestors"
using f1 2 by smt
then show ?thesis
by (meson "1.hyps"(2) in_rtrancl_UnI local.a_host_shadow_root_rel_shadow_root
r_into_rtrancl rtrancl_trans)
qed
qed
qed
qed
qed
end
interpretation i_get_ancestors_di_wf?: l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr known_ptrs get_parent get_parent_locs get_child_nodes get_child_nodes_locs
get_host get_host_locs get_disconnected_document get_disconnected_document_locs get_ancestors_di
get_ancestors_di_locs get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_owner\_document\<close>
locale l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes +
l_get_child_nodes +
l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf +
l_known_ptrs +
l_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
assumes known_ptr_impl: "known_ptr = ShadowRootClass.known_ptr"
begin
lemma get_owner_document_disconnected_nodes:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assumes "node_ptr \<in> set disc_nodes"
assumes known_ptrs: "known_ptrs h"
assumes type_wf: "type_wf h"
shows "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r document_ptr"
proof -
have 2: "node_ptr |\<in>| node_ptr_kinds h"
using assms
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.a_all_ptrs_in_heap_def)[1]
using assms(1) local.heap_is_wellformed_disc_nodes_in_heap by blast
have 3: "document_ptr |\<in>| document_ptr_kinds h"
using assms(2) get_disconnected_nodes_ptr_in_heap by blast
then have 4: "\<not>(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using CD.distinct_lists_no_parent assms unfolding heap_is_wellformed_def CD.heap_is_wellformed_def
by simp
moreover have "(\<exists>document_ptr. document_ptr |\<in>| document_ptr_kinds h \<and>
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r) \<or>
(\<exists>parent_ptr. parent_ptr |\<in>| object_ptr_kinds h \<and> node_ptr \<in> set |h \<turnstile> get_child_nodes parent_ptr|\<^sub>r)"
using assms(1) 2 "3" assms(2) assms(3) by auto
ultimately have 0: "\<exists>!document_ptr\<in>set |h \<turnstile> document_ptr_kinds_M|\<^sub>r.
node_ptr \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using concat_map_distinct assms(1) known_ptrs_implies
by (smt CD.heap_is_wellformed_one_disc_parent DocumentMonad.ptr_kinds_ptr_kinds_M
disjoint_iff_not_equal local.get_disconnected_nodes_ok local.heap_is_wellformed_def
returns_result_select_result type_wf)
have "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
using 4 2
apply(auto simp add: get_parent_def intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I )[1]
apply(auto intro!: filter_M_empty_I bind_pure_I bind_pure_returns_result_I)[1]
using get_child_nodes_ok assms(4) type_wf
by (metis get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have 4: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r cast node_ptr"
using get_root_node_no_parent
by simp
obtain document_ptrs where document_ptrs: "h \<turnstile> document_ptr_kinds_M \<rightarrow>\<^sub>r document_ptrs"
by simp
then have "h \<turnstile> ok (filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs)"
using assms(1) get_disconnected_nodes_ok type_wf
by(auto intro!: bind_is_OK_I2 filter_M_is_OK_I bind_pure_I)
then obtain candidates where
candidates: "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r candidates"
by auto
have filter: "filter (\<lambda>document_ptr. |h \<turnstile> do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr \<in> cast ` set disconnected_nodes)
}|\<^sub>r) document_ptrs = [document_ptr]"
apply(rule filter_ex1)
using 0 document_ptrs apply(simp)[1]
apply (smt "0" "3" assms bind_is_OK_pure_I bind_pure_returns_result_I bind_pure_returns_result_I2
bind_returns_result_E2 bind_returns_result_E3 document_ptr_kinds_M_def get_disconnected_nodes_ok
get_disconnected_nodes_pure image_eqI is_OK_returns_result_E l_ptr_kinds_M.ptr_kinds_ptr_kinds_M return_ok
return_returns_result returns_result_eq select_result_E select_result_I select_result_I2 select_result_I2)
using assms(2) assms(3)
apply (smt bind_is_OK_I2 bind_returns_result_E3 get_disconnected_nodes_pure image_eqI
is_OK_returns_result_I return_ok return_returns_result select_result_E)
using document_ptrs 3 apply(simp)
using document_ptrs
by simp
have "h \<turnstile> filter_M (\<lambda>document_ptr. do {
disconnected_nodes \<leftarrow> get_disconnected_nodes document_ptr;
return (((cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr)) \<in> cast ` set disconnected_nodes)
}) document_ptrs \<rightarrow>\<^sub>r [document_ptr]"
apply(rule filter_M_filter2)
using get_disconnected_nodes_ok document_ptrs 3 assms(1) type_wf filter
by(auto intro: bind_pure_I bind_is_OK_I2)
with 4 document_ptrs have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r document_ptr"
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_pure_returns_result_I
filter_M_pure_I bind_pure_I split: option.splits)
moreover have "known_ptr (cast node_ptr)"
using known_ptrs_known_ptr[OF known_ptrs, where ptr="cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"] 2
known_ptrs_implies by(simp)
ultimately show ?thesis
using 2
apply(auto simp add: CD.a_get_owner_document_tups_def get_owner_document_def
a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_shadow_root_ptr)
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto split: option.splits intro!: bind_pure_returns_result_I)
qed
lemma in_disconnected_nodes_no_parent:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r None"
assumes "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r owner_document"
assumes "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assumes "known_ptrs h"
assumes "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
have "\<And>parent. parent |\<in>| object_ptr_kinds h \<Longrightarrow> node_ptr \<notin> set |h \<turnstile> get_child_nodes parent|\<^sub>r"
using assms(2)
by (meson get_child_nodes_ok assms(1) assms(5) assms(6) local.child_parent_dual
local.known_ptrs_known_ptr option.distinct(1) returns_result_eq returns_result_select_result)
then show ?thesis
by (smt assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) finite_set_in
is_OK_returns_result_I local.get_disconnected_nodes_ok local.get_owner_document_disconnected_nodes
local.get_parent_ptr_in_heap local.heap_is_wellformed_children_disc_nodes returns_result_select_result
select_result_I2)
qed
lemma get_owner_document_owner_document_in_heap_node:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
proof -
obtain root where
root: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r root"
using assms(4)
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: option.splits)
then show ?thesis
proof (cases "is_document_ptr root")
case True
then show ?thesis
using assms(4) root
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using assms document_ptr_kinds_commutes get_root_node_root_in_heap
by blast
next
case False
have "known_ptr root"
using assms local.get_root_node_root_in_heap local.known_ptrs_known_ptr root by blast
have "root |\<in>| object_ptr_kinds h"
using root
using assms local.get_root_node_root_in_heap
by blast
show ?thesis
proof (cases "is_shadow_root_ptr root")
case True
then show ?thesis
using assms(4) root
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply(drule(1) returns_result_eq) apply(auto)[1]
using assms document_ptr_kinds_commutes get_root_node_root_in_heap
by blast
next
case False
then have "is_node_ptr_kind root"
using \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root\<close> \<open>known_ptr root\<close> \<open>root |\<in>| object_ptr_kinds h\<close>
apply(simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs)
using is_node_ptr_kind_none
by force
then
have "(\<exists>document_ptr \<in> fset (document_ptr_kinds h). root \<in> cast ` set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)"
using local.child_parent_dual local.get_child_nodes_ok local.get_root_node_same_no_parent
local.heap_is_wellformed_children_disc_nodes local.known_ptrs_known_ptr node_ptr_casts_commute3
node_ptr_inclusion node_ptr_kinds_commutes notin_fset option.distinct(1) returns_result_eq
returns_result_select_result root
by (metis (no_types, lifting) assms \<open>root |\<in>| object_ptr_kinds h\<close>)
then obtain some_owner_document where
"some_owner_document |\<in>| document_ptr_kinds h" and
"root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r"
by auto
then
obtain candidates where
candidates: "h \<turnstile> filter_M
(\<lambda>document_ptr.
Heap_Error_Monad.bind (get_disconnected_nodes document_ptr)
(\<lambda>disconnected_nodes. return (root \<in> cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ` set disconnected_nodes)))
(sorted_list_of_set (fset (document_ptr_kinds h)))
\<rightarrow>\<^sub>r candidates"
by (metis (no_types, lifting) assms bind_is_OK_I2 bind_pure_I filter_M_is_OK_I finite_fset
is_OK_returns_result_E local.get_disconnected_nodes_ok local.get_disconnected_nodes_pure notin_fset
return_ok return_pure sorted_list_of_set(1))
then have "some_owner_document \<in> set candidates"
apply(rule filter_M_in_result_if_ok)
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto intro!: bind_pure_I bind_pure_returns_result_I)[1]
using \<open>some_owner_document |\<in>| document_ptr_kinds h\<close>
\<open>root \<in> cast ` set |h \<turnstile> get_disconnected_nodes some_owner_document|\<^sub>r\<close>
apply(auto simp add: assms local.get_disconnected_nodes_ok
intro!: bind_pure_I bind_pure_returns_result_I)[1]
done
then have "candidates \<noteq> []"
by auto
then have "owner_document \<in> set candidates"
using assms(4) root
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis candidates list.set_sel(1) returns_result_eq)
by (metis \<open>is_node_ptr_kind root\<close> node_ptr_no_document_ptr_cast returns_result_eq)
then show ?thesis
using candidates
by (meson bind_pure_I bind_returns_result_E2 filter_M_holds_for_result is_OK_returns_result_I
local.get_disconnected_nodes_ptr_in_heap local.get_disconnected_nodes_pure return_pure)
qed
qed
qed
lemma get_owner_document_owner_document_in_heap:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
shows "owner_document |\<in>| document_ptr_kinds h"
using assms
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_split_asm)+
proof -
assume "h \<turnstile> invoke [] ptr () \<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by (meson invoke_empty is_OK_returns_result_I)
next
assume "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ())
\<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
split: if_splits)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then show ?thesis
by (metis bind_returns_result_E2 check_in_heap_pure comp_apply
get_owner_document_owner_document_in_heap_node)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then show ?thesis
by (metis bind_returns_result_E2 check_in_heap_pure comp_apply get_owner_document_owner_document_in_heap_node)
next
assume 0: "heap_is_wellformed h"
and 1: "type_wf h"
and 2: "known_ptrs h"
and 3: "\<not> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 4: "\<not> is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 5: "\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 6: "is_shadow_root_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr"
and 7: "h \<turnstile> Heap_Error_Monad.bind (check_in_heap ptr)
(\<lambda>_. (local.a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r \<circ> the \<circ> cast\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r) ptr ()) \<rightarrow>\<^sub>r owner_document"
then show "owner_document |\<in>| document_ptr_kinds h"
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2 split: if_splits)
qed
lemma get_owner_document_ok:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (get_owner_document ptr)"
proof -
have "known_ptr ptr"
using assms(2) assms(4) local.known_ptrs_known_ptr
by blast
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(auto simp add: known_ptr_impl)[1]
using NodeClass.a_known_ptr_def known_ptr_not_character_data_ptr known_ptr_not_document_ptr
known_ptr_not_shadow_root_ptr known_ptr_not_element_ptr apply blast
using assms(4)
apply(auto simp add: get_root_node_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I filter_M_is_OK_I
split: option.splits)[1]
using assms(4)
apply(auto simp add: get_root_node_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_is_OK_pure_I
filter_M_pure_I bind_pure_I filter_M_is_OK_I split: option.splits)[1]
using assms(4)
apply(auto simp add: assms(1) assms(2) assms(3) local.get_ancestors_ok get_disconnected_nodes_ok
get_root_node_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
filter_M_is_OK_I split: option.splits)[1]
using assms(4)
apply(auto simp add: assms(1) assms(2) assms(3) local.get_ancestors_ok get_disconnected_nodes_ok
get_root_node_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def intro!: bind_is_OK_pure_I filter_M_pure_I bind_pure_I
filter_M_is_OK_I split: option.splits)[1]
done
qed
lemma get_owner_document_child_same:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
assumes "child \<in> set children"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_child_nodes_ptr_in_heap)
then have "known_ptr ptr"
using assms(2) local.known_ptrs_known_ptr by blast
have "cast child |\<in>| object_ptr_kinds h"
using assms(1) assms(4) assms(5) local.heap_is_wellformed_children_in_heap node_ptr_kinds_commutes
by blast
then
have "known_ptr (cast child)"
using assms(2) local.known_ptrs_known_ptr by blast
then have "is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast child) \<or> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast child)"
by(auto simp add: known_ptr_impl NodeClass.a_known_ptr_def ElementClass.a_known_ptr_def
CharacterDataClass.a_known_ptr_def DocumentClass.a_known_ptr_def a_known_ptr_def
split: option.splits)
obtain root where root: "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
by (meson \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(1) assms(2) assms(3) is_OK_returns_result_E
local.get_root_node_ok)
then have "h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root"
using assms(1) assms(2) assms(3) assms(4) assms(5) local.child_parent_dual local.get_root_node_parent_same
by blast
have "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr ptr")
case True
then obtain document_ptr where document_ptr: "cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr = ptr"
using case_optionE document_ptr_casts_commute by blast
then have "root = cast document_ptr"
using root
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using document_ptr \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast document_ptr\<close>
document_ptr]
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2 dest!: bind_returns_result_E3[rotated, OF
\<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast document_ptr\<close> document_ptr], rotated]
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: if_splits option.splits)[1]
using \<open>ptr |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes by blast
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> True
by(auto simp add: document_ptr[symmetric] intro!: bind_pure_returns_result_I
split: option.splits)
next
case False
then show ?thesis
proof (cases "is_shadow_root_ptr ptr")
case True
then obtain shadow_root_ptr where shadow_root_ptr: "cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr = ptr"
using case_optionE shadow_root_ptr_casts_commute
by (metis (no_types, lifting) document_ptr_casts_commute3 is_document_ptr_kind_none option.case_eq_if)
then have "root = cast shadow_root_ptr"
using root
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have "h \<turnstile> a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r shadow_root_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using shadow_root_ptr \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified \<open>root = cast shadow_root_ptr\<close>
shadow_root_ptr]
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>[simplified
\<open>root = cast shadow_root_ptr\<close> shadow_root_ptr], rotated] intro!: bind_pure_returns_result_I
filter_M_pure_I bind_pure_I split: if_splits option.splits)[1]
using \<open>ptr |\<in>| object_ptr_kinds h\<close> shadow_root_ptr_kinds_commutes document_ptr_kinds_commutes
by blast
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> True
using False
by(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def shadow_root_ptr[symmetric]
intro!: bind_pure_returns_result_I split: option.splits)
next
case False
then obtain node_ptr where node_ptr: "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr = ptr"
using \<open>known_ptr ptr\<close> \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document \<longleftrightarrow>
h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r child () \<rightarrow>\<^sub>r owner_document"
using root \<open>h \<turnstile> get_root_node (cast child) \<rightarrow>\<^sub>r root\<close>
unfolding CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
by (meson bind_pure_returns_result_I bind_returns_result_E3 local.get_root_node_pure)
then show ?thesis
using \<open>known_ptr ptr\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
using \<open>cast child |\<in>| object_ptr_kinds h\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close> False \<open>\<not> is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r ptr\<close>
apply(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I split: )[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
by(auto simp add: node_ptr[symmetric] intro!: bind_pure_returns_result_I dest!: is_OK_returns_result_I)
qed
qed
then show ?thesis
using \<open>is_character_data_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<or> is_element_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child)\<close>
using \<open>cast child |\<in>| object_ptr_kinds h\<close>
by(auto simp add: get_owner_document_def[of "cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child"]
a_get_owner_document_tups_def CD.a_get_owner_document_tups_def split: invoke_splits)
qed
lemma get_owner_document_rel:
assumes "heap_is_wellformed h" "known_ptrs h" "type_wf h"
assumes "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
assumes "ptr \<noteq> cast owner_document"
shows "(cast owner_document, ptr) \<in> (parent_child_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
proof -
have "ptr |\<in>| object_ptr_kinds h"
using assms
by (meson is_OK_returns_result_I local.get_owner_document_ptr_in_heap)
then
have "known_ptr ptr"
using known_ptrs_known_ptr[OF assms(2)] by simp
have "is_node_ptr_kind ptr"
proof (rule ccontr)
assume "\<not> is_node_ptr_kind ptr"
then
show False
using assms(4) \<open>known_ptr ptr\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply(drule(1) known_ptr_not_shadow_root_ptr)
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(5)
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
elim!: bind_returns_result_E2 split: if_splits option.splits)
qed
then obtain node_ptr where node_ptr: "ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
using assms(4) \<open>known_ptr ptr\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply(drule(1) known_ptr_not_shadow_root_ptr)
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>ptr |\<in>| object_ptr_kinds h\<close>
by (auto simp add: is_document_ptr_kind_none)
then obtain root where root: "h \<turnstile> get_root_node (cast node_ptr) \<rightarrow>\<^sub>r root"
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2)
then have "root |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) local.get_root_node_root_in_heap by blast
then
have "known_ptr root"
using \<open>known_ptrs h\<close> local.known_ptrs_known_ptr by blast
have "(root, cast node_ptr) \<in> (parent_child_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using root
by (simp add: assms(1) assms(2) assms(3) in_rtrancl_UnI local.get_root_node_parent_child_rel)
show ?thesis
proof (cases "is_document_ptr_kind root")
case True
then have "root = cast owner_document"
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def
dest!: bind_returns_result_E3[rotated, OF root, rotated] split: option.splits)
then have "(root, cast node_ptr) \<in> (parent_child_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using assms(1) assms(2) assms(3) in_rtrancl_UnI local.get_root_node_parent_child_rel root
by blast
then show ?thesis
using \<open>root = cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r owner_document\<close> node_ptr by blast
next
case False
then obtain root_node where root_node: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node"
using assms(2) \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: known_ptr_impl ShadowRootClass.known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
dest!: known_ptrs_known_ptr split: option.splits)
have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root False
apply(auto simp add: root_node CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
dest!: bind_returns_result_E3[rotated, OF root, rotated] split: option.splits
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I)[1]
by (simp add: assms(1) assms(2) assms(3) local.get_root_node_no_parent local.get_root_node_same_no_parent)
then
have "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
using \<open>known_ptr root\<close>
apply(auto simp add: get_owner_document_def CD.a_get_owner_document_tups_def
a_get_owner_document_tups_def known_ptr_impl)[1]
apply(split invoke_splits, ((rule conjI | rule impI)+)?)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr)
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root
False \<open>root |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root
False \<open>root |\<in>| object_ptr_kinds h\<close>
apply(auto intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root
False \<open>root |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: root_node intro!: bind_pure_returns_result_I split: option.splits)[1]
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> root
False \<open>root |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: root_node intro!: bind_pure_returns_result_I split: option.splits)[1]
done
have "\<not> (\<exists>parent\<in>fset (object_ptr_kinds h). root_node \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)"
using root_node
by (metis (no_types, lifting) assms(1) assms(2) assms(3) local.child_parent_dual
local.get_child_nodes_ok local.get_root_node_same_no_parent local.known_ptrs_known_ptr
notin_fset option.distinct(1) returns_result_eq returns_result_select_result root)
have "root_node |\<in>| node_ptr_kinds h"
using assms(1) assms(2) assms(3) local.get_root_node_root_in_heap node_ptr_kinds_commutes root root_node
by blast
then have "\<exists>document_ptr\<in>fset (document_ptr_kinds h). root_node \<in> set |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using \<open>\<not> (\<exists>parent\<in>fset (object_ptr_kinds h). root_node \<in> set |h \<turnstile> get_child_nodes parent|\<^sub>r)\<close> assms(1)
local.heap_is_wellformed_children_disc_nodes by blast
then obtain disc_nodes document_ptr where "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
and "root_node \<in> set disc_nodes"
by (meson assms(3) local.get_disconnected_nodes_ok notin_fset returns_result_select_result)
then have "document_ptr |\<in>| document_ptr_kinds h"
by (meson is_OK_returns_result_I local.get_disconnected_nodes_ptr_in_heap)
then have "document_ptr = owner_document"
by (metis \<open>h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes\<close>
\<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close> \<open>root_node \<in> set disc_nodes\<close> assms(1) assms(2)
assms(3) local.get_owner_document_disconnected_nodes returns_result_eq root_node)
then have "(cast owner_document, cast root_node) \<in> a_ptr_disconnected_node_rel h"
apply(auto simp add: a_ptr_disconnected_node_rel_def)[1]
using \<open>h \<turnstile> local.CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> assms(1)
assms(2) assms(3) get_owner_document_owner_document_in_heap_node
by (metis (no_types, lifting) \<open>h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes\<close>
\<open>root_node \<in> set disc_nodes\<close> case_prodI mem_Collect_eq pair_imageI select_result_I2)
moreover have "(cast root_node, cast node_ptr) \<in>
(parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
by (metis assms(1) assms(2) assms(3) in_rtrancl_UnI local.get_root_node_parent_child_rel
root root_node)
ultimately show ?thesis
by (metis (no_types, lifting) assms(1) assms(2) assms(3) in_rtrancl_UnI
local.get_root_node_parent_child_rel node_ptr r_into_rtrancl root root_node rtrancl_trans)
qed
qed
end
interpretation i_get_owner_document_wf?: l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_disconnected_nodes get_disconnected_nodes_locs known_ptr get_child_nodes
get_child_nodes_locs DocumentClass.known_ptr get_parent get_parent_locs DocumentClass.type_wf
get_root_node get_root_node_locs CD.a_get_owner_document get_host get_host_locs get_owner_document
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed
parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document get_disconnected_document_locs
known_ptrs get_ancestors get_ancestors_locs
by(auto simp add: l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_wf_is_l_get_owner_document_wf [instances]:
"l_get_owner_document_wf heap_is_wellformed type_wf known_ptr known_ptrs get_disconnected_nodes
get_owner_document get_parent get_child_nodes"
apply(auto simp add: l_get_owner_document_wf_def l_get_owner_document_wf_axioms_def instances)[1]
using get_owner_document_disconnected_nodes apply fast
using in_disconnected_nodes_no_parent apply fast
using get_owner_document_owner_document_in_heap apply fast
using get_owner_document_ok apply fast
using get_owner_document_child_same apply (fast, fast)
done
paragraph \<open>get\_owner\_document\<close>
locale l_get_owner_document_wf_get_root_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_owner_document\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node_wf +
l_get_owner_document_wf +
assumes known_ptr_impl: "known_ptr = a_known_ptr"
begin
lemma get_root_node_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
assumes "is_document_ptr_kind root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r the (cast root)"
proof -
have "ptr |\<in>| object_ptr_kinds h"
using assms(4)
by (meson is_OK_returns_result_I local.get_root_node_ptr_in_heap)
then have "known_ptr ptr"
using assms(3) local.known_ptrs_known_ptr by blast
{
assume "is_document_ptr_kind ptr"
then have "ptr = root"
using assms(4)
by(auto simp add: get_root_node_def get_ancestors_def elim!: bind_returns_result_E2
split: option.splits)
then have ?thesis
using \<open>is_document_ptr_kind ptr\<close> \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
by(auto simp add: CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
intro!: bind_pure_returns_result_I split: option.splits)
}
moreover
{
assume "is_node_ptr_kind ptr"
then have ?thesis
using \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: known_ptr_impl get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
apply(drule(1) known_ptr_not_shadow_root_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_document_ptr[folded known_ptr_impl])
apply(drule(1) known_ptr_not_character_data_ptr)
apply(drule(1) known_ptr_not_element_ptr)
apply(simp add: NodeClass.known_ptr_defs)
apply(auto split: option.splits)[1]
using \<open>h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root\<close> assms(5)
by(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr_kind_def
intro!: bind_pure_returns_result_I split: option.splits)
}
ultimately
show ?thesis
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
qed
lemma get_root_node_same_owner_document:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_root_node ptr \<rightarrow>\<^sub>r root"
shows "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document \<longleftrightarrow> h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof -
have "ptr |\<in>| object_ptr_kinds h"
by (meson assms(4) is_OK_returns_result_I local.get_root_node_ptr_in_heap)
have "root |\<in>| object_ptr_kinds h"
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_root_in_heap by blast
have "known_ptr ptr"
using \<open>ptr |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
have "known_ptr root"
using \<open>root |\<in>| object_ptr_kinds h\<close> assms(3) local.known_ptrs_known_ptr by blast
show ?thesis
proof (cases "is_document_ptr_kind ptr")
case True
then
have "ptr = root"
using assms(4)
apply(auto simp add: get_root_node_def elim!: bind_returns_result_E2)[1]
by (metis document_ptr_casts_commute3 last_ConsL local.get_ancestors_not_node node_ptr_no_document_ptr_cast)
then show ?thesis
by auto
next
case False
then have "is_node_ptr_kind ptr"
using \<open>known_ptr ptr\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
then obtain node_ptr where node_ptr: "ptr = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr"
by (metis node_ptr_casts_commute3)
show ?thesis
proof
assume "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
using node_ptr
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto elim!: bind_returns_result_E2 split: option.splits)
show "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
then show ?thesis
proof (cases "is_shadow_root_ptr root")
case True
then
have "is_shadow_root_ptr root"
using True \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
have "root = cast owner_document"
using \<open>is_document_ptr_kind root\<close>
by (smt \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3) assms(4)
document_ptr_casts_commute3 get_root_node_document returns_result_eq)
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_shadow_root_ptr root\<close> apply blast
using \<open>root |\<in>| object_ptr_kinds h\<close>
apply(simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none)
apply (metis \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3)
case_optionE document_ptr_kinds_def is_shadow_root_ptr_kind_none l_get_owner_document_wf.get_owner_document_owner_document_in_heap local.l_get_owner_document_wf_axioms not_None_eq return_bind shadow_root_ptr_casts_commute3 shadow_root_ptr_kinds_commutes shadow_root_ptr_kinds_def)
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
done
next
case False
then
have "is_document_ptr root"
using True \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
have "root = cast owner_document"
using True
by (smt \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3) assms(4)
document_ptr_casts_commute3 get_root_node_document returns_result_eq)
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_document_ptr\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root\<close> apply blast
using \<open>root |\<in>| object_ptr_kinds h\<close>
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none)[1]
apply (metis \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> assms(1) assms(2) assms(3)
case_optionE document_ptr_kinds_def is_shadow_root_ptr_kind_none
l_get_owner_document_wf.get_owner_document_owner_document_in_heap local.l_get_owner_document_wf_axioms
not_None_eq return_bind shadow_root_ptr_casts_commute3 shadow_root_ptr_kinds_commutes shadow_root_ptr_kinds_def)
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close> document_ptr_kinds_commutes
apply(auto simp add: a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
is_node_ptr_kind_none intro!: bind_pure_returns_result_I)[1]
done
qed
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document\<close> assms(4)
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
apply (metis assms(1) assms(2) assms(3) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq)
using \<open>is_node_ptr_kind root\<close> node_ptr returns_result_eq by fastforce
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using \<open>is_node_ptr_kind root\<close> \<open>known_ptr root\<close>
apply(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
using \<open>is_node_ptr_kind root\<close> \<open>known_ptr root\<close>
apply(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
using \<open>is_node_ptr_kind root\<close> \<open>known_ptr root\<close>
apply(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
split: option.splits)[1]
using \<open>root |\<in>| object_ptr_kinds h\<close>
by(auto simp add: root_node_ptr)
qed
next
assume "h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document"
show "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
proof (cases "is_document_ptr_kind root")
case True
have "root = cast owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
apply(auto simp add: True CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: if_splits option.splits)[1]
apply(auto simp add: True CD.a_get_owner_document\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
a_get_owner_document\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2 split: if_splits option.splits)[1]
apply (metis True cast_document_ptr_not_node_ptr(2) is_document_ptr_kind_obtains
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
by (metis True cast_document_ptr_not_node_ptr(1) document_ptr_casts_commute3
is_node_ptr_kind_none node_ptr_casts_commute3 option.case_eq_if)
then show ?thesis
using assms(1) assms(2) assms(3) assms(4) get_root_node_document
by fastforce
next
case False
then have "is_node_ptr_kind root"
using \<open>known_ptr root\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs split: option.splits)
then obtain root_node_ptr where root_node_ptr: "root = cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr"
by (metis node_ptr_casts_commute3)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r root_node_ptr () \<rightarrow>\<^sub>r owner_document"
using \<open>h \<turnstile> get_owner_document root \<rightarrow>\<^sub>r owner_document\<close>
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits)+
apply (meson invoke_empty is_OK_returns_result_I)
by(auto simp add: is_document_ptr_kind_none elim!: bind_returns_result_E2)
then have "h \<turnstile> CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r node_ptr () \<rightarrow>\<^sub>r owner_document"
apply(auto simp add: CD.a_get_owner_document\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def elim!: bind_returns_result_E2
intro!: bind_pure_returns_result_I filter_M_pure_I bind_pure_I split: option.splits)[1]
using assms(1) assms(2) assms(3) assms(4) local.get_root_node_no_parent
local.get_root_node_same_no_parent node_ptr returns_result_eq root_node_ptr
by fastforce+
then show ?thesis
apply(auto simp add: get_owner_document_def a_get_owner_document_tups_def
CD.a_get_owner_document_tups_def)[1]
apply(split invoke_splits, (rule conjI | rule impI)+)+
using node_ptr \<open>known_ptr ptr\<close> \<open>ptr |\<in>| object_ptr_kinds h\<close>
by(auto simp add: known_ptr_impl known_ptr_defs DocumentClass.known_ptr_defs
CharacterDataClass.known_ptr_defs ElementClass.known_ptr_defs NodeClass.known_ptr_defs
intro!: bind_pure_returns_result_I split: option.splits)
qed
qed
qed
qed
end
interpretation i_get_owner_document_wf_get_root_node_wf?: l_get_owner_document_wf_get_root_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
DocumentClass.known_ptr get_parent get_parent_locs DocumentClass.type_wf get_disconnected_nodes
get_disconnected_nodes_locs get_root_node get_root_node_locs CD.a_get_owner_document
get_host get_host_locs get_owner_document get_child_nodes get_child_nodes_locs type_wf known_ptr
known_ptrs get_ancestors get_ancestors_locs heap_is_wellformed parent_child_rel
by(auto simp add: l_get_owner_document_wf_get_root_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def
l_get_owner_document_wf_get_root_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms_def instances)
declare l_get_owner_document_wf_get_root_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma get_owner_document_wf_get_root_node_wf_is_l_get_owner_document_wf_get_root_node_wf [instances]:
"l_get_owner_document_wf_get_root_node_wf heap_is_wellformed type_wf known_ptr known_ptrs get_root_node get_owner_document"
apply(auto simp add: l_get_owner_document_wf_get_root_node_wf_def l_get_owner_document_wf_get_root_node_wf_axioms_def instances)[1]
using get_root_node_document apply blast
using get_root_node_same_owner_document apply (blast, blast)
done
subsubsection \<open>remove\_child\<close>
locale l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_set_disconnected_nodes_get_disconnected_nodes +
l_get_child_nodes +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_owner_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
CD: l_remove_child_wf2\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma remove_child_preserves_type_wf:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "type_wf h'"
using CD.remove_child_heap_is_wellformed_preserved(1) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_child_preserves_known_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'"
using CD.remove_child_heap_is_wellformed_preserved(2) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_child_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove_child ptr child \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
proof -
obtain owner_document children_h h2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r child) \<rightarrow>\<^sub>r owner_document" and
children_h: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h2: "h \<turnstile> set_disconnected_nodes owner_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> set_child_nodes ptr (remove1 child children_h) \<rightarrow>\<^sub>h h'"
using assms(4)
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure] split: if_splits)[1]
using pure_returns_heap_eq by fastforce
have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
using CD.remove_child_heap_is_wellformed_preserved(3) assms
unfolding heap_is_wellformed_def
by auto
have "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document"
using owner_document children_h child_in_children_h
using local.get_owner_document_child_same assms by blast
have shadow_root_eq: "\<And>ptr' shadow_root_ptr_opt. h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads remove_child_writes assms(4)
apply(rule reads_writes_preserved)
by(auto simp add: remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2: "\<And>ptr'. |h \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq: "\<And>ptr' tag. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads remove_child_writes assms(4)
apply(rule reads_writes_preserved)
by(auto simp add: remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq: "object_ptr_kinds h = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
have document_ptr_kinds_eq: "document_ptr_kinds h = document_ptr_kinds h'"
using object_ptr_kinds_eq
by(auto simp add: document_ptr_kinds_def document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq: "element_ptr_kinds h = element_ptr_kinds h'"
using object_ptr_kinds_eq
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h"
using \<open>heap_is_wellformed h\<close> heap_is_wellformed_def
using CD.remove_child_parent_child_rel_subset
using \<open>known_ptrs h\<close> \<open>type_wf h\<close> assms(4)
by simp
have "known_ptr ptr"
using assms(3)
using children_h get_child_nodes_ptr_in_heap local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'",
OF set_disconnected_nodes_writes h2]
using set_disconnected_nodes_types_preserved \<open>type_wf h\<close>
by(auto simp add: reflp_def transp_def)
have children_eq:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children =
h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
apply(rule reads_writes_preserved[OF get_child_nodes_reads remove_child_writes assms(4)])
unfolding remove_child_locs_def
using set_disconnected_nodes_get_child_nodes set_child_nodes_get_child_nodes_different_pointers
by fast
then have children_eq2:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h"
apply(rule reads_writes_separate_forwards[OF get_child_nodes_reads
set_disconnected_nodes_writes h2 children_h] )
by (simp add: set_disconnected_nodes_get_child_nodes)
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r remove1 child children_h"
using assms(4) owner_document h2 disconnected_nodes_h children_h
apply(auto simp add: remove_child_def split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto split: if_splits)[1]
apply(simp)
apply(auto split: if_splits)[1]
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E3)
apply(auto)[1]
apply(simp)
apply(drule bind_returns_heap_E4)
apply(auto)[1]
apply simp
using \<open>type_wf h2\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close> h'
by blast
have disconnected_nodes_eq: "\<And>ptr' disc_nodes. ptr' \<noteq> owner_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_disconnected_nodes_writes h2
apply(rule reads_writes_preserved)
by (metis local.set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then
have disconnected_nodes_eq2: "\<And>ptr'. ptr' \<noteq> owner_document \<Longrightarrow>
|h \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
have "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using h2 local.set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h2:
"\<And>ptr' disc_nodes. h2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_child_nodes_writes h'
apply(rule reads_writes_preserved)
using local.set_child_nodes_get_disconnected_nodes by blast
then
have disconnected_nodes_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h' \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
have "a_host_shadow_root_rel h' = a_host_shadow_root_rel h"
by(auto simp add: a_host_shadow_root_rel_def shadow_root_eq2 element_ptr_kinds_eq)
moreover
have "(ptr, cast child) \<in> parent_child_rel h"
using child_in_children_h children_h local.CD.parent_child_rel_child by blast
moreover
have "a_ptr_disconnected_node_rel h' = insert (cast owner_document, cast child) (a_ptr_disconnected_node_rel h)"
using \<open>h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h\<close> disconnected_nodes_eq2 disconnected_nodes_h
apply(auto simp add: a_ptr_disconnected_node_rel_def disconnected_nodes_eq2_h2[symmetric] document_ptr_kinds_eq[symmetric])[1]
apply(case_tac "aa = owner_document")
apply(auto)[1]
apply(auto)[1]
apply (metis (no_types, lifting) assms(4) case_prodI disconnected_nodes_eq_h2 h2
is_OK_returns_heap_I local.remove_child_in_disconnected_nodes
local.set_disconnected_nodes_ptr_in_heap mem_Collect_eq owner_document pair_imageI select_result_I2)
by (metis (no_types, lifting) case_prodI list.set_intros(2) mem_Collect_eq pair_imageI select_result_I2)
then
have "a_ptr_disconnected_node_rel h' = a_ptr_disconnected_node_rel h \<union> {(cast owner_document, cast child)}"
by auto
moreover have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using assms(1) local.heap_is_wellformed_def by blast
moreover have "parent_child_rel h' = parent_child_rel h - {(ptr, cast child)}"
apply(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq children_eq2)[1]
apply (metis (no_types, lifting) children_eq2 children_h children_h' notin_set_remove1 select_result_I2)
using \<open>h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r child # disconnected_nodes_h\<close>
\<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close> disconnected_nodes_eq_h2 local.CD.distinct_lists_no_parent
local.CD.heap_is_wellformed_def apply auto[1]
by (metis (no_types, lifting) children_eq2 children_h children_h' in_set_remove1 select_result_I2)
moreover have "(cast owner_document, ptr) \<in> (parent_child_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using \<open>h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document\<close> get_owner_document_rel
using assms(1) assms(2) assms(3) by blast
then have "(cast owner_document, ptr) \<in> (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
by (metis (no_types, lifting) in_rtrancl_UnI inf_sup_aci(5) inf_sup_aci(7))
ultimately
have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by (smt Un_assoc Un_insert_left Un_insert_right acyclic_insert insert_Diff_single
insert_absorb2 mk_disjoint_insert prod.inject rtrancl_Un_separator_converseE rtrancl_trans
singletonD sup_bot.comm_neutral)
show ?thesis
using \<open>heap_is_wellformed h\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close>
using \<open>acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
host_shadow_root_rel_def a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def)[1]
by(auto simp add: object_ptr_kinds_eq element_ptr_kinds_eq shadow_root_ptr_kinds_eq
shadow_root_eq shadow_root_eq2 tag_name_eq tag_name_eq2)
qed
lemma remove_preserves_type_wf:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "type_wf h'"
using CD.remove_heap_is_wellformed_preserved(1) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_preserves_known_ptrs:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "known_ptrs h'"
using CD.remove_heap_is_wellformed_preserved(2) assms
unfolding heap_is_wellformed_def
by auto
lemma remove_heap_is_wellformed_preserved:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> remove child \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'"
using assms
by(auto simp add: remove_def elim!: bind_returns_heap_E2
intro: remove_child_heap_is_wellformed_preserved split: option.splits)
lemma remove_child_removes_child:
"heap_is_wellformed h \<Longrightarrow> h \<turnstile> remove_child ptr' child \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children
\<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> child \<notin> set children"
using CD.remove_child_removes_child local.heap_is_wellformed_def by blast
lemma remove_child_removes_first_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children \<Longrightarrow>
h \<turnstile> remove_child ptr node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using CD.remove_child_removes_first_child local.heap_is_wellformed_def by blast
lemma remove_removes_child:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r node_ptr # children \<Longrightarrow>
h \<turnstile> remove node_ptr \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using CD.remove_removes_child local.heap_is_wellformed_def by blast
lemma remove_for_all_empty_children:
"heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow>
h \<turnstile> forall_M remove children \<rightarrow>\<^sub>h h' \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
using CD.remove_for_all_empty_children local.heap_is_wellformed_def by blast
end
interpretation i_remove_child_wf2?: l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs known_ptr get_child_nodes get_child_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs
DocumentClass.known_ptr get_parent get_parent_locs DocumentClass.type_wf get_root_node get_root_node_locs
CD.a_get_owner_document get_owner_document known_ptrs get_ancestors get_ancestors_locs set_child_nodes
set_child_nodes_locs remove_child remove_child_locs remove
by(auto simp add: l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_remove_child_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma remove_child_wf2_is_l_remove_child_wf2 [instances]:
"l_remove_child_wf2 type_wf known_ptr known_ptrs remove_child heap_is_wellformed get_child_nodes remove"
apply(auto simp add: l_remove_child_wf2_def l_remove_child_wf2_axioms_def instances)[1]
using remove_child_preserves_type_wf apply fast
using remove_child_preserves_known_ptrs apply fast
using remove_child_heap_is_wellformed_preserved apply (fast)
using remove_preserves_type_wf apply fast
using remove_preserves_known_ptrs apply fast
using remove_heap_is_wellformed_preserved apply (fast)
using remove_child_removes_child apply fast
using remove_child_removes_first_child apply fast
using remove_removes_child apply fast
using remove_for_all_empty_children apply fast
done
subsubsection \<open>adopt\_node\<close>
locale l_adopt_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
CD: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ _ _ _ adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_removes_first_child: "heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h'
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r node # children
\<Longrightarrow> h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
by (smt CD.adopt_node_removes_first_child bind_returns_heap_E error_returns_heap
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M.adopt_node_def local.CD.adopt_node_impl local.get_ancestors_di_pure
local.l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms pure_returns_heap_eq)
lemma adopt_node_document_in_heap: "heap_is_wellformed h \<Longrightarrow> known_ptrs h \<Longrightarrow> type_wf h
\<Longrightarrow> h \<turnstile> ok (adopt_node owner_document node)
\<Longrightarrow> owner_document |\<in>| document_ptr_kinds h"
by (metis (no_types, lifting) bind_returns_heap_E document_ptr_kinds_commutes is_OK_returns_heap_E
is_OK_returns_result_I local.adopt_node_def local.get_ancestors_di_ptr_in_heap)
end
locale l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_disconnected_nodes +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
l_get_owner_document +
l_remove_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M+
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_root_node +
l_set_disconnected_nodes_get_child_nodes +
l_get_owner_document_wf +
l_remove_child_wf2 +
l_adopt_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_parent_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_disconnected_document +
l_get_ancestors_di\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma adopt_node_removes_child:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h2"
and children: "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<notin> set children"
proof -
obtain old_document parent_opt h' where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h': "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return () ) \<rightarrow>\<^sub>h h'"
using adopt_node
by(auto simp add: adopt_node_def CD.adopt_node_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_ancestors_di_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
split: if_splits)
then have "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using adopt_node
apply(auto simp add: adopt_node_def CD.adopt_node_def
dest!: bind_returns_heap_E3[rotated, OF old_document, rotated]
bind_returns_heap_E3[rotated, OF parent_opt, rotated]
elim!: bind_returns_heap_E2[rotated, OF get_ancestors_di_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
bind_returns_heap_E4[rotated, OF h', rotated] split: if_splits)[1]
apply(auto split: if_splits elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_ancestors_di_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
apply (simp add: set_disconnected_nodes_get_child_nodes children
reads_writes_preserved[OF get_child_nodes_reads set_disconnected_nodes_writes])
using children by blast
show ?thesis
proof(insert parent_opt h', induct parent_opt)
case None
then show ?case
using child_parent_dual wellformed known_ptrs type_wf \<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close>
returns_result_eq by fastforce
next
case (Some option)
then show ?case
using remove_child_removes_child \<open>h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children\<close> known_ptrs type_wf wellformed
by auto
qed
qed
lemma adopt_node_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> adopt_node document_ptr child \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'"
proof -
obtain old_document parent_opt h2 ancestors where
"h \<turnstile> get_ancestors_di (cast document_ptr) \<rightarrow>\<^sub>r ancestors" and
"cast child \<notin> set ancestors" and
old_document: "h \<turnstile> get_owner_document (cast child) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent child \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent child | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if document_ptr \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 child old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes document_ptr;
set_disconnected_nodes document_ptr (child # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)
apply(auto simp add: adopt_node_def[unfolded CD.adopt_node_def] elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_ancestors_di_pure])[1]
apply(split if_splits)
by(auto simp add: elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure])
have object_ptr_kinds_h_eq3: "object_ptr_kinds h = object_ptr_kinds h2"
using h2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF remove_child_writes])
using remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
unfolding object_ptr_kinds_M_defs by simp
then have object_ptr_kinds_eq_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using h2 remove_child_heap_is_wellformed_preserved known_ptrs type_wf
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
then show "heap_is_wellformed h'"
proof(cases "document_ptr = old_document")
case True
then show "heap_is_wellformed h'"
using h' wellformed_h2 by auto
next
case False
then obtain h3 old_disc_nodes disc_nodes_document_ptr_h3 where
docs_neq: "document_ptr \<noteq> old_document" and
old_disc_nodes: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h3: "h2 \<turnstile> set_disconnected_nodes old_document (remove1 child old_disc_nodes) \<rightarrow>\<^sub>h h3" and
disc_nodes_document_ptr_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (child # disc_nodes_document_ptr_h3) \<rightarrow>\<^sub>h h'"
using h'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h2_eq3: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF set_disconnected_nodes_writes h3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h2: "node_ptr_kinds h2 = node_ptr_kinds h3"
by auto
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2 document_ptr_kinds_M_eq by auto
have children_eq_h2: "\<And>ptr children. h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr. |h2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h3_eq3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3: "\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h3: "node_ptr_kinds h3 = node_ptr_kinds h'"
by auto
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3 document_ptr_kinds_M_eq by auto
have children_eq_h3: "\<And>ptr children. h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h' \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. old_document \<noteq> doc_ptr \<Longrightarrow>
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. old_document \<noteq> doc_ptr \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
obtain disc_nodes_old_document_h2 where disc_nodes_old_document_h2:
"h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
using old_disc_nodes by blast
then have disc_nodes_old_document_h3:
"h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
using h3 old_disc_nodes returns_result_eq set_disconnected_nodes_get_disconnected_nodes
by fastforce
have "distinct disc_nodes_old_document_h2"
using disc_nodes_old_document_h2 local.heap_is_wellformed_disconnected_nodes_distinct wellformed_h2
by blast
have "type_wf h2"
proof (insert h2, induct parent_opt)
case None
then show ?case
using type_wf by simp
next
case (Some option)
then show ?case
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF remove_child_writes]
type_wf remove_child_types_preserved
by (simp add: reflp_def transp_def)
qed
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr \<Longrightarrow>
h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr \<Longrightarrow>
|h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2:
"h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
using disconnected_nodes_eq_h2 docs_neq disc_nodes_document_ptr_h3 by auto
have disc_nodes_document_ptr_h':
"h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
using h' disc_nodes_document_ptr_h3
using set_disconnected_nodes_get_disconnected_nodes by blast
have document_ptr_in_heap: "document_ptr |\<in>| document_ptr_kinds h2"
using disc_nodes_document_ptr_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using disc_nodes_document_ptr_h2 get_disconnected_nodes_ptr_in_heap by blast
have old_document_in_heap: "old_document |\<in>| document_ptr_kinds h2"
using disc_nodes_old_document_h3 document_ptr_kinds_eq2_h2 get_disconnected_nodes_ok assms(1)
unfolding heap_is_wellformed_def
using get_disconnected_nodes_ptr_in_heap old_disc_nodes by blast
have "child \<in> set disc_nodes_old_document_h2"
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h2"
by(auto)
moreover have "CD.a_owner_document_valid h"
using assms(1) by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
ultimately show ?case
using old_document disc_nodes_old_document_h2 None(1) child_parent_dual[OF assms(1)]
in_disconnected_nodes_no_parent assms(1) known_ptrs type_wf by blast
next
case (Some option)
then show ?case
apply(simp split: option.splits)
using assms(1) disc_nodes_old_document_h2 old_document remove_child_in_disconnected_nodes known_ptrs
by blast
qed
have "child \<notin> set (remove1 child disc_nodes_old_document_h2)"
using disc_nodes_old_document_h3 h3 known_ptrs wellformed_h2 \<open>distinct disc_nodes_old_document_h2\<close>
by auto
have "child \<notin> set disc_nodes_document_ptr_h3"
proof -
have "CD.a_distinct_lists h2"
using heap_is_wellformed_def CD.heap_is_wellformed_def wellformed_h2 by blast
then have 0: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r))"
by(simp add: CD.a_distinct_lists_def)
show ?thesis
using distinct_concat_map_E(1)[OF 0] \<open>child \<in> set disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h2 disc_nodes_document_ptr_h2
by (meson \<open>type_wf h2\<close> docs_neq known_ptrs local.get_owner_document_disconnected_nodes
local.known_ptrs_preserved object_ptr_kinds_h_eq3 returns_result_eq wellformed_h2)
qed
have child_in_heap: "child |\<in>| node_ptr_kinds h"
using get_owner_document_ptr_in_heap[OF is_OK_returns_result_I[OF old_document]] node_ptr_kinds_commutes
by blast
have "CD.a_acyclic_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
have "parent_child_rel h' \<subseteq> parent_child_rel h2"
proof
fix x
assume "x \<in> parent_child_rel h'"
then show "x \<in> parent_child_rel h2"
using object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 children_eq2_h2 children_eq2_h3
mem_Collect_eq object_ptr_kinds_M_eq_h3 select_result_eq split_cong
unfolding CD.parent_child_rel_def
by(simp)
qed
then have " CD.a_acyclic_heap h'"
using \<open> CD.a_acyclic_heap h2\<close> CD.acyclic_heap_def acyclic_subset by blast
moreover have " CD.a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h3"
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq3_h2 children_eq_h2)[1]
apply (metis CD.l_heap_is_wellformed_axioms \<open>type_wf h2\<close> children_eq2_h2 known_ptrs
l_heap_is_wellformed.heap_is_wellformed_children_in_heap local.get_child_nodes_ok
local.known_ptrs_known_ptr node_ptr_kinds_eq3_h2 object_ptr_kinds_h2_eq3 object_ptr_kinds_h_eq3
returns_result_select_result wellformed_h2)
by (metis (no_types, lifting) disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 document_ptr_kinds_eq3_h2 finite_set_in select_result_I2 set_remove1_subset
subsetD)
then have "CD.a_all_ptrs_in_heap h'"
by (smt \<open>child \<in> set disc_nodes_old_document_h2\<close> children_eq2_h3 disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq3_h3
finite_set_in local.CD.a_all_ptrs_in_heap_def local.heap_is_wellformed_disc_nodes_in_heap
node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3 object_ptr_kinds_h3_eq3 select_result_I2 set_ConsD
subset_code(1) wellformed_h2)
moreover have "CD.a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(simp add: CD.a_owner_document_valid_def node_ptr_kinds_eq_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
children_eq2_h2 children_eq2_h3 )
by (metis (no_types) disc_nodes_document_ptr_h' disc_nodes_document_ptr_h2
disc_nodes_old_document_h2 disc_nodes_old_document_h3 disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 document_ptr_in_heap document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3
in_set_remove1 list.set_intros(1) list.set_intros(2) node_ptr_kinds_eq3_h2 node_ptr_kinds_eq3_h3
object_ptr_kinds_h2_eq3 object_ptr_kinds_h3_eq3 select_result_I2)
have a_distinct_lists_h2: "CD.a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h'"
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h3 object_ptr_kinds_eq_h2
children_eq2_h2 children_eq2_h3)[1]
proof -
assume 1: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set
(fset (object_ptr_kinds h')))))"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 3: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
show "distinct (concat (map (\<lambda>document_ptr. |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h')))))"
proof(rule distinct_concat_map_I)
show "distinct (sorted_list_of_set (fset (document_ptr_kinds h')))"
by(auto simp add: document_ptr_kinds_M_def )
next
fix x
assume a1: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
have 4: "distinct |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a_distinct_lists_h2 "2" a1 concat_map_all_distinct document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3
by fastforce
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
proof (cases "old_document \<noteq> x")
case True
then show ?thesis
proof (cases "document_ptr \<noteq> x")
case True
then show ?thesis
using disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>]
disconnected_nodes_eq2_h3[OF \<open>document_ptr \<noteq> x\<close>] 4
by(auto)
next
case False
then show ?thesis
using disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' 4
\<open>child \<notin> set disc_nodes_document_ptr_h3\<close>
by(auto simp add: disconnected_nodes_eq2_h2[OF \<open>old_document \<noteq> x\<close>] )
qed
next
case False
then show ?thesis
by (metis (no_types, opaque_lifting) \<open>distinct disc_nodes_old_document_h2\<close>
disc_nodes_old_document_h3 disconnected_nodes_eq2_h3 distinct_remove1 docs_neq select_result_I2)
qed
next
fix x y
assume a0: "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a1: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h')))"
and a2: "x \<noteq> y"
moreover have 5: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using 2 calculation by (auto simp add: document_ptr_kinds_eq3_h2 document_ptr_kinds_eq3_h3
dest: distinct_concat_map_E(1))
ultimately show "set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
proof(cases "old_document = x")
case True
have "old_document \<noteq> y"
using \<open>x \<noteq> y\<close> \<open>old_document = x\<close> by simp
have "document_ptr \<noteq> x"
using docs_neq \<open>old_document = x\<close> by auto
show ?thesis
proof(cases "document_ptr = y")
case True
then show ?thesis
using 5 True select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2] select_result_I2[OF disc_nodes_old_document_h3]
\<open>old_document = x\<close>
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
\<open>document_ptr \<noteq> x\<close> disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1 set_ConsD)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2] select_result_I2[OF disc_nodes_old_document_h3]
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 \<open>old_document = x\<close>
docs_neq \<open>old_document \<noteq> y\<close>
by (metis (no_types, lifting) disjoint_iff_not_equal notin_set_remove1)
qed
next
case False
then show ?thesis
proof(cases "old_document = y")
case True
then show ?thesis
proof(cases "document_ptr = x")
case True
show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document \<noteq> x\<close> \<open>old_document = y\<close> \<open>document_ptr = x\<close>
apply(simp)
by (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
disconnected_nodes_eq2_h3 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document \<noteq> x\<close> \<open>old_document = y\<close>
\<open>document_ptr \<noteq> x\<close>
by (metis (no_types, lifting) disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal docs_neq notin_set_remove1)
qed
next
case False
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
by (metis DocumentMonad.ptr_kinds_M_ok DocumentMonad.ptr_kinds_M_ptr_kinds False
\<open>type_wf h2\<close> a1 disc_nodes_old_document_h2 document_ptr_kinds_M_def document_ptr_kinds_eq2_h2
document_ptr_kinds_eq2_h3 l_ptr_kinds_M.ptr_kinds_ptr_kinds_M local.get_disconnected_nodes_ok
local.heap_is_wellformed_one_disc_parent returns_result_select_result wellformed_h2)
then show ?thesis
proof(cases "document_ptr = x")
case True
then have "document_ptr \<noteq> y"
using \<open>x \<noteq> y\<close> by auto
have "set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}"
using \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by blast
then show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_document_ptr_h2]
select_result_I2[OF disc_nodes_old_document_h2]
select_result_I2[OF disc_nodes_old_document_h3] \<open>old_document \<noteq> x\<close> \<open>old_document \<noteq> y\<close>
\<open>document_ptr = x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3 \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
by(auto)
next
case False
then show ?thesis
proof(cases "document_ptr = y")
case True
have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set disc_nodes_document_ptr_h3 = {}"
using 2 a1 document_ptr_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>document_ptr \<noteq> x\<close> select_result_I2[OF disc_nodes_document_ptr_h3, symmetric]
disconnected_nodes_eq2_h2[OF docs_neq[symmetric], symmetric]
by (simp add: "5" True)
moreover have f1: "set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = {}"
using 2 a1 old_document_in_heap document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
\<open>old_document \<noteq> x\<close>
by (metis (no_types, lifting) a0 distinct_concat_map_E(1) document_ptr_kinds_eq3_h2
- document_ptr_kinds_eq3_h3 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ document_ptr_kinds_eq3_h3 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
ultimately show ?thesis
using 5 select_result_I2[OF disc_nodes_document_ptr_h']
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr = y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by auto
next
case False
then show ?thesis
using 5
select_result_I2[OF disc_nodes_old_document_h2] \<open>old_document \<noteq> x\<close>
\<open>document_ptr \<noteq> x\<close> \<open>document_ptr \<noteq> y\<close>
\<open>child \<in> set disc_nodes_old_document_h2\<close> disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3
by (metis \<open>set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r \<inter> set disc_nodes_old_document_h2 = {}\<close>
empty_iff inf.idem)
qed
qed
qed
qed
qed
next
fix x xa xb
assume 0: "distinct (concat (map (\<lambda>ptr. |h' \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h2)))))"
and 2: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h2). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h'"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h'"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
then show False
using \<open>child \<in> set disc_nodes_old_document_h2\<close> disc_nodes_document_ptr_h'
disc_nodes_document_ptr_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3
old_document_in_heap
apply(auto)[1]
apply(cases "xb = old_document")
proof -
assume a1: "xb = old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a3: "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 child disc_nodes_old_document_h2"
assume a4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a5: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f6: "old_document |\<in>| document_ptr_kinds h'"
using a1 \<open>xb |\<in>| document_ptr_kinds h'\<close> by blast
have f7: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a2 by simp
have "x \<in> set disc_nodes_old_document_h2"
using f6 a3 a1 by (metis (no_types) \<open>type_wf h'\<close> \<open>x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r\<close>
disconnected_nodes_eq_h3 docs_neq get_disconnected_nodes_ok returns_result_eq
returns_result_select_result set_remove1_subset subsetCE)
then have "set |h' \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using f7 f6 a5 a4 \<open>xa |\<in>| object_ptr_kinds h'\<close>
by fastforce
then show ?thesis
using \<open>x \<in> set disc_nodes_old_document_h2\<close> a1 a4 f7 by blast
next
assume a1: "xb \<noteq> old_document"
assume a2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_document_ptr_h3"
assume a3: "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disc_nodes_old_document_h2"
assume a4: "xa |\<in>| object_ptr_kinds h'"
assume a5: "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r child # disc_nodes_document_ptr_h3"
assume a6: "old_document |\<in>| document_ptr_kinds h'"
assume a7: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
assume a8: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
assume a9: "document_ptr_kinds h2 = document_ptr_kinds h'"
assume a10: "\<And>doc_ptr. old_document \<noteq> doc_ptr \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a11: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr \<Longrightarrow>
|h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
assume a12: "(\<Union>x\<in>fset (object_ptr_kinds h'). set |h' \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h'). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
have f13: "\<And>d. d \<notin> set |h' \<turnstile> document_ptr_kinds_M|\<^sub>r \<or> h2 \<turnstile> ok get_disconnected_nodes d"
using a9 \<open>type_wf h2\<close> get_disconnected_nodes_ok
by simp
then have f14: "|h2 \<turnstile> get_disconnected_nodes old_document|\<^sub>r = disc_nodes_old_document_h2"
using a6 a3 by simp
have "x \<notin> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
using a12 a8 a4 \<open>xb |\<in>| document_ptr_kinds h'\<close>
- by (meson UN_I disjoint_iff_not_equal fmember.rep_eq)
+ by (meson UN_I disjoint_iff_not_equal fmember_iff_member_fset)
then have "x = child"
using f13 a11 a10 a7 a5 a2 a1
by (metis (no_types, lifting) select_result_I2 set_ConsD)
then have "child \<notin> set disc_nodes_old_document_h2"
using f14 a12 a8 a6 a4
by (metis \<open>type_wf h'\<close> adopt_node_removes_child assms(1) assms(2) type_wf
get_child_nodes_ok known_ptrs local.known_ptrs_known_ptr object_ptr_kinds_h2_eq3
object_ptr_kinds_h3_eq3 object_ptr_kinds_h_eq3 returns_result_select_result)
then show ?thesis
using \<open>child \<in> set disc_nodes_old_document_h2\<close> by fastforce
qed
qed
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
using \<open>type_wf h'\<close> \<open>CD.a_owner_document_valid h'\<close> CD.heap_is_wellformed_def by blast
have shadow_root_eq_h2: "\<And>ptr' shadow_root_ptr_opt. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have shadow_root_eq_h3: "\<And>ptr' shadow_root_ptr_opt. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h2: "\<And>ptr' tag. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h3: "\<And>ptr' tag. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have document_ptr_kinds_eq_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have document_ptr_kinds_eq_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h3 = element_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have "a_host_shadow_root_rel h' = a_host_shadow_root_rel h3" and
"a_host_shadow_root_rel h3 = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def shadow_root_eq2_h2 shadow_root_eq2_h3
element_ptr_kinds_eq_h2 element_ptr_kinds_eq_h3)
have "parent_child_rel h' = parent_child_rel h3" and "parent_child_rel h3 = parent_child_rel h2"
by(auto simp add: CD.parent_child_rel_def children_eq2_h2 children_eq2_h3
object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3)
have "parent_child_rel h2 \<subseteq> parent_child_rel h"
using h2 parent_opt
proof (induct parent_opt)
case None
then show ?case
by simp
next
case (Some parent)
then
have h2: "h \<turnstile> remove_child parent child \<rightarrow>\<^sub>h h2"
by auto
have child_nodes_eq_h: "\<And>ptr children. parent \<noteq> ptr \<Longrightarrow>
h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads remove_child_writes h2
apply(rule reads_writes_preserved)
apply(auto simp add: remove_child_locs_def)[1]
by (simp add: set_child_nodes_get_child_nodes_different_pointers)
moreover obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using Some local.get_parent_child_dual by blast
ultimately show ?thesis
using object_ptr_kinds_eq_h h2
apply(auto simp add: CD.parent_child_rel_def split: option.splits)[1]
apply(case_tac "parent = a")
apply (metis (no_types, lifting) \<open>type_wf h3\<close> children_eq2_h2 children_eq_h2 known_ptrs
local.get_child_nodes_ok local.known_ptrs_known_ptr local.remove_child_children_subset
object_ptr_kinds_h2_eq3 returns_result_select_result subset_code(1) type_wf)
apply (metis (no_types, lifting) known_ptrs local.get_child_nodes_ok local.known_ptrs_known_ptr
returns_result_select_result select_result_I2 type_wf)
done
qed
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h"
using h2
proof (induct parent_opt)
case None
then show ?case
by simp
next
case (Some parent)
then
have h2: "h \<turnstile> remove_child parent child \<rightarrow>\<^sub>h h2"
by auto
have "\<And>ptr shadow_root. h \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root = h2 \<turnstile> get_shadow_root ptr \<rightarrow>\<^sub>r shadow_root"
using get_shadow_root_reads remove_child_writes h2
apply(rule reads_writes_preserved)
apply(auto simp add: remove_child_locs_def)[1]
by (auto simp add: set_disconnected_nodes_get_shadow_root set_child_nodes_get_shadow_root)
then show ?case
apply(auto simp add: a_host_shadow_root_rel_def)[1]
apply (metis (mono_tags, lifting) Collect_cong \<open>type_wf h2\<close> case_prodE case_prodI
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_host_shadow_root_rel_def local.get_shadow_root_ok
local.a_host_shadow_root_rel_shadow_root returns_result_select_result)
by (metis (no_types, lifting) Collect_cong case_prodE case_prodI local.get_shadow_root_ok
local.a_host_shadow_root_rel_def local.a_host_shadow_root_rel_shadow_root returns_result_select_result type_wf)
qed
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast old_document, cast child)}"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)[1]
using disconnected_nodes_eq2_h2 disc_nodes_old_document_h2 disc_nodes_old_document_h3
using \<open>distinct disc_nodes_old_document_h2\<close>
apply (metis (no_types, lifting) \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close>
case_prodI in_set_remove1 mem_Collect_eq pair_imageI select_result_I2)
using \<open>child \<notin> set (remove1 child disc_nodes_old_document_h2)\<close> disc_nodes_old_document_h3
apply auto[1]
by (metis (no_types, lifting) case_prodI disc_nodes_old_document_h2 disc_nodes_old_document_h3
disconnected_nodes_eq2_h2 in_set_remove1 mem_Collect_eq pair_imageI select_result_I2)
have "a_ptr_disconnected_node_rel h3 \<subseteq> a_ptr_disconnected_node_rel h"
using h2 parent_opt
proof (induct parent_opt)
case None
then show ?case
by(auto simp add: \<open>a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast old_document, cast child)}\<close>)
next
case (Some parent)
then
have h2: "h \<turnstile> remove_child parent child \<rightarrow>\<^sub>h h2"
by auto
then
obtain children_h h'2 disconnected_nodes_h where
children_h: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "child \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h'2: "h \<turnstile> set_disconnected_nodes old_document (child # disconnected_nodes_h) \<rightarrow>\<^sub>h h'2" and
h': "h'2 \<turnstile> set_child_nodes parent (remove1 child children_h) \<rightarrow>\<^sub>h h2"
using old_document
apply(auto simp add: remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure]
pure_returns_heap_eq[rotated, OF get_disconnected_nodes_pure] split: if_splits)[1]
using select_result_I2 by fastforce
have "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h object_ptr_kinds_eq_h2
by(auto simp add: document_ptr_kinds_def)
have disconnected_nodes_eq_h: "\<And>ptr disc_nodes. old_document \<noteq> ptr \<Longrightarrow>
h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes = h2 \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads remove_child_writes h2
apply(rule reads_writes_preserved)
apply(auto simp add: remove_child_locs_def)[1]
using old_document
by (auto simp add:set_child_nodes_get_disconnected_nodes set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then
have foo: "\<And>ptr disc_nodes. old_document \<noteq> ptr \<Longrightarrow>
h \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes ptr \<rightarrow>\<^sub>r disc_nodes"
using disconnected_nodes_eq_h2 by simp
then
have foo2: "\<And>ptr. old_document \<noteq> ptr \<Longrightarrow> |h \<turnstile> get_disconnected_nodes ptr|\<^sub>r =
|h3 \<turnstile> get_disconnected_nodes ptr|\<^sub>r"
by (meson select_result_eq)
have "h'2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using h'2
using local.set_disconnected_nodes_get_disconnected_nodes by blast
have "h2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r child # disconnected_nodes_h"
using get_disconnected_nodes_reads set_child_nodes_writes h'
\<open>h'2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r child # disconnected_nodes_h\<close>
apply(rule reads_writes_separate_forwards)
using local.set_child_nodes_get_disconnected_nodes by blast
then have "h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h"
using h3
using disc_nodes_old_document_h2 disc_nodes_old_document_h3 returns_result_eq
by fastforce
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h"
using \<open>|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h \<turnstile> document_ptr_kinds_M|\<^sub>r\<close>
apply(auto simp add: a_ptr_disconnected_node_rel_def )[1]
apply(case_tac "old_document = aa")
using disconnected_nodes_h \<open>h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h\<close>
using foo2
apply(auto)[1]
using disconnected_nodes_h \<open>h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h\<close>
using foo2
apply(auto)[1]
apply(case_tac "old_document = aa")
using disconnected_nodes_h \<open>h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h\<close>
using foo2
apply(auto)[1]
using disconnected_nodes_h \<open>h3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h\<close>
using foo2
apply(auto)[1]
done
then show ?thesis
by auto
qed
have "acyclic (parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2)"
using local.heap_is_wellformed_def wellformed_h2 by blast
then have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)"
using \<open>a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast old_document, cast child)}\<close>
by(auto simp add: \<open>parent_child_rel h3 = parent_child_rel h2\<close> \<open>a_host_shadow_root_rel h3 = a_host_shadow_root_rel h2\<close> elim!: acyclic_subset)
moreover
have "a_ptr_disconnected_node_rel h' = insert (cast document_ptr, cast child) (a_ptr_disconnected_node_rel h3)"
using disconnected_nodes_eq2_h3[symmetric] disc_nodes_document_ptr_h3 disc_nodes_document_ptr_h' document_ptr_in_heap[unfolded document_ptr_kinds_eq_h2]
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h3[symmetric])[1]
apply(case_tac "document_ptr = aa")
apply(auto)[1]
apply(auto)[1]
apply(case_tac "document_ptr = aa")
apply(auto)[1]
apply(auto)[1]
done
moreover have "(cast child, cast document_ptr) \<notin> (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using \<open>h \<turnstile> get_ancestors_di (cast document_ptr) \<rightarrow>\<^sub>r ancestors\<close>
\<open>cast child \<notin> set ancestors\<close> get_ancestors_di_parent_child_a_host_shadow_root_rel
using assms(1) known_ptrs type_wf by blast
moreover have "(cast child, cast document_ptr) \<notin> (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*"
proof -
have "(parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3 \<union> local.a_ptr_disconnected_node_rel h3) \<subseteq> (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h)"
apply(simp add: \<open>parent_child_rel h3 = parent_child_rel h2\<close> \<open>a_host_shadow_root_rel h3 = a_host_shadow_root_rel h2\<close> \<open>a_host_shadow_root_rel h2 = a_host_shadow_root_rel h\<close>)
using \<open>local.a_ptr_disconnected_node_rel h3 \<subseteq> local.a_ptr_disconnected_node_rel h\<close> \<open>parent_child_rel h2 \<subseteq> parent_child_rel h\<close>
by blast
then show ?thesis
using calculation(3) rtrancl_mono by blast
qed
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by(auto simp add: \<open>parent_child_rel h' = parent_child_rel h3\<close> \<open>a_host_shadow_root_rel h' = a_host_shadow_root_rel h3\<close>)
show "heap_is_wellformed h'"
using \<open>heap_is_wellformed h2\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close>
using \<open>acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def)[1]
by(auto simp add: object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3 shadow_root_ptr_kinds_eq_h2 shadow_root_ptr_kinds_eq_h3 shadow_root_eq_h2
shadow_root_eq_h3 shadow_root_eq2_h2 shadow_root_eq2_h3 tag_name_eq_h2 tag_name_eq_h3 tag_name_eq2_h2
tag_name_eq2_h3)
qed
qed
lemma adopt_node_node_in_disconnected_nodes:
assumes wellformed: "heap_is_wellformed h"
and adopt_node: "h \<turnstile> adopt_node owner_document node_ptr \<rightarrow>\<^sub>h h'"
and "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "node_ptr \<in> set disc_nodes"
proof -
obtain old_document parent_opt h2 where
old_document: "h \<turnstile> get_owner_document (cast node_ptr) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node_ptr \<rightarrow>\<^sub>r parent_opt" and
h2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node_ptr | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h2" and
h': "h2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node_ptr old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node_ptr # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h'"
using assms(2)[unfolded adopt_node_def CD.adopt_node_def]
by(auto elim!: bind_returns_heap_E dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_parent_pure] pure_returns_heap_eq[rotated, OF get_ancestors_di_pure]
split: option.splits if_splits)
show ?thesis
proof (cases "owner_document = old_document")
case True
then show ?thesis
proof (insert parent_opt h2, induct parent_opt)
case None
then have "h = h'"
using h2 h' by(auto)
then show ?case
using in_disconnected_nodes_no_parent assms None old_document by blast
next
case (Some parent)
then show ?case
using remove_child_in_disconnected_nodes known_ptrs True h' assms(3) old_document
by auto
qed
next
case False
then show ?thesis
using assms(3) h' list.set_intros(1) select_result_I2
set_disconnected_nodes_get_disconnected_nodes
apply(auto elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated])[1]
proof -
fix x and h'a and xb
assume a1: "h' \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes"
assume a2: "\<And>h document_ptr disc_nodes h'. h \<turnstile> set_disconnected_nodes document_ptr disc_nodes \<rightarrow>\<^sub>h h' \<Longrightarrow>
h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes"
assume "h'a \<turnstile> set_disconnected_nodes owner_document (node_ptr # xb) \<rightarrow>\<^sub>h h'"
then have "node_ptr # xb = disc_nodes"
using a2 a1 by (meson returns_result_eq)
then show ?thesis
by (meson list.set_intros(1))
qed
qed
qed
end
interpretation i_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes
set_child_nodes_locs remove heap_is_wellformed parent_child_rel
by(auto simp add: l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare i_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.l_adopt_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_adopt_node_wf?: l_adopt_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_owner_document get_parent get_parent_locs remove_child remove_child_locs get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs get_ancestors_di
get_ancestors_di_locs adopt_node adopt_node_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf
get_child_nodes get_child_nodes_locs known_ptrs set_child_nodes set_child_nodes_locs get_host
get_host_locs get_disconnected_document get_disconnected_document_locs remove heap_is_wellformed
parent_child_rel
by(auto simp add: l_adopt_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
interpretation i_adopt_node_wf2?: l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
set_child_nodes set_child_nodes_locs get_shadow_root get_shadow_root_locs set_disconnected_nodes
set_disconnected_nodes_locs get_tag_name get_tag_name_locs get_owner_document get_parent get_parent_locs
remove_child remove_child_locs remove known_ptrs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_host get_host_locs get_disconnected_document get_disconnected_document_locs get_root_node
get_root_node_locs get_ancestors_di get_ancestors_di_locs adopt_node adopt_node_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_adopt_node_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma adopt_node_wf_is_l_adopt_node_wf [instances]:
"l_adopt_node_wf type_wf known_ptr heap_is_wellformed parent_child_rel get_child_nodes
get_disconnected_nodes known_ptrs adopt_node"
apply(auto simp add: l_adopt_node_wf_def l_adopt_node_wf_axioms_def instances)[1]
using adopt_node_preserves_wellformedness apply blast
using adopt_node_removes_child apply blast
using adopt_node_node_in_disconnected_nodes apply blast
using adopt_node_removes_first_child apply blast
using adopt_node_document_in_heap apply blast
done
subsubsection \<open>insert\_before\<close>
locale l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_disconnected_nodes +
l_set_child_nodes_get_shadow_root +
l_set_disconnected_nodes_get_shadow_root +
l_set_child_nodes_get_tag_name +
l_set_disconnected_nodes_get_tag_name +
l_set_disconnected_nodes_get_disconnected_nodes +
l_set_child_nodes_get_disconnected_nodes +
l_set_disconnected_nodes_get_disconnected_nodes_wf +
(* l_set_disconnected_nodes_get_ancestors_si + *)
l_insert_before\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M _ _ _ _ _ _ get_ancestors_di get_ancestors_di_locs +
(* l_get_root_node_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M + *)
l_get_owner_document +
l_adopt_node\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_wf +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_adopt_node_get_shadow_root +
l_get_ancestors_di_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_remove_child_wf2
begin
lemma insert_before_child_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> insert_before ptr node child \<rightarrow>\<^sub>h h'"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain ancestors reference_child owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
reference_child: "h \<turnstile> (if Some node = child then a_next_sibling node else return child) \<rightarrow>\<^sub>r reference_child" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node reference_child \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
obtain old_document parent_opt h'2 (* ancestors *) where
(* "h \<turnstile> get_ancestors_di (cast owner_document) \<rightarrow>\<^sub>r ancestors" and
"cast child \<notin> set ancestors" and *)
old_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
parent_opt: "h \<turnstile> get_parent node \<rightarrow>\<^sub>r parent_opt" and
h'2: "h \<turnstile> (case parent_opt of Some parent \<Rightarrow> remove_child parent node | None \<Rightarrow> return ()) \<rightarrow>\<^sub>h h'2" and
h2': "h'2 \<turnstile> (if owner_document \<noteq> old_document then do {
old_disc_nodes \<leftarrow> get_disconnected_nodes old_document;
set_disconnected_nodes old_document (remove1 node old_disc_nodes);
disc_nodes \<leftarrow> get_disconnected_nodes owner_document;
set_disconnected_nodes owner_document (node # disc_nodes)
} else do {
return ()
}) \<rightarrow>\<^sub>h h2"
using h2
apply(auto simp add: adopt_node_def[unfolded CD.adopt_node_def] elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_ancestors_di_pure])[1]
apply(split if_splits)
by(auto simp add: elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure] pure_returns_heap_eq[rotated, OF get_parent_pure])
have "type_wf h2"
using \<open>type_wf h\<close>
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using adopt_node_types_preserved
by(auto simp add: reflp_def transp_def)
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF insert_node_writes h']
using set_child_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have "object_ptr_kinds h = object_ptr_kinds h2"
using adopt_node_writes h2
apply(rule writes_small_big)
using adopt_node_pointers_preserved
by(auto simp add: reflp_def transp_def)
moreover have "\<dots> = object_ptr_kinds h3"
using set_disconnected_nodes_writes h3
apply(rule writes_small_big)
using set_disconnected_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
moreover have "\<dots> = object_ptr_kinds h'"
using insert_node_writes h'
apply(rule writes_small_big)
using set_child_nodes_pointers_preserved
by(auto simp add: reflp_def transp_def)
ultimately
show "known_ptrs h'"
using \<open>known_ptrs h\<close> known_ptrs_preserved
by blast
have "known_ptrs h2"
using \<open>known_ptrs h\<close> known_ptrs_preserved \<open>object_ptr_kinds h = object_ptr_kinds h2\<close>
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved \<open>object_ptr_kinds h2 = object_ptr_kinds h3\<close>
by blast
have "known_ptr ptr"
by (meson get_owner_document_ptr_in_heap is_OK_returns_result_I \<open>known_ptrs h\<close>
l_known_ptrs.known_ptrs_known_ptr l_known_ptrs_axioms owner_document)
have object_ptr_kinds_M_eq3_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF adopt_node_writes h2])
using adopt_node_pointers_preserved
apply blast
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h: "\<And>ptrs. h \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs )
then have object_ptr_kinds_M_eq2_h: "|h \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h: "|h \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have wellformed_h2: "heap_is_wellformed h2"
using adopt_node_preserves_wellformedness[OF \<open>heap_is_wellformed h\<close> h2] \<open>known_ptrs h\<close> \<open>type_wf h\<close>
.
have object_ptr_kinds_M_eq3_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h3])
unfolding a_remove_child_locs_def
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h2: "\<And>ptrs. h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h2: "|h2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h2: "|h2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h2: "|h2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h2 document_ptr_kinds_M_eq by auto
have object_ptr_kinds_M_eq3_h': "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF insert_node_writes h'])
unfolding a_remove_child_locs_def
using set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h3: "\<And>ptrs. h3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h' \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_M_eq2_h3: "|h3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h' \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
then have node_ptr_kinds_eq2_h3: "|h3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
have document_ptr_kinds_eq2_h3: "|h3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h' \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_M_eq2_h3 document_ptr_kinds_M_eq by auto
have shadow_root_eq_h2: "\<And>ptr' shadow_root. h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root =
h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root"
using get_shadow_root_reads adopt_node_writes h2
apply(rule reads_writes_preserved)
using local.adopt_node_get_shadow_root by blast
have disconnected_nodes_eq_h2: "\<And>doc_ptr disc_nodes. owner_document \<noteq> doc_ptr \<Longrightarrow>
h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h2: "\<And>doc_ptr. doc_ptr \<noteq> owner_document \<Longrightarrow>
|h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_h3: "h3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r remove1 node disconnected_nodes_h2"
using h3 set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
using set_child_nodes_get_disconnected_nodes by fast
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by (auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h3:
"\<And>ptr' children. ptr \<noteq> ptr' \<Longrightarrow> h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using get_child_nodes_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by (auto simp add: set_child_nodes_get_child_nodes_different_pointers)
then have children_eq2_h3: "\<And>ptr'. ptr \<noteq> ptr' \<Longrightarrow> |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
obtain children_h3 where children_h3: "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children_h3"
using h' a_insert_node_def by auto
have children_h': "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r insert_before_list node reference_child children_h3"
using h' \<open>type_wf h3\<close> \<open>known_ptr ptr\<close>
by(auto simp add: a_insert_node_def elim!: bind_returns_heap_E2
dest!: set_child_nodes_get_child_nodes returns_result_eq[OF children_h3])
have shadow_root_eq_h: "\<And>ptr' shadow_root_ptr_opt. h \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads adopt_node_writes h2
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def CD.adopt_node_locs_def CD.remove_child_locs_def
set_child_nodes_get_shadow_root set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h: "\<And>ptr'. |h \<turnstile> get_shadow_root ptr'|\<^sub>r = |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have shadow_root_eq_h2: "\<And>ptr' shadow_root_ptr_opt. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have shadow_root_eq_h3: "\<And>ptr' shadow_root_ptr_opt. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt =
h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r shadow_root_ptr_opt"
using get_shadow_root_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_shadow_root
set_disconnected_nodes_get_shadow_root)
then
have shadow_root_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h2: "\<And>ptr' tag. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads set_disconnected_nodes_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have tag_name_eq_h3: "\<And>ptr' tag. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag = h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r tag"
using get_tag_name_reads insert_node_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: adopt_node_locs_def remove_child_locs_def set_child_nodes_get_tag_name
set_disconnected_nodes_get_tag_name)
then
have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
by (meson select_result_eq)
have object_ptr_kinds_eq_hx: "object_ptr_kinds h = object_ptr_kinds h'2"
using h'2 apply(simp split: option.splits)
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF CD.remove_child_writes])
using CD.remove_child_pointers_preserved
by (auto simp add: reflp_def transp_def)
have document_ptr_kinds_eq_hx: "document_ptr_kinds h = document_ptr_kinds h'2"
using object_ptr_kinds_eq_hx
by(auto simp add: document_ptr_kinds_def document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_hx: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h'2"
using object_ptr_kinds_eq_hx
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_hx: "element_ptr_kinds h = element_ptr_kinds h'2"
using object_ptr_kinds_eq_hx
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have object_ptr_kinds_eq_h: "object_ptr_kinds h = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF adopt_node_writes h2])
unfolding adopt_node_locs_def CD.adopt_node_locs_def CD.remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have document_ptr_kinds_eq_h: "document_ptr_kinds h = document_ptr_kinds h2"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h = shadow_root_ptr_kinds h2"
using object_ptr_kinds_eq_h
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h = element_ptr_kinds h2"
using object_ptr_kinds_eq_h
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h2 = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF set_disconnected_nodes_writes h3])
unfolding adopt_node_locs_def remove_child_locs_def
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have document_ptr_kinds_eq_h2: "document_ptr_kinds h2 = document_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: document_ptr_kinds_def document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h2 = element_ptr_kinds h3"
using object_ptr_kinds_eq_h2
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h3 = object_ptr_kinds h'"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'", OF insert_node_writes h'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def split: if_splits)
have document_ptr_kinds_eq_h3: "document_ptr_kinds h3 = document_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: document_ptr_kinds_def document_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def document_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h3 = element_ptr_kinds h'"
using object_ptr_kinds_eq_h3
by(auto simp add: element_ptr_kinds_def node_ptr_kinds_def)
have wellformed_h'2: "heap_is_wellformed h'2"
using h'2 remove_child_heap_is_wellformed_preserved assms
by (metis (no_types, lifting) assms(1) option.case_eq_if pure_returns_heap_eq return_pure)
have "known_ptrs h'2"
using \<open>known_ptrs h\<close> known_ptrs_preserved \<open>object_ptr_kinds h = object_ptr_kinds h'2\<close>
by blast
have "type_wf h'2"
using \<open>type_wf h\<close> h'2
apply(auto split: option.splits)[1]
apply(drule writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF CD.remove_child_writes])
using CD.remove_child_types_preserved
by(auto simp add: reflp_def transp_def )
have ptr_in_heap: "ptr |\<in>| object_ptr_kinds h3"
using children_h3 get_child_nodes_ptr_in_heap by blast
have node_in_heap: "node |\<in>| node_ptr_kinds h"
using h2 adopt_node_child_in_heap by fast
have child_not_in_any_children: "\<And>p children. h2 \<turnstile> get_child_nodes p \<rightarrow>\<^sub>r children \<Longrightarrow> node \<notin> set children"
using \<open>heap_is_wellformed h\<close> h2 adopt_node_removes_child \<open>type_wf h\<close> \<open>known_ptrs h\<close> by auto
have "node \<in> set disconnected_nodes_h2"
using disconnected_nodes_h2 h2 adopt_node_node_in_disconnected_nodes assms(1) \<open>type_wf h\<close> \<open>known_ptrs h\<close> by blast
have node_not_in_disconnected_nodes: "\<And>d. d |\<in>| document_ptr_kinds h3 \<Longrightarrow> node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof -
fix d
assume "d |\<in>| document_ptr_kinds h3"
show "node \<notin> set |h3 \<turnstile> get_disconnected_nodes d|\<^sub>r"
proof (cases "d = owner_document")
case True
then show ?thesis
using disconnected_nodes_h2 wellformed_h2 h3 remove_from_disconnected_nodes_removes wellformed_h2
\<open>d |\<in>| document_ptr_kinds h3\<close> disconnected_nodes_h3
by fastforce
next
case False
then have "set |h2 \<turnstile> get_disconnected_nodes d|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes owner_document|\<^sub>r = {}"
using distinct_concat_map_E(1) wellformed_h2
by (metis (no_types, lifting) \<open>d |\<in>| document_ptr_kinds h3\<close> \<open>type_wf h2\<close> disconnected_nodes_h2
document_ptr_kinds_M_def document_ptr_kinds_eq2_h2 l_ptr_kinds_M.ptr_kinds_ptr_kinds_M
local.get_disconnected_nodes_ok local.heap_is_wellformed_one_disc_parent returns_result_select_result
select_result_I2)
then show ?thesis
using disconnected_nodes_eq2_h2[OF False] \<open>node \<in> set disconnected_nodes_h2\<close> disconnected_nodes_h2 by fastforce
qed
qed
have "cast node \<noteq> ptr"
using ancestors node_not_in_ancestors get_ancestors_ptr
by fast
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h shadow_root_eq2_h)
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq2_h2)
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3 shadow_root_eq2_h3)
have "parent_child_rel h2 \<subseteq> parent_child_rel h"
proof -
have "parent_child_rel h'2 \<subseteq> parent_child_rel h"
using h'2 parent_opt
proof (induct parent_opt)
case None
then show ?case
by simp
next
case (Some parent)
then
have h'2: "h \<turnstile> remove_child parent node \<rightarrow>\<^sub>h h'2"
by auto
then
have "parent |\<in>| object_ptr_kinds h"
using CD.remove_child_ptr_in_heap
by blast
have child_nodes_eq_h: "\<And>ptr children. parent \<noteq> ptr \<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children =
h'2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads CD.remove_child_writes h'2
apply(rule reads_writes_preserved)
apply(auto simp add: CD.remove_child_locs_def)[1]
by (simp add: set_child_nodes_get_child_nodes_different_pointers)
moreover obtain children where children: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children"
using Some local.get_parent_child_dual by blast
moreover obtain children_h'2 where children_h'2: "h'2 \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children_h'2"
using object_ptr_kinds_eq_hx calculation(2) \<open>parent |\<in>| object_ptr_kinds h\<close> get_child_nodes_ok
by (metis \<open>type_wf h'2\<close> assms(3) is_OK_returns_result_E local.known_ptrs_known_ptr)
ultimately show ?thesis
using object_ptr_kinds_eq_h h2
apply(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_hx split: option.splits)[1]
apply(case_tac "parent = a")
using CD.remove_child_children_subset
apply (metis (no_types, lifting) assms(2) assms(3) contra_subsetD h'2 select_result_I2)
by (metis select_result_eq)
qed
moreover have "parent_child_rel h2 = parent_child_rel h'2"
proof(cases "owner_document = old_document")
case True
then show ?thesis
using h2' by simp
next
case False
then obtain h'3 old_disc_nodes disc_nodes_document_ptr_h'3 where
docs_neq: "owner_document \<noteq> old_document" and
old_disc_nodes: "h'2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h'3: "h'2 \<turnstile> set_disconnected_nodes old_document (remove1 node old_disc_nodes) \<rightarrow>\<^sub>h h'3" and
disc_nodes_document_ptr_h3: "h'3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes_document_ptr_h'3" and
h2': "h'3 \<turnstile> set_disconnected_nodes owner_document (node # disc_nodes_document_ptr_h'3) \<rightarrow>\<^sub>h h2"
using h2'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h'2_eq3: "object_ptr_kinds h'2 = object_ptr_kinds h'3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h'2: "\<And>ptrs. h'2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h'3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h'2: "|h'2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h'2: "|h'2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h'2: "node_ptr_kinds h'2 = node_ptr_kinds h'3"
by auto
have document_ptr_kinds_eq2_h'2: "|h'2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h'2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h'2: "document_ptr_kinds h'2 = document_ptr_kinds h'3"
using object_ptr_kinds_eq_h'2 document_ptr_kinds_M_eq by auto
have children_eq_h'2: "\<And>ptr children. h'2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children = h'3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h'3
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h'2: "\<And>ptr. |h'2 \<turnstile> get_child_nodes ptr|\<^sub>r = |h'3 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_h'3_eq3: "object_ptr_kinds h'3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h2. object_ptr_kinds h = object_ptr_kinds h2",
OF set_disconnected_nodes_writes h2'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h'3: "\<And>ptrs. h'3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h'3: "|h'3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h'3: "|h'3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h'3: "node_ptr_kinds h'3 = node_ptr_kinds h2"
by auto
have document_ptr_kinds_eq2_h'3: "|h'3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h'3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h'3: "document_ptr_kinds h'3 = document_ptr_kinds h2"
using object_ptr_kinds_eq_h'3 document_ptr_kinds_M_eq by auto
have children_eq_h'3: "\<And>ptr children. h'3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children =
h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children"
using get_child_nodes_reads set_disconnected_nodes_writes h2'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h'3: "\<And>ptr. |h'3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
show ?thesis
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_h'2_eq3 object_ptr_kinds_h'3_eq3
children_eq2_h'3 children_eq2_h'2)
qed
ultimately
show ?thesis
by simp
qed
have "parent_child_rel h2 = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
have "parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))"
using children_h3 children_h' ptr_in_heap
apply(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h' children_eq2_h3
insert_before_list_node_in_set)[1]
apply (metis (no_types, lifting) children_eq2_h3 insert_before_list_in_set select_result_I2)
by (metis (no_types, lifting) children_eq2_h3 imageI insert_before_list_in_set select_result_I2)
have "a_ptr_disconnected_node_rel h3 \<subseteq> a_ptr_disconnected_node_rel h"
proof -
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast owner_document, cast node)}"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2)[1]
apply(case_tac "aa = owner_document")
using disconnected_nodes_h2 disconnected_nodes_h3 notin_set_remove1 apply fastforce
using disconnected_nodes_eq2_h2 apply auto[1]
using node_not_in_disconnected_nodes apply blast
apply(case_tac "aa = owner_document")
using disconnected_nodes_h2 disconnected_nodes_h3 notin_set_remove1 apply fastforce
using disconnected_nodes_eq2_h2 apply auto[1]
apply(case_tac "aa = owner_document")
using disconnected_nodes_h2 disconnected_nodes_h3 notin_set_remove1 apply fastforce
using disconnected_nodes_eq2_h2 apply auto[1]
done
then have "a_ptr_disconnected_node_rel h'2 \<subseteq> a_ptr_disconnected_node_rel h \<union> {(cast old_document, cast node)}"
using h'2 parent_opt
proof (induct parent_opt)
case None
then show ?case
by auto
next
case (Some parent)
then
have h'2: "h \<turnstile> remove_child parent node \<rightarrow>\<^sub>h h'2"
by auto
then
have "parent |\<in>| object_ptr_kinds h"
using CD.remove_child_ptr_in_heap
by blast
obtain children_h h''2 disconnected_nodes_h where
owner_document: "h \<turnstile> get_owner_document (cast node) \<rightarrow>\<^sub>r old_document" and
children_h: "h \<turnstile> get_child_nodes parent \<rightarrow>\<^sub>r children_h" and
child_in_children_h: "node \<in> set children_h" and
disconnected_nodes_h: "h \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r disconnected_nodes_h" and
h''2: "h \<turnstile> set_disconnected_nodes old_document (node # disconnected_nodes_h) \<rightarrow>\<^sub>h h''2" and
h'2: "h''2 \<turnstile> set_child_nodes parent (remove1 node children_h) \<rightarrow>\<^sub>h h'2"
using h'2 old_document
apply(auto simp add: CD.remove_child_def elim!: bind_returns_heap_E
dest!: pure_returns_heap_eq[rotated, OF get_owner_document_pure]
pure_returns_heap_eq[rotated, OF get_child_nodes_pure] split: if_splits)[1]
using pure_returns_heap_eq returns_result_eq by fastforce
have disconnected_nodes_eq: "\<And>ptr' disc_nodes. ptr' \<noteq> old_document \<Longrightarrow>
h \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h''2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_disconnected_nodes_writes h''2
apply(rule reads_writes_preserved)
by (metis local.set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then
have disconnected_nodes_eq2: "\<And>ptr'. ptr' \<noteq> old_document \<Longrightarrow>
|h \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h''2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
have "h''2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r node # disconnected_nodes_h"
using h''2 local.set_disconnected_nodes_get_disconnected_nodes
by blast
have disconnected_nodes_eq_h2:
"\<And>ptr' disc_nodes. h''2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h'2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_child_nodes_writes h'2
apply(rule reads_writes_preserved)
by (metis local.set_child_nodes_get_disconnected_nodes)
then
have disconnected_nodes_eq2_h2:
"\<And>ptr'. |h''2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h'2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
show ?case
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_hx
\<open>\<And>ptr'. |h''2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h'2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r\<close>[symmetric])[1]
apply(case_tac "aa = old_document")
using disconnected_nodes_h
\<open>h''2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r node # disconnected_nodes_h\<close>
apply(auto)[1]
apply(auto dest!: disconnected_nodes_eq2)[1]
apply(case_tac "aa = old_document")
using disconnected_nodes_h
\<open>h''2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r node # disconnected_nodes_h\<close>
apply(auto)[1]
apply(auto dest!: disconnected_nodes_eq2)[1]
done
qed
show ?thesis
proof(cases "owner_document = old_document")
case True
then have "a_ptr_disconnected_node_rel h'2 = a_ptr_disconnected_node_rel h2"
using h2'
by(auto simp add: a_ptr_disconnected_node_rel_def)
then
show ?thesis
using \<open>a_ptr_disconnected_node_rel h3 =
a_ptr_disconnected_node_rel h2 - {(cast owner_document, cast node)}\<close>
using True \<open>local.a_ptr_disconnected_node_rel h'2 \<subseteq> local.a_ptr_disconnected_node_rel h \<union>
{(cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r old_document, cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node)}\<close> by auto
next
case False
then obtain h'3 old_disc_nodes disc_nodes_document_ptr_h'3 where
docs_neq: "owner_document \<noteq> old_document" and
old_disc_nodes: "h'2 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r old_disc_nodes" and
h'3: "h'2 \<turnstile> set_disconnected_nodes old_document (remove1 node old_disc_nodes) \<rightarrow>\<^sub>h h'3" and
disc_nodes_document_ptr_h3: "h'3 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disc_nodes_document_ptr_h'3" and
h2': "h'3 \<turnstile> set_disconnected_nodes owner_document (node # disc_nodes_document_ptr_h'3) \<rightarrow>\<^sub>h h2"
using h2'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated] )
have object_ptr_kinds_h'2_eq3: "object_ptr_kinds h'2 = object_ptr_kinds h'3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h = object_ptr_kinds h'",
OF set_disconnected_nodes_writes h'3])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h'2:
"\<And>ptrs. h'2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h'3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h'2: "|h'2 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h'2: "|h'2 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h'2: "node_ptr_kinds h'2 = node_ptr_kinds h'3"
by auto
have document_ptr_kinds_eq2_h'2: "|h'2 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h'3 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h'2 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h'2: "document_ptr_kinds h'2 = document_ptr_kinds h'3"
using object_ptr_kinds_eq_h'2 document_ptr_kinds_M_eq by auto
have disconnected_nodes_eq: "\<And>ptr' disc_nodes. ptr' \<noteq> old_document \<Longrightarrow>
h'2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h'3 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_disconnected_nodes_writes h'3
apply(rule reads_writes_preserved)
by (metis local.set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then
have disconnected_nodes_eq2: "\<And>ptr'. ptr' \<noteq> old_document \<Longrightarrow>
|h'2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h'3 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
have "h'3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r (remove1 node old_disc_nodes)"
using h'3 local.set_disconnected_nodes_get_disconnected_nodes
by blast
have object_ptr_kinds_h'3_eq3: "object_ptr_kinds h'3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h2. object_ptr_kinds h = object_ptr_kinds h2",
OF set_disconnected_nodes_writes h2'])
using set_disconnected_nodes_pointers_preserved set_child_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have object_ptr_kinds_M_eq_h'3: "\<And>ptrs. h'3 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs = h2 \<turnstile> object_ptr_kinds_M \<rightarrow>\<^sub>r ptrs"
by(simp add: object_ptr_kinds_M_defs)
then have object_ptr_kinds_eq_h'3: "|h'3 \<turnstile> object_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> object_ptr_kinds_M|\<^sub>r"
by(simp)
then have node_ptr_kinds_eq_h'3: "|h'3 \<turnstile> node_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_ptr_kinds_M_eq by blast
then have node_ptr_kinds_eq3_h'3: "node_ptr_kinds h'3 = node_ptr_kinds h2"
by auto
have document_ptr_kinds_eq2_h'3: "|h'3 \<turnstile> document_ptr_kinds_M|\<^sub>r = |h2 \<turnstile> document_ptr_kinds_M|\<^sub>r"
using object_ptr_kinds_eq_h'3 document_ptr_kinds_M_eq by auto
then have document_ptr_kinds_eq3_h'3: "document_ptr_kinds h'3 = document_ptr_kinds h2"
using object_ptr_kinds_eq_h'3 document_ptr_kinds_M_eq by auto
have disc_nodes_eq_h'3:
"\<And>ptr disc_nodes. h'3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r disc_nodes = h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r disc_nodes"
using get_child_nodes_reads set_disconnected_nodes_writes h2'
apply(rule reads_writes_preserved)
by (simp add: set_disconnected_nodes_get_child_nodes)
then have disc_nodes_eq2_h'3: "\<And>ptr. |h'3 \<turnstile> get_child_nodes ptr|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq: "\<And>ptr' disc_nodes. ptr' \<noteq> owner_document \<Longrightarrow>
h'3 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes = h2 \<turnstile> get_disconnected_nodes ptr' \<rightarrow>\<^sub>r disc_nodes"
using local.get_disconnected_nodes_reads set_disconnected_nodes_writes h2'
apply(rule reads_writes_preserved)
by (metis local.set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then
have disconnected_nodes_eq2': "\<And>ptr'. ptr' \<noteq> owner_document \<Longrightarrow>
|h'3 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes ptr'|\<^sub>r"
by (meson select_result_eq)
have "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r (node # disc_nodes_document_ptr_h'3)"
using h2' local.set_disconnected_nodes_get_disconnected_nodes
by blast
have "a_ptr_disconnected_node_rel h'3 = a_ptr_disconnected_node_rel h'2 - {(cast old_document, cast node)}"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq2_h'2[simplified])[1]
apply(case_tac "aa = old_document")
using \<open>h'3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r (remove1 node old_disc_nodes)\<close>
notin_set_remove1 old_disc_nodes
apply fastforce
apply(auto dest!: disconnected_nodes_eq2)[1]
using \<open>h'3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r remove1 node old_disc_nodes\<close> h'3
local.remove_from_disconnected_nodes_removes old_disc_nodes wellformed_h'2
apply auto[1]
defer
apply(case_tac "aa = old_document")
using \<open>h'3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r (remove1 node old_disc_nodes)\<close>
notin_set_remove1 old_disc_nodes
apply fastforce
apply(auto dest!: disconnected_nodes_eq2)[1]
apply(case_tac "aa = old_document")
using \<open>h'3 \<turnstile> get_disconnected_nodes old_document \<rightarrow>\<^sub>r (remove1 node old_disc_nodes)\<close>
notin_set_remove1 old_disc_nodes
apply fastforce
apply(auto dest!: disconnected_nodes_eq2)[1]
done
moreover
have "a_ptr_disconnected_node_rel h2 = a_ptr_disconnected_node_rel h'3 \<union>
{(cast owner_document, cast node)}"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq2_h'3[simplified])[1]
apply(case_tac "aa = owner_document")
apply(simp)
apply(auto dest!: disconnected_nodes_eq2')[1]
apply(case_tac "aa = owner_document")
using \<open>h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r node # disc_nodes_document_ptr_h'3\<close>
disc_nodes_document_ptr_h3 apply auto[1]
apply(auto dest!: disconnected_nodes_eq2')[1]
using \<open>node \<in> set disconnected_nodes_h2\<close> disconnected_nodes_h2 local.a_ptr_disconnected_node_rel_def
local.a_ptr_disconnected_node_rel_disconnected_node apply blast
defer
apply(case_tac "aa = owner_document")
using \<open>h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r node # disc_nodes_document_ptr_h'3\<close>
disc_nodes_document_ptr_h3 apply auto[1]
apply(auto dest!: disconnected_nodes_eq2')[1]
done
ultimately show ?thesis
using \<open>a_ptr_disconnected_node_rel h3 =
a_ptr_disconnected_node_rel h2 - {(cast owner_document, cast node)}\<close>
using \<open>a_ptr_disconnected_node_rel h'2 \<subseteq>
a_ptr_disconnected_node_rel h \<union> {(cast old_document, cast node)}\<close>
by blast
qed
qed
have "(cast node, ptr) \<notin> (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)\<^sup>*"
using h2
apply(auto simp add: adopt_node_def elim!: bind_returns_heap_E2 split: if_splits)[1]
using ancestors assms(1) assms(2) assms(3) local.get_ancestors_di_parent_child_a_host_shadow_root_rel node_not_in_ancestors
by blast
then
have "(cast node, ptr) \<notin> (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*"
apply(simp add: \<open>a_host_shadow_root_rel h = a_host_shadow_root_rel h2\<close> \<open>a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3\<close>)
apply(simp add: \<open>parent_child_rel h2 = parent_child_rel h3\<close>[symmetric])
using \<open>parent_child_rel h2 \<subseteq> parent_child_rel h\<close> \<open>a_ptr_disconnected_node_rel h3 \<subseteq> a_ptr_disconnected_node_rel h\<close>
by (smt Un_assoc in_rtrancl_UnI sup.orderE sup_left_commute)
have "CD.a_acyclic_heap h'"
proof -
have "acyclic (parent_child_rel h2)"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
then have "acyclic (parent_child_rel h3)"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_M_eq3_h2 children_eq2_h2)
moreover have "cast node \<notin> {x. (x, ptr) \<in> (parent_child_rel h3)\<^sup>*}"
by (meson \<open>(cast\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r node, ptr) \<notin> (parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3 \<union>
local.a_ptr_disconnected_node_rel h3)\<^sup>*\<close> in_rtrancl_UnI mem_Collect_eq)
ultimately show ?thesis
using \<open>parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))\<close>
by(auto simp add: CD.acyclic_heap_def)
qed
moreover have "CD.a_all_ptrs_in_heap h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
have "CD.a_all_ptrs_in_heap h'"
proof -
have "CD.a_all_ptrs_in_heap h3"
using \<open>CD.a_all_ptrs_in_heap h2\<close>
apply(auto simp add: CD.a_all_ptrs_in_heap_def object_ptr_kinds_M_eq2_h2 node_ptr_kinds_eq2_h2
children_eq_h2)[1]
apply (metis \<open>known_ptrs h3\<close> \<open>type_wf h3\<close> children_eq_h2
l_heap_is_wellformed.heap_is_wellformed_children_in_heap local.get_child_nodes_ok
local.known_ptrs_known_ptr local.l_heap_is_wellformed_axioms node_ptr_kinds_commutes
object_ptr_kinds_eq_h2 returns_result_select_result wellformed_h2)
by (metis (mono_tags, opaque_lifting) disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 document_ptr_kinds_eq_h2 finite_set_in node_ptr_kinds_commutes
object_ptr_kinds_eq_h2 select_result_I2 set_remove1_subset subsetD)
have "set children_h3 \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using children_h3 \<open>CD.a_all_ptrs_in_heap h3\<close>
apply(auto simp add: CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq2_h3)[1]
using children_eq_h2 local.heap_is_wellformed_children_in_heap node_ptr_kinds_eq2_h2
node_ptr_kinds_eq2_h3 wellformed_h2 by auto
then have "set (insert_before_list node reference_child children_h3) \<subseteq> set |h' \<turnstile> node_ptr_kinds_M|\<^sub>r"
using node_in_heap
apply(auto simp add: node_ptr_kinds_eq2_h node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3)[1]
by (metis (no_types, opaque_lifting) contra_subsetD finite_set_in insert_before_list_in_set
node_ptr_kinds_commutes object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h' object_ptr_kinds_M_eq3_h2)
then show ?thesis
using \<open>CD.a_all_ptrs_in_heap h3\<close>
apply(auto simp add: object_ptr_kinds_M_eq3_h' CD.a_all_ptrs_in_heap_def node_ptr_kinds_def
node_ptr_kinds_eq2_h3 disconnected_nodes_eq_h3)[1]
apply (metis (no_types, lifting) children_eq2_h3 children_h' finite_set_in select_result_I2 subsetD)
by (metis (no_types, lifting) disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3 in_mono notin_fset)
qed
moreover have "CD.a_distinct_lists h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def )
then have "CD.a_distinct_lists h3"
proof(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_M_eq2_h2 document_ptr_kinds_eq2_h2
children_eq2_h2 intro!: distinct_concat_map_I)
fix x
assume 1: "x |\<in>| document_ptr_kinds h3"
and 2: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
show "distinct |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
using distinct_concat_map_E(2)[OF 2] select_result_I2[OF disconnected_nodes_h3]
disconnected_nodes_eq2_h2 select_result_I2[OF disconnected_nodes_h2] 1
- by (metis (full_types) distinct_remove1 finite_fset fmember.rep_eq set_sorted_list_of_set)
+ by (metis (full_types) distinct_remove1 finite_fset fmember_iff_member_fset set_sorted_list_of_set)
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>document_ptr. |h2 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and 2: "x |\<in>| document_ptr_kinds h3"
and 3: "y |\<in>| document_ptr_kinds h3"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r"
and 6: "xa \<in> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r"
show False
proof (cases "x = owner_document")
case True
then have "y \<noteq> owner_document"
using 4 by simp
show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>y \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
proof (cases "y = owner_document")
case True
then show ?thesis
using distinct_concat_map_E(1)[OF 1]
using 2 3 4 5 6 select_result_I2[OF disconnected_nodes_h3] select_result_I2[OF disconnected_nodes_h2]
apply(auto simp add: True disconnected_nodes_eq2_h2[OF \<open>x \<noteq> owner_document\<close>])[1]
by (metis (no_types, opaque_lifting) disconnected_nodes_eq2_h2 disjoint_iff_not_equal notin_set_remove1)
next
case False
then show ?thesis
using distinct_concat_map_E(1)[OF 1, simplified, OF 2 3 4] 5 6
using disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3
- disjoint_iff_not_equal finite_fset fmember.rep_eq notin_set_remove1 select_result_I2
+ disjoint_iff_not_equal finite_fset fmember_iff_member_fset notin_set_remove1 select_result_I2
set_sorted_list_of_set
by (metis (no_types, lifting))
qed
qed
next
fix x xa xb
assume 1: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h3 \<turnstile> get_child_nodes x|\<^sub>r) \<inter>
(\<Union>x\<in>fset (document_ptr_kinds h3). set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 2: "xa |\<in>| object_ptr_kinds h3"
and 3: "x \<in> set |h3 \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h3"
and 5: "x \<in> set |h3 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 4
by (metis \<open>type_wf h2\<close> children_eq2_h2 document_ptr_kinds_commutes \<open>known_ptrs h\<close>
local.get_child_nodes_ok local.get_disconnected_nodes_ok local.heap_is_wellformed_children_disc_nodes_different
local.known_ptrs_known_ptr object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h2 returns_result_select_result wellformed_h2)
show False
proof (cases "xb = owner_document")
case True
then show ?thesis
using select_result_I2[OF disconnected_nodes_h3,folded select_result_I2[OF disconnected_nodes_h2]]
by (metis (no_types, lifting) "3" "5" "6" disjoint_iff_not_equal notin_set_remove1)
next
case False
show ?thesis
using 2 3 4 5 6 unfolding disconnected_nodes_eq2_h2[OF False] by auto
qed
qed
then have "CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def document_ptr_kinds_eq2_h3 object_ptr_kinds_M_eq2_h3
disconnected_nodes_eq2_h3 intro!: distinct_concat_map_I)
fix x
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h')))))" and
2: "x |\<in>| object_ptr_kinds h'"
have 3: "\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> distinct |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using 1 by (auto elim: distinct_concat_map_E)
show "distinct |h' \<turnstile> get_child_nodes x|\<^sub>r"
proof(cases "ptr = x")
case True
show ?thesis
using 3[OF 2] children_h3 children_h'
by(auto simp add: True insert_before_list_distinct dest: child_not_in_any_children[unfolded children_eq_h2])
next
case False
show ?thesis
using children_eq2_h3[OF False] 3[OF 2] by auto
qed
next
fix x y xa
assume 1: "distinct (concat (map (\<lambda>ptr. |h3 \<turnstile> get_child_nodes ptr|\<^sub>r) (sorted_list_of_set (fset (object_ptr_kinds h')))))"
and 2: "x |\<in>| object_ptr_kinds h'"
and 3: "y |\<in>| object_ptr_kinds h'"
and 4: "x \<noteq> y"
and 5: "xa \<in> set |h' \<turnstile> get_child_nodes x|\<^sub>r"
and 6: "xa \<in> set |h' \<turnstile> get_child_nodes y|\<^sub>r"
have 7:"set |h3 \<turnstile> get_child_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_child_nodes y|\<^sub>r = {}"
using distinct_concat_map_E(1)[OF 1] 2 3 4 by auto
show False
proof (cases "ptr = x")
case True
then have "ptr \<noteq> y"
using 4 by simp
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> y\<close>])[1]
by (metis (no_types, opaque_lifting) "3" "7" \<open>type_wf h3\<close> children_eq2_h3 disjoint_iff_not_equal
get_child_nodes_ok insert_before_list_in_set \<open>known_ptrs h\<close> local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h object_ptr_kinds_M_eq3_h' object_ptr_kinds_M_eq3_h2
returns_result_select_result select_result_I2)
next
case False
then show ?thesis
proof (cases "ptr = y")
case True
then show ?thesis
using children_h3 children_h' child_not_in_any_children[unfolded children_eq_h2] 5 6
apply(auto simp add: True children_eq2_h3[OF \<open>ptr \<noteq> x\<close>])[1]
by (metis (no_types, opaque_lifting) "2" "4" "7" IntI \<open>known_ptrs h3\<close> \<open>type_wf h'\<close>
children_eq_h3 empty_iff insert_before_list_in_set local.get_child_nodes_ok local.known_ptrs_known_ptr
object_ptr_kinds_M_eq3_h' returns_result_select_result select_result_I2)
next
case False
then show ?thesis
using children_eq2_h3[OF \<open>ptr \<noteq> x\<close>] children_eq2_h3[OF \<open>ptr \<noteq> y\<close>] 5 6 7 by auto
qed
qed
next
fix x xa xb
assume 1: " (\<Union>x\<in>fset (object_ptr_kinds h'). set |h3 \<turnstile> get_child_nodes x|\<^sub>r) \<inter> (\<Union>x\<in>fset (document_ptr_kinds h'). set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r) = {} "
and 2: "xa |\<in>| object_ptr_kinds h'"
and 3: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 4: "xb |\<in>| document_ptr_kinds h'"
and 5: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
have 6: "set |h3 \<turnstile> get_child_nodes xa|\<^sub>r \<inter> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r = {}"
using 1 2 3 4 5
proof -
have "\<forall>h d. \<not> type_wf h \<or> d |\<notin>| document_ptr_kinds h \<or> h \<turnstile> ok get_disconnected_nodes d"
using local.get_disconnected_nodes_ok by satx
then have "h' \<turnstile> ok get_disconnected_nodes xb"
using "4" \<open>type_wf h'\<close> by fastforce
then have f1: "h3 \<turnstile> get_disconnected_nodes xb \<rightarrow>\<^sub>r |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
by (simp add: disconnected_nodes_eq_h3)
have "xa |\<in>| object_ptr_kinds h3"
using "2" object_ptr_kinds_M_eq3_h' by blast
then show ?thesis
using f1 \<open>local.CD.a_distinct_lists h3\<close> CD.distinct_lists_no_parent by fastforce
qed
show False
proof (cases "ptr = xa")
case True
show ?thesis
using 6 node_not_in_disconnected_nodes 3 4 5 select_result_I2[OF children_h']
select_result_I2[OF children_h3] True disconnected_nodes_eq2_h3
by (metis (no_types, lifting) "2" DocumentMonad.ptr_kinds_ptr_kinds_M \<open>CD.a_distinct_lists h3\<close>
\<open>type_wf h'\<close> disconnected_nodes_eq_h3 CD.distinct_lists_no_parent document_ptr_kinds_eq2_h3
get_disconnected_nodes_ok insert_before_list_in_set object_ptr_kinds_M_eq3_h' returns_result_select_result)
next
case False
then show ?thesis
using 1 2 3 4 5 children_eq2_h3[OF False] by fastforce
qed
qed
moreover have "CD.a_owner_document_valid h2"
using wellformed_h2 by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def object_ptr_kinds_M_eq2_h2 object_ptr_kinds_M_eq2_h3
node_ptr_kinds_eq2_h2 node_ptr_kinds_eq2_h3 document_ptr_kinds_eq2_h2 document_ptr_kinds_eq2_h3 children_eq2_h2 )[1]
apply(auto simp add: document_ptr_kinds_eq2_h2[simplified] document_ptr_kinds_eq2_h3[simplified]
object_ptr_kinds_M_eq2_h2[simplified] object_ptr_kinds_M_eq2_h3[simplified] node_ptr_kinds_eq2_h2[simplified]
node_ptr_kinds_eq2_h3[simplified])[1]
apply(auto simp add: disconnected_nodes_eq2_h3[symmetric])[1]
by (smt Core_DOM_Functions.i_insert_before.insert_before_list_in_set children_eq2_h3 children_h'
children_h3 disconnected_nodes_eq2_h2 disconnected_nodes_h2 disconnected_nodes_h3 finite_set_in in_set_remove1
object_ptr_kinds_eq_h3 ptr_in_heap select_result_I2)
ultimately have "heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'"
by (simp add: CD.heap_is_wellformed_def)
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast owner_document, cast node)}"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)[1]
apply(case_tac "aa = owner_document")
apply (metis (no_types, lifting) case_prodI disconnected_nodes_h2 disconnected_nodes_h3
in_set_remove1 mem_Collect_eq node_not_in_disconnected_nodes pair_imageI select_result_I2)
using disconnected_nodes_eq2_h2 apply auto[1]
using node_not_in_disconnected_nodes apply blast
by (metis (no_types, lifting) case_prodI disconnected_nodes_eq2_h2 disconnected_nodes_h2
disconnected_nodes_h3 in_set_remove1 mem_Collect_eq pair_imageI select_result_I2)
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h'"
by(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h3 disconnected_nodes_eq2_h3)
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)"
using \<open>heap_is_wellformed h2\<close>
by(auto simp add: \<open>a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h2 - {(cast owner_document, cast node)}\<close>
heap_is_wellformed_def \<open>parent_child_rel h2 = parent_child_rel h3\<close> \<open>a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3\<close> elim!: acyclic_subset)
then
have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> local.a_ptr_disconnected_node_rel h')"
using \<open>(cast node, ptr) \<notin> (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*\<close>
by(auto simp add: \<open>a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h'\<close> \<open>a_host_shadow_root_rel h3 =
a_host_shadow_root_rel h'\<close> \<open>parent_child_rel h' = insert (ptr, cast node) ((parent_child_rel h3))\<close>)
then
show "heap_is_wellformed h'"
using \<open>heap_is_wellformed h2\<close>
using \<open>heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M h'\<close>
apply(auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def
a_all_ptrs_in_heap_def a_distinct_lists_def a_shadow_root_valid_def)[1]
by(auto simp add: object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3 shadow_root_ptr_kinds_eq_h2 shadow_root_ptr_kinds_eq_h3 shadow_root_eq_h2
shadow_root_eq_h3 shadow_root_eq2_h2 shadow_root_eq2_h3 tag_name_eq_h2 tag_name_eq_h3 tag_name_eq2_h2
tag_name_eq2_h3)
qed
end
interpretation i_insert_before_wf?: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_parent get_parent_locs get_child_nodes
get_child_nodes_locs set_child_nodes set_child_nodes_locs get_ancestors_di get_ancestors_di_locs adopt_node
adopt_node_locs set_disconnected_nodes set_disconnected_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_owner_document insert_before insert_before_locs append_child type_wf known_ptr known_ptrs heap_is_wellformed
parent_child_rel
by(simp add: l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf_is_l_insert_before_wf [instances]: "l_insert_before_wf Shadow_DOM.heap_is_wellformed
ShadowRootClass.type_wf ShadowRootClass.known_ptr ShadowRootClass.known_ptrs
Shadow_DOM.insert_before Shadow_DOM.get_child_nodes"
apply(auto simp add: l_insert_before_wf_def l_insert_before_wf_axioms_def instances)[1]
using insert_before_removes_child apply fast
done
lemma l_set_disconnected_nodes_get_disconnected_nodes_wf [instances]: "l_set_disconnected_nodes_get_disconnected_nodes_wf ShadowRootClass.type_wf
ShadowRootClass.known_ptr Shadow_DOM.heap_is_wellformed Shadow_DOM.parent_child_rel Shadow_DOM.get_child_nodes
get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs"
apply(auto simp add: l_set_disconnected_nodes_get_disconnected_nodes_wf_def l_set_disconnected_nodes_get_disconnected_nodes_wf_axioms_def instances)[1]
by (metis Diff_iff Shadow_DOM.i_heap_is_wellformed.heap_is_wellformed_disconnected_nodes_distinct Shadow_DOM.i_remove_child.set_disconnected_nodes_get_disconnected_nodes insert_iff returns_result_eq set_remove1_eq)
interpretation i_insert_before_wf2?: l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
set_child_nodes set_child_nodes_locs get_shadow_root get_shadow_root_locs set_disconnected_nodes
set_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel get_parent
get_parent_locs adopt_node adopt_node_locs get_owner_document insert_before insert_before_locs append_child
known_ptrs remove_child remove_child_locs get_ancestors_di get_ancestors_di_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs
remove heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma insert_before_wf2_is_l_insert_before_wf2 [instances]:
"l_insert_before_wf2 ShadowRootClass.type_wf ShadowRootClass.known_ptr ShadowRootClass.known_ptrs Shadow_DOM.insert_before
Shadow_DOM.heap_is_wellformed"
apply(auto simp add: l_insert_before_wf2_def l_insert_before_wf2_axioms_def instances)[1]
using insert_before_child_preserves apply(fast, fast, fast)
done
subsubsection \<open>append\_child\<close>
locale l_append_child_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_insert_before_wf2\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_append_child\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma append_child_heap_is_wellformed_preserved:
assumes wellformed: "heap_is_wellformed h"
and append_child: "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
and known_ptrs: "known_ptrs h"
and type_wf: "type_wf h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
using assms
by(auto simp add: append_child_def intro: insert_before_child_preserves)
lemma append_child_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> append_child ptr node \<rightarrow>\<^sub>h h'"
assumes "node \<notin> set xs"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [node]"
proof -
obtain ancestors owner_document h2 h3 disconnected_nodes_h2 where
ancestors: "h \<turnstile> get_ancestors_di ptr \<rightarrow>\<^sub>r ancestors" and
node_not_in_ancestors: "cast node \<notin> set ancestors" and
owner_document: "h \<turnstile> get_owner_document ptr \<rightarrow>\<^sub>r owner_document" and
h2: "h \<turnstile> adopt_node owner_document node \<rightarrow>\<^sub>h h2" and
disconnected_nodes_h2: "h2 \<turnstile> get_disconnected_nodes owner_document \<rightarrow>\<^sub>r disconnected_nodes_h2" and
h3: "h2 \<turnstile> set_disconnected_nodes owner_document (remove1 node disconnected_nodes_h2) \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> a_insert_node ptr node None \<rightarrow>\<^sub>h h'"
using assms(5)
by(auto simp add: append_child_def insert_before_def a_ensure_pre_insertion_validity_def
elim!: bind_returns_heap_E bind_returns_result_E
bind_returns_heap_E2[rotated, OF get_parent_pure, rotated]
bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_disconnected_nodes_pure, rotated]
bind_returns_heap_E2[rotated, OF get_ancestors_pure, rotated]
bind_returns_heap_E2[rotated, OF next_sibling_pure, rotated]
bind_returns_heap_E2[rotated, OF get_owner_document_pure, rotated]
split: if_splits option.splits)
have "\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr"
using assms(1) assms(4) assms(6)
by (metis (no_types, lifting) assms(2) assms(3) h2 is_OK_returns_heap_I is_OK_returns_result_E
local.adopt_node_child_in_heap local.get_parent_child_dual local.get_parent_ok
select_result_I2)
have "h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads adopt_node_writes h2 assms(4)
apply(rule reads_writes_separate_forwards)
using \<open>\<And>parent. |h \<turnstile> get_parent node|\<^sub>r = Some parent \<Longrightarrow> parent \<noteq> ptr\<close>
apply(auto simp add: adopt_node_locs_def CD.adopt_node_locs_def CD.remove_child_locs_def)[1]
by (meson local.set_child_nodes_get_child_nodes_different_pointers)
have "h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
using get_child_nodes_reads set_disconnected_nodes_writes h3 \<open>h2 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
apply(rule reads_writes_separate_forwards)
by(auto)
have "ptr |\<in>| object_ptr_kinds h"
by (meson ancestors is_OK_returns_result_I local.get_ancestors_ptr_in_heap)
then
have "known_ptr ptr"
using assms(3)
using local.known_ptrs_known_ptr by blast
have "type_wf h2"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF adopt_node_writes h2]
using adopt_node_types_preserved \<open>type_wf h\<close>
by(auto simp add: adopt_node_locs_def remove_child_locs_def reflp_def transp_def split: if_splits)
then
have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h3]
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@[node]"
using h'
apply(auto simp add: a_insert_node_def
dest!: bind_returns_heap_E3[rotated, OF \<open>h3 \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs\<close>
get_child_nodes_pure, rotated])[1]
using \<open>type_wf h3\<close> set_child_nodes_get_child_nodes \<open>known_ptr ptr\<close>
by metis
qed
lemma append_child_for_all_on_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "set nodes \<inter> set xs = {}"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs@nodes"
using assms
apply(induct nodes arbitrary: h xs)
apply(simp)
proof(auto elim!: bind_returns_heap_E)[1]fix a nodes h xs h'a
assume 0: "(\<And>h xs. heap_is_wellformed h \<Longrightarrow> type_wf h \<Longrightarrow> known_ptrs h
\<Longrightarrow> h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs \<Longrightarrow> h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'
\<Longrightarrow> set nodes \<inter> set xs = {} \<Longrightarrow> h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ nodes)"
and 1: "heap_is_wellformed h"
and 2: "type_wf h"
and 3: "known_ptrs h"
and 4: "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs"
and 5: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>r ()"
and 6: "h \<turnstile> append_child ptr a \<rightarrow>\<^sub>h h'a"
and 7: "h'a \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
and 8: "a \<notin> set xs"
and 9: "set nodes \<inter> set xs = {}"
and 10: "a \<notin> set nodes"
and 11: "distinct nodes"
then have "h'a \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ [a]"
using append_child_children 6
using "1" "2" "3" "4" "8" by blast
moreover have "heap_is_wellformed h'a" and "type_wf h'a" and "known_ptrs h'a"
using insert_before_child_preserves 1 2 3 6 append_child_def
by metis+
moreover have "set nodes \<inter> set (xs @ [a]) = {}"
using 9 10
by auto
ultimately show "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r xs @ a # nodes"
using 0 7
by fastforce
qed
lemma append_child_for_all_on_no_children:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r []"
assumes "h \<turnstile> forall_M (append_child ptr) nodes \<rightarrow>\<^sub>h h'"
assumes "distinct nodes"
shows "h' \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r nodes"
using assms append_child_for_all_on_children
by force
end
interpretation i_append_child_wf?: l_append_child_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs set_child_nodes set_child_nodes_locs get_shadow_root get_shadow_root_locs
set_disconnected_nodes set_disconnected_nodes_locs get_tag_name get_tag_name_locs heap_is_wellformed
parent_child_rel get_parent get_parent_locs adopt_node adopt_node_locs get_owner_document insert_before
insert_before_locs append_child known_ptrs remove_child remove_child_locs get_ancestors_di
get_ancestors_di_locs adopt_node\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M adopt_node_locs\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs remove heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
by(auto simp add: l_append_child_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_append_child_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma append_child_wf_is_l_append_child_wf [instances]:
"l_append_child_wf type_wf known_ptr known_ptrs append_child heap_is_wellformed"
apply(auto simp add: l_append_child_wf_def l_append_child_wf_axioms_def instances)[1]
using append_child_heap_is_wellformed_preserved by fast+
subsubsection \<open>to\_tree\_order\<close>
interpretation i_to_tree_order_wf?: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf get_child_nodes
get_child_nodes_locs to_tree_order known_ptrs get_parent get_parent_locs heap_is_wellformed
parent_child_rel get_disconnected_nodes get_disconnected_nodes_locs
apply(auto simp add: l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)[1]
done
declare l_to_tree_order_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_is_l_to_tree_order_wf [instances]:
"l_to_tree_order_wf heap_is_wellformed parent_child_rel type_wf known_ptr known_ptrs
to_tree_order get_parent get_child_nodes"
apply(auto simp add: l_to_tree_order_wf_def l_to_tree_order_wf_axioms_def instances)[1]
using to_tree_order_ok apply fast
using to_tree_order_ptrs_in_heap apply fast
using to_tree_order_parent_child_rel apply(fast, fast)
using to_tree_order_child2 apply blast
using to_tree_order_node_ptrs apply fast
using to_tree_order_child apply fast
using to_tree_order_ptr_in_result apply fast
using to_tree_order_parent apply fast
using to_tree_order_subset apply fast
done
paragraph \<open>get\_root\_node\<close>
interpretation i_to_tree_order_wf_get_root_node_wf?: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr type_wf known_ptrs heap_is_wellformed parent_child_rel get_child_nodes get_child_nodes_locs
get_disconnected_nodes get_disconnected_nodes_locs get_parent get_parent_locs get_ancestors
get_ancestors_locs get_root_node get_root_node_locs to_tree_order
by(auto simp add: l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_to_tree_order_wf_get_root_node_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
lemma to_tree_order_wf_get_root_node_wf_is_l_to_tree_order_wf_get_root_node_wf [instances]:
"l_to_tree_order_wf_get_root_node_wf ShadowRootClass.type_wf ShadowRootClass.known_ptr
ShadowRootClass.known_ptrs to_tree_order Shadow_DOM.get_root_node
Shadow_DOM.heap_is_wellformed"
apply(auto simp add: l_to_tree_order_wf_get_root_node_wf_def
l_to_tree_order_wf_get_root_node_wf_axioms_def instances)[1]
using to_tree_order_get_root_node apply fast
using to_tree_order_same_root apply fast
done
subsubsection \<open>to\_tree\_order\_si\<close>
locale l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_child_nodes +
l_get_parent_get_host_get_disconnected_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_to_tree_order_si\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma to_tree_order_si_ok:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
and "ptr |\<in>| object_ptr_kinds h"
shows "h \<turnstile> ok (to_tree_order_si ptr)"
proof(insert assms(1) assms(4), induct rule: heap_wellformed_induct_si)
case (step parent)
have "known_ptr parent"
using assms(2) local.known_ptrs_known_ptr step.prems
by blast
then show ?case
using step
using assms(1) assms(2) assms(3)
using local.heap_is_wellformed_children_in_heap local.get_shadow_root_shadow_root_ptr_in_heap
by(auto simp add: to_tree_order_si_def[of parent] intro: get_child_nodes_ok get_shadow_root_ok
intro!: bind_is_OK_pure_I map_M_pure_I bind_pure_I map_M_ok_I split: option.splits)
qed
end
interpretation i_to_tree_order_si_wf?: l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
type_wf known_ptr get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs known_ptrs get_parent get_parent_locs to_tree_order_si
by(auto simp add: l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_to_tree_order_si_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_assigned\_nodes\<close>
lemma forall_M_small_big: "h \<turnstile> forall_M f xs \<rightarrow>\<^sub>h h' \<Longrightarrow> P h \<Longrightarrow>
(\<And>h h' x. x \<in> set xs \<Longrightarrow> h \<turnstile> f x \<rightarrow>\<^sub>h h' \<Longrightarrow> P h \<Longrightarrow> P h') \<Longrightarrow> P h'"
by(induct xs arbitrary: h) (auto elim!: bind_returns_heap_E)
locale l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_assigned_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_heap_is_wellformed +
l_remove_child_wf2 +
l_append_child_wf +
l_remove_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
begin
lemma assigned_nodes_distinct:
assumes "heap_is_wellformed h"
assumes "h \<turnstile> assigned_nodes slot \<rightarrow>\<^sub>r nodes"
shows "distinct nodes"
proof -
have "\<And>ptr children. h \<turnstile> get_child_nodes ptr \<rightarrow>\<^sub>r children \<Longrightarrow> distinct children"
using assms(1) local.heap_is_wellformed_children_distinct by blast
then show ?thesis
using assms
apply(auto simp add: assigned_nodes_def elim!: bind_returns_result_E2 split: if_splits)[1]
by (simp add: filter_M_distinct)
qed
lemma flatten_dom_preserves:
assumes "heap_is_wellformed h" and "known_ptrs h" and "type_wf h"
assumes "h \<turnstile> flatten_dom \<rightarrow>\<^sub>h h'"
shows "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
proof -
obtain tups h2 element_ptrs shadow_root_ptrs where
"h \<turnstile> element_ptr_kinds_M \<rightarrow>\<^sub>r element_ptrs" and
tups: "h \<turnstile> map_filter_M2 (\<lambda>element_ptr. do {
tag \<leftarrow> get_tag_name element_ptr;
assigned_nodes \<leftarrow> assigned_nodes element_ptr;
(if tag = ''slot'' \<and> assigned_nodes \<noteq> []
then return (Some (element_ptr, assigned_nodes)) else return None)}) element_ptrs \<rightarrow>\<^sub>r tups"
(is "h \<turnstile> map_filter_M2 ?f element_ptrs \<rightarrow>\<^sub>r tups") and
h2: "h \<turnstile> forall_M (\<lambda>(slot, assigned_nodes). do {
get_child_nodes (cast slot) \<bind> forall_M remove;
forall_M (append_child (cast slot)) assigned_nodes
}) tups \<rightarrow>\<^sub>h h2" and
"h2 \<turnstile> shadow_root_ptr_kinds_M \<rightarrow>\<^sub>r shadow_root_ptrs" and
h': "h2 \<turnstile> forall_M (\<lambda>shadow_root_ptr. do {
host \<leftarrow> get_host shadow_root_ptr;
get_child_nodes (cast host) \<bind> forall_M remove;
get_child_nodes (cast shadow_root_ptr) \<bind> forall_M (append_child (cast host));
remove_shadow_root host
}) shadow_root_ptrs \<rightarrow>\<^sub>h h'"
using \<open>h \<turnstile> flatten_dom \<rightarrow>\<^sub>h h'\<close>
apply(auto simp add: flatten_dom_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF ElementMonad.ptr_kinds_M_pure, rotated]
bind_returns_heap_E2[rotated, OF ShadowRootMonad.ptr_kinds_M_pure, rotated])[1]
apply(drule pure_returns_heap_eq)
by(auto intro!: map_filter_M2_pure bind_pure_I)
have "heap_is_wellformed h2 \<and> known_ptrs h2 \<and> type_wf h2"
using h2 \<open>heap_is_wellformed h\<close> \<open>known_ptrs h\<close> \<open>type_wf h\<close>
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
elim!: forall_M_small_big[where P = "\<lambda>h. heap_is_wellformed h \<and> known_ptrs h \<and> type_wf h", simplified]
intro: remove_preserves_known_ptrs remove_heap_is_wellformed_preserved remove_preserves_type_wf
append_child_preserves_known_ptrs append_child_heap_is_wellformed_preserved append_child_preserves_type_wf)
then
show "heap_is_wellformed h'" and "known_ptrs h'" and "type_wf h'"
using h'
by(auto elim!: bind_returns_heap_E bind_returns_heap_E2[rotated, OF get_host_pure, rotated] bind_returns_heap_E2[rotated, OF get_child_nodes_pure, rotated]
dest!: forall_M_small_big[where P = "\<lambda>h. heap_is_wellformed h \<and> known_ptrs h \<and> type_wf h", simplified]
intro: remove_preserves_known_ptrs remove_heap_is_wellformed_preserved remove_preserves_type_wf
append_child_preserves_known_ptrs append_child_heap_is_wellformed_preserved append_child_preserves_type_wf
remove_shadow_root_preserves
)
qed
end
interpretation i_assigned_nodes_wf?: l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
known_ptr assigned_nodes assigned_nodes_flatten flatten_dom get_child_nodes get_child_nodes_locs
get_tag_name get_tag_name_locs get_root_node get_root_node_locs get_host get_host_locs find_slot
assigned_slot remove insert_before insert_before_locs append_child remove_shadow_root
remove_shadow_root_locs type_wf get_shadow_root get_shadow_root_locs set_shadow_root
set_shadow_root_locs get_parent get_parent_locs to_tree_order heap_is_wellformed parent_child_rel
get_disconnected_nodes get_disconnected_nodes_locs known_ptrs remove_child remove_child_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_document get_disconnected_document_locs
by(auto simp add: l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_assigned_nodes_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>get\_shadow\_root\_safe\<close>
locale l_get_shadow_root_safe_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs
known_ptr type_wf heap_is_wellformed parent_child_rel heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs +
l_type_wf type_wf +
l_get_shadow_root_safe\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf get_shadow_root_safe get_shadow_root_safe_locs get_shadow_root
get_shadow_root_locs get_mode get_mode_locs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root_safe :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_safe_locs :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_child_nodes :: "(_::linorder) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
end
subsubsection \<open>create\_element\<close>
locale l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name type_wf set_tag_name set_tag_name_locs +
l_create_element_defs create_element +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs +
l_new_element_get_disconnected_nodes get_disconnected_nodes get_disconnected_nodes_locs +
l_set_tag_name_get_disconnected_nodes type_wf set_tag_name set_tag_name_locs
get_disconnected_nodes get_disconnected_nodes_locs +
l_create_element\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs set_tag_name set_tag_name_locs type_wf
create_element known_ptr type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M +
l_new_element_get_child_nodes type_wf known_ptr get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_child_nodes type_wf set_tag_name set_tag_name_locs known_ptr
get_child_nodes get_child_nodes_locs +
l_set_tag_name_get_tag_name type_wf get_tag_name get_tag_name_locs set_tag_name set_tag_name_locs +
l_new_element_get_tag_name type_wf get_tag_name get_tag_name_locs +
l_set_disconnected_nodes_get_child_nodes set_disconnected_nodes set_disconnected_nodes_locs
get_child_nodes get_child_nodes_locs +
l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes set_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs +
l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs +
l_set_disconnected_nodes type_wf set_disconnected_nodes set_disconnected_nodes_locs +
l_set_disconnected_nodes_get_disconnected_nodes type_wf get_disconnected_nodes
get_disconnected_nodes_locs set_disconnected_nodes set_disconnected_nodes_locs +
l_new_element_get_shadow_root type_wf get_shadow_root get_shadow_root_locs +
l_set_tag_name_get_shadow_root type_wf set_tag_name set_tag_name_locs get_shadow_root get_shadow_root_locs +
l_new_element type_wf +
l_known_ptrs known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma create_element_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_element_ptr h2 h3 disc_nodes_h3 where
new_element_ptr: "h \<turnstile> new_element \<rightarrow>\<^sub>r new_element_ptr" and
h2: "h \<turnstile> new_element \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_tag_name new_element_ptr tag \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_element_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: create_element_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF CD.get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr"
apply(auto simp add: create_element_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I CD.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_element_ptr \<notin> set |h \<turnstile> element_ptr_kinds_M|\<^sub>r"
using new_element_ptr ElementMonad.ptr_kinds_ptr_kinds_M h2
using new_element_ptr_not_in_heap by blast
then have "cast new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h: "object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
using new_element_new_ptr h2 new_element_ptr by blast
then have node_ptr_kinds_eq_h: "node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_element_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h |\<union>| {|new_element_ptr|}"
apply(simp add: element_ptr_kinds_def)
by force
have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h2 = character_data_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def character_data_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_tag_name_writes h3])
using set_tag_name_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
by(simp add: element_ptr_kinds_def)
have "known_ptr (cast new_element_ptr)"
using \<open>h \<turnstile> create_element document_ptr tag \<rightarrow>\<^sub>r new_element_ptr\<close> local.create_element_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_element_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_child_nodes
by blast
have tag_name_eq_h:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2 get_tag_name_new_element[rotated, OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by(blast)+
then have tag_name_eq2_h: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_empty_tag_name
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h2 get_disconnected_nodes_new_element[OF new_element_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_child_nodes)
then have children_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_tag_name_writes h3])
by (metis local.set_tag_name_get_tag_name_different_pointers)
then have tag_name_eq2_h2: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_tag_name new_element_ptr \<rightarrow>\<^sub>r ''''"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_empty_tag_name
by blast
have "type_wf h2"
using \<open>type_wf h\<close> new_element_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_tag_name_writes h3]
using set_tag_name_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3:
"\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3:
"\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. ptr' \<noteq> new_element_ptr
\<Longrightarrow> h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_tag_name_writes h3])
by (metis local.set_tag_name_get_tag_name_different_pointers)
then have tag_name_eq2_h2: "\<And>ptr'. ptr' \<noteq> new_element_ptr
\<Longrightarrow> |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_element_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close>
using \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
apply(rule reads_writes_preserved[OF get_tag_name_reads set_disconnected_nodes_writes h'])
using set_disconnected_nodes_get_tag_name
by blast
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting)
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
apply (metis \<open>known_ptrs h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1)
assms(3) funion_iff CD.get_child_nodes_ok local.known_ptrs_known_ptr
local.parent_child_rel_child_in_heap CD.parent_child_rel_child_nodes2 node_ptr_kinds_commutes
node_ptr_kinds_eq_h returns_result_select_result)
by (metis (no_types, lifting) CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> assms(3) assms(4) children_eq_h
disconnected_nodes_eq2_h document_ptr_kinds_eq_h finite_set_in is_OK_returns_result_I
local.known_ptrs_known_ptr node_ptr_kinds_commutes returns_result_select_result subsetD)
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (smt children_eq2_h3 disc_nodes_h3 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3
element_ptr_kinds_commutes h' h2 local.CD.a_all_ptrs_in_heap_def
local.set_disconnected_nodes_get_disconnected_nodes new_element_ptr new_element_ptr_in_heap
node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h3 notin_fset object_ptr_kinds_eq_h3 select_result_I2
set_ConsD subset_code(1))
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_element_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M CD.a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem CD.get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_element_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_element_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_element_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: CD.heap_is_wellformed_def heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_element_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_element_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff CD.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
by (metis \<open> CD.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
then have " CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)
then have " CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3
intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, lifting) \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set disc_nodes_h3\<close>
\<open> CD.a_distinct_lists h3\<close> \<open>type_wf h'\<close> disc_nodes_h3 distinct.simps(2)
CD.distinct_lists_disconnected_nodes get_disconnected_nodes_ok returns_result_eq
returns_result_select_result)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
apply(-)
apply(cases "x = document_ptr")
apply(smt NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> \<open>CD.a_all_ptrs_in_heap h\<close>
disc_nodes_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
set_disconnected_nodes_get_disconnected_nodes
CD.a_all_ptrs_in_heap_def
select_result_I2 set_ConsD subsetD)
by (smt NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> \<open>CD.a_all_ptrs_in_heap h\<close>
disc_nodes_document_ptr_h2 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disjoint_iff_not_equal document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
CD.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply -
apply(cases "xb = document_ptr")
apply (metis (no_types, opaque_lifting) "3" "4" "6"
\<open>\<And>p. p |\<in>| object_ptr_kinds h3
\<Longrightarrow> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r\<close>
\<open> CD.a_distinct_lists h3\<close> children_eq2_h3 disc_nodes_h3 CD.distinct_lists_no_parent h'
select_result_I2 set_ConsD set_disconnected_nodes_get_disconnected_nodes)
by (metis "3" "4" "5" "6" \<open> CD.a_distinct_lists h3\<close> \<open>type_wf h3\<close> children_eq2_h3
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(auto simp add: CD.a_owner_document_valid_def)[1]
apply(auto simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )[1]
apply(auto simp add: object_ptr_kinds_eq_h2)[1]
apply(auto simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )[1]
apply(auto simp add: document_ptr_kinds_eq_h2)[1]
apply(auto simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )[1]
apply(auto simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )[1]
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric]
disconnected_nodes_eq2_h disconnected_nodes_eq2_h2
disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by(metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close> children_eq2_h children_eq2_h2
children_eq2_h3 disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_eq_h finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms node_ptr_kinds_commutes
select_result_I2)
have "CD.a_heap_is_wellformed h'"
using \<open>CD.a_acyclic_heap h'\<close> \<open>CD.a_all_ptrs_in_heap h'\<close> \<open>CD.a_distinct_lists h'\<close> \<open>CD.a_owner_document_valid h'\<close>
by(simp add: CD.a_heap_is_wellformed_def)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h"
using document_ptr_kinds_eq_h
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
using document_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
using document_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_eq_h: "\<And>element_ptr shadow_root_opt. element_ptr \<noteq> new_element_ptr
\<Longrightarrow> h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt = h2 \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt"
proof -
fix element_ptr shadow_root_opt
assume "element_ptr \<noteq> new_element_ptr "
have "\<forall>P \<in> get_shadow_root_locs element_ptr. P h h2"
using get_shadow_root_new_element new_element_ptr h2
using \<open>element_ptr \<noteq> new_element_ptr\<close> by blast
then
have "preserved (get_shadow_root element_ptr) h h2"
using get_shadow_root_new_element[rotated, OF new_element_ptr h2]
using get_shadow_root_reads
by(simp add: reads_def)
then show "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt = h2 \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r shadow_root_opt"
by (simp add: preserved_def)
qed
have shadow_root_none: "h2 \<turnstile> get_shadow_root (new_element_ptr) \<rightarrow>\<^sub>r None"
using new_element_ptr h2 new_element_ptr_in_heap[OF h2 new_element_ptr]
new_element_is_element_ptr[OF new_element_ptr] new_element_no_shadow_root
by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_tag_name_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_tag_name_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
using set_disconnected_nodes_get_shadow_root
by(auto simp add: set_disconnected_nodes_get_shadow_root)
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h shadow_root_none by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
by (simp add: shadow_root_eq_h3)
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
apply(case_tac "x = new_element_ptr")
using shadow_root_none apply auto[1]
using shadow_root_eq_h
by (smt Diff_empty Diff_insert0 ElementMonad.ptr_kinds_M_ptr_kinds
ElementMonad.ptr_kinds_ptr_kinds_M assms(1) assms(3) finite_set_in h2 insort_split
local.get_shadow_root_ok local.shadow_root_same_host new_element_ptr new_element_ptr_not_in_heap
option.distinct(1) returns_result_select_result select_result_I2 shadow_root_none)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3 select_result_eq[OF shadow_root_eq_h3])
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h2"
proof (unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h2)"
obtain previous_host where
"previous_host \<in> fset (element_ptr_kinds h)" and
"|h \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
by (metis \<open>local.a_shadow_root_valid h\<close> \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h2)\<close>
local.a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h)
moreover have "previous_host \<noteq> new_element_ptr"
using calculation(1) h2 new_element_ptr new_element_ptr_not_in_heap by auto
ultimately have "|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
using shadow_root_eq_h
apply (simp add: tag_name_eq2_h)
by (metis \<open>previous_host \<noteq> new_element_ptr\<close> \<open>|h \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr\<close>
select_result_eq shadow_root_eq_h)
then
show "\<exists>host\<in>fset (element_ptr_kinds h2). |h2 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h2 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
by (meson \<open>previous_host \<in> fset (element_ptr_kinds h)\<close> \<open>previous_host \<noteq> new_element_ptr\<close> assms(3)
local.get_shadow_root_ok local.get_shadow_root_ptr_in_heap notin_fset returns_result_select_result shadow_root_eq_h)
qed
then have "a_shadow_root_valid h3"
proof (unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h2). \<exists>host\<in>fset (element_ptr_kinds h2).
|h2 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h2 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h3)"
obtain previous_host where
"previous_host \<in> fset (element_ptr_kinds h2)" and
"|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
by (metis \<open>local.a_shadow_root_valid h2\<close> \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h3)\<close>
local.a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h2)
moreover have "previous_host \<noteq> new_element_ptr"
using calculation(1) h3 new_element_ptr new_element_ptr_not_in_heap
using calculation(3) shadow_root_none by auto
ultimately have "|h2 \<turnstile> get_tag_name previous_host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr"
using shadow_root_eq_h2
apply (simp add: tag_name_eq2_h2)
by (metis \<open>previous_host \<noteq> new_element_ptr\<close> \<open>|h2 \<turnstile> get_shadow_root previous_host|\<^sub>r = Some shadow_root_ptr\<close>
select_result_eq shadow_root_eq_h)
then
show "\<exists>host\<in>fset (element_ptr_kinds h3). |h3 \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h3 \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
by (smt \<open>previous_host \<in> fset (element_ptr_kinds h2)\<close> \<open>previous_host \<noteq> new_element_ptr\<close> \<open>type_wf h2\<close>
\<open>type_wf h3\<close> element_ptr_kinds_eq_h2 finite_set_in local.get_shadow_root_ok returns_result_eq
returns_result_select_result shadow_root_eq_h2 tag_name_eq2_h2)
qed
then have "a_shadow_root_valid h'"
apply(auto simp add: a_shadow_root_valid_def element_ptr_kinds_eq_h3 shadow_root_eq_h3
shadow_root_ptr_kinds_eq_h3 tag_name_eq2_h3)[1]
by (smt \<open>type_wf h3\<close> finite_set_in local.get_shadow_root_ok returns_result_select_result
select_result_I2 shadow_root_eq_h3)
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h shadow_root_eq_h)[1]
apply (smt assms(3) case_prod_conv h2 image_iff local.get_shadow_root_ok mem_Collect_eq new_element_ptr
new_element_ptr_not_in_heap returns_result_select_result select_result_I2 shadow_root_eq_h)
using shadow_root_none apply auto[1]
apply (metis (no_types, lifting) Collect_cong assms(3) case_prodE case_prodI h2 host_shadow_root_rel_def
i_get_parent_get_host_get_disconnected_document_wf.a_host_shadow_root_rel_shadow_root
local.a_host_shadow_root_rel_def local.get_shadow_root_impl local.get_shadow_root_ok new_element_ptr
new_element_ptr_not_in_heap returns_result_select_result select_result_I2 shadow_root_eq_h)
done
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq_h2)[1]
apply (smt Collect_cong \<open>type_wf h2\<close> case_prodE case_prodI element_ptr_kinds_eq_h2 host_shadow_root_rel_def
i_get_root_node_si_wf.a_host_shadow_root_rel_shadow_root local.a_host_shadow_root_rel_def local.get_shadow_root_impl
local.get_shadow_root_ok returns_result_select_result shadow_root_eq_h2)
by (metis (no_types, lifting) Collect_cong \<open>type_wf h3\<close> case_prodI2 case_prod_conv element_ptr_kinds_eq_h2
host_shadow_root_rel_def i_get_root_node_si_wf.a_host_shadow_root_rel_shadow_root local.a_host_shadow_root_rel_def
local.get_shadow_root_impl local.get_shadow_root_ok returns_result_select_result shadow_root_eq_h2)
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 shadow_root_eq_h2)[1]
apply (smt Collect_cong Shadow_DOM.a_host_shadow_root_rel_def \<open>type_wf h3\<close> case_prodD case_prodI2
element_ptr_kinds_eq_h2 i_get_root_node_si_wf.a_host_shadow_root_rel_shadow_root local.get_shadow_root_impl
local.get_shadow_root_ok returns_result_select_result shadow_root_eq_h3)
apply (smt Collect_cong \<open>type_wf h'\<close> case_prodE case_prodI element_ptr_kinds_eq_h2 host_shadow_root_rel_def
i_get_root_node_si_wf.a_host_shadow_root_rel_shadow_root l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_defs.a_host_shadow_root_rel_def
local.get_shadow_root_impl local.get_shadow_root_ok returns_result_select_result shadow_root_eq_h3)
done
have "a_ptr_disconnected_node_rel h = a_ptr_disconnected_node_rel h2"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h disconnected_nodes_eq2_h)
have "a_ptr_disconnected_node_rel h2 = a_ptr_disconnected_node_rel h3"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)
have "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_element_ptr # disc_nodes_h3"
using h' local.set_disconnected_nodes_get_disconnected_nodes by auto
have " document_ptr |\<in>| document_ptr_kinds h3"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h document_ptr_kinds_eq_h2)
have "cast new_element_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3\<close>
by auto
have "a_ptr_disconnected_node_rel h' = {(cast document_ptr, cast new_element_ptr)} \<union> a_ptr_disconnected_node_rel h3"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h3 disconnected_nodes_eq2_h3)[1]
apply(case_tac "aa = document_ptr")
using disc_nodes_h3 h' \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_element_ptr # disc_nodes_h3\<close>
apply(auto)[1]
using disconnected_nodes_eq2_h3 apply auto[1]
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_element_ptr # disc_nodes_h3\<close>
using \<open>cast new_element_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r\<close>
using \<open>document_ptr |\<in>| document_ptr_kinds h3\<close> apply auto[1]
apply(case_tac "document_ptr = aa")
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr # disc_nodes_h3\<close> disc_nodes_h3
apply auto[1]
using disconnected_nodes_eq_h3[THEN select_result_eq, simplified] by auto
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>local.a_ptr_disconnected_node_rel h = local.a_ptr_disconnected_node_rel h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close>
by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>local.a_ptr_disconnected_node_rel h2 = local.a_ptr_disconnected_node_rel h3\<close> \<open>parent_child_rel h2 = parent_child_rel h3\<close>
by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast document_ptr, cast new_element_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h3 = local.a_host_shadow_root_rel h'\<close>
\<open>local.a_ptr_disconnected_node_rel h' = {(cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr, cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr)} \<union>
local.a_ptr_disconnected_node_rel h3\<close> \<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "\<And>a b. (a, b) \<in> parent_child_rel h3 \<Longrightarrow> a \<noteq> cast new_element_ptr"
using CD.parent_child_rel_parent_in_heap \<open>parent_child_rel h = parent_child_rel h2\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> element_ptr_kinds_commutes h2 new_element_ptr
new_element_ptr_not_in_heap node_ptr_kinds_commutes
by blast
moreover
have "\<And>a b. (a, b) \<in> a_host_shadow_root_rel h3 \<Longrightarrow> a \<noteq> cast new_element_ptr"
using shadow_root_eq_h2 shadow_root_none
by(auto simp add: a_host_shadow_root_rel_def)
moreover
have "\<And>a b. (a, b) \<in> a_ptr_disconnected_node_rel h3 \<Longrightarrow> a \<noteq> cast new_element_ptr"
by(auto simp add: a_ptr_disconnected_node_rel_def)
moreover
have "cast new_element_ptr \<notin> {x. (x, cast document_ptr) \<in>
(parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*}"
by (smt Un_iff \<open>\<And>b a. (a, b) \<in> local.a_host_shadow_root_rel h3 \<Longrightarrow>
a \<noteq> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr\<close> \<open>\<And>b a. (a, b) \<in> local.a_ptr_disconnected_node_rel h3 \<Longrightarrow>
a \<noteq> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr\<close> \<open>\<And>b a. (a, b) \<in> parent_child_rel h3 \<Longrightarrow>
a \<noteq> cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_element_ptr\<close> cast_document_ptr_not_node_ptr(1) converse_rtranclE mem_Collect_eq)
moreover
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2\<close>
\<open>parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3 \<union> local.a_ptr_disconnected_node_rel h3\<close>
by auto
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast document_ptr, cast new_element_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3\<close>)
show " heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h' \<union> local.a_ptr_disconnected_node_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl \<open>local.CD.a_heap_is_wellformed h'\<close>
\<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close> \<open>local.a_shadow_root_valid h'\<close>)
qed
end
interpretation i_create_element_wf?: l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs heap_is_wellformed
parent_child_rel set_tag_name set_tag_name_locs set_disconnected_nodes
set_disconnected_nodes_locs create_element get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs DocumentClass.known_ptr DocumentClass.type_wf
by(auto simp add: l_create_element_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_create_element_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
subsubsection \<open>create\_character\_data\<close>
locale l_create_character_data_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes type_wf get_disconnected_nodes get_disconnected_nodes_locs +
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs +
l_create_character_data\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
set_disconnected_nodes set_disconnected_nodes_locs set_val set_val_locs create_character_data known_ptr
type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
+ l_new_character_data_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_val_get_disconnected_nodes
type_wf set_val set_val_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_new_character_data_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_set_val_get_child_nodes
type_wf set_val set_val_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes_get_child_nodes
set_disconnected_nodes set_disconnected_nodes_locs get_child_nodes get_child_nodes_locs
+ l_set_disconnected_nodes
type_wf set_disconnected_nodes set_disconnected_nodes_locs
+ l_set_disconnected_nodes_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs set_disconnected_nodes
set_disconnected_nodes_locs
+ l_set_val_get_shadow_root type_wf set_val set_val_locs get_shadow_root get_shadow_root_locs
+ l_set_disconnected_nodes_get_shadow_root set_disconnected_nodes set_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs
+ l_new_character_data_get_tag_name
get_tag_name get_tag_name_locs
+ l_set_val_get_tag_name type_wf set_val set_val_locs get_tag_name get_tag_name_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_set_disconnected_nodes_get_tag_name type_wf set_disconnected_nodes set_disconnected_nodes_locs
get_tag_name get_tag_name_locs
+ l_new_character_data
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
begin
lemma create_character_data_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'" and "type_wf h'" and "known_ptrs h'"
proof -
obtain new_character_data_ptr h2 h3 disc_nodes_h3 where
new_character_data_ptr: "h \<turnstile> new_character_data \<rightarrow>\<^sub>r new_character_data_ptr" and
h2: "h \<turnstile> new_character_data \<rightarrow>\<^sub>h h2" and
h3: "h2 \<turnstile> set_val new_character_data_ptr text \<rightarrow>\<^sub>h h3" and
disc_nodes_h3: "h3 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3" and
h': "h3 \<turnstile> set_disconnected_nodes document_ptr (cast new_character_data_ptr # disc_nodes_h3) \<rightarrow>\<^sub>h h'"
using assms(2)
by(auto simp add: CD.create_character_data_def
elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF CD.get_disconnected_nodes_pure, rotated] )
then have "h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr"
apply(auto simp add: CD.create_character_data_def intro!: bind_returns_result_I)[1]
apply (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
apply (metis is_OK_returns_heap_E is_OK_returns_result_I local.CD.get_disconnected_nodes_pure
pure_returns_heap_eq)
by (metis is_OK_returns_heap_I is_OK_returns_result_E old.unit.exhaust)
have "new_character_data_ptr \<notin> set |h \<turnstile> character_data_ptr_kinds_M|\<^sub>r"
using new_character_data_ptr CharacterDataMonad.ptr_kinds_ptr_kinds_M h2
using new_character_data_ptr_not_in_heap by blast
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF CD.set_val_writes h3])
using CD.set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_character_data_ptr)"
using \<open>h \<turnstile> create_character_data document_ptr text \<rightarrow>\<^sub>r new_character_data_ptr\<close>
local.create_character_data_known_ptr by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
using new_character_data_new_ptr h2 new_character_data_ptr by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h |\<union>| {|cast new_character_data_ptr|}"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h |\<union>| {|new_character_data_ptr|}"
apply(simp add: character_data_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: document_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF CD.set_val_writes h3])
using CD.set_val_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h2: "character_data_ptr_kinds h3 = character_data_ptr_kinds h2"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
using node_ptr_kinds_eq_h2
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_disconnected_nodes_writes h'])
using set_disconnected_nodes_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h3: "character_data_ptr_kinds h' = character_data_ptr_kinds h3"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
using node_ptr_kinds_eq_h3
by(simp add: element_ptr_kinds_def)
have "document_ptr |\<in>| document_ptr_kinds h"
using disc_nodes_h3 document_ptr_kinds_eq_h object_ptr_kinds_eq_h2
CD.get_disconnected_nodes_ptr_in_heap \<open>type_wf h\<close> document_ptr_kinds_def
by (metis is_OK_returns_result_I)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_character_data[rotated, OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_character_data_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []"
using new_character_data_ptr h2 new_character_data_ptr_in_heap[OF h2 new_character_data_ptr]
new_character_data_is_character_data_ptr[OF new_character_data_ptr]
new_character_data_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h2
get_disconnected_nodes_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2
get_tag_name_new_character_data[OF new_character_data_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads CD.set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_tag_name)
then have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_character_data_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF CD.set_val_writes h3]
using set_val_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_disconnected_nodes_writes h']
using set_disconnected_nodes_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. document_ptr \<noteq> doc_ptr
\<Longrightarrow> h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_disconnected_nodes_different_pointers)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. document_ptr \<noteq> doc_ptr
\<Longrightarrow> |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_disconnected_nodes_get_tag_name)
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have disc_nodes_document_ptr_h2: "h2 \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h2 disc_nodes_h3 by auto
then have disc_nodes_document_ptr_h: "h \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r disc_nodes_h3"
using disconnected_nodes_eq_h by auto
then have "cast new_character_data_ptr \<notin> set disc_nodes_h3"
using \<open>heap_is_wellformed h\<close> using \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
a_all_ptrs_in_heap_def heap_is_wellformed_def
using NodeMonad.ptr_kinds_ptr_kinds_M local.heap_is_wellformed_disc_nodes_in_heap by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
\<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) NodeMonad.ptr_kinds_ptr_kinds_M \<open>parent_child_rel h = parent_child_rel h2\<close>
children_eq2_h finite_set_in finsert_iff funion_finsert_right CD.parent_child_rel_child
CD.parent_child_rel_parent_in_heap node_ptr_kinds_commutes object_ptr_kinds_eq_h
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>h2 \<turnstile> get_child_nodes (cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> assms(3) assms(4)
children_eq_h disconnected_nodes_eq2_h document_ptr_kinds_eq_h finite_set_in is_OK_returns_result_I
local.known_ptrs_known_ptr node_ptr_kinds_commutes returns_result_select_result subset_code(1))
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (smt character_data_ptr_kinds_commutes character_data_ptr_kinds_eq_h2 children_eq2_h3
disc_nodes_h3 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3 h' h2 local.CD.a_all_ptrs_in_heap_def
local.set_disconnected_nodes_get_disconnected_nodes new_character_data_ptr new_character_data_ptr_in_heap
node_ptr_kinds_eq_h3 notin_fset object_ptr_kinds_eq_h3 select_result_I2 set_ConsD subset_code(1))
have "\<And>p. p |\<in>| object_ptr_kinds h \<Longrightarrow> cast new_character_data_ptr \<notin> set |h \<turnstile> get_child_nodes p|\<^sub>r"
using \<open>heap_is_wellformed h\<close> \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
heap_is_wellformed_children_in_heap
by (meson NodeMonad.ptr_kinds_ptr_kinds_M CD.a_all_ptrs_in_heap_def assms(3) assms(4) fset_mp
fset_of_list_elem CD.get_child_nodes_ok known_ptrs_known_ptr returns_result_select_result)
then have "\<And>p. p |\<in>| object_ptr_kinds h2 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h2 \<turnstile> get_child_nodes p|\<^sub>r"
using children_eq2_h
apply(auto simp add: object_ptr_kinds_eq_h)[1]
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close> apply auto[1]
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M \<open>cast new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>)
then have "\<And>p. p |\<in>| object_ptr_kinds h3 \<Longrightarrow> cast new_character_data_ptr \<notin> set |h3 \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h2 children_eq2_h2 by auto
then have new_character_data_ptr_not_in_any_children:
"\<And>p. p |\<in>| object_ptr_kinds h' \<Longrightarrow> cast new_character_data_ptr \<notin> set |h' \<turnstile> get_child_nodes p|\<^sub>r"
using object_ptr_kinds_eq_h3 children_eq2_h3 by auto
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_child_nodes (cast new_character_data_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: CD.a_distinct_lists_def object_ptr_kinds_eq_h document_ptr_kinds_eq_h
disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(case_tac "x=cast new_character_data_ptr")
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
apply (metis IntI assms(1) assms(3) assms(4) empty_iff CD.get_child_nodes_ok
local.heap_is_wellformed_one_parent local.known_ptrs_known_ptr
returns_result_select_result)
apply(auto simp add: children_eq2_h[symmetric] insort_split dest: distinct_concat_map_E(2))[1]
thm children_eq2_h
using \<open>CD.a_distinct_lists h\<close> \<open>type_wf h2\<close> disconnected_nodes_eq_h document_ptr_kinds_eq_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok returns_result_select_result
by metis
then have "CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "CD.a_distinct_lists h'"
proof(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)[1]
fix x
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
then show "distinct |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
using document_ptr_kinds_eq_h3 disconnected_nodes_eq_h3 h' set_disconnected_nodes_get_disconnected_nodes
by (metis (no_types, opaque_lifting) \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set disc_nodes_h3\<close>
\<open>type_wf h2\<close> assms(1) disc_nodes_document_ptr_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
disconnected_nodes_eq_h distinct.simps(2) document_ptr_kinds_eq_h2 local.get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct returns_result_select_result select_result_I2)
next
fix x y xa
assume "distinct (concat (map (\<lambda>document_ptr. |h3 \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h3)))))"
and "x |\<in>| document_ptr_kinds h3"
and "y |\<in>| document_ptr_kinds h3"
and "x \<noteq> y"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
and "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
moreover have "set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r \<inter> set |h3 \<turnstile> get_disconnected_nodes y|\<^sub>r = {}"
using calculation by(auto dest: distinct_concat_map_E(1))
ultimately show "False"
using NodeMonad.ptr_kinds_ptr_kinds_M \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>n\<^sub>o\<^sub>d\<^sub>e\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> node_ptr_kinds_M|\<^sub>r\<close>
by (smt local.CD.a_all_ptrs_in_heap_def \<open>CD.a_all_ptrs_in_heap h\<close> disc_nodes_document_ptr_h2
disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3 disjoint_iff_not_equal
document_ptr_kinds_eq_h document_ptr_kinds_eq_h2 finite_set_in h'
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
local.a_all_ptrs_in_heap_def local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
select_result_I2 set_ConsD subsetD)
next
fix x xa xb
assume 2: "(\<Union>x\<in>fset (object_ptr_kinds h3). set |h' \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h3). set |h3 \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 3: "xa |\<in>| object_ptr_kinds h3"
and 4: "x \<in> set |h' \<turnstile> get_child_nodes xa|\<^sub>r"
and 5: "xb |\<in>| document_ptr_kinds h3"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
show "False"
using disc_nodes_document_ptr_h disconnected_nodes_eq2_h3
apply(cases "document_ptr = xb")
apply (metis (no_types, lifting) "3" "4" "5" "6" CD.distinct_lists_no_parent
\<open>local.CD.a_distinct_lists h2\<close> \<open>type_wf h'\<close> children_eq2_h2 children_eq2_h3 disc_nodes_document_ptr_h2
document_ptr_kinds_eq_h3 h' local.get_disconnected_nodes_ok local.set_disconnected_nodes_get_disconnected_nodes
new_character_data_ptr_not_in_any_children object_ptr_kinds_eq_h2 object_ptr_kinds_eq_h3 returns_result_eq
returns_result_select_result set_ConsD)
by (metis "3" "4" "5" "6" CD.distinct_lists_no_parent \<open>local.CD.a_distinct_lists h3\<close> \<open>type_wf h3\<close>
children_eq2_h3 local.get_disconnected_nodes_ok returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close>
apply(simp add: CD.a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric] disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
apply (metis (no_types, lifting) document_ptr_kinds_eq_h h' list.set_intros(1)
local.set_disconnected_nodes_get_disconnected_nodes select_result_I2)
apply(simp add: object_ptr_kinds_eq_h)
by (metis (mono_tags, lifting) \<open>cast\<^sub>c\<^sub>h\<^sub>a\<^sub>r\<^sub>a\<^sub>c\<^sub>t\<^sub>e\<^sub>r\<^sub>_\<^sub>d\<^sub>a\<^sub>t\<^sub>a\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_character_data_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
children_eq2_h disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h finite_set_in h'
l_ptr_kinds_M.ptr_kinds_ptr_kinds_M
l_set_disconnected_nodes_get_disconnected_nodes.set_disconnected_nodes_get_disconnected_nodes
list.set_intros(2) local.l_set_disconnected_nodes_get_disconnected_nodes_axioms
object_ptr_kinds_M_def
select_result_I2)
have shadow_root_ptr_kinds_eq_h: "shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h"
using document_ptr_kinds_eq_h
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
using document_ptr_kinds_eq_h2
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
using document_ptr_kinds_eq_h3
by(auto simp add: shadow_root_ptr_kinds_def)
have shadow_root_eq_h: "\<And>character_data_ptr shadow_root_opt.
h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads h2 get_shadow_root_new_character_data[rotated, OF h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_character_data_ptr apply blast
using local.get_shadow_root_locs_impl new_character_data_ptr by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_val_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_val_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_disconnected_nodes_writes h'
apply(rule reads_writes_preserved)
using set_disconnected_nodes_get_shadow_root
by(auto simp add: set_disconnected_nodes_get_shadow_root)
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
by (simp add: shadow_root_eq_h3)
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h2\<close> assms(1) assms(3) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3 select_result_eq[OF shadow_root_eq_h3])
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h2"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h element_ptr_kinds_eq_h
select_result_eq[OF shadow_root_eq_h] tag_name_eq2_h)
then have "a_shadow_root_valid h3"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h2 element_ptr_kinds_eq_h2
select_result_eq[OF shadow_root_eq_h2] tag_name_eq2_h2)
then have "a_shadow_root_valid h'"
by(auto simp add: a_shadow_root_valid_def shadow_root_ptr_kinds_eq_h3 element_ptr_kinds_eq_h3
select_result_eq[OF shadow_root_eq_h3] tag_name_eq2_h3)
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h select_result_eq[OF shadow_root_eq_h])
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
have "a_host_shadow_root_rel h3 = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3 select_result_eq[OF shadow_root_eq_h3])
have "a_ptr_disconnected_node_rel h = a_ptr_disconnected_node_rel h2"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h disconnected_nodes_eq2_h)
have "a_ptr_disconnected_node_rel h2 = a_ptr_disconnected_node_rel h3"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)
have "h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3"
using h' local.set_disconnected_nodes_get_disconnected_nodes by auto
have " document_ptr |\<in>| document_ptr_kinds h3"
by (simp add: \<open>document_ptr |\<in>| document_ptr_kinds h\<close> document_ptr_kinds_eq_h document_ptr_kinds_eq_h2)
have "cast new_character_data_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r"
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3\<close> by auto
have "a_ptr_disconnected_node_rel h' = {(cast document_ptr, cast new_character_data_ptr)} \<union> a_ptr_disconnected_node_rel h3"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h3 disconnected_nodes_eq2_h3)[1]
apply(case_tac "aa = document_ptr")
using disc_nodes_h3 h' \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3\<close>
apply(auto)[1]
using disconnected_nodes_eq2_h3 apply auto[1]
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3\<close>
using \<open>cast new_character_data_ptr \<in> set |h' \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r\<close>
using \<open>document_ptr |\<in>| document_ptr_kinds h3\<close> apply auto[1]
apply(case_tac "document_ptr = aa")
using \<open>h' \<turnstile> get_disconnected_nodes document_ptr \<rightarrow>\<^sub>r cast new_character_data_ptr # disc_nodes_h3\<close> disc_nodes_h3 apply auto[1]
using disconnected_nodes_eq_h3[THEN select_result_eq, simplified] by auto
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>local.a_ptr_disconnected_node_rel h = local.a_ptr_disconnected_node_rel h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close> by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>local.a_ptr_disconnected_node_rel h2 = local.a_ptr_disconnected_node_rel h3\<close> \<open>parent_child_rel h2 = parent_child_rel h3\<close> by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast document_ptr, cast new_character_data_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h3 = local.a_host_shadow_root_rel h'\<close>
\<open>local.a_ptr_disconnected_node_rel h' = {(cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r document_ptr, cast new_character_data_ptr)} \<union>
local.a_ptr_disconnected_node_rel h3\<close> \<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "\<And>a b. (a, b) \<in> parent_child_rel h3 \<Longrightarrow> a \<noteq> cast new_character_data_ptr"
using CD.parent_child_rel_parent_in_heap \<open>parent_child_rel h = parent_child_rel h2\<close>
\<open>parent_child_rel h2 = parent_child_rel h3\<close> character_data_ptr_kinds_commutes h2 new_character_data_ptr
new_character_data_ptr_not_in_heap node_ptr_kinds_commutes by blast
moreover
have "\<And>a b. (a, b) \<in> a_host_shadow_root_rel h3 \<Longrightarrow> a \<noteq> cast new_character_data_ptr"
using shadow_root_eq_h2
by(auto simp add: a_host_shadow_root_rel_def)
moreover
have "\<And>a b. (a, b) \<in> a_ptr_disconnected_node_rel h3 \<Longrightarrow> a \<noteq> cast new_character_data_ptr"
by(auto simp add: a_ptr_disconnected_node_rel_def)
moreover
have "cast new_character_data_ptr \<notin> {x. (x, cast document_ptr) \<in>
(parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*}"
by (smt Un_iff calculation(1) calculation(2) calculation(3) cast_document_ptr_not_node_ptr(2)
converse_rtranclE mem_Collect_eq)
moreover
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2\<close>
\<open>parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3 \<union> local.a_ptr_disconnected_node_rel h3\<close>
by auto
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast document_ptr, cast new_character_data_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3\<close>)
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close>
\<open>local.CD.a_distinct_lists h'\<close> \<open>local.CD.a_owner_document_valid h'\<close>)
show " heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h' \<union> local.a_ptr_disconnected_node_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl \<open>local.CD.a_heap_is_wellformed h'\<close>
\<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close> \<open>local.a_shadow_root_valid h'\<close>)
qed
end
subsubsection \<open>create\_document\<close>
locale l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_child_nodes get_child_nodes_locs get_disconnected_nodes
get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs
+ l_new_document_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_create_document\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M
create_document
+ l_new_document_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_new_document_get_tag_name get_tag_name get_tag_name_locs
+ l_get_disconnected_nodes\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M type_wf type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_disconnected_nodes get_disconnected_nodes_locs
+ l_new_document
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_document :: "((_) heap, exception, (_) document_ptr) prog"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
begin
lemma create_document_preserves_wellformedness:
assumes "heap_is_wellformed h"
and "h \<turnstile> create_document \<rightarrow>\<^sub>h h'"
and "type_wf h"
and "known_ptrs h"
shows "heap_is_wellformed h'"
proof -
obtain new_document_ptr where
new_document_ptr: "h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr" and
h': "h \<turnstile> new_document \<rightarrow>\<^sub>h h'"
using assms(2)
apply(simp add: create_document_def)
using new_document_ok by blast
have "new_document_ptr \<notin> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have "new_document_ptr |\<notin>| document_ptr_kinds h"
using new_document_ptr DocumentMonad.ptr_kinds_ptr_kinds_M
using new_document_ptr_not_in_heap h' by blast
then have "cast new_document_ptr |\<notin>| object_ptr_kinds h"
by simp
have object_ptr_kinds_eq: "object_ptr_kinds h' = object_ptr_kinds h |\<union>| {|cast new_document_ptr|}"
using new_document_new_ptr h' new_document_ptr by blast
then have node_ptr_kinds_eq: "node_ptr_kinds h' = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h: "character_data_ptr_kinds h' = character_data_ptr_kinds h"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h: "element_ptr_kinds h' = element_ptr_kinds h"
using object_ptr_kinds_eq
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h' = document_ptr_kinds h |\<union>| {|new_document_ptr|}"
using object_ptr_kinds_eq
apply(auto simp add: document_ptr_kinds_def)[1]
by (metis (no_types, lifting) document_ptr_kinds_commutes document_ptr_kinds_def finsertI1 fset.map_comp)
have children_eq:
"\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h' get_child_nodes_new_document[rotated, OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2: "\<And>ptr'. ptr' \<noteq> cast new_document_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []"
using new_document_ptr h' new_document_ptr_in_heap[OF h' new_document_ptr]
new_document_is_document_ptr[OF new_document_ptr] new_document_no_child_nodes
by blast
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes = h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using CD.get_disconnected_nodes_reads h' get_disconnected_nodes_new_document_different_pointers new_document_ptr
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis(full_types) \<open>\<And>thesis. (\<And>new_document_ptr.
\<lbrakk>h \<turnstile> new_document \<rightarrow>\<^sub>r new_document_ptr; h \<turnstile> new_document \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
local.get_disconnected_nodes_new_document_different_pointers new_document_ptr)+
then have disconnected_nodes_eq2_h: "\<And>doc_ptr. doc_ptr \<noteq> new_document_ptr
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
using h' local.new_document_no_disconnected_nodes new_document_ptr by blast
have "type_wf h'"
using \<open>type_wf h\<close> new_document_types_preserved h' by blast
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (auto simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h'"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h'"
by (simp add: object_ptr_kinds_eq)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h'"
and 1: "x \<in> set |h' \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 empty_iff empty_set image_eqI select_result_I2)
qed
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def )
then have "CD.a_all_ptrs_in_heap h'"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close> assms(1) children_eq fset_of_list_elem
local.heap_is_wellformed_children_in_heap CD.parent_child_rel_child
CD.parent_child_rel_parent_in_heap node_ptr_kinds_eq
apply (metis (no_types, lifting) \<open>h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2 finite_set_in finsert_iff funion_finsert_right object_ptr_kinds_eq
select_result_I2 subsetD sup_bot.right_neutral)
by (metis (no_types, lifting) \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close> \<open>type_wf h'\<close>
assms(1) disconnected_nodes_eq_h empty_iff empty_set local.get_disconnected_nodes_ok
local.heap_is_wellformed_disc_nodes_in_heap node_ptr_kinds_eq returns_result_select_result select_result_I2)
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h'"
using \<open>h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []\<close>
\<open>h' \<turnstile> get_child_nodes (cast new_document_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: children_eq2[symmetric] CD.a_distinct_lists_def insort_split object_ptr_kinds_eq
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(auto simp add: dest: distinct_concat_map_E)[1]
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close>
apply(auto simp add: distinct_insort dest: distinct_concat_map_E)[1]
apply (metis assms(1) assms(3) disconnected_nodes_eq2_h get_disconnected_nodes_ok
local.heap_is_wellformed_disconnected_nodes_distinct
returns_result_select_result)
proof -
fix x :: "(_) document_ptr" and y :: "(_) document_ptr" and xa :: "(_) node_ptr"
assume a1: "x \<noteq> y"
assume a2: "x |\<in>| document_ptr_kinds h"
assume a3: "x \<noteq> new_document_ptr"
assume a4: "y |\<in>| document_ptr_kinds h"
assume a5: "y \<noteq> new_document_ptr"
assume a6: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
assume a7: "xa \<in> set |h' \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a8: "xa \<in> set |h' \<turnstile> get_disconnected_nodes y|\<^sub>r"
have f9: "xa \<in> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a7 a3 disconnected_nodes_eq2_h by presburger
have f10: "xa \<in> set |h \<turnstile> get_disconnected_nodes y|\<^sub>r"
using a8 a5 disconnected_nodes_eq2_h by presburger
have f11: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a4 by simp
have "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a2 by simp
then show False
using f11 f10 f9 a6 a1 by (meson disjoint_iff_not_equal distinct_concat_map_E(1))
next
fix x xa xb
assume 0: "h' \<turnstile> get_disconnected_nodes new_document_ptr \<rightarrow>\<^sub>r []"
and 1: "h' \<turnstile> get_child_nodes (cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr) \<rightarrow>\<^sub>r []"
and 2: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
and 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
and 4: "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h). set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 5: "x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r"
and 6: "x \<in> set |h' \<turnstile> get_disconnected_nodes xb|\<^sub>r"
and 7: "xa |\<in>| object_ptr_kinds h"
and 8: "xa \<noteq> cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr"
and 9: "xb |\<in>| document_ptr_kinds h"
and 10: "xb \<noteq> new_document_ptr"
then show "False"
by (metis \<open>CD.a_distinct_lists h\<close> assms(3) disconnected_nodes_eq2_h
CD.distinct_lists_no_parent get_disconnected_nodes_ok
returns_result_select_result)
qed
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
apply(auto simp add: CD.a_owner_document_valid_def)[1]
by (metis \<open>cast\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_document_ptr |\<notin>| object_ptr_kinds h\<close>
children_eq2 disconnected_nodes_eq2_h document_ptr_kinds_commutes finite_set_in funion_iff
node_ptr_kinds_eq object_ptr_kinds_eq)
have shadow_root_eq_h: "\<And>character_data_ptr shadow_root_opt. h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h' \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads assms(2) get_shadow_root_new_document[rotated, OF h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_document_ptr apply blast
using local.get_shadow_root_locs_impl new_document_ptr by blast
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_def document_ptr_kinds_eq_h)[1]
using shadow_root_eq_h by fastforce
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h'\<close> assms(1) assms(3) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h'
get_tag_name_new_document[OF new_document_ptr h']
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_shadow_root_valid h'"
using new_document_is_document_ptr[OF new_document_ptr]
by(auto simp add: a_shadow_root_valid_def element_ptr_kinds_eq_h document_ptr_kinds_eq_h
shadow_root_ptr_kinds_def select_result_eq[OF shadow_root_eq_h] select_result_eq[OF tag_name_eq_h]
is_shadow_root_ptr_kind\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def is_document_ptr\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r_def
split: option.splits)
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h'"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h select_result_eq[OF shadow_root_eq_h])
have "a_ptr_disconnected_node_rel h = a_ptr_disconnected_node_rel h'"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h disconnected_nodes_eq2_h)[1]
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close> disconnected_nodes_eq2_h apply fastforce
using new_document_disconnected_nodes[OF h' new_document_ptr]
apply(simp add: CD.get_disconnected_nodes_impl CD.a_get_disconnected_nodes_def)
using \<open>new_document_ptr |\<notin>| document_ptr_kinds h\<close> disconnected_nodes_eq2_h apply fastforce
done
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
moreover
have "parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h =
parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h'"
by (simp add: \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h'\<close>
\<open>local.a_ptr_disconnected_node_rel h = local.a_ptr_disconnected_node_rel h'\<close>
\<open>parent_child_rel h = parent_child_rel h'\<close>)
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by simp
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close>
\<open>local.CD.a_distinct_lists h'\<close> \<open>local.CD.a_owner_document_valid h'\<close>)
show "heap_is_wellformed h'"
using CD.heap_is_wellformed_impl \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h' \<union>
local.a_ptr_disconnected_node_rel h')\<close> \<open>local.CD.a_heap_is_wellformed h'\<close> \<open>local.a_all_ptrs_in_heap h'\<close>
\<open>local.a_distinct_lists h'\<close> \<open>local.a_shadow_root_valid h'\<close> local.heap_is_wellformed_def by auto
qed
end
interpretation l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr type_wf DocumentClass.type_wf get_child_nodes
get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs get_shadow_root
get_shadow_root_locs get_tag_name get_tag_name_locs
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs
heap_is_wellformed parent_child_rel set_val set_val_locs set_disconnected_nodes set_disconnected_nodes_locs
create_document known_ptrs
by(auto simp add: l_create_document_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
subsubsection \<open>attach\_shadow\_root\<close>
locale l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M =
l_get_disconnected_nodes
type_wf get_disconnected_nodes get_disconnected_nodes_locs
+ l_heap_is_wellformed\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
get_shadow_root get_shadow_root_locs get_tag_name get_tag_name_locs known_ptr type_wf
heap_is_wellformed parent_child_rel
heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document get_disconnected_document_locs
+ l_attach_shadow_root\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr set_shadow_root set_shadow_root_locs set_mode set_mode_locs
attach_shadow_root type_wf get_tag_name get_tag_name_locs get_shadow_root get_shadow_root_locs
+ l_new_shadow_root_get_disconnected_nodes
get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_mode_get_disconnected_nodes
type_wf set_mode set_mode_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_new_shadow_root_get_child_nodes
type_wf known_ptr get_child_nodes get_child_nodes_locs
+ l_new_shadow_root_get_tag_name
type_wf get_tag_name get_tag_name_locs
+ l_set_mode_get_child_nodes
type_wf set_mode set_mode_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_shadow_root_get_child_nodes
type_wf set_shadow_root set_shadow_root_locs known_ptr get_child_nodes get_child_nodes_locs
+ l_set_shadow_root
type_wf set_shadow_root set_shadow_root_locs
+ l_set_shadow_root_get_disconnected_nodes
set_shadow_root set_shadow_root_locs get_disconnected_nodes get_disconnected_nodes_locs
+ l_set_mode_get_shadow_root type_wf set_mode set_mode_locs get_shadow_root get_shadow_root_locs
+ l_set_shadow_root_get_shadow_root type_wf set_shadow_root set_shadow_root_locs
get_shadow_root get_shadow_root_locs
+ l_new_character_data_get_tag_name
get_tag_name get_tag_name_locs
+ l_set_mode_get_tag_name type_wf set_mode set_mode_locs get_tag_name get_tag_name_locs
+ l_get_tag_name type_wf get_tag_name get_tag_name_locs
+ l_set_shadow_root_get_tag_name set_shadow_root set_shadow_root_locs get_tag_name get_tag_name_locs
+ l_new_shadow_root
type_wf
+ l_known_ptrs
known_ptr known_ptrs
for known_ptr :: "(_::linorder) object_ptr \<Rightarrow> bool"
and known_ptrs :: "(_) heap \<Rightarrow> bool"
and type_wf :: "(_) heap \<Rightarrow> bool"
and get_child_nodes :: "(_) object_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_child_nodes_locs :: "(_) object_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_nodes :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, (_) node_ptr list) prog"
and get_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed :: "(_) heap \<Rightarrow> bool"
and parent_child_rel :: "(_) heap \<Rightarrow> ((_) object_ptr \<times> (_) object_ptr) set"
and set_tag_name :: "(_) element_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and set_disconnected_nodes :: "(_) document_ptr \<Rightarrow> (_) node_ptr list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_disconnected_nodes_locs :: "(_) document_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_element :: "(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_shadow_root :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, (_) shadow_root_ptr option) prog"
and get_shadow_root_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_tag_name :: "(_) element_ptr \<Rightarrow> ((_) heap, exception, char list) prog"
and get_tag_name_locs :: "(_) element_ptr \<Rightarrow> ((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and get_host :: "(_) shadow_root_ptr \<Rightarrow> ((_) heap, exception, (_) element_ptr) prog"
and get_host_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and get_disconnected_document :: "(_) node_ptr \<Rightarrow> ((_) heap, exception, (_) document_ptr) prog"
and get_disconnected_document_locs :: "((_) heap \<Rightarrow> (_) heap \<Rightarrow> bool) set"
and set_val :: "(_) character_data_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, unit) prog"
and set_val_locs :: "(_) character_data_ptr \<Rightarrow> ((_) heap, exception, unit) prog set"
and create_character_data ::
"(_) document_ptr \<Rightarrow> char list \<Rightarrow> ((_) heap, exception, (_) character_data_ptr) prog"
and known_ptr\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_::linorder) object_ptr \<Rightarrow> bool"
and type_wf\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M :: "(_) heap \<Rightarrow> bool"
and set_shadow_root :: "(_) element_ptr \<Rightarrow> (_) shadow_root_ptr option \<Rightarrow> (_, unit) dom_prog"
and set_shadow_root_locs :: "(_) element_ptr \<Rightarrow> (_, unit) dom_prog set"
and set_mode :: "(_) shadow_root_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, unit) dom_prog"
and set_mode_locs :: "(_) shadow_root_ptr \<Rightarrow> (_, unit) dom_prog set"
and attach_shadow_root :: "(_) element_ptr \<Rightarrow> shadow_root_mode \<Rightarrow> (_, (_) shadow_root_ptr) dom_prog"
begin
lemma attach_shadow_root_child_preserves:
assumes "heap_is_wellformed h" and "type_wf h" and "known_ptrs h"
assumes "h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>h h'"
shows "type_wf h'" and "known_ptrs h'" and "heap_is_wellformed h'"
proof -
obtain h2 h3 new_shadow_root_ptr element_tag_name where
element_tag_name: "h \<turnstile> get_tag_name element_ptr \<rightarrow>\<^sub>r element_tag_name" and
"element_tag_name \<in> safe_shadow_root_element_types" and
prev_shadow_root: "h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r None" and
h2: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2" and
new_shadow_root_ptr: "h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr" and
h3: "h2 \<turnstile> set_mode new_shadow_root_ptr new_mode \<rightarrow>\<^sub>h h3" and
h': "h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'"
using assms(4)
by(auto simp add: attach_shadow_root_def elim!: bind_returns_heap_E
bind_returns_heap_E2[rotated, OF get_tag_name_pure, rotated]
bind_returns_heap_E2[rotated, OF get_shadow_root_pure, rotated] split: if_splits)
have "h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr"
thm bind_pure_returns_result_I[OF get_tag_name_pure]
apply(unfold attach_shadow_root_def)[1]
using element_tag_name
apply(rule bind_pure_returns_result_I[OF get_tag_name_pure])
apply(rule bind_pure_returns_result_I)
using \<open>element_tag_name \<in> safe_shadow_root_element_types\<close> apply(simp)
using \<open>element_tag_name \<in> safe_shadow_root_element_types\<close> apply(simp)
using prev_shadow_root
apply(rule bind_pure_returns_result_I[OF get_shadow_root_pure])
apply(rule bind_pure_returns_result_I)
apply(simp)
apply(simp)
using h2 new_shadow_root_ptr h3 h'
by(auto intro!: bind_returns_result_I intro: is_OK_returns_result_E[OF is_OK_returns_heap_I[OF h3]]
is_OK_returns_result_E[OF is_OK_returns_heap_I[OF h']])
have "new_shadow_root_ptr \<notin> set |h \<turnstile> shadow_root_ptr_kinds_M|\<^sub>r"
using new_shadow_root_ptr ShadowRootMonad.ptr_kinds_ptr_kinds_M h2
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap by blast
then have "cast new_shadow_root_ptr \<notin> set |h \<turnstile> document_ptr_kinds_M|\<^sub>r"
by simp
then have "cast new_shadow_root_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r"
by simp
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_new_ptr h2 new_shadow_root_ptr by blast
then have document_ptr_kinds_eq_h:
"document_ptr_kinds h2 = document_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
apply(simp add: document_ptr_kinds_def)
by force
then have shadow_root_ptr_kinds_eq_h:
"shadow_root_ptr_kinds h2 = shadow_root_ptr_kinds h |\<union>| {|new_shadow_root_ptr|}"
apply(simp add: shadow_root_ptr_kinds_def)
by force
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_mode_writes h3])
using set_mode_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
then have shadow_root_ptr_kinds_eq_h2: "shadow_root_ptr_kinds h3 = shadow_root_ptr_kinds h2"
by (auto simp add: shadow_root_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_shadow_root_writes h'])
using set_shadow_root_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
then have shadow_root_ptr_kinds_eq_h3: "shadow_root_ptr_kinds h' = shadow_root_ptr_kinds h3"
by (auto simp add: shadow_root_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
have "known_ptr (cast new_shadow_root_ptr)"
using \<open>h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr\<close> create_shadow_root_known_ptr
by blast
then
have "known_ptrs h2"
using known_ptrs_new_ptr object_ptr_kinds_eq_h \<open>known_ptrs h\<close> h2
by blast
then
have "known_ptrs h3"
using known_ptrs_preserved object_ptr_kinds_eq_h2 by blast
then
show "known_ptrs h'"
using known_ptrs_preserved object_ptr_kinds_eq_h3 by blast
have "element_ptr |\<in>| element_ptr_kinds h"
by (meson \<open>h \<turnstile> attach_shadow_root element_ptr new_mode \<rightarrow>\<^sub>r new_shadow_root_ptr\<close> is_OK_returns_result_I
local.attach_shadow_root_element_ptr_in_heap)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_shadow_root[rotated, OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h:
"\<And>ptr'. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have object_ptr_kinds_eq_h:
"object_ptr_kinds h2 = object_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_new_ptr h2 new_shadow_root_ptr object_ptr_kinds_eq_h by blast
then have node_ptr_kinds_eq_h:
"node_ptr_kinds h2 = node_ptr_kinds h"
apply(simp add: node_ptr_kinds_def)
by force
then have character_data_ptr_kinds_eq_h:
"character_data_ptr_kinds h2 = character_data_ptr_kinds h"
apply(simp add: character_data_ptr_kinds_def)
done
have element_ptr_kinds_eq_h: "element_ptr_kinds h2 = element_ptr_kinds h"
using object_ptr_kinds_eq_h
by(auto simp add: node_ptr_kinds_def element_ptr_kinds_def)
have document_ptr_kinds_eq_h: "document_ptr_kinds h2 = document_ptr_kinds h |\<union>| {|cast new_shadow_root_ptr|}"
using object_ptr_kinds_eq_h
apply(auto simp add: document_ptr_kinds_def)[1]
by (metis (full_types) document_ptr_kinds_def document_ptr_kinds_eq_h finsert_fsubset fset.map_comp funion_upper2)
have object_ptr_kinds_eq_h2: "object_ptr_kinds h3 = object_ptr_kinds h2"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_mode_writes h3])
using set_mode_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h2: "document_ptr_kinds h3 = document_ptr_kinds h2"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h2: "node_ptr_kinds h3 = node_ptr_kinds h2"
using object_ptr_kinds_eq_h2
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h2: "character_data_ptr_kinds h3 = character_data_ptr_kinds h2"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h2: "element_ptr_kinds h3 = element_ptr_kinds h2"
using node_ptr_kinds_eq_h2
by(simp add: element_ptr_kinds_def)
have object_ptr_kinds_eq_h3: "object_ptr_kinds h' = object_ptr_kinds h3"
apply(rule writes_small_big[where P="\<lambda>h h'. object_ptr_kinds h' = object_ptr_kinds h",
OF set_shadow_root_writes h'])
using set_shadow_root_pointers_preserved
by (auto simp add: reflp_def transp_def)
then have document_ptr_kinds_eq_h3: "document_ptr_kinds h' = document_ptr_kinds h3"
by (auto simp add: document_ptr_kinds_def)
have node_ptr_kinds_eq_h3: "node_ptr_kinds h' = node_ptr_kinds h3"
using object_ptr_kinds_eq_h3
by(auto simp add: node_ptr_kinds_def)
then have character_data_ptr_kinds_eq_h3: "character_data_ptr_kinds h' = character_data_ptr_kinds h3"
by(simp add: character_data_ptr_kinds_def)
have element_ptr_kinds_eq_h3: "element_ptr_kinds h' = element_ptr_kinds h3"
using node_ptr_kinds_eq_h3
by(simp add: element_ptr_kinds_def)
have children_eq_h: "\<And>(ptr'::(_) object_ptr) children. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads h2 get_child_nodes_new_shadow_root[rotated, OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have children_eq2_h: "\<And>ptr'. ptr' \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> |h \<turnstile> get_child_nodes ptr'|\<^sub>r = |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
using h2 local.new_shadow_root_no_child_nodes new_shadow_root_ptr by auto
have disconnected_nodes_eq_h:
"\<And>doc_ptr disc_nodes. doc_ptr \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> h \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads h2
get_disconnected_nodes_new_shadow_root_different_pointers[rotated, OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by (metis (no_types, lifting))+
then have disconnected_nodes_eq2_h:
"\<And>doc_ptr. doc_ptr \<noteq> cast new_shadow_root_ptr
\<Longrightarrow> |h \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have "h2 \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
using h2 new_shadow_root_no_disconnected_nodes new_shadow_root_ptr by auto
have tag_name_eq_h:
"\<And>ptr' disc_nodes. h \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads h2
get_tag_name_new_shadow_root[OF new_shadow_root_ptr h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
by blast+
then have tag_name_eq2_h: "\<And>ptr'. |h \<turnstile> get_tag_name ptr'|\<^sub>r = |h2 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have children_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_child_nodes)
then have children_eq2_h2:
"\<And>ptr'. |h2 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h2:
"\<And>doc_ptr disc_nodes. h2 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_disconnected_nodes)
then have disconnected_nodes_eq2_h2:
"\<And>doc_ptr. |h2 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h2:
"\<And>ptr' disc_nodes. h2 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_tag_name)
then have tag_name_eq2_h2: "\<And>ptr'. |h2 \<turnstile> get_tag_name ptr'|\<^sub>r = |h3 \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "type_wf h2"
using \<open>type_wf h\<close> new_shadow_root_types_preserved h2 by blast
then have "type_wf h3"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_mode_writes h3]
using set_mode_types_preserved
by(auto simp add: reflp_def transp_def)
then show "type_wf h'"
using writes_small_big[where P="\<lambda>h h'. type_wf h \<longrightarrow> type_wf h'", OF set_shadow_root_writes h']
using set_shadow_root_types_preserved
by(auto simp add: reflp_def transp_def)
have children_eq_h3:
"\<And>ptr' children. h3 \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_child_nodes ptr' \<rightarrow>\<^sub>r children"
using CD.get_child_nodes_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_child_nodes)
then have children_eq2_h3:
" \<And>ptr'. |h3 \<turnstile> get_child_nodes ptr'|\<^sub>r = |h' \<turnstile> get_child_nodes ptr'|\<^sub>r"
using select_result_eq by force
have disconnected_nodes_eq_h3: "\<And>doc_ptr disc_nodes. h3 \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_disconnected_nodes doc_ptr \<rightarrow>\<^sub>r disc_nodes"
using get_disconnected_nodes_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_disconnected_nodes)
then have disconnected_nodes_eq2_h3: "\<And>doc_ptr. |h3 \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r = |h' \<turnstile> get_disconnected_nodes doc_ptr|\<^sub>r"
using select_result_eq by force
have tag_name_eq_h3:
"\<And>ptr' disc_nodes. h3 \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes
= h' \<turnstile> get_tag_name ptr' \<rightarrow>\<^sub>r disc_nodes"
using get_tag_name_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_tag_name)
then have tag_name_eq2_h3: "\<And>ptr'. |h3 \<turnstile> get_tag_name ptr'|\<^sub>r = |h' \<turnstile> get_tag_name ptr'|\<^sub>r"
using select_result_eq by force
have "acyclic (parent_child_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def CD.acyclic_heap_def)
also have "parent_child_rel h = parent_child_rel h2"
proof(auto simp add: CD.parent_child_rel_def)[1]
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h2"
by (simp add: object_ptr_kinds_eq_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h"
and 1: "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
by (metis ObjectMonad.ptr_kinds_ptr_kinds_M
\<open>cast new_shadow_root_ptr \<notin> set |h \<turnstile> object_ptr_kinds_M|\<^sub>r\<close> children_eq2_h)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "a |\<in>| object_ptr_kinds h"
using object_ptr_kinds_eq_h \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto)
next
fix a x
assume 0: "a |\<in>| object_ptr_kinds h2"
and 1: "x \<in> set |h2 \<turnstile> get_child_nodes a|\<^sub>r"
then show "x \<in> set |h \<turnstile> get_child_nodes a|\<^sub>r"
by (metis (no_types, lifting) \<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
children_eq2_h empty_iff empty_set image_eqI select_result_I2)
qed
also have "\<dots> = parent_child_rel h3"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h2 children_eq2_h2)
also have "\<dots> = parent_child_rel h'"
by(auto simp add: CD.parent_child_rel_def object_ptr_kinds_eq_h3 children_eq2_h3)
finally have "CD.a_acyclic_heap h'"
by (simp add: CD.acyclic_heap_def)
have "CD.a_all_ptrs_in_heap h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_all_ptrs_in_heap h2"
apply(auto simp add: CD.a_all_ptrs_in_heap_def)[1]
using node_ptr_kinds_eq_h
\<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
apply (metis (no_types, lifting) CD.get_child_nodes_ok CD.l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms \<open>known_ptrs h2\<close>
\<open>parent_child_rel h = parent_child_rel h2\<close> \<open>type_wf h2\<close> assms(1) assms(2) l_heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M.parent_child_rel_child
local.known_ptrs_known_ptr local.parent_child_rel_child_in_heap node_ptr_kinds_commutes returns_result_select_result)
by (metis (no_types, opaque_lifting) \<open>h2 \<turnstile> get_disconnected_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>type_wf h2\<close> disconnected_nodes_eq_h empty_iff finite_set_in is_OK_returns_result_E is_OK_returns_result_I
local.get_disconnected_nodes_ok local.get_disconnected_nodes_ptr_in_heap node_ptr_kinds_eq_h select_result_I2
set_empty subset_code(1))
then have "CD.a_all_ptrs_in_heap h3"
by (simp add: children_eq2_h2 disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h2 object_ptr_kinds_eq_h2)
then have "CD.a_all_ptrs_in_heap h'"
by (simp add: children_eq2_h3 disconnected_nodes_eq2_h3 document_ptr_kinds_eq_h3
CD.a_all_ptrs_in_heap_def node_ptr_kinds_eq_h3 object_ptr_kinds_eq_h3)
have "cast new_shadow_root_ptr |\<notin>| document_ptr_kinds h"
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap new_shadow_root_ptr shadow_root_ptr_kinds_commutes by blast
have "CD.a_distinct_lists h"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_distinct_lists h2"
using \<open>h2 \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
\<open>h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
apply(auto simp add: children_eq2_h[symmetric] CD.a_distinct_lists_def insort_split object_ptr_kinds_eq_h
document_ptr_kinds_eq_h disconnected_nodes_eq2_h intro!: distinct_concat_map_I)[1]
apply (metis distinct_sorted_list_of_set finite_fset sorted_list_of_set_insert_remove)
apply(auto simp add: dest: distinct_concat_map_E)[1]
apply(auto simp add: dest: distinct_concat_map_E)[1]
using \<open>cast new_shadow_root_ptr |\<notin>| document_ptr_kinds h\<close>
apply(auto simp add: distinct_insort dest: distinct_concat_map_E)[1]
apply (metis (no_types) DocumentMonad.ptr_kinds_M_ptr_kinds DocumentMonad.ptr_kinds_ptr_kinds_M
concat_map_all_distinct disconnected_nodes_eq2_h select_result_I2)
proof -
fix x :: "(_) document_ptr" and y :: "(_) document_ptr" and xa :: "(_) node_ptr"
assume a1: "x \<noteq> y"
assume a2: "x |\<in>| document_ptr_kinds h"
assume a3: "x \<noteq> cast new_shadow_root_ptr"
assume a4: "y |\<in>| document_ptr_kinds h"
assume a5: "y \<noteq> cast new_shadow_root_ptr"
assume a6: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
assume a7: "xa \<in> set |h2 \<turnstile> get_disconnected_nodes x|\<^sub>r"
assume a8: "xa \<in> set |h2 \<turnstile> get_disconnected_nodes y|\<^sub>r"
have f9: "xa \<in> set |h \<turnstile> get_disconnected_nodes x|\<^sub>r"
using a7 a3 disconnected_nodes_eq2_h
by (simp add: disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)
have f10: "xa \<in> set |h \<turnstile> get_disconnected_nodes y|\<^sub>r"
using a8 a5 disconnected_nodes_eq2_h
by (simp add: disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)
have f11: "y \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a4 by simp
have "x \<in> set (sorted_list_of_set (fset (document_ptr_kinds h)))"
using a2 by simp
then show False
using f11 f10 f9 a6 a1 by (meson disjoint_iff_not_equal distinct_concat_map_E(1))
next
fix x xa xb
assume 0: "h2 \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
and 1: "h2 \<turnstile> get_child_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []"
and 2: "distinct (concat (map (\<lambda>ptr. |h \<turnstile> get_child_nodes ptr|\<^sub>r)
(sorted_list_of_set (fset (object_ptr_kinds h)))))"
and 3: "distinct (concat (map (\<lambda>document_ptr. |h \<turnstile> get_disconnected_nodes document_ptr|\<^sub>r)
(sorted_list_of_set (fset (document_ptr_kinds h)))))"
and 4: "(\<Union>x\<in>fset (object_ptr_kinds h). set |h \<turnstile> get_child_nodes x|\<^sub>r)
\<inter> (\<Union>x\<in>fset (document_ptr_kinds h). set |h \<turnstile> get_disconnected_nodes x|\<^sub>r) = {}"
and 5: "x \<in> set |h \<turnstile> get_child_nodes xa|\<^sub>r"
and 6: "x \<in> set |h2 \<turnstile> get_disconnected_nodes xb|\<^sub>r"
and 7: "xa |\<in>| object_ptr_kinds h"
and 8: "xa \<noteq> cast new_shadow_root_ptr"
and 9: "xb |\<in>| document_ptr_kinds h"
and 10: "xb \<noteq> cast new_shadow_root_ptr"
then show "False"
by (metis CD.distinct_lists_no_parent \<open>local.CD.a_distinct_lists h\<close> assms(2) disconnected_nodes_eq2_h
local.get_disconnected_nodes_ok returns_result_select_result)
qed
then have "CD.a_distinct_lists h3"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h2 document_ptr_kinds_eq_h2
children_eq2_h2 object_ptr_kinds_eq_h2)[1]
then have "CD.a_distinct_lists h'"
by(auto simp add: CD.a_distinct_lists_def disconnected_nodes_eq2_h3 children_eq2_h3
object_ptr_kinds_eq_h3 document_ptr_kinds_eq_h3 intro!: distinct_concat_map_I)
have "CD.a_owner_document_valid h"
using \<open>heap_is_wellformed h\<close> by (simp add: heap_is_wellformed_def CD.heap_is_wellformed_def)
then have "CD.a_owner_document_valid h'"
(* using disc_nodes_h3 \<open>document_ptr |\<in>| document_ptr_kinds h\<close> *)
apply(simp add: CD.a_owner_document_valid_def)
apply(simp add: object_ptr_kinds_eq_h object_ptr_kinds_eq_h3 )
apply(simp add: object_ptr_kinds_eq_h2)
apply(simp add: document_ptr_kinds_eq_h document_ptr_kinds_eq_h3 )
apply(simp add: document_ptr_kinds_eq_h2)
apply(simp add: node_ptr_kinds_eq_h node_ptr_kinds_eq_h3 )
apply(simp add: node_ptr_kinds_eq_h2 node_ptr_kinds_eq_h )
apply(auto simp add: children_eq2_h2[symmetric] children_eq2_h3[symmetric] disconnected_nodes_eq2_h
disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3)[1]
by (metis CD.get_child_nodes_ok CD.get_child_nodes_ptr_in_heap
\<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr |\<notin>| document_ptr_kinds h\<close> assms(2) assms(3) children_eq2_h
children_eq_h disconnected_nodes_eq2_h disconnected_nodes_eq2_h2 disconnected_nodes_eq2_h3
document_ptr_kinds_commutes finite_set_in is_OK_returns_result_I local.known_ptrs_known_ptr
returns_result_select_result)
have shadow_root_eq_h: "\<And>character_data_ptr shadow_root_opt. h \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt =
h2 \<turnstile> get_shadow_root character_data_ptr \<rightarrow>\<^sub>r shadow_root_opt"
using get_shadow_root_reads h2 get_shadow_root_new_shadow_root[rotated, OF h2]
apply(auto simp add: reads_def reflp_def transp_def preserved_def)[1]
using local.get_shadow_root_locs_impl new_shadow_root_ptr apply blast
using local.get_shadow_root_locs_impl new_shadow_root_ptr by blast
have shadow_root_eq_h2:
"\<And>ptr' children. h2 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_mode_writes h3
apply(rule reads_writes_preserved)
by(auto simp add: set_mode_get_shadow_root)
have shadow_root_eq_h3:
"\<And>ptr' children. element_ptr \<noteq> ptr' \<Longrightarrow> h3 \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children = h' \<turnstile> get_shadow_root ptr' \<rightarrow>\<^sub>r children"
using get_shadow_root_reads set_shadow_root_writes h'
apply(rule reads_writes_preserved)
by(auto simp add: set_shadow_root_get_shadow_root_different_pointers)
have shadow_root_h3: "h' \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r Some new_shadow_root_ptr"
using \<open>type_wf h3\<close> h' local.set_shadow_root_get_shadow_root by blast
have "a_all_ptrs_in_heap h"
by (simp add: assms(1) local.a_all_ptrs_in_heap_def local.get_shadow_root_shadow_root_ptr_in_heap)
then have "a_all_ptrs_in_heap h2"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h)[1]
using returns_result_eq shadow_root_eq_h by fastforce
then have "a_all_ptrs_in_heap h3"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h2)[1]
using shadow_root_eq_h2 by blast
then have "a_all_ptrs_in_heap h'"
apply(auto simp add: a_all_ptrs_in_heap_def shadow_root_ptr_kinds_eq_h3)[1]
apply(case_tac "shadow_root_ptr = new_shadow_root_ptr")
using h2 new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_in_heap new_shadow_root_ptr shadow_root_ptr_kinds_eq_h2
apply blast
using \<open>type_wf h3\<close> h' local.set_shadow_root_get_shadow_root returns_result_eq shadow_root_eq_h3
apply fastforce
done
have "a_distinct_lists h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then have "a_distinct_lists h2"
apply(auto simp add: a_distinct_lists_def character_data_ptr_kinds_eq_h)[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (metis \<open>type_wf h2\<close> assms(1) assms(2) local.get_shadow_root_ok local.shadow_root_same_host
returns_result_select_result shadow_root_eq_h)
then have "a_distinct_lists h3"
by(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
then have "a_distinct_lists h'"
apply(auto simp add: a_distinct_lists_def element_ptr_kinds_eq_h3 select_result_eq[OF shadow_root_eq_h3])[1]
apply(auto simp add: distinct_insort intro!: distinct_concat_map_I split: option.splits)[1]
by (smt \<open>type_wf h3\<close> assms(1) assms(2) h' h2 local.get_shadow_root_ok
local.get_shadow_root_shadow_root_ptr_in_heap local.set_shadow_root_get_shadow_root local.shadow_root_same_host
new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M_ptr_not_in_heap new_shadow_root_ptr returns_result_select_result select_result_I2 shadow_root_eq_h
shadow_root_eq_h2 shadow_root_eq_h3)
have "a_shadow_root_valid h"
using assms(1)
by (simp add: heap_is_wellformed_def)
then
have "a_shadow_root_valid h'"
proof(unfold a_shadow_root_valid_def; safe)
fix shadow_root_ptr
assume "\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
assume "a_shadow_root_valid h"
assume "shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h')"
show "\<exists>host\<in>fset (element_ptr_kinds h'). |h' \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and>
|h' \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
proof (cases "shadow_root_ptr = new_shadow_root_ptr")
case True
have "element_ptr \<in> fset (element_ptr_kinds h')"
by (simp add: \<open>element_ptr |\<in>| element_ptr_kinds h\<close> element_ptr_kinds_eq_h element_ptr_kinds_eq_h2
element_ptr_kinds_eq_h3)
moreover have "|h' \<turnstile> get_tag_name element_ptr|\<^sub>r \<in> safe_shadow_root_element_types"
by (smt \<open>\<And>thesis. (\<And>h2 h3 new_shadow_root_ptr element_tag_name. \<lbrakk>h \<turnstile> get_tag_name element_ptr \<rightarrow>\<^sub>r element_tag_name;
element_tag_name \<in> safe_shadow_root_element_types; h \<turnstile> get_shadow_root element_ptr \<rightarrow>\<^sub>r None; h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>h h2;
h \<turnstile> new\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>R\<^sub>o\<^sub>o\<^sub>t_M \<rightarrow>\<^sub>r new_shadow_root_ptr; h2 \<turnstile> set_mode new_shadow_root_ptr new_mode \<rightarrow>\<^sub>h h3;
h3 \<turnstile> set_shadow_root element_ptr (Some new_shadow_root_ptr) \<rightarrow>\<^sub>h h'\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
select_result_I2 tag_name_eq2_h tag_name_eq2_h2 tag_name_eq2_h3)
moreover have "|h' \<turnstile> get_shadow_root element_ptr|\<^sub>r = Some shadow_root_ptr"
using shadow_root_h3
by (simp add: True)
ultimately
show ?thesis
by meson
next
case False
then obtain host where host: "host \<in> fset (element_ptr_kinds h)" and
"|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types" and
"|h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr"
using \<open>shadow_root_ptr \<in> fset (shadow_root_ptr_kinds h')\<close>
using \<open>\<forall>shadow_root_ptr\<in>fset (shadow_root_ptr_kinds h). \<exists>host\<in>fset (element_ptr_kinds h).
|h \<turnstile> get_tag_name host|\<^sub>r \<in> safe_shadow_root_element_types \<and> |h \<turnstile> get_shadow_root host|\<^sub>r = Some shadow_root_ptr\<close>
apply(simp add: shadow_root_ptr_kinds_eq_h3 shadow_root_ptr_kinds_eq_h2 shadow_root_ptr_kinds_eq_h)
by (meson finite_set_in)
moreover have "host \<noteq> element_ptr"
using calculation(3) prev_shadow_root by auto
ultimately show ?thesis
using element_ptr_kinds_eq_h3 element_ptr_kinds_eq_h2 element_ptr_kinds_eq_h
by (smt \<open>type_wf h'\<close> assms(2) finite_set_in local.get_shadow_root_ok returns_result_eq
returns_result_select_result shadow_root_eq_h shadow_root_eq_h2 shadow_root_eq_h3 tag_name_eq2_h
tag_name_eq2_h2 tag_name_eq2_h3)
qed
qed
have "a_host_shadow_root_rel h = a_host_shadow_root_rel h2"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h select_result_eq[OF shadow_root_eq_h])
have "a_host_shadow_root_rel h2 = a_host_shadow_root_rel h3"
by(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h2 select_result_eq[OF shadow_root_eq_h2])
have "a_host_shadow_root_rel h' = {(cast element_ptr, cast new_shadow_root_ptr)} \<union> a_host_shadow_root_rel h3"
apply(auto simp add: a_host_shadow_root_rel_def element_ptr_kinds_eq_h3 )[1]
apply(case_tac "element_ptr \<noteq> aa")
using select_result_eq[OF shadow_root_eq_h3] apply (simp add: image_iff)
using select_result_eq[OF shadow_root_eq_h3]
apply (metis (no_types, lifting) \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close> \<open>type_wf h3\<close> host_shadow_root_rel_def
i_get_parent_get_host_get_disconnected_document_wf.a_host_shadow_root_rel_shadow_root local.get_shadow_root_impl
local.get_shadow_root_ok option.distinct(1) prev_shadow_root returns_result_select_result)
apply (metis (mono_tags, lifting) \<open>\<And>ptr'. (\<And>x. element_ptr \<noteq> ptr') \<Longrightarrow>
|h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r\<close> case_prod_conv image_iff
is_OK_returns_result_I mem_Collect_eq option.inject returns_result_eq returns_result_select_result
shadow_root_h3)
using element_ptr_kinds_eq_h3 local.get_shadow_root_ptr_in_heap shadow_root_h3 apply fastforce
apply (smt Shadow_DOM.a_host_shadow_root_rel_def \<open>\<And>ptr'. (\<And>x. element_ptr \<noteq> ptr') \<Longrightarrow>
|h3 \<turnstile> get_shadow_root ptr'|\<^sub>r = |h' \<turnstile> get_shadow_root ptr'|\<^sub>r\<close> \<open>type_wf h3\<close> case_prodE case_prodI
i_get_root_node_si_wf.a_host_shadow_root_rel_shadow_root image_iff local.get_shadow_root_impl
local.get_shadow_root_ok mem_Collect_eq option.distinct(1) prev_shadow_root returns_result_eq
returns_result_select_result shadow_root_eq_h shadow_root_eq_h2)
done
have "a_ptr_disconnected_node_rel h = a_ptr_disconnected_node_rel h2"
apply(auto simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h)[1]
apply (metis (no_types, lifting) \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr |\<notin>| document_ptr_kinds h\<close>
case_prodI disconnected_nodes_eq2_h mem_Collect_eq pair_imageI)
using \<open>h2 \<turnstile> get_disconnected_nodes (cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
apply auto[1]
apply(case_tac "cast new_shadow_root_ptr \<noteq> aa")
apply (simp add: disconnected_nodes_eq2_h image_iff)
using \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr |\<notin>| document_ptr_kinds h\<close>
apply blast
done
have "a_ptr_disconnected_node_rel h2 = a_ptr_disconnected_node_rel h3"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h2 disconnected_nodes_eq2_h2)
have "a_ptr_disconnected_node_rel h3 = a_ptr_disconnected_node_rel h'"
by(simp add: a_ptr_disconnected_node_rel_def document_ptr_kinds_eq_h3 disconnected_nodes_eq2_h3)
have "acyclic (parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h)"
using \<open>heap_is_wellformed h\<close>
by (simp add: heap_is_wellformed_def)
have "parent_child_rel h \<union> a_host_shadow_root_rel h \<union> a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2"
using \<open>local.a_host_shadow_root_rel h = local.a_host_shadow_root_rel h2\<close>
\<open>local.a_ptr_disconnected_node_rel h = local.a_ptr_disconnected_node_rel h2\<close> \<open>parent_child_rel h = parent_child_rel h2\<close>
by auto
have "parent_child_rel h2 \<union> a_host_shadow_root_rel h2 \<union> a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
using \<open>local.a_host_shadow_root_rel h2 = local.a_host_shadow_root_rel h3\<close>
\<open>local.a_ptr_disconnected_node_rel h2 = local.a_ptr_disconnected_node_rel h3\<close> \<open>parent_child_rel h2 = parent_child_rel h3\<close>
by auto
have "parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast element_ptr, cast new_shadow_root_ptr)} \<union> parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3"
by (simp add: \<open>local.a_host_shadow_root_rel h' =
{(cast\<^sub>e\<^sub>l\<^sub>e\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r element_ptr, cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>o\<^sub>b\<^sub>j\<^sub>e\<^sub>c\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr)} \<union> local.a_host_shadow_root_rel h3\<close>
\<open>local.a_ptr_disconnected_node_rel h3 = local.a_ptr_disconnected_node_rel h'\<close> \<open>parent_child_rel h3 = parent_child_rel h'\<close>)
have "\<And>a b. (a, b) \<in> parent_child_rel h3 \<Longrightarrow> a \<noteq> cast new_shadow_root_ptr"
using CD.parent_child_rel_parent_in_heap \<open>cast\<^sub>s\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>r\<^sub>o\<^sub>o\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r\<^sub>2\<^sub>d\<^sub>o\<^sub>c\<^sub>u\<^sub>m\<^sub>e\<^sub>n\<^sub>t\<^sub>_\<^sub>p\<^sub>t\<^sub>r new_shadow_root_ptr |\<notin>| document_ptr_kinds h\<close>
\<open>parent_child_rel h = parent_child_rel h2\<close> \<open>parent_child_rel h2 = parent_child_rel h3\<close> document_ptr_kinds_commutes
by blast
moreover
have "\<And>a b. (a, b) \<in> a_host_shadow_root_rel h3 \<Longrightarrow> a \<noteq> cast new_shadow_root_ptr"
using shadow_root_eq_h2
by(auto simp add: a_host_shadow_root_rel_def)
moreover
have "\<And>a b. (a, b) \<in> a_ptr_disconnected_node_rel h3 \<Longrightarrow> a \<noteq> cast new_shadow_root_ptr"
using \<open>h2 \<turnstile> get_disconnected_nodes (cast new_shadow_root_ptr) \<rightarrow>\<^sub>r []\<close>
by(auto simp add: a_ptr_disconnected_node_rel_def disconnected_nodes_eq_h2)
moreover
have "cast new_shadow_root_ptr \<notin> {x. (x, cast element_ptr) \<in>
(parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)\<^sup>*}"
by (smt Un_iff calculation(1) calculation(2) calculation(3) cast_document_ptr_not_node_ptr(2) converse_rtranclE mem_Collect_eq)
moreover
have "acyclic (parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3)"
using \<open>acyclic (parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h)\<close>
\<open>parent_child_rel h \<union> local.a_host_shadow_root_rel h \<union> local.a_ptr_disconnected_node_rel h =
parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2\<close>
\<open>parent_child_rel h2 \<union> local.a_host_shadow_root_rel h2 \<union> local.a_ptr_disconnected_node_rel h2 =
parent_child_rel h3 \<union> local.a_host_shadow_root_rel h3 \<union> local.a_ptr_disconnected_node_rel h3\<close> by auto
ultimately have "acyclic (parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h')"
by(simp add: \<open>parent_child_rel h' \<union> a_host_shadow_root_rel h' \<union> a_ptr_disconnected_node_rel h' =
{(cast element_ptr, cast new_shadow_root_ptr)} \<union>
parent_child_rel h3 \<union> a_host_shadow_root_rel h3 \<union> a_ptr_disconnected_node_rel h3\<close>)
have "CD.a_heap_is_wellformed h'"
apply(simp add: CD.a_heap_is_wellformed_def)
by (simp add: \<open>local.CD.a_acyclic_heap h'\<close> \<open>local.CD.a_all_ptrs_in_heap h'\<close> \<open>local.CD.a_distinct_lists h'\<close>
\<open>local.CD.a_owner_document_valid h'\<close>)
show "heap_is_wellformed h' "
using \<open>acyclic (parent_child_rel h' \<union> local.a_host_shadow_root_rel h' \<union> local.a_ptr_disconnected_node_rel h')\<close>
by(simp add: heap_is_wellformed_def CD.heap_is_wellformed_impl \<open>local.CD.a_heap_is_wellformed h'\<close>
\<open>local.a_all_ptrs_in_heap h'\<close> \<open>local.a_distinct_lists h'\<close> \<open>local.a_shadow_root_valid h'\<close>)
qed
end
interpretation l_attach_shadow_root_wf?: l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M known_ptr known_ptrs type_wf
get_child_nodes get_child_nodes_locs get_disconnected_nodes get_disconnected_nodes_locs
heap_is_wellformed parent_child_rel set_tag_name set_tag_name_locs set_disconnected_nodes
set_disconnected_nodes_locs create_element get_shadow_root get_shadow_root_locs get_tag_name
get_tag_name_locs heap_is_wellformed\<^sub>C\<^sub>o\<^sub>r\<^sub>e\<^sub>_\<^sub>D\<^sub>O\<^sub>M get_host get_host_locs get_disconnected_document
get_disconnected_document_locs set_val set_val_locs create_character_data DocumentClass.known_ptr
DocumentClass.type_wf set_shadow_root set_shadow_root_locs set_mode set_mode_locs attach_shadow_root
by(auto simp add: l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_def instances)
declare l_attach_shadow_root_wf\<^sub>S\<^sub>h\<^sub>a\<^sub>d\<^sub>o\<^sub>w\<^sub>_\<^sub>D\<^sub>O\<^sub>M_axioms [instances]
end
diff --git a/thys/UTP/toolkit/FSet_Extra.thy b/thys/UTP/toolkit/FSet_Extra.thy
--- a/thys/UTP/toolkit/FSet_Extra.thy
+++ b/thys/UTP/toolkit/FSet_Extra.thy
@@ -1,282 +1,282 @@
(******************************************************************************)
(* Project: Isabelle/UTP Toolkit *)
(* File: FSet_Extra.thy *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK) *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk *)
(******************************************************************************)
section \<open>Finite Sets: extra functions and properties\<close>
theory FSet_Extra
imports
"HOL-Library.FSet"
"HOL-Library.Countable_Set_Type"
begin
setup_lifting type_definition_fset
notation fempty ("\<lbrace>\<rbrace>")
notation fset ("\<langle>_\<rangle>\<^sub>f")
notation fminus (infixl "-\<^sub>f" 65)
syntax
"_FinFset" :: "args => 'a fset" ("\<lbrace>(_)\<rbrace>")
translations
"\<lbrace>x, xs\<rbrace>" == "CONST finsert x \<lbrace>xs\<rbrace>"
"\<lbrace>x\<rbrace>" == "CONST finsert x \<lbrace>\<rbrace>"
term "fBall"
syntax
"_fBall" :: "pttrn => 'a fset => bool => bool" ("(3\<forall> _|\<in>|_./ _)" [0, 0, 10] 10)
"_fBex" :: "pttrn => 'a fset => bool => bool" ("(3\<exists> _|\<in>|_./ _)" [0, 0, 10] 10)
translations
"\<forall> x|\<in>|A. P" == "CONST fBall A (%x. P)"
"\<exists> x|\<in>|A. P" == "CONST fBex A (%x. P)"
definition FUnion :: "'a fset fset \<Rightarrow> 'a fset" ("\<Union>\<^sub>f_" [90] 90) where
"FUnion xs = Abs_fset (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
definition FInter :: "'a fset fset \<Rightarrow> 'a fset" ("\<Inter>\<^sub>f_" [90] 90) where
"FInter xs = Abs_fset (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
text \<open>Finite power set\<close>
definition FinPow :: "'a fset \<Rightarrow> 'a fset fset" where
"FinPow xs = Abs_fset (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)"
text \<open>Set of all finite subsets of a set\<close>
definition Fow :: "'a set \<Rightarrow> 'a fset set" where
"Fow A = {x. \<langle>x\<rangle>\<^sub>f \<subseteq> A}"
declare Abs_fset_inverse [simp]
lemma fset_intro:
"fset x = fset y \<Longrightarrow> x = y"
by (simp add:fset_inject)
lemma fset_elim:
"\<lbrakk> x = y; fset x = fset y \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (auto)
lemma fmember_intro:
"\<lbrakk> x \<in> fset(xs) \<rbrakk> \<Longrightarrow> x |\<in>| xs"
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma fmember_elim:
"\<lbrakk> x |\<in>| xs; x \<in> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma fnmember_intro [intro]:
"\<lbrakk> x \<notin> fset(xs) \<rbrakk> \<Longrightarrow> x |\<notin>| xs"
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma fnmember_elim [elim]:
"\<lbrakk> x |\<notin>| xs; x \<notin> fset(xs) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
- by (metis fmember.rep_eq)
+ by (metis fmember_iff_member_fset)
lemma fsubset_intro [intro]:
"\<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> xs |\<subseteq>| ys"
by (metis less_eq_fset.rep_eq)
lemma fsubset_elim [elim]:
"\<lbrakk> xs |\<subseteq>| ys; \<langle>xs\<rangle>\<^sub>f \<subseteq> \<langle>ys\<rangle>\<^sub>f \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by (metis less_eq_fset.rep_eq)
lemma fBall_intro [intro]:
"Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> fBall A P"
- by (metis (poly_guards_query) fBallI fmember.rep_eq)
+ by (metis (poly_guards_query) fBallI fmember_iff_member_fset)
lemma fBall_elim [elim]:
"\<lbrakk> fBall A P; Ball \<langle>A\<rangle>\<^sub>f P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
- by (metis fBallE fmember.rep_eq)
+ by (metis fBallE fmember_iff_member_fset)
lift_definition finset :: "'a list \<Rightarrow> 'a fset" is set ..
context linorder
begin
lemma sorted_list_of_set_inj:
"\<lbrakk> finite xs; finite ys; sorted_list_of_set xs = sorted_list_of_set ys \<rbrakk>
\<Longrightarrow> xs = ys"
apply (simp add:sorted_list_of_set_def)
apply (induct xs rule:finite_induct)
apply (induct ys rule:finite_induct)
apply (simp_all)
apply (metis finite.insertI insert_not_empty sorted_list_of_set_def sorted_list_of_set_empty sorted_list_of_set_eq_Nil_iff)
apply (metis finite.insertI finite_list set_remdups set_sort sorted_list_of_set_def sorted_list_of_set_sort_remdups)
done
definition flist :: "'a fset \<Rightarrow> 'a list" where
"flist xs = sorted_list_of_set (fset xs)"
lemma flist_inj: "inj flist"
apply (simp add:flist_def inj_on_def)
apply (clarify)
apply (rename_tac x y)
apply (subgoal_tac "fset x = fset y")
apply (simp add:fset_inject)
apply (rule sorted_list_of_set_inj, simp_all)
done
lemma flist_props [simp]:
"sorted (flist xs)"
"distinct (flist xs)"
by (simp_all add:flist_def)
lemma flist_empty [simp]:
"flist \<lbrace>\<rbrace> = []"
by (simp add:flist_def)
lemma flist_inv [simp]: "finset (flist xs) = xs"
by (simp add:finset_def flist_def fset_inverse)
lemma flist_set [simp]: "set (flist xs) = fset xs"
by (simp add:finset_def flist_def fset_inverse)
lemma fset_inv [simp]: "\<lbrakk> sorted xs; distinct xs \<rbrakk> \<Longrightarrow> flist (finset xs) = xs"
apply (simp add:finset_def flist_def fset_inverse)
apply (metis local.sorted_list_of_set_sort_remdups local.sorted_sort_id remdups_id_iff_distinct)
done
lemma fcard_flist:
"fcard xs = length (flist xs)"
apply (simp add:fcard_def)
apply (fold flist_set)
apply (unfold distinct_card[OF flist_props(2)])
apply (rule refl)
done
lemma flist_nth:
"i < fcard vs \<Longrightarrow> flist vs ! i |\<in>| vs"
apply (simp add: fmember_def flist_def fcard_def)
apply (metis fcard.rep_eq fcard_flist finset.rep_eq flist_def flist_inv nth_mem)
done
definition fmax :: "'a fset \<Rightarrow> 'a" where
"fmax xs = (if (xs = \<lbrace>\<rbrace>) then undefined else last (flist xs))"
end
definition flists :: "'a fset \<Rightarrow> 'a list set" where
"flists A = {xs. distinct xs \<and> finset xs = A}"
lemma flists_nonempty: "\<exists> xs. xs \<in> flists A"
apply (simp add: flists_def)
apply (metis Abs_fset_cases Abs_fset_inverse finite_distinct_list finite_fset finset.rep_eq)
done
lemma flists_elem_uniq: "\<lbrakk> x \<in> flists A; x \<in> flists B \<rbrakk> \<Longrightarrow> A = B"
by (simp add: flists_def)
definition flist_arb :: "'a fset \<Rightarrow> 'a list" where
"flist_arb A = (SOME xs. xs \<in> flists A)"
lemma flist_arb_distinct [simp]: "distinct (flist_arb A)"
by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)
lemma flist_arb_inv [simp]: "finset (flist_arb A) = A"
by (metis (mono_tags) flist_arb_def flists_def flists_nonempty mem_Collect_eq someI_ex)
lemma flist_arb_inj:
"inj flist_arb"
by (metis flist_arb_inv injI)
lemma flist_arb_lists: "flist_arb ` Fow A \<subseteq> lists A"
apply (auto)
using Fow_def finset.rep_eq apply fastforce
done
lemma countable_Fow:
fixes A :: "'a set"
assumes "countable A"
shows "countable (Fow A)"
proof -
from assms obtain to_nat_list :: "'a list \<Rightarrow> nat" where "inj_on to_nat_list (lists A)"
by blast
thus ?thesis
apply (simp add: countable_def)
apply (rule_tac x="to_nat_list \<circ> flist_arb" in exI)
apply (rule comp_inj_on)
apply (metis flist_arb_inv inj_on_def)
apply (simp add: flist_arb_lists subset_inj_on)
done
qed
definition flub :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"flub A t = (if (\<forall> a\<in>A. a |\<subseteq>| t) then Abs_fset (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else t)"
lemma finite_Union_subsets:
"\<lbrakk> \<forall> a \<in> A. a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>A)"
by (metis Sup_le_iff finite_subset)
lemma finite_UN_subsets:
"\<lbrakk> \<forall> a \<in> A. B a \<subseteq> b; finite b \<rbrakk> \<Longrightarrow> finite (\<Union>a\<in>A. B a)"
by (metis UN_subset_iff finite_subset)
lemma flub_rep_eq:
"\<langle>flub A t\<rangle>\<^sub>f = (if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f)"
apply (subgoal_tac "(if (\<forall> a\<in>A. a |\<subseteq>| t) then (\<Union>x\<in>A. \<langle>x\<rangle>\<^sub>f) else \<langle>t\<rangle>\<^sub>f) \<in> {x. finite x}")
apply (auto simp add:flub_def)
apply (rule finite_UN_subsets[of _ _ "\<langle>t\<rangle>\<^sub>f"])
apply (auto)
done
definition fglb :: "'a fset set \<Rightarrow> 'a fset \<Rightarrow> 'a fset" where
"fglb A t = (if (A = {}) then t else Abs_fset (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"
lemma fglb_rep_eq:
"\<langle>fglb A t\<rangle>\<^sub>f = (if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f))"
apply (subgoal_tac "(if (A = {}) then \<langle>t\<rangle>\<^sub>f else (\<Inter>x\<in>A. \<langle>x\<rangle>\<^sub>f)) \<in> {x. finite x}")
apply (metis Abs_fset_inverse fglb_def)
apply (auto)
apply (metis finite_INT finite_fset)
done
lemma FinPow_rep_eq [simp]:
"fset (FinPow xs) = {ys. ys |\<subseteq>| xs}"
apply (subgoal_tac "finite (Abs_fset ` Pow \<langle>xs\<rangle>\<^sub>f)")
apply (auto simp add: fmember_def FinPow_def)
apply (rename_tac x' y')
apply (subgoal_tac "finite x'")
apply (auto)
apply (metis finite_fset finite_subset)
apply (metis (full_types) Pow_iff fset_inverse imageI less_eq_fset.rep_eq)
done
lemma FUnion_rep_eq [simp]:
"\<langle>\<Union>\<^sub>f xs\<rangle>\<^sub>f = (\<Union>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
by (simp add:FUnion_def)
lemma FInter_rep_eq [simp]:
"xs \<noteq> \<lbrace>\<rbrace> \<Longrightarrow> \<langle>\<Inter>\<^sub>f xs\<rangle>\<^sub>f = (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)"
apply (simp add:FInter_def)
apply (subgoal_tac "finite (\<Inter>x\<in>\<langle>xs\<rangle>\<^sub>f. \<langle>x\<rangle>\<^sub>f)")
apply (simp)
apply (metis (poly_guards_query) bot_fset.rep_eq fglb_rep_eq finite_fset fset_inverse)
done
lemma FUnion_empty [simp]:
"\<Union>\<^sub>f \<lbrace>\<rbrace> = \<lbrace>\<rbrace>"
by (auto simp add:FUnion_def fmember_def)
lemma FinPow_member [simp]:
"xs |\<in>| FinPow xs"
by (auto simp add:fmember_def)
lemma FUnion_FinPow [simp]:
"\<Union>\<^sub>f (FinPow x) = x"
by (auto simp add:fmember_def less_eq_fset_def)
lemma Fow_mem [iff]: "x \<in> Fow A \<longleftrightarrow> \<langle>x\<rangle>\<^sub>f \<subseteq> A"
by (auto simp add:Fow_def)
lemma Fow_UNIV [simp]: "Fow UNIV = UNIV"
by (simp add:Fow_def)
lift_definition FMax :: "('a::linorder) fset \<Rightarrow> 'a" is "Max" .
end
\ No newline at end of file

File Metadata

Mime Type
application/octet-stream
Expires
Wed, May 22, 1:42 PM (2 d)
Storage Engine
chunks
Storage Format
Chunks
Storage Handle
Of3D38U9jFHZ
Default Alt Text
(4 MB)

Event Timeline