No OneTemporary
Actions

Size

5 MB

Subscribers

None

View Options

This file is larger than 256 KB, so syntax highlighting was skipped.

	diff --git a/thys/Affine_Arithmetic/Affine_Approximation.thy b/thys/Affine_Arithmetic/Affine_Approximation.thy
	--- a/thys/Affine_Arithmetic/Affine_Approximation.thy
	+++ b/thys/Affine_Arithmetic/Affine_Approximation.thy
	@@ -1,3874 +1,3874 @@
	section \<open>Approximation with Affine Forms\<close>
	theory Affine_Approximation
	imports
	"HOL-Decision_Procs.Approximation"
	"HOL-Library.Monad_Syntax"
	"HOL-Library.Mapping"
	Executable_Euclidean_Space
	Affine_Form
	Straight_Line_Program
	begin
	text \<open>\label{sec:approxaffine}\<close>

	lemma convex_on_imp_above_tangent:\<comment> \<open>TODO: generalizes @{thm convex_on_imp_above_tangent}\<close>
	assumes convex: "convex_on A f" and connected: "connected A"
	assumes c: "c \<in> A" and x : "x \<in> A"
	assumes deriv: "(f has_field_derivative f') (at c within A)"
	shows "f x - f c \<ge> f' * (x - c)"
	proof (cases x c rule: linorder_cases)
	assume xc: "x > c"
	let ?A' = "{c<..<x}"
	have subs: "?A' \<subseteq> A" using xc x c
	by (simp add: connected connected_contains_Ioo)
	have "at c within ?A' \<noteq> bot"
	using xc
	by (simp add: at_within_eq_bot_iff)
	moreover from deriv have "((\<lambda>y. (f y - f c) / (y - c)) \<longlongrightarrow> f') (at c within ?A')"
	unfolding has_field_derivative_iff using subs
	by (blast intro: tendsto_mono at_le)
	moreover from eventually_at_right_real[OF xc]
	have "eventually (\<lambda>y. (f y - f c) / (y - c) \<le> (f x - f c) / (x - c)) (at_right c)"
	proof eventually_elim
	fix y assume y: "y \<in> {c<..<x}"
	with convex connected x c have "f y \<le> (f x - f c) / (x - c) * (y - c) + f c"
	using interior_subset[of A]
	by (intro convex_onD_Icc' convex_on_subset[OF convex] connected_contains_Icc) auto
	hence "f y - f c \<le> (f x - f c) / (x - c) * (y - c)" by simp
	thus "(f y - f c) / (y - c) \<le> (f x - f c) / (x - c)" using y xc by (simp add: divide_simps)
	qed
	hence "eventually (\<lambda>y. (f y - f c) / (y - c) \<le> (f x - f c) / (x - c)) (at c within ?A')"
	by (simp add: eventually_at_filter eventually_mono)
	ultimately have "f' \<le> (f x - f c) / (x - c)" by (simp add: tendsto_upperbound)
	thus ?thesis using xc by (simp add: field_simps)
	next
	assume xc: "x < c"
	let ?A' = "{x<..<c}"
	have subs: "?A' \<subseteq> A" using xc x c
	by (simp add: connected connected_contains_Ioo)
	have "at c within ?A' \<noteq> bot"
	using xc
	by (simp add: at_within_eq_bot_iff)
	moreover from deriv have "((\<lambda>y. (f y - f c) / (y - c)) \<longlongrightarrow> f') (at c within ?A')"
	unfolding has_field_derivative_iff using subs
	by (blast intro: tendsto_mono at_le)
	moreover from eventually_at_left_real[OF xc]
	have "eventually (\<lambda>y. (f y - f c) / (y - c) \<ge> (f x - f c) / (x - c)) (at_left c)"
	proof eventually_elim
	fix y assume y: "y \<in> {x<..<c}"
	with convex connected x c have "f y \<le> (f x - f c) / (c - x) * (c - y) + f c"
	using interior_subset[of A]
	by (intro convex_onD_Icc'' convex_on_subset[OF convex] connected_contains_Icc) auto
	hence "f y - f c \<le> (f x - f c) * ((c - y) / (c - x))" by simp
	also have "(c - y) / (c - x) = (y - c) / (x - c)" using y xc by (simp add: field_simps)
	finally show "(f y - f c) / (y - c) \<ge> (f x - f c) / (x - c)" using y xc
	by (simp add: divide_simps)
	qed
	hence "eventually (\<lambda>y. (f y - f c) / (y - c) \<ge> (f x - f c) / (x - c)) (at c within ?A')"
	by (simp add: eventually_at_filter eventually_mono)
	ultimately have "f' \<ge> (f x - f c) / (x - c)" by (simp add: tendsto_lowerbound)
	thus ?thesis using xc by (simp add: field_simps)
	qed simp_all


	text \<open>Approximate operations on affine forms.\<close>

	lemma Affine_notempty[intro, simp]: "Affine X \<noteq> {}"
	by (auto simp: Affine_def valuate_def)

	lemma truncate_up_lt: "x < y \<Longrightarrow> x < truncate_up prec y"
	by (rule less_le_trans[OF _ truncate_up])

	lemma truncate_up_pos_eq[simp]: "0 < truncate_up p x \<longleftrightarrow> 0 < x"
	by (auto simp: truncate_up_lt) (metis (poly_guards_query) not_le truncate_up_nonpos)

	lemma inner_scaleR_pdevs_0: "inner_scaleR_pdevs 0 One_pdevs = zero_pdevs"
	unfolding inner_scaleR_pdevs_def
	by transfer (auto simp: unop_pdevs_raw_def)

	lemma Affine_aform_of_point_eq[simp]: "Affine (aform_of_point p) = {p}"
	by (simp add: Affine_aform_of_ivl aform_of_point_def)

	lemma mem_Affine_aform_of_point: "x \<in> Affine (aform_of_point x)"
	by simp

	lemma
	aform_val_aform_of_ivl_innerE:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "a \<le> b" "c \<in> Basis"
	obtains f where "aform_val e (aform_of_ivl a b) \<bullet> c = aform_val f (aform_of_ivl (a \<bullet> c) (b \<bullet> c))"
	"f \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	have [simp]: "a \<bullet> c \<le> b \<bullet> c"
	using assms by (auto simp: eucl_le[where 'a='a])
	have "(\<lambda>x. x \<bullet> c) ` Affine (aform_of_ivl a b) = Affine (aform_of_ivl (a \<bullet> c) (b \<bullet> c))"
	using assms
	by (auto simp: Affine_aform_of_ivl eucl_le[where 'a='a]
	image_eqI[where x="\<Sum>i\<in>Basis. (if i = c then x else a \<bullet> i) *\<^sub>R i" for x])
	then obtain f where
	"aform_val e (aform_of_ivl a b) \<bullet> c = aform_val f (aform_of_ivl (a \<bullet> c) (b \<bullet> c))"
	"f \<in> UNIV \<rightarrow> {-1 .. 1}"
	using assms
	by (force simp: Affine_def valuate_def)
	thus ?thesis ..
	qed

	lift_definition coord_pdevs::"nat \<Rightarrow> real pdevs" is "\<lambda>n i. if i = n then 1 else 0" by auto

	lemma pdevs_apply_coord_pdevs [simp]: "pdevs_apply (coord_pdevs i) x = (if x = i then 1 else 0)"
	by transfer simp

	lemma degree_coord_pdevs[simp]: "degree (coord_pdevs i) = Suc i"
	by (auto intro!: degree_eqI)

	lemma pdevs_val_coord_pdevs[simp]: "pdevs_val e (coord_pdevs i) = e i"
	by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong)

	definition "aforms_of_ivls ls us = map
	(\<lambda>(i, (l, u)). ((l + u)/2, scaleR_pdevs ((u - l)/2) (coord_pdevs i)))
	(zip [0..<length ls] (zip ls us))"

	lemma
	aforms_of_ivls:
	assumes "length ls = length us" "length xs = length ls"
	assumes "\<And>i. i < length xs \<Longrightarrow> xs ! i \<in> {ls ! i .. us ! i}"
	shows "xs \<in> Joints (aforms_of_ivls ls us)"
	proof -
	{
	fix i assume "i < length xs"
	then have "\<exists>e. e \<in> {-1 .. 1} \<and> xs ! i = (ls ! i + us ! i) / 2 + e * (us ! i - ls ! i) / 2"
	using assms
	by (force intro!: exI[where x="(xs ! i - (ls ! i + us ! i) / 2) / (us ! i - ls ! i) * 2"]
	simp: divide_simps algebra_simps)
	} then obtain e where e: "e i \<in> {-1 .. 1}"
	"xs ! i = (ls ! i + us ! i) / 2 + e i * (us ! i - ls ! i) / 2"
	if "i < length xs" for i
	using that by metis
	define e' where "e' i = (if i < length xs then e i else 0)" for i
	show ?thesis
	using e assms
	by (auto simp: aforms_of_ivls_def Joints_def valuate_def e'_def aform_val_def
	intro!: image_eqI[where x=e'] nth_equalityI)
	qed


	subsection \<open>Approximate Operations\<close>

	definition "max_pdev x = fold (\<lambda>x y. if infnorm (snd x) \<ge> infnorm (snd y) then x else y) (list_of_pdevs x) (0, 0)"


	subsubsection \<open>set of generated endpoints\<close>

	fun points_of_list where
	"points_of_list x0 [] = [x0]"
	\| "points_of_list x0 ((i, x)#xs) = (points_of_list (x0 + x) xs @ points_of_list (x0 - x) xs)"

	primrec points_of_aform where
	"points_of_aform (x, xs) = points_of_list x (list_of_pdevs xs)"


	subsubsection \<open>Approximate total deviation\<close>

	definition sum_list'::"nat \<Rightarrow> 'a list \<Rightarrow> 'a::executable_euclidean_space"
	where "sum_list' p xs = fold (\<lambda>a b. eucl_truncate_up p (a + b)) xs 0"

	definition "tdev' p x = sum_list' p (map (abs o snd) (list_of_pdevs x))"

	lemma
	eucl_fold_mono:
	fixes f::"'a::ordered_euclidean_space\<Rightarrow>'a\<Rightarrow>'a"
	assumes mono: "\<And>w x y z. w \<le> x \<Longrightarrow> y \<le> z \<Longrightarrow> f w y \<le> f x z"
	shows "x \<le> y \<Longrightarrow> fold f xs x \<le> fold f xs y"
	by (induct xs arbitrary: x y) (auto simp: mono)

	lemma sum_list_add_le_fold_eucl_truncate_up:
	fixes z::"'a::executable_euclidean_space"
	shows "sum_list xs + z \<le> fold (\<lambda>x y. eucl_truncate_up p (x + y)) xs z"
	proof (induct xs arbitrary: z)
	case (Cons x xs)
	have "sum_list (x # xs) + z = sum_list xs + (z + x)"
	by simp
	also have "\<dots> \<le> fold (\<lambda>x y. eucl_truncate_up p (x + y)) xs (z + x)"
	using Cons by simp
	also have "\<dots> \<le> fold (\<lambda>x y. eucl_truncate_up p (x + y)) xs (eucl_truncate_up p (x + z))"
	by (auto intro!: add_mono eucl_fold_mono eucl_truncate_up eucl_truncate_up_mono simp: ac_simps)
	finally show ?case by simp
	qed simp

	lemma sum_list_le_sum_list':
	"sum_list xs \<le> sum_list' p xs"
	unfolding sum_list'_def
	using sum_list_add_le_fold_eucl_truncate_up[of xs 0] by simp

	lemma sum_list'_sum_list_le:
	"y \<le> sum_list xs \<Longrightarrow> y \<le> sum_list' p xs"
	by (metis sum_list_le_sum_list' order.trans)

	lemma tdev': "tdev x \<le> tdev' p x"
	unfolding tdev'_def
	proof -
	have "tdev x = (\<Sum>i = 0 ..< degree x. \<bar>pdevs_apply x i\<bar>)"
	by (auto intro!: sum.mono_neutral_cong_left simp: tdev_def)
	also have "\<dots> = (\<Sum>i \<leftarrow> rev [0 ..< degree x]. \<bar>pdevs_apply x i\<bar>)"
	by (metis atLeastLessThan_upt sum_list_rev rev_map sum_set_upt_conv_sum_list_nat)
	also have
	"\<dots> = sum_list (map (\<lambda>xa. \<bar>pdevs_apply x xa\<bar>) [xa\<leftarrow>rev [0..<degree x] . pdevs_apply x xa \<noteq> 0])"
	unfolding filter_map map_map o_def
	by (subst sum_list_map_filter) auto
	also note sum_list_le_sum_list'[of _ p]
	also have "[xa\<leftarrow>rev [0..<degree x] . pdevs_apply x xa \<noteq> 0] =
	rev (sorted_list_of_set (pdevs_domain x))"
	by (subst rev_is_rev_conv[symmetric])
	(auto simp: filter_map rev_filter intro!: sorted_distinct_set_unique
	sorted_filter[of "\<lambda>x. x", simplified] degree_gt)
	finally
	show "tdev x \<le> sum_list' p (map (abs \<circ> snd) (list_of_pdevs x))"
	by (auto simp: list_of_pdevs_def o_def rev_map filter_map rev_filter)
	qed

	lemma tdev'_le: "x \<le> tdev y \<Longrightarrow> x \<le> tdev' p y"
	by (metis order.trans tdev')

	lemmas abs_pdevs_val_le_tdev' = tdev'_le[OF abs_pdevs_val_le_tdev]

	lemma tdev'_uminus_pdevs[simp]: "tdev' p (uminus_pdevs x) = tdev' p x"
	by (auto simp: tdev'_def o_def rev_map filter_map rev_filter list_of_pdevs_def pdevs_domain_def)

	abbreviation Radius::"'a::ordered_euclidean_space aform \<Rightarrow> 'a"
	where "Radius X \<equiv> tdev (snd X)"

	abbreviation Radius'::"nat\<Rightarrow>'a::executable_euclidean_space aform \<Rightarrow> 'a"
	where "Radius' p X \<equiv> tdev' p (snd X)"

	lemma Radius'_uminus_aform[simp]: "Radius' p (uminus_aform X) = Radius' p X"
	by (auto simp: uminus_aform_def)


	subsubsection \<open>truncate partial deviations\<close>

	definition trunc_pdevs_raw::"nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a::executable_euclidean_space"
	where "trunc_pdevs_raw p x i = eucl_truncate_down p (x i)"

	lemma nonzeros_trunc_pdevs_raw:
	"{i. trunc_pdevs_raw r x i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0}"
	by (auto simp: trunc_pdevs_raw_def[abs_def])

	lift_definition trunc_pdevs::"nat \<Rightarrow> 'a::executable_euclidean_space pdevs \<Rightarrow> 'a pdevs"
	is trunc_pdevs_raw
	by (auto intro!: finite_subset[OF nonzeros_trunc_pdevs_raw])

	definition trunc_err_pdevs_raw::"nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a::executable_euclidean_space"
	where "trunc_err_pdevs_raw p x i = trunc_pdevs_raw p x i - x i"

	lemma nonzeros_trunc_err_pdevs_raw:
	"{i. trunc_err_pdevs_raw r x i \<noteq> 0} \<subseteq> {i. x i \<noteq> 0}"
	by (auto simp: trunc_pdevs_raw_def trunc_err_pdevs_raw_def[abs_def])

	lift_definition trunc_err_pdevs::"nat \<Rightarrow> 'a::executable_euclidean_space pdevs \<Rightarrow> 'a pdevs"
	is trunc_err_pdevs_raw
	by (auto intro!: finite_subset[OF nonzeros_trunc_err_pdevs_raw])

	term float_plus_down

	lemma pdevs_apply_trunc_pdevs[simp]:
	fixes x y::"'a::euclidean_space"
	shows "pdevs_apply (trunc_pdevs p X) n = eucl_truncate_down p (pdevs_apply X n)"
	by transfer (simp add: trunc_pdevs_raw_def)

	lemma pdevs_apply_trunc_err_pdevs[simp]:
	fixes x y::"'a::euclidean_space"
	shows "pdevs_apply (trunc_err_pdevs p X) n =
	eucl_truncate_down p (pdevs_apply X n) - (pdevs_apply X n)"
	by transfer (auto simp: trunc_err_pdevs_raw_def trunc_pdevs_raw_def)

	lemma pdevs_val_trunc_pdevs:
	fixes x y::"'a::euclidean_space"
	shows "pdevs_val e (trunc_pdevs p X) = pdevs_val e X + pdevs_val e (trunc_err_pdevs p X)"
	proof -
	have "pdevs_val e X + pdevs_val e (trunc_err_pdevs p X) =
	pdevs_val e (add_pdevs X (trunc_err_pdevs p X))"
	by simp
	also have "\<dots> = pdevs_val e (trunc_pdevs p X)"
	by (auto simp: pdevs_val_def trunc_pdevs_raw_def trunc_err_pdevs_raw_def)
	finally show ?thesis by simp
	qed

	lemma pdevs_val_trunc_err_pdevs:
	fixes x y::"'a::euclidean_space"
	shows "pdevs_val e (trunc_err_pdevs p X) = pdevs_val e (trunc_pdevs p X) - pdevs_val e X"
	by (simp add: pdevs_val_trunc_pdevs)

	definition truncate_aform::"nat \<Rightarrow> 'a aform \<Rightarrow> 'a::executable_euclidean_space aform"
	where "truncate_aform p x = (eucl_truncate_down p (fst x), trunc_pdevs p (snd x))"

	definition truncate_error_aform::"nat \<Rightarrow> 'a aform \<Rightarrow> 'a::executable_euclidean_space aform"
	where "truncate_error_aform p x =
	(eucl_truncate_down p (fst x) - fst x, trunc_err_pdevs p (snd x))"

	lemma
	abs_aform_val_le:
	assumes "e \<in> UNIV \<rightarrow> {- 1..1}"
	shows "abs (aform_val e X) \<le> eucl_truncate_up p (\<bar>fst X\<bar> + tdev' p (snd X))"
	proof -
	have "abs (aform_val e X) \<le> \<bar>fst X\<bar> + \<bar>pdevs_val e (snd X)\<bar>"
	by (auto simp: aform_val_def intro!: abs_triangle_ineq)
	also have "\<bar>pdevs_val e (snd X)\<bar> \<le> tdev (snd X)"
	using assms by (rule abs_pdevs_val_le_tdev)
	also note tdev'
	also note eucl_truncate_up
	finally show ?thesis by simp
	qed


	subsubsection \<open>truncation with error bound\<close>

	definition "trunc_bound_eucl p s =
	(let
	d = eucl_truncate_down p s;
	ed = abs (d - s) in
	(d, eucl_truncate_up p ed))"

	lemma trunc_bound_euclE:
	obtains err where
	"\<bar>err\<bar> \<le> snd (trunc_bound_eucl p x)"
	"fst (trunc_bound_eucl p x) = x + err"
	proof atomize_elim
	have "fst (trunc_bound_eucl p x) = x + (eucl_truncate_down p x - x)"
	(is "_ = _ + ?err")
	by (simp_all add: trunc_bound_eucl_def Let_def)
	moreover have "abs ?err \<le> snd (trunc_bound_eucl p x)"
	by (simp add: trunc_bound_eucl_def Let_def eucl_truncate_up)
	ultimately show "\<exists>err. \<bar>err\<bar> \<le> snd (trunc_bound_eucl p x) \<and> fst (trunc_bound_eucl p x) = x + err"
	by auto
	qed

	definition "trunc_bound_pdevs p x = (trunc_pdevs p x, tdev' p (trunc_err_pdevs p x))"

	lemma pdevs_apply_fst_trunc_bound_pdevs[simp]: "pdevs_apply (fst (trunc_bound_pdevs p x)) =
	pdevs_apply (trunc_pdevs p x)"
	by (simp add: trunc_bound_pdevs_def)

	lemma trunc_bound_pdevsE:
	assumes "e \<in> UNIV \<rightarrow> {- 1..1}"
	obtains err where
	"\<bar>err\<bar> \<le> snd (trunc_bound_pdevs p x)"
	"pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err"
	proof atomize_elim
	have "pdevs_val e (fst (trunc_bound_pdevs p x)) = pdevs_val e x +
	pdevs_val e (add_pdevs (trunc_pdevs p x) (uminus_pdevs x))"
	(is "_ = _ + ?err")
	by (simp_all add: trunc_bound_pdevs_def Let_def)
	moreover have "abs ?err \<le> snd (trunc_bound_pdevs p x)"
	using assms
	by (auto simp add: pdevs_val_trunc_pdevs trunc_bound_pdevs_def Let_def eucl_truncate_up
	intro!: order_trans[OF abs_pdevs_val_le_tdev tdev'])
	ultimately show "\<exists>err. \<bar>err\<bar> \<le> snd (trunc_bound_pdevs p x) \<and>
	pdevs_val e (fst ((trunc_bound_pdevs p x))) = pdevs_val e x + err"
	by auto
	qed

	lemma
	degree_add_pdevs_le:
	assumes "degree X \<le> n"
	assumes "degree Y \<le> n"
	shows "degree (add_pdevs X Y) \<le> n"
	using assms
	by (auto intro!: degree_le)


	lemma truncate_aform_error_aform_cancel:
	"aform_val e (truncate_aform p z) = aform_val e z + aform_val e (truncate_error_aform p z) "
	by (simp add: truncate_aform_def aform_val_def truncate_error_aform_def pdevs_val_trunc_pdevs)

	lemma error_absE:
	assumes "abs err \<le> k"
	obtains e::real where "err = e * k" "e \<in> {-1 .. 1}"
	using assms
	by atomize_elim
	(safe intro!: exI[where x="err / abs k"] divide_atLeastAtMost_1_absI, auto)

	lemma eucl_truncate_up_nonneg_eq_zero_iff:
	"x \<ge> 0 \<Longrightarrow> eucl_truncate_up p x = 0 \<longleftrightarrow> x = 0"
	by (metis (poly_guards_query) eq_iff eucl_truncate_up eucl_truncate_up_zero)

	lemma
	aform_val_consume_error:
	assumes "abs err \<le> abs (pdevs_apply (snd X) n)"
	shows "aform_val (e(n := 0)) X + err = aform_val (e(n := err/pdevs_apply (snd X) n)) X"
	using assms
	by (auto simp add: aform_val_def)

	lemma
	aform_val_consume_errorE:
	fixes X::"real aform"
	assumes "abs err \<le> abs (pdevs_apply (snd X) n)"
	obtains err' where "aform_val (e(n := 0)) X + err = aform_val (e(n := err')) X" "err' \<in> {-1 .. 1}"
	by atomize_elim
	(rule aform_val_consume_error assms aform_val_consume_error exI conjI
	divide_atLeastAtMost_1_absI)+

	lemma
	degree_trunc_pdevs_le:
	assumes "degree X \<le> n"
	shows "degree (trunc_pdevs p X) \<le> n"
	using assms
	by (auto intro!: degree_le)

	lemma pdevs_val_sum_less_degree:
	"pdevs_val e X = (\<Sum>i<d. e i *\<^sub>R pdevs_apply X i)" if "degree X \<le> d"
	unfolding pdevs_val_pdevs_domain
	apply (rule sum.mono_neutral_cong_left)
	using that
	by force+


	subsubsection \<open>general affine operation\<close>

	definition "affine_binop (X::real aform) Y a b c d k =
	(a * fst X + b * fst Y + c,
	pdev_upd (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) k d)"

	lemma pdevs_domain_One_pdevs[simp]: "pdevs_domain (One_pdevs::'a::executable_euclidean_space pdevs) =
	{0..<DIM('a)}"
	apply (auto simp: length_Basis_list split: if_splits)
	subgoal for i
	using nth_Basis_list_in_Basis[of i, where 'a='a]
	by (auto simp: length_Basis_list)
	done

	lemma pdevs_val_One_pdevs:
	"pdevs_val e (One_pdevs::'a::executable_euclidean_space pdevs) = (\<Sum>i<DIM('a). e i *\<^sub>R Basis_list ! i)"
	by (auto simp: pdevs_val_pdevs_domain length_Basis_list intro!:sum.cong)

	lemma affine_binop:
	assumes "degree_aforms [X, Y] \<le> k"
	shows "aform_val e (affine_binop X Y a b c d k) =
	a * aform_val e X + b * aform_val e Y + c + e k * d"
	using assms
	by (auto simp: aform_val_def affine_binop_def degrees_def
	pdevs_val_msum_pdevs degree_add_pdevs_le pdevs_val_One_pdevs Basis_list_real_def
	algebra_simps)

	definition "affine_binop' p (X::real aform) Y a b c d k =
	(let
	\<comment> \<open>TODO: more round-off operations here?\<close>
	(r, e1) = trunc_bound_eucl p (a * fst X + b * fst Y + c);
	(Z, e2) = trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y)))
	in
	(r, pdev_upd Z k (sum_list' p [e1, e2, d]))
	)"

	lemma sum_list'_noneg_eq_zero_iff: "sum_list' p xs = 0 \<longleftrightarrow> (\<forall>x\<in>set xs. x = 0)" if "\<And>x. x \<in> set xs \<Longrightarrow> x \<ge> 0"
	proof safe
	fix x assume x: "sum_list' p xs = 0" "x \<in> set xs"
	from that have "0 \<le> sum_list xs" by (auto intro!: sum_list_nonneg)
	with that x have "sum_list xs = 0"
	by (metis antisym sum_list_le_sum_list')
	then have "(\<Sum>i<length xs. xs ! i) = 0"
	by (auto simp: sum_list_sum_nth atLeast0LessThan)
	then show "x = 0" using x(2) that
	by (subst (asm) sum_nonneg_eq_0_iff) (auto simp: in_set_conv_nth)
	next
	show "\<forall>x\<in>set xs. x = 0 \<Longrightarrow> sum_list' p xs = 0"
	by (induction xs) (auto simp: sum_list'_def)
	qed

	lemma affine_binop'E:
	assumes deg: "degree_aforms [X, Y] \<le> k"
	assumes e: "e \<in> UNIV \<rightarrow> {- 1..1}"
	assumes d: "abs u \<le> d"
	obtains ek where
	"a * aform_val e X + b * aform_val e Y + c + u = aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)"
	"ek \<in> {-1 .. 1}"
	proof -
	have "a * aform_val e X + b * aform_val e Y + c + u =
	(a * fst X + b * fst Y + c) + pdevs_val e (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))) + u"
	(is "_ = ?c + pdevs_val _ ?ps + _")
	by (auto simp: aform_val_def algebra_simps)

	from trunc_bound_euclE[of p ?c] obtain ec where ec: "abs ec \<le> snd (trunc_bound_eucl p ?c)"
	"fst (trunc_bound_eucl p ?c) - ec = ?c"
	by (auto simp: algebra_simps)

	moreover

	from trunc_bound_pdevsE[OF e, of p ?ps]
	obtain eps where eps: "\<bar>eps\<bar> \<le> snd (trunc_bound_pdevs p ?ps)"
	"pdevs_val e (fst (trunc_bound_pdevs p ?ps)) - eps = pdevs_val e ?ps"
	by (auto simp: algebra_simps)

	moreover
	define ek where "ek = (u - ec - eps)/
	sum_list' p [snd (trunc_bound_eucl p ?c), snd (trunc_bound_pdevs p ?ps), d]"
	have "degree (fst (trunc_bound_pdevs p ?ps)) \<le>
	degree_aforms [X, Y]"
	by (auto simp: trunc_bound_pdevs_def degrees_def intro!: degree_trunc_pdevs_le degree_add_pdevs_le)
	moreover
	from this have "pdevs_apply (fst (trunc_bound_pdevs p ?ps)) k = 0"
	using deg order_trans by blast
	ultimately have "a * aform_val e X + b * aform_val e Y + c + u =
	aform_val (e(k:=ek)) (affine_binop' p X Y a b c d k)"
	apply (auto simp: affine_binop'_def algebra_simps aform_val_def split: prod.splits)
	subgoal for x y z
	apply (cases "sum_list' p [x, z, d] = 0")
	subgoal
	apply simp
	apply (subst (asm) sum_list'_noneg_eq_zero_iff)
	using d deg
	by auto
	subgoal
	apply (simp add: divide_simps algebra_simps ek_def)
	using \<open>pdevs_apply (fst (trunc_bound_pdevs p (add_pdevs (scaleR_pdevs a (snd X)) (scaleR_pdevs b (snd Y))))) k = 0\<close> by auto
	done
	done
	moreover have "ek \<in> {-1 .. 1}"
	unfolding ek_def
	apply (rule divide_atLeastAtMost_1_absI)
	apply (rule abs_triangle_ineq4[THEN order_trans])
	apply (rule order_trans)
	apply (rule add_right_mono)
	apply (rule abs_triangle_ineq4)
	using ec(1) eps(1)
	by (auto simp: sum_list'_def eucl_truncate_up_real_def add.assoc
	intro!: order_trans[OF _ abs_ge_self] order_trans[OF _ truncate_up_le] add_mono d )
	ultimately show ?thesis ..
	qed

	subsubsection \<open>Inf/Sup\<close>

	definition "Inf_aform' p X = eucl_truncate_down p (fst X - tdev' p (snd X))"

	definition "Sup_aform' p X = eucl_truncate_up p (fst X + tdev' p (snd X))"

	lemma Inf_aform':
	shows "Inf_aform' p X \<le> Inf_aform X"
	unfolding Inf_aform_def Inf_aform'_def
	by (auto intro!: eucl_truncate_down_le add_left_mono tdev')

	lemma Sup_aform':
	shows "Sup_aform X \<le> Sup_aform' p X"
	unfolding Sup_aform_def Sup_aform'_def
	by (rule eucl_truncate_up_le add_left_mono tdev')+

	lemma Inf_aform_le_Sup_aform[intro]:
	"Inf_aform X \<le> Sup_aform X"
	by (simp add: Inf_aform_def Sup_aform_def algebra_simps)

	lemma Inf_aform'_le_Sup_aform'[intro]:
	"Inf_aform' p X \<le> Sup_aform' p X"
	by (metis Inf_aform' Inf_aform_le_Sup_aform Sup_aform' order.trans)

	definition
	"ivls_of_aforms prec = map (\<lambda>a. Interval' (float_of (Inf_aform' prec a)) (float_of(Sup_aform' prec a)))"

	lemma
	assumes "\<And>i. e'' i \<le> 1"
	assumes "\<And>i. -1 \<le> e'' i"
	shows Inf_aform'_le: "Inf_aform' p r \<le> aform_val e'' r"
	and Sup_aform'_le: "aform_val e'' r \<le> Sup_aform' p r"
	by (auto intro!: order_trans[OF Inf_aform'] order_trans[OF _ Sup_aform'] Inf_aform Sup_aform
	simp: Affine_def valuate_def intro!: image_eqI[where x=e''] assms)


	lemma InfSup_aform'_in_float[intro, simp]:
	"Inf_aform' p X \<in> float" "Sup_aform' p X \<in> float"
	by (auto simp: Inf_aform'_def eucl_truncate_down_real_def
	Sup_aform'_def eucl_truncate_up_real_def)

	theorem ivls_of_aforms: "xs \<in> Joints XS \<Longrightarrow> bounded_by xs (ivls_of_aforms prec XS)"
	by (auto simp: bounded_by_def ivls_of_aforms_def Affine_def valuate_def Pi_iff set_of_eq
	intro!: Inf_aform'_le Sup_aform'_le
	dest!: nth_in_AffineI split: Interval'_splits)

	definition "isFDERIV_aform prec N xs fas AS = isFDERIV_approx prec N xs fas (ivls_of_aforms prec AS)"

	theorem isFDERIV_aform:
	assumes "isFDERIV_aform prec N xs fas AS"
	assumes "vs \<in> Joints AS"
	shows "isFDERIV N xs fas vs"
	apply (rule isFDERIV_approx)
	apply (rule ivls_of_aforms)
	apply (rule assms)
	apply (rule assms[unfolded isFDERIV_aform_def])
	done

	definition "env_len env l = (\<forall>xs \<in> env. length xs = l)"

	lemma env_len_takeI: "env_len xs d1 \<Longrightarrow> d1 \<ge> d \<Longrightarrow> env_len (take d ` xs) d"
	by (auto simp: env_len_def)

	subsection \<open>Min Range approximation\<close>

	lemma
	linear_lower:
	fixes x::real
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> (f has_field_derivative f' x) (at x within {a .. b})"
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> f' x \<le> u"
	assumes "x \<in> {a .. b}"
	shows "f b + u * (x - b) \<le> f x"
	proof -
	from assms(2-)
	mvt_very_simple[of x b f "\<lambda>x. (*) (f' x)",
	rule_format,
	OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
	obtain y where "y \<in> {x .. b}" "f b - f x = (b - x) * f' y"
	by (auto simp: Bex_def ac_simps)
	moreover hence "f' y \<le> u" using assms by auto
	ultimately have "f b - f x \<le> (b - x) * u"
	by (auto intro!: mult_left_mono)
	thus ?thesis by (simp add: algebra_simps)
	qed

	lemma
	linear_lower2:
	fixes x::real
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> (f has_field_derivative f' x) (at x within {a .. b})"
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> l \<le> f' x"
	assumes "x \<in> {a .. b}"
	shows "f x \<ge> f a + l * (x - a)"
	proof -
	from assms(2-)
	mvt_very_simple[of a x f "\<lambda>x. (*) (f' x)",
	rule_format,
	OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
	obtain y where "y \<in> {a .. x}" "f x - f a = (x - a) * f' y"
	by (auto simp: Bex_def ac_simps)
	moreover hence "l \<le> f' y" using assms by auto
	ultimately have "(x - a) * l \<le> f x - f a"
	by (auto intro!: mult_left_mono)
	thus ?thesis by (simp add: algebra_simps)
	qed

	lemma
	linear_upper:
	fixes x::real
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> (f has_field_derivative f' x) (at x within {a .. b})"
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> f' x \<le> u"
	assumes "x \<in> {a .. b}"
	shows "f x \<le> f a + u * (x - a)"
	proof -
	from assms(2-)
	mvt_very_simple[of a x f "\<lambda>x. (*) (f' x)",
	rule_format,
	OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
	obtain y where "y \<in> {a .. x}" "f x - f a = (x - a) * f' y"
	by (auto simp: Bex_def ac_simps)
	moreover hence "f' y \<le> u" using assms by auto
	ultimately have "(x - a) * u \<ge> f x - f a"
	by (auto intro!: mult_left_mono)
	thus ?thesis by (simp add: algebra_simps)
	qed

	lemma
	linear_upper2:
	fixes x::real
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> (f has_field_derivative f' x) (at x within {a .. b})"
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> l \<le> f' x"
	assumes "x \<in> {a .. b}"
	shows "f x \<le> f b + l * (x - b)"
	proof -
	from assms(2-)
	mvt_very_simple[of x b f "\<lambda>x. (*) (f' x)",
	rule_format,
	OF _ has_derivative_subset[OF assms(1)[simplified has_field_derivative_def]]]
	obtain y where "y \<in> {x .. b}" "f b - f x = (b - x) * f' y"
	by (auto simp: Bex_def ac_simps)
	moreover hence "l \<le> f' y" using assms by auto
	ultimately have "f b - f x \<ge> (b - x) * l"
	by (auto intro!: mult_left_mono)
	thus ?thesis by (simp add: algebra_simps)
	qed

	lemma linear_enclosure:
	fixes x::real
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> (f has_field_derivative f' x) (at x within {a .. b})"
	assumes "\<And>x. x \<in> {a .. b} \<Longrightarrow> f' x \<le> u"
	assumes "x \<in> {a .. b}"
	shows "f x \<in> {f b + u * (x - b) .. f a + u * (x - a)}"
	using linear_lower[OF assms] linear_upper[OF assms]
	by auto

	definition "mid_err ivl = ((lower ivl + upper ivl::float)/2, (upper ivl - lower ivl)/2)"

	lemma degree_aform_uminus_aform[simp]: "degree_aform (uminus_aform X) = degree_aform X"
	by (auto simp: uminus_aform_def)


	subsubsection \<open>Addition\<close>

	definition add_aform::"'a::real_vector aform \<Rightarrow> 'a aform \<Rightarrow> 'a aform"
	where "add_aform x y = (fst x + fst y, add_pdevs (snd x) (snd y))"

	lemma aform_val_add_aform:
	shows "aform_val e (add_aform X Y) = aform_val e X + aform_val e Y"
	by (auto simp: add_aform_def aform_val_def)

	type_synonym aform_err = "real aform \<times> real"

	definition add_aform'::"nat \<Rightarrow> aform_err \<Rightarrow> aform_err \<Rightarrow> aform_err"
	where "add_aform' p x y =
	(let
	z0 = trunc_bound_eucl p (fst (fst x) + fst (fst y));
	z = trunc_bound_pdevs p (add_pdevs (snd (fst x)) (snd (fst y)))
	in ((fst z0, fst z), (sum_list' p [snd z0, snd z, abs (snd x), abs (snd y)])))"

	abbreviation degree_aform_err::"aform_err \<Rightarrow> nat"
	where "degree_aform_err X \<equiv> degree_aform (fst X)"

	lemma degree_aform_err_add_aform':
	assumes "degree_aform_err x \<le> n"
	assumes "degree_aform_err y \<le> n"
	shows "degree_aform_err (add_aform' p x y) \<le> n"
	using assms
	by (auto simp: add_aform'_def Let_def trunc_bound_pdevs_def
	intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le)

	definition "aform_err e Xe = {aform_val e (fst Xe) - snd Xe .. aform_val e (fst Xe) + snd Xe::real}"

	lemma aform_errI: "x \<in> aform_err e Xe"
	if "abs (x - aform_val e (fst Xe)) \<le> snd Xe"
	using that by (auto simp: aform_err_def abs_real_def algebra_simps split: if_splits)

	lemma add_aform':
	assumes e: "e \<in> UNIV \<rightarrow> {- 1..1}"
	assumes x: "x \<in> aform_err e X"
	assumes y: "y \<in> aform_err e Y"
	shows "x + y \<in> aform_err e (add_aform' p X Y)"
	proof -
	let ?t1 = "trunc_bound_eucl p (fst (fst X) + fst (fst Y))"
	from trunc_bound_euclE
	obtain e1 where abs_e1: "\<bar>e1\<bar> \<le> snd ?t1" and e1: "fst ?t1 = fst (fst X) + fst (fst Y) + e1"
	by blast
	let ?t2 = "trunc_bound_pdevs p (add_pdevs (snd (fst X)) (snd (fst Y)))"
	from trunc_bound_pdevsE[OF e, of p "add_pdevs (snd (fst X)) (snd (fst Y))"]
	obtain e2 where abs_e2: "\<bar>e2\<bar> \<le> snd (?t2)"
	and e2: "pdevs_val e (fst ?t2) = pdevs_val e (add_pdevs (snd (fst X)) (snd (fst Y))) + e2"
	by blast

	have e_le: "\<bar>e1 + e2 + snd X + snd Y\<bar> \<le> snd (add_aform' p (X) Y)"
	apply (auto simp: add_aform'_def Let_def )
	apply (rule sum_list'_sum_list_le)
	apply (simp add: add.assoc)
	by (intro order.trans[OF abs_triangle_ineq] add_mono abs_e1 abs_e2 order_refl)
	then show ?thesis
	apply (intro aform_errI)
	using x y abs_e1 abs_e2
	apply (simp add: aform_val_def aform_err_def add_aform_def add_aform'_def Let_def e1 e2 assms)
	by (auto intro!: order_trans[OF _ sum_list_le_sum_list'] )
	qed


	subsubsection \<open>Scaling\<close>

	definition aform_scaleR::"real aform \<Rightarrow> 'a::real_vector \<Rightarrow> 'a aform"
	where "aform_scaleR x y = (fst x *\<^sub>R y, pdevs_scaleR (snd x) y)"

	lemma aform_val_scaleR_aform[simp]:
	shows "aform_val e (aform_scaleR X y) = aform_val e X *\<^sub>R y"
	by (auto simp: aform_scaleR_def aform_val_def scaleR_left_distrib)


	subsubsection \<open>Multiplication\<close>

	lemma aform_val_mult_exact:
	"aform_val e x * aform_val e y =
	fst x * fst y +
	pdevs_val e (add_pdevs (scaleR_pdevs (fst y) (snd x)) (scaleR_pdevs (fst x) (snd y))) +
	(\<Sum>i<d. e i \<^sub>R pdevs_apply (snd x) i)(\<Sum>i<d. e i *\<^sub>R pdevs_apply (snd y) i)"
	if "degree (snd x) \<le> d" "degree (snd y) \<le> d"
	using that
	by (auto simp: pdevs_val_sum_less_degree[where d=d] aform_val_def algebra_simps)

	lemma sum_times_bound:\<comment> \<open>TODO: this gives better bounds for the remainder of multiplication\<close>
	"(\<Sum>i<d. e i * f i::real) * (\<Sum>i<d. e i * g i) =
	(\<Sum>i<d. (e i)\<^sup>2 * (f i * g i)) +
	(\<Sum>(i, j) \| i < j \<and> j < d. (e i * e j) * (f j * g i + f i * g j))" for d::nat
	proof -
	have "(\<Sum>i<d. e i * f i)(\<Sum>i<d. e i g i) = (\<Sum>(i, j)\<in>{..<d} \<times> {..<d}. e i * f i * (e j * g j))"
	unfolding sum_product sum.cartesian_product ..
	also have "\<dots> = (\<Sum>(i, j)\<in>{..<d} \<times> {..<d} \<inter> {(i, j). i = j}. e i * f i * (e j * g j)) +
	((\<Sum>(i, j)\<in>{..<d} \<times> {..<d} \<inter> {(i, j). i < j}. e i * f i * (e j * g j)) +
	(\<Sum>(i, j)\<in>{..<d} \<times> {..<d} \<inter> {(i, j). j < i}. e i * f i * (e j * g j)))"
	(is "_ = ?a + (?b + ?c)")
	by (subst sum.union_disjoint[symmetric], force, force, force)+ (auto intro!: sum.cong)
	also have "?c = (\<Sum>(i, j)\<in>{..<d} \<times> {..<d} \<inter> {(i, j). i < j}. e i * f j * (e j * g i))"
	by (rule sum.reindex_cong[of "\<lambda>(x, y). (y, x)"]) (auto intro!: inj_onI)
	also have "?b + \<dots> = (\<Sum>(i, j)\<in>{..<d} \<times> {..<d} \<inter> {(i, j). i < j}. (e i * e j) * (f j * g i + f i * g j))"
	by (auto simp: algebra_simps sum.distrib split_beta')
	also have "\<dots> = (\<Sum>(i, j) \| i < j \<and> j < d. (e i * e j) * (f j * g i + f i * g j))"
	by (rule sum.cong) auto
	also have "?a = (\<Sum>i<d. (e i)\<^sup>2 * (f i * g i))"
	by (rule sum.reindex_cong[of "\<lambda>i. (i, i)"]) (auto simp: power2_eq_square intro!: inj_onI)
	finally show ?thesis by simp
	qed

	definition mult_aform::"aform_err \<Rightarrow> aform_err \<Rightarrow> aform_err"
	where "mult_aform x y = ((fst (fst x) * fst (fst y),
	(add_pdevs (scaleR_pdevs (fst (fst y)) (snd (fst x))) (scaleR_pdevs (fst (fst x)) (snd (fst y))))),
	(tdev (snd (fst x)) * tdev (snd (fst y)) +
	abs (snd x) * (abs (fst (fst y)) + Radius (fst y)) +
	abs (snd y) * (abs (fst (fst x)) + Radius (fst x)) + abs (snd x) * abs (snd y)
	))"

	lemma mult_aformE:
	fixes X Y::"aform_err"
	assumes e: "e \<in> UNIV \<rightarrow> {- 1..1}"
	assumes x: "x \<in> aform_err e X"
	assumes y: "y \<in> aform_err e Y"
	shows "x * y \<in> aform_err e (mult_aform X Y)"
	proof -
	define ex where "ex \<equiv> x - aform_val e (fst X)"
	define ey where "ey \<equiv> y - aform_val e (fst Y)"

	have [intro, simp]: "\<bar>ex\<bar> \<le> \<bar>snd X\<bar>" "\<bar>ey\<bar> \<le> \<bar>snd Y\<bar>"
	using x y
	by (auto simp: ex_def ey_def aform_err_def)
	have "x * y =
	fst (fst X) * fst (fst Y) +
	fst (fst Y) * pdevs_val e (snd (fst X)) +
	fst (fst X) * pdevs_val e (snd (fst Y)) +

	(pdevs_val e (snd (fst X)) * pdevs_val e (snd (fst Y)) +
	ex * (fst (fst Y) + pdevs_val e (snd (fst Y))) +
	ey * (fst (fst X) + pdevs_val e (snd (fst X))) +
	ex * ey)"
	(is "_ = ?c + ?d + ?e + ?err")
	by (auto simp: ex_def ey_def algebra_simps aform_val_def)

	have abs_err: "abs ?err \<le> snd (mult_aform X Y)"
	by (auto simp: mult_aform_def abs_mult
	intro!: abs_triangle_ineq[THEN order_trans] add_mono mult_mono
	abs_pdevs_val_le_tdev e)
	show ?thesis
	apply (auto simp: intro!: aform_errI order_trans[OF _ abs_err])
	apply (subst mult_aform_def)
	apply (auto simp: aform_val_def ex_def ey_def algebra_simps)
	done
	qed

	definition mult_aform'::"nat \<Rightarrow> aform_err \<Rightarrow> aform_err \<Rightarrow> aform_err"
	where "mult_aform' p x y = (
	let
	(fx, sx) = x;
	(fy, sy) = y;
	ex = abs sx;
	ey = abs sy;
	z0 = trunc_bound_eucl p (fst fx * fst fy);
	u = trunc_bound_pdevs p (scaleR_pdevs (fst fy) (snd fx));
	v = trunc_bound_pdevs p (scaleR_pdevs (fst fx) (snd fy));
	w = trunc_bound_pdevs p (add_pdevs (fst u) (fst v));
	tx = tdev' p (snd fx);
	ty = tdev' p (snd fy);
	l = truncate_up p (tx * ty);
	ee = truncate_up p (ex * ey);
	e1 = truncate_up p (ex * truncate_up p (abs (fst fy) + ty));
	e2 = truncate_up p (ey * truncate_up p (abs (fst fx) + tx))
	in
	((fst z0, (fst w)), (sum_list' p [ee, e1, e2, l, snd z0, snd u, snd v, snd w])))"

	lemma aform_errE:
	"abs (x - aform_val e (fst X)) \<le> snd X"
	if "x \<in> aform_err e X"
	using that by (auto simp: aform_err_def)

	lemma mult_aform'E:
	fixes X Y::"aform_err"
	assumes e: "e \<in> UNIV \<rightarrow> {- 1..1}"
	assumes x: "x \<in> aform_err e X"
	assumes y: "y \<in> aform_err e Y"
	shows "x * y \<in> aform_err e (mult_aform' p X Y)"
	proof -
	let ?z0 = "trunc_bound_eucl p (fst (fst X) * fst (fst Y))"
	from trunc_bound_euclE
	obtain e1 where abs_e1: "\<bar>e1\<bar> \<le> snd ?z0" and e1: "fst ?z0 = fst (fst X) * fst (fst Y) + e1"
	by blast
	let ?u = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst Y)) (snd (fst X)))"
	from trunc_bound_pdevsE[OF e]
	obtain e2 where abs_e2: "\<bar>e2\<bar> \<le> snd (?u)"
	and e2: "pdevs_val e (fst ?u) = pdevs_val e (scaleR_pdevs (fst (fst Y)) (snd (fst X))) + e2"
	by blast
	let ?v = "trunc_bound_pdevs p (scaleR_pdevs (fst (fst X)) (snd (fst Y)))"
	from trunc_bound_pdevsE[OF e]
	obtain e3 where abs_e3: "\<bar>e3\<bar> \<le> snd (?v)"
	and e3: "pdevs_val e (fst ?v) = pdevs_val e (scaleR_pdevs (fst (fst X)) (snd (fst Y))) + e3"
	by blast
	let ?w = "trunc_bound_pdevs p (add_pdevs (fst ?u) (fst ?v))"
	from trunc_bound_pdevsE[OF e]
	obtain e4 where abs_e4: "\<bar>e4\<bar> \<le> snd (?w)"
	and e4: "pdevs_val e (fst ?w) = pdevs_val e (add_pdevs (fst ?u) (fst ?v)) + e4"
	by blast
	let ?tx = "tdev' p (snd (fst X))" and ?ty = "tdev' p (snd (fst Y))"
	let ?l = "truncate_up p (?tx * ?ty)"
	let ?ee = "truncate_up p (abs (snd X) * abs (snd Y))"
	let ?e1 = "truncate_up p (abs (snd X) * truncate_up p (\<bar>fst (fst Y)\<bar> + ?ty))"
	let ?e2 = "truncate_up p (abs (snd Y) * truncate_up p (\<bar>fst (fst X)\<bar> + ?tx))"

	let ?e0 = "x * y - fst (fst X) * fst (fst Y) -
	fst (fst X) * pdevs_val e (snd (fst Y)) -
	fst (fst Y) * pdevs_val e (snd (fst X))"
	let ?err = "?e0 - (e1 + e2 + e3 + e4)"
	have "abs ?err \<le> abs ?e0 + abs e1 + abs e2 + abs e3 + abs e4"
	by arith
	also have "\<dots> \<le> abs ?e0 + snd ?z0 + snd ?u + snd ?v + snd ?w"
	unfolding abs_mult
	by (auto intro!: add_mono mult_mono e abs_pdevs_val_le_tdev' abs_ge_zero abs_e1 abs_e2 abs_e3
	abs_e4 intro: tdev'_le)
	also
	have asdf: "snd (mult_aform X Y) \<le> tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) + ?e1 + ?e2 + ?ee"
	by (auto simp: mult_aform_def intro!: add_mono mult_mono order_trans[OF _ tdev'] truncate_up_le)
	have "abs ?e0 \<le> ?ee + ?e1 + ?e2 + tdev' p (snd (fst X)) * tdev' p (snd (fst Y))"
	using mult_aformE[OF e x y, THEN aform_errE, THEN order_trans, OF asdf]
	by (simp add: aform_val_def mult_aform_def) arith
	also have "tdev' p (snd (fst X)) * tdev' p (snd (fst Y)) \<le> ?l"
	by (auto intro!: truncate_up_le)
	also have "?ee + ?e1 + ?e2 + ?l + snd ?z0 + snd ?u + snd ?v + snd ?w \<le>
	sum_list' p [?ee, ?e1, ?e2, ?l, snd ?z0, snd ?u, snd ?v, snd ?w]"
	by (rule order_trans[OF _ sum_list_le_sum_list']) simp
	also have "\<dots> \<le> (snd (mult_aform' p X Y))"
	by (auto simp: mult_aform'_def Let_def assms split: prod.splits)
	finally have err_le: "abs ?err \<le> (snd (mult_aform' p X Y))" by arith

	show ?thesis
	apply (rule aform_errI[OF order_trans[OF _ err_le]])
	apply (subst mult_aform'_def)
	using e1 e2 e3 e4
	apply (auto simp: aform_val_def Let_def assms split: prod.splits)
	done
	qed

	lemma degree_aform_mult_aform':
	assumes "degree_aform_err x \<le> n"
	assumes "degree_aform_err y \<le> n"
	shows "degree_aform_err (mult_aform' p x y) \<le> n"
	using assms
	by (auto simp: mult_aform'_def Let_def trunc_bound_pdevs_def split: prod.splits
	intro!: degree_pdev_upd_le degree_trunc_pdevs_le degree_add_pdevs_le)

	lemma
	fixes x a b::real
	assumes "a > 0"
	assumes "x \<in> {a ..b}"
	assumes "- inverse (b*b) \<le> alpha"
	shows inverse_linear_lower: "inverse b + alpha * (x - b) \<le> inverse x" (is ?lower)
	and inverse_linear_upper: "inverse x \<le> inverse a + alpha * (x - a)" (is ?upper)
	proof -
	have deriv_inv:
	"\<And>x. x \<in> {a .. b} \<Longrightarrow> (inverse has_field_derivative - inverse (x*x)) (at x within {a .. b})"
	using assms
	by (auto intro!: derivative_eq_intros)
	show ?lower
	using assms
	by (intro linear_lower[OF deriv_inv])
	(auto simp: mult_mono intro!: order_trans[OF _ assms(3)])
	show ?upper
	using assms
	by (intro linear_upper[OF deriv_inv])
	(auto simp: mult_mono intro!: order_trans[OF _ assms(3)])
	qed


	subsubsection \<open>Inverse\<close>

	definition inverse_aform'::"nat \<Rightarrow> real aform \<Rightarrow> real aform \<times> real" where
	"inverse_aform' p X = (
	let l = Inf_aform' p X in
	let u = Sup_aform' p X in
	let a = min (abs l) (abs u) in
	let b = max (abs l) (abs u) in
	let sq = truncate_up p (b * b) in
	let alpha = - real_divl p 1 sq in
	let dmax = truncate_up p (real_divr p 1 a - alpha * a) in
	let dmin = truncate_down p (real_divl p 1 b - alpha * b) in
	let zeta' = truncate_up p ((dmin + dmax) / 2) in
	let zeta = if l < 0 then - zeta' else zeta' in
	let delta = truncate_up p (zeta - dmin) in
	let res1 = trunc_bound_eucl p (alpha * fst X) in
	let res2 = trunc_bound_eucl p (fst res1 + zeta) in
	let zs = trunc_bound_pdevs p (scaleR_pdevs alpha (snd X)) in
	((fst res2, fst zs), (sum_list' p [delta, snd res1, snd res2, snd zs])))"

	lemma inverse_aform'E:
	fixes X::"real aform"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes Inf_pos: "Inf_aform' p X > 0"
	assumes "x = aform_val e X"
	shows "inverse x \<in> aform_err e (inverse_aform' p X)"
	proof -
	define l where "l = Inf_aform' p X"
	define u where "u = Sup_aform' p X"
	define a where "a = min (abs l) (abs u)"
	define b where "b = max (abs l) (abs u)"
	define sq where "sq = truncate_up p (b * b)"
	define alpha where "alpha = - (real_divl p 1 sq)"
	define d_max' where "d_max' = truncate_up p (real_divr p 1 a - alpha * a)"
	define d_min' where "d_min' = truncate_down p (real_divl p 1 b - alpha * b)"
	define zeta where "zeta = truncate_up p ((d_min' + d_max') / 2)"
	define delta where "delta = truncate_up p (zeta - d_min')"
	note vars = l_def u_def a_def b_def sq_def alpha_def d_max'_def d_min'_def zeta_def delta_def
	let ?x = "aform_val e X"

	have "0 < l" using assms by (auto simp add: l_def Inf_aform_def)
	have "l \<le> u" by (auto simp: l_def u_def)

	hence a_def': "a = l" and b_def': "b = u" and "0 < a" "0 < b"
	using \<open>0 < l\<close> by (simp_all add: a_def b_def)
	have "0 < ?x"
	by (rule less_le_trans[OF Inf_pos order.trans[OF Inf_aform' Inf_aform], OF e])
	have "a \<le> ?x"
	by (metis order.trans Inf_aform e Inf_aform' a_def' l_def)
	have "?x \<le> b"
	by (metis order.trans Sup_aform e Sup_aform' b_def' u_def)
	hence "?x \<in> {?x .. b}"
	by simp

	have "- inverse (b * b) \<le> alpha"
	by (auto simp add: alpha_def inverse_mult_distrib[symmetric] inverse_eq_divide sq_def
	intro!: order_trans[OF real_divl] divide_left_mono truncate_up mult_pos_pos \<open>0 < b\<close>)

	{
	note \<open>0 < a\<close>
	moreover
	have "?x \<in> {a .. b}" using \<open>a \<le> ?x\<close> \<open>?x \<le> b\<close> by simp
	moreover
	note \<open>- inverse (b * b) \<le> alpha\<close>
	ultimately have "inverse ?x \<le> inverse a + alpha * (?x - a)"
	by (rule inverse_linear_upper)
	also have "\<dots> = alpha * ?x + (inverse a - alpha * a)"
	by (simp add: algebra_simps)
	also have "inverse a - (alpha * a) \<le> (real_divr p 1 a - alpha * a)"
	by (auto simp: inverse_eq_divide real_divr)
	also have "\<dots> \<le> (truncate_down p (real_divl p 1 b - alpha * b) +
	(real_divr p 1 a - alpha * a)) / 2 +
	(truncate_up p (real_divr p 1 a - alpha * a) -
	truncate_down p (real_divl p 1 b - alpha * b)) / 2"
	(is "_ \<le> (truncate_down p ?lb + ?ra) / 2 + (truncate_up p ?ra - truncate_down p ?lb) / 2")
	by (auto simp add: field_simps
	intro!: order_trans[OF _ add_left_mono[OF mult_left_mono[OF truncate_up]]])
	also have "(truncate_down p ?lb + ?ra) / 2 \<le>
	truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2)"
	by (intro truncate_up_le divide_right_mono add_left_mono truncate_up) auto
	also
	have "(truncate_up p ?ra - truncate_down p ?lb) / 2 + truncate_down p ?lb \<le>
	(truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2))"
	by (rule truncate_up_le) (simp add: field_simps)
	hence "(truncate_up p ?ra - truncate_down p ?lb) / 2 \<le> truncate_up p
	(truncate_up p ((truncate_down p ?lb + truncate_up p ?ra) / 2) - truncate_down p ?lb)"
	by (intro truncate_up_le) (simp add: field_simps)
	finally have "inverse ?x \<le> alpha * ?x + zeta + delta"
	by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib ac_simps)
	} note upper = this

	{
	have "alpha * b + truncate_down p (real_divl p 1 b - alpha * b) \<le> inverse b"
	by (rule order_trans[OF add_left_mono[OF truncate_down]])
	(auto simp: inverse_eq_divide real_divl)
	hence "zeta + alpha * b \<le> delta + inverse b"
	by (auto simp: zeta_def delta_def d_min'_def d_max'_def right_diff_distrib
	intro!: order_trans[OF _ add_right_mono[OF truncate_up]])
	hence "alpha * ?x + zeta - delta \<le> inverse b + alpha * (?x - b)"
	by (simp add: algebra_simps)
	also
	{
	note \<open>0 < aform_val e X\<close>
	moreover
	note \<open>aform_val e X \<in> {aform_val e X .. b}\<close>
	moreover

	note \<open>- inverse (b * b) \<le> alpha\<close>
	ultimately
	have "inverse b + alpha * (aform_val e X - b) \<le> inverse (aform_val e X)"
	by (rule inverse_linear_lower)
	}
	finally have "alpha * (aform_val e X) + zeta - delta \<le> inverse (aform_val e X)" .
	} note lower = this


	have "inverse (aform_val e X) = alpha * (aform_val e X) + zeta +
	(inverse (aform_val e X) - alpha * (aform_val e X) - zeta)"
	(is "_ = _ + ?linerr")
	by simp
	also
	have "?linerr \<in> {- delta .. delta}"
	using lower upper by simp
	hence linerr_le: "abs ?linerr \<le> delta"
	by auto

	let ?z0 = "trunc_bound_eucl p (alpha * fst X)"
	from trunc_bound_euclE
	obtain e1 where abs_e1: "\<bar>e1\<bar> \<le> snd ?z0" and e1: "fst ?z0 = alpha * fst X + e1"
	by blast
	let ?z1 = "trunc_bound_eucl p (fst ?z0 + zeta)"
	from trunc_bound_euclE
	obtain e1' where abs_e1': "\<bar>e1'\<bar> \<le> snd ?z1" and e1': "fst ?z1 = fst ?z0 + zeta + e1'"
	by blast

	let ?zs = "trunc_bound_pdevs p (scaleR_pdevs alpha (snd X))"
	from trunc_bound_pdevsE[OF e]
	obtain e2 where abs_e2: "\<bar>e2\<bar> \<le> snd (?zs)"
	and e2: "pdevs_val e (fst ?zs) = pdevs_val e (scaleR_pdevs alpha (snd X)) + e2"
	by blast

	have "alpha * (aform_val e X) + zeta =
	aform_val e (fst (inverse_aform' p X)) + (- e1 - e1' - e2)"
	unfolding inverse_aform'_def Let_def vars[symmetric]
	using \<open>0 < l\<close>
	by (simp add: aform_val_def assms e1') (simp add: e1 e2 algebra_simps)
	also
	let ?err = "(- e1 - e1' - e2 + inverse (aform_val e X) - alpha * aform_val e X - zeta)"
	{
	have "abs ?err \<le> abs ?linerr + abs e1 + abs e1' + abs e2"
	by simp
	also have "\<dots> \<le> delta + snd ?z0 + snd ?z1 + snd ?zs"
	by (blast intro: add_mono linerr_le abs_e1 abs_e1' abs_e2)
	also have "\<dots> \<le> (snd (inverse_aform' p X))"
	unfolding inverse_aform'_def Let_def vars[symmetric]
	using \<open>0 < l\<close>
	by (auto simp add: inverse_aform'_def pdevs_apply_trunc_pdevs assms vars[symmetric]
	intro!: order.trans[OF _ sum_list'_sum_list_le])
	finally have "abs ?err \<le> snd (inverse_aform' p X)" by simp
	} note err_le = this
	have "aform_val (e) (fst (inverse_aform' p X)) + (- e1 - e1' - e2) +
	(inverse (aform_val e X) - alpha * aform_val e X - zeta) =
	aform_val e (fst (inverse_aform' p X)) + ?err"
	by simp
	finally
	show ?thesis
	apply (intro aform_errI)
	using err_le
	by (auto simp: assms)
	qed

	definition "inverse_aform p a =
	do {
	let l = Inf_aform' p a;
	let u = Sup_aform' p a;
	if (l \<le> 0 \<and> 0 \<le> u) then None
	else if (l \<le> 0) then (Some (apfst uminus_aform (inverse_aform' p (uminus_aform a))))
	else Some (inverse_aform' p a)
	}"

	lemma eucl_truncate_up_eq_eucl_truncate_down:
	"eucl_truncate_up p x = - (eucl_truncate_down p (- x))"
	by (auto simp: eucl_truncate_up_def eucl_truncate_down_def truncate_up_eq_truncate_down sum_negf)

	lemma inverse_aformE:
	fixes X::"real aform"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	and disj: "Inf_aform' p X > 0 \<or> Sup_aform' p X < 0"
	obtains Y where
	"inverse_aform p X = Some Y"
	"inverse (aform_val e X) \<in> aform_err e Y"
	proof -
	{
	assume neg: "Sup_aform' p X < 0"
	from neg have [simp]: "Inf_aform' p X \<le> 0"
	by (metis Inf_aform'_le_Sup_aform' dual_order.strict_trans1 less_asym not_less)
	from neg disj have "0 < Inf_aform' p (uminus_aform X)"
	by (auto simp: Inf_aform'_def Sup_aform'_def eucl_truncate_up_eq_eucl_truncate_down ac_simps)
	from inverse_aform'E[OF e(1) this]
	have iin: "inverse (aform_val e (uminus_aform X)) \<in> aform_err e (inverse_aform' p (uminus_aform X))"
	by simp
	let ?Y = "apfst uminus_aform (inverse_aform' p (uminus_aform X))"
	have "inverse_aform p X = Some ?Y"
	"inverse (aform_val e X) \<in> aform_err e ?Y"
	using neg iin by (auto simp: inverse_aform_def aform_err_def)
	then have ?thesis ..
	} moreover {
	assume pos: "Inf_aform' p X > 0"
	from pos have eq: "inverse_aform p X = Some (inverse_aform' p X)"
	by (auto simp: inverse_aform_def)
	moreover
	from inverse_aform'E[OF e(1) pos refl]
	have "inverse (aform_val e X) \<in> aform_err e (inverse_aform' p X)" .
	ultimately have ?thesis ..
	} ultimately show ?thesis
	using assms by auto
	qed

	definition aform_err_to_aform::"aform_err \<Rightarrow> nat \<Rightarrow> real aform"
	where "aform_err_to_aform X n = (fst (fst X), pdev_upd (snd (fst X)) n (snd X))"

	lemma aform_err_to_aformE:
	assumes "x \<in> aform_err e X"
	assumes deg: "degree_aform_err X \<le> n"
	obtains err where "x = aform_val (e(n:=err)) (aform_err_to_aform X n)"
	"-1 \<le> err" "err \<le> 1"
	proof -
	from aform_errE[OF assms(1)] have "\<bar>x - aform_val e (fst X)\<bar> \<le> snd X" by auto
	from error_absE[OF this] obtain err where err:
	"x - aform_val e (fst X) = err * snd X" "err \<in> {- 1..1}"
	by auto
	have "x = aform_val (e(n:=err)) (aform_err_to_aform X n)"
	"-1 \<le> err" "err \<le> 1"
	using err deg
	by (auto simp: aform_val_def aform_err_to_aform_def)
	then show ?thesis ..
	qed

	definition aform_to_aform_err::"real aform \<Rightarrow> nat \<Rightarrow> aform_err"
	where "aform_to_aform_err X n = ((fst X, pdev_upd (snd X) n 0), abs (pdevs_apply (snd X) n))"

	lemma aform_to_aform_err: "aform_val e X \<in> aform_err e (aform_to_aform_err X n)"
	if "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	from that have abs_e[simp]: "\<And>i. \<bar>e i\<bar> \<le> 1" by (auto simp: abs_real_def)
	have "- e n * pdevs_apply (snd X) n \<le> \<bar>pdevs_apply (snd X) n\<bar>"
	proof -
	have "- e n * pdevs_apply (snd X) n \<le> \<bar>- e n * pdevs_apply (snd X) n\<bar>"
	by auto
	also have "\<dots> \<le> abs (pdevs_apply (snd X) n)"
	using that
	by (auto simp: abs_mult intro!: mult_left_le_one_le)
	finally show ?thesis .
	qed
	moreover have "e n * pdevs_apply (snd X) n \<le> \<bar>pdevs_apply (snd X) n\<bar>"
	proof -
	have "e n * pdevs_apply (snd X) n \<le> \<bar>e n * pdevs_apply (snd X) n\<bar>"
	by auto
	also have "\<dots> \<le> abs (pdevs_apply (snd X) n)"
	using that
	by (auto simp: abs_mult intro!: mult_left_le_one_le)
	finally show ?thesis .
	qed
	ultimately
	show ?thesis
	by (auto simp: aform_to_aform_err_def aform_err_def aform_val_def)
	qed

	definition "acc_err p x e \<equiv> (fst x, truncate_up p (snd x + e))"

	definition ivl_err :: "real interval \<Rightarrow> (real \<times> real pdevs) \<times> real"
	where "ivl_err ivl \<equiv> (((upper ivl + lower ivl)/2, zero_pdevs::real pdevs), (upper ivl - lower ivl) / 2)"

	lemma inverse_aform:
	fixes X::"real aform"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "inverse_aform p X = Some Y"
	shows "inverse (aform_val e X) \<in> aform_err e Y"
	proof -
	from assms have "Inf_aform' p X > 0 \<or> 0 > Sup_aform' p X"
	by (auto simp: inverse_aform_def Let_def bind_eq_Some_conv split: if_splits)
	from inverse_aformE[OF e this] obtain Y where
	"inverse_aform p X = Some Y" "inverse (aform_val e X) \<in> aform_err e Y"
	by auto
	with assms show ?thesis by auto
	qed

	lemma aform_err_acc_err_leI:
	"fx \<in> aform_err e (acc_err p X err)"
	if "aform_val e (fst X) - (snd X + err) \<le> fx" "fx \<le> aform_val e (fst X) + (snd X + err)"
	using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that
	by (auto simp: aform_err_def acc_err_def)

	lemma aform_err_acc_errI:
	"fx \<in> aform_err e (acc_err p X err)"
	if "fx \<in> aform_err e (fst X, snd X + err)"
	using truncate_up[of "(snd X + err)" p] truncate_down[of p "(snd X + err)"] that
	by (auto simp: aform_err_def acc_err_def)

	lemma minus_times_le_abs: "- (err * B) \<le> \<bar>B\<bar>" if "-1 \<le> err" "err \<le> 1" for err::real
	proof -
	- have [simp]: "abs err \<le> 1" using that by (auto simp: )
	+ have [simp]: "abs err \<le> 1" using that by auto
	have "- (err * B) \<le> abs (- err * B)" by auto
	also have "\<dots> \<le> abs B"
	by (auto simp: abs_mult intro!: mult_left_le_one_le)
	finally show ?thesis by simp
	qed

	lemma times_le_abs: "err * B \<le> \<bar>B\<bar>" if "-1 \<le> err" "err \<le> 1" for err::real
	proof -
	- have [simp]: "abs err \<le> 1" using that by (auto simp: )
	+ have [simp]: "abs err \<le> 1" using that by auto
	have "err * B \<le> abs (err * B)" by auto
	also have "\<dots> \<le> abs B"
	by (auto simp: abs_mult intro!: mult_left_le_one_le)
	finally show ?thesis by simp
	qed

	lemma aform_err_lemma1: "- 1 \<le> err \<Longrightarrow> err \<le> 1 \<Longrightarrow>
	X1 + (A - e d * B + err * B) - e1 \<le> x \<Longrightarrow>
	X1 + (A - e d * B) - truncate_up p (\<bar>B\<bar> + e1) \<le> x"
	apply (rule order_trans)
	apply (rule diff_mono)
	apply (rule order_refl)
	apply (rule truncate_up_le[where x="e1 - err * B"])
	by (auto simp: minus_times_le_abs)

	lemma aform_err_lemma2: "- 1 \<le> err \<Longrightarrow> err \<le> 1 \<Longrightarrow>
	x \<le> X1 + (A - e d * B + err * B) + e1 \<Longrightarrow>
	x \<le> X1 + (A - e d * B) + truncate_up p (\<bar>B\<bar> + e1)"
	apply (rule order_trans[rotated])
	apply (rule add_mono)
	apply (rule order_refl)
	apply (rule truncate_up_le[where x="e1 + err * B"])
	by (auto simp: times_le_abs)

	lemma aform_err_acc_err_aform_to_aform_errI:
	"x \<in> aform_err e (acc_err p (aform_to_aform_err X1 d) e1)"
	if "-1 \<le> err" "err \<le> 1" "x \<in> aform_err (e(d := err)) (X1, e1)"
	using that
	by (auto simp: acc_err_def aform_err_def aform_val_def aform_to_aform_err_def
	aform_err_to_aform_def aform_err_lemma1 aform_err_lemma2)

	definition "map_aform_err I p X =
	(do {
	let X0 = aform_err_to_aform X (degree_aform_err X);
	(X1, e1) \<leftarrow> I X0;
	Some (acc_err p (aform_to_aform_err X1 (degree_aform_err X)) e1)
	})"

	lemma map_aform_err:
	"i x \<in> aform_err e Y"
	if I: "\<And>e X Y. e \<in> UNIV \<rightarrow> {-1 .. 1} \<Longrightarrow> I X = Some Y \<Longrightarrow> i (aform_val e X) \<in> aform_err e Y"
	and e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	and Y: "map_aform_err I p X = Some Y"
	and x: "x \<in> aform_err e X"
	proof -
	obtain X1 e1 where
	X1: "(I (aform_err_to_aform X (degree_aform_err X))) = Some (X1, e1)"
	and Y: "Y = acc_err p (aform_to_aform_err X1 (degree_aform (fst X))) e1"
	using Y by (auto simp: map_aform_err_def bind_eq_Some_conv Let_def)
	from aform_err_to_aformE[OF x] obtain err where
	err: "x = aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X (degree_aform_err X)) "
	(is "_ = aform_val ?e _")
	and "- 1 \<le> err" "err \<le> 1"
	by auto
	then have e': "?e \<in> UNIV \<rightarrow> {-1 .. 1}" using e by auto
	from err have "i x =
	i (aform_val (e(degree_aform_err X := err)) (aform_err_to_aform X (degree_aform_err X)))"
	by simp
	also note I[OF e' X1]
	also have "aform_err (e(degree_aform_err X := err)) (X1, e1) \<subseteq> aform_err e Y"
	apply rule
	unfolding Y using \<open>-1 \<le> err\<close> \<open>err \<le> 1\<close>
	by (rule aform_err_acc_err_aform_to_aform_errI)
	finally show ?thesis .
	qed

	definition "inverse_aform_err p X = map_aform_err (inverse_aform p) p X"

	lemma inverse_aform_err:
	"inverse x \<in> aform_err e Y"
	if e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	and Y: "inverse_aform_err p X = Some Y"
	and x: "x \<in> aform_err e X"
	using map_aform_err[OF inverse_aform[where p=p] e Y[unfolded inverse_aform_err_def] x]
	by auto

	subsection \<open>Reduction (Summarization of Coefficients)\<close>
	text \<open>\label{sec:affinesummarize}\<close>

	definition "pdevs_of_centered_ivl r = (inner_scaleR_pdevs r One_pdevs)"

	lemma pdevs_of_centered_ivl_eq_pdevs_of_ivl[simp]: "pdevs_of_centered_ivl r = pdevs_of_ivl (-r) r"
	by (auto simp: pdevs_of_centered_ivl_def pdevs_of_ivl_def algebra_simps intro!: pdevs_eqI)

	lemma filter_pdevs_raw_nonzeros: "{i. filter_pdevs_raw s f i \<noteq> 0} = {i. f i \<noteq> 0} \<inter> {x. s x (f x)}"
	by (auto simp: filter_pdevs_raw_def)

	definition summarize_pdevs::
	"nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a::executable_euclidean_space pdevs \<Rightarrow> 'a pdevs"
	where "summarize_pdevs p I d x =
	(let t = tdev' p (filter_pdevs (-I) x)
	in msum_pdevs d (filter_pdevs I x) (pdevs_of_centered_ivl t))"

	definition summarize_threshold
	where "summarize_threshold p t x y \<longleftrightarrow> infnorm y \<ge> t * infnorm (eucl_truncate_up p (tdev' p x))"

	lemma error_abs_euclE:
	fixes err::"'a::ordered_euclidean_space"
	assumes "abs err \<le> k"
	obtains e::"'a \<Rightarrow> real" where "err = (\<Sum>i\<in>Basis. (e i * (k \<bullet> i)) *\<^sub>R i)" "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof atomize_elim
	{
	fix i::'a
	assume "i \<in> Basis"
	hence "abs (err \<bullet> i) \<le> (k \<bullet> i)" using assms by (auto simp add: eucl_le[where 'a='a] abs_inner)
	hence "\<exists>e. (err \<bullet> i = e * (k \<bullet> i)) \<and> e \<in> {-1..1}"
	by (rule error_absE) auto
	}
	then obtain e where e:
	"\<And>i. i \<in> Basis \<Longrightarrow> err \<bullet> i = e i * (k \<bullet> i)"
	"\<And>i. i \<in> Basis \<Longrightarrow> e i \<in> {-1 .. 1}"
	by metis
	have singleton: "\<And>b. b \<in> Basis \<Longrightarrow> (\<Sum>i\<in>Basis. e i * (k \<bullet> i) * (if i = b then 1 else 0)) =
	(\<Sum>i\<in>{b}. e i * (k \<bullet> i) * (if i = b then 1 else 0))"
	by (rule sum.mono_neutral_cong_right) auto
	show "\<exists>e::'a\<Rightarrow>real. err = (\<Sum>i\<in>Basis. (e i * (k \<bullet> i)) *\<^sub>R i) \<and> (e \<in> UNIV \<rightarrow> {-1..1})"
	using e
	by (auto intro!: exI[where x="\<lambda>i. if i \<in> Basis then e i else 0"] euclidean_eqI[where 'a='a]
	simp: inner_sum_left inner_Basis singleton)
	qed

	lemma summarize_pdevsE:
	fixes x::"'a::executable_euclidean_space pdevs"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes d: "degree x \<le> d"
	obtains e' where "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)"
	"\<And>i. i < d \<Longrightarrow> e i = e' i"
	"e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof atomize_elim
	have "pdevs_val e x = (\<Sum>i<degree x. e i *\<^sub>R pdevs_apply x i)"
	by (auto simp add: pdevs_val_sum intro!: sum.cong)
	also have "\<dots> = (\<Sum>i \<in> {..<degree x} \<inter> {i. I i (pdevs_apply x i)}. e i *\<^sub>R pdevs_apply x i) +
	(\<Sum>i\<in> {..<degree x} - {i. I i (pdevs_apply x i)}. e i *\<^sub>R pdevs_apply x i)"
	(is "_ = ?large + ?small")
	by (subst sum.union_disjoint[symmetric]) (auto simp: ac_simps intro!: sum.cong)
	also have "?large = pdevs_val e (filter_pdevs I x)"
	by (simp add: pdevs_val_filter_pdevs)
	also have "?small = pdevs_val e (filter_pdevs (-I) x)"
	by (simp add: pdevs_val_filter_pdevs Collect_neg_eq Diff_eq)
	also
	have "abs \<dots> \<le> tdev' p (filter_pdevs (-I) x)" (is "abs ?r \<le> ?t")
	using e by (rule abs_pdevs_val_le_tdev')
	hence "?r \<in> {-?t .. ?t}"
	by (metis abs_le_D1 abs_le_D2 atLeastAtMost_iff minus_le_iff)
	from in_ivl_affine_of_ivlE[OF this] obtain e2
	where "?r = aform_val e2 (aform_of_ivl (- ?t) ?t)"
	and e2: "e2 \<in> UNIV \<rightarrow> {- 1..1}"
	by metis
	note this(1)
	also
	define e' where "e' i = (if i < d then e i else e2 (i - d))" for i
	hence "aform_val e2 (aform_of_ivl (- ?t) ?t) =
	pdevs_val (\<lambda>i. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)"
	by (auto simp: aform_of_ivl_def aform_val_def)
	also
	have "pdevs_val e (filter_pdevs I x) = pdevs_val e' (filter_pdevs I x)"
	using assms by (auto simp: e'_def pdevs_val_sum intro!: sum.cong)
	finally have "pdevs_val e x =
	pdevs_val e' (filter_pdevs I x) + pdevs_val (\<lambda>i. e' (i + d)) (pdevs_of_ivl (- ?t) ?t)"
	.
	also note pdevs_val_msum_pdevs[symmetric, OF order_trans[OF degree_filter_pdevs_le d]]
	finally have "pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x)"
	by (auto simp: summarize_pdevs_def Let_def)
	moreover have "e' \<in> UNIV \<rightarrow> {-1 .. 1}" using e e2 by (auto simp: e'_def Pi_iff)
	moreover have "\<forall>i < d. e' i = e i"
	by (auto simp: e'_def)
	ultimately show "\<exists>e'. pdevs_val e x = pdevs_val e' (summarize_pdevs p I d x) \<and>
	(\<forall>i<d. e i = e' i) \<and> e' \<in> UNIV \<rightarrow> {- 1..1}"
	by auto
	qed

	definition "summarize_pdevs_list p I d xs =
	map (\<lambda>(d, x). summarize_pdevs p (\<lambda>i _. I i (pdevs_applys xs i)) d x) (zip [d..<d + length xs] xs)"

	lemma filter_pdevs_cong[cong]:
	assumes "x = y"
	assumes "\<And>i. i \<in> pdevs_domain y \<Longrightarrow> P i (pdevs_apply x i) = Q i (pdevs_apply y i)"
	shows "filter_pdevs P x = filter_pdevs Q y"
	using assms
	by (force intro!: pdevs_eqI)

	lemma summarize_pdevs_cong[cong]:
	assumes "p = q" "a = c" "b = d"
	assumes PQ: "\<And>i. i \<in> pdevs_domain d \<Longrightarrow> P i (pdevs_apply b i) = Q i (pdevs_apply d i)"
	shows "summarize_pdevs p P a b = summarize_pdevs q Q c d"
	proof -
	have "(filter_pdevs P b) = filter_pdevs Q d"
	"(filter_pdevs (\<lambda>a b. \<not> P a b) b) = filter_pdevs (\<lambda>a b. \<not> Q a b) d"
	using assms
	by (auto intro!: filter_pdevs_cong)
	then show ?thesis by (auto simp add: assms summarize_pdevs_def Let_def)
	qed

	lemma lookup_eq_None_iff: "(Mapping.lookup M x = None) = (x \<notin> Mapping.keys M)"
	by (transfer) auto

	lemma lookup_eq_SomeD:
	"(Mapping.lookup M x = Some y) \<Longrightarrow> (x \<in> Mapping.keys M)"
	by transfer auto

	definition "domain_pdevs xs = (\<Union>(pdevs_domain ` (set xs)))"

	definition "pdevs_mapping xs =
	(let
	D = sorted_list_of_set (domain_pdevs xs);
	M = Mapping.tabulate D (pdevs_applys xs);
	zeroes = replicate (length xs) 0
	in Mapping.lookup_default zeroes M)"

	lemma pdevs_mapping_eq[simp]: "pdevs_mapping xs = pdevs_applys xs"
	unfolding pdevs_mapping_def pdevs_applys_def
	apply (auto simp: Mapping.lookup_default_def lookup_eq_None_iff domain_pdevs_def
	split: option.splits intro!: ext)
	subgoal by (auto intro!: nth_equalityI)
	subgoal apply (auto intro!: nth_equalityI dest: )
	subgoal
	apply (frule lookup_eq_SomeD)
	apply auto
	by (metis distinct_sorted_list_of_set keys_tabulate length_map lookup_eq_SomeD lookup_tabulate option.inject)
	subgoal
	apply (frule lookup_eq_SomeD)
	apply (auto simp: map_nth)
	by (metis (mono_tags, lifting) keys_tabulate
	lookup_eq_SomeD lookup_tabulate option.inject distinct_sorted_list_of_set)
	done
	done

	lemma compute_summarize_pdevs_list[code]:
	"summarize_pdevs_list p I d xs =
	(let M = pdevs_mapping xs
	in map (\<lambda>(x, y). summarize_pdevs p (\<lambda>i _. I i (M i)) x y) (zip [d..<d + length xs] xs))"
	unfolding summarize_pdevs_list_def pdevs_mapping_eq
	by auto

	lemma
	in_centered_ivlE:
	fixes r t::real
	assumes "r \<in> {-t .. t}"
	obtains e where "e \<in> {-1 .. 1}" "r = e * t"
	using assms
	by (atomize_elim) (auto intro!: exI[where x="r / t"] simp: divide_simps)

	lift_definition singleton_pdevs::"'a \<Rightarrow> 'a::real_normed_vector pdevs" is "\<lambda>x i. if i = 0 then x else 0"
	by auto
	lemmas [simp] = singleton_pdevs.rep_eq

	lemma singleton_0[simp]: "singleton_pdevs 0 = zero_pdevs"
	by (auto intro!: pdevs_eqI)

	lemma degree_singleton_pdevs[simp]: "degree (singleton_pdevs x) = (if x = 0 then 0 else Suc 0)"
	by (auto simp: intro!: degree_eqI)

	lemma pdevs_val_singleton_pdevs[simp]: "pdevs_val e (singleton_pdevs x) = e 0 *\<^sub>R x"
	by (auto simp: pdevs_val_sum if_distrib sum.delta cong: if_cong)

	lemma pdevs_of_ivl_real:
	fixes a b::real
	shows "pdevs_of_ivl a b = singleton_pdevs ((b - a) / 2)"
	by (auto simp: pdevs_of_ivl_def Basis_list_real_def intro!: pdevs_eqI)

	lemma summarize_pdevs_listE:
	fixes X::"real pdevs list"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes d: "degrees X \<le> d"
	obtains e' where "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)"
	"\<And>i. i < d \<Longrightarrow> e i = e' i"
	"e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	let ?I = "{i. I i (pdevs_applys X i)}"
	let ?J = "\<lambda>i x. I i (pdevs_applys X i)"

	have "pdevs_vals e X = map (\<lambda>x. \<Sum>i<degree x. e i *\<^sub>R pdevs_apply x i) X"
	using d
	by (auto simp: pdevs_vals_def
	simp del: real_scaleR_def
	intro!: pdevs_val_sum_le
	dest!: degrees_leD)
	also have "\<dots> = map (\<lambda>x.
	(\<Sum>i\<in>{..<degree x} \<inter> ?I. e i * pdevs_apply x i) +
	(\<Sum>i\<in>{..<degree x} - ?I. e i * pdevs_apply x i)) X"
	by (rule map_cong[OF refl], subst sum.union_disjoint[symmetric]) (auto intro!: sum.cong)
	also
	have "\<dots> = map (\<lambda>x. pdevs_val e (filter_pdevs ?J x) + pdevs_val e (filter_pdevs (-?J) x)) X"
	(is "_ = map (\<lambda>x. ?large x + ?small x) _")
	by (auto simp: pdevs_val_filter_pdevs Diff_eq Compl_eq)
	also have "\<dots> = map snd (zip [d..<d + length X] \<dots>)" by simp
	also have "\<dots> = map (\<lambda>(d, x). ?large x + ?small x) (zip [d..<d + length X] X)"
	(is "_ = map _ ?z")
	unfolding map_zip_map2
	by simp
	also have "\<dots> = map (\<lambda>(d', x). ?large x + ?small (snd (?z ! (d' - d)))) ?z"
	by (auto simp: in_set_zip)
	also
	let ?t = "\<lambda>x. tdev' p (filter_pdevs (-?J) x)"
	let ?x = "\<lambda>d'. snd (?z ! (d' - d))"
	{
	fix d' assume "d \<le> d'" "d' < d + length X"
	have "abs (?small (?x d')) \<le> ?t (?x d')"
	using \<open>e \<in> _\<close> by (rule abs_pdevs_val_le_tdev')
	then have "?small (?x d') \<in> {-?t (?x d') .. ?t (?x d')}"
	by auto
	from in_centered_ivlE[OF this] have "\<exists>e\<in>{-1 .. 1}. ?small (?x d') = e * ?t (?x d')" by blast
	} then obtain e'' where e'':
	"e'' d' \<in> {-1 .. 1}"
	"?small (?x d') = e'' d' * ?t (?x d')"
	if "d' \<in> {d ..< d + length X}" for d'
	apply atomize_elim
	unfolding all_conj_distrib[symmetric] imp_conjR[symmetric]
	unfolding Ball_def[symmetric] atLeastAtMost_iff[symmetric]
	apply (rule bchoice)
	apply (auto simp: Bex_def )
	done
	define e' where "e' \<equiv> \<lambda>i. if i < d then e i else if i < d + length X then e'' i else 0"
	have e': "e' d' \<in> {-1 .. 1}"
	"?small (?x d') = e' d' * ?t (?x d')"
	if "d' \<in> {d ..< d + length X}" for d'
	using e'' that
	by (auto simp: e'_def split: if_splits)
	then have *: "pdevs_val e (filter_pdevs (\<lambda>a b. \<not> I a (pdevs_applys X a)) (?x d')) =
	e' d' * ?t (?x d')" if "d' \<in> {d ..< d + length X}" for d'
	using that
	by auto
	have "map (\<lambda>(d', x). ?large x + ?small (?x d')) ?z =
	map (\<lambda>(d', x). ?large x + e' d' * ?t (?x d')) ?z"
	apply (auto simp: in_set_zip)
	subgoal for n
	using e'(2)[of "d + n"]
	by auto
	done
	also have "\<dots> = map (\<lambda>(d', x). pdevs_val e' (summarize_pdevs p ?J d' x)) (zip [d..<d + length X] X)"
	apply (auto simp: summarize_pdevs_def pdevs_val_msum_pdevs Let_def in_set_zip)
	apply (subst pdevs_val_msum_pdevs)
	using d
	apply (auto intro!: degree_filter_pdevs_le[THEN order_trans])
	subgoal by (auto dest!: degrees_leD nth_mem)
	apply (auto simp: pdevs_of_ivl_real intro!: )
	subgoal premises prems
	proof -
	have "degree (filter_pdevs (\<lambda>i x. I i (pdevs_applys X i)) (X ! n)) \<le> d" if "n < length X" for n
	using d that
	by (intro degree_filter_pdevs_le[THEN order_trans]) (simp add: degrees_leD)
	then show ?thesis
	using prems e''
	apply (intro pdevs_val_degree_cong)
	apply (auto dest!: )
	apply (auto simp: e'_def)
	apply (meson \<open>\<And>n. \<lbrakk>n < length X; degrees X \<le> d\<rbrakk> \<Longrightarrow> degree (X ! n) \<le> d + n\<close> degree_filter_pdevs_le less_le_trans)
	by (meson less_le_trans trans_less_add1)
	qed
	done
	also have "\<dots> = pdevs_vals e' (summarize_pdevs_list p I d X)"
	by (auto simp: summarize_pdevs_list_def pdevs_vals_def)
	finally have "pdevs_vals e X = pdevs_vals e' (summarize_pdevs_list p I d X)" .
	moreover have "(\<And>i. i < d \<Longrightarrow> e i = e' i)" "e' \<in> UNIV \<rightarrow> {- 1..1}"
	using \<open>e \<in> _\<close> e''
	by (auto simp: e'_def)
	ultimately show ?thesis ..
	qed

	fun list_ex2 where
	"list_ex2 P [] xs = False"
	\| "list_ex2 P xs [] = False"
	\| "list_ex2 P (x#xs) (y#ys) = (P x y \<or> list_ex2 P xs ys)"

	lemma list_ex2_iff:
	"list_ex2 P xs ys \<longleftrightarrow> (\<not>list_all2 (-P) (take (length ys) xs) (take (length xs) ys))"
	by (induction P xs ys rule: list_ex2.induct) auto

	definition "summarize_aforms p C d (X::real aform list) =
	(zip (map fst X) (summarize_pdevs_list p (C X) d (map snd X)))"

	lemma aform_vals_pdevs_vals:
	"aform_vals e X = map (\<lambda>(x, y). x + y) (zip (map fst X) (pdevs_vals e (map snd X)))"
	by (auto simp: pdevs_vals_def aform_vals_def aform_val_def[abs_def]
	map_zip_map map_zip_map2 split_beta' zip_same_conv_map)

	lemma summarize_aformsE:
	fixes X::"real aform list"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes d: "degree_aforms X \<le> d"
	obtains e' where "aform_vals e X = aform_vals e' (summarize_aforms p C d X)"
	"\<And>i. i < d \<Longrightarrow> e i = e' i"
	"e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	define Xs where "Xs = map snd X"
	have "aform_vals e X = map (\<lambda>(x, y). x + y) (zip (map fst X) (pdevs_vals e Xs))"
	by (auto simp: aform_vals_pdevs_vals Xs_def)
	also obtain e' where e': "e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	"\<And>i. i < d \<Longrightarrow> e i = e' i"
	"pdevs_vals e Xs = pdevs_vals e' (summarize_pdevs_list p (C X) d Xs)"
	using summarize_pdevs_listE[OF e d, of p "C X"]
	by (metis Xs_def)
	note this(3)
	also have "map (\<lambda>(x, y). x + y) (zip (map fst X) \<dots>) = aform_vals e' (summarize_aforms p C d X)"
	unfolding aform_vals_pdevs_vals
	by (simp add: summarize_aforms_def Let_def Xs_def summarize_pdevs_list_def
	split_beta')
	finally have "aform_vals e X = aform_vals e' (summarize_aforms p C d X)"
	"\<And>i. i < d \<Longrightarrow> e i = e' i"
	"e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	using e' d
	by (auto simp: Xs_def)
	then show ?thesis ..
	qed

	text \<open>Different reduction strategies:\<close>

	definition "collect_threshold p ta t (X::real aform list) =
	(let
	Xs = map snd X;
	as = map (\<lambda>X. max ta (t * tdev' p X)) Xs
	in (\<lambda>(i::nat) xs. list_ex2 (\<le>) as (map abs xs)))"

	definition "collect_girard p m (X::real aform list) =
	(let
	Xs = map snd X;
	M = pdevs_mapping Xs;
	D = domain_pdevs Xs;
	N = length X
	in if card D \<le> m then (\<lambda>_ _. True) else
	let
	Ds = sorted_list_of_set D;
	ortho_indices = map fst (take (2 * N) (sort_key (\<lambda>(i, r). r) (map (\<lambda>i. let xs = M i in (i, sum_list' p xs - fold max xs 0)) Ds)));
	_ = ()
	in (\<lambda>i (xs::real list). i \<in> set ortho_indices))"



	subsection \<open>Splitting with heuristics\<close>

	definition "abs_pdevs = unop_pdevs abs"

	definition "abssum_of_pdevs_list X = fold (\<lambda>a b. (add_pdevs (abs_pdevs a) b)) X zero_pdevs"

	definition "split_aforms xs i = (let splits = map (\<lambda>x. split_aform x i) xs in (map fst splits, map snd splits))"

	definition "split_aforms_largest_uncond X =
	(let (i, x) = max_pdev (abssum_of_pdevs_list (map snd X)) in split_aforms X i)"

	definition "Inf_aform_err p Rd = (float_of (truncate_down p (Inf_aform' p (fst Rd) - abs(snd Rd))))"
	definition "Sup_aform_err p Rd = (float_of (truncate_up p (Sup_aform' p (fst Rd) + abs(snd Rd))))"

	context includes interval.lifting begin
	lift_definition ivl_of_aform_err::"nat \<Rightarrow> aform_err \<Rightarrow> float interval"
	is "\<lambda>p Rd. (Inf_aform_err p Rd, Sup_aform_err p Rd)"
	by (auto simp: aform_err_def Inf_aform_err_def Sup_aform_err_def
	intro!: truncate_down_le truncate_up_le add_increasing[OF _ Inf_aform'_le_Sup_aform'])
	lemma lower_ivl_of_aform_err: "lower (ivl_of_aform_err p Rd) = Inf_aform_err p Rd"
	and upper_ivl_of_aform_err: "upper (ivl_of_aform_err p Rd) = Sup_aform_err p Rd"
	by (transfer, simp)+
	end

	definition approx_un::"nat
	\<Rightarrow> (float interval \<Rightarrow> float interval option)
	\<Rightarrow> ((real \<times> real pdevs) \<times> real) option
	\<Rightarrow> ((real \<times> real pdevs) \<times> real) option"
	where "approx_un p f a = do {
	rd \<leftarrow> a;
	ivl \<leftarrow> f (ivl_of_aform_err p rd);
	Some (ivl_err (real_interval ivl))
	}"

	definition interval_extension1::"(float interval \<Rightarrow> (float interval) option) \<Rightarrow> (real \<Rightarrow> real) \<Rightarrow> bool"
	where "interval_extension1 F f \<longleftrightarrow> (\<forall>ivl ivl'. F ivl = Some ivl' \<longrightarrow> (\<forall>x. x \<in>\<^sub>r ivl \<longrightarrow> f x \<in>\<^sub>r ivl'))"

	lemma interval_extension1D:
	assumes "interval_extension1 F f"
	assumes "F ivl = Some ivl'"
	assumes "x \<in>\<^sub>r ivl"
	shows "f x \<in>\<^sub>r ivl'"
	using assms by (auto simp: interval_extension1_def)

	lemma approx_un_argE:
	assumes au: "approx_un p F X = Some Y"
	obtains X' where "X = Some X'"
	using assms
	by (auto simp: approx_un_def bind_eq_Some_conv)

	lemma degree_aform_independent_from:
	"degree_aform (independent_from d1 X) \<le> d1 + degree_aform X"
	by (auto simp: independent_from_def degree_msum_pdevs_le)

	lemma degree_aform_of_ivl:
	fixes a b::"'a::executable_euclidean_space"
	shows "degree_aform (aform_of_ivl a b) \<le> length (Basis_list::'a list)"
	by (auto simp: aform_of_ivl_def degree_pdevs_of_ivl_le)

	lemma aform_err_ivl_err[simp]: "aform_err e (ivl_err ivl') = set_of ivl'"
	by (auto simp: aform_err_def ivl_err_def aform_val_def divide_simps set_of_eq)

	lemma Inf_Sup_aform_err:
	fixes X
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	defines "X' \<equiv> fst X"
	shows "aform_err e X \<subseteq> {Inf_aform_err p X .. Sup_aform_err p X}"
	using Inf_aform[OF e, of X'] Sup_aform[OF e, of X'] Inf_aform'[of p X'] Sup_aform'[of X' p]
	by (auto simp: aform_err_def X'_def Inf_aform_err_def Sup_aform_err_def
	intro!: truncate_down_le truncate_up_le)

	lemma ivl_of_aform_err:
	fixes X
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "x \<in> aform_err e X \<Longrightarrow> x \<in>\<^sub>r ivl_of_aform_err p X"
	using Inf_Sup_aform_err[OF e, of X p]
	by (auto simp: set_of_eq lower_ivl_of_aform_err upper_ivl_of_aform_err)

	lemma approx_unE:
	assumes ie: "interval_extension1 F f"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes au: "approx_un p F X'err = Some Ye"
	assumes x: "case X'err of None \<Rightarrow> True \| Some X'err \<Rightarrow> x \<in> aform_err e X'err"
	shows "f x \<in> aform_err e Ye"
	proof -
	from au obtain ivl' X' err
	where F: "F (ivl_of_aform_err p (X', err)) = Some (ivl')"
	and Y: "Ye = ivl_err (real_interval ivl')"
	and X'err: "X'err = Some (X', err)"
	by (auto simp: approx_un_def bind_eq_Some_conv)

	from x
	have "x \<in> aform_err e (X', err)" by (auto simp: X'err)
	from ivl_of_aform_err[OF e this]
	have "x \<in>\<^sub>r ivl_of_aform_err p (X', err)" .
	from interval_extension1D[OF ie F this]
	have "f x \<in>\<^sub>r ivl'" .
	also have "\<dots> = aform_err e Ye"
	unfolding Y aform_err_ivl_err ..
	finally show ?thesis .
	qed

	definition "approx_bin p f rd sd = do {
	ivl \<leftarrow> f (ivl_of_aform_err p rd)
	(ivl_of_aform_err p sd);
	Some (ivl_err (real_interval ivl))
	}"

	definition interval_extension2::"(float interval \<Rightarrow> float interval \<Rightarrow> float interval option) \<Rightarrow> (real \<Rightarrow> real \<Rightarrow> real) \<Rightarrow> bool"
	where "interval_extension2 F f \<longleftrightarrow> (\<forall>ivl1 ivl2 ivl. F ivl1 ivl2 = Some ivl \<longrightarrow>
	(\<forall>x y. x \<in>\<^sub>r ivl1 \<longrightarrow> y \<in>\<^sub>r ivl2 \<longrightarrow> f x y \<in>\<^sub>r ivl))"

	lemma interval_extension2D:
	assumes "interval_extension2 F f"
	assumes "F ivl1 ivl2 = Some ivl"
	shows "x \<in>\<^sub>r ivl1 \<Longrightarrow> y \<in>\<^sub>r ivl2 \<Longrightarrow> f x y \<in>\<^sub>r ivl"
	using assms by (auto simp: interval_extension2_def)

	lemma approx_binE:
	assumes ie: "interval_extension2 F f"
	assumes w: "w \<in> aform_err e (W', errw)"
	assumes x: "x \<in> aform_err e (X', errx)"
	assumes ab: "approx_bin p F ((W', errw)) ((X', errx)) = Some Ye"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "f w x \<in> aform_err e Ye"
	proof -
	from ab obtain ivl'
	where F: "F (ivl_of_aform_err p (W', errw)) (ivl_of_aform_err p (X', errx)) = Some ivl'"
	and Y: "Ye = ivl_err (real_interval ivl')"
	by (auto simp: approx_bin_def bind_eq_Some_conv max_def)
	from interval_extension2D[OF ie F
	ivl_of_aform_err[OF e, where p=p, OF w]
	ivl_of_aform_err[OF e, where p=p, OF x]]
	have "f w x \<in>\<^sub>r ivl'" .
	also have "\<dots> = aform_err e Ye" unfolding Y aform_err_ivl_err ..
	finally show ?thesis .
	qed

	definition "min_aform_err p a1 (a2::aform_err) =
	(let
	ivl1 = ivl_of_aform_err p a1;
	ivl2 = ivl_of_aform_err p a2
	in if upper ivl1 < lower ivl2 then a1
	else if upper ivl2 < lower ivl1 then a2
	else ivl_err (real_interval (min_interval ivl1 ivl2)))"

	definition "max_aform_err p a1 (a2::aform_err) =
	(let
	ivl1 = ivl_of_aform_err p a1;
	ivl2 = ivl_of_aform_err p a2
	in if upper ivl1 < lower ivl2 then a2
	else if upper ivl2 < lower ivl1 then a1
	else ivl_err (real_interval (max_interval ivl1 ivl2)))"


	subsection \<open>Approximate Min Range - Kind Of Trigonometric Functions\<close>

	definition affine_unop :: "nat \<Rightarrow> real \<Rightarrow> real \<Rightarrow> real \<Rightarrow> aform_err \<Rightarrow> aform_err" where
	"affine_unop p a b d X = (let
	((x, xs), xe) = X;
	(ax, axe) = trunc_bound_eucl p (a * x);
	(y, ye) = trunc_bound_eucl p (ax + b);
	(ys, yse) = trunc_bound_pdevs p (scaleR_pdevs a xs)
	in ((y, ys), sum_list' p [truncate_up p (\<bar>a\<bar> * xe), axe, ye, yse, d]))"
	\<comment> \<open>TODO: also do binop\<close>

	lemma aform_err_leI:
	"y \<in> aform_err e (c, d)"
	if "y \<in> aform_err e (c, d')" "d' \<le> d"
	using that by (auto simp: aform_err_def)

	lemma aform_err_eqI:
	"y \<in> aform_err e (c, d)"
	if "y \<in> aform_err e (c, d')" "d' = d"
	using that by (auto simp: aform_err_def)

	lemma sum_list'_append[simp]: "sum_list' p (ds@[d]) = truncate_up p (d + sum_list' p ds)"
	unfolding sum_list'_def
	by (simp add: eucl_truncate_up_real_def)

	lemma aform_err_sum_list':
	"y \<in> aform_err e (c, sum_list' p ds)"
	if "y \<in> aform_err e (c, sum_list ds)"
	using that(1)
	apply (rule aform_err_leI)
	by (rule sum_list_le_sum_list')

	lemma aform_err_trunc_bound_eucl:
	"y \<in> aform_err e ((fst (trunc_bound_eucl p X), xs), snd (trunc_bound_eucl p X) + d)"
	if y: "y \<in> aform_err e ((X, xs), d)"
	using that
	proof -
	from aform_errE[OF y]
	have "\<bar>y - aform_val e (X, xs)\<bar> \<le> d" by auto
	then show ?thesis
	apply (intro aform_errI)
	apply (rule trunc_bound_euclE[of p X])
	by (auto simp: aform_val_def)
	qed

	lemma trunc_err_pdevsE:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	obtains err where
	"\<bar>err\<bar> \<le> tdev' p (trunc_err_pdevs p xs)"
	"pdevs_val e (trunc_pdevs p xs) = pdevs_val e xs + err"
	using trunc_bound_pdevsE[of e p xs]
	by (auto simp: trunc_bound_pdevs_def assms)

	lemma aform_err_trunc_bound_pdevsI:
	"y \<in> aform_err e ((c, fst (trunc_bound_pdevs p xs)), snd (trunc_bound_pdevs p xs) + d)"
	if y: "y \<in> aform_err e ((c, xs), d)"
	and e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	using that
	proof -
	define exs where "exs = trunc_err_pdevs p xs"
	from aform_errE[OF y]
	have "\<bar>y - aform_val e (c, xs)\<bar> \<le> d" by auto
	then show ?thesis
	apply (intro aform_errI)
	apply (rule trunc_err_pdevsE[OF e, of p xs])
	by (auto simp: aform_val_def trunc_bound_pdevs_def)
	qed

	lemma aform_err_addI:
	"y \<in> aform_err e ((a + b, xs), d)"
	if "y - b \<in> aform_err e ((a, xs), d)"
	using that
	by (auto simp: aform_err_def aform_val_def)

	theorem affine_unop:
	assumes x: "x \<in> aform_err e X"
	assumes f: "\<bar>f x - (a * x + b)\<bar> \<le> d"
	and e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "f x \<in> aform_err e (affine_unop p a b d X)"
	proof -
	show ?thesis
	unfolding affine_unop_def Let_def
	apply (auto simp: split_beta')
	apply (rule aform_err_sum_list')
	apply simp
	apply (rule aform_err_eqI)
	apply (rule aform_err_trunc_bound_eucl)
	apply (rule aform_err_addI)
	apply (rule aform_err_trunc_bound_eucl)
	apply (rule aform_err_trunc_bound_pdevsI)
	using e
	apply auto
	apply (rule aform_errI)
	apply (auto simp: aform_val_def)
	proof -
	define x' where "x' = (fst (fst X) + pdevs_val e (snd (fst X)))"
	have x_x': "\<bar>x - x'\<bar> \<le> snd X"
	using aform_errE[OF x]
	by (auto simp: x'_def aform_val_def)
	have "\<bar>f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))\<bar> =
	\<bar>f x - (a * x + b) + a * (x - x')\<bar>"
	by (simp add: algebra_simps x'_def)
	also have "\<dots> \<le> \<bar>f x - (a * x + b)\<bar> + \<bar>a * (x - x')\<bar>"
	by (rule abs_triangle_ineq)
	also note f
	also have "\<bar>a * (x - x')\<bar> \<le> truncate_up p (\<bar>a\<bar> * snd X)"
	by (rule truncate_up_le)
	(auto simp: abs_mult intro!: mult_left_mono x_x')
	finally show "\<bar>f x - b - (a * fst (fst X) + a * pdevs_val e (snd (fst X)))\<bar> \<le>
	truncate_up p (\<bar>a\<bar> * snd X) + d"
	by auto
	qed
	qed

	lemma min_range_coeffs_ge:
	"\<bar>f x - (a * x + b)\<bar> \<le> d"
	if l: "l \<le> x" and u: "x \<le> u"
	and f': "\<And>y. y \<in> {l .. u} \<Longrightarrow> (f has_real_derivative f' y) (at y)"
	and a: "\<And>y. y \<in> {l..u} \<Longrightarrow> a \<le> f' y"
	and d: "d \<ge> (f u - f l - a * (u - l)) / 2 + \<bar>(f l + f u - a * (l + u)) / 2 - b\<bar>"
	for a b d::real
	proof (rule order_trans[OF _ d])
	note f'_at = has_field_derivative_at_within[OF f']
	from l u have lu: "x \<in> {l .. u}" and llu: "l \<in> {l .. u}" by simp_all

	define m where "m = (f l + f u - a * (l + u)) / 2"
	have "\<bar>f x - (a * x + b)\<bar> = \<bar>f x - (a * x + m) + (m - b)\<bar>" by (simp add: algebra_simps)
	also have "\<dots> \<le> \<bar>f x - (a * x + m)\<bar> + \<bar>m - b\<bar>" by (rule abs_triangle_ineq)
	also have "\<bar>f x - (a * x + m)\<bar> \<le> (f u - f l - a * (u - l)) / 2"
	proof (rule abs_leI)
	have "f x \<ge> f l + a * (x - l)" (is "?l \<ge> ?r")
	apply (rule order_trans) prefer 2
	apply (rule linear_lower2[OF f'_at, of l u a])
	subgoal by assumption
	subgoal by (rule a)
	subgoal
	using lu
	by (auto intro!: mult_right_mono)
	subgoal using lu by auto
	done
	also have "a * x + m - (f u - f l - a * (u - l)) / 2 \<le> ?r"
	by (simp add: algebra_simps m_def field_simps)
	finally (xtrans) show "- (f x - (a * x + m)) \<le> (f u - f l - a * (u - l)) / 2"
	by (simp add: algebra_simps m_def divide_simps)
	next
	have "f x \<le> f u + a * (x - u)"
	apply (rule order_trans)
	apply (rule linear_upper2[OF f'_at, of l u a])
	subgoal by assumption
	subgoal by (rule a)
	subgoal
	using lu
	by (auto intro!: mult_right_mono)
	subgoal using lu by auto
	done
	also have "\<dots> \<le> a * x + m + (f u - f l - a * (u - l)) / 2"
	by (simp add: m_def divide_simps algebra_simps)
	finally show "f x - (a * x + m) \<le> (f u - f l - a * (u - l)) / 2"
	by (simp add: algebra_simps m_def divide_simps)
	qed
	also have "\<bar>m - b\<bar> = abs ((f l + f u - a * (l + u)) / 2 - b)"
	unfolding m_def ..
	finally show "\<bar>f x - (a * x + b)\<bar> \<le> (f u - f l - a * (u - l)) / 2 + \<bar>(f l + f u - a * (l + u)) / 2 - b\<bar>"
	by (simp)
	qed

	lemma min_range_coeffs_le:
	"\<bar>f x - (a * x + b)\<bar> \<le> d"
	if l: "l \<le> x" and u: "x \<le> u"
	and f': "\<And>y. y \<in> {l .. u} \<Longrightarrow> (f has_real_derivative f' y) (at y)"
	and a: "\<And>y. y \<in> {l .. u} \<Longrightarrow> f' y \<le> a"
	and d: "d \<ge> (f l - f u + a * (u - l)) / 2 + \<bar>(f l + f u - a * (l + u)) / 2 - b\<bar>"
	for a b d::real
	proof (rule order_trans[OF _ d])
	note f'_at = has_field_derivative_at_within[OF f']
	from l u have lu: "x \<in> {l .. u}" and llu: "l \<in> {l .. u}" by simp_all

	define m where "m = (f l + f u - a * (l + u)) / 2"
	have "\<bar>f x - (a * x + b)\<bar> = \<bar>f x - (a * x + m) + (m - b)\<bar>" by (simp add: algebra_simps)
	also have "\<dots> \<le> \<bar>f x - (a * x + m)\<bar> + \<bar>m - b\<bar>" by (rule abs_triangle_ineq)
	also have "\<bar>f x - (a * x + m)\<bar> \<le> (f l - f u + a * (u - l)) / 2"
	proof (rule abs_leI)
	have "f x \<ge> f u + a * (x - u)" (is "?l \<ge> ?r")
	apply (rule order_trans) prefer 2
	apply (rule linear_lower[OF f'_at, of l u a])
	subgoal by assumption
	subgoal by (rule a)
	subgoal
	using lu
	by (auto intro!: mult_right_mono)
	subgoal using lu by auto
	done
	also have "a * x + m - (f l - f u + a * (u - l)) / 2 \<le> ?r"
	using lu
	by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg)
	finally (xtrans) show "- (f x - (a * x + m)) \<le> (f l - f u + a * (u - l)) / 2"
	by (simp add: algebra_simps m_def divide_simps)
	next
	have "f x \<le> f l + a * (x - l)"
	apply (rule order_trans)
	apply (rule linear_upper[OF f'_at, of l u a])
	subgoal by assumption
	subgoal by (rule a)
	subgoal
	using lu
	by (auto intro!: mult_right_mono)
	subgoal using lu by auto
	done
	also have "\<dots> \<le> a * x + m + (f l - f u + a * (u - l)) / 2"
	using lu
	by (auto simp add: algebra_simps m_def field_simps intro!: mult_left_mono_neg)
	finally show "f x - (a * x + m) \<le> (f l - f u + a * (u - l)) / 2"
	by (simp add: algebra_simps m_def divide_simps)
	qed
	also have "\<bar>m - b\<bar> = abs ((f l + f u - a * (l + u)) / 2 - b)"
	unfolding m_def ..
	finally show "\<bar>f x - (a * x + b)\<bar> \<le> (f l - f u + a * (u - l)) / 2 + \<bar>(f l + f u - a * (l + u)) / 2 - b\<bar>"
	by (simp)
	qed

	context includes floatarith_notation begin

	definition "range_reducer p l =
	(if l < 0 \<or> l > 2 * lb_pi p
	then approx p (Pi * (Num (-2)) * (Floor (Num (l * Float 1 (-1)) / Pi))) []
	else Some 0)"

	lemmas approx_emptyD = approx[OF bounded_by_None[of Nil], simplified]

	lemma range_reducerE:
	assumes "range_reducer p l = Some ivl"
	obtains n::int where "n * (2 * pi) \<in>\<^sub>r ivl"
	proof (cases "l \<ge> 0 \<and> l \<le> 2 * lb_pi p")
	case False
	with assms have "- \<lfloor>l / (2 * pi)\<rfloor> * (2 * pi) \<in>\<^sub>r ivl"
	by (auto simp: range_reducer_def bind_eq_Some_conv inverse_eq_divide
	algebra_simps dest!: approx_emptyD)
	then show ?thesis ..
	next
	case True then have "real_of_int 0 * (2 * pi) \<in>\<^sub>r ivl" using assms
	by (auto simp: range_reducer_def zero_in_float_intervalI)
	then show ?thesis ..
	qed

	definition "range_reduce_aform_err p X = do {
	r \<leftarrow> range_reducer p (lower (ivl_of_aform_err p X));
	Some (add_aform' p X (ivl_err (real_interval r)))
	}"

	lemma range_reduce_aform_errE:
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes x: "x \<in> aform_err e X"
	assumes "range_reduce_aform_err p X = Some Y"
	obtains n::int where "x + n * (2 * pi) \<in> aform_err e Y"
	proof -
	from assms obtain r
	where x: "x \<in> aform_err e X"
	and r: "range_reducer p (lower (ivl_of_aform_err p X)) = Some r"
	and Y: "Y = add_aform' p X (ivl_err (real_interval r))"
	by (auto simp: range_reduce_aform_err_def bind_eq_Some_conv mid_err_def split: prod.splits)
	from range_reducerE[OF r]
	obtain n::int where "n * (2 * pi) \<in>\<^sub>r r"
	by auto
	then have "n * (2 * pi) \<in> aform_err e (ivl_err (real_interval r))"
	by (auto simp: aform_val_def ac_simps divide_simps abs_real_def set_of_eq intro!: aform_errI)
	from add_aform'[OF e x this, of p]
	have "x + n * (2 * pi) \<in> aform_err e Y"
	by (auto simp: Y)
	then show ?thesis ..
	qed

	definition "min_range_mono p F DF l u X = do {
	let L = Num l;
	let U = Num u;
	aivl \<leftarrow> approx p (Min (DF L) (DF U)) [];
	let a = lower aivl;
	let A = Num a;
	bivl \<leftarrow> approx p (Half (F L + F U - A * (L + U))) [];
	let (b, be) = mid_err bivl;
	let (B, Be) = (Num (float_of b), Num (float_of be));
	divl \<leftarrow> approx p ((Half (F U - F L - A * (U - L))) + Be) [];
	Some (affine_unop p a b (real_of_float (upper divl)) X)
	}"

	lemma min_range_mono:
	assumes x: "x \<in> aform_err e X"
	assumes "l \<le> x" "x \<le> u"
	assumes "min_range_mono p F DF l u X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes F: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> interpret_floatarith (F (Num x)) [] = f x"
	assumes DF: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> interpret_floatarith (DF (Num x)) [] = f' x"
	assumes f': "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> (f has_real_derivative f' x) (at x)"
	assumes f'_le: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> min (f' l) (f' u) \<le> f' x"
	shows "f x \<in> aform_err e Y"
	proof -
	from assms obtain a b be bivl divl
	where bivl: "(f l + f u - a * (l + u))/2 \<in>\<^sub>r bivl"
	and Y: "Y = affine_unop p a b (upper divl) X"
	and du: "(f u - f l - a * (u - l)) / 2 + be \<in>\<^sub>r divl"
	and a: "a \<le> f' l" "a \<le> f' u"
	and b_def: "b = (lower bivl + upper bivl) / 2"
	and be_def: "be = (upper bivl - lower bivl) / 2"
	by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq
	simp del: eq_divide_eq_numeral1
	split: prod.splits if_splits dest!: approx_emptyD)
	have diff_le: "real_of_float a \<le> f' y" if "real_of_float l \<le> y" "y \<le> u" for y
	using f'_le[of y] that a
	by auto
	have le_be: "\<bar>(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b\<bar> \<le> be"
	using bivl
	unfolding b_def be_def
	by (auto simp: abs_real_def divide_simps set_of_eq)
	have "\<bar>f x - (a * x + b)\<bar> \<le> upper divl"
	apply (rule min_range_coeffs_ge)
	apply (rule \<open>l \<le> x\<close>)
	apply (rule \<open>x \<le> u\<close>)
	apply (rule f') apply assumption
	using diff_le apply force
	apply (rule order_trans[OF add_mono[OF order_refl]])
	apply (rule le_be)
	using bivl du
	unfolding b_def[symmetric] be_def[symmetric]
	by (auto simp: set_of_eq)
	from affine_unop[where f=f and p = p, OF \<open>x \<in> _\<close> this e]
	have "f x \<in> aform_err e (affine_unop p (real_of_float a) b (upper divl) X)"
	by (auto simp: Y)
	then show ?thesis
	by (simp add: Y b_def)
	qed

	definition "min_range_antimono p F DF l u X = do {
	let L = Num l;
	let U = Num u;
	aivl \<leftarrow> approx p (Max (DF L) (DF U)) [];
	let a = upper aivl;
	let A = Num a;
	bivl \<leftarrow> approx p (Half (F L + F U - A * (L + U))) [];
	let (b, be) = mid_err bivl;
	let (B, Be) = (Num (float_of b), Num (float_of be));
	divl \<leftarrow> approx p (Add (Half (F L - F U + A * (U - L))) Be) [];
	Some (affine_unop p a b (real_of_float (upper divl)) X)
	}"

	lemma min_range_antimono:
	assumes x: "x \<in> aform_err e X"
	assumes "l \<le> x" "x \<le> u"
	assumes "min_range_antimono p F DF l u X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes F: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> interpret_floatarith (F (Num x)) [] = f x"
	assumes DF: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> interpret_floatarith (DF (Num x)) [] = f' x"
	assumes f': "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> (f has_real_derivative f' x) (at x)"
	assumes f'_le: "\<And>x. x \<in> {real_of_float l .. u} \<Longrightarrow> f' x \<le> max (f' l) (f' u)"
	shows "f x \<in> aform_err e Y"
	proof -
	from assms obtain a b be aivl bivl divl
	where bivl: "(f l + f u - real_of_float a * (l + u)) / 2 \<in>\<^sub>r bivl"
	and Y: "Y = affine_unop p a b (real_of_float (upper divl)) X"
	and du: "(f l - f u + a * (u - l)) / 2 + be \<in>\<^sub>r divl"
	and a: "f' l \<le> a" "f' u \<le> a"
	and a_def: "a = upper aivl"
	and b_def: "b = (lower bivl + upper bivl) / 2"
	and be_def: "be = (upper bivl - lower bivl) / 2"
	by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def set_of_eq
	simp del: eq_divide_eq_numeral1
	split: prod.splits if_splits dest!: approx_emptyD)
	have diff_le: "f' y \<le> real_of_float a" if "real_of_float l \<le> y" "y \<le> u" for y
	using f'_le[of y] that a
	by auto
	have le_be: "\<bar>(f (l) + f (u) - a * (real_of_float l + u)) / 2 - b\<bar> \<le> be"
	using bivl
	unfolding b_def be_def
	by (auto simp: abs_real_def divide_simps set_of_eq)
	have "\<bar>f x - (a * x + b)\<bar> \<le> upper divl"
	apply (rule min_range_coeffs_le)
	apply (rule \<open>l \<le> x\<close>)
	apply (rule \<open>x \<le> u\<close>)
	apply (rule f') apply assumption
	using diff_le apply force
	apply (rule order_trans[OF add_mono[OF order_refl]])
	apply (rule le_be)
	using du bivl
	unfolding b_def[symmetric] be_def[symmetric]
	by (auto simp: set_of_eq)
	from affine_unop[where f=f and p = p, OF \<open>x \<in> _\<close> this e]
	have "f x \<in> aform_err e (affine_unop p (real_of_float a) b (upper divl) X)"
	by (auto simp: Y)
	then show ?thesis
	by (simp add: Y b_def)
	qed

	definition "cos_aform_err p X = do {
	X \<leftarrow> range_reduce_aform_err p X;
	let ivl = ivl_of_aform_err p X;
	let l = lower ivl;
	let u = upper ivl;
	let L = Num l;
	let U = Num u;
	if l \<ge> 0 \<and> u \<le> lb_pi p then
	min_range_antimono p Cos (\<lambda>x. (Minus (Sin x))) l u X
	else if l \<ge> ub_pi p \<and> u \<le> 2 * lb_pi p then
	min_range_mono p Cos (\<lambda>x. (Minus (Sin x))) l u X
	else do {
	Some (ivl_err (real_interval (cos_float_interval p ivl)))
	}
	}"

	lemma abs_half_enclosure:
	fixes r::real
	assumes "bl \<le> r" "r \<le> bu"
	shows "\<bar>r - (bl + bu) / 2\<bar> \<le> (bu - bl) / 2"
	using assms
	by (auto simp: abs_real_def divide_simps)

	lemma cos_aform_err:
	assumes x: "x \<in> aform_err e X0"
	assumes "cos_aform_err p X0 = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "cos x \<in> aform_err e Y"
	proof -
	from assms obtain X ivl l u where
	X: "range_reduce_aform_err p X0 = Some X"
	and ivl_def: "ivl = ivl_of_aform_err p X"
	and l_def: "l = lower ivl"
	and u_def: "u = upper ivl"
	by (auto simp: cos_aform_err_def bind_eq_Some_conv)
	from range_reduce_aform_errE[OF e x X]
	obtain n where xn: "x + real_of_int n * (2 * pi) \<in> aform_err e X"
	by auto
	define xn where "xn = x + n * (2 * pi)"
	with xn have xn: "xn \<in> aform_err e X" by auto
	from ivl_of_aform_err[OF e xn, of p, folded ivl_def]
	have "xn \<in>\<^sub>r ivl" .
	then have lxn: "l \<le> xn" and uxn: "xn \<le> u"
	by (auto simp: l_def u_def set_of_eq)
	consider "l \<ge> 0" "u \<le> lb_pi p"
	\| "l < 0 \<or> u > lb_pi p" "l \<ge> ub_pi p" "u \<le> 2 * lb_pi p"
	\| "l < 0 \<or> u > lb_pi p" "l < ub_pi p \<or> u > 2 * lb_pi p"
	by arith
	then show ?thesis
	proof cases
	case 1
	then have min_eq_Some: "min_range_antimono p Cos (\<lambda>x. Minus (Sin x)) l u X = Some Y"
	and bounds: "0 \<le> l" "u \<le> (lb_pi p)"
	using assms(2)
	unfolding cos_aform_err_def X l_def u_def
	by (auto simp: X Let_def simp flip: l_def u_def ivl_def split: prod.splits)
	have bounds: "0 \<le> l" "u \<le> pi" using bounds pi_boundaries[of p] by auto
	have diff_le: "- sin y \<le> max (- sin (real_of_float l)) (- sin (real_of_float u))"
	if "real_of_float l \<le> y" "y \<le> real_of_float u" for y
	proof -
	consider "y \<le> pi / 2" \| "y \<ge> pi / 2" by arith
	then show ?thesis
	proof cases
	case 1
	then have "- sin y \<le> - sin l"
	using that bounds
	by (auto intro!: sin_monotone_2pi_le)
	then show ?thesis by auto
	next
	case 2
	then have "- sin y \<le> - sin u"
	using that bounds
	unfolding sin_minus_pi[symmetric]
	apply (intro sin_monotone_2pi_le)
	by (auto intro!: )
	then show ?thesis by auto
	qed
	qed
	have "cos xn \<in> aform_err e Y"
	apply (rule min_range_antimono[OF xn lxn uxn min_eq_Some e, where f'="\<lambda>x. - sin x"])
	subgoal by simp
	subgoal by simp
	subgoal by (auto intro!: derivative_eq_intros)
	subgoal by (rule diff_le) auto
	done
	then show ?thesis
	unfolding xn_def
	- by (simp add: )
	+ by simp
	next
	case 2
	then have min_eq_Some: "min_range_mono p Cos (\<lambda>x. Minus (Sin x)) l u X = Some Y"
	and bounds: "ub_pi p \<le> l" "u \<le> 2 * lb_pi p"
	using assms(2)
	unfolding cos_aform_err_def X
	by (auto simp: X Let_def simp flip: l_def u_def ivl_def split: prod.splits)
	have bounds: "pi \<le> l" "u \<le> 2 * pi" using bounds pi_boundaries[of p] by auto
	have diff_le: "min (- sin (real_of_float l)) (- sin (real_of_float u)) \<le> - sin y"
	if "real_of_float l \<le> y" "y \<le> real_of_float u" for y
	proof -
	consider "y \<le> 3 * pi / 2" \| "y \<ge> 3 * pi / 2" by arith
	then show ?thesis
	proof cases
	case 1
	then have "- sin l \<le> - sin y"
	unfolding sin_minus_pi[symmetric]
	apply (intro sin_monotone_2pi_le)
	using that bounds
	by (auto)
	then show ?thesis by auto
	next
	case 2
	then have "- sin u \<le> - sin y"
	unfolding sin_2pi_minus[symmetric]
	using that bounds
	apply (intro sin_monotone_2pi_le)
	by (auto intro!: )
	then show ?thesis by auto
	qed
	qed
	have "cos xn \<in> aform_err e Y"
	apply (rule min_range_mono[OF xn lxn uxn min_eq_Some e, where f'="\<lambda>x. - sin x"])
	subgoal by simp
	subgoal by simp
	subgoal by (auto intro!: derivative_eq_intros)
	subgoal by (rule diff_le) auto
	done
	then show ?thesis
	unfolding xn_def
	- by (simp add: )
	+ by simp
	next
	case 3
	then obtain ivl' where
	"cos_float_interval p ivl = ivl'"
	"Y = ivl_err (real_interval ivl')"
	using assms(2)
	unfolding cos_aform_err_def X l_def u_def
	by (auto simp: X simp flip: l_def u_def ivl_def split: prod.splits)
	with cos_float_intervalI[OF \<open>xn \<in>\<^sub>r ivl\<close>, of p]
	show ?thesis
	by (auto simp: xn_def)
	qed
	qed

	definition "sqrt_aform_err p X = do {
	let ivl = ivl_of_aform_err p X;
	let l = lower ivl;
	let u = upper ivl;
	if 0 < l then min_range_mono p Sqrt (\<lambda>x. Half (Inverse (Sqrt x))) l u X
	else Some (ivl_err (real_interval (sqrt_float_interval p ivl)))
	}"

	lemma sqrt_aform_err:
	assumes x: "x \<in> aform_err e X"
	assumes "sqrt_aform_err p X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "sqrt x \<in> aform_err e Y"
	proof -
	obtain l u ivl
	where ivl_def: "ivl = ivl_of_aform_err p X"
	and l_def: "l = lower ivl"
	and u_def: "u = upper ivl"
	by auto
	from ivl_of_aform_err[OF e x, of p, folded ivl_def]
	have ivl: "x \<in>\<^sub>r ivl" .
	then have lx: "l \<le> x" and ux: "x \<le> u"
	by (auto simp flip: ivl_def simp: l_def u_def set_of_eq)
	consider "l > 0" \| "l \<le> 0"
	by arith
	then show ?thesis
	proof cases
	case 1
	then have min_eq_Some: "min_range_mono p Sqrt (\<lambda>x. Half (Inverse (Sqrt x))) l u X = Some Y"
	and bounds: "0 < l"
	using assms(2)
	unfolding sqrt_aform_err_def
	by (auto simp: Let_def simp flip: l_def u_def ivl_def split: prod.splits)
	have "sqrt x \<in> aform_err e Y"
	apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="\<lambda>x. 1 / (2 * sqrt x)"])
	subgoal by simp
	subgoal by (simp add: divide_simps)
	subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
	subgoal using \<open>l > 0\<close> by (auto simp: inverse_eq_divide min_def divide_simps)
	done
	then show ?thesis
	- by (simp add: )
	+ by simp
	next
	case 2
	then have "Y = ivl_err (real_interval (sqrt_float_interval p ivl))"
	using assms(2)
	unfolding sqrt_aform_err_def
	by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits)
	with sqrt_float_intervalI[OF ivl]
	show ?thesis
	by (auto simp: set_of_eq)
	qed
	qed

	definition "ln_aform_err p X = do {
	let ivl = ivl_of_aform_err p X;
	let l = lower ivl;
	if 0 < l then min_range_mono p Ln inverse l (upper ivl) X
	else None
	}"

	lemma ln_aform_err:
	assumes x: "x \<in> aform_err e X"
	assumes "ln_aform_err p X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "ln x \<in> aform_err e Y"
	proof -
	obtain ivl l u
	where l_def: "l = lower ivl"
	and u_def: "u = upper ivl"
	and ivl_def: "ivl = ivl_of_aform_err p X"
	by auto
	from ivl_of_aform_err[OF e x, of p, folded ivl_def]
	have "x \<in>\<^sub>r ivl" .
	then have lx: "l \<le> x" and ux: "x \<le> u"
	by (auto simp: set_of_eq l_def u_def)
	consider "l > 0" \| "l \<le> 0"
	by arith
	then show ?thesis
	proof cases
	case 1
	then have min_eq_Some: "min_range_mono p Ln inverse l u X = Some Y"
	and bounds: "0 < l"
	using assms(2)
	unfolding ln_aform_err_def
	by (auto simp: Let_def simp flip: ivl_def l_def u_def split: prod.splits if_splits)
	have "ln x \<in> aform_err e Y"
	apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=inverse])
	subgoal by simp
	subgoal by (simp add: divide_simps)
	subgoal using bounds by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
	subgoal using \<open>l > 0\<close> by (auto simp: inverse_eq_divide min_def divide_simps)
	done
	then show ?thesis
	- by (simp add: )
	+ by simp
	next
	case 2
	then show ?thesis using assms
	by (auto simp: ln_aform_err_def Let_def l_def ivl_def)
	qed
	qed

	definition "exp_aform_err p X = do {
	let ivl = ivl_of_aform_err p X;
	min_range_mono p Exp Exp (lower ivl) (upper ivl) X
	}"

	lemma exp_aform_err:
	assumes x: "x \<in> aform_err e X"
	assumes "exp_aform_err p X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "exp x \<in> aform_err e Y"
	proof -
	obtain l u ivl
	where l_def: "l = lower ivl"
	and u_def: "u = upper ivl"
	and ivl_def: "ivl = ivl_of_aform_err p X"
	by auto
	from ivl_of_aform_err[OF e x, of p, folded ivl_def]
	have "x \<in>\<^sub>r ivl" .
	then have lx: "l \<le> x" and ux: "x \<le> u"
	by (auto simp: ivl_def l_def u_def set_of_eq)
	have min_eq_Some: "min_range_mono p Exp Exp l u X = Some Y"
	using assms(2)
	unfolding exp_aform_err_def
	by (auto simp: Let_def simp flip: ivl_def u_def l_def split: prod.splits if_splits)
	have "exp x \<in> aform_err e Y"
	apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'=exp])
	subgoal by simp
	subgoal by (simp add: divide_simps)
	subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
	subgoal by (auto simp: inverse_eq_divide min_def divide_simps)
	done
	then show ?thesis
	- by (simp add: )
	+ by simp
	qed

	definition "arctan_aform_err p X = do {
	let l = Inf_aform_err p X;
	let u = Sup_aform_err p X;
	min_range_mono p Arctan (\<lambda>x. 1 / (Num 1 + x * x)) l u X
	}"

	lemma pos_add_nonneg_ne_zero: "a > 0 \<Longrightarrow> b \<ge> 0 \<Longrightarrow> a + b \<noteq> 0"
	for a b::real
	by arith

	lemma arctan_aform_err:
	assumes x: "x \<in> aform_err e X"
	assumes "arctan_aform_err p X = Some Y"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "arctan x \<in> aform_err e Y"
	proof -
	obtain l u where l: "l = Inf_aform_err p X"
	and u: "u = Sup_aform_err p X"
	by auto
	from x l u have lx: "l \<le> x" and ux: "x \<le> u"
	using Inf_Sup_aform_err[OF e, of X p]
	by auto
	have min_eq_Some: "min_range_mono p Arctan (\<lambda>x. 1 / (Num 1 + x * x)) l u X = Some Y"
	using assms(2)
	unfolding arctan_aform_err_def l u
	by (auto simp: l[symmetric] u[symmetric] split: prod.splits if_splits)
	have "arctan x \<in> aform_err e Y"
	apply (rule min_range_mono[OF x lx ux min_eq_Some e, where f'="\<lambda>x. inverse (1 + x\<^sup>2)"])
	subgoal by simp
	subgoal by (simp add: power2_eq_square inverse_eq_divide)
	subgoal by (auto intro!: derivative_eq_intros simp: inverse_eq_divide)
	subgoal for x
	apply (cases "x \<le> 0")
	subgoal
	apply (rule min.coboundedI1)
	apply (rule deriv_nonneg_imp_mono[of "real_of_float l" x])
	by (auto intro!: derivative_eq_intros simp: mult_le_0_iff pos_add_nonneg_ne_zero)
	subgoal
	apply (rule min.coboundedI2)
	apply (rule le_imp_inverse_le)
	by (auto intro!: power_mono add_pos_nonneg)
	done
	done
	then show ?thesis
	- by (simp add: )
	+ by simp
	qed

	subsection \<open>Power, TODO: compare with Min-range approximation?!\<close>

	definition "power_aform_err p (X::aform_err) n =
	(if n = 0 then ((1, zero_pdevs), 0)
	else if n = 1 then X
	else
	let x0 = float_of (fst (fst X));
	xs = snd (fst X);
	xe = float_of (snd X);
	C = the (approx p (Num x0 ^\<^sub>e n) []);
	(c, ce) = mid_err C;
	NX = the (approx p (Num (of_nat n) * (Num x0 ^\<^sub>e (n - 1))) []);
	(nx, nxe) = mid_err NX;
	Y = scaleR_pdevs nx xs;
	(Y', Y_err) = trunc_bound_pdevs p Y;
	t = tdev' p xs;
	Ye = truncate_up p (nxe * t);
	err = the (approx p
	(Num (of_nat n) * Num xe * Abs (Num x0) ^\<^sub>e (n - 1) +
	(Sum\<^sub>e (\<lambda>k. Num (of_nat (n choose k)) * Abs (Num x0) ^\<^sub>e (n - k) * (Num xe + Num (float_of t)) ^\<^sub>e k)
	[2..<Suc n])) []);
	ERR = upper err
	in ((c, Y'), sum_list' p [ce, Y_err, Ye, real_of_float ERR]))"

	lemma bounded_by_Nil: "bounded_by [] []"
	by (auto simp: bounded_by_def)

	lemma plain_floatarith_approx:
	assumes "plain_floatarith 0 f"
	shows "interpret_floatarith f [] \<in>\<^sub>r (the (approx p f []))"
	proof -
	from plain_floatarith_approx_not_None[OF assms(1), of Nil p]
	obtain ivl where "approx p f [] = Some ivl"
	by auto
	from this approx[OF bounded_by_Nil this]
	show ?thesis
	by auto
	qed

	lemma plain_floatarith_Sum\<^sub>e:
	"plain_floatarith n (Sum\<^sub>e f xs) \<longleftrightarrow> list_all (\<lambda>i. plain_floatarith n (f i)) xs"
	by (induction xs) (auto simp: zero_floatarith_def plus_floatarith_def)

	lemma sum_list'_float[simp]: "sum_list' p xs \<in> float"
	by (induction xs rule: rev_induct) (auto simp: sum_list'_def eucl_truncate_up_real_def)

	lemma tdev'_float[simp]: "tdev' p xs \<in> float"
	by (auto simp: tdev'_def)

	lemma
	fixes x y::real
	assumes "abs (x - y) \<le> e"
	obtains err where "x = y + err" "abs err \<le> e"
	using assms
	apply atomize_elim
	apply (rule exI[where x="x - y"])
	by (auto simp: abs_real_def)

	theorem power_aform_err:
	assumes "x \<in> aform_err e X"
	assumes floats[simp]: "fst (fst X) \<in> float" "snd X \<in> float"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "x ^ n \<in> aform_err e (power_aform_err p X n)"
	proof -
	consider "n = 0" \| "n = 1" \| "n \<ge> 2"
	by arith
	then show ?thesis
	proof cases
	case 1
	then show ?thesis by (auto simp: aform_err_def power_aform_err_def aform_val_def)
	next
	case 2
	then show ?thesis
	using assms
	by (auto simp: aform_err_def power_aform_err_def aform_val_def)
	next
	case n: 3
	define x0 where "x0 = (fst (fst X))"
	define xs where "xs = snd (fst X)"
	define xe where "xe = (snd X)"
	have [simp]: "x0 \<in> float" "xe \<in> float" using assms by (auto simp: x0_def xe_def)

	define xe' where "xe' = x - aform_val e (x0, xs)"
	from aform_errE[OF assms(1)]
	have xe': "\<bar>xe'\<bar> \<le> xe"
	by (auto simp: x0_def xs_def xe_def xe'_def)
	then have xe_nonneg: "0 \<le> xe"
	- by (auto simp: )
	+ by auto

	define t where "t = tdev' p xs"
	have t: "tdev xs \<le> t" "t \<in> float" by (auto simp add: t_def tdev'_le)
	then have t_nonneg: "0 \<le> t" using tdev_nonneg[of xs] by arith
	note t_pdevs = abs_pdevs_val_le_tdev[OF e, THEN order_trans, OF t(1)]

	have rewr1: "{..n} = (insert 0 (insert 1 {2..n}))" using n by auto
	have "x = (pdevs_val e xs + xe') + x0"
	by (simp add: xe'_def aform_val_def)
	also have "\<dots> ^ n = x0 ^ n + n * x0 ^ (n - Suc 0) * pdevs_val e xs +
	(n * xe' * x0 ^ (n - Suc 0) +
	(\<Sum>k = 2..n. real (n choose k) * (pdevs_val e xs + xe') ^ k * x0 ^ (n - k)))"
	(is "_ = _ + ?err")
	apply (subst binomial_ring)
	unfolding rewr1
	using n
	apply (simp add: algebra_simps)
	done
	also

	let ?ERR = "(Num (of_nat n) * Num (float_of xe) * Abs (Num (float_of x0)) ^\<^sub>e (n - 1) +
	(Sum\<^sub>e (\<lambda>k. Num (of_nat (n choose k)) * Abs (Num (float_of x0)) ^\<^sub>e (n - k) *
	(Num (float_of xe) + Num (float_of t)) ^\<^sub>e k)
	[2..<Suc n]))"
	define err where "err = the (approx p ?ERR [])"
	define ERR where "ERR = upper err"
	have ERR: "abs ?err \<le> ERR"
	proof -
	have err_aerr: "abs (?err) \<le> n * xe * abs x0 ^ (n - Suc 0) +
	(\<Sum>k = 2..n. real (n choose k) * (t + xe) ^ k * abs x0 ^ (n - k))"
	(is "_ \<le> ?aerr")
	by (auto simp: abs_mult power_abs intro!: sum_mono mult_mono power_mono xe'
	mult_nonneg_nonneg zero_le_power t_nonneg xe_nonneg add_nonneg_nonneg
	sum_abs[THEN order_trans] abs_triangle_ineq[THEN order_trans] add_mono t_pdevs)
	also
	have rewr: "{2 .. n} = {2 ..<Suc n}"
	using n
	- by (auto simp: )
	+ by auto
	have "plain_floatarith 0 ?ERR"
	by (auto simp add: zero_floatarith_def plain_floatarith_Sum\<^sub>e times_floatarith_def
	plus_floatarith_def intro!: list_allI)
	from plain_floatarith_approx[OF this, of p]
	have "ERR \<ge> ?aerr"
	using n
	by (auto simp: set_of_eq err_def ERR_def sum_list_distinct_conv_sum_set rewr t x0_def
	algebra_simps)
	finally show ?thesis .
	qed

	let ?x0n = "Num (float_of x0) ^\<^sub>e n"
	define C where "C = the (approx p ?x0n [])"
	have "plain_floatarith 0 ?x0n" by simp
	from plain_floatarith_approx[OF this, of p]
	have C: "x0 ^ n \<in> {lower C .. upper C}"
	by (auto simp: C_def x0_def set_of_eq)

	define c where "c = fst (mid_err C)"
	define ce where "ce = snd (mid_err C)"
	define ce' where "ce' = x0 ^ n - c"
	have ce': "abs (ce') \<le> ce"
	using C
	by (auto simp: ce'_def c_def ce_def abs_diff_le_iff mid_err_def divide_simps)
	have "x0 ^ n = c + ce'" by (simp add: ce'_def)
	also

	let ?NX = "(Num (of_nat n) * (Num (float_of x0) ^\<^sub>e (n - 1)))"
	define NX where "NX = the (approx p ?NX [])"
	have "plain_floatarith 0 ?NX" by (simp add: times_floatarith_def)
	from plain_floatarith_approx[OF this, of p]
	have NX: "n * x0 ^ (n - 1) \<in> {lower NX .. upper NX}"
	by (auto simp: NX_def x0_def set_of_eq)

	define nx where "nx = fst (mid_err NX)"
	define nxe where "nxe = snd (mid_err NX)"
	define nx' where "nx' = n * x0 ^ (n - 1) - nx"
	define Ye where "Ye = truncate_up p (nxe * t)"
	have Ye: "Ye \<ge> nxe * t" by (auto simp: Ye_def truncate_up_le)
	have nx: "abs (nx') \<le> nxe" "0 \<le> nxe"
	using NX
	by (auto simp: nx_def nxe_def abs_diff_le_iff mid_err_def divide_simps nx'_def)
	have Ye: "abs (nx' * pdevs_val e xs) \<le> Ye"
	by (auto simp: Ye_def abs_mult intro!: truncate_up_le mult_mono nx t_pdevs)
	have "n * x0 ^ (n - Suc 0) = nx + nx'" by (simp add: nx'_def)
	also

	define Y where "Y = scaleR_pdevs nx xs"
	have Y: "pdevs_val e Y = nx * pdevs_val e xs"
	by (simp add: Y_def)
	have "(nx + nx') * pdevs_val e xs = pdevs_val e Y + nx' * pdevs_val e xs"
	unfolding Y by (simp add: algebra_simps)
	also

	define Y' where "Y' = fst (trunc_bound_pdevs p Y)"
	define Y_err where "Y_err = snd (trunc_bound_pdevs p Y)"
	have Y_err: "abs (- pdevs_val e (trunc_err_pdevs p Y)) \<le> Y_err"
	by (auto simp: Y_err_def trunc_bound_pdevs_def abs_pdevs_val_le_tdev' e)
	have "pdevs_val e Y = pdevs_val e Y' + - pdevs_val e (trunc_err_pdevs p Y)"
	by (simp add: Y'_def trunc_bound_pdevs_def pdevs_val_trunc_err_pdevs)
	finally
	have "\<bar>x ^ n - aform_val e (c, Y') \<bar> =
	\<bar>ce' + - pdevs_val e (trunc_err_pdevs p Y) + nx' * pdevs_val e xs + ?err\<bar>"
	by (simp add: algebra_simps aform_val_def)
	also have "\<dots> \<le> ce + Y_err + Ye + ERR"
	by (intro ERR abs_triangle_ineq[THEN order_trans] add_mono ce' Ye Y_err)
	also have "\<dots> \<le> sum_list' p [ce, Y_err, Ye, real_of_float ERR]"
	by (auto intro!: sum_list'_sum_list_le)
	finally show ?thesis
	using n
	by (intro aform_errI)
	(auto simp: power_aform_err_def c_def Y'_def C_def Y_def ERR_def x0_def nx_def xs_def NX_def
	ce_def Y_err_def Ye_def xe_def nxe_def t_def Let_def split_beta' set_of_eq err_def)
	qed
	qed

	definition [code_abbrev]: "is_float r \<longleftrightarrow> r \<in> float"
	lemma [code]: "is_float (real_of_float f) = True"
	by (auto simp: is_float_def)

	definition "powr_aform_err p X A = (
	if Inf_aform_err p X > 0 then do {
	L \<leftarrow> ln_aform_err p X;
	exp_aform_err p (mult_aform' p A L)
	}
	else approx_bin p (powr_float_interval p) X A)"

	lemma interval_extension_powr: "interval_extension2 (powr_float_interval p) (powr)"
	using powr_float_interval_eqI[of p]
	by (auto simp: interval_extension2_def)

	theorem powr_aform_err:
	assumes x: "x \<in> aform_err e X"
	assumes a: "a \<in> aform_err e A"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes Y: "powr_aform_err p X A = Some Y"
	shows "x powr a \<in> aform_err e Y"
	proof cases
	assume pos: "Inf_aform_err p X > 0"
	with Inf_Sup_aform_err[OF e, of X p] x
	have "x > 0" by auto
	then have "x powr a = exp (a * ln x)"
	by (simp add: powr_def)
	also
	from pos obtain L where L: "ln_aform_err p X = Some L"
	and E: "exp_aform_err p (mult_aform' p A L) = Some Y"
	using Y
	by (auto simp: bind_eq_Some_conv powr_aform_err_def)
	from ln_aform_err[OF x L e] have "ln x \<in> aform_err e L" .
	from mult_aform'E[OF e a this] have "a * ln x \<in> aform_err e (mult_aform' p A L)" .
	from exp_aform_err[OF this E e]
	have "exp (a * ln x) \<in> aform_err e Y" .
	finally show ?thesis .
	next
	from x a have xa: "x \<in> aform_err e (fst X, snd X)" "a \<in> aform_err e (fst A, snd A)" by simp_all
	assume "\<not> Inf_aform_err p X > 0"
	then have "approx_bin p (powr_float_interval p) (fst X, snd X) (fst A, snd A) = Some Y"
	using Y by (auto simp: powr_aform_err_def)
	from approx_binE[OF interval_extension_powr xa this e]
	show "x powr a \<in> aform_err e Y" .
	qed

	fun
	approx_floatarith :: "nat \<Rightarrow> floatarith \<Rightarrow> aform_err list \<Rightarrow> (aform_err) option"
	where
	"approx_floatarith p (Add a b) vs =
	do {
	a1 \<leftarrow> approx_floatarith p a vs;
	a2 \<leftarrow> approx_floatarith p b vs;
	Some (add_aform' p a1 a2)
	}"
	\| "approx_floatarith p (Mult a b) vs =
	do {
	a1 \<leftarrow> approx_floatarith p a vs;
	a2 \<leftarrow> approx_floatarith p b vs;
	Some (mult_aform' p a1 a2)
	}"
	\| "approx_floatarith p (Inverse a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	inverse_aform_err p a
	}"
	\| "approx_floatarith p (Minus a) vs =
	map_option (apfst uminus_aform) (approx_floatarith p a vs)"
	\| "approx_floatarith p (Num f) vs =
	Some (num_aform (real_of_float f), 0)"
	\| "approx_floatarith p (Var i) vs =
	(if i < length vs then Some (vs ! i) else None)"
	\| "approx_floatarith p (Abs a) vs =
	do {
	r \<leftarrow> approx_floatarith p a vs;
	let ivl = ivl_of_aform_err p r;
	let i = lower ivl;
	let s = upper ivl;
	if i > 0 then Some r
	else if s < 0 then Some (apfst uminus_aform r)
	else do {
	Some (ivl_err (real_interval (abs_interval ivl)))
	}
	}"
	\| "approx_floatarith p (Min a b) vs =
	do {
	a1 \<leftarrow> approx_floatarith p a vs;
	a2 \<leftarrow> approx_floatarith p b vs;
	Some (min_aform_err p a1 a2)
	}"
	\| "approx_floatarith p (Max a b) vs =
	do {
	a1 \<leftarrow> approx_floatarith p a vs;
	a2 \<leftarrow> approx_floatarith p b vs;
	Some (max_aform_err p a1 a2)
	}"
	\| "approx_floatarith p (Floor a) vs =
	approx_un p (\<lambda>ivl. Some (floor_float_interval ivl)) (approx_floatarith p a vs)"
	\| "approx_floatarith p (Cos a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	cos_aform_err p a
	}"
	\| "approx_floatarith p Pi vs = Some (ivl_err (real_interval (pi_float_interval p)))"
	\| "approx_floatarith p (Sqrt a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	sqrt_aform_err p a
	}"
	\| "approx_floatarith p (Ln a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	ln_aform_err p a
	}"
	\| "approx_floatarith p (Arctan a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	arctan_aform_err p a
	}"
	\| "approx_floatarith p (Exp a) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	exp_aform_err p a
	}"
	\| "approx_floatarith p (Power a n) vs =
	do {
	((a, as), e) \<leftarrow> approx_floatarith p a vs;
	if is_float a \<and> is_float e then Some (power_aform_err p ((a, as), e) n)
	else None
	}"
	\| "approx_floatarith p (Powr a b) vs =
	do {
	ae1 \<leftarrow> approx_floatarith p a vs;
	ae2 \<leftarrow> approx_floatarith p b vs;
	powr_aform_err p ae1 ae2
	}"

	lemma uminus_aform_uminus_aform[simp]: "uminus_aform (uminus_aform z) = (z::'a::real_vector aform)"
	by (auto intro!: prod_eqI pdevs_eqI simp: uminus_aform_def)

	lemma degree_aform_inverse_aform':
	"degree_aform X \<le> n \<Longrightarrow> degree_aform (fst (inverse_aform' p X)) \<le> n"
	unfolding inverse_aform'_def
	by (auto simp: Let_def trunc_bound_pdevs_def intro!: degree_pdev_upd_le degree_trunc_pdevs_le)

	lemma degree_aform_inverse_aform:
	assumes "inverse_aform p X = Some Y"
	assumes "degree_aform X \<le> n"
	shows "degree_aform (fst Y) \<le> n"
	using assms
	by (auto simp: inverse_aform_def Let_def degree_aform_inverse_aform' split: if_splits)

	lemma degree_aform_ivl_err[simp]: "degree_aform (fst (ivl_err a)) = 0"
	by (auto simp: ivl_err_def)

	lemma degree_aform_approx_bin:
	assumes "approx_bin p ivl X Y = Some Z"
	assumes "degree_aform (fst X) \<le> m"
	assumes "degree_aform (fst Y) \<le> m"
	shows "degree_aform (fst Z) \<le> m"
	using assms
	by (auto simp: approx_bin_def bind_eq_Some_conv Basis_list_real_def
	intro!: order_trans[OF degree_aform_independent_from]
	order_trans[OF degree_aform_of_ivl])

	lemma degree_aform_approx_un:
	assumes "approx_un p ivl X = Some Y"
	assumes "case X of None \<Rightarrow> True \| Some X \<Rightarrow> degree_aform (fst X) \<le> d1"
	shows "degree_aform (fst Y) \<le> d1"
	using assms
	by (auto simp: approx_un_def bind_eq_Some_conv Basis_list_real_def
	intro!: order_trans[OF degree_aform_independent_from]
	order_trans[OF degree_aform_of_ivl])

	lemma degree_aform_num_aform[simp]: "degree_aform (num_aform x) = 0"
	by (auto simp: num_aform_def)

	lemma degree_max_aform:
	assumes "degree_aform_err x \<le> d"
	assumes "degree_aform_err y \<le> d"
	shows "degree_aform_err (max_aform_err p x y) \<le> d"
	using assms
	by (auto simp: max_aform_err_def Let_def Basis_list_real_def split: prod.splits
	intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl])

	lemma degree_min_aform:
	assumes "degree_aform_err x \<le> d"
	assumes "degree_aform_err y \<le> d"
	shows "degree_aform_err ((min_aform_err p x y)) \<le> d"
	using assms
	by (auto simp: min_aform_err_def Let_def Basis_list_real_def split: prod.splits
	intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl])

	lemma degree_aform_acc_err:
	"degree_aform (fst (acc_err p X e)) \<le> d"
	if "degree_aform (fst X) \<le> d"
	using that by (auto simp: acc_err_def)

	lemma degree_pdev_upd_degree:
	assumes "degree b \<le> Suc n"
	assumes "degree b \<le> Suc (degree_aform_err X)"
	assumes "degree_aform_err X \<le> n"
	shows "degree (pdev_upd b (degree_aform_err X) 0) \<le> n"
	using assms
	by (auto intro!: degree_le)

	lemma degree_aform_err_inverse_aform_err:
	assumes "inverse_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: inverse_aform_err_def bind_eq_Some_conv aform_to_aform_err_def
	acc_err_def map_aform_err_def
	aform_err_to_aform_def
	intro!: degree_aform_acc_err)
	apply (rule degree_pdev_upd_degree)
	apply (auto dest!: degree_aform_inverse_aform)
	apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans)
	apply (meson degree_pdev_upd_le nat_le_linear not_less_eq_eq order_trans)
	done

	lemma degree_aform_err_affine_unop:
	"degree_aform_err (affine_unop p a b d X) \<le> n"
	if "degree_aform_err X \<le> n"
	using that
	by (auto simp: affine_unop_def trunc_bound_pdevs_def degree_trunc_pdevs_le split: prod.splits)


	lemma degree_aform_err_min_range_mono:
	assumes "min_range_mono p F D l u X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	by (auto simp: min_range_mono_def bind_eq_Some_conv aform_to_aform_err_def
	acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
	aform_err_to_aform_def Let_def split: if_splits prod.splits
	intro!: degree_aform_err_affine_unop)

	lemma degree_aform_err_min_range_antimono:
	assumes "min_range_antimono p F D l u X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	by (auto simp: min_range_antimono_def bind_eq_Some_conv aform_to_aform_err_def
	acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
	aform_err_to_aform_def Let_def split: if_splits prod.splits
	intro!: degree_aform_err_affine_unop)

	lemma degree_aform_err_cos_aform_err:
	assumes "cos_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: cos_aform_err_def bind_eq_Some_conv aform_to_aform_err_def
	acc_err_def map_aform_err_def mid_err_def range_reduce_aform_err_def
	aform_err_to_aform_def Let_def split: if_splits prod.splits
	intro!: degree_aform_err_affine_unop)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_antimono degree_aform_ivl_err zero_le)
	done

	lemma degree_aform_err_sqrt_aform_err:
	assumes "sqrt_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: sqrt_aform_err_def Let_def split: if_splits)
	apply (metis degree_aform_err_min_range_mono)
	done

	lemma degree_aform_err_arctan_aform_err:
	assumes "arctan_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: arctan_aform_err_def bind_eq_Some_conv)
	apply (metis degree_aform_err_min_range_mono)
	done

	lemma degree_aform_err_exp_aform_err:
	assumes "exp_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: exp_aform_err_def bind_eq_Some_conv)
	apply (metis degree_aform_err_min_range_mono)
	done

	lemma degree_aform_err_ln_aform_err:
	assumes "ln_aform_err p X = Some Y"
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: ln_aform_err_def Let_def split: if_splits)
	apply (metis degree_aform_err_add_aform' degree_aform_err_min_range_mono degree_aform_ivl_err zero_le)
	done

	lemma degree_aform_err_power_aform_err:
	assumes "degree_aform_err X \<le> n"
	shows "degree_aform_err (power_aform_err p X m) \<le> n"
	using assms
	by (auto simp: power_aform_err_def Let_def trunc_bound_pdevs_def degree_trunc_pdevs_le
	split: if_splits prod.splits)

	lemma degree_aform_err_powr_aform_err:
	assumes "powr_aform_err p X Z = Some Y"
	assumes "degree_aform_err X \<le> n"
	assumes "degree_aform_err Z \<le> n"
	shows "degree_aform_err Y \<le> n"
	using assms
	apply (auto simp: powr_aform_err_def bind_eq_Some_conv degree_aform_mult_aform'
	dest!: degree_aform_err_ln_aform_err degree_aform_err_exp_aform_err
	split: if_splits)
	apply (metis degree_aform_mult_aform' fst_conv order_trans snd_conv)
	apply (rule degree_aform_approx_bin, assumption)
	apply auto
	done

	lemma approx_floatarith_degree:
	assumes "approx_floatarith p ra VS = Some X"
	assumes "\<And>V. V \<in> set VS \<Longrightarrow> degree_aform_err V \<le> d"
	shows "degree_aform_err X \<le> d"
	using assms
	proof (induction ra arbitrary: X)
	case (Add ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: degree_aform_err_add_aform' degree_aform_acc_err)
	next
	case (Minus ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv)
	next
	case (Mult ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: degree_aform_mult_aform' degree_aform_acc_err)
	next
	case (Inverse ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_inverse_aform_err)
	next
	case (Cos ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_cos_aform_err)
	next
	case (Arctan ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_arctan_aform_err)
	next
	case (Abs ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def
	intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]
	degree_aform_acc_err
	split: if_splits)
	next
	case (Max ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: degree_max_aform degree_aform_acc_err)
	next
	case (Min ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: degree_min_aform degree_aform_acc_err)
	next
	case Pi
	then show ?case
	by (auto simp: bind_eq_Some_conv Let_def Basis_list_real_def
	intro!: order_trans[OF degree_aform_independent_from] order_trans[OF degree_aform_of_ivl]
	degree_aform_acc_err
	split: if_splits)
	next
	case (Sqrt ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_sqrt_aform_err)
	next
	case (Exp ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_exp_aform_err)
	next
	case (Powr ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_powr_aform_err)
	next
	case (Ln ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro: degree_aform_err_ln_aform_err)
	next
	case (Power ra x2a)
	then show ?case
	by (auto intro!: degree_aform_err_power_aform_err simp: bind_eq_Some_conv split: if_splits)
	next
	case (Floor ra)
	then show ?case
	apply -
	by (rule degree_aform_approx_un) (auto split: option.splits)
	next
	case (Var x)
	then show ?case
	by (auto simp: max_def split: if_splits)
	(use Var.prems(2) nat_le_linear nth_mem order_trans in blast)+
	next
	case (Num x)
	then show ?case by auto
	qed

	definition affine_extension2 where
	"affine_extension2 fnctn_aff fnctn \<longleftrightarrow> (
	\<forall>d a1 a2 X e2.
	fnctn_aff d a1 a2 = Some X \<longrightarrow>
	e2 \<in> UNIV \<rightarrow> {- 1..1} \<longrightarrow>
	d \<ge> degree_aform a1 \<longrightarrow>
	d \<ge> degree_aform a2 \<longrightarrow>
	(\<exists>e3 \<in> UNIV \<rightarrow> {- 1..1}.
	(fnctn (aform_val e2 a1) (aform_val e2 a2) = aform_val e3 X \<and>
	(\<forall>n. n < d \<longrightarrow> e3 n = e2 n) \<and>
	aform_val e2 a1 = aform_val e3 a1 \<and> aform_val e2 a2 = aform_val e3 a2)))"

	lemma affine_extension2E:
	assumes "affine_extension2 fnctn_aff fnctn"
	assumes "fnctn_aff d a1 a2 = Some X"
	"e \<in> UNIV \<rightarrow> {- 1..1}"
	"d \<ge> degree_aform a1"
	"d \<ge> degree_aform a2"
	obtains e' where "e' \<in> UNIV \<rightarrow> {- 1..1}"
	"fnctn (aform_val e a1) (aform_val e a2) = aform_val e' X"
	"\<And>n. n < d \<Longrightarrow> e' n = e n"
	"aform_val e a1 = aform_val e' a1"
	"aform_val e a2 = aform_val e' a2"
	using assms
	unfolding affine_extension2_def
	by metis

	lemma aform_err_uminus_aform:
	"- x \<in> aform_err e (uminus_aform X, ba)"
	if "e \<in> UNIV \<rightarrow> {-1 .. 1}" "x \<in> aform_err e (X, ba)"
	using that by (auto simp: aform_err_def)

	definition "aforms_err e (xs::aform_err list) = listset (map (aform_err e) xs)"

	lemma aforms_err_Nil[simp]: "aforms_err e [] = {[]}"
	and aforms_err_Cons: "aforms_err e (x#xs) = set_Cons (aform_err e x) (aforms_err e xs)"
	by (auto simp: aforms_err_def)

	lemma in_set_ConsI: "a#b \<in> set_Cons A B"
	if "a \<in> A" and "b \<in> B"
	using that
	by (auto simp: set_Cons_def)

	lemma mem_aforms_err_Cons_iff[simp]: "x#xs \<in> aforms_err e (X#XS) \<longleftrightarrow> x \<in> aform_err e X \<and> xs \<in> aforms_err e XS"
	by (auto simp: aforms_err_Cons set_Cons_def)

	lemma mem_aforms_err_Cons_iff_Ex_conv: "x \<in> aforms_err e (X#XS) \<longleftrightarrow> (\<exists>y ys. x = y#ys \<and> y \<in> aform_err e X \<and> ys \<in> aforms_err e XS)"
	by (auto simp: aforms_err_Cons set_Cons_def)

	lemma listset_Cons_mem_conv:
	"a # vs \<in> listset AVS \<longleftrightarrow> (\<exists>A VS. AVS = A # VS \<and> a \<in> A \<and> vs \<in> listset VS)"
	by (induction AVS) (auto simp: set_Cons_def)

	lemma listset_Nil_mem_conv[simp]:
	"[] \<in> listset AVS \<longleftrightarrow> AVS = []"
	by (induction AVS) (auto simp: set_Cons_def)

	lemma listset_nthD: "vs \<in> listset VS \<Longrightarrow> i < length vs \<Longrightarrow> vs ! i \<in> VS ! i"
	by (induction vs arbitrary: VS i)
	(auto simp: nth_Cons listset_Cons_mem_conv split: nat.splits)

	lemma length_listsetD:
	"vs \<in> listset VS \<Longrightarrow> length vs = length VS"
	by (induction vs arbitrary: VS) (auto simp: listset_Cons_mem_conv)

	lemma length_aforms_errD:
	"vs \<in> aforms_err e VS \<Longrightarrow> length vs = length VS"
	by (auto simp: aforms_err_def length_listsetD)

	lemma nth_aforms_errI:
	"vs ! i \<in> aform_err e (VS ! i)"
	if "vs \<in> aforms_err e VS" "i < length vs"
	using that
	unfolding aforms_err_def
	apply -
	apply (frule listset_nthD, assumption)
	by (auto simp: aforms_err_def length_listsetD )

	lemma eucl_truncate_down_float[simp]: "eucl_truncate_down p x \<in> float"
	by (auto simp: eucl_truncate_down_def)

	lemma eucl_truncate_up_float[simp]: "eucl_truncate_up p x \<in> float"
	by (auto simp: eucl_truncate_up_def)

	lemma trunc_bound_eucl_float[simp]: "fst (trunc_bound_eucl p x) \<in> float"
	"snd (trunc_bound_eucl p x) \<in> float"
	by (auto simp: trunc_bound_eucl_def Let_def)

	lemma add_aform'_float:
	"add_aform' p x y = ((a, b), ba) \<Longrightarrow> a \<in> float"
	"add_aform' p x y = ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: add_aform'_def Let_def)

	lemma uminus_aform_float: "uminus_aform (aa, bb) = (a, b) \<Longrightarrow> aa \<in> float \<Longrightarrow> a \<in> float"
	by (auto simp: uminus_aform_def)

	lemma mult_aform'_float: "mult_aform' p x y = ((a, b), ba) \<Longrightarrow> a \<in> float"
	"mult_aform' p x y = ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: mult_aform'_def Let_def split_beta')

	lemma inverse_aform'_float: "inverse_aform' p x = ((a, bb), baa) \<Longrightarrow> a \<in> float"
	using [[linarith_split_limit=256]]
	by (auto simp: inverse_aform'_def Let_def)

	lemma inverse_aform_float:
	"inverse_aform p x = Some ((a, bb), baa) \<Longrightarrow> a \<in> float"
	by (auto simp: inverse_aform_def Let_def apfst_def map_prod_def uminus_aform_def
	inverse_aform'_float
	split: if_splits prod.splits)

	lemma inverse_aform_err_float: "inverse_aform_err p x = Some ((a, b), ba) \<Longrightarrow> a \<in> float"
	"inverse_aform_err p x = Some ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: inverse_aform_err_def map_aform_err_def acc_err_def bind_eq_Some_conv
	aform_err_to_aform_def aform_to_aform_err_def inverse_aform_float)

	lemma affine_unop_float:
	"affine_unop p asdf aaa bba h = ((a, b), ba) \<Longrightarrow> a \<in> float"
	"affine_unop p asdf aaa bba h = ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: affine_unop_def trunc_bound_eucl_def Let_def split: prod.splits)

	lemma min_range_antimono_float:
	"min_range_antimono p f f' i g h = Some ((a, b), ba) \<Longrightarrow> a \<in> float"
	"min_range_antimono p f f' i g h = Some ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: min_range_antimono_def Let_def bind_eq_Some_conv mid_err_def
	affine_unop_float split: prod.splits)

	lemma min_range_mono_float:
	"min_range_mono p f f' i g h = Some ((a, b), ba) \<Longrightarrow> a \<in> float"
	"min_range_mono p f f' i g h = Some ((a, b), ba) \<Longrightarrow> ba \<in> float"
	by (auto simp: min_range_mono_def Let_def bind_eq_Some_conv mid_err_def
	affine_unop_float split: prod.splits)

	lemma in_float_timesI: "a \<in> float" if "b = a * 2" "b \<in> float"
	proof -
	from that have "a = b / 2" by simp
	also have "\<dots> \<in> float" using that(2) by auto
	finally show ?thesis .
	qed

	lemma interval_extension_floor: "interval_extension1 (\<lambda>ivl. Some (floor_float_interval ivl)) floor"
	by (auto simp: interval_extension1_def floor_float_intervalI)

	lemma approx_floatarith_Elem:
	assumes "approx_floatarith p ra VS = Some X"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "vs \<in> aforms_err e VS"
	shows "interpret_floatarith ra vs \<in> aform_err e X"
	using assms(1)
	proof (induction ra arbitrary: X)
	case (Add ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: add_aform'[OF e])
	next
	case (Minus ra)
	then show ?case
	by (auto intro!: aform_err_uminus_aform[OF e])
	next
	case (Mult ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: mult_aform'E[OF e])
	next
	case (Inverse ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: inverse_aform_err[OF e])
	next
	case (Cos ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: cos_aform_err[OF _ _ e])
	next
	case (Arctan ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: arctan_aform_err[OF _ _ e])
	next
	case (Abs fa)
	from Abs.prems
	obtain a where a: "approx_floatarith p fa VS = Some a"
	by (auto simp add: Let_def bind_eq_Some_conv)
	from Abs.IH[OF a]
	have mem: "interpret_floatarith fa vs \<in> aform_err e a"
	by auto
	then have mem': "-interpret_floatarith fa vs \<in> aform_err e (apfst uminus_aform a)"
	by (auto simp: aform_err_def)

	let ?i = "lower (ivl_of_aform_err p a)"
	let ?s = "upper (ivl_of_aform_err p a)"
	consider "?i > 0" \| "?i \<le> 0" "?s < 0" \| "?i \<le> 0" "?s \<ge> 0"
	by arith
	then show ?case
	proof cases
	case hyps: 1
	then show ?thesis
	using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
	by (auto simp: a set_of_eq)
	next
	case hyps: 2
	then show ?thesis
	using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
	ivl_of_aform_err[OF e mem', of p]
	by (cases a) (auto simp: a abs_real_def set_of_eq intro!: aform_err_uminus_aform[OF e])
	next
	case hyps: 3
	then show ?thesis
	using Abs.prems mem ivl_of_aform_err[OF e mem, of p]
	by (auto simp: a abs_real_def max_def Let_def set_of_eq)
	qed
	next
	case (Max ra1 ra2)
	from Max.prems
	obtain a b where a: "approx_floatarith p ra1 VS = Some a"
	and b: "approx_floatarith p ra2 VS = Some b"
	by (auto simp add: Let_def bind_eq_Some_conv)
	from Max.IH(1)[OF a] Max.IH(2)[OF b]
	have mem: "interpret_floatarith ra1 vs \<in> aform_err e a"
	"interpret_floatarith ra2 vs \<in> aform_err e b"
	by auto
	let ?ia = "lower (ivl_of_aform_err p a)"
	let ?sa = "upper (ivl_of_aform_err p a)"
	let ?ib = "lower (ivl_of_aform_err p b)"
	let ?sb = "upper (ivl_of_aform_err p b)"
	consider "?sa < ?ib" \| "?sa \<ge> ?ib" "?sb < ?ia" \| "?sa \<ge> ?ib" "?sb \<ge> ?ia"
	by arith
	then show ?case
	using Max.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p]
	by cases (auto simp: a b max_def max_aform_err_def set_of_eq)
	next
	case (Min ra1 ra2)
	from Min.prems
	obtain a b where a: "approx_floatarith p ra1 VS = Some a"
	and b: "approx_floatarith p ra2 VS = Some b"
	by (auto simp add: Let_def bind_eq_Some_conv)
	from Min.IH(1)[OF a] Min.IH(2)[OF b]
	have mem: "interpret_floatarith ra1 vs \<in> aform_err e a"
	"interpret_floatarith ra2 vs \<in> aform_err e b"
	by auto
	let ?ia = "lower (ivl_of_aform_err p a)"
	let ?sa = "upper (ivl_of_aform_err p a)"
	let ?ib = "lower (ivl_of_aform_err p b)"
	let ?sb = "upper (ivl_of_aform_err p b)"
	consider "?sa < ?ib" \| "?sa \<ge> ?ib" "?sb < ?ia" \| "?sa \<ge> ?ib" "?sb \<ge> ?ia"
	by arith
	then show ?case
	using Min.prems mem ivl_of_aform_err[OF e mem(1), of p] ivl_of_aform_err[OF e mem(2), of p]
	by cases (auto simp: a b min_def min_aform_err_def set_of_eq)
	next
	case Pi
	then show ?case using pi_float_interval
	- by (auto simp: )
	+ by auto
	next
	case (Sqrt ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: sqrt_aform_err[OF _ _ e])
	next
	case (Exp ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: exp_aform_err[OF _ _ e])
	next
	case (Powr ra1 ra2)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: powr_aform_err[OF _ _ e])
	next
	case (Ln ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: ln_aform_err[OF _ _ e])
	next
	case (Power ra x2a)
	then show ?case
	by (auto simp: bind_eq_Some_conv is_float_def
	intro!: power_aform_err[OF _ _ _ e] split: if_splits)
	next
	case (Floor ra)
	then show ?case
	by (auto simp: bind_eq_Some_conv intro!: approx_unE[OF interval_extension_floor e]
	split: option.splits)
	next
	case (Var x)
	then show ?case
	using assms(3)
	apply -
	apply (frule length_aforms_errD)
	by (auto split: if_splits simp: aform_err_def dest!: nth_aforms_errI[where i=x])
	next
	case (Num x)
	then show ?case
	by (auto split: if_splits simp: aform_err_def num_aform_def aform_val_def)
	qed

	primrec approx_floatariths_aformerr ::
	"nat \<Rightarrow> floatarith list \<Rightarrow> aform_err list \<Rightarrow> aform_err list option"
	where
	"approx_floatariths_aformerr _ [] _ = Some []"
	\| "approx_floatariths_aformerr p (a#bs) vs =
	do {
	a \<leftarrow> approx_floatarith p a vs;
	r \<leftarrow> approx_floatariths_aformerr p bs vs;
	Some (a#r)
	}"


	lemma approx_floatariths_Elem:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "approx_floatariths_aformerr p ra VS = Some X"
	assumes "vs \<in> aforms_err e VS"
	shows "interpret_floatariths ra vs \<in> aforms_err e X"
	using assms(2)
	proof (induction ra arbitrary: X)
	case Nil then show ?case by simp
	next
	case (Cons ra ras)
	from Cons.prems
	obtain a r where a: "approx_floatarith p ra VS = Some a"
	and r: "approx_floatariths_aformerr p ras VS = Some r"
	and X: "X = a # r"
	by (auto simp: bind_eq_Some_conv)
	then show ?case
	using assms(1)
	by (auto simp: X Cons.IH intro!: approx_floatarith_Elem assms)
	qed

	lemma fold_max_mono:
	fixes x::"'a::linorder"
	shows "x \<le> y \<Longrightarrow> fold max zs x \<le> fold max zs y"
	by (induct zs arbitrary: x y) (auto intro!: Cons simp: max_def)

	lemma fold_max_le_self:
	fixes y::"'a::linorder"
	shows "y \<le> fold max ys y"
	by (induct ys) (auto intro: order_trans[OF _ fold_max_mono])

	lemma fold_max_le:
	fixes x::"'a::linorder"
	shows "x \<in> set xs \<Longrightarrow> x \<le> fold max xs z"
	by (induct xs arbitrary: x z) (auto intro: order_trans[OF _ fold_max_le_self])

	abbreviation "degree_aforms_err \<equiv> degrees o map (snd o fst)"

	definition "aforms_err_to_aforms d xs =
	(map (\<lambda>(d, x). aform_err_to_aform x d) (zip [d..<d + length xs] xs))"

	lemma aform_vals_empty[simp]: "aform_vals e' [] = []"
	by (auto simp: aform_vals_def)
	lemma aforms_err_to_aforms_Nil[simp]: "(aforms_err_to_aforms n []) = []"
	by (auto simp: aforms_err_to_aforms_def)

	lemma aforms_err_to_aforms_Cons[simp]:
	"aforms_err_to_aforms n (X # XS) = aform_err_to_aform X n # aforms_err_to_aforms (Suc n) XS"
	by (auto simp: aforms_err_to_aforms_def not_le nth_append nth_Cons
	intro!: nth_equalityI split: nat.splits)

	lemma degree_aform_err_to_aform_le:
	"degree_aform (aform_err_to_aform X n) \<le> max (degree_aform_err X) (Suc n)"
	by (auto simp: aform_err_to_aform_def intro!: degree_le)

	lemma less_degree_aform_aform_err_to_aformD: "i < degree_aform (aform_err_to_aform X n) \<Longrightarrow> i < max (Suc n) (degree_aform_err X)"
	using degree_aform_err_to_aform_le[of X n] by auto

	lemma pdevs_domain_aform_err_to_aform:
	"pdevs_domain (snd (aform_err_to_aform X n)) = pdevs_domain (snd (fst X)) \<union> (if snd X = 0 then {} else {n})"
	if "n \<ge> degree_aform_err X"
	using that
	by (auto simp: aform_err_to_aform_def split: if_splits)

	lemma length_aforms_err_to_aforms[simp]: "length (aforms_err_to_aforms i XS) = length XS"
	by (auto simp: aforms_err_to_aforms_def)

	lemma aforms_err_to_aforms_ex:
	assumes X: "x \<in> aforms_err e X"
	assumes deg: "degree_aforms_err X \<le> n"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "\<exists>e'\<in> UNIV \<rightarrow> {-1 .. 1}. x = aform_vals e' (aforms_err_to_aforms n X) \<and>
	(\<forall>i < n. e' i = e i)"
	using X deg
	proof (induction X arbitrary: x n)
	case Nil then show ?case using e
	by (auto simp: o_def degrees_def intro!: bexI[where x="\<lambda>i. e i"])
	next
	case (Cons X XS)
	from Cons.prems obtain y ys where ys:
	"degree_aform_err X \<le> n"
	"degree_aforms_err XS \<le> n"
	"x = y # ys" "y \<in> aform_err e X" "ys \<in> aforms_err e XS"
	by (auto simp: mem_aforms_err_Cons_iff_Ex_conv degrees_def)
	then have "degree_aforms_err XS \<le> Suc n" by auto
	from Cons.IH[OF ys(5) this]
	obtain e' where e': "e'\<in>UNIV \<rightarrow> {- 1..1}" "ys = aform_vals e' (aforms_err_to_aforms (Suc n) XS)"
	"(\<forall>i<n. e' i = e i)"
	by auto
	from aform_err_to_aformE[OF ys(4,1)] obtain err where err:
	"y = aform_val (e(n := err)) (aform_err_to_aform X n)" "- 1 \<le> err" "err \<le> 1"
	by auto
	show ?case
	proof (safe intro!: bexI[where x="e'(n:=err)"], goal_cases)
	case 1
	then show ?case
	unfolding ys e' err
	apply (auto simp: aform_vals_def aform_val_def simp del: pdevs_val_upd)
	apply (rule pdevs_val_degree_cong)
	apply simp
	subgoal
	using ys e'
	by (auto dest!: less_degree_aform_aform_err_to_aformD simp: max_def split: if_splits)
	subgoal premises prems for a b
	proof -
	have "pdevs_val (\<lambda>a. if a = n then err else e' a) b = pdevs_val (e'(n:=err)) b"
	unfolding fun_upd_def by simp
	also have "\<dots> = pdevs_val e' b - e' n * pdevs_apply b n + err * pdevs_apply b n"
	by simp
	also
	from prems
	obtain i where i: "aforms_err_to_aforms (Suc n) XS ! i = (a, b)"
	"i < length (aforms_err_to_aforms (Suc n) XS)"
	by (auto simp: in_set_conv_nth )
	{ note i(1)[symmetric]
	also have "aforms_err_to_aforms (Suc n) XS ! i = aform_err_to_aform (XS ! i) (Suc n + i) "
	unfolding aforms_err_to_aforms_def
	using i
	by (simp del: upt_Suc)
	finally have "b = snd (aform_err_to_aform (XS ! i) (Suc n + i))" by (auto simp: prod_eq_iff)
	} note b = this
	have "degree_aform_err (XS ! i) \<le> n"
	using ys(2) i by (auto simp: degrees_def)
	then have "n \<notin> pdevs_domain b" unfolding b
	apply (subst pdevs_domain_aform_err_to_aform)
	by (auto intro!: degree)
	then have "pdevs_apply b n = 0" by simp
	finally
	show ?thesis by simp
	qed
	done
	next
	case (2 i)
	then show ?case
	using e' by auto
	next
	case (3 i)
	then show ?case
	using e' err
	by auto
	qed
	qed

	lemma aforms_err_to_aformsE:
	assumes X: "x \<in> aforms_err e X"
	assumes deg: "degree_aforms_err X \<le> n"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	obtains e' where "x = aform_vals e' (aforms_err_to_aforms n X)" "e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	"\<And>i. i < n \<Longrightarrow> e' i = e i"
	using aforms_err_to_aforms_ex[OF X deg e]
	by blast

	definition "approx_floatariths p ea as =
	do {
	let da = (degree_aforms as);
	let aes = (map (\<lambda>x. (x, 0)) as);
	rs \<leftarrow> approx_floatariths_aformerr p ea aes;
	let d = max da (degree_aforms_err (rs));
	Some (aforms_err_to_aforms d rs)
	}"

	lemma listset_sings[simp]:
	"listset (map (\<lambda>x. {f x}) as) = {map f as}"
	by (induction as) (auto simp: set_Cons_def)

	lemma approx_floatariths_outer:
	assumes "approx_floatariths p ea as = Some XS"
	assumes "vs \<in> Joints as"
	shows "(interpret_floatariths ea vs @ vs) \<in> Joints (XS @ as)"
	proof -
	from assms obtain da aes rs d where
	da: "da = degree_aforms as"
	and aes: "aes = (map (\<lambda>x. (x, 0)) as)"
	and rs: "approx_floatariths_aformerr p ea aes = Some rs"
	and d: "d = max da (degree_aforms_err (rs))"
	and XS: "aforms_err_to_aforms d rs = XS"
	by (auto simp: approx_floatariths_def Let_def bind_eq_Some_conv)
	have abbd: "(a, b) \<in> set as \<Longrightarrow> degree b \<le> degree_aforms as" for a b
	apply (rule degrees_leD[OF order_refl]) by force
	from da d have i_less: "(a, b) \<in> set as \<Longrightarrow> i < degree b \<Longrightarrow> i < min d da" for i a b
	by (auto dest!: abbd)

	have abbd: "(a, b) \<in> set as \<Longrightarrow> degree b \<le> degree_aforms as" for a b
	apply (rule degrees_leD[OF order_refl]) by force
	from assms obtain e' where vs: "vs = (map (aform_val e') as)" and e': "e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	by (auto simp: Joints_def valuate_def)
	note vs
	also
	have vs_aes: "vs \<in> aforms_err e' aes"
	unfolding aes
	by (auto simp: vs aforms_err_def o_def aform_err_def)
	from approx_floatariths_Elem[OF e' rs this]
	have iars: "interpret_floatariths ea (map (aform_val e') as) \<in> aforms_err e' rs"
	by (auto simp: vs)
	have "degree_aforms_err rs \<le> d"
	by (auto simp: d da)
	from aforms_err_to_aformsE[OF iars this e'] obtain e where
	"interpret_floatariths ea (map (aform_val e') as) = aform_vals e XS"
	and e: "e \<in> UNIV \<rightarrow> {- 1..1}" "\<And>i. i < d \<Longrightarrow> e i = e' i"
	by (auto simp: XS)
	note this (1)
	finally have "interpret_floatariths ea vs = aform_vals e XS" .

	moreover

	from e have e'_eq: "e' i = e i" if "i < min d da" for i
	using that
	by (auto simp: min_def split: if_splits)
	then have "vs = aform_vals e as"
	by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less)

	ultimately show ?thesis
	using e(1)
	by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e])
	qed

	lemma length_eq_NilI: "length [] = length []"
	and length_eq_ConsI: "length xs = length ys \<Longrightarrow> length (x#xs) = length (y#ys)"
	by auto


	subsection \<open>Generic operations on Affine Forms in Euclidean Space\<close>

	lemma pdevs_val_domain_cong:
	assumes "b = d"
	assumes "\<And>i. i \<in> pdevs_domain b \<Longrightarrow> a i = c i"
	shows "pdevs_val a b = pdevs_val c d"
	using assms
	by (auto simp: pdevs_val_pdevs_domain)

	lemma fresh_JointsI:
	assumes "xs \<in> Joints XS"
	assumes "list_all (\<lambda>Y. pdevs_domain (snd X) \<inter> pdevs_domain (snd Y) = {}) XS"
	assumes "x \<in> Affine X"
	shows "x#xs \<in> Joints (X#XS)"
	using assms
	unfolding Joints_def Affine_def valuate_def
	proof safe
	fix e e'::"nat \<Rightarrow> real"
	assume H: "list_all (\<lambda>Y. pdevs_domain (snd X) \<inter> pdevs_domain (snd Y) = {}) XS"
	"e \<in> UNIV \<rightarrow> {- 1..1}"
	"e' \<in> UNIV \<rightarrow> {- 1..1}"
	have "\<And>a b i. \<forall>Y\<in>set XS. pdevs_domain (snd X) \<inter> pdevs_domain (snd Y) = {} \<Longrightarrow>
	pdevs_apply b i \<noteq> 0 \<Longrightarrow>
	pdevs_apply (snd X) i \<noteq> 0 \<Longrightarrow>
	(a, b) \<notin> set XS"
	by (metis (poly_guards_query) IntI all_not_in_conv in_pdevs_domain snd_eqD)
	with H show
	"aform_val e' X # map (aform_val e) XS \<in> (\<lambda>e. map (aform_val e) (X # XS)) ` (UNIV \<rightarrow> {- 1..1})"
	by (intro image_eqI[where x = "\<lambda>i. if i \<in> pdevs_domain (snd X) then e' i else e i"])
	(auto simp: aform_val_def list_all_iff Pi_iff intro!: pdevs_val_domain_cong)
	qed


	primrec approx_slp::"nat \<Rightarrow> slp \<Rightarrow> aform_err list \<Rightarrow> aform_err list option"
	where
	"approx_slp p [] xs = Some xs"
	\| "approx_slp p (ea # eas) xs =
	do {
	r \<leftarrow> approx_floatarith p ea xs;
	approx_slp p eas (r#xs)
	}"

	lemma Nil_mem_Joints[intro, simp]: "[] \<in> Joints []"
	by (force simp: Joints_def valuate_def)

	lemma map_nth_Joints: "xs \<in> Joints XS \<Longrightarrow> (\<And>i. i \<in> set is \<Longrightarrow> i < length XS) \<Longrightarrow> map (nth xs) is @ xs \<in> Joints (map (nth XS) is @ XS)"
	by (auto simp: Joints_def valuate_def)

	lemma map_nth_Joints': "xs \<in> Joints XS \<Longrightarrow> (\<And>i. i \<in> set is \<Longrightarrow> i < length XS) \<Longrightarrow> map (nth xs) is \<in> Joints (map (nth XS) is)"
	by (rule Joints_appendD2[OF map_nth_Joints]) auto

	lemma approx_slp_Elem:
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "vs \<in> aforms_err e VS"
	assumes "approx_slp p ra VS = Some X"
	shows "interpret_slp ra vs \<in> aforms_err e X"
	using assms(2-)
	proof (induction ra arbitrary: X vs VS)
	case (Cons ra ras)
	from Cons.prems
	obtain a where a: "approx_floatarith p ra VS = Some a"
	and r: "approx_slp p ras (a # VS) = Some X"
	by (auto simp: bind_eq_Some_conv)
	from approx_floatarith_Elem[OF a e Cons.prems(1)]
	have "interpret_floatarith ra vs \<in> aform_err e a"
	by auto
	then have 1: "interpret_floatarith ra vs#vs \<in> aforms_err e (a#VS)"
	unfolding mem_aforms_err_Cons_iff
	using Cons.prems(1)
	by auto
	show ?case
	by (auto intro!: Cons.IH 1 r)
	qed auto

	definition "approx_slp_outer p n slp XS =
	do {
	let d = degree_aforms XS;
	let XSe = (map (\<lambda>x. (x, 0)) XS);
	rs \<leftarrow> approx_slp p slp XSe;
	let rs' = take n rs;
	let d' = max d (degree_aforms_err rs');
	Some (aforms_err_to_aforms d' rs')
	}"

	lemma take_in_listsetI: "xs \<in> listset XS \<Longrightarrow> take n xs \<in> listset (take n XS)"
	by (induction XS arbitrary: xs n) (auto simp: take_Cons listset_Cons_mem_conv set_Cons_def split: nat.splits)

	lemma take_in_aforms_errI: "take n xs \<in> aforms_err e (take n XS)"
	if "xs \<in> aforms_err e XS"
	using that
	by (auto simp: aforms_err_def take_map[symmetric] intro!: take_in_listsetI)

	theorem approx_slp_outer:
	assumes "approx_slp_outer p n slp XS = Some RS"
	assumes slp: "slp = slp_of_fas fas" "n = length fas"
	assumes "xs \<in> Joints XS"
	shows "interpret_floatariths fas xs @ xs \<in> Joints (RS @ XS)"
	proof -
	from assms obtain d XSe rs rs' d' where
	d: "d = degree_aforms XS"
	and XSe: "XSe = (map (\<lambda>x. (x, 0)) XS)"
	and rs: "approx_slp p (slp_of_fas fas) XSe = Some rs"
	and rs': "rs' = take (length fas) rs"
	and d': "d' = max d (degree_aforms_err rs')"
	and RS: "aforms_err_to_aforms d' rs' = RS"
	by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv)
	have abbd: "(a, b) \<in> set XS \<Longrightarrow> degree b \<le> degree_aforms XS" for a b
	apply (rule degrees_leD[OF order_refl]) by force
	from d' d have i_less: "(a, b) \<in> set XS \<Longrightarrow> i < degree b \<Longrightarrow> i < min d d'" for i a b
	by (auto dest!: abbd)
	from assms obtain e' where vs: "xs = (map (aform_val e') XS)" and e': "e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	by (auto simp: Joints_def valuate_def)
	from d have d: "V \<in> set XS \<Longrightarrow> degree_aform V \<le> d" for V
	by (auto intro!: degrees_leD)
	have xs_XSe: "xs \<in> aforms_err e' XSe"
	by (auto simp: vs aforms_err_def XSe o_def aform_err_def)
	from approx_slp_Elem[OF e' xs_XSe rs]
	have aforms_err: "interpret_slp (slp_of_fas fas) xs \<in> aforms_err e' rs" .
	have "interpret_floatariths fas xs = take (length fas) (interpret_slp (slp_of_fas fas) xs)"
	using assms by (simp add: slp_of_fas)
	also
	from aforms_err
	have "take (length fas) (interpret_slp (slp_of_fas fas) xs) \<in> aforms_err e' rs'"
	unfolding rs'
	by (auto simp: take_map intro!: take_in_aforms_errI)
	finally have ier: "interpret_floatariths fas xs \<in> aforms_err e' rs'" .
	have "degree_aforms_err rs' \<le> d'" using d' by auto
	from aforms_err_to_aformsE[OF ier this e'] obtain e where
	"interpret_floatariths fas xs = aform_vals e RS"
	and e: "e \<in> UNIV \<rightarrow> {- 1..1}" "\<And>i. i < d' \<Longrightarrow> e i = e' i"
	unfolding RS
	- by (auto simp: )
	+ by auto
	moreover

	from e have e'_eq: "e' i = e i" if "i < min d d'" for i
	using that
	by (auto simp: min_def split: if_splits)
	then have "xs = aform_vals e XS"
	by (auto simp: vs aform_vals_def aform_val_def intro!: pdevs_val_degree_cong e'_eq i_less)

	ultimately show ?thesis
	using e(1)
	by (auto simp: Joints_def valuate_def aform_vals_def intro!: image_eqI[where x=e])

	qed

	theorem approx_slp_outer_plain:
	assumes "approx_slp_outer p n slp XS = Some RS"
	assumes slp: "slp = slp_of_fas fas" "n = length fas"
	assumes "xs \<in> Joints XS"
	shows "interpret_floatariths fas xs \<in> Joints RS"
	proof -
	have "length fas = length RS"
	proof -
	have f1: "length xs = length XS"
	using Joints_imp_length_eq assms(4) by blast
	have "interpret_floatariths fas xs @ xs \<in> Joints (RS @ XS)"
	using approx_slp_outer assms(1) assms(2) assms(3) assms(4) by blast
	then show ?thesis
	using f1 Joints_imp_length_eq by fastforce
	qed
	with Joints_appendD2[OF approx_slp_outer[OF assms]] show ?thesis by simp
	qed

	end

	end
	diff --git a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
	--- a/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
	+++ b/thys/Affine_Arithmetic/Counterclockwise_2D_Arbitrary.thy
	@@ -1,925 +1,925 @@
	section \<open>CCW for Arbitrary Points in the Plane\<close>
	theory Counterclockwise_2D_Arbitrary
	imports Counterclockwise_2D_Strict
	begin

	subsection \<open>Interpretation of Knuth's axioms in the plane\<close>

	definition lex::"point \<Rightarrow> point \<Rightarrow> bool" where
	"lex p q \<longleftrightarrow> (fst p < fst q \<or> fst p = fst q \<and> snd p < snd q \<or> p = q)"

	definition psi::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
	"psi p q r \<longleftrightarrow> (lex p q \<and> lex q r)"

	definition ccw::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> bool" where
	"ccw p q r \<longleftrightarrow> ccw' p q r \<or> (det3 p q r = 0 \<and> (psi p q r \<or> psi q r p \<or> psi r p q))"

	interpretation ccw: linorder_list0 "ccw x" for x .

	lemma ccw'_imp_ccw: "ccw' a b c \<Longrightarrow> ccw a b c"
	by (simp add: ccw_def)

	lemma ccw_ncoll_imp_ccw: "ccw a b c \<Longrightarrow> \<not>coll a b c \<Longrightarrow> ccw' a b c"
	by (simp add: ccw_def)

	lemma ccw_translate: "ccw p (p + q) (p + r) = ccw 0 q r"
	by (auto simp: ccw_def psi_def lex_def)

	lemma ccw_translate_origin: "NO_MATCH 0 p \<Longrightarrow> ccw p q r = ccw 0 (q - p) (r - p)"
	using ccw_translate[of p "q - p" "r - p"]
	by simp

	lemma psi_scale:
	"psi (r \<^sub>R a) (r \<^sub>R b) 0 = (if r > 0 then psi a b 0 else if r < 0 then psi 0 b a else True)"
	"psi (r \<^sub>R a) 0 (r \<^sub>R b) = (if r > 0 then psi a 0 b else if r < 0 then psi b 0 a else True)"
	"psi 0 (r \<^sub>R a) (r \<^sub>R b) = (if r > 0 then psi 0 a b else if r < 0 then psi b a 0 else True)"
	by (auto simp: psi_def lex_def det3_def' not_less algebra_split_simps)

	lemma ccw_scale23: "ccw 0 a b \<Longrightarrow> r > 0 \<Longrightarrow> ccw 0 (r \<^sub>R a) (r \<^sub>R b)"
	by (auto simp: ccw_def psi_scale)

	lemma psi_notI: "distinct3 p q r \<Longrightarrow> psi p q r \<Longrightarrow> \<not> psi q p r"
	by (auto simp: algebra_simps psi_def lex_def)

	lemma not_lex_eq: "\<not> lex a b \<longleftrightarrow> lex b a \<and> b \<noteq> a"
	by (auto simp: algebra_simps lex_def prod_eq_iff)

	lemma lex_trans: "lex a b \<Longrightarrow> lex b c \<Longrightarrow> lex a c"
	by (auto simp: lex_def)

	lemma lex_sym_eqI: "lex a b \<Longrightarrow> lex b a \<Longrightarrow> a = b"
	and lex_sym_eq_iff: "lex a b \<Longrightarrow> lex b a \<longleftrightarrow> a = b"
	by (auto simp: lex_def)

	lemma lex_refl[simp]: "lex p p"
	by (metis not_lex_eq)

	lemma psi_disjuncts:
	"distinct3 p q r \<Longrightarrow> psi p q r \<or> psi p r q \<or> psi q r p \<or> psi q p r \<or> psi r p q \<or> psi r q p"
	by (auto simp: psi_def not_lex_eq)

	lemma nlex_ccw_left: "lex x 0 \<Longrightarrow> ccw 0 (0, 1) x"
	by (auto simp: ccw_def lex_def psi_def ccw'_def det3_def')

	interpretation ccw_system123 ccw
	apply unfold_locales
	subgoal by (force simp: ccw_def ccw'_def det3_def' algebra_simps)
	subgoal by (force simp: ccw_def ccw'_def det3_def' psi_def algebra_simps lex_sym_eq_iff)
	subgoal by (drule psi_disjuncts) (force simp: ccw_def ccw'_def det3_def' algebra_simps)
	done

	lemma lex_scaleR_nonneg: "lex a b \<Longrightarrow> r \<ge> 0 \<Longrightarrow> lex a (a + r *\<^sub>R (b - a))"
	by (auto simp: lex_def)

	lemma lex_scale1_zero:
	"lex (v *\<^sub>R u) 0 = (if v > 0 then lex u 0 else if v < 0 then lex 0 u else True)"
	and lex_scale2_zero:
	"lex 0 (v *\<^sub>R u) = (if v > 0 then lex 0 u else if v < 0 then lex u 0 else True)"
	by (auto simp: lex_def prod_eq_iff less_eq_prod_def algebra_split_simps)

	lemma nlex_add:
	assumes "lex a 0" "lex b 0"
	shows "lex (a + b) 0"
	using assms by (auto simp: lex_def)

	lemma nlex_sum:
	assumes "finite X"
	assumes "\<And>x. x \<in> X \<Longrightarrow> lex (f x) 0"
	shows "lex (sum f X) 0"
	using assms
	by induction (auto intro!: nlex_add)

	lemma abs_add_nlex:
	assumes "coll 0 a b"
	assumes "lex a 0"
	assumes "lex b 0"
	shows "abs (a + b) = abs a + abs b"
	proof (rule antisym[OF abs_triangle_ineq])
	have "fst (\<bar>a\<bar> + \<bar>b\<bar>) \<le> fst \<bar>a + b\<bar>"
	using assms
	by (auto simp add: det3_def' abs_prod_def lex_def)
	moreover
	{
	assume H: "fst a < 0" "fst b < 0"
	hence "snd b \<le> 0 \<longleftrightarrow> snd a \<le> 0"
	using assms
	by (auto simp: lex_def det3_def' mult.commute)
	(metis mult_le_cancel_left_neg mult_zero_right)+
	hence "\<bar>snd a\<bar> + \<bar>snd b\<bar> \<le> \<bar>snd a + snd b\<bar>"
	using H by auto
	} hence "snd (\<bar>a\<bar> + \<bar>b\<bar>) \<le> snd \<bar>a + b\<bar>"
	using assms
	by (auto simp add: det3_def' abs_prod_def lex_def)
	ultimately
	show "\<bar>a\<bar> + \<bar>b\<bar> \<le> \<bar>a + b\<bar>" unfolding less_eq_prod_def ..
	qed

	lemma lex_sum_list: "(\<And>x. x \<in> set xs \<Longrightarrow> lex x 0) \<Longrightarrow> lex (sum_list xs) 0"
	by (induct xs) (auto simp: nlex_add)

	lemma
	abs_sum_list_coll:
	assumes coll: "list_all (coll 0 x) xs"
	assumes "x \<noteq> 0"
	assumes up: "list_all (\<lambda>x. lex x 0) xs"
	shows "abs (sum_list xs) = sum_list (map abs xs)"
	using assms
	proof (induct xs)
	case (Cons y ys)
	hence "coll 0 x y" "coll 0 x (sum_list ys)"
	by (auto simp: list_all_iff intro!: coll_sum_list)
	hence "coll 0 y (sum_list ys)" using \<open>x \<noteq> 0\<close>
	by (rule coll_trans)
	hence "\<bar>y + sum_list ys\<bar> = abs y + abs (sum_list ys)" using Cons
	by (subst abs_add_nlex) (auto simp: list_all_iff lex_sum_list)
	thus ?case using Cons by simp
	qed simp

	lemma lex_diff1: "lex (a - b) c = lex a (c + b)"
	and lex_diff2: "lex c (a - b) = lex (c + b) a"
	by (auto simp: lex_def)

	lemma sum_list_eq_0_iff_nonpos:
	fixes xs::"'a::ordered_ab_group_add list"
	shows "list_all (\<lambda>x. x \<le> 0) xs \<Longrightarrow> sum_list xs = 0 \<longleftrightarrow> (\<forall>n\<in>set xs. n = 0)"
	by (auto simp: list_all_iff sum_list_sum_nth sum_nonpos_eq_0_iff)
	(auto simp add: in_set_conv_nth)

	lemma sum_list_nlex_eq_zeroI:
	assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
	assumes "sum_list xs = 0"
	assumes "x \<in> set xs"
	shows "x = 0"
	proof -
	from assms(2) have z1: "sum_list (map fst xs) = 0" and z2: "sum_list (map snd xs) = 0"
	by (auto simp: prod_eq_iff fst_sum_list snd_sum_list)
	from nlex have "list_all (\<lambda>x. x \<le> 0) (map fst xs)"
	by (auto simp: lex_def list_all_iff)
	from sum_list_eq_0_iff_nonpos[OF this] z1 nlex
	have
	z1': "list_all (\<lambda>x. x = 0) (map fst xs)"
	and "list_all (\<lambda>x. x \<le> 0) (map snd xs)"
	by (auto simp: list_all_iff lex_def)
	from sum_list_eq_0_iff_nonpos[OF this(2)] z2
	have "list_all (\<lambda>x. x = 0) (map snd xs)" by (simp add: list_all_iff)
	with z1' show "x = 0" by (auto simp: list_all_iff zero_prod_def assms prod_eq_iff)
	qed

	lemma sum_list_eq0I: "(\<forall>x\<in>set xs. x = 0) \<Longrightarrow> sum_list xs = 0"
	by (induct xs) auto

	lemma sum_list_nlex_eq_zero_iff:
	assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
	shows "sum_list xs = 0 \<longleftrightarrow> list_all ((=) 0) xs"
	using assms
	by (auto intro: sum_list_nlex_eq_zeroI sum_list_eq0I simp: list_all_iff)

	lemma
	assumes "lex p q" "lex q r" "0 \<le> a" "0 \<le> b" "0 \<le> c" "a + b + c = 1"
	assumes comb_def: "comb = a \<^sub>R p + b \<^sub>R q + c *\<^sub>R r"
	shows lex_convex3: "lex p comb" "lex comb r"
	proof -
	from convex3_alt[OF assms(3-6), of p q r]
	obtain u v where
	uv: "a \<^sub>R p + b \<^sub>R q + c \<^sub>R r = p + u \<^sub>R (q - p) + v *\<^sub>R (r - p)" "0 \<le> u" "0 \<le> v" "u + v \<le> 1" .
	have "lex p r"
	using assms by (metis lex_trans)
	hence "lex (v *\<^sub>R (p - r)) 0" using uv
	by (simp add: lex_scale1_zero lex_diff1)
	also
	have "lex 0 (u *\<^sub>R (q - p))" using \<open>lex p q\<close> uv
	by (simp add: lex_scale2_zero lex_diff2)
	finally (lex_trans)
	show "lex p comb"
	unfolding comb_def uv
	by (simp add: lex_def prod_eq_iff algebra_simps)
	from comb_def have comb_def': "comb = c \<^sub>R r + b \<^sub>R q + a *\<^sub>R p" by simp
	from assms have "c + b + a = 1" by simp
	from convex3_alt[OF assms(5,4,3) this, of r q p]
	obtain u v where uv: "c \<^sub>R r + b \<^sub>R q + a \<^sub>R p = r + u \<^sub>R (q - r) + v *\<^sub>R (p - r)"
	"0 \<le> u" "0 \<le> v" "u + v \<le> 1"
	by auto
	have "lex (u *\<^sub>R (q - r)) 0"
	using uv \<open>lex q r\<close>
	by (simp add: lex_scale1_zero lex_diff1)
	also have "lex 0 (v *\<^sub>R (r - p))"
	using uv \<open>lex p r\<close>
	by (simp add: lex_scale2_zero lex_diff2)
	finally (lex_trans) show "lex comb r"
	unfolding comb_def' uv
	by (simp add: lex_def prod_eq_iff algebra_simps)
	qed

	lemma lex_convex_self2:
	assumes "lex p q" "0 \<le> a" "a \<le> 1"
	defines "r \<equiv> a \<^sub>R p + (1 - a) \<^sub>R q"
	shows "lex p r" (is ?th1)
	and "lex r q" (is ?th2)
	using lex_convex3[OF \<open>lex p q\<close>, of q a "1 - a" 0 r]
	assms
	by (simp_all add: r_def)

	lemma lex_uminus0[simp]: "lex (-a) 0 = lex 0 a"
	by (auto simp: lex_def)

	lemma
	lex_fst_zero_imp:
	"fst x = 0 \<Longrightarrow> lex x 0 \<Longrightarrow> lex y 0 \<Longrightarrow> \<not>coll 0 x y \<Longrightarrow> ccw' 0 y x"
	by (auto simp: ccw'_def det3_def' lex_def algebra_split_simps)

	lemma lex_ccw_left: "lex x y \<Longrightarrow> r > 0 \<Longrightarrow> ccw y (y + (0, r)) x"
	by (auto simp: ccw_def ccw'_def det3_def' algebra_simps lex_def psi_def)

	lemma lex_translate_origin: "NO_MATCH 0 a \<Longrightarrow> lex a b = lex 0 (b - a)"
	by (auto simp: lex_def)


	subsection \<open>Order prover setup\<close>

	definition "lexs p q \<longleftrightarrow> (lex p q \<and> p \<noteq> q)"

	lemma lexs_irrefl: "\<not> lexs p p"
	and lexs_imp_lex: "lexs x y \<Longrightarrow> lex x y"
	and not_lexs: "(\<not> lexs x y) = (lex y x)"
	and not_lex: "(\<not> lex x y) = (lexs y x)"
	and eq_lex_refl: "x = y \<Longrightarrow> lex x y"
	by (auto simp: lexs_def lex_def prod_eq_iff)

	lemma lexs_trans: "lexs x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
	and lexs_lex_trans: "lexs x y \<Longrightarrow> lex y z \<Longrightarrow> lexs x z"
	and lex_lexs_trans: "lex x y \<Longrightarrow> lexs y z \<Longrightarrow> lexs x z"
	and lex_neq_trans: "lex a b \<Longrightarrow> a \<noteq> b \<Longrightarrow> lexs a b"
	and neq_lex_trans: "a \<noteq> b \<Longrightarrow> lex a b \<Longrightarrow> lexs a b"
	and lexs_imp_neq: "lexs a b \<Longrightarrow> a \<noteq> b"
	by (auto simp: lexs_def lex_def prod_eq_iff)

	local_setup \<open>
	HOL_Order_Tac.declare_linorder {
	ops = {eq = @{term \<open>(=) :: point \<Rightarrow> point \<Rightarrow> bool\<close>}, le = @{term \<open>lex\<close>}, lt = @{term \<open>lexs\<close>}},
	thms = {trans = @{thm lex_trans}, refl = @{thm lex_refl}, eqD1 = @{thm eq_lex_refl},
	eqD2 = @{thm eq_lex_refl[OF sym]}, antisym = @{thm lex_sym_eqI}, contr = @{thm notE}},
	conv_thms = {less_le = @{thm eq_reflection[OF lexs_def]},
	nless_le = @{thm eq_reflection[OF not_lexs]},
	nle_le = @{thm eq_reflection[OF not_lex_eq]}}
	}
	\<close>

	subsection \<open>Contradictions\<close>

	lemma
	assumes d: "distinct4 s p q r"
	shows contra1: "\<not>(lex p q \<and> lex q r \<and> lex r s \<and> indelta s p q r)" (is ?th1)
	and contra2: "\<not>(lex s p \<and> lex p q \<and> lex q r \<and> indelta s p q r)" (is ?th2)
	and contra3: "\<not>(lex p r \<and> lex p s \<and> lex q r \<and> lex q s \<and> insquare p r q s)" (is ?th3)
	proof -
	{
	assume "det3 s p q = 0" "det3 s q r = 0" "det3 s r p = 0" "det3 p q r = 0"
	hence ?th1 ?th2 ?th3 using d
	by (auto simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
	} moreover {
	assume *: "\<not>(det3 s p q = 0 \<and> det3 s q r = 0 \<and> det3 s r p = 0 \<and> det3 p q r = 0)"
	{
	assume d0: "det3 p q r = 0"
	with d have "?th1 \<and> ?th2"
	by (force simp add: det3_def' ccw'_def ccw_def psi_def algebra_simps)
	} moreover {
	assume dp: "det3 p q r \<noteq> 0"
	have "?th1 \<and> ?th2"
	unfolding de_Morgan_disj[symmetric]
	proof (rule notI, goal_cases)
	case prems: 1
	hence **: "indelta s p q r" by auto
	hence nonnegs: "det3 p q r \<ge> 0" "0 \<le> det3 s q r" "0 \<le> det3 p s r" "0 \<le> det3 p q s"
	by (auto simp: ccw_def ccw'_def det3_def' algebra_simps)
	hence det_pos: "det3 p q r > 0" using dp by simp
	have det_eq: "det3 s q r + det3 p s r + det3 p q s = det3 p q r"
	by (auto simp: ccw_def det3_def' algebra_simps)
	hence det_div_eq:
	"det3 s q r / det3 p q r + det3 p s r / det3 p q r + det3 p q s / det3 p q r = 1"
	using det_pos by (auto simp: field_simps)
	from lex_convex3[OF _ _ _ _ _ det_div_eq convex_comb_dets[OF det_pos, of s]]
	have "lex p s" "lex s r"
	using prems by (auto simp: nonnegs)
	with prems d show False by (simp add: lex_sym_eq_iff)
	qed
	} moreover have ?th3
	proof (safe, goal_cases)
	case prems: 1
	have nonnegs: "det3 p r q \<ge> 0" "det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
	using prems
	by (auto simp add: ccw_def ccw'_def less_eq_real_def)
	have dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
	by (auto simp: det3_def')
	hence **: "det3 p r q = 0 \<and> det3 q s p = 0 \<Longrightarrow> det3 r q s = 0 \<and> det3 s p r = 0"
	using prems
	by (auto simp: ccw_def ccw'_def)
	moreover
	{
	fix p r q s
	assume det_pos: "det3 p r q > 0"
	assume dets_eq: "det3 p r q + det3 q s p = det3 r q s + det3 s p r"
	assume nonnegs:"det3 r q s \<ge> 0" "det3 s p r \<ge> 0" "det3 q s p \<ge> 0"
	assume g14: "lex p r" "lex p s" "lex q r" "lex q s"
	assume d: "distinct4 s p q r"

	let ?sum = "(det3 p r q + det3 q s p) / det3 p r q"
	have eqs: "det3 s p r = det3 p r s" "det3 r q s = det3 s r q" "det3 q s p = - det3 p s q"
	by (auto simp: det3_def' algebra_simps)
	from convex_comb_dets[OF det_pos, of s]
	have "((det3 p r q / det3 p r q) \<^sub>R s + (det3 q s p / det3 p r q) \<^sub>R r) /\<^sub>R ?sum =
	((det3 r q s / det3 p r q) \<^sub>R p + (det3 s p r / det3 p r q) \<^sub>R q) /\<^sub>R ?sum"
	unfolding eqs
	by (simp add: algebra_simps prod_eq_iff)
	hence srpq: "(det3 p r q / det3 p r q / ?sum) \<^sub>R s + (det3 q s p / det3 p r q / ?sum) \<^sub>R r =
	(det3 r q s / det3 p r q / ?sum) \<^sub>R p + (det3 s p r / det3 p r q / ?sum) \<^sub>R q"
	(is "?s \<^sub>R s + ?r \<^sub>R r = ?p \<^sub>R p + ?q \<^sub>R q")
	using det_pos
	by (simp add: algebra_simps inverse_eq_divide)
	have eqs: "?s + ?r = 1" "?p + ?q = 1"
	and s: "?s \<ge> 0" "?s \<le> 1"
	and r: "?r \<ge> 0" "?r \<le> 1"
	and p: "?p \<ge> 0" "?p \<le> 1"
	and q: "?q \<ge> 0" "?q \<le> 1"
	unfolding add_divide_distrib[symmetric]
	using det_pos nonnegs dets_eq
	by (auto)
	from eqs have eqs': "1 - ?s = ?r" "1 - ?r = ?s" "1 - ?p = ?q" "1 - ?q = ?p"
	by auto
	have comm: "?r \<^sub>R r + ?s \<^sub>R s = ?s \<^sub>R s + ?r \<^sub>R r"
	"?q \<^sub>R q + ?p \<^sub>R p = ?p \<^sub>R p + ?q \<^sub>R q"
	by simp_all
	define K
	where "K = (det3 r q s / det3 p r q / ?sum) \<^sub>R p + (det3 s p r / det3 p r q / ?sum) \<^sub>R q"
	note rewrs = eqs' comm srpq K_def[symmetric]
	from lex_convex_self2[OF _ s, of s r, unfolded rewrs]
	lex_convex_self2[OF _ r, of r s, unfolded rewrs]
	lex_convex_self2[OF _ p, of p q, unfolded rewrs]
	lex_convex_self2[OF _ q, of q p, unfolded rewrs]
	have False using g14 d det_pos
	by (metis lex_trans not_lex_eq)
	} note wlog = this
	from dets_eq have 1: "det3 q s p + det3 p r q = det3 s p r + det3 r q s"
	by simp
	from d have d': "distinct4 r q p s" by auto
	note wlog[of q s p r, OF _ 1 nonnegs(3,2,1) prems(4,3,2,1) d']
	wlog[of p r q s, OF _ dets_eq nonnegs(2,3,4) prems(1-4) d]
	ultimately show False using nonnegs d *
	by (auto simp: less_eq_real_def det3_def' algebra_simps)
	qed
	ultimately have ?th1 ?th2 ?th3 by blast+
	} ultimately show ?th1 ?th2 ?th3 by force+
	qed

	lemma ccw'_subst_psi_disj:
	assumes "det3 t r s = 0"
	assumes "psi t r s \<or> psi t s r \<or> psi s r t"
	assumes "s \<noteq> t"
	assumes "ccw' t r p"
	shows "ccw' t s p"
	proof cases
	assume "r \<noteq> s"
	from assms have "r \<noteq> t" by (auto simp: det3_def' ccw'_def algebra_simps)
	from assms have "det3 r s t = 0"
	by (auto simp: algebra_simps det3_def')
	from coll_ex_scaling[OF assms(3) this]
	obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
	from assms(4)[simplified s]
	have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
	by (auto simp: algebra_simps det3_def' ccw'_def)
	also have "s + x \<^sub>R (t - s) - t = (1 - x) \<^sub>R (s - t)"
	by (simp add: algebra_simps)
	finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
	by (simp add: ccw'_def)
	hence neq: "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
	have tr: "fst s < fst r \<Longrightarrow> fst t = fst s \<Longrightarrow> snd t \<le> snd r"
	by (simp add: s)
	from s have "fst (r - s) = fst (x \<^sub>R (t - s))" "snd (r - s) = snd (x \<^sub>R (t - s))"
	- by (auto simp: )
	+ by auto
	hence "x = (if fst (t - s) = 0 then snd (r - s) / snd (t - s) else fst (r - s) / fst (t - s))"
	using \<open>s \<noteq> t\<close>
	by (auto simp add: field_simps prod_eq_iff)
	also have "\<dots> \<le> 1"
	using assms
	by (auto simp: lex_def psi_def tr)
	finally have "x < 1" using neq by simp
	thus ?thesis using ccw'
	by (auto simp: ccw'.translate_origin)
	qed (insert assms, simp)

	lemma lex_contr:
	assumes "distinct4 t s q r"
	assumes "lex t s" "lex s r"
	assumes "det3 t s r = 0"
	assumes "ccw' t s q"
	assumes "ccw' t q r"
	shows "False"
	using ccw'_subst_psi_disj[of t s r q] assms
	by (cases "r = t") (auto simp: det3_def' algebra_simps psi_def ccw'_def)

	lemma contra4:
	assumes "distinct4 s r q p"
	assumes lex: "lex q p" "lex p r" "lex r s"
	assumes ccw: "ccw r q s" "ccw r s p" "ccw r q p"
	shows False
	proof cases
	assume c: "ccw s q p"
	from c have *: "indelta s r q p"
	using assms by simp
	with contra1[OF assms(1)]
	have "\<not> (lex r q \<and> lex q p \<and> lex p s)" by blast
	hence "\<not> lex q p"
	using \<open>ccw s q p\<close> contra1 cyclic assms nondegenerate by blast
	thus False using assms by simp
	next
	assume "\<not> ccw s q p"
	with ccw have "ccw q s p \<and> ccw s p r \<and> ccw p r q \<and> ccw r q s"
	by (metis assms(1) ccw'.cyclic ccw_def not_ccw'_eq psi_disjuncts)
	moreover
	from lex have "lex q r" "lex q s" "lex p r" "lex p s" by order+
	ultimately show False using contra3[of r q p s] \<open>distinct4 s r q p\<close> by blast
	qed

	lemma not_coll_ordered_lexI:
	assumes "l \<noteq> x0"
	and "lex x1 r"
	and "lex x1 l"
	and "lex r x0"
	and "lex l x0"
	and "ccw' x0 l x1"
	and "ccw' x0 x1 r"
	shows "det3 x0 l r \<noteq> 0"
	proof
	assume "coll x0 l r"
	from \<open>coll x0 l r\<close> have 1: "coll 0 (l - x0) (r - x0)"
	by (simp add: det3_def' algebra_simps)
	from \<open>lex r x0\<close> have 2: "lex (r - x0) 0" by (auto simp add: lex_def)
	from \<open>lex l x0\<close> have 3: "lex (l - x0) 0" by (auto simp add: lex_def)
	from \<open>ccw' x0 l x1\<close> have 4: "ccw' 0 (l - x0) (x1 - x0)"
	by (simp add: det3_def' ccw'_def algebra_simps)
	from \<open>ccw' x0 x1 r\<close> have 5: "ccw' 0 (x1 - x0) (r - x0)"
	by (simp add: det3_def' ccw'_def algebra_simps)
	from \<open>lex x1 r\<close> have 6: "lex 0 (r - x0 - (x1 - x0))" by (auto simp: lex_def)
	from \<open>lex x1 l\<close> have 7: "lex 0 (l - x0 - (x1 - x0))" by (auto simp: lex_def)
	define r' where "r' = r - x0"
	define l' where "l' = l - x0"
	define x0' where "x0' = x1 - x0"
	from 1 2 3 4 5 6 7
	have rs: "coll 0 l' r'" "lex r' 0"
	"lex l' 0"
	"ccw' 0 l' x0'"
	"ccw' 0 x0' r'"
	"lex 0 (r' - x0')"
	"lex 0 (l' - x0')"
	unfolding r'_def[symmetric] l'_def[symmetric] x0'_def[symmetric]
	by auto
	from assms have "l' \<noteq> 0"
	by (auto simp: l'_def)
	from coll_scale[OF \<open>coll 0 l' _\<close> this]
	obtain y where y: "r' = y *\<^sub>R l'" by auto
	{
	assume "y > 0"
	with rs have False
	by (auto simp: det3_def' algebra_simps y ccw'_def)
	} moreover {
	assume "y < 0"
	with rs have False
	by (auto simp: lex_def not_less algebra_simps algebra_split_simps y ccw'_def)
	} moreover {
	assume "y = 0"
	from this rs have False
	by (simp add: ccw'_def y)
	} ultimately show False by arith
	qed

	interpretation ccw_system4 ccw
	proof unfold_locales
	fix p q r t
	assume ccw: "ccw t q r" "ccw p t r" "ccw p q t"
	show "ccw p q r"
	proof (cases "det3 t q r = 0 \<and> det3 p t r = 0 \<and> det3 p q t = 0")
	case True
	{
	assume "psi t q r \<or> psi q r t \<or> psi r t q"
	"psi p t r \<or> psi t r p \<or> psi r p t"
	"psi p q t \<or> psi q t p \<or> psi t p q"
	hence "psi p q r \<or> psi q r p \<or> psi r p q"
	using lex_sym_eq_iff psi_def by blast
	}
	with True ccw show ?thesis
	by (simp add: det3_def' algebra_simps ccw_def ccw'_def)
	next
	case False
	hence "0 \<le> det3 t q r" "0 \<le> det3 p t r" "0 \<le> det3 p q t"
	using ccw by (auto simp: less_eq_real_def ccw_def ccw'_def)
	with False show ?thesis
	by (auto simp: ccw_def det3_def' algebra_simps ccw'_def intro!: disjI1)
	qed
	qed

	lemma lex_total: "lex t q \<and> t \<noteq> q \<or> lex q t \<and> t \<noteq> q \<or> t = q"
	by auto

	lemma
	ccw_two_up_contra:
	assumes c: "ccw' t p q" "ccw' t q r"
	assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
	assumes distinct: "distinct5 t s p q r"
	shows False
	proof -
	from ccws
	have nn: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t r p \<ge> 0"
	by (auto simp add: less_eq_real_def ccw_def ccw'_def)
	with c det_identity[of t p q s r]
	have tsr: "coll t s r" and tsp: "coll t s p"
	by (auto simp: add_nonneg_eq_0_iff ccw'_def)
	moreover
	have trp: "coll t r p"
	by (metis ccw'_subst_collinear distinct not_ccw'_eq tsr tsp)
	ultimately have tpr: "coll t p r"
	by (auto simp: det3_def' algebra_simps)
	moreover
	have psi: "psi t p r \<or> psi t r p \<or> psi r p t"
	unfolding psi_def
	proof -
	have ntsr: "\<not> ccw' t s r" "\<not> ccw' t r s"
	using tsr
	by (auto simp: not_ccw'_eq det3_def' algebra_simps)
	have f8: "\<not> ccw' t r s"
	using tsr not_ccw'_eq by blast
	have f9: "\<not> ccw' t r p"
	using tpr by (simp add: not_ccw'_eq)
	have f10: "(lex t r \<and> lex r p \<or> lex r p \<and> lex p t \<or> lex p t \<and> lex t r)"
	using ccw_def ccws(6) psi_def f9 by auto

	have "\<not> ccw' t r q"
	using c(2) not_ccw'_eq by blast
	moreover
	have "\<not>coll t q s"
	using ntsr ccw'_subst_collinear distinct c(2) by blast
	hence "ccw' t s q"
	by (meson ccw_def ccws(2) not_ccw'_eq)
	moreover
	from tsr tsp \<open>coll t r p\<close> have "coll t p s" "coll t p r" "coll t r s"
	by (auto simp add: det3_def' algebra_simps)
	ultimately
	show "lex t p \<and> lex p r \<or> lex t r \<and> lex r p \<or> lex r p \<and> lex p t"
	by (metis ccw'_subst_psi_disj distinct ccw_def ccws(3) contra4 tsp ntsr(1) f10 lex_total
	psi_def trp)
	qed
	moreover
	from distinct have "r \<noteq> t" by auto
	ultimately
	have "ccw' t r q" using c(1)
	by (rule ccw'_subst_psi_disj)
	thus False
	using c(2) by (simp add: ccw'_contra)
	qed

	lemma
	ccw_transitive_contr:
	fixes t s p q r
	assumes ccws: "ccw t s p" "ccw t s q" "ccw t s r" "ccw t p q" "ccw t q r" "ccw t r p"
	assumes distinct: "distinct5 t s p q r"
	shows False
	proof -
	from ccws distinct have *: "ccw p t r" "ccw p q t" by (metis cyclic)+
	with distinct have "ccw r p q" using interior[OF _ _ ccws(5) *, of UNIV]
	by (auto intro: cyclic)

	from ccws have nonnegs: "det3 t s p \<ge> 0" "det3 t s q \<ge> 0" "det3 t s r \<ge> 0" "det3 t p q \<ge> 0"
	"det3 t q r \<ge> 0" "det3 t r p \<ge> 0"
	by (auto simp add: less_eq_real_def ccw_def ccw'_def)
	{
	assume "ccw' t p q" "ccw' t q r" "ccw' t r p"
	hence False
	using ccw_two_up_contra ccws distinct by blast
	} moreover {
	assume c: "coll t q r" "coll t r p"
	with distinct four_points_aligned(1)[OF c, of s]
	have "coll t p q"
	by auto
	hence "(psi t p q \<or> psi p q t \<or> psi q t p)"
	"psi t q r \<or> psi q r t \<or> psi r t q"
	"psi t r p \<or> psi r p t \<or> psi p t r"
	using ccws(4,5,6) c
	by (simp_all add: ccw_def ccw'_def)
	hence False
	using distinct
	by (auto simp: psi_def ccw'_def)
	} moreover {
	assume c: "det3 t p q = 0" "det3 t q r > 0" "det3 t r p = 0"
	have "\<And>x. det3 t q r = 0 \<or> t = x \<or> r = q \<or> q = x \<or> r = p \<or> p = x \<or> r = x"
	by (meson c(1) c(3) distinct four_points_aligned(1))
	hence False
	by (metis (full_types) c(2) distinct less_irrefl)
	} moreover {
	assume c: "det3 t p q = 0" "det3 t q r = 0" "det3 t r p > 0"
	have "\<And>x. det3 t r p = 0 \<or> t = x \<or> r = x \<or> q = x \<or> p = x"
	by (meson c(1) c(2) distinct four_points_aligned(1))
	hence False
	by (metis (no_types) c(3) distinct less_numeral_extra(3))
	} moreover {
	assume c: "ccw' t p q" "ccw' t q r"
	from ccw_two_up_contra[OF this ccws distinct]
	have False .
	} moreover {
	assume c: "ccw' t p q" "ccw' t r p"
	from ccw_two_up_contra[OF this(2,1), of s] ccws distinct
	have False by auto
	} moreover {
	assume c: "ccw' t q r" "ccw' t r p"
	from ccw_two_up_contra[OF this, of s] ccws distinct
	have False by auto
	} ultimately show "False"
	using \<open>0 \<le> det3 t p q\<close>
	\<open>0 \<le> det3 t q r\<close>\<open>0 \<le> det3 t r p\<close>
	by (auto simp: less_eq_real_def ccw'_def)
	qed

	interpretation ccw: ccw_system ccw
	by unfold_locales (metis ccw_transitive_contr nondegenerate)

	lemma ccw_scaleR1:
	"det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 (e*\<^sub>Rxr) P"
	by (simp add: ccw_def)

	lemma ccw_scaleR2:
	"det3 0 xr P \<noteq> 0 \<Longrightarrow> 0 < e \<Longrightarrow> ccw 0 xr P \<Longrightarrow> ccw 0 xr (e*\<^sub>RP)"
	by (simp add: ccw_def)

	lemma ccw_translate3_aux:
	assumes "\<not>coll 0 a b"
	assumes "x < 1"
	assumes "ccw 0 (a - x\<^sub>Ra) (b - x \<^sub>R a)"
	shows "ccw 0 a b"
	proof -
	from assms have "\<not> coll 0 (a - x\<^sub>Ra) (b - x \<^sub>R a)"
	by simp
	with assms have "ccw' 0 ((1 - x) \<^sub>R a) (b - x \<^sub>R a)"
	by (simp add: algebra_simps ccw_def)
	thus "ccw 0 a b"
	using \<open>x < 1\<close>
	by (simp add: ccw_def)
	qed

	lemma ccw_translate3_minus: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a (b - x *\<^sub>R a) \<Longrightarrow> ccw 0 a b"
	using ccw_translate3_aux[of a b x] ccw_scaleR1[of a "b - x *\<^sub>R a" "1-x" ]
	by (auto simp add: algebra_simps)

	lemma ccw_translate3: "det3 0 a b \<noteq> 0 \<Longrightarrow> x < 1 \<Longrightarrow> ccw 0 a b \<Longrightarrow> ccw 0 a (x *\<^sub>R a + b)"
	by (rule ccw_translate3_minus) (auto simp add: algebra_simps)

	lemma ccw_switch23: "det3 0 P Q \<noteq> 0 \<Longrightarrow> (\<not> ccw 0 Q P \<longleftrightarrow> ccw 0 P Q)"
	by (auto simp: ccw_def algebra_simps not_ccw'_eq ccw'_not_coll)

	lemma ccw0_upward: "fst a > 0 \<Longrightarrow> snd a = 0 \<Longrightarrow> snd b > snd a \<Longrightarrow> ccw 0 a b"
	by (auto simp: ccw_def det3_def' algebra_simps ccw'_def)

	lemma ccw_uminus3[simp]: "det3 a b c \<noteq> 0 \<Longrightarrow> ccw (-a) (-b) (-c) = ccw a b c"
	by (auto simp: ccw_def ccw'_def algebra_simps det3_def')

	lemma coll_minus_eq: "coll (x - a) (x - b) (x - c) = coll a b c"
	by (auto simp: det3_def' algebra_simps)

	lemma ccw_minus3: "\<not> coll a b c \<Longrightarrow> ccw (x - a) (x - b) (x - c) \<longleftrightarrow> ccw a b c"
	by (simp add: ccw_def coll_minus_eq)

	lemma ccw0_uminus[simp]: "\<not> coll 0 a b \<Longrightarrow> ccw 0 (-a) (-b) \<longleftrightarrow> ccw 0 a b"
	using ccw_uminus3[of 0 a b]
	by simp

	lemma lex_convex2:
	assumes "lex p q" "lex p r" "0 \<le> u" "u \<le> 1"
	shows "lex p (u \<^sub>R q + (1 - u) \<^sub>R r)"
	proof cases
	note \<open>lex p q\<close>
	also
	assume "lex q r"
	hence "lex q (u \<^sub>R q + (1 - u) \<^sub>R r)"
	using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
	by (rule lex_convex_self2)
	finally (lex_trans) show ?thesis .
	next
	note \<open>lex p r\<close>
	also
	assume "\<not> lex q r"
	hence "lex r q"
	by simp
	hence "lex r ((1 - u) \<^sub>R r + (1 - (1 - u)) \<^sub>R q)"
	using \<open>0 \<le> u\<close> \<open>u \<le> 1\<close>
	by (intro lex_convex_self2) simp_all
	finally (lex_trans) show ?thesis by (simp add: ac_simps)
	qed

	lemma lex_convex2':
	assumes "lex q p" "lex r p" "0 \<le> u" "u \<le> 1"
	shows "lex (u \<^sub>R q + (1 - u) \<^sub>R r) p"
	proof -
	have "lex (- p) (u \<^sub>R (-q) + (1 - u) \<^sub>R (-r))"
	using assms
	by (intro lex_convex2) (auto simp: lex_def)
	thus ?thesis
	by (auto simp: lex_def algebra_simps)
	qed

	lemma psi_convex1:
	assumes "psi c a b"
	assumes "psi d a b"
	assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
	shows "psi (u \<^sub>R c + v \<^sub>R d) a b"
	proof -
	from assms have v: "v = (1 - u)" by simp
	show ?thesis
	using assms
	by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
	qed

	lemma psi_convex2:
	assumes "psi a c b"
	assumes "psi a d b"
	assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
	shows "psi a (u \<^sub>R c + v \<^sub>R d) b"
	proof -
	from assms have v: "v = (1 - u)" by simp
	show ?thesis
	using assms
	by (auto simp: psi_def v intro!: lex_convex2' lex_convex2)
	qed

	lemma psi_convex3:
	assumes "psi a b c"
	assumes "psi a b d"
	assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
	shows "psi a b (u \<^sub>R c + v \<^sub>R d)"
	proof -
	from assms have v: "v = (1 - u)" by simp
	show ?thesis
	using assms
	by (auto simp: psi_def v intro!: lex_convex2)
	qed

	lemma coll_convex:
	assumes "coll a b c" "coll a b d"
	assumes "0 \<le> u" "0 \<le> v" "u + v = 1"
	shows "coll a b (u \<^sub>R c + v \<^sub>R d)"
	proof cases
	assume "a \<noteq> b"
	with assms(1, 2)
	obtain x y where xy: "c - a = x \<^sub>R (b - a)" "d - a = y \<^sub>R (b - a)"
	by (auto simp: det3_translate_origin dest!: coll_scale)
	from assms have "(u + v) *\<^sub>R a = a" by simp
	hence "u \<^sub>R c + v \<^sub>R d - a = u \<^sub>R (c - a) + v \<^sub>R (d - a)"
	by (simp add: algebra_simps)
	also have "\<dots> = u \<^sub>R x \<^sub>R (b - a) + v \<^sub>R y \<^sub>R (b - a)"
	by (simp add: xy)
	also have "\<dots> = (u * x + v * y) *\<^sub>R (b - a)" by (simp add: algebra_simps)
	also have "coll 0 (b - a) \<dots>"
	by (simp add: coll_scaleR_right_eq)
	finally show ?thesis
	by (auto simp: det3_translate_origin)
	qed simp

	lemma (in ccw_vector_space) convex3:
	assumes "u \<ge> 0" "v \<ge> 0" "u + v = 1" "ccw a b d" "ccw a b c"
	shows "ccw a b (u \<^sub>R c + v \<^sub>R d)"
	proof -
	have "v = 1 - u" using assms by simp
	hence "ccw 0 (b - a) (u \<^sub>R (c - a) + v \<^sub>R (d - a))"
	using assms
	by (cases "u = 0" "v = 0" rule: bool.exhaust[case_product bool.exhaust])
	(auto simp add: translate_origin intro!: add3)
	also
	have "(u + v) *\<^sub>R a = a" by (simp add: assms)
	hence "u \<^sub>R (c - a) + v \<^sub>R (d - a) = u \<^sub>R c + v \<^sub>R d - a"
	by (auto simp: algebra_simps)
	finally show ?thesis by (simp add: translate_origin)
	qed

	lemma ccw_self[simp]: "ccw a a b" "ccw b a a"
	by (auto simp: ccw_def psi_def intro: cyclic)

	lemma ccw_sefl'[simp]: "ccw a b a"
	by (rule cyclic) simp

	lemma ccw_convex':
	assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
	assumes "ccw a b c" and 1: "coll a b c"
	assumes "ccw a b d" and 2: "\<not> coll a b d"
	shows "ccw a b (u \<^sub>R c + v \<^sub>R d)"
	proof -
	from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
	by (auto simp: algebra_simps)
	let ?c = "u \<^sub>R c + v \<^sub>R d"
	from 1 have abd: "ccw' a b d"
	using assms by (auto simp: ccw_def)
	{
	assume 2: "\<not> coll a b c"
	from 2 have "ccw' a b c"
	using assms by (auto simp: ccw_def)
	with abd have "ccw' a b ?c"
	using assms by (auto intro!: ccw'.convex3)
	hence ?thesis
	by (simp add: ccw_def)
	} moreover {
	assume 2: "coll a b c"
	{
	assume "a = b"
	hence ?thesis by simp
	} moreover {
	assume "v = 0"
	hence ?thesis
	by (auto simp: v assms)
	} moreover {
	assume "v \<noteq> 0" "a \<noteq> b"
	have "coll c a b" using 2 by (auto simp: det3_def' algebra_simps)
	from coll_ex_scaling[OF \<open>a \<noteq> b\<close> this]
	obtain r where c: "c = a + r *\<^sub>R (b - a)" by auto
	have : "u \<^sub>R (a + r \<^sub>R (b - a)) + v \<^sub>R d - a = (u * r) \<^sub>R (b - a) + (1 - u) \<^sub>R (d - a)"
	by (auto simp: algebra_simps v)
	have "ccw' a b ?c"
	using \<open>v \<noteq> 0\<close> uv abd
	by (simp add: ccw'.translate_origin c *)
	hence ?thesis by (simp add: ccw_def)
	} ultimately have ?thesis by blast
	} ultimately show ?thesis by blast
	qed

	lemma ccw_convex:
	assumes uv: "u \<ge> 0" "v \<ge> 0" "u + v = 1"
	assumes "ccw a b c"
	assumes "ccw a b d"
	assumes lex: "coll a b c \<Longrightarrow> coll a b d \<Longrightarrow> lex b a"
	shows "ccw a b (u \<^sub>R c + v \<^sub>R d)"
	proof -
	from assms have u: "0 \<le> u" "u \<le> 1" and v: "v = 1 - u"
	by (auto simp: algebra_simps)
	let ?c = "u \<^sub>R c + v \<^sub>R d"
	{
	assume coll: "coll a b c \<and> coll a b d"
	hence "coll a b ?c"
	by (auto intro!: coll_convex assms)
	moreover
	from coll have "psi a b c \<or> psi b c a \<or> psi c a b" "psi a b d \<or> psi b d a \<or> psi d a b"
	using assms by (auto simp add: ccw_def ccw'_not_coll)
	hence "psi a b ?c \<or> psi b ?c a \<or> psi ?c a b"
	using coll uv lex
	by (auto simp: psi_def ccw_def not_lex lexs_def v intro: lex_convex2 lex_convex2')
	ultimately have ?thesis
	by (simp add: ccw_def)
	} moreover {
	assume 1: "\<not> coll a b d" and 2: "\<not> coll a b c"
	from 1 have abd: "ccw' a b d"
	using assms by (auto simp: ccw_def)
	from 2 have "ccw' a b c"
	using assms by (auto simp: ccw_def)
	with abd have "ccw' a b ?c"
	using assms by (auto intro!: ccw'.convex3)
	hence ?thesis
	by (simp add: ccw_def)
	} moreover {
	assume "\<not> coll a b d" "coll a b c"
	have ?thesis
	by (rule ccw_convex') fact+
	} moreover {
	assume 1: "coll a b d" and 2: "\<not> coll a b c"
	have "0 \<le> 1 - u" using assms by (auto )
	from ccw_convex'[OF this \<open>0 \<le> u\<close> _ \<open>ccw a b d\<close> 1 \<open>ccw a b c\<close> 2]
	have ?thesis by (simp add: algebra_simps v)
	} ultimately show ?thesis by blast
	qed

	interpretation ccw: ccw_convex ccw S "\<lambda>a b. lex b a" for S
	by unfold_locales (rule ccw_convex)

	lemma ccw_sorted_scaleR: "ccw.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw.sortedP 0 (map ((*\<^sub>R) r) xs)"
	by (induct xs)
	(auto intro!: ccw.sortedP.Cons ccw_scale23 elim!: ccw.sortedP_Cons simp del: scaleR_Pair)

	lemma ccw_sorted_implies_ccw'_sortedP:
	assumes nonaligned: "\<And>y z. y \<in> set Ps \<Longrightarrow> z \<in> set Ps \<Longrightarrow> y \<noteq> z \<Longrightarrow> \<not> coll 0 y z"
	assumes sorted: "linorder_list0.sortedP (ccw 0) Ps"
	assumes "distinct Ps"
	shows "linorder_list0.sortedP (ccw' 0 ) Ps"
	using assms
	proof (induction Ps)
	case (Cons P Ps)
	{
	fix p assume p: "p \<in> set Ps"
	moreover
	from p Cons.prems have "ccw 0 P p"
	by (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
	ultimately
	have "ccw' 0 P p"
	using \<open>distinct (P#Ps)\<close>
	by (intro ccw_ncoll_imp_ccw Cons) auto
	}
	moreover
	have "linorder_list0.sortedP (ccw' 0) Ps"
	using Cons.prems
	by (intro Cons) (auto elim!: linorder_list0.sortedP_Cons intro: Cons)
	ultimately
	show ?case
	by (auto intro!: linorder_list0.Cons )
	qed (auto intro: linorder_list0.Nil)

	end
	diff --git a/thys/Affine_Arithmetic/Counterclockwise_2D_Strict.thy b/thys/Affine_Arithmetic/Counterclockwise_2D_Strict.thy
	--- a/thys/Affine_Arithmetic/Counterclockwise_2D_Strict.thy
	+++ b/thys/Affine_Arithmetic/Counterclockwise_2D_Strict.thy
	@@ -1,519 +1,519 @@
	section \<open>CCW for Nonaligned Points in the Plane\<close>
	theory Counterclockwise_2D_Strict
	imports
	Counterclockwise_Vector
	Affine_Arithmetic_Auxiliarities
	begin
	text \<open>\label{sec:counterclockwise2d}\<close>

	subsection \<open>Determinant\<close>

	type_synonym point = "real*real"

	fun det3::"point \<Rightarrow> point \<Rightarrow> point \<Rightarrow> real" where "det3 (xp, yp) (xq, yq) (xr, yr) =
	xp * yq + yp * xr + xq * yr - yq * xr - yp * xq - xp * yr"

	lemma det3_def':
	"det3 p q r = fst p * snd q + snd p * fst r + fst q * snd r -
	snd q * fst r - snd p * fst q - fst p * snd r"
	by (cases p q r rule: prod.exhaust[case_product prod.exhaust[case_product prod.exhaust]]) auto

	lemma det3_eq_det: "det3 (xa, ya) (xb, yb) (xc, yc) =
	det (vector [vector [xa, ya, 1], vector [xb, yb, 1], vector [xc, yc, 1]]::real^3^3)"
	unfolding Determinants.det_def UNIV_3
	by (auto simp: sum_over_permutations_insert
	vector_3 sign_swap_id permutation_swap_id sign_compose)

	declare det3.simps[simp del]

	lemma det3_self23[simp]: "det3 a b b = 0"
	and det3_self12[simp]: "det3 b b a = 0"
	by (auto simp: det3_def')

	lemma
	coll_ex_scaling:
	assumes "b \<noteq> c"
	assumes d: "det3 a b c = 0"
	shows "\<exists>r. a = b + r *\<^sub>R (c - b)"
	proof -
	from assms have "fst b \<noteq> fst c \<or> snd b \<noteq> snd c" by (auto simp: prod_eq_iff)
	thus ?thesis
	proof
	assume neq: "fst b \<noteq> fst c"
	with d have "snd a = ((fst a - fst b) * snd c + (fst c - fst a) * snd b) / (fst c - fst b)"
	by (auto simp: det3_def' field_simps)
	hence "snd a = ((fst a - fst b)/ (fst c - fst b)) * snd c +
	((fst c - fst a)/ (fst c - fst b)) * snd b"
	by (simp add: add_divide_distrib)
	hence "snd a = snd b + (fst a - fst b) * snd c / (fst c - fst b) +
	((fst c - fst a) - (fst c - fst b)) * snd b / (fst c - fst b)"
	using neq
	by (simp add: field_simps)
	hence "snd a = snd b + ((fst a - fst b) * snd c + (- fst a + fst b) * snd b) / (fst c - fst b)"
	unfolding add_divide_distrib
	by (simp add: algebra_simps)
	also
	have "(fst a - fst b) * snd c + (- fst a + fst b) * snd b = (fst a - fst b) * (snd c - snd b)"
	by (simp add: algebra_simps)
	finally have "snd a = snd b + (fst a - fst b) / (fst c - fst b) * (snd c - snd b)"
	by simp
	moreover
	hence "fst a = fst b + (fst a - fst b) / (fst c - fst b) * (fst c - fst b)"
	using neq by simp
	ultimately have "a = b + ((fst a - fst b) / (fst c - fst b)) *\<^sub>R (c - b)"
	by (auto simp: prod_eq_iff)
	thus ?thesis by blast
	next
	assume neq: "snd b \<noteq> snd c"
	with d have "fst a = ((snd a - snd b) * fst c + (snd c - snd a) * fst b) / (snd c - snd b)"
	by (auto simp: det3_def' field_simps)
	hence "fst a = ((snd a - snd b)/ (snd c - snd b)) * fst c +
	((snd c - snd a)/ (snd c - snd b)) * fst b"
	by (simp add: add_divide_distrib)
	hence "fst a = fst b + (snd a - snd b) * fst c / (snd c - snd b) +
	((snd c - snd a) - (snd c - snd b)) * fst b / (snd c - snd b)"
	using neq
	by (simp add: field_simps)
	hence "fst a = fst b + ((snd a - snd b) * fst c + (- snd a + snd b) * fst b) / (snd c - snd b)"
	unfolding add_divide_distrib
	by (simp add: algebra_simps)
	also
	have "(snd a - snd b) * fst c + (- snd a + snd b) * fst b = (snd a - snd b) * (fst c - fst b)"
	by (simp add: algebra_simps)
	finally have "fst a = fst b + (snd a - snd b) / (snd c - snd b) * (fst c - fst b)"
	by simp
	moreover
	hence "snd a = snd b + (snd a - snd b) / (snd c - snd b) * (snd c - snd b)"
	using neq by simp
	ultimately have "a = b + ((snd a - snd b) / (snd c - snd b)) *\<^sub>R (c - b)"
	by (auto simp: prod_eq_iff)
	thus ?thesis by blast
	qed
	qed

	lemma cramer: "\<not>det3 s t q = 0 \<Longrightarrow>
	(det3 t p r) = ((det3 t q r) * (det3 s t p) + (det3 t p q) * (det3 s t r))/(det3 s t q)"
	by (auto simp: det3_def' field_simps)

	lemma convex_comb_dets:
	assumes "det3 p q r > 0"
	shows "s = (det3 s q r / det3 p q r) \<^sub>R p + (det3 p s r / det3 p q r) \<^sub>R q +
	(det3 p q s / det3 p q r) *\<^sub>R r"
	(is "?lhs = ?rhs")
	proof -
	from assms have "det3 p q r \<^sub>R ?lhs = det3 p q r \<^sub>R ?rhs"
	by (simp add: field_simps prod_eq_iff scaleR_add_right) (simp add: algebra_simps det3_def')
	thus ?thesis using assms by simp
	qed

	lemma four_points_aligned:
	assumes c: "det3 t p q = 0" "det3 t q r = 0"
	assumes distinct: "distinct5 t s p q r"
	shows "det3 t r p = 0" "det3 p q r = 0"
	proof -
	from distinct have d: "p \<noteq> q" "q \<noteq> r" by (auto)
	from coll_ex_scaling[OF d(1) c(1)] obtain s1 where s1: "t = p + s1 *\<^sub>R (q - p)" by auto
	from coll_ex_scaling[OF d(2) c(2)] obtain s2 where s2: "t = q + s2 *\<^sub>R (r - q)" by auto
	from distinct s1 have ne: "1 - s1 \<noteq> 0" by auto
	from s1 s2 have "(1 - s1) \<^sub>R p = (1 - s1 - s2) \<^sub>R q + s2 *\<^sub>R r"
	by (simp add: algebra_simps)
	hence "(1 - s1) \<^sub>R p /\<^sub>R (1 - s1)= ((1 - s1 - s2) \<^sub>R q + s2 *\<^sub>R r) /\<^sub>R (1 - s1)"
	by simp
	with ne have p: "p = ((1 - s1 - s2) / (1 - s1)) \<^sub>R q + (s2 / (1 - s1)) \<^sub>R r"
	using ne
	by (simp add: prod_eq_iff inverse_eq_divide add_divide_distrib)
	define k1 where "k1 = (1 - s1 - s2) / (1 - s1)"
	define k2 where "k2 = s2 / (1 - s1)"
	have "det3 t r p = det3 0 (k1 \<^sub>R q + (k2 - 1) \<^sub>R r)
	(k1 \<^sub>R q + (k2 - 1) \<^sub>R r + (- s1 * (k1 - 1)) \<^sub>R q - (s1 k2) *\<^sub>R r)"
	unfolding s1 p k1_def[symmetric] k2_def[symmetric]
	by (simp add: algebra_simps det3_def')
	also have "- s1 * (k1 - 1) = s1 * k2"
	using ne by (auto simp: k1_def field_simps k2_def)
	also
	have "1 - k1 = k2"
	using ne
	by (auto simp: k2_def k1_def field_simps)
	have k21: "k2 - 1 = -k1"
	using ne
	by (auto simp: k2_def k1_def field_simps)
	finally have "det3 t r p = det3 0 (k1 \<^sub>R (q - r)) ((k1 + (s1 k2)) *\<^sub>R (q - r))"
	by (auto simp: algebra_simps)
	also have "\<dots> = 0"
	by (simp add: algebra_simps det3_def')
	finally show "det3 t r p = 0" .
	have "det3 p q r = det3 (k1 \<^sub>R q + k2 \<^sub>R r) q r"
	unfolding p k1_def[symmetric] k2_def[symmetric] ..
	also have "\<dots> = det3 0 (r - q) (k1 \<^sub>R q + (-k1) \<^sub>R r)"
	unfolding k21[symmetric]
	by (auto simp: algebra_simps det3_def')
	also have "\<dots> = det3 0 (r - q) (-k1 *\<^sub>R (r - q))"
	by (auto simp: det3_def' algebra_simps)
	also have "\<dots> = 0"
	by (auto simp: det3_def')
	finally show "det3 p q r = 0" .
	qed

	lemma det_identity:
	"det3 t p q * det3 t s r + det3 t q r * det3 t s p + det3 t r p * det3 t s q = 0"
	by (auto simp: det3_def' algebra_simps)

	lemma det3_eq_zeroI:
	assumes "p = q + x *\<^sub>R (t - q)"
	shows "det3 q t p = 0"
	unfolding assms
	by (auto simp: det3_def' algebra_simps)

	lemma det3_rotate: "det3 a b c = det3 c a b"
	by (auto simp: det3_def')

	lemma det3_switch: "det3 a b c = - det3 a c b"
	by (auto simp: det3_def')

	lemma det3_switch': "det3 a b c = - det3 b a c"
	by (auto simp: det3_def')

	lemma det3_pos_transitive_coll:
	"det3 t s p > 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
	det3 t q r > 0 \<Longrightarrow> det3 t s q = 0 \<Longrightarrow> det3 t p r > 0"
	using det_identity[of t p q s r]
	by (metis add.commute add_less_same_cancel1 det3_switch det3_switch' less_eq_real_def
	less_not_sym monoid_add_class.add.left_neutral mult_pos_pos mult_zero_left mult_zero_right)

	lemma det3_pos_transitive:
	"det3 t s p > 0 \<Longrightarrow> det3 t s q \<ge> 0 \<Longrightarrow> det3 t s r \<ge> 0 \<Longrightarrow> det3 t p q \<ge> 0 \<Longrightarrow>
	det3 t q r > 0 \<Longrightarrow> det3 t p r > 0"
	apply (cases "det3 t s q \<noteq> 0")
	using cramer[of q t s p r]
	apply (force simp: det3_rotate[of q t p] det3_rotate[of p q t] det3_switch[of t p s]
	det3_switch'[of q t r] det3_rotate[of q t s] det3_rotate[of s q t]
	intro!: divide_pos_pos add_nonneg_pos)
	apply (metis det3_pos_transitive_coll)
	done

	lemma det3_zero_translate_plus[simp]: "det3 (a + x) (b + x) (c + x) = 0 \<longleftrightarrow> det3 a b c = 0"
	by (auto simp: algebra_simps det3_def')

	lemma det3_zero_translate_plus'[simp]: "det3 (a) (a + b) (a + c) = 0 \<longleftrightarrow> det3 0 b c = 0"
	by (auto simp: algebra_simps det3_def')

	lemma
	det30_zero_scaleR1:
	"0 < e \<Longrightarrow> det3 0 xr P = 0 \<Longrightarrow> det3 0 (e *\<^sub>R xr) P = 0"
	by (auto simp: zero_prod_def algebra_simps det3_def')

	lemma det3_same[simp]: "det3 a x x = 0"
	by (auto simp: det3_def')

	lemma
	det30_zero_scaleR2:
	"0 < e \<Longrightarrow> det3 0 P xr = 0 \<Longrightarrow> det3 0 P (e *\<^sub>R xr) = 0"
	by (auto simp: zero_prod_def algebra_simps det3_def')

	lemma det3_eq_zero: "e \<noteq> 0 \<Longrightarrow> det3 0 xr (e *\<^sub>R Q) = 0 \<longleftrightarrow> det3 0 xr Q = 0"
	by (auto simp: det3_def')

	lemma det30_plus_scaled3[simp]: "det3 0 a (b + x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
	by (auto simp: det3_def' algebra_simps)

	lemma det30_plus_scaled2[simp]:
	shows "det3 0 (a + x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = -1 then True else det3 0 a b = 0)"
	(is "?lhs = ?rhs")
	proof
	assume "det3 0 (a + x *\<^sub>R a) b = 0"
	hence "fst a * snd b * (1 + x) = fst b * snd a * (1 + x)"
	by (simp add: algebra_simps det3_def')
	thus ?rhs
	by (auto simp add: det3_def')
	qed (auto simp: det3_def' algebra_simps split: if_split_asm)

	lemma det30_uminus2[simp]: "det3 0 (-a) (b) = 0 \<longleftrightarrow> det3 0 a b = 0"
	and det30_uminus3[simp]: "det3 0 a (-b) = 0 \<longleftrightarrow> det3 0 a b = 0"
	by (auto simp: det3_def' algebra_simps)

	lemma det30_minus_scaled3[simp]: "det3 0 a (b - x *\<^sub>R a) = 0 \<longleftrightarrow> det3 0 a b = 0"
	using det30_plus_scaled3[of a b "-x"] by simp

	lemma det30_scaled_minus3[simp]: "det3 0 a (e *\<^sub>R a - b) = 0 \<longleftrightarrow> det3 0 a b = 0"
	using det30_plus_scaled3[of a "-b" e]
	by (simp add: algebra_simps)

	lemma det30_minus_scaled2[simp]:
	"det3 0 (a - x *\<^sub>R a) b = 0 \<longleftrightarrow> (if x = 1 then True else det3 0 a b = 0)"
	using det30_plus_scaled2[of a "-x" b] by simp

	lemma det3_nonneg_scaleR1:
	"0 < e \<Longrightarrow> det3 0 xr P \<ge> 0 \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0"
	by (auto simp add: det3_def' algebra_simps)

	lemma det3_nonneg_scaleR1_eq:
	"0 < e \<Longrightarrow> det3 0 (e*\<^sub>Rxr) P \<ge> 0 \<longleftrightarrow> det3 0 xr P \<ge> 0"
	by (auto simp add: det3_def' algebra_simps)

	lemma det3_translate_origin: "NO_MATCH 0 p \<Longrightarrow> det3 p q r = det3 0 (q - p) (r - p)"
	by (auto simp: det3_def' algebra_simps)

	lemma det3_nonneg_scaleR_segment2:
	assumes "det3 x y z \<ge> 0"
	assumes "a > 0"
	shows "det3 x ((1 - a) \<^sub>R x + a \<^sub>R y) z \<ge> 0"
	proof -
	from assms have "0 \<le> det3 0 (a *\<^sub>R (y - x)) (z - x)"
	by (intro det3_nonneg_scaleR1) (simp_all add: det3_translate_origin)
	thus ?thesis
	by (simp add: algebra_simps det3_translate_origin)
	qed

	lemma det3_nonneg_scaleR_segment1:
	assumes "det3 x y z \<ge> 0"
	assumes "0 \<le> a" "a < 1"
	shows "det3 ((1 - a) \<^sub>R x + a \<^sub>R y) y z \<ge> 0"
	proof -
	from assms have "det3 0 ((1 - a) \<^sub>R (y - x)) (z - x + (- a) \<^sub>R (y - x)) \<ge> 0"
	by (subst det3_nonneg_scaleR1_eq) (auto simp add: det3_def' algebra_simps)
	thus ?thesis
	by (auto simp: algebra_simps det3_translate_origin)
	qed


	subsection \<open>Strict CCW Predicate\<close>

	definition "ccw' p q r \<longleftrightarrow> 0 < det3 p q r"

	interpretation ccw': ccw_vector_space ccw'
	by unfold_locales (auto simp: ccw'_def det3_def' algebra_simps)

	interpretation ccw': linorder_list0 "ccw' x" for x .

	lemma ccw'_contra: "ccw' t r q \<Longrightarrow> ccw' t q r = False"
	by (auto simp: ccw'_def det3_def' algebra_simps)

	lemma not_ccw'_eq: "\<not> ccw' t p s \<longleftrightarrow> ccw' t s p \<or> det3 t s p = 0"
	by (auto simp: ccw'_def det3_def' algebra_simps)

	lemma neq_left_right_of: "ccw' a b c \<Longrightarrow> ccw' a c d \<Longrightarrow> b \<noteq> d"
	by (auto simp: ccw'_def det3_def' algebra_simps)

	lemma ccw'_subst_collinear:
	assumes "det3 t r s = 0"
	assumes "s \<noteq> t"
	assumes "ccw' t r p"
	shows "ccw' t s p \<or> ccw' t p s"
	proof cases
	assume "r \<noteq> s"
	from assms have "det3 r s t = 0"
	by (auto simp: algebra_simps det3_def')
	from coll_ex_scaling[OF assms(2) this]
	obtain x where s: "r = s + x *\<^sub>R (t - s)" by auto
	from assms(3)[simplified ccw'_def s]
	have "0 < det3 0 (s + x *\<^sub>R (t - s) - t) (p - t)"
	by (auto simp: algebra_simps det3_def')
	also have "s + x \<^sub>R (t - s) - t = (1 - x) \<^sub>R (s - t)"
	by (simp add: algebra_simps)
	finally have ccw': "ccw' 0 ((1 - x) *\<^sub>R (s - t)) (p - t)"
	by (simp add: ccw'_def)
	hence "x \<noteq> 1" by (auto simp add: det3_def' ccw'_def)
	{
	assume "x < 1"
	hence ?thesis using ccw'
	by (auto simp: not_ccw'_eq ccw'.translate_origin)
	} moreover {
	assume "x > 1"
	hence ?thesis using ccw'
	by (auto simp: not_ccw'_eq ccw'.translate_origin)
	} ultimately show ?thesis using \<open>x \<noteq> 1\<close> by arith
	qed (insert assms, simp)

	lemma ccw'_sorted_scaleR: "ccw'.sortedP 0 xs \<Longrightarrow> r > 0 \<Longrightarrow> ccw'.sortedP 0 (map ((*\<^sub>R) r) xs)"
	by (induct xs) (auto intro!: ccw'.sortedP.Cons elim!: ccw'.sortedP_Cons simp del: scaleR_Pair)


	subsection \<open>Collinearity\<close>

	abbreviation "coll a b c \<equiv> det3 a b c = 0"

	lemma coll_zero[intro, simp]: "coll 0 z 0"
	by (auto simp: det3_def')

	lemma coll_zero1[intro, simp]: "coll 0 0 z"
	by (auto simp: det3_def')

	lemma coll_self[intro, simp]: "coll 0 z z"
	- by (auto simp: )
	+ by auto

	lemma ccw'_not_coll:
	"ccw' a b c \<Longrightarrow> \<not>coll a b c"
	"ccw' a b c \<Longrightarrow> \<not>coll a c b"
	"ccw' a b c \<Longrightarrow> \<not>coll b a c"
	"ccw' a b c \<Longrightarrow> \<not>coll b c a"
	"ccw' a b c \<Longrightarrow> \<not>coll c a b"
	"ccw' a b c \<Longrightarrow> \<not>coll c b a"
	by (auto simp: det3_def' ccw'_def algebra_simps)

	lemma coll_add: "coll 0 x y \<Longrightarrow> coll 0 x z \<Longrightarrow> coll 0 x (y + z)"
	by (auto simp: det3_def' algebra_simps)

	lemma coll_scaleR_left_eq[simp]: "coll 0 (r *\<^sub>R x) y \<longleftrightarrow> r = 0 \<or> coll 0 x y"
	by (auto simp: det3_def' algebra_simps)

	lemma coll_scaleR_right_eq[simp]: "coll 0 y (r *\<^sub>R x) \<longleftrightarrow> r = 0 \<or> coll 0 y x"
	by (auto simp: det3_def' algebra_simps)

	lemma coll_scaleR: "coll 0 x y \<Longrightarrow> coll 0 (r *\<^sub>R x) y"
	by (auto simp: det3_def' algebra_simps)

	lemma coll_sum_list: "(\<And>y. y \<in> set ys \<Longrightarrow> coll 0 x y) \<Longrightarrow> coll 0 x (sum_list ys)"
	by (induct ys) (auto intro!: coll_add)

	lemma scaleR_left_normalize:
	fixes a ::real and b c::"'a::real_vector"
	shows "a *\<^sub>R b = c \<longleftrightarrow> (if a = 0 then c = 0 else b = c /\<^sub>R a)"
	by (auto simp: field_simps)

	lemma coll_scale_pair: "coll 0 (a, b) (c, d) \<Longrightarrow> (a, b) \<noteq> 0 \<Longrightarrow> (\<exists>x. (c, d) = x *\<^sub>R (a, b))"
	by (auto intro: exI[where x="c/a"] exI[where x="d/b"] simp: det3_def' field_simps prod_eq_iff)

	lemma coll_scale: "coll 0 r q \<Longrightarrow> r \<noteq> 0 \<Longrightarrow> (\<exists>x. q = x *\<^sub>R r)"
	using coll_scale_pair[of "fst r" "snd r" "fst q" "snd q"]
	by simp

	lemma coll_add_trans:
	assumes "coll 0 x (y + z)"
	assumes "coll 0 y z"
	assumes "x \<noteq> 0"
	assumes "y \<noteq> 0"
	assumes "z \<noteq> 0"
	assumes "y + z \<noteq> 0"
	shows "coll 0 x z"
	proof (cases "snd z = 0")
	case True
	hence "snd y = 0"
	using assms
	by (cases z) (auto simp add: zero_prod_def det3_def')
	with True assms have "snd x = 0"
	by (cases y, cases z) (auto simp add: zero_prod_def det3_def')
	from \<open>snd x = 0\<close> \<open>snd y = 0\<close> \<open>snd z = 0\<close>
	show ?thesis
	by (auto simp add: zero_prod_def det3_def')
	next
	case False
	note z = False
	hence "snd y \<noteq> 0"
	using assms
	by (cases y) (auto simp add: zero_prod_def det3_def')
	with False assms have "snd x \<noteq> 0"
	apply (cases x)
	apply (cases y)
	apply (cases z)
	apply (auto simp add: zero_prod_def det3_def')
	apply (metis mult.commute mult_eq_0_iff ring_class.ring_distribs(1))
	done
	with False assms \<open>snd y \<noteq> 0\<close> have yz: "snd (y + z) \<noteq> 0"
	by (cases x; cases y; cases z) (auto simp add: det3_def' zero_prod_def)
	from coll_scale[OF assms(1) assms(3)] coll_scale[OF assms(2) assms(4)]
	obtain r s where rs: "y + z = r \<^sub>R x" "z = s \<^sub>R y"
	by auto
	with z have "s \<noteq> 0"
	by (cases x; cases y; cases z) (auto simp: zero_prod_def)
	with rs z yz have "r \<noteq> 0"
	by (cases x; cases y; cases z) (auto simp: zero_prod_def)
	from \<open>s \<noteq> 0\<close> rs have "y = r *\<^sub>R x - z" "y = z /\<^sub>R s"
	by (auto simp: inverse_eq_divide algebra_simps)
	hence "r *\<^sub>R x - z = z /\<^sub>R s" by simp
	hence "r \<^sub>R x = (1 + inverse s) \<^sub>R z"
	by (auto simp: inverse_eq_divide algebra_simps)
	hence "x = (inverse r * (1 + inverse s)) *\<^sub>R z"
	using \<open>r \<noteq> 0\<close> \<open>s \<noteq> 0\<close>
	by (auto simp: field_simps scaleR_left_normalize)
	from this
	show ?thesis
	by (auto intro: coll_scaleR)
	qed

	lemma coll_commute: "coll 0 a b \<longleftrightarrow> coll 0 b a"
	by (metis det3_rotate det3_switch' diff_0 diff_self)

	lemma coll_add_cancel: "coll 0 a (a + b) \<Longrightarrow> coll 0 a b"
	by (cases a, cases b) (auto simp: det3_def' algebra_simps)

	lemma coll_trans:
	"coll 0 a b \<Longrightarrow> coll 0 a c \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 b c"
	by (metis coll_scale coll_scaleR)

	lemma sum_list_posI:
	fixes xs::"'a::ordered_comm_monoid_add list"
	shows "(\<And>x. x \<in> set xs \<Longrightarrow> x > 0) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> sum_list xs > 0"
	proof (induct xs)
	case (Cons x xs)
	thus ?case
	by (cases "xs = []") (auto intro!: add_pos_pos)
	qed simp

	lemma nonzero_fstI[intro, simp]: "fst x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
	and nonzero_sndI[intro, simp]: "snd x \<noteq> 0 \<Longrightarrow> x \<noteq> 0"
	by auto

	lemma coll_sum_list_trans:
	"xs \<noteq> [] \<Longrightarrow> coll 0 a (sum_list xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y) \<Longrightarrow>
	(\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x (sum_list xs)) \<Longrightarrow>
	(\<And>x. x \<in> set xs \<Longrightarrow> snd x > 0) \<Longrightarrow> a \<noteq> 0 \<Longrightarrow> coll 0 a y"
	proof (induct xs rule: list_nonempty_induct)
	case (single x)
	from single(1) single(2)[of x] single(4)[of x] have "coll 0 x a" "coll 0 x y" "x \<noteq> 0"
	by (auto simp: coll_commute)
	thus ?case by (rule coll_trans)
	next
	case (cons x xs)
	from cons(5)[of x] \<open>a \<noteq> 0\<close> cons(6)[of x]
	have *: "coll 0 x (sum_list xs)" "a \<noteq> 0" "x \<noteq> 0" by (force simp add: coll_add_cancel)+
	have "0 < snd (sum_list (x#xs))"
	unfolding snd_sum_list
	by (rule sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
	hence "x + sum_list xs \<noteq> 0" by simp
	from coll_add_trans[OF cons(3)[simplified] * _ this]
	have cH: "coll 0 a (sum_list xs)"
	by (cases "sum_list xs = 0") auto
	from cons(4) have cy: "(\<And>x. x \<in> set xs \<Longrightarrow> coll 0 x y)" by simp
	{
	fix y assume "y \<in> set xs"
	hence "snd (sum_list xs) > 0"
	unfolding snd_sum_list
	by (intro sum_list_posI) (auto intro!: add_pos_pos cons simp: snd_sum_list)
	hence "sum_list xs \<noteq> 0" by simp
	from cons(5)[of x] have "coll 0 x (sum_list xs)"
	by (simp add: coll_add_cancel)
	from cons(5)[of y]
	have "coll 0 y (sum_list xs)"
	using \<open>y \<in> set xs\<close> cons(6)[of y] \<open>x + sum_list xs \<noteq> 0\<close>
	apply (cases "y = x")
	subgoal by (force simp add: coll_add_cancel)
	subgoal by (force simp: dest!: coll_add_trans[OF _ (1) _ (3)])
	done
	} note cl = this
	show ?case
	by (rule cons(2)[OF cH cy cl cons(6) \<open>a \<noteq> 0\<close>]) auto
	qed

	lemma sum_list_coll_ex_scale:
	assumes coll: "\<And>x. x \<in> set xs \<Longrightarrow> coll 0 z x"
	assumes nz: "z \<noteq> 0"
	shows "\<exists>r. sum_list xs = r *\<^sub>R z"
	proof -
	{
	fix i assume i: "i < length xs"
	hence nth: "xs ! i \<in> set xs" by simp
	note coll_scale[OF coll[OF nth] \<open>z \<noteq> 0\<close>]
	} then obtain r where r: "\<And>i. i < length xs \<Longrightarrow> r i *\<^sub>R z = xs ! i"
	by metis
	have "xs = map ((!) xs) [0..<length xs]" by (simp add: map_nth)
	also have "\<dots> = map (\<lambda>i. r i *\<^sub>R z) [0..<length xs]"
	by (auto simp: r)
	also have "sum_list \<dots> = (\<Sum>i\<leftarrow>[0..<length xs]. r i) *\<^sub>R z"
	by (simp add: sum_list_sum_nth scaleR_sum_left)
	finally show ?thesis ..
	qed

	lemma sum_list_filter_coll_ex_scale: "z \<noteq> 0 \<Longrightarrow> \<exists>r. sum_list (filter (coll 0 z) zs) = r *\<^sub>R z"
	by (rule sum_list_coll_ex_scale) simp

	end
	diff --git a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
	--- a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
	+++ b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
	@@ -1,1078 +1,1078 @@
	section \<open>Euclidean Space: Executability\<close>
	theory Executable_Euclidean_Space
	imports
	"HOL-Analysis.Multivariate_Analysis"
	"List-Index.List_Index"
	"HOL-Library.Float"
	"HOL-Library.Code_Cardinality"
	Affine_Arithmetic_Auxiliarities
	begin

	subsection \<open>Ordered representation of Basis and Rounding of Components\<close>

	class executable_euclidean_space = ordered_euclidean_space +
	fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
	assumes eucl_down_def:
	"eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
	assumes eucl_truncate_down_def:
	"eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
	assumes eucl_truncate_up_def:
	"eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
	assumes Basis_list[simp]: "set Basis_list = Basis"
	assumes distinct_Basis_list[simp]: "distinct Basis_list"
	begin

	lemma length_Basis_list:
	"length Basis_list = card Basis"
	by (metis Basis_list distinct_Basis_list distinct_card)

	end

	lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
	by (auto simp: eucl_truncate_down_def truncate_down_zero)

	lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
	by (auto simp: eucl_truncate_up_def)

	subsection \<open>Instantiations\<close>

	instantiation real::executable_euclidean_space
	begin

	definition Basis_list_real :: "real list" where
	"Basis_list_real = [1]"

	definition "eucl_down prec b = round_down prec b"
	definition "eucl_truncate_down prec b = truncate_down prec b"
	definition "eucl_truncate_up prec b = truncate_up prec b"

	instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
	eucl_truncate_up_real_def)

	end

	instantiation prod::(executable_euclidean_space, executable_euclidean_space)
	executable_euclidean_space
	begin

	definition Basis_list_prod :: "('a \<times> 'b) list" where
	"Basis_list_prod =
	zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
	zip (replicate (length (Basis_list::'b list)) 0) Basis_list"

	definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
	definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
	definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"

	instance
	proof
	show "set Basis_list = (Basis::('a*'b) set)"
	by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
	(auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
	show "distinct (Basis_list::('a*'b)list)"
	using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
	by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
	elim!: in_set_zipE)
	qed
	(auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
	sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
	eucl_truncate_down_def eucl_truncate_up_def
	intro!: euclidean_eqI[where 'a="'a*'b"])

	end

	lemma eucl_truncate_down_Basis[simp]:
	"i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
	by (simp add: eucl_truncate_down_def)

	lemma eucl_truncate_down_correct:
	"dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in>
	{0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
	proof -
	have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
	unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
	also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr of_int (- e))\<^sup>2))"
	by (intro real_sqrt_le_mono sum_mono power_mono)
	(auto simp: dist_real_def eucl_down_def abs_round_down_le)
	finally show ?thesis
	by (simp add: real_sqrt_mult)
	qed

	lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
	by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)

	lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
	by (auto simp add: eucl_le[where 'a='a] truncate_down)

	lemma eucl_truncate_down_le:
	"x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
	using eucl_truncate_down
	by (rule order.trans)

	lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
	by (simp add: eucl_truncate_up_def truncate_up_def)

	lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
	by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)

	lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
	using _ eucl_truncate_up
	by (rule order.trans)

	lemma eucl_truncate_down_mono:
	fixes x::"'a::executable_euclidean_space"
	shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
	by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)

	lemma eucl_truncate_up_mono:
	fixes x::"'a::executable_euclidean_space"
	shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
	by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)

	lemma infnorm[code]:
	fixes x::"'a::executable_euclidean_space"
	shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
	by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
	intro!: max.absorb2[symmetric])

	declare Inf_real_def[code del]
	declare Sup_real_def[code del]
	declare Inf_prod_def[code del]
	declare Sup_prod_def[code del]
	declare [[code abort: "Inf::real set \<Rightarrow> real"]]
	declare [[code abort: "Sup::real set \<Rightarrow> real"]]
	declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
	declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]

	lemma nth_Basis_list_in_Basis[simp]:
	"n < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> Basis_list ! n \<in> (Basis::'a set)"
	by (metis Basis_list nth_mem)

	subsection \<open>Representation as list\<close>

	lemma nth_eq_iff_index:
	"distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> xs ! n = i \<longleftrightarrow> n = index xs i"
	using index_nth_id by fastforce

	lemma in_Basis_index_Basis_list: "i \<in> Basis \<Longrightarrow> i = Basis_list ! index Basis_list i"
	by simp

	lemmas [simp] = length_Basis_list

	lemma sum_Basis_sum_nth_Basis_list:
	"(\<Sum>i\<in>Basis. f i) = (\<Sum>i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
	apply (rule sum.reindex_cong[OF _ _ refl])
	apply (auto intro!: inj_on_nth)
	by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)

	definition "eucl_of_list xs = (\<Sum>(x, i)\<leftarrow>zip xs Basis_list. x *\<^sub>R i)"

	lemma eucl_of_list_nth:
	assumes "length xs = DIM('a)"
	shows "eucl_of_list xs = (\<Sum>i<DIM('a::executable_euclidean_space). (xs ! i) *\<^sub>R ((Basis_list::'a list) ! i))"
	by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)

	lemma eucl_of_list_inner:
	fixes i::"'a::executable_euclidean_space"
	assumes i: "i \<in> Basis"
	assumes l: "length xs = DIM('a)"
	shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
	by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
	nth_eq_iff_index sum.delta if_distrib cong: if_cong)

	lemma inner_eucl_of_list:
	fixes i::"'a::executable_euclidean_space"
	assumes i: "i \<in> Basis"
	assumes l: "length xs = DIM('a)"
	shows "i \<bullet> eucl_of_list xs = xs ! (index Basis_list i)"
	using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)


	definition "list_of_eucl x = map ((\<bullet>) x) Basis_list"

	lemma index_Basis_list_nth[simp]:
	"i < DIM('a::executable_euclidean_space) \<Longrightarrow> index Basis_list ((Basis_list::'a list) ! i) = i"
	by (simp add: index_nth_id)

	lemma list_of_eucl_eucl_of_list[simp]:
	"length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl (eucl_of_list xs::'a) = xs"
	by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)

	lemma eucl_of_list_list_of_eucl[simp]:
	"eucl_of_list (list_of_eucl x) = x"
	by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])


	lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
	by (auto simp: list_of_eucl_def)

	lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl x ! n = x \<bullet> (Basis_list ! n::'a)"
	by (auto simp: list_of_eucl_def)

	lemma nth_ge_len: "n \<ge> length xs \<Longrightarrow> xs ! n = [] ! (n - length xs)"
	by (induction xs arbitrary: n) auto

	lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x \<bullet> (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
	apply (auto simp: list_of_eucl_def )
	apply (subst nth_ge_len)
	apply auto
	done

	lemma list_of_eucl_eq_iff:
	"list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) \<longleftrightarrow>
	(DIM('a) = DIM('b) \<and> (\<forall>i < DIM('b). x \<bullet> Basis_list ! i = y \<bullet> Basis_list ! i))"
	by (auto simp: list_eq_iff_nth_eq)

	lemma eucl_le_Basis_list_iff:
	"(x::'a::executable_euclidean_space) \<le> y \<longleftrightarrow>
	(\<forall>i<DIM('a). x \<bullet> Basis_list ! i \<le> y \<bullet> Basis_list ! i)"
	apply (auto simp: eucl_le[where 'a='a])
	subgoal for i
	subgoal by (auto dest!: spec[where x="index Basis_list i"])
	done
	done

	lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> length ys = DIM('a) \<Longrightarrow>
	(eucl_of_list xs::'a) = eucl_of_list (ys) \<Longrightarrow> xs = ys"
	apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
	using nth_Basis_list_in_Basis[where 'a="'a"]
	by fastforce

	lemma eucl_of_list_map_plus[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. f x + g x) xs)::'a) =
	eucl_of_list (map f xs) + eucl_of_list (map g xs)"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma eucl_of_list_map_uminus[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. - f x) xs)::'a) = - eucl_of_list (map f xs)"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma eucl_of_list_map_mult_left[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. r * f x) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma eucl_of_list_map_mult_right[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. f x * r) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma eucl_of_list_map_divide_right[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. f x / r) xs)::'a) = eucl_of_list (map f xs) /\<^sub>R r"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)

	lemma eucl_of_list_map_const[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	shows "(eucl_of_list (map (\<lambda>x. c) xs)::'a) = c *\<^sub>R One"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
	by (auto intro!: nth_equalityI)

	lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
	unfolding eucl_of_list_def
	apply (auto simp: sum_list_sum_nth)
	apply (rule sum.mono_neutral_cong_right)
	by (auto simp: nth_append)

	lemma Basis_prodD:
	assumes "(i, j) \<in> Basis"
	shows "i \<in> Basis \<and> j = 0 \<or> i = 0 \<and> j \<in> Basis"
	using assms
	by (auto simp: Basis_prod_def)

	lemma eucl_of_list_take_DIM[simp]:
	assumes "d = DIM('b::executable_euclidean_space)"
	shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
	by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)

	lemma eucl_of_list_eqI:
	assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
	take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
	shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
	proof -
	have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
	- by (simp add: )
	+ by simp
	also note assms
	also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
	by simp
	finally show ?thesis .
	qed

	lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
	proof -
	have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
	by simp
	also have "\<dots> = eucl_of_list (replicate DIM('a) 0)"
	apply (rule eucl_of_list_eqI)
	by (auto simp: min_def nth_append intro!: nth_equalityI)
	also have "\<dots> = 0"
	by (simp add: replicate_eq_list_of_eucl_zero)
	finally show ?thesis by simp
	qed

	lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
	using eucl_of_list_replicate_zero[of 0] by simp


	lemma fst_eucl_of_list_prod:
	shows "fst (eucl_of_list xs::'b::executable_euclidean_space \<times> _) = (eucl_of_list (take DIM('b) xs)::'b)"
	apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
	apply (simp add: sum_list_sum_nth)
	apply (rule sum.mono_neutral_cong_right)
	subgoal by simp
	subgoal by auto
	subgoal by (auto simp: Basis_list_prod_def nth_append)
	subgoal by (auto simp: Basis_list_prod_def nth_append)
	done

	lemma index_zip_replicate1[simp]: "index (zip (replicate d a) bs) (a, b) = index bs b"
	if "d = length bs"
	using that
	by (induction bs arbitrary: d) auto

	lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
	if "d = length as"
	using that
	by (induction as arbitrary: d) auto

	lemma index_Basis_list_prod[simp]:
	fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
	shows "a \<in> Basis \<Longrightarrow> index Basis_list (a, 0::'b) = index Basis_list a"
	"b \<in> Basis \<Longrightarrow> index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
	by (auto simp: Basis_list_prod_def index_append
	in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])

	lemma eucl_of_list_eq_takeI:
	assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
	shows "eucl_of_list xs = x"
	using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
	by auto

	lemma eucl_of_list_inner_le:
	fixes i::"'a::executable_euclidean_space"
	assumes i: "i \<in> Basis"
	assumes l: "length xs \<ge> DIM('a)"
	shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
	proof -
	have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
	by (rule eucl_of_list_eq_takeI) simp
	also have "\<dots> \<bullet> i = xs ! (index Basis_list i)"
	using assms
	by (subst eucl_of_list_inner) auto
	finally show ?thesis .
	qed

	lemma eucl_of_list_prod_if:
	assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
	shows "eucl_of_list xs =
	(eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
	apply (rule euclidean_eqI)
	using assms
	apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
	apply (subst eucl_of_list_inner_le)
	apply (auto simp: Basis_list_prod_def index_append in_set_zip)
	done


	lemma snd_eucl_of_list_prod:
	shows "snd (eucl_of_list xs::'b::executable_euclidean_space \<times> 'c::executable_euclidean_space) =
	(eucl_of_list (drop DIM('b) xs)::'c)"
	proof (cases "length xs \<le> DIM('b)")
	case True
	then show ?thesis
	by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
	(simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
	next
	case False
	have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
	also have "eucl_of_list \<dots> = (eucl_of_list (\<dots> @ replicate (length xs - DIM('c)) 0)::'b \<times> 'c)"
	by simp
	finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b \<times> 'c)"
	by simp
	also have "\<dots> = eucl_of_list (take (DIM ('b \<times> 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
	- by (simp add: )
	+ by simp
	finally have *: "(eucl_of_list xs::'b\<times>'c) = eucl_of_list (take DIM('b \<times> 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
	by simp
	show ?thesis
	apply (subst *)
	apply (subst eucl_of_list_prod_if)
	subgoal by simp
	subgoal
	apply simp
	apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
	apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
	apply (rule arg_cong[where f=eucl_of_list])
	by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
	done
	qed

	lemma eucl_of_list_prod:
	shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
	eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
	using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
	using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
	by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)

	lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
	by (auto simp: eucl_of_list_def Basis_list_real_def)

	lemma eucl_of_list_append[simp]:
	assumes "length xs = DIM('i::executable_euclidean_space)"
	assumes "length ys = DIM('j::executable_euclidean_space)"
	shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
	using assms
	by (auto simp: eucl_of_list_prod)

	lemma list_allI: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> list_all P xs"
	by (auto simp: list_all_iff)

	lemma
	concat_map_nthI:
	assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set (f x) \<Longrightarrow> P y"
	assumes "j < length (concat (map f xs))"
	shows "P (concat (map f xs) ! j)"
	proof -
	have "list_all P (concat (map f xs))"
	by (rule list_allI) (auto simp: assms)
	then show ?thesis
	by (auto simp: list_all_length assms)
	qed

	lemma map_nth_append1:
	assumes "length xs = d"
	shows "map ((!) (xs @ ys)) [0..<d] = xs"
	using assms
	by (auto simp: nth_append intro!: nth_equalityI)

	lemma map_nth_append2:
	assumes "length ys = d"
	shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
	using assms
	by (auto simp: intro!: nth_equalityI)

	lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
	by simp

	lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
	if "n < length xs" "n < length ys"
	using that by simp

	lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
	by (auto intro!: nth_equalityI simp: inner_simps)

	lemma list_of_eucl_inj:
	"list_of_eucl z = list_of_eucl y \<Longrightarrow> y = z"
	by (metis eucl_of_list_list_of_eucl)

	lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
	by (metis length_pos_if_in_set Basis_list SOME_Basis)

	lemma Basis_list_nth_nonzero:
	"i < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> (Basis_list::'a list) ! i \<noteq> 0"
	by (auto dest!: nth_mem simp: nonzero_Basis)

	lemma nth_Basis_list_prod:
	"i < DIM('a) + DIM('b) \<Longrightarrow> (Basis_list::('a::executable_euclidean_space \<times> 'b::executable_euclidean_space) list) ! i =
	(if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
	by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)

	lemma eucl_of_list_if:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
	shows "eucl_of_list (map (\<lambda>xa. if xa = x then 1 else 0) (xs::nat list)) =
	(if x \<in> set xs then Basis_list ! index xs x else 0::'a)"
	by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)


	lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
	by (auto intro!: nth_equalityI simp: nth_append min_def)

	lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (\<Sum>b\<in>Basis. f b)"
	by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)

	lemma hd_Basis_list[simp]: "hd Basis_list \<in> Basis"
	unfolding Basis_list[symmetric]
	by (rule hd_in_set) (auto simp: set_empty[symmetric])

	definition "inner_lv_rel a b = sum_list (map2 (*) a b)"

	lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = inner_lv_rel xs ys"
	if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
	using that
	by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
	(auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)


	lemma euclidean_vec_componentwise:
	"(\<Sum>(xa::'a::euclidean_space^'b::finite)\<in>Basis. f xa) = (\<Sum>a\<in>Basis. (\<Sum>b::'b\<in>UNIV. f (axis b a)))"
	apply (auto simp: Basis_vec_def)
	apply (subst sum.swap)
	apply (subst sum.Union_disjoint)
	apply auto
	apply (simp add: axis_eq_axis nonzero_Basis)
	apply (simp add: axis_eq_axis nonzero_Basis)
	apply (subst sum.reindex)
	apply (auto intro!: injI)
	subgoal
	apply (auto simp: set_eq_iff)
	by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
	apply (rule sum.cong[OF refl])
	apply (auto )
	apply (rule sum.reindex_cong[OF _ _ refl])
	apply (auto intro!: inj_onI)
	using axis_eq_axis by blast

	lemma vec_nth_inner_scaleR_craziness:
	"f (x $ i \<bullet> j) \<^sub>R j = (\<Sum>xa\<in>UNIV. f (x $ xa \<bullet> j) \<^sub>R axis xa j) $ i"
	by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)

	instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
	begin

	definition Basis_list_vec :: "('a, 'b) vec list" where
	"Basis_list_vec = concat (map (\<lambda>n. map (axis n) Basis_list) enum_class.enum)"

	definition eucl_down_vec :: "int \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
	"eucl_down_vec p x = (\<chi> i. eucl_down p (x $ i))"

	definition eucl_truncate_down_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
	"eucl_truncate_down_vec p x = (\<chi> i. eucl_truncate_down p (x $ i))"

	definition eucl_truncate_up_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
	"eucl_truncate_up_vec p x = (\<chi> i. eucl_truncate_up p (x $ i))"

	instance
	proof
	show *: "set (Basis_list::('a, 'b) vec list) = Basis"
	unfolding Basis_list_vec_def Basis_vec_def
	apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
	intro!: distinct_concat inj_onI split: if_splits)
	apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
	UNIV_enum[symmetric]
	intro!: distinct_concat inj_onI split: if_splits)
	done
	have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
	by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
	sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
	then show "distinct (Basis_list::('a, 'b) vec list)"
	using * by (auto intro!: card_distinct)
	qed (simp_all only: vector_cart[symmetric] vec_eq_iff
	eucl_down_vec_def eucl_down_def
	eucl_truncate_down_vec_def eucl_truncate_down_def
	eucl_truncate_up_vec_def eucl_truncate_up_def,
	auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
	vec_nth_inner_scaleR_craziness
	intro!: sum.cong[OF refl])
	end


	lemma concat_same_lengths_nth:
	assumes "\<And>xs. xs \<in> set XS \<Longrightarrow> length xs = N"
	assumes "i < length XS * N" "N > 0"
	shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
	using assms
	apply (induction XS arbitrary: i)
	apply (auto simp: nth_append nth_Cons split: nat.splits)
	apply (simp add: div_eq_0_iff)
	by (metis Suc_inject div_geq mod_geq)

	lemma concat_map_map_index:
	shows "concat (map (\<lambda>n. map (f n) xs) ys) =
	map (\<lambda>i. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
	apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
	apply (subst concat_same_lengths_nth)
	- apply (auto simp: )
	+ apply auto
	apply (subst nth_map_upt)
	apply (auto simp: ac_simps)
	apply (subst nth_map)
	apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
	apply (subst nth_map)
	subgoal for i
	using gr_implies_not_zero by fastforce
	subgoal by simp
	done

	lemma
	sum_list_zip_map:
	assumes "distinct xs"
	shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
	by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
	in_set_zip in_set_conv_nth inj_on_convol_ident
	intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])

	lemma
	sum_list_zip_map_of:
	assumes "distinct bs"
	assumes "length xs = length bs"
	shows "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
	proof -
	have "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>(y, x)\<leftarrow>zip bs xs. f x y)"
	by (subst zip_commute) (auto simp: o_def split_beta')
	also have "\<dots> = (\<Sum>(x, y)\<leftarrow>zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
	proof (rule arg_cong, rule map_cong)
	have "xs = (map (the \<circ> map_of (zip bs xs)) bs)"
	using assms
	by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
	then show "zip bs xs = zip bs (map (the \<circ> map_of (zip bs xs)) bs)"
	by simp
	qed auto
	also have "\<dots> = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
	using assms(1)
	by (subst sum_list_zip_map) (auto simp: o_def)
	finally show ?thesis .
	qed



	lemma vec_nth_matrix:
	"vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
	unfolding matrix_def by simp

	lemma matrix_eqI:
	assumes "\<And>x. x \<in> Basis \<Longrightarrow> A v x = B v x"
	shows "(A::real^'n^'n) = B"
	apply vector
	using assms
	apply (auto simp: Basis_vec_def)
	by (metis cart_eq_inner_axis matrix_vector_mul_component)

	lemma matrix_columnI:
	assumes "\<And>i. column i A = column i B"
	shows "(A::real^'n^'n) = B"
	using assms
	apply vector
	apply (auto simp: column_def)
	apply vector
	by (metis iso_tuple_UNIV_I vec_lambda_inject)

	lemma
	vec_nth_Basis:
	fixes x::"real^'n"
	shows "x \<in> Basis \<Longrightarrow> vec_nth x i = (if x = axis i 1 then 1 else 0)"
	apply (auto simp: Basis_vec_def)
	by (metis cart_eq_inner_axis inner_axis_axis)

	lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) \<Longrightarrow>
	vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
	apply (auto simp: eucl_of_list_def)
	apply (subst sum_list_zip_map_of)
	apply (auto intro!: distinct_zipI2 simp: split_beta')
	apply (subst sum.cong[OF refl])
	apply (subst vec_nth_Basis)
	apply (force simp: set_zip)
	apply (rule refl)
	apply (auto simp: if_distrib sum.delta cong: if_cong)
	subgoal
	apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
	subgoal premises prems
	proof -
	have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
	by (auto simp: in_set_zip)
	then show ?thesis
	using prems
	by (subst (asm) map_of_eq_None_iff) simp
	qed
	subgoal for a
	apply (auto simp: in_set_zip)
	subgoal premises prems for n
	by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
	done
	done
	done

	lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
	apply (auto simp: Basis_list_vec_def Basis_list_real_def )
	apply (subst index_map_inj)
	by (auto intro!: injI simp: axis_eq_axis)

	lemma vec_nth_eq_list_of_eucl1:
	"(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
	apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
	apply (subst vec_nth_eucl_of_list_eq)
	unfolding index_Basis_list_axis1
	by auto

	lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
	by code_simp+

	lemma three_eq_zero: "(3::3) = 0" by simp

	lemma forall_3': "(\<forall>i::3. P i) \<longleftrightarrow> P 0 \<and> P 1 \<and> P 2"
	using forall_3 three_eq_zero by auto

	lemma euclidean_eq_list_of_euclI: "x = y" if "list_of_eucl x = list_of_eucl y"
	using that
	by (metis eucl_of_list_list_of_eucl)

	lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) \<noteq> 0"
	by (auto simp: axis_def vec_eq_iff)


	lemma eucl_of_list_vec_nth3[simp]:
	"(eucl_of_list [g, h, i]::real^3) $ 0 = g"
	"(eucl_of_list [g, h, i]::real^3) $ 1 = h"
	"(eucl_of_list [g, h, i]::real^3) $ 2 = i"
	"(eucl_of_list [g, h, i]::real^3) $ 3 = g"
	by (auto simp: cart_eq_inner_axis eucl_of_list_inner vec_nth_eq_list_of_eucl1 index_Basis_list_axis1)

	type_synonym R3 = "realrealreal"

	lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
	by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)

	lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
	by (auto simp: Basis_list_vec_def Basis_list_real_def)

	lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
	by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
	Basis_prod_def Basis_list_vec3 Basis_list_R3
	intro!: euclidean_eqI[where 'a=R3])


	subsection \<open>Bounded Linear Functions\<close>

	subsection \<open>bounded linear functions\<close>

	locale blinfun_syntax
	begin
	no_notation vec_nth (infixl "$" 90)
	notation blinfun_apply (infixl "$" 999)
	end

	lemma bounded_linear_via_derivative:
	fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector" \<comment> \<open>TODO: generalize?\<close>
	assumes "\<And>i. ((\<lambda>x. blinfun_apply (f x) i) has_derivative (\<lambda>x. f' y x i)) (at y)"
	shows "bounded_linear (f' y x)"
	proof -
	interpret linear "f' y x"
	proof (unfold_locales, goal_cases)
	case (1 v w)
	from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
	has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
	show ?case .
	next
	case (2 r v)
	from has_derivative_unique[OF assms[of "r *\<^sub>R v", unfolded blinfun.bilinear_simps]
	has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
	show ?case .
	qed
	let ?bnd = "\<Sum>i\<in>Basis. norm (f' y x i)"
	{
	fix v
	have "f' y x v = (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R f' y x i)"
	by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
	also have "norm \<dots> \<le> norm v * ?bnd"
	by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
	simp: sum_distrib_left Basis_le_norm)
	finally have "norm (f' y x v) \<le> norm v * ?bnd" .
	}
	then show ?thesis by unfold_locales auto
	qed

	definition blinfun_scaleR::"('a::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)"
	where "blinfun_scaleR a b = blinfun_scaleR_left b o\<^sub>L a"

	lemma blinfun_scaleR_transfer[transfer_rule]:
	"rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
	(\<lambda>a b c. a c *\<^sub>R b) blinfun_scaleR"
	by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)

	lemma blinfun_scaleR_rep_eq[simp]:
	"blinfun_scaleR a b c = a c *\<^sub>R b"
	by (simp add: blinfun_scaleR_def)

	lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
	unfolding blinfun_scaleR_def[abs_def]
	by (auto intro!: bounded_linear_intros)

	lemma blinfun_scaleR_has_derivative[derivative_intros]:
	assumes "(f has_derivative f') (at x within s)"
	shows "((\<lambda>x. blinfun_scaleR a (f x)) has_derivative (\<lambda>x. blinfun_scaleR a (f' x))) (at x within s)"
	using bounded_linear_blinfun_scaleR assms
	by (rule bounded_linear.has_derivative)

	lemma blinfun_componentwise:
	fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
	shows "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
	by (auto intro!: blinfun_eqI
	simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
	blinfun.sum_right[symmetric])

	lemma
	blinfun_has_derivative_componentwiseI:
	fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. f x i) has_derivative blinfun_apply (f' i)) (at x)"
	shows "(f has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
	by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)

	lemma
	has_derivative_BlinfunI:
	fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
	assumes "\<And>i. ((\<lambda>x. f x i) has_derivative (\<lambda>x. f' y x i)) (at y)"
	shows "(f has_derivative (\<lambda>x. Blinfun (f' y x))) (at y)"
	proof -
	have 1: "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
	by (rule blinfun_componentwise)
	moreover have 2: "(\<dots> has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
	by (force intro: assms derivative_eq_intros)
	moreover
	interpret f': bounded_linear "f' y x" for x
	by (rule bounded_linear_via_derivative) (rule assms)
	have 3: "(\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
	by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
	f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
	intro!: blinfun_euclidean_eqI)
	have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
	apply (subst bounded_linear_Blinfun_apply)
	subgoal by unfold_locales
	subgoal by simp
	done
	show ?thesis
	apply (subst 1)
	apply (rule 2[THEN has_derivative_eq_rhs])
	apply (rule ext)
	apply (rule blinfun_eqI)
	apply (subst 3)
	apply (subst 4)
	apply (rule refl)
	done
	qed

	lemma
	has_derivative_Blinfun:
	assumes "(f has_derivative f') F"
	shows "(f has_derivative Blinfun f') F"
	using assms
	by (subst bounded_linear_Blinfun_apply) auto

	lift_definition flip_blinfun::
	"('a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'c" is
	"\<lambda>f x y. f y x"
	using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
	by auto

	lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
	by transfer simp

	lemma le_norm_blinfun:
	shows "norm (blinfun_apply f x) / norm x \<le> norm f"
	by transfer (rule le_onorm)

	lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
	proof (rule antisym)
	from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
	show "?l \<le> ?r"
	by (auto intro!: norm_blinfun_bound simp: ac_simps)
	have "norm (x a b) \<le> norm (flip_blinfun x) * norm a * norm b" for a b
	proof -
	have "norm (x a b) / norm a \<le> norm (flip_blinfun x b)"
	by (rule order_trans[OF _ le_norm_blinfun]) auto
	also have "\<dots> \<le> norm (flip_blinfun x) * norm b"
	by (rule norm_blinfun)
	finally show ?thesis
	by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
	qed
	then show "?r \<le> ?l"
	by (auto intro!: norm_blinfun_bound)
	qed

	lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
	by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])

	lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
	by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
	norm_flip_blinfun)


	context includes blinfun.lifting begin

	lift_definition blinfun_of_vmatrix::"(real^'m^'n) \<Rightarrow> ((real^('m::finite)) \<Rightarrow>\<^sub>L (real^('n::finite)))" is
	"matrix_vector_mult:: ((real, 'm) vec, 'n) vec \<Rightarrow> ((real, 'm) vec \<Rightarrow> (real, 'n) vec)"
	unfolding linear_linear
	by (rule matrix_vector_mul_linear)

	lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
	apply vector
	apply (auto simp: matrix_def)
	apply transfer
	by (metis cart_eq_inner_axis matrix_vector_mul_component)

	end

	lemma blinfun_apply_componentwise:
	"B = (\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
	using blinfun_componentwise[of "\<lambda>x. B", unfolded fun_eq_iff]
	by blast

	lemma blinfun_apply_eq_sum:
	assumes [simp]: "length v = CARD('n)"
	shows "blinfun_apply (B::(real^'n::enum)\<Rightarrow>\<^sub>L(real^'m::enum)) (eucl_of_list v) =
	(\<Sum>i<CARD('m). \<Sum>j<CARD('n). ((B (Basis_list ! j) \<bullet> Basis_list ! i) * v ! j) *\<^sub>R (Basis_list ! i))"
	apply (subst blinfun_apply_componentwise[of B])
	apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
	simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
	sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
	cong: if_cong)
	apply (subst sum.swap)
	by (auto simp: sum.delta algebra_simps)

	lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
	proof -
	have "x * C + y < (D - 1) * C + C"
	apply (rule add_le_less_mono)
	apply (rule mult_right_mono)
	using that
	by auto
	also have "\<dots> \<le> D * C"
	using that
	by (auto simp: algebra_simps)
	finally show ?thesis .
	qed

	lemma less_square_imp_div_less[intro, simp]: "i < E * D \<Longrightarrow> i div E < D" for i::nat
	by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)

	lemma in_square_lemma'[intro, simp]: "i < L \<Longrightarrow> n < N \<Longrightarrow> i * N + n < N * L" for i n::nat
	by (metis in_square_lemma mult.commute)

	lemma
	distinct_nth_eq_iff:
	"distinct xs \<Longrightarrow> x < length xs \<Longrightarrow> y < length xs \<Longrightarrow> xs ! x = xs ! y \<longleftrightarrow> x = y"
	by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)

	lemma index_Basis_list_axis2:
	"index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
	(index enum_class.enum j) * CARD('i) + index enum_class.enum i"
	apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
	apply (subst concat_map_map_index)
	unfolding card_UNIV_length_enum[symmetric]
	subgoal
	proof -
	have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
	by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
	have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
	by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
	have *: "axis j (axis i 1) =
	(\<lambda>i. axis (enum_class.enum ! (i div CARD('i)))
	(axis (enum_class.enum ! (i mod CARD('i))) 1))
	((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
	by (auto simp: index_less_cardi enum_UNIV)
	note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
	show ?thesis
	apply (subst *)
	apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
	subgoal
	apply (auto intro!: inj_onI simp: axis_eq_axis )
	apply (subst (asm) distinct_nth_eq_iff)
	apply (auto simp: enum_distinct card_UNIV_length_enum)
	subgoal for x y
	using gr_implies_not0 by fastforce
	subgoal for x y
	using gr_implies_not0 by fastforce
	subgoal for x y
	apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
	apply (auto simp: card_UNIV_length_enum mult.commute)
	subgoal
	by (metis mod_mult_div_eq)
	done
	done
	- subgoal using less by (auto simp: )
	+ subgoal using less by auto
	subgoal by (auto simp: card_UNIV_length_enum ac_simps)
	subgoal apply (subst index_upt)
	subgoal using less by auto
	subgoal using less by (auto simp: ac_simps)
	subgoal using less by auto
	done
	done
	qed
	done

	lemma
	vec_nth_Basis2:
	fixes x::"real^'n^'m"
	shows "x \<in> Basis \<Longrightarrow> vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
	by (auto simp: Basis_vec_def axis_def)

	lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) \<Longrightarrow>
	vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
	apply (auto simp: eucl_of_list_def)
	apply (subst sum_list_zip_map_of)
	apply (auto intro!: distinct_zipI2 simp: split_beta')
	apply (subst sum.cong[OF refl])
	apply (subst vec_nth_Basis2)
	apply (force simp: set_zip)
	apply (rule refl)
	apply (auto simp: if_distrib sum.delta cong: if_cong)
	subgoal
	apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
	subgoal premises prems
	proof -
	have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
	by (auto simp: in_set_zip)
	then show ?thesis
	using prems
	by (subst (asm) map_of_eq_None_iff) auto
	qed
	subgoal for a
	apply (auto simp: in_set_zip)
	subgoal premises prems for n
	proof -
	have "n < card (Basis::(real^'n::_^'m::_) set)"
	by (simp add: prems(4))
	then show ?thesis
	by (metis index_Basis_list_nth prems(2))
	qed
	done
	done
	done

	lemma vec_nth_eq_list_of_eucl2:
	"vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
	list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
	apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
	apply (subst vec_nth_eucl_of_list_eq2)
	unfolding index_Basis_list_axis2
	by auto

	theorem
	eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
	assumes "length M = CARD('n) * CARD('m)"
	assumes "length v = CARD('n)"
	shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
	(\<Sum>i<CARD('m).
	(\<Sum>j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *\<^sub>R Basis_list ! i)"
	apply (vector matrix_vector_mult_def)
	- apply (auto simp: )
	+ apply auto
	apply (subst vec_nth_eucl_of_list_eq2)
	apply (auto simp: assms)
	apply (subst vec_nth_eucl_of_list_eq)
	apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
	nth_eq_iff_index
	if_distrib cong: if_cong)
	subgoal for i
	apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
	apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
	apply (rule image_eqI[OF ])
	apply (rule nth_index[symmetric])
	apply (auto simp: enum_UNIV)
	by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
	subgoal for i
	using index_less[of i "enum_class.enum" "CARD('n)"]
	by (auto simp: enum_UNIV card_UNIV_length_enum)
	done

	lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
	by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)

	lemmas [intro, simp] = enum_distinct
	lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV

	lemma sum_index_enum_eq:
	"(\<Sum>(k::'n::enum)\<in>UNIV. f (index enum_class.enum k)) = (\<Sum>i<CARD('n). f i)"
	by (rule sum.reindex_cong[where l="nth enum_class.enum"])
	(force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+

	end
	\ No newline at end of file
	diff --git a/thys/Affine_Arithmetic/Floatarith_Expression.thy b/thys/Affine_Arithmetic/Floatarith_Expression.thy
	--- a/thys/Affine_Arithmetic/Floatarith_Expression.thy
	+++ b/thys/Affine_Arithmetic/Floatarith_Expression.thy
	@@ -1,2233 +1,2233 @@
	section \<open>Operations on Expressions\<close>
	theory Floatarith_Expression
	imports
	"HOL-Decision_Procs.Approximation"
	Affine_Arithmetic_Auxiliarities
	Executable_Euclidean_Space
	begin

	text \<open>Much of this could move to the distribution...\<close>

	subsection \<open>Approximating Expressions\<close>

	unbundle floatarith_notation

	text \<open>\label{sec:affineexpr}\<close>

	primrec interpret_floatariths :: "floatarith list \<Rightarrow> real list \<Rightarrow> real list"
	where
	"interpret_floatariths [] vs = []"
	\| "interpret_floatariths (a#bs) vs = interpret_floatarith a vs#interpret_floatariths bs vs"

	lemma length_interpret_floatariths[simp]: "length (interpret_floatariths fas xs) = length fas"
	by (induction fas) auto

	lemma interpret_floatariths_nth[simp]:
	"interpret_floatariths fas xs ! n = interpret_floatarith (fas ! n) xs"
	if "n < length fas"
	using that
	by (induction fas arbitrary: n) (auto simp: nth_Cons split: nat.splits)

	abbreviation "einterpret \<equiv> \<lambda>fas vs. eucl_of_list (interpret_floatariths fas vs)"

	subsection \<open>Syntax\<close>

	syntax interpret_floatarith::"floatarith \<Rightarrow> real list \<Rightarrow> real"

	instantiation floatarith :: "{plus, minus, uminus, times, inverse, zero, one}"
	begin

	definition "- f = Minus f"
	lemma interpret_floatarith_uminus[simp]:
	"interpret_floatarith (- f) xs = - interpret_floatarith f xs"
	by (auto simp: uminus_floatarith_def)

	definition "f + g = Add f g"
	lemma interpret_floatarith_plus[simp]:
	"interpret_floatarith (f + g) xs = interpret_floatarith f xs + interpret_floatarith g xs"
	by (auto simp: plus_floatarith_def)

	definition "f - g = Add f (Minus g)"
	lemma interpret_floatarith_minus[simp]:
	"interpret_floatarith (f - g) xs = interpret_floatarith f xs - interpret_floatarith g xs"
	by (auto simp: minus_floatarith_def)

	definition "inverse f = Inverse f"
	lemma interpret_floatarith_inverse[simp]:
	"interpret_floatarith (inverse f) xs = inverse (interpret_floatarith f xs)"
	by (auto simp: inverse_floatarith_def)

	definition "f * g = Mult f g"
	lemma interpret_floatarith_times[simp]:
	"interpret_floatarith (f * g) xs = interpret_floatarith f xs * interpret_floatarith g xs"
	by (auto simp: times_floatarith_def)

	definition "f div g = f * Inverse g"
	lemma interpret_floatarith_divide[simp]:
	"interpret_floatarith (f div g) xs = interpret_floatarith f xs / interpret_floatarith g xs"
	by (auto simp: divide_floatarith_def inverse_eq_divide)

	definition "1 = Num 1"
	lemma interpret_floatarith_one[simp]:
	"interpret_floatarith 1 xs = 1"
	by (auto simp: one_floatarith_def)

	definition "0 = Num 0"
	lemma interpret_floatarith_zero[simp]:
	"interpret_floatarith 0 xs = 0"
	by (auto simp: zero_floatarith_def)

	instance proof qed
	end


	subsection \<open>Derived symbols\<close>

	definition "R\<^sub>e r = (case quotient_of r of (n, d) \<Rightarrow> Num (of_int n) / Num (of_int d))"
	declare [[coercion R\<^sub>e ]]

	lemma interpret_R\<^sub>e[simp]: "interpret_floatarith (R\<^sub>e x) xs = real_of_rat x"
	by (auto simp: R\<^sub>e_def of_rat_divide dest!: quotient_of_div split: prod.splits)

	definition "Sin x = Cos ((Pi * (Num (Float 1 (-1)))) - x)"

	lemma interpret_floatarith_Sin[simp]:
	"interpret_floatarith (Sin x) vs = sin (interpret_floatarith x vs)"
	by (auto simp: Sin_def approximation_preproc_floatarith(11))

	definition "Half x = Mult (Num (Float 1 (-1))) x"
	lemma interpret_Half[simp]: "interpret_floatarith (Half x) xs = interpret_floatarith x xs / 2"
	by (auto simp: Half_def)

	definition "Tan x = (Sin x) / (Cos x)"

	lemma interpret_floatarith_Tan[simp]:
	"interpret_floatarith (Tan x) vs = tan (interpret_floatarith x vs)"
	by (auto simp: Tan_def approximation_preproc_floatarith(12) inverse_eq_divide)

	primrec Sum\<^sub>e where
	"Sum\<^sub>e f [] = 0"
	\| "Sum\<^sub>e f (x#xs) = f x + Sum\<^sub>e f xs"

	lemma interpret_floatarith_Sum\<^sub>e[simp]:
	"interpret_floatarith (Sum\<^sub>e f x) vs = (\<Sum>i\<leftarrow>x. interpret_floatarith (f i) vs)"
	by (induction x) auto

	definition Norm where "Norm is = Sqrt (Sum\<^sub>e (\<lambda>i. i * i) is)"

	lemma interpret_floatarith_norm[simp]:
	assumes [simp]: "length x = DIM('a)"
	shows "interpret_floatarith (Norm x) vs = norm (einterpret x vs::'a::executable_euclidean_space)"
	apply (auto simp: Norm_def norm_eq_sqrt_inner)
	apply (subst euclidean_inner[where 'a='a])
	apply (auto simp: power2_eq_square[symmetric] )
	apply (subst sum_list_Basis_list[symmetric])
	apply (rule sum_list_nth_eqI)
	by (auto simp: in_set_zip eucl_of_list_inner)

	notation floatarith.Power (infixr "^\<^sub>e" 80)

	subsection \<open>Constant Folding\<close>

	fun dest_Num_fa where
	"dest_Num_fa (floatarith.Num x) = Some x"
	\| "dest_Num_fa _ = None"

	fun_cases dest_Num_fa_None: "dest_Num_fa fa = None"
	and dest_Num_fa_Some: "dest_Num_fa fa = Some x"

	fun fold_const_fa where
	"fold_const_fa (Add fa1 fa2) =
	(let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2)
	in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of
	(Some a, Some b) \<Rightarrow> Num (a + b)
	\| (Some a, None) \<Rightarrow> (if a = 0 then ffa2 else Add (Num a) ffa2)
	\| (None, Some a) \<Rightarrow> (if a = 0 then ffa1 else Add ffa1 (Num a))
	\| (None, None) \<Rightarrow> Add ffa1 ffa2)"
	\| "fold_const_fa (Minus a) =
	(case (fold_const_fa a) of
	(Num x) \<Rightarrow> Num (-x)
	\| x \<Rightarrow> Minus x)"
	\| "fold_const_fa (Mult fa1 fa2) =
	(let (ffa1, ffa2) = (fold_const_fa fa1, fold_const_fa fa2)
	in case (dest_Num_fa ffa1, dest_Num_fa (ffa2)) of
	(Some a, Some b) \<Rightarrow> Num (a * b)
	\| (Some a, None) \<Rightarrow> (if a = 0 then Num 0 else if a = 1 then ffa2 else Mult (Num a) ffa2)
	\| (None, Some a) \<Rightarrow> (if a = 0 then Num 0 else if a = 1 then ffa1 else Mult ffa1 (Num a))
	\| (None, None) \<Rightarrow> Mult ffa1 ffa2)"
	\| "fold_const_fa (Inverse a) = Inverse (fold_const_fa a)"
	\| "fold_const_fa (Abs a) =
	(case (fold_const_fa a) of
	(Num x) \<Rightarrow> Num (abs x)
	\| x \<Rightarrow> Abs x)"
	\| "fold_const_fa (Max a b) =
	(case (fold_const_fa a, fold_const_fa b) of
	(Num x, Num y) \<Rightarrow> Num (max x y)
	\| (x, y) \<Rightarrow> Max x y)"
	\| "fold_const_fa (Min a b) =
	(case (fold_const_fa a, fold_const_fa b) of
	(Num x, Num y) \<Rightarrow> Num (min x y)
	\| (x, y) \<Rightarrow> Min x y)"
	\| "fold_const_fa (Floor a) =
	(case (fold_const_fa a) of
	(Num x) \<Rightarrow> Num (floor_fl x)
	\| x \<Rightarrow> Floor x)"
	\| "fold_const_fa (Power a b) =
	(case (fold_const_fa a) of
	(Num x) \<Rightarrow> Num (x ^ b)
	\| x \<Rightarrow> Power x b)"
	\| "fold_const_fa (Cos a) = Cos (fold_const_fa a)"
	\| "fold_const_fa (Arctan a) = Arctan (fold_const_fa a)"
	\| "fold_const_fa (Sqrt a) = Sqrt (fold_const_fa a)"
	\| "fold_const_fa (Exp a) = Exp (fold_const_fa a)"
	\| "fold_const_fa (Ln a) = Ln (fold_const_fa a)"
	\| "fold_const_fa (Powr a b) = Powr (fold_const_fa a) (fold_const_fa b)"
	\| "fold_const_fa Pi = Pi"
	\| "fold_const_fa (Var v) = Var v"
	\| "fold_const_fa (Num x) = Num x"

	fun_cases fold_const_fa_Num: "fold_const_fa fa = Num y"
	and fold_const_fa_Add: "fold_const_fa fa = Add x y"
	and fold_const_fa_Minus: "fold_const_fa fa = Minus y"

	lemma fold_const_fa[simp]: "interpret_floatarith (fold_const_fa fa) xs = interpret_floatarith fa xs"
	by (induction fa) (auto split!: prod.splits floatarith.splits option.splits
	elim!: dest_Num_fa_None dest_Num_fa_Some
	simp: max_def min_def floor_fl_def)


	subsection \<open>Free Variables\<close>

	primrec max_Var_floatarith where\<comment> \<open>TODO: include bound in predicate\<close>
	"max_Var_floatarith (Add a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_floatarith (Mult a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_floatarith (Inverse a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Minus a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Num a) = 0"
	\| "max_Var_floatarith (Var i) = Suc i"
	\| "max_Var_floatarith (Cos a) = max_Var_floatarith a"
	\| "max_Var_floatarith (floatarith.Arctan a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Abs a) = max_Var_floatarith a"
	\| "max_Var_floatarith (floatarith.Max a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_floatarith (floatarith.Min a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_floatarith (floatarith.Pi) = 0"
	\| "max_Var_floatarith (Sqrt a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Exp a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Powr a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_floatarith (floatarith.Ln a) = max_Var_floatarith a"
	\| "max_Var_floatarith (Power a n) = max_Var_floatarith a"
	\| "max_Var_floatarith (Floor a) = max_Var_floatarith a"

	primrec max_Var_floatariths where
	"max_Var_floatariths [] = 0"
	\| "max_Var_floatariths (x#xs) = max (max_Var_floatarith x) (max_Var_floatariths xs)"

	primrec max_Var_form where
	"max_Var_form (Conj a b) = max (max_Var_form a) (max_Var_form b)"
	\| "max_Var_form (Disj a b) = max (max_Var_form a) (max_Var_form b)"
	\| "max_Var_form (Less a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_form (LessEqual a b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	\| "max_Var_form (Bound a b c d) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c, max_Var_form d}"
	\| "max_Var_form (AtLeastAtMost a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_floatarith c}"
	\| "max_Var_form (Assign a b c) = linorder_class.Max {max_Var_floatarith a,max_Var_floatarith b, max_Var_form c}"

	lemma
	interpret_floatarith_eq_take_max_VarI:
	assumes "take (max_Var_floatarith ra) ys = take (max_Var_floatarith ra) zs"
	shows "interpret_floatarith ra ys = interpret_floatarith ra zs"
	using assms
	by (induct ra) (auto dest!: take_max_eqD simp: take_Suc_eq split: if_split_asm)

	lemma
	interpret_floatariths_eq_take_max_VarI:
	assumes "take (max_Var_floatariths ea) ys = take (max_Var_floatariths ea) zs"
	shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
	using assms
	apply (induction ea)
	subgoal by simp
	subgoal by (clarsimp) (metis interpret_floatarith_eq_take_max_VarI take_map take_max_eqD)
	done


	lemma Max_Image_distrib:
	includes no_floatarith_notation
	assumes "finite X" "X \<noteq> {}"
	shows "Max ((\<lambda>x. max (f1 x) (f2 x)) ` X) = max (Max (f1 ` X)) (Max (f2 ` X))"
	apply (rule Max_eqI)
	subgoal using assms by simp
	subgoal for y
	using assms
	by (force intro: max.coboundedI1 max.coboundedI2 Max_ge)
	subgoal
	proof -
	have "Max (f1 ` X) \<in> f1 ` X" using assms by auto
	then obtain x1 where x1: "x1 \<in> X" "Max (f1 ` X) = f1 x1" by auto
	have "Max (f2 ` X) \<in> f2 ` X" using assms by auto
	then obtain x2 where x2: "x2 \<in> X" "Max (f2 ` X) = f2 x2" by auto
	show ?thesis
	apply (rule image_eqI[where x="if f1 x1 \<le> f2 x2 then x2 else x1"])
	using x1 x2 assms
	apply (auto simp: max_def)
	apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1))
	apply (metis Max_ge dual_order.trans finite_imageI image_eqI assms(1))
	done
	qed
	done

	lemma max_Var_floatarith_simps[simp]:
	"max_Var_floatarith (a / b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	"max_Var_floatarith (a * b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	"max_Var_floatarith (a + b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	"max_Var_floatarith (a - b) = max (max_Var_floatarith a) (max_Var_floatarith b)"
	"max_Var_floatarith (- b) = (max_Var_floatarith b)"
	by (auto simp: divide_floatarith_def times_floatarith_def plus_floatarith_def minus_floatarith_def
	uminus_floatarith_def)

	lemma max_Var_floatariths_Max:
	"max_Var_floatariths xs = (if set xs = {} then 0 else linorder_class.Max (max_Var_floatarith ` set xs))"
	by (induct xs) auto


	lemma max_Var_floatariths_map_plus[simp]:
	"max_Var_floatariths (map (\<lambda>i. fa1 i + fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
	by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

	lemma max_Var_floatariths_map_times[simp]:
	"max_Var_floatariths (map (\<lambda>i. fa1 i * fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
	by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

	lemma max_Var_floatariths_map_divide[simp]:
	"max_Var_floatariths (map (\<lambda>i. fa1 i / fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
	by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

	lemma max_Var_floatariths_map_uminus[simp]:
	"max_Var_floatariths (map (\<lambda>i. - fa1 i) xs) = max_Var_floatariths (map fa1 xs)"
	by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)

	lemma max_Var_floatariths_map_const[simp]:
	"max_Var_floatariths (map (\<lambda>i. fa) xs) = (if xs = [] then 0 else max_Var_floatarith fa)"
	by (auto simp: max_Var_floatariths_Max image_image image_constant_conv)

	lemma max_Var_floatariths_map_minus[simp]:
	"max_Var_floatariths (map (\<lambda>i. fa1 i - fa2 i) xs) = max (max_Var_floatariths (map fa1 xs)) (max_Var_floatariths (map fa2 xs))"
	by (auto simp: max_Var_floatariths_Max image_image Max_Image_distrib)


	primrec fresh_floatarith where
	"fresh_floatarith (Var y) x \<longleftrightarrow> (x \<noteq> y)"
	\| "fresh_floatarith (Num a) x \<longleftrightarrow> True"
	\| "fresh_floatarith Pi x \<longleftrightarrow> True"
	\| "fresh_floatarith (Cos a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Abs a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Arctan a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Sqrt a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Exp a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Floor a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Power a n) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Minus a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Ln a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Inverse a) x \<longleftrightarrow> fresh_floatarith a x"
	\| "fresh_floatarith (Add a b) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatarith b x"
	\| "fresh_floatarith (Mult a b) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatarith b x"
	\| "fresh_floatarith (Max a b) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatarith b x"
	\| "fresh_floatarith (Min a b) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatarith b x"
	\| "fresh_floatarith (Powr a b) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatarith b x"

	lemma fresh_floatarith_subst:
	fixes v::float
	assumes "fresh_floatarith e x"
	assumes "x < length vs"
	shows "interpret_floatarith e (vs[x:=v]) = interpret_floatarith e vs"
	using assms
	by (induction e) (auto simp: map_update)

	lemma fresh_floatarith_max_Var:
	assumes "max_Var_floatarith ea \<le> i"
	shows "fresh_floatarith ea i"
	using assms
	by (induction ea) auto

	primrec fresh_floatariths where
	"fresh_floatariths [] x \<longleftrightarrow> True"
	\| "fresh_floatariths (a#as) x \<longleftrightarrow> fresh_floatarith a x \<and> fresh_floatariths as x"

	lemma fresh_floatariths_max_Var:
	assumes "max_Var_floatariths ea \<le> i"
	shows "fresh_floatariths ea i"
	using assms
	by (induction ea) (auto simp: fresh_floatarith_max_Var)

	lemma
	interpret_floatariths_take_eqI:
	assumes "take n ys = take n zs"
	assumes "max_Var_floatariths ea \<le> n"
	shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
	by (rule interpret_floatariths_eq_take_max_VarI) (rule take_greater_eqI[OF assms])

	lemma
	interpret_floatarith_fresh_eqI:
	assumes "\<And>i. fresh_floatarith ea i \<or> (i < length ys \<and> i < length zs \<and> ys ! i = zs ! i)"
	shows "interpret_floatarith ea ys = interpret_floatarith ea zs"
	using assms
	by (induction ea) force+

	lemma
	interpret_floatariths_fresh_eqI:
	assumes "\<And>i. fresh_floatariths ea i \<or> (i < length ys \<and> i < length zs \<and> ys ! i = zs ! i)"
	shows "interpret_floatariths ea ys = interpret_floatariths ea zs"
	using assms
	apply (induction ea)
	subgoal by (force simp: interpret_floatarith_fresh_eqI intro: interpret_floatarith_fresh_eqI)
	subgoal for e ea
	apply clarsimp
	apply (auto simp: list_eq_iff_nth_eq)
	using interpret_floatarith_fresh_eqI by blast
	done

	lemma
	interpret_floatarith_max_Var_cong:
	assumes "\<And>i. i < max_Var_floatarith f \<Longrightarrow> xs ! i = ys ! i"
	shows "interpret_floatarith f ys = interpret_floatarith f xs"
	using assms
	by (induction f) auto

	lemma
	interpret_floatarith_fresh_cong:
	assumes "\<And>i. \<not>fresh_floatarith f i \<Longrightarrow> xs ! i = ys ! i"
	shows "interpret_floatarith f ys = interpret_floatarith f xs"
	using assms
	by (induction f) auto

	lemma max_Var_floatarith_le_max_Var_floatariths:
	"fa \<in> set fas \<Longrightarrow> max_Var_floatarith fa \<le> max_Var_floatariths fas"
	by (induction fas) (auto simp: nth_Cons max_def split: nat.splits)

	lemma max_Var_floatarith_le_max_Var_floatariths_nth:
	"n < length fas \<Longrightarrow> max_Var_floatarith (fas ! n) \<le> max_Var_floatariths fas"
	by (rule max_Var_floatarith_le_max_Var_floatariths) auto

	lemma max_Var_floatariths_leI:
	assumes "\<And>i. i < length xs \<Longrightarrow> max_Var_floatarith (xs ! i) \<le> F"
	shows "max_Var_floatariths xs \<le> F"
	using assms
	by (auto simp: max_Var_floatariths_Max in_set_conv_nth)

	lemma fresh_floatariths_map_Var[simp]:
	"fresh_floatariths (map floatarith.Var xs) i \<longleftrightarrow> i \<notin> set xs"
	by (induction xs) auto


	lemma max_Var_floatarith_fold_const_fa:
	"max_Var_floatarith (fold_const_fa fa) \<le> max_Var_floatarith fa"
	by (induction fa) (auto simp: fold_const_fa.simps split!: option.splits floatarith.splits)

	lemma max_Var_floatariths_fold_const_fa:
	"max_Var_floatariths (map fold_const_fa xs) \<le> max_Var_floatariths xs"
	by (auto simp: intro!: max_Var_floatariths_leI max_Var_floatarith_le_max_Var_floatariths_nth
	max_Var_floatarith_fold_const_fa[THEN order_trans])

	lemma interpret_form_max_Var_cong:
	assumes "\<And>i. i < max_Var_form f \<Longrightarrow> xs ! i = ys ! i"
	shows "interpret_form f xs = interpret_form f ys"
	using assms
	by (induction f) (auto simp: interpret_floatarith_max_Var_cong[where xs=xs and ys=ys])

	lemma max_Var_floatariths_lessI: "i < max_Var_floatarith (fas ! j) \<Longrightarrow> j < length fas \<Longrightarrow> i < max_Var_floatariths fas"
	by (metis leD le_trans less_le max_Var_floatarith_le_max_Var_floatariths nth_mem)

	lemma interpret_floatariths_max_Var_cong:
	assumes "\<And>i. i < max_Var_floatariths f \<Longrightarrow> xs ! i = ys ! i"
	shows "interpret_floatariths f ys = interpret_floatariths f xs"
	by (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong assms max_Var_floatariths_lessI)


	lemma max_Var_floatarithimage_Var[simp]: "max_Var_floatarith ` Var ` X = Suc ` X" by force

	lemma max_Var_floatariths_map_Var[simp]:
	"max_Var_floatariths (map Var xs) = (if xs = [] then 0 else Suc (linorder_class.Max (set xs)))"
	by (auto simp: max_Var_floatariths_Max hom_Max_commute split: if_splits)

	lemma Max_atLeastLessThan_nat[simp]: "a < b \<Longrightarrow> linorder_class.Max {a..<b} = b - 1" for a b::nat
	by (auto intro!: Max_eqI)


	subsection \<open>Derivatives\<close>

	lemma isDERIV_Power_iff: "isDERIV j (Power fa n) xs = (if n = 0 then True else isDERIV j fa xs)"
	by (cases n) auto

	lemma isDERIV_max_Var_floatarithI:
	assumes "isDERIV n f ys"
	assumes "\<And>i. i < max_Var_floatarith f \<Longrightarrow> xs ! i = ys ! i"
	shows "isDERIV n f xs"
	using assms
	proof (induction f)
	case (Power f n) then show ?case by (cases n) auto
	qed (auto simp: max_def interpret_floatarith_max_Var_cong[of _ xs ys] split: if_splits)

	definition isFDERIV where "isFDERIV n xs fas vs \<longleftrightarrow>
	(\<forall>i<n. \<forall>j<n. isDERIV (xs ! i) (fas ! j) vs) \<and> length fas = n \<and> length xs = n"

	lemma isFDERIV_I: "(\<And>i j. i < n \<Longrightarrow> j < n \<Longrightarrow> isDERIV (xs ! i) (fas ! j) vs) \<Longrightarrow>
	length fas = n \<Longrightarrow> length xs = n \<Longrightarrow> isFDERIV n xs fas vs"
	by (auto simp: isFDERIV_def)

	lemma isFDERIV_isDERIV_D: "isFDERIV n xs fas vs \<Longrightarrow> i < n \<Longrightarrow> j < n \<Longrightarrow> isDERIV (xs ! i) (fas ! j) vs"
	by (auto simp: isFDERIV_def)

	lemma isFDERIV_lengthD: "length fas = n" "length xs = n" if "isFDERIV n xs fas vs"
	using that by (auto simp: isFDERIV_def)

	lemma isFDERIV_uptD: "isFDERIV n [0..<n] fas vs \<Longrightarrow> i < n \<Longrightarrow> j < n \<Longrightarrow> isDERIV i (fas ! j) vs"
	by (auto simp: isFDERIV_def)

	lemma isFDERIV_max_Var_congI: "isFDERIV n xs fas ws"
	if f: "isFDERIV n xs fas vs" and c: "(\<And>i. i < max_Var_floatariths fas \<Longrightarrow> vs ! i = ws ! i)"
	using c f
	by (auto simp: isFDERIV_def max_Var_floatariths_lessI
	intro!: isFDERIV_I isDERIV_max_Var_floatarithI[OF isFDERIV_isDERIV_D[OF f]])

	lemma isFDERIV_max_Var_cong: "isFDERIV n xs fas ws \<longleftrightarrow> isFDERIV n xs fas vs"
	if c: "(\<And>i. i < max_Var_floatariths fas \<Longrightarrow> vs ! i = ws ! i)"
	using c by (auto intro: isFDERIV_max_Var_congI)

	lemma isDERIV_max_VarI:
	"i \<ge> max_Var_floatarith fa \<Longrightarrow> isDERIV j fa xs \<Longrightarrow> isDERIV i fa xs"
	by (induction fa) (auto simp: isDERIV_Power_iff)

	lemmas max_Var_floatarith_le_max_Var_floatariths_nthI =
	max_Var_floatarith_le_max_Var_floatariths_nth[THEN order_trans]


	lemma
	isFDERIV_appendD1:
	assumes "isFDERIV (J + K) [0..<J + K] (es @ rs) xs"
	assumes "length es = J"
	assumes "length rs = K"
	assumes "max_Var_floatariths es \<le> J"
	shows "isFDERIV J [0..<J] (es) xs"
	unfolding isFDERIV_def
	apply (safe)
	subgoal for i j
	using assms
	apply (cases "i < length es")
	subgoal by (auto simp: nth_append isFDERIV_def) (metis add.commute trans_less_add2)
	subgoal
	apply (rule isDERIV_max_VarI[where j=0])
	apply (rule max_Var_floatarith_le_max_Var_floatariths_nthI)
	apply force
	apply force
	apply force
	done
	done
	subgoal by (auto simp: assms)
	subgoal by (auto simp: assms)
	done

	lemma interpret_floatariths_Var[simp]:
	"interpret_floatariths (map floatarith.Var xs) vs = (map (nth vs) xs)"
	- by (induction xs) (auto simp: )
	+ by (induction xs) auto

	lemma max_Var_floatariths_append[simp]: "max_Var_floatariths (xs @ ys) = max (max_Var_floatariths xs) (max_Var_floatariths ys)"
	by (induction xs) (auto)

	lemma map_nth_append_upt[simp]:
	assumes "a \<ge> length xs"
	shows "map ((!) (xs @ ys)) [a..<b] = map ((!) ys) [a - length xs..<b - length xs]"
	using assms
	by (auto intro!: nth_equalityI simp: nth_append)

	lemma map_nth_Cons_upt[simp]:
	assumes "a > 0"
	shows "map ((!) (x # ys)) [a..<b] = map ((!) ys) [a - Suc 0..<b - Suc 0]"
	using assms
	by (auto intro!: nth_equalityI simp: nth_append)

	lemma map_nth_eq_self[simp]:
	shows "length fas = l \<Longrightarrow> (map ((!) fas) [0..<l]) = fas"
	by (auto simp: intro!: nth_equalityI)


	lemma
	isFDERIV_appendI1:
	assumes "isFDERIV J [0..<J] (es) xs"
	assumes "\<And>i j. i < J + K \<Longrightarrow> j < K \<Longrightarrow> isDERIV i (rs ! j) xs"
	assumes "length es = J"
	assumes "length rs = K"
	assumes "max_Var_floatariths es \<le> J"
	shows "isFDERIV (J + K) [0..<J + K] (es @ rs) xs"
	unfolding isFDERIV_def
	apply safe
	subgoal for i j
	using assms
	apply (cases "j < length es")
	subgoal
	apply (auto simp: nth_append isFDERIV_def)
	by (metis (no_types, opaque_lifting) isDERIV_max_VarI le_trans less_le
	max_Var_floatarith_le_max_Var_floatariths_nthI nat_le_linear)
	subgoal by (auto simp: nth_append)
	done
	subgoal by (auto simp: assms)
	subgoal by (auto simp: assms)
	done


	lemma matrix_matrix_mult_zero[simp]:
	"a 0 = 0" "0 a = 0"
	by (vector matrix_matrix_mult_def)+

	lemma scaleR_blinfun_compose_left: "i \<^sub>R (A o\<^sub>L B) = i \<^sub>R A o\<^sub>L B"
	and scaleR_blinfun_compose_right: "i \<^sub>R (A o\<^sub>L B) = A o\<^sub>L i \<^sub>R B"
	by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)

	lemma
	matrix_blinfun_compose:
	fixes A B::"(real ^ 'n) \<Rightarrow>\<^sub>L (real ^ 'n)"
	shows "matrix (A o\<^sub>L B) = (matrix A) ** (matrix B)"
	by transfer (auto simp: matrix_compose linear_linear)

	lemma matrix_add_rdistrib: "((B + C) A) = (B A) + (C ** A)"
	by (vector matrix_matrix_mult_def sum.distrib[symmetric] field_simps)

	lemma matrix_scaleR_right: "r \<^sub>R (a::'a::real_algebra_1^'n^'m) * b = r \<^sub>R (a * b)"
	by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right)

	lemma matrix_scaleR_left: "(a::'a::real_algebra_1^'n^'m) ** r \<^sub>R b = r \<^sub>R (a ** b)"
	by (vector matrix_matrix_mult_def algebra_simps scaleR_sum_right)

	lemma bounded_bilinear_matrix_matrix_mult[bounded_bilinear]:
	"bounded_bilinear ((**)::
	('a::{euclidean_space, real_normed_algebra_1}^'n^'m) \<Rightarrow>
	('a::{euclidean_space, real_normed_algebra_1}^'p^'n) \<Rightarrow>
	('a::{euclidean_space, real_normed_algebra_1}^'p^'m))"
	unfolding bilinear_conv_bounded_bilinear[symmetric]
	unfolding bilinear_def
	apply safe
	by unfold_locales (auto simp: matrix_add_ldistrib matrix_add_rdistrib matrix_scaleR_right matrix_scaleR_left)

	lemma norm_axis: "norm (axis ia 1::'a::{real_normed_algebra_1}^'n) = 1"
	by (auto simp: axis_def norm_vec_def L2_set_def if_distrib if_distribR sum.delta
	cong: if_cong)

	lemma abs_vec_nth_blinfun_apply_lemma:
	fixes x::"(real^'n) \<Rightarrow>\<^sub>L (real^'m)"
	shows "abs (vec_nth (blinfun_apply x (axis ia 1)) i) \<le> norm x"
	apply (rule component_le_norm_cart[THEN order_trans])
	apply (rule norm_blinfun[THEN order_trans])
	by (auto simp: norm_axis)

	lemma bounded_linear_matrix_blinfun_apply: "bounded_linear (\<lambda>x::(real^'n) \<Rightarrow>\<^sub>L (real^'m). matrix (blinfun_apply x))"
	apply standard
	subgoal by (vector blinfun.bilinear_simps matrix_def)
	subgoal by (vector blinfun.bilinear_simps matrix_def)
	apply (rule exI[where x="real (CARD('n) * CARD('m))"])
	apply (auto simp: matrix_def)
	apply (subst norm_vec_def)
	apply (rule L2_set_le_sum[THEN order_trans])
	apply simp
	apply auto
	apply (rule sum_mono[THEN order_trans])
	apply (subst norm_vec_def)
	apply (rule L2_set_le_sum)
	apply simp
	apply (rule sum_mono[THEN order_trans])
	apply (rule sum_mono)
	apply simp
	apply (rule abs_vec_nth_blinfun_apply_lemma)
	apply (simp add: abs_vec_nth_blinfun_apply_lemma)
	done

	lemma matrix_has_derivative:
	shows "((\<lambda>x::(real^'n)\<Rightarrow>\<^sub>L(real^'n). matrix (blinfun_apply x)) has_derivative (\<lambda>h. matrix (blinfun_apply h))) (at x)"
	apply (auto simp: has_derivative_at2)
	unfolding linear_linear
	subgoal by (rule bounded_linear_matrix_blinfun_apply)
	subgoal
	by (auto simp: blinfun.bilinear_simps matrix_def) vector
	done

	lemma
	matrix_comp_has_derivative[derivative_intros]:
	fixes f::"'a::real_normed_vector \<Rightarrow> ((real^'n)\<Rightarrow>\<^sub>L(real^'n))"
	assumes "(f has_derivative f') (at x within S)"
	shows "((\<lambda>x. matrix (blinfun_apply (f x))) has_derivative (\<lambda>x. matrix (f' x))) (at x within S)"
	using has_derivative_compose[OF assms matrix_has_derivative]
	by auto

	fun inner_floatariths where
	"inner_floatariths [] _ = Num 0"
	\| "inner_floatariths _ [] = Num 0"
	\| "inner_floatariths (x#xs) (y#ys) = Add (Mult x y) (inner_floatariths xs ys)"

	lemma interpret_floatarith_inner_eq:
	assumes "length xs = length ys"
	shows "interpret_floatarith (inner_floatariths xs ys) vs =
	(\<Sum>i<length ys. (interpret_floatariths xs vs ! i) * (interpret_floatariths ys vs ! i))"
	using assms
	proof (induction rule: list_induct2)
	case Nil
	then show ?case by simp
	next
	case (Cons x xs y ys)
	then show ?case
	unfolding length_Cons sum.lessThan_Suc_shift
	by simp
	qed

	lemma
	interpret_floatarith_inner_floatariths:
	assumes "length xs = DIM('a::executable_euclidean_space)"
	assumes "length ys = DIM('a)"
	assumes "eucl_of_list (interpret_floatariths xs vs) = (x::'a)"
	assumes "eucl_of_list (interpret_floatariths ys vs) = y"
	shows "interpret_floatarith (inner_floatariths xs ys) vs = x \<bullet> y"
	using assms
	by (subst euclidean_inner)
	(auto simp: interpret_floatarith_inner_eq sum_Basis_sum_nth_Basis_list eucl_of_list_inner
	index_nth_id
	intro!: euclidean_eqI[where 'a='a] sum.cong)

	lemma max_Var_floatarith_inner_floatariths[simp]:
	assumes "length f = length g"
	shows "max_Var_floatarith (inner_floatariths f g) = max (max_Var_floatariths f) (max_Var_floatariths g)"
	using assms
	by (induction f g rule: list_induct2) auto


	definition FDERIV_floatarith where
	"FDERIV_floatarith fa xs d = inner_floatariths (map (\<lambda>x. fold_const_fa (DERIV_floatarith x fa)) xs) d"
	\<comment> \<open>TODO: specialize to \<open>FDERIV_floatarith fa [0..<n] [m..<m + n]\<close> and do the rest with @{term subst_floatarith}?
	TODO: introduce approximation on type @{typ "real^'i^'j"} and use @{term jacobian}?\<close>

	lemma interpret_floatariths_map: "interpret_floatariths (map f xs) vs = map (\<lambda>x. interpret_floatarith (f x) vs) xs"
	- by (induct xs) (auto simp: )
	+ by (induct xs) auto

	lemma max_Var_floatarith_DERIV_floatarith:
	"max_Var_floatarith (DERIV_floatarith x fa) \<le> max_Var_floatarith fa"
	by (induction x fa rule: DERIV_floatarith.induct) (auto)

	lemma max_Var_floatarith_FDERIV_floatarith:
	"length xs = length d \<Longrightarrow>
	max_Var_floatarith (FDERIV_floatarith fa xs d) \<le> max (max_Var_floatarith fa) (max_Var_floatariths d)"
	unfolding FDERIV_floatarith_def
	by (auto simp: max_Var_floatariths_Max intro!: max_Var_floatarith_DERIV_floatarith[THEN order_trans]
	max_Var_floatarith_fold_const_fa[THEN order_trans])

	definition FDERIV_floatariths where
	"FDERIV_floatariths fas xs d = map (\<lambda>fa. FDERIV_floatarith fa xs d) fas"

	lemma max_Var_floatarith_FDERIV_floatariths:
	"length xs = length d \<Longrightarrow> max_Var_floatariths (FDERIV_floatariths fa xs d) \<le> max (max_Var_floatariths fa) (max_Var_floatariths d)"
	by (auto simp: FDERIV_floatariths_def max_Var_floatariths_Max
	intro!: max_Var_floatarith_FDERIV_floatarith[THEN order_trans])
	(auto simp: max_def)

	lemma length_FDERIV_floatariths[simp]:
	"length (FDERIV_floatariths fas xs ds) = length fas"
	by (auto simp: FDERIV_floatariths_def)

	lemma FDERIV_floatariths_nth[simp]:
	"i < length fas \<Longrightarrow> FDERIV_floatariths fas xs ds ! i = FDERIV_floatarith (fas ! i) xs ds"
	by (auto simp: FDERIV_floatariths_def)

	definition "FDERIV_n_floatariths fas xs ds n = ((\<lambda>x. FDERIV_floatariths x xs ds)^^n) fas"

	lemma FDERIV_n_floatariths_Suc[simp]:
	"FDERIV_n_floatariths fa xs ds 0 = fa"
	"FDERIV_n_floatariths fa xs ds (Suc n) = FDERIV_floatariths (FDERIV_n_floatariths fa xs ds n) xs ds"
	by (auto simp: FDERIV_n_floatariths_def)

	lemma length_FDERIV_n_floatariths[simp]: "length (FDERIV_n_floatariths fa xs ds n) = length fa"
	by (induction n) (auto simp: FDERIV_n_floatariths_def)

	lemma max_Var_floatarith_FDERIV_n_floatariths:
	"length xs = length d \<Longrightarrow> max_Var_floatariths (FDERIV_n_floatariths fa xs d n) \<le> max (max_Var_floatariths fa) (max_Var_floatariths d)"
	by (induction n)
	(auto intro!: max_Var_floatarith_FDERIV_floatariths[THEN order_trans] simp: FDERIV_n_floatariths_def)

	lemma interpret_floatarith_FDERIV_floatarith_cong:
	assumes rq: "\<And>i. i < max_Var_floatarith f \<Longrightarrow> rs ! i = qs ! i"
	assumes [simp]: "length ds = length xs" "length es = length xs"
	assumes "interpret_floatariths ds qs = interpret_floatariths es rs"
	shows "interpret_floatarith (FDERIV_floatarith f xs ds) qs =
	interpret_floatarith (FDERIV_floatarith f xs es) rs"
	apply (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_eq)
	apply (rule sum.cong[OF refl])
	subgoal premises prems for i
	proof -
	have "interpret_floatarith (DERIV_floatarith (xs ! i) f) qs = interpret_floatarith (DERIV_floatarith (xs ! i) f) rs"
	apply (rule interpret_floatarith_max_Var_cong)
	apply (auto simp: intro!: rq)
	by (metis leD le_trans max_Var_floatarith_DERIV_floatarith nat_less_le)
	moreover
	have "interpret_floatarith (ds ! i) qs = interpret_floatarith (es ! i) rs"
	using assms
	by (metis \<open>i \<in> {..<length xs}\<close> interpret_floatariths_nth lessThan_iff)
	ultimately show ?thesis by auto
	qed
	done

	theorem
	matrix_vector_mult_eq_list_of_eucl_nth:
	"(M::real^'n::enum^'m::enum) *v v =
	(\<Sum>i<CARD('m).
	(\<Sum>j<CARD('n). list_of_eucl M ! (i * CARD('n) + j) * list_of_eucl v ! j) *\<^sub>R Basis_list ! i)"
	using eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list[of "list_of_eucl M" "list_of_eucl v",
	where 'n='n and 'm = 'm]
	by auto

	definition "mmult_fa l m n AS BS =
	concat (map (\<lambda>i. map (\<lambda>k. inner_floatariths
	(map (\<lambda>j. AS ! (i * m + j)) [0..<m]) (map (\<lambda>j. BS ! (j * n + k)) [0..<m])) [0..<n]) [0..<l])"

	lemma length_mmult_fa[simp]: "length (mmult_fa l m n AS BS) = l * n"
	by (auto simp: mmult_fa_def length_concat o_def sum_list_distinct_conv_sum_set)

	lemma einterpret_mmult_fa:
	assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)" "Dl = CARD('l::enum)"
	"length A = CARD('l)CARD('m)" "length B = CARD('m)CARD('n)"
	shows "einterpret (mmult_fa Dl Dm Dn A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'l) vec) ** (einterpret B vs::((real, 'n::enum) vec, 'm) vec)"
	apply (vector matrix_matrix_mult_def)
	apply (auto simp: mmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2
	concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set
	interpret_floatarith_inner_eq)
	apply (subst sum_index_enum_eq)
	apply simp
	done

	lemma max_Var_floatariths_mmult_fa:
	assumes [simp]: "length A = D * E" "length B = E * F"
	shows "max_Var_floatariths (mmult_fa D E F A B) \<le> max (max_Var_floatariths A) (max_Var_floatariths B)"
	apply (auto simp: mmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI)
	apply (rule max.coboundedI1)
	apply (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2)
	apply (cases "F = 0")
	apply simp_all
	done

	lemma isDERIV_inner_iff:
	assumes "length xs = length ys"
	shows "isDERIV i (inner_floatariths xs ys) vs \<longleftrightarrow>
	(\<forall>k < length xs. isDERIV i (xs ! k) vs) \<and> (\<forall>k < length ys. isDERIV i (ys ! k) vs)"
	using assms
	by (induction xs ys rule: list_induct2) (auto simp: nth_Cons split: nat.splits)

	lemma isDERIV_Power: "isDERIV x (fa) vs \<Longrightarrow> isDERIV x (fa ^\<^sub>e n) vs"
	by (induction n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)

	lemma isDERIV_mmult_fa_nth:
	assumes "\<And>j. j < D * E \<Longrightarrow> isDERIV i (A ! j) xs"
	assumes "\<And>j. j < E * F \<Longrightarrow> isDERIV i (B ! j) xs"
	assumes [simp]: "length A = D * E" "length B = E * F" "j < D * F"
	shows "isDERIV i (mmult_fa D E F A B ! j) xs"
	using assms
	apply (cases "F = 0")
	apply (auto simp: mmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps)
	apply (metis add.commute assms(5) in_square_lemma less_square_imp_div_less mult.commute)
	done

	definition "mvmult_fa n m AS B =
	map (\<lambda>i. inner_floatariths (map (\<lambda>j. AS ! (i * m + j)) [0..<m]) (map (\<lambda>j. B ! j) [0..<m])) [0..<n]"

	lemma einterpret_mvmult_fa:
	assumes [simp]: "Dn = CARD('n::enum)" "Dm = CARD('m::enum)"
	"length A = CARD('n)*CARD('m)" "length B = CARD('m)"
	shows "einterpret (mvmult_fa Dn Dm A B) vs = (einterpret A vs::((real, 'm::enum) vec, 'n) vec) *v (einterpret B vs::(real, 'm) vec)"
	apply (vector matrix_vector_mult_def)
	apply (auto simp: mvmult_fa_def vec_nth_eucl_of_list_eq2 index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_eucl_of_list_eq
	concat_map_map_index length_concat o_def sum_list_distinct_conv_sum_set
	interpret_floatarith_inner_eq)
	apply (subst sum_index_enum_eq)
	apply simp
	done


	lemma max_Var_floatariths_mvult_fa:
	assumes [simp]: "length A = D * E" "length B = E"
	shows "max_Var_floatariths (mvmult_fa D E A B) \<le> max (max_Var_floatariths A) (max_Var_floatariths B)"
	apply (auto simp: mvmult_fa_def concat_map_map_index intro!: max_Var_floatariths_leI)
	apply (rule max.coboundedI1)
	by (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth max.coboundedI2)

	lemma isDERIV_mvmult_fa_nth:
	assumes "\<And>j. j < D * E \<Longrightarrow> isDERIV i (A ! j) xs"
	assumes "\<And>j. j < E \<Longrightarrow> isDERIV i (B ! j) xs"
	assumes [simp]: "length A = D * E" "length B = E" "j < D"
	shows "isDERIV i (mvmult_fa D E A B ! j) xs"
	using assms
	apply (auto simp: mvmult_fa_def concat_map_map_index isDERIV_inner_iff ac_simps)
	by (metis assms(5) in_square_lemma semiring_normalization_rules(24) semiring_normalization_rules(7))

	lemma max_Var_floatariths_mapI:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> max_Var_floatarith (f x) \<le> m"
	shows "max_Var_floatariths (map f xs) \<le> m"
	using assms
	by (force intro!: max_Var_floatariths_leI simp: in_set_conv_nth)

	lemma
	max_Var_floatariths_list_updateI:
	assumes "max_Var_floatariths xs \<le> m"
	assumes "max_Var_floatarith v \<le> m"
	assumes "i < length xs"
	shows "max_Var_floatariths (xs[i := v]) \<le> m"
	using assms
	apply (auto simp: nth_list_update intro!: max_Var_floatariths_leI )
	using max_Var_floatarith_le_max_Var_floatariths_nthI by blast

	lemma
	max_Var_floatariths_replicateI:
	assumes "max_Var_floatarith v \<le> m"
	shows "max_Var_floatariths (replicate n v) \<le> m"
	using assms
	by (auto intro!: max_Var_floatariths_leI )

	definition "FDERIV_n_floatarith fa xs ds n = ((\<lambda>x. FDERIV_floatarith x xs ds)^^n) fa"
	lemma FDERIV_n_floatariths_nth: "i < length fas \<Longrightarrow> FDERIV_n_floatariths fas xs ds n ! i = FDERIV_n_floatarith (fas ! i) xs ds n"
	by (induction n)
	(auto simp: FDERIV_n_floatarith_def FDERIV_floatariths_nth)


	lemma einterpret_fold_const_fa[simp]:
	"(einterpret (map (\<lambda>i. fold_const_fa (fa i)) xs) vs::'a::executable_euclidean_space) =
	einterpret (map fa xs) vs" if "length xs = DIM('a)"
	using that
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma einterpret_plus[simp]:
	shows "(einterpret (map (\<lambda>i. fa1 i + fa2 i) [0..<DIM('a)]) vs::'a) =
	einterpret (map fa1 [0..<DIM('a::executable_euclidean_space)]) vs + einterpret (map fa2 [0..<DIM('a)]) vs"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma einterpret_uminus[simp]:
	shows "(einterpret (map (\<lambda>i. - fa1 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
	- einterpret (map fa1 [0..<DIM('a)]) vs"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma diff_floatarith_conv_add_uminus: "a - b = a + - b" for a b::floatarith
	by (auto simp: minus_floatarith_def plus_floatarith_def uminus_floatarith_def)

	lemma einterpret_minus[simp]:
	shows "(einterpret (map (\<lambda>i. fa1 i - fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
	einterpret (map fa1 [0..<DIM('a)]) vs - einterpret (map fa2 [0..<DIM('a)]) vs"
	by (simp add: diff_floatarith_conv_add_uminus)

	lemma einterpret_scaleR[simp]:
	shows "(einterpret (map (\<lambda>i. fa1 * fa2 i) [0..<DIM('a)]) vs::'a::executable_euclidean_space) =
	interpret_floatarith (fa1) vs *\<^sub>R einterpret (map fa2 [0..<DIM('a)]) vs"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	lemma einterpret_nth[simp]:
	assumes [simp]: "length xs = DIM('a)"
	shows "(einterpret (map ((!) xs) [0..<DIM('a)]) vs::'a::executable_euclidean_space) = einterpret xs vs"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

	type_synonym 'n rvec = "(real, 'n) vec"

	lemma length_mvmult_fa[simp]: "length (mvmult_fa D E xs ys) = D"
	by (auto simp: mvmult_fa_def)

	lemma interpret_mvmult_nth:
	assumes "D = CARD('n::enum)"
	assumes "E = CARD('m::enum)"
	assumes "length xs = D * E"
	assumes "length ys = E"
	assumes "n < CARD('n)"
	shows "interpret_floatarith (mvmult_fa D E xs ys ! n) vs =
	((einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs) \<bullet> (Basis_list ! n)"
	proof -
	have "interpret_floatarith (mvmult_fa D E xs ys ! n) vs = einterpret (mvmult_fa D E xs ys) vs \<bullet> (Basis_list ! n::'n rvec)"
	using assms
	by (auto simp: eucl_of_list_inner)
	also
	from einterpret_mvmult_fa[OF assms(1,2), of xs ys vs]
	have "einterpret (mvmult_fa D E xs ys) vs = (einterpret xs vs::((real, 'm) vec, 'n) vec) *v einterpret ys vs"
	using assms by simp
	finally show ?thesis by simp
	qed


	lemmas [simp del] = fold_const_fa.simps

	lemma take_eq_map_nth: "n < length xs \<Longrightarrow> take n xs = map ((!) xs) [0..<n]"
	by (induction xs) (auto intro!: nth_equalityI)

	lemmas [simp del] = upt_rec_numeral
	lemmas map_nth_eq_take = take_eq_map_nth[symmetric]


	subsection \<open>Definition of Approximating Function using Affine Arithmetic\<close>

	lemma interpret_Floatreal: "interpret_floatarith (floatarith.Num f) vs = (real_of_float f)"
	by simp

	ML \<open>
	(* Make a congruence rule out of a defining equation for the interpretation

	th is one defining equation of f,
	i.e. th is "f (Cp ?t1 ... ?tn) = P(f ?t1, .., f ?tn)"
	Cp is a constructor pattern and P is a pattern

	The result is:
	[\|?A1 = f ?t1 ; .. ; ?An= f ?tn \|] ==> P (?A1, .., ?An) = f (Cp ?t1 .. ?tn)
	+ the a list of names of the A1 .. An, Those are fresh in the ctxt *)

	fun mk_congeq ctxt fs th =
	let
	val Const (fN, _) = th \|> Thm.prop_of \|> HOLogic.dest_Trueprop \|> HOLogic.dest_eq
	\|> fst \|> strip_comb \|> fst;
	val ((_, [th']), ctxt') = Variable.import true [th] ctxt;
	val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of th'));
	fun add_fterms (t as t1 $ t2) =
	if exists (fn f => Term.could_unify (t \|> strip_comb \|> fst, f)) fs
	then insert (op aconv) t
	else add_fterms t1 #> add_fterms t2
	\| add_fterms (t as Abs _) =
	if exists_Const (fn (c, _) => c = fN) t
	then K [t]
	else K []
	\| add_fterms _ = I;
	val fterms = add_fterms rhs [];
	val (xs, ctxt'') = Variable.variant_fixes (replicate (length fterms) "x") ctxt';
	val tys = map fastype_of fterms;
	val vs = map Free (xs ~~ tys);
	val env = fterms ~~ vs; (FIXME)
	fun replace_fterms (t as t1 $ t2) =
	(case AList.lookup (op aconv) env t of
	SOME v => v
	\| NONE => replace_fterms t1 $ replace_fterms t2)
	\| replace_fterms t =
	(case AList.lookup (op aconv) env t of
	SOME v => v
	\| NONE => t);
	fun mk_def (Abs (x, xT, t), v) =
	HOLogic.mk_Trueprop (HOLogic.all_const xT $ Abs (x, xT, HOLogic.mk_eq (v $ Bound 0, t)))
	\| mk_def (t, v) = HOLogic.mk_Trueprop (HOLogic.mk_eq (v, t));
	fun tryext x =
	(x RS @{lemma "(\<forall>x. f x = g x) \<Longrightarrow> f = g" by blast} handle THM _ => x);
	val cong =
	(Goal.prove ctxt'' [] (map mk_def env)
	(HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, replace_fterms rhs)))
	(fn {context = goal_ctxt, prems} =>
	Local_Defs.unfold0_tac goal_ctxt (map tryext prems) THEN resolve_tac goal_ctxt [th'] 1))
	RS sym;
	val (cong' :: vars') =
	Variable.export ctxt'' ctxt (cong :: map (Drule.mk_term o Thm.cterm_of ctxt'') vs);
	val vs' = map (fst o fst o Term.dest_Var o Thm.term_of o Drule.dest_term) vars';

	in (vs', cong') end;

	fun mk_congs ctxt eqs =
	let
	val fs = fold_rev (fn eq => insert (op =) (eq \|> Thm.prop_of \|> HOLogic.dest_Trueprop
	\|> HOLogic.dest_eq \|> fst \|> strip_comb
	\|> fst)) eqs [];
	val tys = fold_rev (fn f => fold (insert (op =)) (f \|> fastype_of \|> binder_types \|> tl)) fs [];
	val (vs, ctxt') = Variable.variant_fixes (replicate (length tys) "vs") ctxt;
	val subst =
	the o AList.lookup (op =)
	(map2 (fn T => fn v => (T, Thm.cterm_of ctxt' (Free (v, T)))) tys vs);
	fun prep_eq eq =
	let
	val (_, _ :: vs) = eq \|> Thm.prop_of \|> HOLogic.dest_Trueprop
	\|> HOLogic.dest_eq \|> fst \|> strip_comb;
	val subst = map_filter (fn Var v => SOME (v, subst (#2 v)) \| _ => NONE) vs;
	in Thm.instantiate (TVars.empty, Vars.make subst) eq end;
	val (ps, congs) = map_split (mk_congeq ctxt' fs o prep_eq) eqs;
	val bds = AList.make (K ([], [])) tys;
	in (ps ~~ Variable.export ctxt' ctxt congs, bds) end
	\<close>

	ML \<open>
	fun interpret_floatariths_congs ctxt =
	mk_congs ctxt @{thms interpret_floatarith.simps interpret_floatariths.simps}
	\|> fst
	\|> map snd
	\<close>

	ML \<open>
	fun preproc_form_conv ctxt =
	Simplifier.rewrite
	(put_simpset HOL_basic_ss ctxt addsimps
	(Named_Theorems.get ctxt @{named_theorems approximation_preproc}))\<close>

	ML \<open>fun reify_floatariths_tac ctxt i =
	CONVERSION (preproc_form_conv ctxt) i
	THEN REPEAT_ALL_NEW (fn i => resolve_tac ctxt (interpret_floatariths_congs ctxt) i) i\<close>

	method_setup reify_floatariths = \<open>
	Scan.succeed (fn ctxt => SIMPLE_METHOD' (reify_floatariths_tac ctxt))
	\<close> "reification of floatariths expression"

	schematic_goal reify_example:
	"[xs!i * xs!j, xs!i + xs!j powr (sin (xs!0)), xs!k + (2 / 3 * xs!i * xs!j)] = interpret_floatariths ?fas xs"
	by (reify_floatariths)

	ML \<open>fun interpret_floatariths_step_tac ctxt i = resolve_tac ctxt (interpret_floatariths_congs ctxt) i\<close>

	method_setup reify_floatariths_step = \<open>
	Scan.succeed (fn ctxt => SIMPLE_METHOD' (interpret_floatariths_step_tac ctxt))
	\<close> "reification of floatariths expression (step)"

	lemma eucl_of_list_interpret_floatariths_cong:
	fixes y::"'a::executable_euclidean_space"
	assumes "\<And>b. b \<in> Basis \<Longrightarrow> interpret_floatarith (fa (index Basis_list b)) vs = y \<bullet> b"
	assumes "length xs = DIM('a)"
	shows "eucl_of_list (interpret_floatariths (map fa [0..<DIM('a)]) vs) = y"
	apply (rule euclidean_eqI)
	apply (subst eucl_of_list_inner)
	by (auto simp: assms)

	lemma interpret_floatariths_fold_const_fa[simp]:
	"interpret_floatariths (map fold_const_fa ds) = interpret_floatariths ds"
	by (auto intro!: nth_equalityI)

	fun subst_floatarith where
	"subst_floatarith s (Add a b) = Add (subst_floatarith s a) (subst_floatarith s b)" \|
	"subst_floatarith s (Mult a b) = Mult (subst_floatarith s a) (subst_floatarith s b)" \|
	"subst_floatarith s (Minus a) = Minus (subst_floatarith s a)" \|
	"subst_floatarith s (Inverse a) = Inverse (subst_floatarith s a)" \|
	"subst_floatarith s (Cos a) = Cos (subst_floatarith s a)" \|
	"subst_floatarith s (Arctan a) = Arctan (subst_floatarith s a)" \|
	"subst_floatarith s (Min a b) = Min (subst_floatarith s a) (subst_floatarith s b)" \|
	"subst_floatarith s (Max a b) = Max (subst_floatarith s a) (subst_floatarith s b)" \|
	"subst_floatarith s (Abs a) = Abs (subst_floatarith s a)" \|
	"subst_floatarith s Pi = Pi" \|
	"subst_floatarith s (Sqrt a) = Sqrt (subst_floatarith s a)" \|
	"subst_floatarith s (Exp a) = Exp (subst_floatarith s a)" \|
	"subst_floatarith s (Powr a b) = Powr (subst_floatarith s a) (subst_floatarith s b)" \|
	"subst_floatarith s (Ln a) = Ln (subst_floatarith s a)" \|
	"subst_floatarith s (Power a i) = Power (subst_floatarith s a) i" \|
	"subst_floatarith s (Floor a) = Floor (subst_floatarith s a)" \|
	"subst_floatarith s (Num f) = Num f" \|
	"subst_floatarith s (Var n) = s n"

	lemma interpret_floatarith_subst_floatarith:
	assumes "max_Var_floatarith fa \<le> D"
	shows "interpret_floatarith (subst_floatarith s fa) vs =
	interpret_floatarith fa (map (\<lambda>i. interpret_floatarith (s i) vs) [0..<D])"
	using assms
	by (induction fa) auto

	lemma max_Var_floatarith_subst_floatarith_le[THEN order_trans]:
	assumes "length xs \<ge> max_Var_floatarith fa"
	shows "max_Var_floatarith (subst_floatarith ((!) xs) fa) \<le> max_Var_floatariths xs"
	using assms
	by (induction fa) (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth)

	lemma max_Var_floatariths_subst_floatarith_le[THEN order_trans]:
	assumes "length xs \<ge> max_Var_floatariths fas"
	shows "max_Var_floatariths (map (subst_floatarith ((!) xs)) fas) \<le> max_Var_floatariths xs"
	using assms
	by (induction fas) (auto simp: max_Var_floatarith_subst_floatarith_le)

	fun continuous_on_floatarith :: "floatarith \<Rightarrow> bool" where
	"continuous_on_floatarith (Add a b) = (continuous_on_floatarith a \<and> continuous_on_floatarith b)" \|
	"continuous_on_floatarith (Mult a b) = (continuous_on_floatarith a \<and> continuous_on_floatarith b)" \|
	"continuous_on_floatarith (Minus a) = continuous_on_floatarith a" \|
	"continuous_on_floatarith (Inverse a) = False" \|
	"continuous_on_floatarith (Cos a) = continuous_on_floatarith a" \|
	"continuous_on_floatarith (Arctan a) = continuous_on_floatarith a" \|
	"continuous_on_floatarith (Min a b) = (continuous_on_floatarith a \<and> continuous_on_floatarith b)" \|
	"continuous_on_floatarith (Max a b) = (continuous_on_floatarith a \<and> continuous_on_floatarith b)" \|
	"continuous_on_floatarith (Abs a) = continuous_on_floatarith a" \|
	"continuous_on_floatarith Pi = True" \|
	"continuous_on_floatarith (Sqrt a) = False" \|
	"continuous_on_floatarith (Exp a) = continuous_on_floatarith a" \|
	"continuous_on_floatarith (Powr a b) = False" \|
	"continuous_on_floatarith (Ln a) = False" \|
	"continuous_on_floatarith (Floor a) = False" \|
	"continuous_on_floatarith (Power a n) = (if n = 0 then True else continuous_on_floatarith a)" \|
	"continuous_on_floatarith (Num f) = True" \|
	"continuous_on_floatarith (Var n) = True"

	definition "Maxs\<^sub>e xs = fold (\<lambda>a b. floatarith.Max a b) xs"
	definition "norm2\<^sub>e n = Maxs\<^sub>e (map (\<lambda>j. Norm (map (\<lambda>i. Var (Suc j * n + i)) [0..<n])) [0..<n]) (Num 0)"

	definition "N\<^sub>r l = Num (float_of l)"

	lemma interpret_floatarith_Norm:
	"interpret_floatarith (Norm xs) vs = L2_set (\<lambda>i. interpret_floatarith (xs ! i) vs) {0..<length xs}"
	by (auto simp: Norm_def L2_set_def sum_list_sum_nth power2_eq_square)

	lemma interpret_floatarith_Nr[simp]: "interpret_floatarith (N\<^sub>r U) vs = real_of_float (float_of U)"
	by (auto simp: N\<^sub>r_def)


	fun list_updates where
	"list_updates [] _ xs = xs"
	\| "list_updates _ [] xs = xs"
	\| "list_updates (i#is) (u#us) xs = list_updates is us (xs[i:=u])"


	lemma list_updates_nth_notmem:
	assumes "length xs = length ys"
	assumes "i \<notin> set xs"
	shows "list_updates xs ys vs ! i = vs ! i"
	using assms
	by (induction xs ys arbitrary: i vs rule: list_induct2) auto

	lemma list_updates_nth_less:
	assumes "length xs = length ys" "distinct xs"
	assumes "i < length vs"
	shows "list_updates xs ys vs ! i = (if i \<in> set xs then ys ! (index xs i) else vs ! i)"
	using assms
	by (induction xs ys arbitrary: i vs rule: list_induct2) (auto simp: list_updates_nth_notmem)

	lemma length_list_updates[simp]: "length (list_updates xs ys vs) = length vs"
	by (induction xs ys vs rule: list_updates.induct) simp_all

	lemma list_updates_nth_ge[simp]:
	"x \<ge> length vs \<Longrightarrow> length xs = length ys \<Longrightarrow> list_updates xs ys vs ! x = vs ! x"
	apply (induction xs ys vs rule: list_updates.induct)
	apply (auto simp: nth_list_update)
	by (metis list_update_beyond nth_list_update_neq)

	lemma
	list_updates_nth:
	assumes [simp]: "length xs = length ys" "distinct xs"
	shows "list_updates xs ys vs ! i = (if i < length vs \<and> i \<in> set xs then ys ! index xs i else vs ! i)"
	by (auto simp: list_updates_nth_less list_updates_nth_notmem)

	lemma list_of_eucl_coord_update:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
	assumes [simp]: "distinct xs"
	assumes [simp]: "i \<in> Basis"
	assumes [simp]: "\<And>n. n \<in> set xs \<Longrightarrow> n < length vs"
	shows "list_updates xs (list_of_eucl (x + (p - x \<bullet> i) *\<^sub>R i::'a)) vs =
	(list_updates xs (list_of_eucl x) vs)[xs ! index Basis_list i := p]"
	apply (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update)
	apply (simp add: algebra_simps inner_Basis index_nth_id)
	apply (auto simp add: algebra_simps inner_Basis index_nth_id)
	done

	definition "eucl_of_env is vs = eucl_of_list (map (nth vs) is)"

	lemma list_updates_list_of_eucl_of_env[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
	shows "list_updates xs (list_of_eucl (eucl_of_env xs vs::'a)) vs = vs"
	by (auto intro!: nth_equalityI simp: list_updates_nth nth_list_update eucl_of_env_def)

	lemma nth_nth_eucl_of_env_inner:
	"b \<in> Basis \<Longrightarrow> length is = DIM('a) \<Longrightarrow> vs ! (is ! index Basis_list b) = eucl_of_env is vs \<bullet> b"
	for b::"'a::executable_euclidean_space"
	by (auto simp: eucl_of_env_def eucl_of_list_inner)

	lemma list_updates_idem[simp]:
	assumes "(\<And>i. i \<in> set X0 \<Longrightarrow> i < length vs)"
	shows "(list_updates X0 (map ((!) vs) X0) vs) = vs"
	using assms
	by (induction X0) auto


	lemma pairwise_orthogonal_Basis[intro, simp]: "pairwise orthogonal Basis"
	by (auto simp: pairwise_alt orthogonal_def inner_Basis)

	primrec freshs_floatarith where
	"freshs_floatarith (Var y) x \<longleftrightarrow> (y \<notin> set x)"
	\| "freshs_floatarith (Num a) x \<longleftrightarrow> True"
	\| "freshs_floatarith Pi x \<longleftrightarrow> True"
	\| "freshs_floatarith (Cos a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Abs a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Arctan a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Sqrt a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Exp a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Floor a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Power a n) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Minus a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Ln a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Inverse a) x \<longleftrightarrow> freshs_floatarith a x"
	\| "freshs_floatarith (Add a b) x \<longleftrightarrow> freshs_floatarith a x \<and> freshs_floatarith b x"
	\| "freshs_floatarith (Mult a b) x \<longleftrightarrow> freshs_floatarith a x \<and> freshs_floatarith b x"
	\| "freshs_floatarith (floatarith.Max a b) x \<longleftrightarrow> freshs_floatarith a x \<and> freshs_floatarith b x"
	\| "freshs_floatarith (floatarith.Min a b) x \<longleftrightarrow> freshs_floatarith a x \<and> freshs_floatarith b x"
	\| "freshs_floatarith (Powr a b) x \<longleftrightarrow> freshs_floatarith a x \<and> freshs_floatarith b x"

	lemma freshs_floatarith[simp]:
	assumes "freshs_floatarith fa ds" "length ds = length xs"
	shows "interpret_floatarith fa (list_updates ds xs vs) = interpret_floatarith fa vs"
	using assms
	by (induction fa) (auto simp: list_updates_nth_notmem)

	lemma freshs_floatarith_max_Var_floatarithI:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> max_Var_floatarith f \<le> x"
	shows "freshs_floatarith f xs"
	using assms Suc_n_not_le_n
	by (induction f; force)

	definition "freshs_floatariths fas xs = (\<forall>fa\<in>set fas. freshs_floatarith fa xs)"

	lemma freshs_floatariths_max_Var_floatarithsI:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> max_Var_floatariths f \<le> x"
	shows "freshs_floatariths f xs"
	using assms le_trans max_Var_floatarith_le_max_Var_floatariths
	by (force simp: freshs_floatariths_def intro!: freshs_floatarith_max_Var_floatarithI)

	lemma freshs_floatariths_freshs_floatarithI:
	assumes "\<And>fa. fa \<in> set fas \<Longrightarrow> freshs_floatarith fa xs"
	shows "freshs_floatariths fas xs"
	by (auto simp: freshs_floatariths_def assms)

	lemma fresh_floatariths_fresh_floatarithI:
	assumes "freshs_floatariths fas xs"
	assumes "fa \<in> set fas"
	shows "freshs_floatarith fa xs"
	using assms
	by (auto simp: freshs_floatariths_def)

	lemma fresh_floatariths_fresh_floatarith[simp]:
	"fresh_floatariths (fas) i \<Longrightarrow> fa \<in> set fas \<Longrightarrow> fresh_floatarith fa i"
	by (induction fas) auto

	lemma interpret_floatariths_fresh_cong:
	assumes "\<And>i. \<not>fresh_floatariths f i \<Longrightarrow> xs ! i = ys ! i"
	shows "interpret_floatariths f ys = interpret_floatariths f xs"
	by (auto intro!: nth_equalityI assms interpret_floatarith_fresh_cong simp: )

	fun subterms :: "floatarith \<Rightarrow> floatarith set" where
	"subterms (Add a b) = insert (Add a b) (subterms a \<union> subterms b)" \|
	"subterms (Mult a b) = insert (Mult a b) (subterms a \<union> subterms b)" \|
	"subterms (Min a b) = insert (Min a b) (subterms a \<union> subterms b)" \|
	"subterms (floatarith.Max a b) = insert (floatarith.Max a b) (subterms a \<union> subterms b)" \|
	"subterms (Powr a b) = insert (Powr a b) (subterms a \<union> subterms b)" \|
	"subterms (Inverse a) = insert (Inverse a) (subterms a)" \|
	"subterms (Cos a) = insert (Cos a) (subterms a)" \|
	"subterms (Arctan a) = insert (Arctan a) (subterms a)" \|
	"subterms (Abs a) = insert (Abs a) (subterms a)" \|
	"subterms (Sqrt a) = insert (Sqrt a) (subterms a)" \|
	"subterms (Exp a) = insert (Exp a) (subterms a)" \|
	"subterms (Ln a) = insert (Ln a) (subterms a)" \|
	"subterms (Power a n) = insert (Power a n) (subterms a)" \|
	"subterms (Floor a) = insert (Floor a) (subterms a)" \|
	"subterms (Minus a) = insert (Minus a) (subterms a)" \|
	"subterms Pi = {Pi}" \|
	"subterms (Var v) = {Var v}" \|
	"subterms (Num n) = {Num n}"

	lemma subterms_self[simp]: "fa2 \<in> subterms fa2"
	by (induction fa2) auto

	lemma interpret_floatarith_FDERIV_floatarith_eucl_of_env:\<comment> \<open>TODO: cleanup, reduce to DERIV?!\<close>
	assumes iD: "\<And>i. i < DIM('a) \<Longrightarrow> isDERIV (xs ! i) fa vs"
	assumes ds_fresh: "freshs_floatarith fa ds"
	assumes [simp]: "length xs = DIM ('a)" "length ds = DIM ('a)"
	"\<And>i. i \<in> set xs \<Longrightarrow> i < length vs" "distinct xs"
	"\<And>i. i \<in> set ds \<Longrightarrow> i < length vs" "distinct ds"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	(interpret_floatarith fa (list_updates xs (list_of_eucl x) vs))) has_derivative
	(\<lambda>d. interpret_floatarith (FDERIV_floatarith fa xs (map Var ds)) (list_updates ds (list_of_eucl d) vs) )
	) (at (eucl_of_env xs vs))"
	using iD ds_fresh
	proof (induction fa)
	case (Add fa1 fa2)
	then show ?case
	by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
	next
	case (Minus fa)
	then show ?case
	by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
	next
	case (Mult fa1 fa2)
	then show ?case
	by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
	next
	case (Inverse fa)
	then show ?case
	by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] power2_eq_square)
	next
	case (Cos fa)
	then show ?case
	by (auto intro!: derivative_eq_intros ext simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map add.commute minus_sin_cos_eq
	simp flip: mult_minus_left list_of_eucl_coord_update cos_pi_minus)
	next
	case (Arctan fa)
	then show ?case
	by (auto intro!: derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
	next
	case (Abs fa)
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Max fa1 fa2)
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Min fa1 fa2)
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case Pi
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Sqrt fa)
	then show ?case
	by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Exp fa)
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Powr fa1 fa2)
	then show ?case
	by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps divide_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Ln fa)
	then show ?case
	by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Power fa x2a)
	then show ?case
	apply (cases x2a)
	apply (auto intro!: DIM_positive derivative_eq_intros simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric])
	apply (auto intro!: ext simp: )
	by (simp add: semiring_normalization_rules(27))
	next
	case (Floor fa)
	then show ?case
	by (force intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	next
	case (Var x)
	then show ?case
	apply (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] if_distrib)
	apply (subst list_updates_nth)
	apply (auto intro!: derivative_eq_intros ext split: if_splits
	cong: if_cong simp: if_distribR eucl_of_list_if)
	apply (subst inner_commute)
	apply (rule arg_cong[where f="\<lambda>b. a \<bullet> b" for a])
	apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner list_updates_nth index_nth_id)
	done
	next
	case (Num x)
	then show ?case
	by (auto intro!: derivative_eq_intros DIM_positive simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths
	interpret_floatariths_map algebra_simps list_of_eucl_coord_update[symmetric] )
	qed

	lemma interpret_floatarith_FDERIV_floatarith_append:
	assumes iD: "\<And>i j. i < DIM('a) \<Longrightarrow> isDERIV i (fa) (list_of_eucl x @ params)"
	assumes m: "max_Var_floatarith fa \<le> DIM('a) + length params"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	interpret_floatarith fa (list_of_eucl x @ params)) has_derivative
	(\<lambda>d. interpret_floatarith
	(FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2*DIM('a)]))
	(list_of_eucl x @ params @ list_of_eucl d))) (at x)"
	proof -
	have m_nth: "ia < max_Var_floatarith fa \<Longrightarrow> ia < DIM('a) + length params" for ia
	using less_le_trans m by blast
	have "((\<lambda>xa::'a. interpret_floatarith fa
	(list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0))) has_derivative
	(\<lambda>d. interpret_floatarith (FDERIV_floatarith fa [0..<DIM('a)] (map Var [length params + DIM('a)..<length params + 2 * DIM('a)]))
	(list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d)
	(list_of_eucl x @ params @ replicate DIM('a) 0))))
	(at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)))"
	by (rule interpret_floatarith_FDERIV_floatarith_eucl_of_env)
	(auto intro!: iD freshs_floatarith_max_Var_floatarithI isDERIV_max_Var_floatarithI[OF iD]
	max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans]
	simp: nth_append add.commute less_diff_conv2 m_nth)
	moreover have "interpret_floatarith fa (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ params @ replicate DIM('a) 0)) =
	interpret_floatarith fa (list_of_eucl xa @ params)" for xa::'a
	apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: )
	apply (auto simp: list_updates_nth nth_append dest: m_nth)
	done
	moreover have "(list_updates [length params + DIM('a)..<length params + 2 * DIM('a)] (list_of_eucl d) (list_of_eucl x @ params @ replicate DIM('a) 0)) =
	(list_of_eucl x @ params @ list_of_eucl d)" for d::'a
	by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append add.commute)
	moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ params @ replicate DIM('a) 0)) = x"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append)
	ultimately show ?thesis by simp
	qed

	lemma interpret_floatarith_FDERIV_floatarith:
	assumes iD: "\<And>i j. i < DIM('a) \<Longrightarrow> isDERIV i (fa) (list_of_eucl x)"
	assumes m: "max_Var_floatarith fa \<le> DIM('a)"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	interpret_floatarith fa (list_of_eucl x)) has_derivative
	(\<lambda>d. interpret_floatarith
	(FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)]))
	(list_of_eucl x @ list_of_eucl d))) (at x)"
	using interpret_floatarith_FDERIV_floatarith_append[where params=Nil,simplified, OF assms]
	by simp

	lemma interpret_floatarith_eventually_isDERIV:
	assumes iD: "\<And>i j. i < DIM('a) \<Longrightarrow> isDERIV i fa (list_of_eucl x @ params)"
	assumes m: "max_Var_floatarith fa \<le> DIM('a::executable_euclidean_space) + length params"
	shows "\<forall>i < DIM('a). \<forall>\<^sub>F (x::'a) in at x. isDERIV i fa (list_of_eucl x @ params)"
	using iD m
	proof (induction fa)
	case (Inverse fa)
	then have "\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa (list_of_eucl x @ params)"
	by auto
	moreover
	have iD: "i < DIM('a) \<Longrightarrow> isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) \<noteq> 0" for i
	using Inverse.prems(1)[OF ] by force+
	from Inverse have m: "max_Var_floatarith fa \<le> DIM('a) + length params" by simp
	from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
	have "isCont (\<lambda>x. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
	then have "\<forall>\<^sub>F x in at x. interpret_floatarith fa (list_of_eucl x @ params) \<noteq> 0"
	using iD(2) tendsto_imp_eventually_ne
	by (auto simp: isCont_def)
	ultimately
	show ?case
	by (auto elim: eventually_elim2)
	next
	case (Sqrt fa)
	then have "\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa (list_of_eucl x @ params)"
	by auto
	moreover
	have iD: "i < DIM('a) \<Longrightarrow> isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i
	using Sqrt.prems(1)[OF ] by force+
	from Sqrt have m: "max_Var_floatarith fa \<le> DIM('a) + length params" by simp
	from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
	have "isCont (\<lambda>x. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
	then have "\<forall>\<^sub>F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0"
	using iD(2) order_tendstoD
	by (auto simp: isCont_def)
	ultimately
	show ?case
	by (auto elim: eventually_elim2)
	next
	case (Powr fa1 fa2)
	then have "\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa1 (list_of_eucl x @ params)"
	"\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa2 (list_of_eucl x @ params)"
	by auto
	moreover
	have iD: "i < DIM('a) \<Longrightarrow> isDERIV i fa1 (list_of_eucl x @ params)" "interpret_floatarith fa1 (list_of_eucl x @ params) > 0"
	for i
	using Powr.prems(1) by force+
	from Powr have m: "max_Var_floatarith fa1 \<le> DIM('a) + length params" by simp
	from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
	have "isCont (\<lambda>x. interpret_floatarith fa1 (list_of_eucl x @ params)) x" by simp
	then have "\<forall>\<^sub>F x in at x. interpret_floatarith fa1 (list_of_eucl x @ params) > 0"
	using iD(2) order_tendstoD
	by (auto simp: isCont_def)
	ultimately
	show ?case
	apply safe
	subgoal for i
	apply (safe dest!: spec[of _ i])
	subgoal premises prems
	using prems(1,3,4)
	by eventually_elim auto
	done
	done
	next
	case (Ln fa)
	then have "\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa (list_of_eucl x @ params)"
	by auto
	moreover
	have iD: "i < DIM('a) \<Longrightarrow> isDERIV i fa (list_of_eucl x @ params)" "interpret_floatarith fa (list_of_eucl x @ params) > 0" for i
	using Ln.prems(1)[OF ] by force+
	from Ln have m: "max_Var_floatarith fa \<le> DIM('a) + length params" by simp
	from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
	have "isCont (\<lambda>x. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
	then have "\<forall>\<^sub>F x in at x. interpret_floatarith fa (list_of_eucl x @ params) > 0"
	using iD(2) order_tendstoD
	by (auto simp: isCont_def)
	ultimately
	show ?case
	by (auto elim: eventually_elim2)
	next
	case (Power fa m) then show ?case by (cases m) auto
	next
	case (Floor fa)
	then have "\<forall>i<DIM('a). \<forall>\<^sub>F x in at x. isDERIV i fa (list_of_eucl x @ params)"
	by auto
	moreover
	have iD: "i < DIM('a) \<Longrightarrow> isDERIV i fa (list_of_eucl x @ params)"
	"interpret_floatarith fa (list_of_eucl x @ params) \<notin> \<int>" for i
	using Floor.prems(1)[OF ] by force+
	from Floor have m: "max_Var_floatarith fa \<le> DIM('a) + length params" by simp
	from has_derivative_continuous[OF interpret_floatarith_FDERIV_floatarith_append, OF iD(1) m]
	have cont: "isCont (\<lambda>x. interpret_floatarith fa (list_of_eucl x @ params)) x" by simp
	let ?i = "\<lambda>x. interpret_floatarith fa (list_of_eucl x @ params)"
	have "\<forall>\<^sub>F y in at x. ?i y > floor (?i x)" "\<forall>\<^sub>F y in at x. ?i y < ceiling (?i x)"
	using cont
	by (auto simp: isCont_def eventually_floor_less eventually_less_ceiling iD(2))
	then have "\<forall>\<^sub>F x in at x. ?i x \<notin> \<int>"
	apply eventually_elim
	apply (auto simp: Ints_def)
	by linarith
	ultimately
	show ?case
	by (auto elim: eventually_elim2)
	qed (fastforce intro: DIM_positive elim: eventually_elim2)+

	lemma eventually_isFDERIV:
	assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)"
	assumes m: "max_Var_floatariths fas \<le> DIM('a::executable_euclidean_space) + length params"
	shows "\<forall>\<^sub>F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)"
	by (auto simp: isFDERIV_def all_nat_less_eq eventually_ball_finite_distrib isFDERIV_lengthD[OF iD]
	intro!: interpret_floatarith_eventually_isDERIV[OF isFDERIV_uptD[OF iD], rule_format]
	max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m)

	lemma isFDERIV_eventually_isFDERIV:
	assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x@params)"
	assumes m: "max_Var_floatariths fas \<le> DIM('a::executable_euclidean_space) + length params"
	shows "\<forall>\<^sub>F (x::'a) in at x. isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ params)"
	by (rule eventually_isFDERIV) (use assms in \<open>auto simp: isFDERIV_def\<close>)

	lemma interpret_floatarith_FDERIV_floatariths_eucl_of_env:
	assumes iD: "isFDERIV DIM('a) xs fas vs"
	assumes fresh: "freshs_floatariths (fas) ds"
	assumes [simp]: "length ds = DIM ('a)"
	"\<And>i. i \<in> set xs \<Longrightarrow> i < length vs" "distinct xs"
	"\<And>i. i \<in> set ds \<Longrightarrow> i < length vs" "distinct ds"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	eucl_of_list
	(interpret_floatariths fas (list_updates xs (list_of_eucl x) vs))::'a) has_derivative
	(\<lambda>d. eucl_of_list (interpret_floatariths
	(FDERIV_floatariths fas xs (map Var ds))
	(list_updates ds (list_of_eucl d) vs)))) (at (eucl_of_env xs vs))"
	by (subst has_derivative_componentwise_within)
	(auto simp add: eucl_of_list_inner isFDERIV_lengthD[OF iD]
	intro!: interpret_floatarith_FDERIV_floatarith_eucl_of_env iD[THEN isFDERIV_isDERIV_D]
	fresh_floatariths_fresh_floatarithI fresh)

	lemma interpret_floatarith_FDERIV_floatariths_append:
	assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x @ ramsch)"
	assumes m: "max_Var_floatariths fas \<le> DIM('a) + length ramsch"
	assumes [simp]: "length fas = DIM('a)"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	eucl_of_list
	(interpret_floatariths fas (list_of_eucl x@ramsch))::'a) has_derivative
	(\<lambda>d. eucl_of_list (interpret_floatariths
	(FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)+length ramsch..<2*DIM('a) + length ramsch]))
	(list_of_eucl x @ ramsch @ list_of_eucl d)))) (at x)"
	proof -
	have m_nth: "ia < max_Var_floatariths fas \<Longrightarrow> ia < DIM('a) + length ramsch" for ia
	using m by simp
	have m_nth': "ia < max_Var_floatarith (fas ! j) \<Longrightarrow> ia < DIM('a) + length ramsch" if "j < DIM('a)" for j ia
	using m_nth max_Var_floatariths_lessI that by auto

	have "((\<lambda>xa::'a. eucl_of_list
	(interpret_floatariths fas
	(list_updates [0..<DIM('a)] (list_of_eucl xa)
	(list_of_eucl x @ ramsch @ replicate DIM('a) 0)))::'a) has_derivative
	(\<lambda>d. eucl_of_list
	(interpret_floatariths
	(FDERIV_floatariths fas [0..<DIM('a)] (map Var [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)]))
	(list_updates [length ramsch + DIM('a)..<length ramsch + 2 * DIM('a)] (list_of_eucl d)
	(list_of_eucl x @ ramsch @ replicate DIM('a) 0)))))
	(at (eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)))"
	by (rule interpret_floatarith_FDERIV_floatariths_eucl_of_env[of
	"[0..<DIM('a)]" fas "list_of_eucl x@ramsch@replicate DIM('a) 0" "[length ramsch+DIM('a)..<length ramsch+2*DIM('a)]"])
	(auto intro!: iD[THEN isFDERIV_uptD] freshs_floatarith_max_Var_floatarithI isFDERIV_max_Var_congI[OF iD]
	max_Var_floatarith_le_max_Var_floatariths[THEN order_trans] m[THEN order_trans]
	freshs_floatariths_max_Var_floatarithsI simp: nth_append m add.commute less_diff_conv2 m_nth)
	moreover have "interpret_floatariths fas (list_updates [0..<DIM('a)] (list_of_eucl xa) (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) =
	interpret_floatariths fas (list_of_eucl xa @ ramsch)" for xa::'a
	apply (auto intro!: nth_equalityI interpret_floatarith_max_Var_cong simp: )
	apply (auto simp: list_updates_nth nth_append dest: m_nth')
	done
	moreover have
	"(list_updates [DIM('a) + length ramsch..<length ramsch + 2 * DIM('a)]
	(list_of_eucl d)
	(list_of_eucl x @ ramsch @ replicate DIM('a) 0)) =
	(list_of_eucl x @ ramsch @ list_of_eucl d)" for d::'a
	by (auto simp: intro!: nth_equalityI simp: list_updates_nth nth_append)
	moreover have "(eucl_of_env [0..<DIM('a)] (list_of_eucl x @ ramsch @ replicate DIM('a) 0)) = x"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_env_def eucl_of_list_inner nth_append)
	ultimately show ?thesis by (simp add: add.commute)
	qed

	lemma interpret_floatarith_FDERIV_floatariths:
	assumes iD: "isFDERIV DIM('a) [0..<DIM('a)] fas (list_of_eucl x)"
	assumes m: "max_Var_floatariths fas \<le> DIM('a)"
	assumes [simp]: "length fas = DIM('a)"
	shows "((\<lambda>x::'a::executable_euclidean_space.
	eucl_of_list
	(interpret_floatariths fas (list_of_eucl x))::'a) has_derivative
	(\<lambda>d. eucl_of_list (interpret_floatariths
	(FDERIV_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2*DIM('a)]))
	(list_of_eucl x @ list_of_eucl d)))) (at x)"
	using interpret_floatarith_FDERIV_floatariths_append[where ramsch=Nil, simplified, OF assms]
	by simp

	lemma continuous_on_min[continuous_intros]:
	fixes f g :: "'a::topological_space \<Rightarrow> 'b::linorder_topology"
	shows "continuous_on A f \<Longrightarrow> continuous_on A g \<Longrightarrow> continuous_on A (\<lambda>x. min (f x) (g x))"
	by (auto simp: continuous_on_def intro!: tendsto_min)

	lemmas [continuous_intros] = continuous_on_max
	lemma continuous_on_if_const[continuous_intros]:
	"continuous_on s f \<Longrightarrow> continuous_on s g \<Longrightarrow> continuous_on s (\<lambda>x. if p then f x else g x)"
	by (cases p) auto

	lemma continuous_on_floatarith:
	assumes "continuous_on_floatarith fa" "length xs = DIM('a)" "distinct xs"
	shows "continuous_on UNIV (\<lambda>x. interpret_floatarith fa (list_updates xs (list_of_eucl (x::'a::executable_euclidean_space)) vs))"
	using assms
	by (induction fa)
	(auto intro!: continuous_intros split: if_splits simp: list_updates_nth list_of_eucl_nth_if)

	fun open_form :: "form \<Rightarrow> bool" where
	"open_form (Bound x a b f) = False" \|
	"open_form (Assign x a f) = False" \|
	"open_form (Less a b) \<longleftrightarrow> continuous_on_floatarith a \<and> continuous_on_floatarith b" \|
	"open_form (LessEqual a b) = False" \|
	"open_form (AtLeastAtMost x a b) = False" \|
	"open_form (Conj f g) \<longleftrightarrow> open_form f \<and> open_form g" \|
	"open_form (Disj f g) \<longleftrightarrow> open_form f \<and> open_form g"

	lemma open_form:
	assumes "open_form f" "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
	shows "open (Collect (\<lambda>x::'a. interpret_form f (list_updates xs (list_of_eucl x) vs)))"
	using assms
	by (induction f) (auto intro!: open_Collect_less continuous_on_floatarith open_Collect_conj open_Collect_disj)

	primrec isnFDERIV where
	"isnFDERIV N fas xs ds vs 0 = True"
	\| "isnFDERIV N fas xs ds vs (Suc n) \<longleftrightarrow>
	isFDERIV N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs \<and>
	isnFDERIV N fas xs ds vs n"

	lemma one_add_square_eq_0: "1 + (x)\<^sup>2 \<noteq> (0::real)"
	by (sos "((R<1 + (([~1] * A=0) + (R<1 * (R<1 * [x]^2)))))")

	lemma isDERIV_fold_const_fa[intro]:
	assumes "isDERIV x fa vs"
	shows "isDERIV x (fold_const_fa fa) vs"
	using assms
	apply (induction fa)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal for fa n
	by (cases n) (auto simp: fold_const_fa.simps split: floatarith.splits nat.splits)
	subgoal
	by (auto simp: fold_const_fa.simps split: floatarith.splits) (subst (asm) fold_const_fa[symmetric], force)+
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	subgoal by (auto simp: fold_const_fa.simps split: floatarith.splits)
	done

	lemma isDERIV_fold_const_fa_minus[intro!]:
	assumes "isDERIV x (fold_const_fa fa) vs"
	shows "isDERIV x (fold_const_fa (Minus fa)) vs"
	using assms
	by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits)

	lemma isDERIV_fold_const_fa_plus[intro!]:
	assumes "isDERIV x (fold_const_fa fa) vs"
	assumes "isDERIV x (fold_const_fa fb) vs"
	shows "isDERIV x (fold_const_fa (Add fa fb)) vs"
	using assms
	by (induction fa)
	(auto simp: fold_const_fa.simps
	split: floatarith.splits option.splits)

	lemma isDERIV_fold_const_fa_mult[intro!]:
	assumes "isDERIV x (fold_const_fa fa) vs"
	assumes "isDERIV x (fold_const_fa fb) vs"
	shows "isDERIV x (fold_const_fa (Mult fa fb)) vs"
	using assms
	by (induction fa)
	(auto simp: fold_const_fa.simps
	split: floatarith.splits option.splits)

	lemma isDERIV_fold_const_fa_power[intro!]:
	assumes "isDERIV x (fold_const_fa fa) vs"
	shows "isDERIV x (fold_const_fa (fa ^\<^sub>e n)) vs"
	apply (cases n, simp add: fold_const_fa.simps split: floatarith.splits)
	using assms
	by (induction fa)
	(auto simp: fold_const_fa.simps split: floatarith.splits option.splits)

	lemma isDERIV_fold_const_fa_inverse[intro!]:
	assumes "isDERIV x (fold_const_fa fa) vs"
	assumes "interpret_floatarith fa vs \<noteq> 0"
	shows "isDERIV x (fold_const_fa (Inverse fa)) vs"
	using assms
	by (simp add: fold_const_fa.simps)

	lemma add_square_ne_zero[simp]: "(y::'a::linordered_idom) > 0 \<Longrightarrow> y + x\<^sup>2 \<noteq> 0"
	by auto (metis less_add_same_cancel2 power2_less_0)

	lemma isDERIV_FDERIV_floatarith:
	assumes "isDERIV x fa vs" "\<And>i. i < length ds \<Longrightarrow> isDERIV x (ds ! i) vs"
	assumes [simp]: "length xs = length ds"
	shows "isDERIV x (FDERIV_floatarith fa xs ds) vs"
	using assms
	apply (induction fa)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal for fa n by (cases n) (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	subgoal by (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	done

	lemma isDERIV_FDERIV_floatariths:
	assumes "isFDERIV N xs fas vs" "isFDERIV N xs ds vs" and [simp]: "length fas = length ds"
	shows "isFDERIV N xs (FDERIV_floatariths fas xs ds) vs"
	using assms
	by (auto simp: isFDERIV_def FDERIV_floatariths_def intro!: isDERIV_FDERIV_floatarith)

	lemma isFDERIV_imp_isFDERIV_FDERIV_n:
	assumes "length fas = length ds"
	shows "isFDERIV N xs fas vs \<Longrightarrow> isFDERIV N xs ds vs \<Longrightarrow>
	isFDERIV N xs (FDERIV_n_floatariths fas xs ds n) vs"
	using assms
	by (induction n) (auto intro!: isDERIV_FDERIV_floatariths)

	lemma isFDERIV_map_Var:
	assumes [simp]: "length ds = N" "length xs = N"
	shows "isFDERIV N xs (map Var ds) vs"
	by (auto simp: isFDERIV_def)

	theorem isFDERIV_imp_isnFDERIV:
	assumes "isFDERIV N xs fas vs" and [simp]: "length fas = N" "length xs = N" "length ds = N"
	shows "isnFDERIV N fas xs ds vs n"
	using assms
	by (induction n) (auto intro!: isFDERIV_imp_isFDERIV_FDERIV_n isFDERIV_map_Var)

	lemma eventually_isnFDERIV:
	assumes iD: "isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl (d::'a)) n"
	assumes m: "max_Var_floatariths fas \<le> 2 * DIM('a::executable_euclidean_space)"
	shows "\<forall>\<^sub>F (x::'a) in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2*DIM('a)] (list_of_eucl x @ list_of_eucl d) n"
	using iD
	proof (induction n)
	case (Suc n)
	then have 1: "\<forall>\<^sub>F x in at x. isnFDERIV DIM('a) fas [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl x @ list_of_eucl d) n"
	and 2: "isFDERIV DIM('a) [0..<DIM('a)] (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n)
	(list_of_eucl x @ list_of_eucl d)"
	by simp_all
	have "max_Var_floatariths (FDERIV_n_floatariths fas [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]) n) \<le>
	DIM('a) + length (list_of_eucl d)"
	by (auto intro!: max_Var_floatarith_FDERIV_n_floatariths[THEN order_trans] m[THEN order_trans])
	from eventually_isFDERIV[OF 2 this] 1
	show ?case
	by eventually_elim simp
	qed simp

	lemma isFDERIV_open:
	assumes "max_Var_floatariths fas \<le> DIM('a)"
	shows "open {x::'a. isFDERIV DIM('a::executable_euclidean_space) [0..<DIM('a)] fas (list_of_eucl x)}"
	(is "open (Collect ?s)")
	proof (safe intro!: topological_space_class.openI)
	fix x::'a assume x: "?s x"
	with eventually_isFDERIV[where 'a='a, of fas x Nil]
	have "\<forall>\<^sub>F x in at x. x \<in> Collect ?s"
	by (auto simp: assms)
	then obtain S where "open S" "x \<in> S"
	"(\<forall>xa\<in>S. xa \<noteq> x \<longrightarrow> ?s xa)"
	unfolding eventually_at_topological
	by auto
	with x show "\<exists>T. open T \<and> x \<in> T \<and> T \<subseteq> Collect ?s"
	by (auto intro!: exI[where x=S])
	qed

	lemma interpret_floatarith_FDERIV_floatarith_eq:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "length ds = DIM('a)"
	shows "interpret_floatarith (FDERIV_floatarith fa xs ds) vs =
	einterpret (map (\<lambda>x. DERIV_floatarith x fa) xs) vs \<bullet> (einterpret ds vs::'a)"
	by (auto simp: FDERIV_floatarith_def interpret_floatarith_inner_floatariths)

	lemma
	interpret_floatariths_FDERIV_floatariths_cong:
	assumes [simp]: "length d1s = DIM('a::executable_euclidean_space)" "length d2s = DIM('a)" "length fas1 = length fas2"
	assumes fresh1: "freshs_floatariths fas1 d1s"
	assumes fresh2: "freshs_floatariths fas2 d2s"
	assumes eq1: "\<And>i. i < length fas1 \<Longrightarrow> interpret_floatariths (map (\<lambda>x. DERIV_floatarith x (fas1 ! i)) [0..<DIM('a)]) xs1 =
	interpret_floatariths (map (\<lambda>x. DERIV_floatarith x (fas2 ! i)) [0..<DIM('a)]) xs2"
	assumes eq2: "\<And>i. i < DIM('a) \<Longrightarrow> xs1 ! (d1s ! i) = xs2 ! (d2s ! i)"
	shows "interpret_floatariths (FDERIV_floatariths fas1 [0..<DIM('a)] (map floatarith.Var d1s)) xs1 =
	interpret_floatariths (FDERIV_floatariths fas2 [0..<DIM('a)] (map floatarith.Var d2s)) xs2"
	proof -
	note eq1
	moreover have "interpret_floatariths (map Var d1s) (xs1) =
	interpret_floatariths (map Var d2s) (xs2)"
	by (auto intro!: nth_equalityI eq2)
	ultimately
	show ?thesis
	by (auto intro!: nth_equalityI simp: interpret_floatarith_FDERIV_floatarith_eq)
	qed

	lemma subst_floatarith_Var_DERIV_floatarith:
	assumes "\<And>x. x = n \<longleftrightarrow> s x = n"
	shows "subst_floatarith (\<lambda>x. Var (s x)) (DERIV_floatarith n fa) =
	DERIV_floatarith n (subst_floatarith (\<lambda>x. Var (s x)) fa)"
	using assms
	proof (induction fa)
	case (Power fa n)
	then show ?case by (cases n) auto
	qed force+

	lemma subst_floatarith_inner_floatariths[simp]:
	assumes "length fs = length gs"
	shows "subst_floatarith s (inner_floatariths fs gs) =
	inner_floatariths (map (subst_floatarith s) fs) (map (subst_floatarith s) gs)"
	using assms
	by (induction rule: list_induct2) auto

	fun_cases subst_floatarith_Num: "subst_floatarith s fa = Num y"
	and subst_floatarith_Add: "subst_floatarith s fa = Add x y"
	and subst_floatarith_Minus: "subst_floatarith s fa = Minus y"

	lemma Num_eq_subst_Var[simp]: "Num x = subst_floatarith (\<lambda>x. Var (s x)) fa \<longleftrightarrow> fa = Num x"
	by (cases fa) auto

	lemma Add_eq_subst_VarE:
	assumes "Add fa1 fa2 = subst_floatarith (\<lambda>x. Var (s x)) fa"
	obtains a1 a2 where "fa = Add a1 a2" "fa1 = subst_floatarith (\<lambda>x. Var (s x)) a1"
	"fa2 = subst_floatarith (\<lambda>x. Var (s x)) a2"
	using assms
	by (cases fa) auto

	lemma subst_floatarith_eq_self[simp]: "subst_floatarith s f = f" if "max_Var_floatarith f = 0"
	using that by (induction f) auto

	lemma fold_const_fa_unique: "False" if "(\<And>x. f = Num x)"
	using that[of 0] that[of 1]
	by auto

	lemma zero_unique: False if "(\<And>x::float. x = 0)"
	using that[of 0] that[of 1]
	by auto

	lemma fold_const_fa_Mult_eq_NumE:
	assumes "fold_const_fa (Mult a b) = Num x"
	obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y * z"
	\| y where "fold_const_fa a = Num 0" "x = 0"
	\| y where "fold_const_fa b = Num 0" "x = 0"
	using assms
	by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits
	elim!: dest_Num_fa_Some dest_Num_fa_None)

	lemma fold_const_fa_Add_eq_NumE:
	assumes "fold_const_fa (Add a b) = Num x"
	obtains y z where "fold_const_fa a = Num y" "fold_const_fa b = Num z" "x = y + z"
	using assms
	by atomize_elim (auto simp: fold_const_fa.simps split!: option.splits if_splits
	elim!: dest_Num_fa_Some dest_Num_fa_None)

	lemma subst_floatarith_Var_fold_const_fa[symmetric]:
	"fold_const_fa (subst_floatarith (\<lambda>x. Var (s x)) fa) =
	subst_floatarith (\<lambda>x. Var (s x)) (fold_const_fa fa)"
	proof (induction fa)
	case (Add fa1 fa2)
	then show ?case
	apply (auto simp: fold_const_fa.simps
	split!: floatarith.splits option.splits if_splits
	elim!: dest_Num_fa_Some)
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	done
	next
	case (Mult fa1 fa2)
	then show ?case
	apply (auto simp: fold_const_fa.simps
	split!: floatarith.splits option.splits if_splits
	elim!: dest_Num_fa_Some)
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	apply (metis Num_eq_subst_Var dest_Num_fa.simps(1) option.simps(3))
	done
	next
	case (Min)
	then show ?case
	by (auto simp: fold_const_fa.simps split: floatarith.splits)
	next
	case (Max)
	then show ?case
	by (auto simp: fold_const_fa.simps split: floatarith.splits)
	qed (auto simp: fold_const_fa.simps
	split!: floatarith.splits option.splits if_splits
	elim!: dest_Num_fa_Some)

	lemma subst_floatarith_eq_Num[simp]: "(subst_floatarith (\<lambda>x. Var (s x)) fa = Num x) \<longleftrightarrow> fa = Num x"
	- by (induction fa) (auto simp: )
	+ by (induction fa) auto

	lemma fold_const_fa_subst_eq_Num0_iff[simp]:
	"fold_const_fa (subst_floatarith (\<lambda>x. Var (s x)) fa) = Num x \<longleftrightarrow> fold_const_fa fa = Num x"
	unfolding subst_floatarith_Var_fold_const_fa[symmetric]
	by simp

	lemma subst_floatarith_Var_FDERIV_floatarith:
	assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)"
	assumes eq: "\<And>x y. x \<in> set xs \<Longrightarrow> (y = x) = (s y = x)"
	shows "subst_floatarith (\<lambda>x. Var (s x)) (FDERIV_floatarith fa xs ds) =
	(FDERIV_floatarith (subst_floatarith (\<lambda>x. Var (s x)) fa) xs (map (subst_floatarith (\<lambda>x. Var (s x))) ds))"
	proof -
	have [simp]: "\<And>x. x \<in> set xs \<Longrightarrow> subst_floatarith (\<lambda>x. Var (s x)) (DERIV_floatarith x fa1) =
	(DERIV_floatarith x (subst_floatarith (\<lambda>x. Var (s x)) fa1))"
	for fa1
	by (rule subst_floatarith_Var_DERIV_floatarith) (rule eq)
	have map_eq: "(map (\<lambda>xa. if xa = s x then Num 1 else Num 0) xs) =
	(map (\<lambda>xa. if xa = x then Num 1 else Num 0) xs)"
	for x
	apply (subst map_eq_conv)
	using eq[of x x] eq[of "s x"]
	- by (auto simp: )
	+ by auto
	show ?thesis
	using len
	by (induction fa)
	(auto simp: FDERIV_floatarith_def o_def if_distrib
	subst_floatarith_Var_fold_const_fa fold_const_fa.simps(18) map_eq
	cong: map_cong if_cong)
	qed

	lemma subst_floatarith_Var_FDERIV_n_nth:
	assumes len: "length xs = DIM('a::executable_euclidean_space)" and [simp]: "length ds = DIM('a)"
	assumes eq: "\<And>x y. x \<in> set xs \<Longrightarrow> (y = x) = (s y = x)"
	assumes [simp]: "i < length fas"
	shows "subst_floatarith (\<lambda>x. Var (s x)) (FDERIV_n_floatariths fas xs ds n ! i) =
	(FDERIV_n_floatariths (map (subst_floatarith (\<lambda>x. Var (s x))) fas) xs (map (subst_floatarith (\<lambda>x. Var (s x))) ds) n ! i)"
	proof (induction n)
	case (Suc n)
	show ?case
	by (simp add: subst_floatarith_Var_FDERIV_floatarith[OF len _ eq] Suc.IH[symmetric])
	qed simp

	lemma subst_floatarith_Var_max_Var_floatarith:
	assumes "\<And>i. i < max_Var_floatarith fa \<Longrightarrow> s i = i"
	shows "subst_floatarith (\<lambda>i. Var (s i)) fa = fa"
	using assms
	by (induction fa) auto

	lemma interpret_floatarith_subst_floatarith_idem:
	assumes mv: "max_Var_floatarith fa \<le> length vs"
	assumes idem: "\<And>j. j < max_Var_floatarith fa \<Longrightarrow> vs ! s j = vs ! j"
	shows "interpret_floatarith (subst_floatarith (\<lambda>i. Var (s i)) fa) vs = interpret_floatarith fa vs"
	using assms
	by (induction fa) auto

	lemma isDERIV_subst_Var_floatarith:
	assumes mv: "max_Var_floatarith fa \<le> length vs"
	assumes idem: "\<And>j. j < max_Var_floatarith fa \<Longrightarrow> vs ! s j = vs ! j"
	assumes "\<And>j. s j = i \<longleftrightarrow> j = i"
	shows "isDERIV i (subst_floatarith (\<lambda>i. Var (s i)) fa) vs = isDERIV i fa vs"
	using mv idem
	proof (induction fa)
	case (Power fa n)
	then show ?case by (cases n) auto
	qed (auto simp: interpret_floatarith_subst_floatarith_idem)

	lemma isFDERIV_subst_Var_floatarith:
	assumes mv: "max_Var_floatariths fas \<le> length vs"
	assumes idem: "\<And>j. j < max_Var_floatariths fas \<Longrightarrow> vs ! (s j) = vs ! j"
	assumes "\<And>i j. i \<in> set xs \<Longrightarrow> s j = i \<longleftrightarrow> j = i"
	shows "isFDERIV n xs (map (subst_floatarith (\<lambda>i. Var (s i))) fas) vs = isFDERIV n xs fas vs"
	proof -
	have mv: "\<And>i. i < length fas \<Longrightarrow> max_Var_floatarith (fas ! i) \<le> length vs"
	apply (rule order_trans[OF _ mv])
	by (intro max_Var_floatarith_le_max_Var_floatariths_nth)
	have idem: "\<And>i j. i < length fas \<Longrightarrow> j < max_Var_floatarith (fas ! i) \<Longrightarrow> vs ! s j = vs ! j"
	using idem
	by (auto simp: dest!: max_Var_floatariths_lessI)
	show ?thesis
	unfolding isFDERIV_def
	using mv idem assms(3)
	by (auto simp: isDERIV_subst_Var_floatarith)
	qed

	lemma interpret_floatariths_append[simp]:
	"interpret_floatariths (xs @ ys) vs = interpret_floatariths xs vs @ interpret_floatariths ys vs"
	by (induction xs) auto

	lemma not_fresh_inner_floatariths:
	assumes "length xs = length ys"
	shows "\<not> fresh_floatarith (inner_floatariths xs ys) i \<longleftrightarrow> \<not>fresh_floatariths xs i \<or> \<not>fresh_floatariths ys i"
	using assms
	by (induction xs ys rule: list_induct2) auto

	lemma fresh_inner_floatariths:
	assumes "length xs = length ys"
	shows "fresh_floatarith (inner_floatariths xs ys) i \<longleftrightarrow> fresh_floatariths xs i \<and> fresh_floatariths ys i"
	using not_fresh_inner_floatariths assms by auto

	lemma not_fresh_floatariths_map:
	" \<not> fresh_floatariths (map f xs) i \<longleftrightarrow> (\<exists>x \<in> set xs. \<not>fresh_floatarith (f x) i)"
	by (induction xs) auto

	lemma fresh_floatariths_map:
	" fresh_floatariths (map f xs) i \<longleftrightarrow> (\<forall>x \<in> set xs. fresh_floatarith (f x) i)"
	by (induction xs) auto

	lemma fresh_floatarith_fold_const_fa: "fresh_floatarith fa i \<Longrightarrow> fresh_floatarith (fold_const_fa fa) i"
	by (induction fa) (auto simp: fold_const_fa.simps split: floatarith.splits option.splits)

	lemma fresh_floatarith_fold_const_fa_Add[intro!]:
	assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i"
	shows "fresh_floatarith (fold_const_fa (Add a b)) i"
	using assms
	by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits)

	lemma fresh_floatarith_fold_const_fa_Mult[intro!]:
	assumes "fresh_floatarith (fold_const_fa a) i" "fresh_floatarith (fold_const_fa b) i"
	shows "fresh_floatarith (fold_const_fa (Mult a b)) i"
	using assms
	by (auto simp: fold_const_fa.simps split!: floatarith.splits option.splits)

	lemma fresh_floatarith_fold_const_fa_Minus[intro!]:
	assumes "fresh_floatarith (fold_const_fa b) i"
	shows "fresh_floatarith (fold_const_fa (Minus b)) i"
	using assms
	by (auto simp: fold_const_fa.simps split!: floatarith.splits)

	lemma fresh_FDERIV_floatarith:
	"fresh_floatarith ode_e i \<Longrightarrow> fresh_floatariths ds i
	\<Longrightarrow> length ds = DIM('a)
	\<Longrightarrow> fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i"
	proof (induction ode_e)
	case (Power ode_e n)
	then show ?case by (cases n) (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa)
	qed (auto simp: FDERIV_floatarith_def fresh_inner_floatariths fresh_floatariths_map fresh_floatarith_fold_const_fa)

	lemma not_fresh_FDERIV_floatarith:
	"\<not> fresh_floatarith (FDERIV_floatarith ode_e [0..<DIM('a::executable_euclidean_space)] ds) i
	\<Longrightarrow> length ds = DIM('a)
	\<Longrightarrow> \<not>fresh_floatarith ode_e i \<or> \<not>fresh_floatariths ds i"
	using fresh_FDERIV_floatarith by auto

	lemma not_fresh_FDERIV_floatariths:
	"\<not> fresh_floatariths (FDERIV_floatariths ode_e [0..<DIM('a::executable_euclidean_space)] ds) i \<Longrightarrow>
	length ds = DIM('a) \<Longrightarrow> \<not>fresh_floatariths ode_e i \<or> \<not>fresh_floatariths ds i"
	by (induction ode_e) (auto simp: FDERIV_floatariths_def dest!: not_fresh_FDERIV_floatarith)

	lemma isDERIV_FDERIV_floatarith_linear:
	fixes x h::"'a::executable_euclidean_space"
	assumes "\<And>k. k < DIM('a) \<Longrightarrow> isDERIV i (DERIV_floatarith k fa) xs"
	assumes "max_Var_floatarith fa \<le> DIM('a)"
	assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)"
	shows "isDERIV i (FDERIV_floatarith fa [0..<DIM('a)] (map Var [DIM('a)..<2 * DIM('a)]))
	(xs @ hs)"
	using assms
	apply (auto simp: FDERIV_floatarith_def isDERIV_inner_iff)
	apply (rule isDERIV_max_Var_floatarithI) apply force
	apply (auto simp: nth_append)
	by (metis add_diff_inverse_nat leD max_Var_floatarith_DERIV_floatarith
	max_Var_floatarith_fold_const_fa trans_le_add1)

	lemma
	isFDERIV_FDERIV_floatariths_linear:
	fixes x h::"'a::executable_euclidean_space"
	assumes "\<And>i j k.
	i < DIM('a) \<Longrightarrow>
	j < DIM('a) \<Longrightarrow> k < DIM('a) \<Longrightarrow> isDERIV i (DERIV_floatarith k (fas ! j)) (xs)"
	assumes [simp]: "length fas = DIM('a::executable_euclidean_space)"
	assumes [simp]: "length xs = DIM('a)" "length hs = DIM('a)"
	assumes "max_Var_floatariths fas \<le> DIM('a)"
	shows "isFDERIV DIM('a) [0..<DIM('a::executable_euclidean_space)]
	(FDERIV_floatariths fas [0..<DIM('a)] (map floatarith.Var [DIM('a)..<2 * DIM('a)]))
	(xs @ hs)"
	apply (auto simp: isFDERIV_def intro!: isDERIV_FDERIV_floatarith_linear assms)
	using assms(5) max_Var_floatariths_lessI not_le_imp_less by fastforce

	definition isFDERIV_approx where
	"isFDERIV_approx p n xs fas vs =
	((\<forall>i<n. \<forall>j<n. isDERIV_approx p (xs ! i) (fas ! j) vs) \<and> length fas = n \<and> length xs = n)"

	lemma isFDERIV_approx:
	"bounded_by vs VS \<Longrightarrow> isFDERIV_approx prec n xs fas VS \<Longrightarrow> isFDERIV n xs fas vs"
	by (auto simp: isFDERIV_approx_def isFDERIV_def intro!: isDERIV_approx)

	primrec isnFDERIV_approx where
	"isnFDERIV_approx p N fas xs ds vs 0 = True"
	\| "isnFDERIV_approx p N fas xs ds vs (Suc n) \<longleftrightarrow>
	isFDERIV_approx p N xs (FDERIV_n_floatariths fas xs (map Var ds) n) vs \<and>
	isnFDERIV_approx p N fas xs ds vs n"

	lemma isnFDERIV_approx:
	"bounded_by vs VS \<Longrightarrow> isnFDERIV_approx prec N fas xs ds VS n \<Longrightarrow> isnFDERIV N fas xs ds vs n"
	by (induction n) (auto intro!: isFDERIV_approx)

	fun plain_floatarith::"nat \<Rightarrow> floatarith \<Rightarrow> bool" where
	"plain_floatarith N (floatarith.Add a b) \<longleftrightarrow> plain_floatarith N a \<and> plain_floatarith N b"
	\| "plain_floatarith N (floatarith.Mult a b) \<longleftrightarrow> plain_floatarith N a \<and> plain_floatarith N b"
	\| "plain_floatarith N (floatarith.Minus a) \<longleftrightarrow> plain_floatarith N a"
	\| "plain_floatarith N (floatarith.Pi) \<longleftrightarrow> True"
	\| "plain_floatarith N (floatarith.Num n) \<longleftrightarrow> True"
	\| "plain_floatarith N (floatarith.Var i) \<longleftrightarrow> i < N"
	\| "plain_floatarith N (floatarith.Max a b) \<longleftrightarrow> plain_floatarith N a \<and> plain_floatarith N b"
	\| "plain_floatarith N (floatarith.Min a b) \<longleftrightarrow> plain_floatarith N a \<and> plain_floatarith N b"
	\| "plain_floatarith N (floatarith.Power a n) \<longleftrightarrow> plain_floatarith N a"
	\| "plain_floatarith N (floatarith.Cos a) \<longleftrightarrow> False" \<comment> \<open>TODO: should be plain!\<close>
	\| "plain_floatarith N (floatarith.Arctan a) \<longleftrightarrow> False" \<comment> \<open>TODO: should be plain!\<close>
	\| "plain_floatarith N (floatarith.Abs a) \<longleftrightarrow> plain_floatarith N a"
	\| "plain_floatarith N (floatarith.Exp a) \<longleftrightarrow> False" \<comment> \<open>TODO: should be plain!\<close>
	\| "plain_floatarith N (floatarith.Sqrt a) \<longleftrightarrow> False" \<comment> \<open>TODO: should be plain!\<close>
	\| "plain_floatarith N (floatarith.Floor a) \<longleftrightarrow> plain_floatarith N a"

	\| "plain_floatarith N (floatarith.Powr a b) \<longleftrightarrow> False"
	\| "plain_floatarith N (floatarith.Inverse a) \<longleftrightarrow> False"
	\| "plain_floatarith N (floatarith.Ln a) \<longleftrightarrow> False"

	lemma plain_floatarith_approx_not_None:
	assumes "plain_floatarith N fa" "N \<le> length XS" "\<And>i. i < N \<Longrightarrow> XS ! i \<noteq> None"
	shows "approx p fa XS \<noteq> None"
	using assms
	by (induction fa)
	(auto simp: Let_def split_beta' prod_eq_iff approx.simps)


	definition "Rad_of w = w * (Pi / Num 180)"
	lemma interpret_Rad_of[simp]: "interpret_floatarith (Rad_of w) xs = rad_of (interpret_floatarith w xs)"
	by (auto simp: Rad_of_def rad_of_def)

	definition "Deg_of w = Num 180 * w / Pi"
	lemma interpret_Deg_of[simp]: "interpret_floatarith (Deg_of w) xs = deg_of (interpret_floatarith w xs)"
	by (auto simp: Deg_of_def deg_of_def inverse_eq_divide)

	unbundle no_floatarith_notation

	end
	diff --git a/thys/Affine_Arithmetic/Intersection.thy b/thys/Affine_Arithmetic/Intersection.thy
	--- a/thys/Affine_Arithmetic/Intersection.thy
	+++ b/thys/Affine_Arithmetic/Intersection.thy
	@@ -1,2814 +1,2814 @@
	section \<open>Intersection\<close>
	theory Intersection
	imports
	"HOL-Library.Monad_Syntax"
	Polygon
	Counterclockwise_2D_Arbitrary
	Affine_Form
	begin
	text \<open>\label{sec:intersection}\<close>

	subsection \<open>Polygons and @{term ccw}, @{term lex}, @{term psi}, @{term coll}\<close>

	lemma polychain_of_ccw_conjunction:
	assumes sorted: "ccw'.sortedP 0 Ps"
	assumes z: "z \<in> set (polychain_of Pc Ps)"
	shows "list_all (\<lambda>(xi, xj). ccw xi xj (fst z) \<and> ccw xi xj (snd z)) (polychain_of Pc Ps)"
	using assms
	proof (induction Ps arbitrary: Pc z rule: list.induct)
	case (Cons P Ps)
	{
	assume "set Ps = {}"
	hence ?case using Cons by simp
	} moreover {
	assume "set Ps \<noteq> {}"
	hence "Ps \<noteq> []" by simp
	{
	fix a assume "a \<in> set Ps"
	hence "ccw' 0 P a"
	using Cons.prems
	by (auto elim!: linorder_list0.sortedP_Cons)
	} note ccw' = this
	have sorted': "linorder_list0.sortedP (ccw' 0) Ps"
	using Cons.prems
	by (auto elim!: linorder_list0.sortedP_Cons)
	from in_set_polychain_of_imp_sum_list[OF Cons(3)]
	obtain d
	where d: "z = (Pc + sum_list (take d (P # Ps)), Pc + sum_list (take (Suc d) (P # Ps)))" .

	from Cons(3)
	have disj: "z = (Pc, Pc + P) \<or> z \<in> set (polychain_of (Pc + P) Ps)"
	by auto

	let ?th = "\<lambda>(xi, xj). ccw xi xj Pc \<and> ccw xi xj (Pc + P)"
	have la: "list_all ?th (polychain_of (Pc + P) Ps)"
	proof (rule list_allI)
	fix x assume x: "x \<in> set (polychain_of (Pc + P) Ps)"
	from in_set_polychain_of_imp_sum_list[OF this]
	obtain e where e: "x = (Pc + P + sum_list (take e Ps), Pc + P + sum_list (take (Suc e) Ps))"
	by auto
	{
	assume "e \<ge> length Ps"
	hence "?th x" by (auto simp: e)
	} moreover {
	assume "e < length Ps"
	have 0: "\<And>e. e < length Ps \<Longrightarrow> ccw' 0 P (Ps ! e)"
	- by (rule ccw') (simp add: )
	+ by (rule ccw') simp
	have 2: "0 < e \<Longrightarrow> ccw' 0 (P + sum_list (take e Ps)) (Ps ! e)"
	using \<open>e < length Ps\<close>
	by (auto intro!: ccw'.add1 0 ccw'.sum2 sorted' ccw'.sorted_nth_less
	simp: sum_list_sum_nth)
	have "ccw Pc (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps))"
	by (cases "e = 0")
	(auto simp add: ccw_translate_origin take_Suc_eq add.assoc[symmetric] 0 2
	intro!: ccw'_imp_ccw intro: cyclic)
	hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) Pc"
	by (rule cyclic)
	moreover
	have "0 < e \<Longrightarrow> ccw 0 (Ps ! e) (- sum_list (take e Ps))"
	using \<open>e < length Ps\<close>
	by (auto simp add: take_Suc_eq add.assoc[symmetric]
	sum_list_sum_nth
	intro!: ccw'_imp_ccw ccw'.sum2 sorted' ccw'.sorted_nth_less)
	hence "ccw (Pc + P + sum_list (take e Ps)) (Pc + P + sum_list (take (Suc e) Ps)) (Pc + P)"
	by (cases "e = 0") (simp_all add: ccw_translate_origin take_Suc_eq)
	ultimately have "?th x"
	by (auto simp add: e)
	} ultimately show "?th x" by arith
	qed
	from disj have ?case
	proof
	assume z: "z \<in> set (polychain_of (Pc + P) Ps)"
	have "ccw 0 P (sum_list (take d (P # Ps)))"
	proof (cases d)
	case (Suc e) note e = this
	show ?thesis
	proof (cases e)
	case (Suc f)
	have "ccw 0 P (P + sum_list (take (Suc f) Ps))"
	using z
	by (force simp add: sum_list_sum_nth intro!: ccw'.sum intro: ccw' ccw'_imp_ccw)
	thus ?thesis
	by (simp add: e Suc)
	qed (simp add: e)
	qed simp
	hence "ccw Pc (Pc + P) (fst z)"
	by (simp add: d ccw_translate_origin)
	moreover
	from z have "ccw 0 P (P + sum_list (take d Ps))"
	by (cases d, force)
	(force simp add: sum_list_sum_nth intro!: ccw'_imp_ccw ccw'.sum intro: ccw')+
	hence "ccw Pc (Pc + P) (snd z)"
	by (simp add: d ccw_translate_origin)
	moreover
	from z Cons.prems have "list_all (\<lambda>(xi, xj). ccw xi xj (fst z) \<and> ccw xi xj (snd z))
	(polychain_of (Pc + P) Ps)"
	by (intro Cons.IH) (auto elim!: linorder_list0.sortedP_Cons)
	ultimately show ?thesis by simp
	qed (simp add: la)
	} ultimately show ?case by blast
	qed simp

	lemma lex_polychain_of_center:
	"d \<in> set (polychain_of x0 xs) \<Longrightarrow> list_all (\<lambda>x. lex x 0) xs \<Longrightarrow> lex (snd d) x0"
	proof (induction xs arbitrary: x0)
	case (Cons x xs) thus ?case
	by (auto simp add: lex_def lex_translate_origin dest!: Cons.IH)
	qed (auto simp: lex_translate_origin)

	lemma lex_polychain_of_last:
	"(c, d) \<in> set (polychain_of x0 xs) \<Longrightarrow> list_all (\<lambda>x. lex x 0) xs \<Longrightarrow>
	lex (snd (last (polychain_of x0 xs))) d"
	proof (induction xs arbitrary: x0 c d)
	case (Cons x xs)
	let ?c1 = "c = x0 \<and> d = x0 + x"
	let ?c2 = "(c, d) \<in> set (polychain_of (x0 + x) xs)"
	from Cons(2) have "?c1 \<or> ?c2" by auto
	thus ?case
	proof
	assume ?c1
	with Cons.prems show ?thesis
	by (auto intro!: lex_polychain_of_center)
	next
	assume ?c2
	from Cons.IH[OF this] Cons.prems
	show ?thesis
	by auto
	qed
	qed (auto simp: lex_translate_origin)

	lemma distinct_fst_polychain_of:
	assumes "list_all (\<lambda>x. x \<noteq> 0) xs"
	assumes "list_all (\<lambda>x. lex x 0) xs"
	shows "distinct (map fst (polychain_of x0 xs))"
	using assms
	proof (induction xs arbitrary: x0)
	case Nil
	thus ?case by simp
	next
	case (Cons x xs)
	hence "\<And>d. list_all (\<lambda>x. lex x 0) (x # take d xs)"
	by (auto simp: list_all_iff dest!: in_set_takeD)
	from sum_list_nlex_eq_zero_iff[OF this] Cons.prems
	show ?case
	by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list)
	qed

	lemma distinct_snd_polychain_of:
	assumes "list_all (\<lambda>x. x \<noteq> 0) xs"
	assumes "list_all (\<lambda>x. lex x 0) xs"
	shows "distinct (map snd (polychain_of x0 xs))"
	using assms
	proof (induction xs arbitrary: x0)
	case Nil
	thus ?case by simp
	next
	case (Cons x xs)
	have contra:
	"\<And>d. xs \<noteq> [] \<Longrightarrow> list_all (\<lambda>x. x \<noteq> 0) xs \<Longrightarrow> list_all ((=) 0) (take (Suc d) xs) \<Longrightarrow> False"
	by (auto simp: neq_Nil_conv)
	from Cons have "\<And>d. list_all (\<lambda>x. lex x 0) (take (Suc d) xs)"
	by (auto simp: list_all_iff dest!: in_set_takeD)
	from sum_list_nlex_eq_zero_iff[OF this] Cons.prems contra
	show ?case
	by (cases "xs = []") (auto intro!: Cons.IH elim!: in_set_polychain_of_imp_sum_list dest!: contra)
	qed


	subsection \<open>Orient all entries\<close>

	lift_definition nlex_pdevs::"point pdevs \<Rightarrow> point pdevs"
	is "\<lambda>x n. if lex 0 (x n) then - x n else x n" by simp

	lemma pdevs_apply_nlex_pdevs[simp]: "pdevs_apply (nlex_pdevs x) n =
	(if lex 0 (pdevs_apply x n) then - pdevs_apply x n else pdevs_apply x n)"
	by transfer simp

	lemma nlex_pdevs_zero_pdevs[simp]: "nlex_pdevs zero_pdevs = zero_pdevs"
	by (auto intro!: pdevs_eqI)

	lemma pdevs_domain_nlex_pdevs[simp]: "pdevs_domain (nlex_pdevs x) = pdevs_domain x"
	by (auto simp: pdevs_domain_def)

	lemma degree_nlex_pdevs[simp]: "degree (nlex_pdevs x) = degree x"
	by (rule degree_cong) auto

	lemma
	pdevs_val_nlex_pdevs:
	assumes "e \<in> UNIV \<rightarrow> I" "uminus ` I = I"
	obtains e' where "e' \<in> UNIV \<rightarrow> I" "pdevs_val e x = pdevs_val e' (nlex_pdevs x)"
	using assms
	by (atomize_elim, intro exI[where x="\<lambda>n. if lex 0 (pdevs_apply x n) then - e n else e n"])
	(force simp: pdevs_val_pdevs_domain intro!: sum.cong)

	lemma
	pdevs_val_nlex_pdevs2:
	assumes "e \<in> UNIV \<rightarrow> I" "uminus ` I = I"
	obtains e' where "e' \<in> UNIV \<rightarrow> I" "pdevs_val e (nlex_pdevs x) = pdevs_val e' x"
	using assms
	by (atomize_elim, intro exI[where x="\<lambda>n. (if lex 0 (pdevs_apply x n) then - e n else e n)"])
	(force simp: pdevs_val_pdevs_domain intro!: sum.cong)

	lemma
	pdevs_val_selsort_ccw:
	assumes "distinct xs"
	assumes "e \<in> UNIV \<rightarrow> I"
	obtains e' where "e' \<in> UNIV \<rightarrow> I"
	"pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))"
	proof -
	have "set xs = set (ccw.selsort 0 xs)" "distinct xs" "distinct (ccw.selsort 0 xs)"
	by (simp_all add: assms)
	from this assms(2) obtain e'
	where "e' \<in> UNIV \<rightarrow> I"
	"pdevs_val e (pdevs_of_list xs) = pdevs_val e' (pdevs_of_list (ccw.selsort 0 xs))"
	by (rule pdevs_val_permute)
	thus thesis ..
	qed

	lemma
	pdevs_val_selsort_ccw2:
	assumes "distinct xs"
	assumes "e \<in> UNIV \<rightarrow> I"
	obtains e' where "e' \<in> UNIV \<rightarrow> I"
	"pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)"
	proof -
	have "set (ccw.selsort 0 xs) = set xs" "distinct (ccw.selsort 0 xs)" "distinct xs"
	by (simp_all add: assms)
	from this assms(2) obtain e'
	where "e' \<in> UNIV \<rightarrow> I"
	"pdevs_val e (pdevs_of_list (ccw.selsort 0 xs)) = pdevs_val e' (pdevs_of_list xs)"
	by (rule pdevs_val_permute)
	thus thesis ..
	qed

	lemma lex_nlex_pdevs: "lex (pdevs_apply (nlex_pdevs x) i) 0"
	by (auto simp: lex_def algebra_simps prod_eq_iff)


	subsection \<open>Lowest Vertex\<close>

	definition lowest_vertex::"'a::ordered_euclidean_space aform \<Rightarrow> 'a" where
	"lowest_vertex X = fst X - sum_list (map snd (list_of_pdevs (snd X)))"

	lemma snd_abs: "snd (abs x) = abs (snd x)"
	by (metis abs_prod_def snd_conv)

	lemma lowest_vertex:
	fixes X Y::"(real*real) aform"
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "\<And>i. snd (pdevs_apply (snd X) i) \<ge> 0"
	assumes "\<And>i. abs (snd (pdevs_apply (snd Y) i)) = abs (snd (pdevs_apply (snd X) i))"
	assumes "degree_aform Y = degree_aform X"
	assumes "fst Y = fst X"
	shows "snd (lowest_vertex X) \<le> snd (aform_val e Y)"
	proof -
	from abs_pdevs_val_le_tdev[OF assms(1), of "snd Y"]
	have "snd \<bar>pdevs_val e (snd Y)\<bar> \<le> (\<Sum>i<degree_aform Y. \<bar>snd (pdevs_apply (snd X) i)\<bar>)"
	unfolding lowest_vertex_def
	by (auto simp: aform_val_def tdev_def less_eq_prod_def snd_sum snd_abs assms)
	also have "\<dots> = (\<Sum>i<degree_aform X. snd (pdevs_apply (snd X) i))"
	by (simp add: assms)
	also have "\<dots> \<le> snd (sum_list (map snd (list_of_pdevs (snd X))))"
	by (simp add: sum_list_list_of_pdevs dense_list_of_pdevs_def sum_list_distinct_conv_sum_set
	snd_sum atLeast0LessThan)
	finally show ?thesis
	by (auto simp: aform_val_def lowest_vertex_def minus_le_iff snd_abs abs_real_def assms
	split: if_split_asm)
	qed

	lemma sum_list_nonposI:
	fixes xs::"'a::ordered_comm_monoid_add list"
	shows "list_all (\<lambda>x. x \<le> 0) xs \<Longrightarrow> sum_list xs \<le> 0"
	by (induct xs) (auto simp: intro!: add_nonpos_nonpos)

	lemma center_le_lowest:
	"fst (fst X) \<le> fst (lowest_vertex (fst X, nlex_pdevs (snd X)))"
	by (auto simp: lowest_vertex_def fst_sum_list intro!: sum_list_nonposI)
	(auto simp: lex_def list_all_iff list_of_pdevs_def dest!: in_set_butlastD split: if_split_asm)

	lemma lowest_vertex_eq_center_iff:
	"lowest_vertex (x0, nlex_pdevs (snd X)) = x0 \<longleftrightarrow> snd X = zero_pdevs"
	proof
	assume "lowest_vertex (x0, nlex_pdevs (snd X)) = x0"
	then have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = 0"
	by (simp add: lowest_vertex_def)
	moreover have "list_all (\<lambda>x. Counterclockwise_2D_Arbitrary.lex x 0)
	(map snd (list_of_pdevs (nlex_pdevs (snd X))))"
	by (auto simp add: list_all_iff list_of_pdevs_def)
	ultimately have "\<forall>x\<in>set (list_of_pdevs (nlex_pdevs (snd X))). snd x = 0"
	by (simp add: sum_list_nlex_eq_zero_iff list_all_iff)
	then have "pdevs_apply (snd X) i = pdevs_apply zero_pdevs i" for i
	by (simp add: list_of_pdevs_def split: if_splits)
	then show "snd X = zero_pdevs"
	by (rule pdevs_eqI)
	qed (simp add: lowest_vertex_def)


	subsection \<open>Collinear Generators\<close>

	lemma scaleR_le_self_cancel:
	fixes c::"'a::ordered_real_vector"
	shows "a *\<^sub>R c \<le> c \<longleftrightarrow> (1 < a \<and> c \<le> 0 \<or> a < 1 \<and> 0 \<le> c \<or> a = 1)"
	using scaleR_le_0_iff[of "a - 1" c]
	by (simp add: algebra_simps)

	lemma pdevs_val_coll:
	assumes coll: "list_all (coll 0 x) xs"
	assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
	assumes "x \<noteq> 0"
	assumes "f \<in> UNIV \<rightarrow> {-1 .. 1}"
	obtains e where "e \<in> {-1 .. 1}" "pdevs_val f (pdevs_of_list xs) = e *\<^sub>R (sum_list xs)"
	proof cases
	assume "sum_list xs = 0"
	have "pdevs_of_list xs = zero_pdevs"
	by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex \<open>sum_list xs = 0\<close>]
	simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem)
	hence "0 \<in> {-1 .. 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *\<^sub>R sum_list xs"
	by simp_all
	thus ?thesis ..
	next
	assume "sum_list xs \<noteq> 0"
	have "sum_list (map abs xs) \<ge> 0"
	by (auto intro!: sum_list_nonneg)
	hence [simp]: "\<not>sum_list (map abs xs) \<le> 0"
	by (metis \<open>sum_list xs \<noteq> 0\<close> abs_le_zero_iff antisym_conv sum_list_abs)

	have collist: "list_all (coll 0 (sum_list xs)) xs"
	proof (rule list_allI)
	fix y assume "y \<in> set xs"
	hence "coll 0 x y"
	using coll by (auto simp: list_all_iff)
	also have "coll 0 x (sum_list xs)"
	using coll by (auto simp: list_all_iff intro!: coll_sum_list)
	finally (coll_trans)
	show "coll 0 (sum_list xs) y"
	by (simp add: coll_commute \<open>x \<noteq> 0\<close>)
	qed

	{
	fix i assume "i < length xs"
	hence "\<exists>r. xs ! i = r *\<^sub>R (sum_list xs)"
	by (metis (mono_tags) coll_scale nth_mem \<open>sum_list xs \<noteq> 0\<close> list_all_iff collist)
	} then obtain r where r: "\<And>i. i < length xs \<Longrightarrow> (xs ! i) = r i *\<^sub>R (sum_list xs)"
	by metis
	let ?coll = "pdevs_of_list xs"
	have "pdevs_val f (pdevs_of_list xs) =
	(\<Sum>i<degree (pdevs_of_list xs). f i *\<^sub>R xs ! i)"
	unfolding pdevs_val_sum
	by (simp add: pdevs_apply_pdevs_of_list less_degree_pdevs_of_list_imp_less_length)
	also have "\<dots> = (\<Sum>i<degree ?coll. (f i * r i) *\<^sub>R (sum_list xs))"
	by (simp add: r less_degree_pdevs_of_list_imp_less_length)
	also have "\<dots> = (\<Sum>i<degree ?coll. f i * r i) *\<^sub>R (sum_list xs)"
	by (simp add: algebra_simps scaleR_sum_left)
	finally have eq: "pdevs_val f ?coll = (\<Sum>i<degree ?coll. f i * r i) *\<^sub>R (sum_list xs)"
	(is "_ = ?e *\<^sub>R _")
	.

	have "abs (pdevs_val f ?coll) \<le> tdev ?coll"
	using assms(4)
	by (intro abs_pdevs_val_le_tdev) (auto simp: Pi_iff less_imp_le)
	also have "\<dots> = sum_list (map abs xs)" using assms by simp
	also note eq
	finally have less: "\<bar>?e\<bar> *\<^sub>R abs (sum_list xs) \<le> sum_list (map abs xs)" by (simp add: abs_scaleR)
	also have "\<bar>sum_list xs\<bar> = sum_list (map abs xs)"
	using coll \<open>x \<noteq> 0\<close> nlex
	by (rule abs_sum_list_coll)
	finally have "?e \<in> {-1 .. 1}"
	by (auto simp add: less_le scaleR_le_self_cancel)
	thus ?thesis using eq ..
	qed

	lemma scaleR_eq_self_cancel:
	fixes x::"'a::real_vector"
	shows "a *\<^sub>R x = x \<longleftrightarrow> a = 1 \<or> x = 0"
	using scaleR_cancel_right[of a x 1]
	by simp

	lemma abs_pdevs_val_less_tdev:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}" "degree x > 0"
	shows "\<bar>pdevs_val e x\<bar> < tdev x"
	proof -
	have bnds: "\<And>i. \<bar>e i\<bar> < 1" "\<And>i. \<bar>e i\<bar> \<le> 1"
	using assms
	by (auto simp: Pi_iff abs_less_iff order.strict_implies_order)
	moreover
	let ?w = "degree x - 1"
	have witness: "\<bar>e ?w\<bar> *\<^sub>R \<bar>pdevs_apply x ?w\<bar> < \<bar>pdevs_apply x ?w\<bar>"
	using degree_least_nonzero[of x] assms bnds
	by (intro neq_le_trans) (auto simp: scaleR_eq_self_cancel Pi_iff
	intro!: scaleR_left_le_one_le neq_le_trans
	intro: abs_leI less_imp_le dest!: order.strict_implies_not_eq)
	ultimately
	show ?thesis
	using assms witness bnds
	by (auto simp: pdevs_val_sum tdev_def abs_scaleR
	intro!: le_less_trans[OF sum_abs] sum_strict_mono_ex1 scaleR_left_le_one_le)
	qed

	lemma pdevs_val_coll_strict:
	assumes coll: "list_all (coll 0 x) xs"
	assumes nlex: "list_all (\<lambda>x. lex x 0) xs"
	assumes "x \<noteq> 0"
	assumes "f \<in> UNIV \<rightarrow> {-1 <..< 1}"
	obtains e where "e \<in> {-1 <..< 1}" "pdevs_val f (pdevs_of_list xs) = e *\<^sub>R (sum_list xs)"
	proof cases
	assume "sum_list xs = 0"
	have "pdevs_of_list xs = zero_pdevs"
	by (auto intro!: pdevs_eqI sum_list_nlex_eq_zeroI[OF nlex \<open>sum_list xs = 0\<close>]
	simp: pdevs_apply_pdevs_of_list list_all_iff dest!: nth_mem)
	hence "0 \<in> {-1 <..< 1::real}" "pdevs_val f (pdevs_of_list xs) = 0 *\<^sub>R sum_list xs"
	by simp_all
	thus ?thesis ..
	next
	assume "sum_list xs \<noteq> 0"
	have "sum_list (map abs xs) \<ge> 0"
	by (auto intro!: sum_list_nonneg)
	hence [simp]: "\<not>sum_list (map abs xs) \<le> 0"
	by (metis \<open>sum_list xs \<noteq> 0\<close> abs_le_zero_iff antisym_conv sum_list_abs)

	have "\<exists>x \<in> set xs. x \<noteq> 0"
	proof (rule ccontr)
	assume "\<not> (\<exists>x\<in>set xs. x \<noteq> 0)"
	hence "\<And>x. x \<in> set xs \<Longrightarrow> x = 0" by auto
	hence "sum_list xs = 0"
	by (auto simp: sum_list_eq_0_iff_nonpos list_all_iff less_eq_prod_def prod_eq_iff fst_sum_list
	snd_sum_list)
	thus False using \<open>sum_list xs \<noteq> 0\<close> by simp
	qed
	then obtain i where i: "i < length xs" "xs ! i \<noteq> 0"
	by (metis in_set_conv_nth)
	hence "i < degree (pdevs_of_list xs)"
	by (auto intro!: degree_gt simp: pdevs_apply_pdevs_of_list)
	hence deg_pos: "0 < degree (pdevs_of_list xs)" by simp

	have collist: "list_all (coll 0 (sum_list xs)) xs"
	proof (rule list_allI)
	fix y assume "y \<in> set xs"
	hence "coll 0 x y"
	using coll by (auto simp: list_all_iff)
	also have "coll 0 x (sum_list xs)"
	using coll by (auto simp: list_all_iff intro!: coll_sum_list)
	finally (coll_trans)
	show "coll 0 (sum_list xs) y"
	by (simp add: coll_commute \<open>x \<noteq> 0\<close>)
	qed

	{
	fix i assume "i < length xs"
	hence "\<exists>r. xs ! i = r *\<^sub>R (sum_list xs)"
	by (metis (mono_tags, lifting) \<open>sum_list xs \<noteq> 0\<close> coll_scale collist list_all_iff nth_mem)
	} then obtain r where r: "\<And>i. i < length xs \<Longrightarrow> (xs ! i) = r i *\<^sub>R (sum_list xs)"
	by metis
	let ?coll = "pdevs_of_list xs"
	have "pdevs_val f (pdevs_of_list xs) =
	(\<Sum>i<degree (pdevs_of_list xs). f i *\<^sub>R xs ! i)"
	unfolding pdevs_val_sum
	by (simp add: less_degree_pdevs_of_list_imp_less_length pdevs_apply_pdevs_of_list)
	also have "\<dots> = (\<Sum>i<degree ?coll. (f i * r i) *\<^sub>R (sum_list xs))"
	by (simp add: r less_degree_pdevs_of_list_imp_less_length)
	also have "\<dots> = (\<Sum>i<degree ?coll. f i * r i) *\<^sub>R (sum_list xs)"
	by (simp add: algebra_simps scaleR_sum_left)
	finally have eq: "pdevs_val f ?coll = (\<Sum>i<degree ?coll. f i * r i) *\<^sub>R (sum_list xs)"
	(is "_ = ?e *\<^sub>R _")
	.

	have "abs (pdevs_val f ?coll) < tdev ?coll"
	using assms(4)
	by (intro abs_pdevs_val_less_tdev) (auto simp: Pi_iff less_imp_le deg_pos)
	also have "\<dots> = sum_list (map abs xs)" using assms by simp
	also note eq
	finally have less: "\<bar>?e\<bar> *\<^sub>R abs (sum_list xs) < sum_list (map abs xs)" by (simp add: abs_scaleR)
	also have "\<bar>sum_list xs\<bar> = sum_list (map abs xs)"
	using coll \<open>x \<noteq> 0\<close> nlex
	by (rule abs_sum_list_coll)
	finally have "?e \<in> {-1 <..< 1}"
	by (auto simp add: less_le scaleR_le_self_cancel)
	thus ?thesis using eq ..
	qed


	subsection \<open>Independent Generators\<close>

	fun independent_pdevs::"point list \<Rightarrow> point list"
	where
	"independent_pdevs [] = []"
	\| "independent_pdevs (x#xs) =
	(let
	(cs, is) = List.partition (coll 0 x) xs;
	s = x + sum_list cs
	in (if s = 0 then [] else [s]) @ independent_pdevs is)"

	lemma in_set_independent_pdevsE:
	assumes "y \<in> set (independent_pdevs xs)"
	obtains x where "x\<in>set xs" "coll 0 x y"
	proof atomize_elim
	show "\<exists>x. x \<in> set xs \<and> coll 0 x y"
	using assms
	proof (induct xs rule: independent_pdevs.induct)
	case 1 thus ?case by simp
	next
	case (2 z zs)
	let ?c1 = "y = z + sum_list (filter (coll 0 z) zs)"
	let ?c2 = "y \<in> set (independent_pdevs (filter (Not \<circ> coll 0 z) zs))"
	from 2
	have "?c1 \<or> ?c2"
	by (auto simp: Let_def split: if_split_asm)
	thus ?case
	proof
	assume ?c2
	hence "y \<in> set (independent_pdevs (snd (partition (coll 0 z) zs)))"
	by simp
	from 2(1)[OF refl prod.collapse refl this]
	show ?case
	by auto
	next
	assume y: ?c1
	show ?case
	unfolding y
	by (rule exI[where x="z"]) (auto intro!: coll_add coll_sum_list )
	qed
	qed
	qed

	lemma in_set_independent_pdevs_nonzero: "x \<in> set (independent_pdevs xs) \<Longrightarrow> x \<noteq> 0"
	proof (induct xs rule: independent_pdevs.induct)
	case (2 y ys)
	from 2(1)[OF refl prod.collapse refl] 2(2)
	show ?case
	by (auto simp: Let_def split: if_split_asm)
	qed simp

	lemma independent_pdevs_pairwise_non_coll:
	assumes "x \<in> set (independent_pdevs xs)"
	assumes "y \<in> set (independent_pdevs xs)"
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0"
	assumes "x \<noteq> y"
	shows "\<not> coll 0 x y"
	using assms
	proof (induct xs rule: independent_pdevs.induct)
	case 1 thus ?case by simp
	next
	case (2 z zs)
	from 2 have "z \<noteq> 0" by simp
	from 2(2) have "x \<noteq> 0" by (rule in_set_independent_pdevs_nonzero)
	from 2(3) have "y \<noteq> 0" by (rule in_set_independent_pdevs_nonzero)
	let ?c = "filter (coll 0 z) zs"
	let ?nc = "filter (Not \<circ> coll 0 z) zs"
	{
	assume "x \<in> set (independent_pdevs ?nc)" "y \<in> set (independent_pdevs ?nc)"
	hence "\<not>coll 0 x y"
	by (intro 2(1)[OF refl prod.collapse refl _ _ 2(4) 2(5)]) auto
	} note IH = this
	{
	fix x assume "x \<noteq> 0" "z + sum_list ?c \<noteq> 0"
	"coll 0 x (z + sum_list ?c)"
	hence "x \<notin> set (independent_pdevs ?nc)"
	using sum_list_filter_coll_ex_scale[OF \<open>z \<noteq> 0\<close>, of "z#zs"]
	by (auto elim!: in_set_independent_pdevsE simp: coll_commute)
	(metis (no_types) \<open>x \<noteq> 0\<close> coll_scale coll_scaleR)
	} note nc = this
	from 2(2,3,4,5) nc[OF \<open>x \<noteq> 0\<close>] nc[OF \<open>y \<noteq> 0\<close>]
	show ?case
	by (auto simp: Let_def IH coll_commute split: if_split_asm)
	qed

	lemma distinct_independent_pdevs[simp]:
	shows "distinct (independent_pdevs xs)"
	proof (induct xs rule: independent_pdevs.induct)
	case 1 thus ?case by simp
	next
	case (2 x xs)
	let ?is = "independent_pdevs (filter (Not \<circ> coll 0 x) xs)"
	have "distinct ?is"
	by (rule 2) (auto intro!: 2)
	thus ?case
	proof (clarsimp simp add: Let_def)
	let ?s = "x + sum_list (filter (coll 0 x) xs)"
	assume s: "?s \<noteq> 0" "?s \<in> set ?is"
	from in_set_independent_pdevsE[OF s(2)]
	obtain y where y:
	"y \<in> set (filter (Not \<circ> coll 0 x) xs)"
	"coll 0 y (x + sum_list (filter (coll 0 x) xs))"
	by auto
	{
	assume "y = 0 \<or> x = 0 \<or> sum_list (filter (coll 0 x) xs) = 0"
	hence False using s y by (auto simp: coll_commute)
	} moreover {
	assume "y \<noteq> 0" "x \<noteq> 0" "sum_list (filter (coll 0 x) xs) \<noteq> 0"
	"sum_list (filter (coll 0 x) xs) + x \<noteq> 0"
	have *: "coll 0 (sum_list (filter (coll 0 x) xs)) x"
	by (auto intro!: coll_sum_list simp: coll_commute)
	have "coll 0 y (sum_list (filter (coll 0 x) xs) + x)"
	using s y by (simp add: add.commute)
	hence "coll 0 y x" using *
	by (rule coll_add_trans) fact+
	hence False using s y by (simp add: coll_commute)
	} ultimately show False using s y by (auto simp: add.commute)
	qed
	qed

	lemma in_set_independent_pdevs_invariant_nlex:
	"x \<in> set (independent_pdevs xs) \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> lex x 0) \<Longrightarrow>
	(\<And>x. x \<in> set xs \<Longrightarrow> x \<noteq> 0) \<Longrightarrow> Counterclockwise_2D_Arbitrary.lex x 0"
	proof (induction xs arbitrary: x rule: independent_pdevs.induct )
	case 1 thus ?case by simp
	next
	case (2 y ys)
	from 2 have "y \<noteq> 0" by auto
	from 2(2)
	have "x \<in> set (independent_pdevs (filter (Not \<circ> coll 0 y) ys)) \<or>
	x = y + sum_list (filter (coll 0 y) ys)"
	by (auto simp: Let_def split: if_split_asm)
	thus ?case
	proof
	assume "x \<in> set (independent_pdevs (filter (Not \<circ> coll 0 y) ys))"
	from 2(1)[OF refl prod.collapse refl, simplified, OF this 2(3,4)]
	show ?case by simp
	next
	assume "x = y + sum_list (filter (coll 0 y) ys)"
	also have "lex \<dots> 0"
	by (force intro: nlex_add nlex_sum simp: sum_list_sum_nth
	dest: nth_mem intro: 2(3))
	finally show ?case .
	qed
	qed

	lemma
	pdevs_val_independent_pdevs2:
	assumes "e \<in> UNIV \<rightarrow> I"
	shows "\<exists>e'. e' \<in> UNIV \<rightarrow> I \<and>
	pdevs_val e (pdevs_of_list (independent_pdevs xs)) = pdevs_val e' (pdevs_of_list xs)"
	using assms
	proof (induct xs arbitrary: e rule: independent_pdevs.induct)
	case 1 thus ?case by force
	next
	case (2 x xs)
	let ?coll = "(filter (coll 0 x) (x#xs))"
	let ?ncoll = "(filter (Not o coll 0 x) (x#xs))"
	let ?e0 = "if sum_list ?coll = 0 then e else e \<circ> (+) (Suc 0)"
	have "pdevs_val e (pdevs_of_list (independent_pdevs (x#xs))) =
	e 0 *\<^sub>R (sum_list ?coll) + pdevs_val ?e0 (pdevs_of_list (independent_pdevs ?ncoll))"
	(is "_ = ?vc + ?vnc")
	by (simp add: Let_def)
	also
	have e_split: "(\<lambda>_. e 0) \<in> UNIV \<rightarrow> I" "?e0 \<in> UNIV \<rightarrow> I"
	using 2(2) by auto
	from 2(1)[OF refl prod.collapse refl e_split(2)]
	obtain e' where e': "e' \<in> UNIV \<rightarrow> I" and "?vnc = pdevs_val e' (pdevs_of_list ?ncoll)"
	by (auto simp add: o_def)
	note this(2)
	also
	have "?vc = pdevs_val (\<lambda>_. e 0) (pdevs_of_list ?coll)"
	by (simp add: pdevs_val_const_pdevs_of_list)
	also
	from pdevs_val_pdevs_of_list_append[OF e_split(1) e'] obtain e'' where
	e'': "e'' \<in> UNIV \<rightarrow> I"
	and "pdevs_val (\<lambda>_. e 0) (pdevs_of_list ?coll) + pdevs_val e' (pdevs_of_list ?ncoll) =
	pdevs_val e'' (pdevs_of_list (?coll @ ?ncoll))"
	by metis
	note this(2)
	also
	from pdevs_val_perm[OF partition_permI e'', of "coll 0 x" "x#xs"]
	obtain e''' where e''': "e''' \<in> UNIV \<rightarrow> I"
	and "\<dots> = pdevs_val e''' (pdevs_of_list (x # xs))"
	by metis
	note this(2)
	finally show ?case using e''' by auto
	qed

	lemma list_all_filter: "list_all p (filter p xs)"
	by (induct xs) auto

	lemma pdevs_val_independent_pdevs:
	assumes "list_all (\<lambda>x. lex x 0) xs"
	assumes "list_all (\<lambda>x. x \<noteq> 0) xs"
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "\<exists>e'. e' \<in> UNIV \<rightarrow> {-1 .. 1} \<and> pdevs_val e (pdevs_of_list xs) =
	pdevs_val e' (pdevs_of_list (independent_pdevs xs))"
	using assms(1,2,3)
	proof (induct xs arbitrary: e rule: independent_pdevs.induct)
	case 1 thus ?case by force
	next
	case (2 x xs)

	let ?coll = "(filter (coll 0 x) (x#xs))"
	let ?ncoll = "(filter (Not o coll 0 x) xs)"

	from 2 have "x \<noteq> 0" by simp

	from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"]
	obtain f g where part: "pdevs_val e (pdevs_of_list (x # xs)) =
	pdevs_val f (pdevs_of_list ?coll) +
	pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))"
	and f: "f \<in> UNIV \<rightarrow> {-1 .. 1}" and g: "g \<in> UNIV \<rightarrow> {-1 .. 1}"
	by blast
	note part
	also

	have "list_all (\<lambda>x. lex x 0) (filter (coll 0 x) (x#xs))"
	using 2(2) by (auto simp: inner_prod_def list_all_iff)
	from pdevs_val_coll[OF list_all_filter this \<open>x \<noteq> 0\<close> f]
	obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *\<^sub>R sum_list (filter (coll 0 x) (x#xs))"
	and f': "f' \<in> {-1 .. 1}"
	by blast
	note this(1)
	also

	have "filter (Not o coll 0 x) (x#xs) = ?ncoll"
	by simp
	also

	from 2(2) have "list_all (\<lambda>x. lex x 0) ?ncoll" "list_all (\<lambda>x. x \<noteq> 0) ?ncoll"
	by (auto simp: list_all_iff)
	from 2(1)[OF refl partition_filter_conv[symmetric] refl this g]
	obtain g'
	where "pdevs_val g (pdevs_of_list ?ncoll) =
	pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))"
	and g': "g' \<in> UNIV \<rightarrow> {-1 .. 1}"
	by metis
	note this(1)
	also

	define h where "h = (if sum_list ?coll \<noteq> 0 then rec_nat f' (\<lambda>i _. g' i) else g')"
	have "f' *\<^sub>R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))
	= pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))"
	by (simp add: h_def o_def Let_def)

	finally
	have "pdevs_val e (pdevs_of_list (x # xs)) =
	pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" .

	moreover have "h \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof
	fix i show "h i \<in> {-1 .. 1}"
	using f' g'
	by (cases i) (auto simp: h_def)
	qed

	ultimately show ?case by blast
	qed

	lemma
	pdevs_val_independent_pdevs_strict:
	assumes "list_all (\<lambda>x. lex x 0) xs"
	assumes "list_all (\<lambda>x. x \<noteq> 0) xs"
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	shows "\<exists>e'. e' \<in> UNIV \<rightarrow> {-1 <..< 1} \<and> pdevs_val e (pdevs_of_list xs) =
	pdevs_val e' (pdevs_of_list (independent_pdevs xs))"
	using assms(1,2,3)
	proof (induct xs arbitrary: e rule: independent_pdevs.induct)
	case 1 thus ?case by force
	next
	case (2 x xs)

	let ?coll = "(filter (coll 0 x) (x#xs))"
	let ?ncoll = "(filter (Not o coll 0 x) xs)"

	from 2 have "x \<noteq> 0" by simp

	from pdevs_val_partition[OF 2(4), of "x#xs" "coll 0 x"]
	obtain f g
	where part: "pdevs_val e (pdevs_of_list (x # xs)) =
	pdevs_val f (pdevs_of_list ?coll) +
	pdevs_val g (pdevs_of_list (filter (Not o coll 0 x) (x#xs)))"
	and f: "f \<in> UNIV \<rightarrow> {-1 <..< 1}" and g: "g \<in> UNIV \<rightarrow> {-1 <..< 1}"
	by blast
	note part
	also

	have "list_all (\<lambda>x. lex x 0) (filter (coll 0 x) (x#xs))"
	using 2(2) by (auto simp: inner_prod_def list_all_iff)
	from pdevs_val_coll_strict[OF list_all_filter this \<open>x \<noteq> 0\<close> f]
	obtain f' where "pdevs_val f (pdevs_of_list ?coll) = f' *\<^sub>R sum_list (filter (coll 0 x) (x#xs))"
	and f': "f' \<in> {-1 <..< 1}"
	by blast
	note this(1)
	also

	have "filter (Not o coll 0 x) (x#xs) = ?ncoll"
	by simp
	also

	from 2(2) have "list_all (\<lambda>x. lex x 0) ?ncoll" "list_all (\<lambda>x. x \<noteq> 0) ?ncoll"
	by (auto simp: list_all_iff)
	from 2(1)[OF refl partition_filter_conv[symmetric] refl this g]
	obtain g'
	where "pdevs_val g (pdevs_of_list ?ncoll) =
	pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))"
	and g': "g' \<in> UNIV \<rightarrow> {-1 <..< 1}"
	by metis
	note this(1)
	also

	define h where "h = (if sum_list ?coll \<noteq> 0 then rec_nat f' (\<lambda>i _. g' i) else g')"
	have "f' *\<^sub>R sum_list ?coll + pdevs_val g' (pdevs_of_list (independent_pdevs ?ncoll))
	= pdevs_val h (pdevs_of_list (independent_pdevs (x#xs)))"
	by (simp add: h_def o_def Let_def)

	finally
	have "pdevs_val e (pdevs_of_list (x # xs)) =
	pdevs_val h (pdevs_of_list (independent_pdevs (x # xs)))" .

	moreover have "h \<in> UNIV \<rightarrow> {-1 <..< 1}"
	proof
	fix i show "h i \<in> {-1 <..< 1}"
	using f' g'
	by (cases i) (auto simp: h_def)
	qed

	ultimately show ?case by blast
	qed

	lemma sum_list_independent_pdevs: "sum_list (independent_pdevs xs) = sum_list xs"
	proof (induct xs rule: independent_pdevs.induct)
	case (2 y ys)
	from 2[OF refl prod.collapse refl]
	show ?case
	using sum_list_partition[of "coll 0 y" ys, symmetric]
	by (auto simp: Let_def)
	qed simp

	lemma independent_pdevs_eq_Nil_iff:
	"list_all (\<lambda>x. lex x 0) xs \<Longrightarrow> list_all (\<lambda>x. x \<noteq> 0) xs \<Longrightarrow> independent_pdevs xs = [] \<longleftrightarrow> xs = []"
	proof (induct xs)
	case Nil thus ?case by simp
	next
	case (Cons x xs)
	from Cons(2) have "list_all (\<lambda>x. lex x 0) (x # filter (coll 0 x) xs)"
	by (auto simp: list_all_iff)
	from sum_list_nlex_eq_zero_iff[OF this] Cons(3)
	show ?case
	by (auto simp: list_all_iff)
	qed


	subsection \<open>Independent Oriented Generators\<close>

	definition "inl p = independent_pdevs (map snd (list_of_pdevs (nlex_pdevs p)))"

	lemma distinct_inl[simp]: "distinct (inl (snd X))"
	by (auto simp: inl_def)

	lemma in_set_inl_nonzero: "x \<in> set (inl xs) \<Longrightarrow> x \<noteq> 0"
	by (auto simp: inl_def in_set_independent_pdevs_nonzero)

	lemma
	inl_ncoll: "y \<in> set (inl (snd X)) \<Longrightarrow> z \<in> set (inl (snd X)) \<Longrightarrow> y \<noteq> z \<Longrightarrow> \<not>coll 0 y z"
	unfolding inl_def
	by (rule independent_pdevs_pairwise_non_coll, assumption+)
	(auto simp: inl_def list_of_pdevs_nonzero)

	lemma in_set_inl_lex: "x \<in> set (inl xs) \<Longrightarrow> lex x 0"
	by (auto simp: inl_def list_of_pdevs_def dest!: in_set_independent_pdevs_invariant_nlex
	split: if_split_asm)

	interpretation ccw0: linorder_list "ccw 0" "set (inl (snd X))"
	proof unfold_locales
	fix a b c
	show "a \<noteq> b \<Longrightarrow> ccw 0 a b \<or> ccw 0 b a"
	by (metis UNIV_I ccw_self(1) nondegenerate)
	assume a: "a \<in> set (inl (snd X))"
	show "ccw 0 a a"
	by simp
	assume b: "b \<in> set (inl (snd X))"
	show "ccw 0 a b \<Longrightarrow> ccw 0 b a \<Longrightarrow> a = b"
	by (metis ccw_self(1) in_set_inl_nonzero mem_Collect_eq not_ccw_eq a b)
	assume c: "c \<in> set (inl (snd X))"
	assume distinct: "a \<noteq> b" "b \<noteq> c" "a \<noteq> c"
	assume ab: "ccw 0 a b" and bc: "ccw 0 b c"
	show "ccw 0 a c"
	using a b c ab bc
	proof (cases "a = (0, 1)" "b = (0, 1)" "c = (0, 1)"
	rule: case_split[case_product case_split[case_product case_split]])
	assume nu: "a \<noteq> (0, 1)" "b \<noteq> (0, 1)" "c \<noteq> (0, 1)"
	have "distinct5 a b c (0, 1) 0" "in5 UNIV a b c (0, 1) 0"
	using a b c distinct nu by (simp_all add: in_set_inl_nonzero)
	moreover have "ccw 0 (0, 1) a" "ccw 0 (0, 1) b" "ccw 0 (0, 1) c"
	by (auto intro!: nlex_ccw_left in_set_inl_lex a b c)
	ultimately show ?thesis using ab bc
	by (rule ccw.transitive[where S=UNIV and s="(0, 1)"])
	next
	assume "a \<noteq> (0, 1)" "b = (0, 1)" "c \<noteq> (0, 1)"
	thus ?thesis
	using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left a b ab
	by blast
	next
	assume "a \<noteq> (0, 1)" "b \<noteq> (0, 1)" "c = (0, 1)"
	thus ?thesis
	using ccw_switch23 in_set_inl_lex inl_ncoll nlex_ccw_left b c bc
	by blast
	qed (auto simp add: nlex_ccw_left in_set_inl_lex)
	qed

	lemma sorted_inl: "ccw.sortedP 0 (ccw.selsort 0 (inl (snd X)))"
	by (rule ccw0.sortedP_selsort) auto

	lemma sorted_scaled_inl: "ccw.sortedP 0 (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X))))"
	using sorted_inl
	by (rule ccw_sorted_scaleR) simp

	lemma distinct_selsort_inl: "distinct (ccw.selsort 0 (inl (snd X)))"
	by simp

	lemma distinct_map_scaleRI:
	fixes xs::"'a::real_vector list"
	shows "distinct xs \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> distinct (map ((*\<^sub>R) c) xs)"
	by (induct xs) auto

	lemma distinct_scaled_inl: "distinct (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X))))"
	using distinct_selsort_inl
	by (rule distinct_map_scaleRI) simp

	lemma ccw'_sortedP_scaled_inl:
	"ccw'.sortedP 0 (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X))))"
	using ccw_sorted_implies_ccw'_sortedP
	by (rule ccw'_sorted_scaleR) (auto simp: sorted_inl inl_ncoll)

	lemma pdevs_val_pdevs_of_list_inl2E:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	obtains e' where "pdevs_val e X = pdevs_val e' (pdevs_of_list (inl X))" "e' \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	let ?l = "map snd (list_of_pdevs (nlex_pdevs X))"
	have l: "list_all (\<lambda>x. Counterclockwise_2D_Arbitrary.lex x 0) ?l"
	"list_all (\<lambda>x. x \<noteq> 0) (map snd (list_of_pdevs (nlex_pdevs X)))"
	by (auto simp: list_all_iff list_of_pdevs_def)

	from pdevs_val_nlex_pdevs[OF assms(1)]
	obtain e' where "e' \<in> UNIV \<rightarrow> {-1 .. 1}" "pdevs_val e X = pdevs_val e' (nlex_pdevs X)"
	by auto
	note this(2)
	also from pdevs_val_of_list_of_pdevs2[OF \<open>e' \<in> _\<close>]
	obtain e'' where "e'' \<in> UNIV \<rightarrow> {-1 .. 1}" "\<dots> = pdevs_val e'' (pdevs_of_list ?l)"
	by metis
	note this(2)
	also from pdevs_val_independent_pdevs[OF l \<open>e'' \<in> _\<close>]
	obtain e'''
	where "e''' \<in> UNIV \<rightarrow> {-1 .. 1}"
	and "\<dots> = pdevs_val e''' (pdevs_of_list (independent_pdevs ?l))"
	by metis
	note this(2)
	also have "\<dots> = pdevs_val e''' (pdevs_of_list (inl X))"
	by (simp add: inl_def)
	finally have "pdevs_val e X = pdevs_val e''' (pdevs_of_list (inl X))" .
	thus thesis using \<open>e''' \<in> _\<close> ..
	qed

	lemma pdevs_val_pdevs_of_list_inlE:
	assumes "e \<in> UNIV \<rightarrow> I" "uminus ` I = I" "0 \<in> I"
	obtains e' where "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e' X" "e' \<in> UNIV \<rightarrow> I"
	proof -
	let ?l = "map snd (list_of_pdevs (nlex_pdevs X))"
	have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e (pdevs_of_list (independent_pdevs ?l))"
	by (simp add: inl_def)
	also
	from pdevs_val_independent_pdevs2[OF \<open>e \<in> _\<close>]
	obtain e'
	where "pdevs_val e (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e' (pdevs_of_list ?l)"
	and "e' \<in> UNIV \<rightarrow> I"
	by auto
	note this(1)
	also
	from pdevs_val_of_list_of_pdevs[OF \<open>e' \<in> _\<close> \<open>0 \<in> I\<close>, of "nlex_pdevs X"]
	obtain e'' where "pdevs_val e' (pdevs_of_list ?l) = pdevs_val e'' (nlex_pdevs X)"
	and "e'' \<in> UNIV \<rightarrow> I"
	by metis
	note this(1)
	also
	from pdevs_val_nlex_pdevs2[OF \<open>e'' \<in> _\<close> \<open>_ = I\<close>]
	obtain e''' where "pdevs_val e'' (nlex_pdevs X) = pdevs_val e''' X" "e''' \<in> UNIV \<rightarrow> I"
	by metis
	note this(1)
	finally have "pdevs_val e (pdevs_of_list (inl X)) = pdevs_val e''' X" .
	thus ?thesis using \<open>e''' \<in> UNIV \<rightarrow> I\<close> ..
	qed

	lemma sum_list_nlex_eq_sum_list_inl:
	"sum_list (map snd (list_of_pdevs (nlex_pdevs X))) = sum_list (inl X)"
	by (auto simp: inl_def sum_list_list_of_pdevs sum_list_independent_pdevs)

	lemma Affine_inl: "Affine (fst X, pdevs_of_list (inl (snd X))) = Affine X"
	by (auto simp: Affine_def valuate_def aform_val_def
	elim: pdevs_val_pdevs_of_list_inlE[of _ _ "snd X"] pdevs_val_pdevs_of_list_inl2E[of _ "snd X"])


	subsection \<open>Half Segments\<close>

	definition half_segments_of_aform::"point aform \<Rightarrow> (point*point) list"
	where "half_segments_of_aform X =
	(let
	x0 = lowest_vertex (fst X, nlex_pdevs (snd X))
	in
	polychain_of x0 (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X)))))"

	lemma subsequent_half_segments:
	fixes X
	assumes "Suc i < length (half_segments_of_aform X)"
	shows "snd (half_segments_of_aform X ! i) = fst (half_segments_of_aform X ! Suc i)"
	using assms
	by (cases i) (auto simp: half_segments_of_aform_def Let_def polychain_of_subsequent_eq)

	lemma polychain_half_segments_of_aform: "polychain (half_segments_of_aform X)"
	by (auto simp: subsequent_half_segments intro!: polychainI)

	lemma fst_half_segments:
	"half_segments_of_aform X \<noteq> [] \<Longrightarrow>
	fst (half_segments_of_aform X ! 0) = lowest_vertex (fst X, nlex_pdevs (snd X))"
	by (auto simp: half_segments_of_aform_def Let_def o_def split_beta')

	lemma nlex_half_segments_of_aform: "(a, b) \<in> set (half_segments_of_aform X) \<Longrightarrow> lex b a"
	by (auto simp: half_segments_of_aform_def prod_eq_iff lex_def
	dest!: in_set_polychain_ofD in_set_inl_lex)

	lemma ccw_half_segments_of_aform_all:
	assumes cd: "(c, d) \<in> set (half_segments_of_aform X)"
	shows "list_all (\<lambda>(xi, xj). ccw xi xj c \<and> ccw xi xj d) (half_segments_of_aform X)"
	proof -
	have
	"list_all (\<lambda>(xi, xj). ccw xi xj (fst (c, d)) \<and> ccw xi xj (snd (c, d)))
	(polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X)))
	((map ((*\<^sub>R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X))))))"
	using ccw'_sortedP_scaled_inl cd[unfolded half_segments_of_aform_def Let_def]
	by (rule polychain_of_ccw_conjunction)
	thus ?thesis
	unfolding half_segments_of_aform_def[unfolded Let_def, symmetric] fst_conv snd_conv .
	qed

	lemma ccw_half_segments_of_aform:
	assumes ij: "(xi, xj) \<in> set (half_segments_of_aform X)"
	assumes c: "(c, d) \<in> set (half_segments_of_aform X)"
	shows "ccw xi xj c" "ccw xi xj d"
	using ccw_half_segments_of_aform_all[OF c] ij
	by (auto simp add: list_all_iff)

	lemma half_segments_of_aform1:
	assumes ch: "x \<in> convex hull set (map fst (half_segments_of_aform X))"
	assumes ab: "(a, b) \<in> set (half_segments_of_aform X)"
	shows "ccw a b x"
	using finite_set _ ch
	proof (rule ccw.convex_hull)
	fix c assume "c \<in> set (map fst (half_segments_of_aform X))"
	then obtain d where "(c, d) \<in> set (half_segments_of_aform X)" by auto
	with ab show "ccw a b c"
	by (rule ccw_half_segments_of_aform(1))
	qed (insert ab, simp add: nlex_half_segments_of_aform)

	lemma half_segments_of_aform2:
	assumes ch: "x \<in> convex hull set (map snd (half_segments_of_aform X))"
	assumes ab: "(a, b) \<in> set (half_segments_of_aform X)"
	shows "ccw a b x"
	using finite_set _ ch
	proof (rule ccw.convex_hull)
	fix d assume "d \<in> set (map snd (half_segments_of_aform X))"
	then obtain c where "(c, d) \<in> set (half_segments_of_aform X)" by auto
	with ab show "ccw a b d"
	by (rule ccw_half_segments_of_aform(2))
	qed (insert ab, simp add: nlex_half_segments_of_aform)

	lemma
	in_set_half_segments_of_aform_aform_valE:
	assumes "(x2, y2) \<in> set (half_segments_of_aform X)"
	obtains e where "y2 = aform_val e X" "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	proof -
	from assms obtain d where
	"y2 = lowest_vertex (fst X, nlex_pdevs (snd X)) +
	sum_list (take (Suc d) (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X)))))"
	by (auto simp: half_segments_of_aform_def elim!: in_set_polychain_of_imp_sum_list)
	also have "lowest_vertex (fst X, nlex_pdevs (snd X)) =
	fst X - sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X))))"
	by (simp add: lowest_vertex_def)
	also have "sum_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))) =
	pdevs_val (\<lambda>_. 1) (nlex_pdevs (snd X))"
	by (auto simp: pdevs_val_sum_list)
	also

	have "sum_list (take (Suc d) (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X))))) =
	pdevs_val (\<lambda>i. if i \<le> d then 2 else 0) (pdevs_of_list (ccw.selsort 0 (inl (snd X))))"
	(is "_ = pdevs_val ?e _")
	by (subst sum_list_take_pdevs_val_eq)
	(auto simp: pdevs_val_sum if_distrib pdevs_apply_pdevs_of_list
	degree_pdevs_of_list_scaleR intro!: sum.cong )
	also
	obtain e'' where "\<dots> = pdevs_val e'' (pdevs_of_list (inl (snd X)))" "e'' \<in> UNIV \<rightarrow> {0..2}"
	by (auto intro: pdevs_val_selsort_ccw2[of "inl (snd X)" ?e "{0 .. 2}"])
	note this(1)
	also note inl_def
	also
	let ?l = "map snd (list_of_pdevs (nlex_pdevs (snd X)))"
	from pdevs_val_independent_pdevs2[OF \<open>e'' \<in> _\<close>]
	obtain e'''
	where "pdevs_val e'' (pdevs_of_list (independent_pdevs ?l)) = pdevs_val e''' (pdevs_of_list ?l)"
	and "e''' \<in> UNIV \<rightarrow> {0..2}"
	by auto
	note this(1)
	also
	have "0 \<in> {0 .. 2::real}" by simp
	from pdevs_val_of_list_of_pdevs[OF \<open>e''' \<in> _\<close> this, of "nlex_pdevs (snd X)"]
	obtain e'''' where "pdevs_val e''' (pdevs_of_list ?l) = pdevs_val e'''' (nlex_pdevs (snd X))"
	and "e'''' \<in> UNIV \<rightarrow> {0 .. 2}"
	by metis
	note this(1)
	finally have
	"y2 = fst X + (pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (\<lambda>_. 1) (nlex_pdevs (snd X)))"
	by simp
	also have "pdevs_val e'''' (nlex_pdevs (snd X)) - pdevs_val (\<lambda>_. 1) (nlex_pdevs (snd X)) =
	pdevs_val (\<lambda>i. e'''' i - 1) (nlex_pdevs (snd X))"
	by (simp add: pdevs_val_minus)
	also
	have "(\<lambda>i. e'''' i - 1) \<in> UNIV \<rightarrow> {-1 .. 1}" using \<open>e'''' \<in> _\<close> by auto
	from pdevs_val_nlex_pdevs2[OF this]
	obtain f where "f \<in> UNIV \<rightarrow> {-1 .. 1}"
	and "pdevs_val (\<lambda>i. e'''' i - 1) (nlex_pdevs (snd X)) = pdevs_val f (snd X)"
	by auto
	note this(2)
	finally have "y2 = aform_val f X" by (simp add: aform_val_def)
	thus ?thesis using \<open>f \<in> _\<close> ..
	qed

	lemma fst_hd_half_segments_of_aform:
	assumes "half_segments_of_aform X \<noteq> []"
	shows "fst (hd (half_segments_of_aform X)) = lowest_vertex (fst X, (nlex_pdevs (snd X)))"
	using assms
	by (auto simp: half_segments_of_aform_def Let_def fst_hd_polychain_of)

	lemma
	"linorder_list0.sortedP (ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))))
	(map snd (half_segments_of_aform X))"
	(is "linorder_list0.sortedP (ccw' ?x0) ?ms")
	unfolding half_segments_of_aform_def Let_def
	by (rule ccw'_sortedP_polychain_of_snd) (rule ccw'_sortedP_scaled_inl)

	lemma rev_zip: "length xs = length ys \<Longrightarrow> rev (zip xs ys) = zip (rev xs) (rev ys)"
	by (induct xs ys rule: list_induct2) auto

	lemma zip_upt_self_aux: "zip [0..<length xs] xs = map (\<lambda>i. (i, xs ! i)) [0..<length xs]"
	by (auto intro!: nth_equalityI)

	lemma half_segments_of_aform_strict:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	assumes "seg \<in> set (half_segments_of_aform X)"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	shows "ccw' (fst seg) (snd seg) (aform_val e X)"
	using assms unfolding half_segments_of_aform_def Let_def
	proof -
	have len: "length (map ((*\<^sub>R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))) \<noteq> 1"
	using assms by (auto simp: half_segments_of_aform_def)

	have "aform_val e X = fst X + pdevs_val e (snd X)"
	by (simp add: aform_val_def)
	also
	obtain e' where "e' \<in> UNIV \<rightarrow> {-1 <..< 1}"
	"pdevs_val e (snd X) = pdevs_val e' (nlex_pdevs (snd X))"
	using pdevs_val_nlex_pdevs[OF \<open>e \<in> _\<close>]
	by auto
	note this(2)
	also obtain e'' where "e'' \<in> UNIV \<rightarrow> {-1 <..< 1}"
	"\<dots> = pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (nlex_pdevs (snd X)))))"
	by (metis pdevs_val_of_list_of_pdevs2[OF \<open>e' \<in> _\<close>])
	note this(2)
	also
	obtain e''' where "e''' \<in> UNIV \<rightarrow> {-1 <..< 1}" "\<dots> = pdevs_val e''' (pdevs_of_list (inl (snd X)))"
	unfolding inl_def
	using
	pdevs_val_independent_pdevs_strict[OF list_all_list_of_pdevsI,
	OF lex_nlex_pdevs list_of_pdevs_all_nonzero \<open>e'' \<in> _\<close>]
	by metis
	note this(2)
	also
	from pdevs_val_selsort_ccw[OF distinct_inl \<open>e''' \<in> _\<close>]
	obtain f where "f \<in> UNIV \<rightarrow> {-1 <..< 1}"
	"\<dots> = pdevs_val f (pdevs_of_list (linorder_list0.selsort (ccw 0) (inl (snd X))))"
	(is "_ = pdevs_val _ (pdevs_of_list ?sl)")
	by metis
	note this(2)
	also have "\<dots> = pdevs_val (\<lambda>i. f i + 1) (pdevs_of_list ?sl) +
	lowest_vertex (fst X, nlex_pdevs (snd X)) - fst X"
	proof -
	have "sum_list (dense_list_of_pdevs (nlex_pdevs (snd X))) =
	sum_list (dense_list_of_pdevs (pdevs_of_list (ccw.selsort 0 (inl (snd X)))))"
	by (subst dense_list_of_pdevs_pdevs_of_list)
	(auto simp: in_set_independent_pdevs_nonzero dense_list_of_pdevs_pdevs_of_list inl_def
	sum_list_distinct_selsort sum_list_independent_pdevs sum_list_list_of_pdevs)
	thus ?thesis
	by (auto simp add: pdevs_val_add lowest_vertex_def algebra_simps pdevs_val_sum_list
	sum_list_list_of_pdevs in_set_inl_nonzero dense_list_of_pdevs_pdevs_of_list)
	qed
	also have "pdevs_val (\<lambda>i. f i + 1) (pdevs_of_list ?sl) =
	pdevs_val (\<lambda>i. 1/2 * (f i + 1)) (pdevs_of_list (map ((*\<^sub>R) 2) ?sl))"
	(is "_ = pdevs_val ?f' (pdevs_of_list ?ssl)")
	by (subst pdevs_val_cmul) (simp add: pdevs_of_list_map_scaleR)
	also
	have "distinct ?ssl" "?f' \<in> UNIV \<rightarrow> {0<..<1}" using \<open>f \<in> _\<close>
	by (auto simp: distinct_map_scaleRI Pi_iff algebra_simps real_0_less_add_iff)
	from pdevs_of_list_sum[OF this]
	obtain g where "g \<in> UNIV \<rightarrow> {0<..<1}"
	"pdevs_val ?f' (pdevs_of_list ?ssl) = (\<Sum>P\<in>set ?ssl. g P *\<^sub>R P)"
	by blast
	note this(2)
	finally
	have "aform_val e X = lowest_vertex (fst X, nlex_pdevs (snd X)) + (\<Sum>P\<in>set ?ssl. g P *\<^sub>R P)"
	by simp
	also
	have "ccw' (fst seg) (snd seg) \<dots>"
	using \<open>g \<in> _\<close> _ len \<open>seg \<in> _\<close>[unfolded half_segments_of_aform_def Let_def]
	by (rule in_polychain_of_ccw) (simp add: ccw'_sortedP_scaled_inl)
	finally show ?thesis .
	qed

	lemma half_segments_of_aform_strict_all:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	shows "list_all (\<lambda>seg. ccw' (fst seg) (snd seg) (aform_val e X)) (half_segments_of_aform X)"
	using assms
	by (auto intro!: half_segments_of_aform_strict simp: list_all_iff)

	lemma list_allD: "list_all P xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> P x"
	by (auto simp: list_all_iff)

	lemma minus_one_less_multI:
	fixes e x::real
	shows "- 1 \<le> e \<Longrightarrow> 0 < x \<Longrightarrow> x < 1 \<Longrightarrow> - 1 < e * x"
	by (metis abs_add_one_gt_zero abs_real_def le_less_trans less_not_sym mult_less_0_iff
	mult_less_cancel_left1 real_0_less_add_iff)

	lemma less_one_multI:
	fixes e x::real
	shows "e \<le> 1 \<Longrightarrow> 0 < x \<Longrightarrow> x < 1 \<Longrightarrow> e * x < 1"
	by (metis (erased, opaque_lifting) less_eq_real_def monoid_mult_class.mult.left_neutral
	mult_strict_mono zero_less_one)

	lemma ccw_half_segments_of_aform_strictI:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	assumes "(s1, s2) \<in> set (half_segments_of_aform X)"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	assumes "x = (aform_val e X)"
	shows "ccw' s1 s2 x"
	using half_segments_of_aform_strict[OF assms(1-3)] assms(4) by simp

	lemma
	ccw'_sortedP_subsequent:
	assumes "Suc i < length xs" "ccw'.sortedP 0 (map dirvec xs)" "fst (xs ! Suc i) = snd (xs ! i)"
	shows "ccw' (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i))"
	using assms
	proof (induct xs arbitrary: i)
	case Nil thus ?case by simp
	next
	case (Cons x xs)
	thus ?case
	by (auto simp: nth_Cons dirvec_minus split: nat.split elim!: ccw'.sortedP_Cons)
	(metis (no_types, lifting) ccw'.renormalize length_greater_0_conv nth_mem prod.case_eq_if)
	qed

	lemma ccw'_sortedP_uminus: "ccw'.sortedP 0 xs \<Longrightarrow> ccw'.sortedP 0 (map uminus xs)"
	by (induct xs) (auto intro!: ccw'.sortedP.Cons elim!: ccw'.sortedP_Cons simp del: uminus_Pair)

	lemma subsequent_half_segments_ccw:
	fixes X
	assumes "Suc i < length (half_segments_of_aform X)"
	shows "ccw' (fst (half_segments_of_aform X ! i)) (snd (half_segments_of_aform X ! i))
	(snd (half_segments_of_aform X ! Suc i))"
	using assms
	by (intro ccw'_sortedP_subsequent )
	(auto simp: subsequent_half_segments half_segments_of_aform_def
	sorted_inl polychain_of_subsequent_eq intro!: ccw_sorted_implies_ccw'_sortedP[OF inl_ncoll]
	ccw'_sorted_scaleR)

	lemma convex_polychain_half_segments_of_aform: "convex_polychain (half_segments_of_aform X)"
	proof cases
	assume "length (half_segments_of_aform X) = 1"
	thus ?thesis
	by (auto simp: length_Suc_conv convex_polychain_def polychain_def)
	next
	assume len: "length (half_segments_of_aform X) \<noteq> 1"
	show ?thesis
	by (rule convex_polychainI)
	(simp_all add: polychain_half_segments_of_aform subsequent_half_segments_ccw
	ccw'_def[symmetric])
	qed

	lemma hd_distinct_neq_last: "distinct xs \<Longrightarrow> length xs > 1 \<Longrightarrow> hd xs \<noteq> last xs"
	by (metis One_nat_def add_Suc_right distinct.simps(2) last.simps last_in_set less_irrefl
	list.exhaust list.sel(1) list.size(3) list.size(4) add.right_neutral nat_neq_iff not_less0)

	lemma ccw_hd_last_half_segments_dirvec:
	assumes "length (half_segments_of_aform X) > 1"
	shows "ccw' 0 (dirvec (hd (half_segments_of_aform X))) (dirvec (last (half_segments_of_aform X)))"
	proof -
	let ?i = "ccw.selsort 0 (inl (snd X))"
	let ?s = "map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X)))"
	from assms have l: "1 < length (inl (snd X))" "inl (snd X) \<noteq> []"
	using assms by (auto simp add: half_segments_of_aform_def)
	hence "hd ?i \<in> set ?i" "last ?i \<in> set ?i"
	by (auto intro!: hd_in_set last_in_set simp del: ccw.set_selsort)
	hence "\<not>coll 0 (hd ?i) (last ?i)" using l
	by (intro inl_ncoll[of _ X]) (auto simp: hd_distinct_neq_last)
	hence "\<not>coll 0 (hd ?s) (last ?s)" using l
	by (auto simp: hd_map last_map)
	hence "ccw' 0 (hd (map ((*\<^sub>R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))))
	(last (map ((*\<^sub>R) 2) (linorder_list0.selsort (ccw 0) (inl (snd X)))))"
	using assms
	by (auto simp add: half_segments_of_aform_def
	intro!: sorted_inl ccw_sorted_scaleR ccw.hd_last_sorted ccw_ncoll_imp_ccw)
	with assms show ?thesis
	by (auto simp add: half_segments_of_aform_def Let_def
	dirvec_hd_polychain_of dirvec_last_polychain_of length_greater_0_conv[symmetric]
	simp del: polychain_of.simps length_greater_0_conv
	split: if_split_asm)
	qed

	lemma map_fst_half_segments_aux_eq: "[] \<noteq> half_segments_of_aform X \<Longrightarrow>
	map fst (half_segments_of_aform X) =
	fst (hd (half_segments_of_aform X))#butlast (map snd (half_segments_of_aform X))"
	by (rule nth_equalityI)
	(auto simp: nth_Cons hd_conv_nth nth_butlast subsequent_half_segments split: nat.split)

	lemma le_less_Suc_eq: "x - Suc 0 \<le> (i::nat) \<Longrightarrow> i < x \<Longrightarrow> x - Suc 0 = i"
	by simp

	lemma map_snd_half_segments_aux_eq: "half_segments_of_aform X \<noteq> [] \<Longrightarrow>
	map snd (half_segments_of_aform X) =
	tl (map fst (half_segments_of_aform X)) @ [snd (last (half_segments_of_aform X))]"
	by (rule nth_equalityI)
	(auto simp: nth_Cons hd_conv_nth nth_append nth_tl subsequent_half_segments
	not_less last_conv_nth algebra_simps dest!: le_less_Suc_eq
	split: nat.split)

	lemma ccw'_sortedP_snd_half_segments_of_aform:
	"ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))"
	by (auto simp: half_segments_of_aform_def Let_def
	intro!: ccw'.sortedP.Cons ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl)

	lemma
	lex_half_segments_lowest_vertex:
	assumes "(c, d) \<in> set (half_segments_of_aform X)"
	shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))"
	unfolding half_segments_of_aform_def Let_def
	by (rule lex_polychain_of_center[OF assms[unfolded half_segments_of_aform_def Let_def],
	unfolded snd_conv])
	(auto simp: list_all_iff lex_def dest!: in_set_inl_lex)

	lemma
	lex_half_segments_lowest_vertex':
	assumes "d \<in> set (map snd (half_segments_of_aform X))"
	shows "lex d (lowest_vertex (fst X, nlex_pdevs (snd X)))"
	using assms
	by (auto intro: lex_half_segments_lowest_vertex)

	lemma
	lex_half_segments_last:
	assumes "(c, d) \<in> set (half_segments_of_aform X)"
	shows "lex (snd (last (half_segments_of_aform X))) d"
	using assms
	unfolding half_segments_of_aform_def Let_def
	by (rule lex_polychain_of_last) (auto simp: list_all_iff lex_def dest!: in_set_inl_lex)

	lemma
	lex_half_segments_last':
	assumes "d \<in> set (map snd (half_segments_of_aform X))"
	shows "lex (snd (last (half_segments_of_aform X))) d"
	using assms
	by (auto intro: lex_half_segments_last)

	lemma
	ccw'_half_segments_lowest_last:
	assumes set_butlast: "(c, d) \<in> set (butlast (half_segments_of_aform X))"
	assumes ne: "inl (snd X) \<noteq> []"
	shows "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) d (snd (last (half_segments_of_aform X)))"
	using set_butlast
	unfolding half_segments_of_aform_def Let_def
	by (rule ccw'_polychain_of_sorted_center_last) (auto simp: ne ccw'_sortedP_scaled_inl)

	lemma distinct_fst_half_segments:
	"distinct (map fst (half_segments_of_aform X))"
	by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero
	simp del: scaleR_Pair
	intro!: distinct_fst_polychain_of
	dest: in_set_inl_nonzero in_set_inl_lex)

	lemma distinct_snd_half_segments:
	"distinct (map snd (half_segments_of_aform X))"
	by (auto simp: half_segments_of_aform_def list_all_iff lex_scale1_zero
	simp del: scaleR_Pair
	intro!: distinct_snd_polychain_of
	dest: in_set_inl_nonzero in_set_inl_lex)


	subsection \<open>Mirror\<close>

	definition "mirror_point x y = 2 *\<^sub>R x - y"

	lemma ccw'_mirror_point3[simp]:
	"ccw' (mirror_point x y) (mirror_point x z) (mirror_point x w) \<longleftrightarrow> ccw' y z w "
	by (auto simp: mirror_point_def det3_def' ccw'_def algebra_simps)

	lemma mirror_point_self_inverse[simp]:
	fixes x::"'a::real_vector"
	shows "mirror_point p (mirror_point p x) = x"
	by (auto simp: mirror_point_def scaleR_2)

	lemma mirror_half_segments_of_aform:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	shows "list_all (\<lambda>seg. ccw' (fst seg) (snd seg) (aform_val e X))
	(map (pairself (mirror_point (fst X))) (half_segments_of_aform X))"
	unfolding list_all_length
	proof safe
	let ?m = "map (pairself (mirror_point (fst X))) (half_segments_of_aform X)"
	fix n assume "n < length ?m"
	hence "ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n))
	(aform_val (- e) X)"
	using assms
	by (auto dest!: nth_mem intro!: half_segments_of_aform_strict)
	also have "aform_val (-e) X = 2 *\<^sub>R fst X - aform_val e X"
	by (auto simp: aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf)
	finally have le:
	"ccw' (fst (half_segments_of_aform X ! n)) (snd (half_segments_of_aform X ! n))
	(2 *\<^sub>R fst X - aform_val e X)"
	.

	have eq: "(map (pairself (mirror_point (fst X))) (half_segments_of_aform X) ! n) =
	(2 *\<^sub>R fst X - fst ((half_segments_of_aform X) ! n),
	2 *\<^sub>R fst X - snd ((half_segments_of_aform X) ! n))"
	using \<open>n < length ?m\<close>
	by (cases "half_segments_of_aform X ! n") (auto simp add: mirror_point_def)
	show "ccw' (fst (?m ! n)) (snd (?m ! n)) (aform_val e X)"
	using le
	unfolding eq
	by (auto simp: algebra_simps ccw'_def det3_def')
	qed

	lemma last_half_segments:
	assumes "half_segments_of_aform X \<noteq> []"
	shows "snd (last (half_segments_of_aform X)) =
	mirror_point (fst X) (lowest_vertex (fst X, nlex_pdevs (snd X)))"
	using assms
	by (auto simp add: half_segments_of_aform_def Let_def lowest_vertex_def mirror_point_def scaleR_2
	scaleR_sum_list[symmetric] last_polychain_of sum_list_distinct_selsort inl_def
	sum_list_independent_pdevs sum_list_list_of_pdevs)

	lemma convex_polychain_map_mirror:
	assumes "convex_polychain hs"
	shows "convex_polychain (map (pairself (mirror_point x)) hs)"
	proof (rule convex_polychainI)
	qed (insert assms, auto simp: convex_polychain_def polychain_map_pairself pairself_apply
	mirror_point_def det3_def' algebra_simps)

	lemma ccw'_mirror_point0:
	"ccw' (mirror_point x y) z w \<longleftrightarrow> ccw' y (mirror_point x z) (mirror_point x w)"
	by (metis ccw'_mirror_point3 mirror_point_self_inverse)

	lemma ccw'_sortedP_mirror:
	"ccw'.sortedP x0 (map (mirror_point p0) xs) \<longleftrightarrow> ccw'.sortedP (mirror_point p0 x0) xs"
	by (induct xs)
	(simp_all add: linorder_list0.sortedP.Nil linorder_list0.sortedP_Cons_iff ccw'_mirror_point0)

	lemma ccw'_sortedP_mirror2:
	"ccw'.sortedP (mirror_point p0 x0) (map (mirror_point p0) xs) \<longleftrightarrow> ccw'.sortedP x0 xs"
	using ccw'_sortedP_mirror[of "mirror_point p0 x0" p0 xs]
	by simp

	lemma map_mirror_o_snd_polychain_of_eq: "map (mirror_point x0 \<circ> snd) (polychain_of y xs) =
	map snd (polychain_of (mirror_point x0 y) (map uminus xs))"
	by (induct xs arbitrary: x0 y) (auto simp: mirror_point_def o_def algebra_simps)

	lemma lowest_vertex_eq_mirror_last:
	"half_segments_of_aform X \<noteq> [] \<Longrightarrow>
	(lowest_vertex (fst X, nlex_pdevs (snd X))) =
	mirror_point (fst X) (snd (last (half_segments_of_aform X)))"
	using last_half_segments[of X] by simp

	lemma snd_last: "xs \<noteq> [] \<Longrightarrow> snd (last xs) = last (map snd xs)"
	by (induct xs) auto

	lemma mirror_point_snd_last_eq_lowest:
	"half_segments_of_aform X \<noteq> [] \<Longrightarrow>
	mirror_point (fst X) (last (map snd (half_segments_of_aform X))) =
	lowest_vertex (fst X, nlex_pdevs (snd X))"
	by (simp add: lowest_vertex_eq_mirror_last snd_last)

	lemma lex_mirror_point: "lex (mirror_point x0 a) (mirror_point x0 b) \<Longrightarrow> lex b a"
	by (auto simp: mirror_point_def lex_def)

	lemma ccw'_mirror_point:
	"ccw' (mirror_point x0 a) (mirror_point x0 b) (mirror_point x0 c) \<Longrightarrow> ccw' a b c"
	by (auto simp: mirror_point_def)

	lemma inj_mirror_point: "inj (mirror_point (x::'a::real_vector))"
	by (auto simp: mirror_point_def inj_on_def algebra_simps)

	lemma
	distinct_map_mirror_point_eq:
	"distinct (map (mirror_point (x::'a::real_vector)) xs) = distinct xs"
	by (auto simp: distinct_map intro!: subset_inj_on[OF inj_mirror_point])

	lemma eq_self_mirror_iff: fixes x::"'a::real_vector" shows "x = mirror_point y x \<longleftrightarrow> x = y"
	by (auto simp: mirror_point_def algebra_simps scaleR_2[symmetric])


	subsection \<open>Full Segments\<close>

	definition segments_of_aform::"point aform \<Rightarrow> (point * point) list"
	where "segments_of_aform X =
	(let hs = half_segments_of_aform X in hs @ map (pairself (mirror_point (fst X))) hs)"

	lemma segments_of_aform_strict:
	assumes "e \<in> UNIV \<rightarrow> {-1 <..< 1}"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	shows "list_all (\<lambda>seg. ccw' (fst seg) (snd seg) (aform_val e X)) (segments_of_aform X)"
	using assms
	by (auto simp: segments_of_aform_def Let_def mirror_half_segments_of_aform
	half_segments_of_aform_strict_all)


	lemma mirror_point_aform_val[simp]: "mirror_point (fst X) (aform_val e X) = aform_val (- e) X"
	by (auto simp: mirror_point_def aform_val_def pdevs_val_sum algebra_simps scaleR_2 sum_negf)

	lemma
	in_set_segments_of_aform_aform_valE:
	assumes "(x2, y2) \<in> set (segments_of_aform X)"
	obtains e where "y2 = aform_val e X" "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	using assms
	proof (auto simp: segments_of_aform_def Let_def)
	assume "(x2, y2) \<in> set (half_segments_of_aform X)"
	from in_set_half_segments_of_aform_aform_valE[OF this]
	obtain e where "y2 = aform_val e X" "e \<in> UNIV \<rightarrow> {- 1..1}" by auto
	thus ?thesis ..
	next
	fix a b aa ba
	assume "((a, b), aa, ba) \<in> set (half_segments_of_aform X)"
	from in_set_half_segments_of_aform_aform_valE[OF this]
	obtain e where e: "(aa, ba) = aform_val e X" "e \<in> UNIV \<rightarrow> {- 1..1}" by auto
	assume "y2 = mirror_point (fst X) (aa, ba)"
	hence "y2 = aform_val (-e) X" "(-e) \<in> UNIV \<rightarrow> {-1 .. 1}" using e by auto
	thus ?thesis ..
	qed

	lemma
	last_half_segments_eq_mirror_hd:
	assumes "half_segments_of_aform X \<noteq> []"
	shows "snd (last (half_segments_of_aform X)) = mirror_point (fst X) (fst (hd (half_segments_of_aform X)))"
	by (simp add: last_half_segments assms fst_hd_half_segments_of_aform)

	lemma polychain_segments_of_aform: "polychain (segments_of_aform X)"
	by (auto simp: segments_of_aform_def Let_def polychain_half_segments_of_aform
	polychain_map_pairself last_half_segments_eq_mirror_hd hd_map pairself_apply
	intro!: polychain_appendI)

	lemma segments_of_aform_closed:
	assumes "segments_of_aform X \<noteq> []"
	shows "fst (hd (segments_of_aform X)) = snd (last (segments_of_aform X))"
	using assms
	by (auto simp: segments_of_aform_def Let_def fst_hd_half_segments_of_aform last_map
	pairself_apply last_half_segments mirror_point_def)

	lemma convex_polychain_segments_of_aform:
	assumes "1 < length (half_segments_of_aform X)"
	shows "convex_polychain (segments_of_aform X)"
	unfolding segments_of_aform_def Let_def
	using ccw_hd_last_half_segments_dirvec[OF assms]
	by (intro convex_polychain_appendI)
	(auto
	simp: convex_polychain_half_segments_of_aform convex_polychain_map_mirror dirvec_minus hd_map
	pairself_apply last_half_segments mirror_point_def fst_hd_half_segments_of_aform det3_def'
	algebra_simps ccw'_def
	intro!: polychain_appendI polychain_half_segments_of_aform polychain_map_pairself)

	lemma convex_polygon_segments_of_aform:
	assumes "1 < length (half_segments_of_aform X)"
	shows "convex_polygon (segments_of_aform X)"
	proof -
	from assms have hne: "half_segments_of_aform X \<noteq> []"
	by auto
	from convex_polychain_segments_of_aform[OF assms]
	have "convex_polychain (segments_of_aform X)" .
	thus ?thesis
	by (auto simp: convex_polygon_def segments_of_aform_closed)
	qed

	lemma
	previous_segments_of_aformE:
	assumes "(y, z) \<in> set (segments_of_aform X)"
	obtains x where "(x, y) \<in> set (segments_of_aform X)"
	proof -
	from assms have ne[simp]: "segments_of_aform X \<noteq> []"
	by auto
	from assms
	obtain i where i: "i<length (segments_of_aform X)" "(segments_of_aform X) ! i = (y, z)"
	by (auto simp: in_set_conv_nth)
	show ?thesis
	proof (cases i)
	case 0
	with segments_of_aform_closed[of X] assms
	have "(fst (last (segments_of_aform X)), y) \<in> set (segments_of_aform X)"
	by (metis fst_conv hd_conv_nth i(2) last_in_set ne snd_conv surj_pair)
	thus ?thesis ..
	next
	case (Suc j)
	have "(fst (segments_of_aform X ! j), snd (segments_of_aform X ! j)) \<in>
	set (segments_of_aform X)"
	using Suc i(1) by auto
	also
	from i have "y = fst (segments_of_aform X ! i)"
	by auto
	hence "snd (segments_of_aform X ! j) = y"
	using polychain_segments_of_aform[of X] i(1) Suc
	by (auto simp: polychain_def Suc)
	finally have "(fst (segments_of_aform X ! j), y) \<in> set (segments_of_aform X)" .
	thus ?thesis ..
	qed
	qed

	lemma fst_compose_pairself: "fst o pairself f = f o fst"
	and snd_compose_pairself: "snd o pairself f = f o snd"
	by (auto simp: pairself_apply)

	lemma in_set_butlastI: "xs \<noteq> [] \<Longrightarrow> x \<in> set xs \<Longrightarrow> x \<noteq> last xs \<Longrightarrow> x \<in> set (butlast xs)"
	by (induct xs) (auto split: if_splits)

	lemma distinct_in_set_butlastD:
	"x \<in> set (butlast xs) \<Longrightarrow> distinct xs \<Longrightarrow> x \<noteq> last xs"
	by (induct xs) auto

	lemma distinct_in_set_tlD:
	"x \<in> set (tl xs) \<Longrightarrow> distinct xs \<Longrightarrow> x \<noteq> hd xs"
	by (induct xs) auto

	lemma ccw'_sortedP_snd_segments_of_aform:
	assumes "length (inl (snd X)) > 1"
	shows
	"ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
	(butlast (map snd (segments_of_aform X)))"
	proof cases
	assume "[] = half_segments_of_aform X"
	from this show ?thesis
	by (simp add: segments_of_aform_def Let_def ccw'.sortedP.Nil)
	next
	assume H: "[] \<noteq> half_segments_of_aform X"
	let ?m = "mirror_point (fst X)"
	have ne: "inl (snd X) \<noteq> []" using assms by auto
	have "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
	(map snd (half_segments_of_aform X) @ butlast (map (?m \<circ> snd)
	(half_segments_of_aform X)))"
	proof (rule ccw'.sortedP_appendI)
	show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X))) (map snd (half_segments_of_aform X))"
	by (rule ccw'_sortedP_snd_half_segments_of_aform)
	have "butlast (map (?m \<circ> snd) (half_segments_of_aform X)) =
	butlast
	(map (?m \<circ> snd) (polychain_of (lowest_vertex (fst X, nlex_pdevs (snd X)))
	(map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X))))))"
	by (simp add: half_segments_of_aform_def)
	also have "\<dots> =
	map snd
	(butlast
	(polychain_of (?m (lowest_vertex (fst X, nlex_pdevs (snd X))))
	(map uminus (map ((*\<^sub>R) 2) (ccw.selsort 0 (inl (snd X)))))))"
	(is "_ = map snd (butlast (polychain_of ?x ?xs))")
	by (simp add: map_mirror_o_snd_polychain_of_eq map_butlast)
	also
	{
	have "ccw'.sortedP 0 ?xs"
	by (intro ccw'_sortedP_uminus ccw'_sortedP_scaled_inl)
	moreover
	have "ccw'.sortedP ?x (map snd (polychain_of ?x ?xs))"
	unfolding ccw'_sortedP_mirror[symmetric] map_map map_mirror_o_snd_polychain_of_eq
	by (auto simp add: o_def intro!: ccw'_sortedP_polychain_of_snd ccw'_sortedP_scaled_inl)
	ultimately
	have "ccw'.sortedP (snd (last (polychain_of ?x ?xs)))
	(map snd (butlast (polychain_of ?x ?xs)))"
	by (rule ccw'_sortedP_convex_rotate_aux)
	}
	also have "(snd (last (polychain_of ?x ?xs))) =
	?m (last (map snd (half_segments_of_aform X)))"
	by (simp add: half_segments_of_aform_def ne map_mirror_o_snd_polychain_of_eq
	last_map[symmetric, where f="?m"]
	last_map[symmetric, where f="snd"])
	also have "\<dots> = lowest_vertex (fst X, nlex_pdevs (snd X))"
	using ne H
	by (auto simp: lowest_vertex_eq_mirror_last snd_last)
	finally show "ccw'.sortedP (lowest_vertex (fst X, nlex_pdevs (snd X)))
	(butlast (map (?m \<circ> snd) (half_segments_of_aform X)))" .
	next
	fix x y
	assume seg: "x \<in> set (map snd (half_segments_of_aform X))"
	and mseg: "y \<in> set (butlast (map (?m \<circ> snd) (half_segments_of_aform X)))"
	from seg assms have neq_Nil: "inl (snd X) \<noteq> []" "half_segments_of_aform X \<noteq> []"
	by auto

	from seg obtain a where a: "(a, x) \<in> set (half_segments_of_aform X)"
	by auto
	from mseg obtain b
	where mirror_y: "(b, ?m y) \<in> set (butlast (half_segments_of_aform X))"
	by (auto simp: map_butlast[symmetric])

	let ?l = "lowest_vertex (fst X, nlex_pdevs (snd X))"
	let ?ml = "?m ?l"

	have mirror_eq_last: "?ml = snd (last (half_segments_of_aform X))"
	using seg H
	by (intro last_half_segments[symmetric]) simp

	define r
	where "r = ?l + (0, abs (snd x - snd ?l) + abs (snd y - snd ?l) + abs (snd ?ml - snd ?l) + 1)"

	have d1: "x \<noteq> r" "y \<noteq> r" "?l \<noteq> r" "?ml \<noteq> r"
	by (auto simp: r_def plus_prod_def prod_eq_iff)
	have "distinct (map (?m \<circ> snd) (half_segments_of_aform X))"
	unfolding map_comp_map[symmetric]
	unfolding o_def distinct_map_mirror_point_eq
	by (rule distinct_snd_half_segments)
	from distinct_in_set_butlastD[OF \<open>y \<in> _\<close> this]
	have "?l \<noteq> y"
	by (simp add: neq_Nil lowest_vertex_eq_mirror_last last_map)
	moreover have "?l \<noteq> ?ml"
	using neq_Nil by (auto simp add: eq_self_mirror_iff lowest_vertex_eq_center_iff inl_def)
	ultimately
	have d2: "?l \<noteq> y" "?l \<noteq> ?ml"
	by auto

	have *: "ccw' ?l (?m y) ?ml"
	by (metis mirror_eq_last ccw'_half_segments_lowest_last mirror_y neq_Nil(1))
	have "ccw' ?ml y ?l"
	by (rule ccw'_mirror_point[of "fst X"]) (simp add: *)
	hence lmy: "ccw' ?l ?ml y"
	by (simp add: ccw'_def det3_def' algebra_simps)
	let ?ccw = "ccw' (lowest_vertex (fst X, nlex_pdevs (snd X))) x y"
	{
	assume "x \<noteq> ?ml"
	hence x_butlast: "(a, x) \<in> set (butlast (half_segments_of_aform X))"
	unfolding mirror_eq_last
	using a
	by (auto intro!: in_set_butlastI simp: prod_eq_iff)
	have "ccw' ?l x ?ml"
	by (metis mirror_eq_last ccw'_half_segments_lowest_last x_butlast neq_Nil(1))
	} note lxml = this
	{
	assume "x = ?ml"
	hence ?ccw
	by (simp add: lmy)
	} moreover {
	assume "x \<noteq> ?ml" "y = ?ml"
	hence ?ccw
	by (simp add: lxml)
	} moreover {
	assume d3: "x \<noteq> ?ml" "y \<noteq> ?ml"

	from \<open>x \<in> set _\<close>
	have "x \<in> set (map snd (half_segments_of_aform X))" by force
	hence "x \<in> set (tl (map fst (half_segments_of_aform X)))"
	using d3
	unfolding map_snd_half_segments_aux_eq[OF neq_Nil(2)]
	by (auto simp: mirror_eq_last)
	from distinct_in_set_tlD[OF this distinct_fst_half_segments]
	have "?l \<noteq> x"
	by (simp add: fst_hd_half_segments_of_aform neq_Nil hd_map)

	from lxml[OF \<open>x \<noteq> ?ml\<close>] \<open>ccw' ?l ?ml y\<close>
	have d4: "x \<noteq> y"
	by (rule neq_left_right_of lxml)

	have "distinct5 x ?ml y r ?l"
	using d1 d2 \<open>?l \<noteq> x\<close> d3 d4
	by simp_all
	moreover
	note _
	moreover
	have "lex x ?l"
	by (rule lex_half_segments_lowest_vertex) fact
	hence "ccw ?l r x"
	unfolding r_def by (rule lex_ccw_left) simp
	moreover
	have "lex ?ml ?l"
	using last_in_set[OF H[symmetric]]
	by (auto simp: mirror_eq_last intro: lex_half_segments_lowest_vertex')
	hence "ccw ?l r ?ml"
	unfolding r_def by (rule lex_ccw_left) simp
	moreover
	have "lex (?m (lowest_vertex (fst X, nlex_pdevs (snd X)))) (?m y)"
	using mirror_y
	by (force dest!: in_set_butlastD intro: lex_half_segments_last' simp: mirror_eq_last )
	hence "lex y ?l"
	by (rule lex_mirror_point)
	hence "ccw ?l r y"
	unfolding r_def by (rule lex_ccw_left) simp
	moreover
	from \<open>x \<noteq> ?ml\<close> have "ccw ?l x ?ml"
	by (simp add: ccw_def lxml)
	moreover
	from lmy have "ccw ?l ?ml y"
	by (simp add: ccw_def)
	ultimately
	have "ccw ?l x y"
	by (rule ccw.transitive[where S=UNIV]) simp

	moreover
	{
	have "x \<noteq> ?l" using \<open>?l \<noteq> x\<close> by simp
	moreover
	have "lex (?m y) (?m ?ml)"
	using mirror_y
	by (force intro: lex_half_segments_lowest_vertex in_set_butlastD)
	hence "lex ?ml y"
	by (rule lex_mirror_point)
	moreover
	from a have "lex ?ml x"
	unfolding mirror_eq_last
	by (rule lex_half_segments_last)
	moreover note \<open>lex y ?l\<close> \<open>lex x ?l\<close> \<open>ccw' ?l x ?ml\<close> \<open>ccw' ?l ?ml y\<close>
	ultimately
	have ncoll: "\<not> coll ?l x y"
	by (rule not_coll_ordered_lexI)
	}
	ultimately have ?ccw
	by (simp add: ccw_def)
	} ultimately show ?ccw
	by blast
	qed
	thus ?thesis using H
	by (simp add: segments_of_aform_def Let_def butlast_append snd_compose_pairself)
	qed

	lemma polychain_of_segments_of_aform1:
	assumes "length (segments_of_aform X) = 1"
	shows "False"
	using assms
	by (auto simp: segments_of_aform_def Let_def half_segments_of_aform_def add_is_1
	split: if_split_asm)

	lemma polychain_of_segments_of_aform2:
	assumes "segments_of_aform X = [x, y]"
	assumes "between (fst x, snd x) p"
	shows "p \<in> convex hull set (map fst (segments_of_aform X))"
	proof -
	from polychain_segments_of_aform[of X] segments_of_aform_closed[of X] assms
	have "fst y = snd x" "snd y = fst x" by (simp_all add: polychain_def)
	thus ?thesis
	using assms
	by (cases x) (auto simp: between_mem_convex_hull)
	qed

	lemma append_eq_2:
	assumes "length xs = length ys"
	shows "xs @ ys = [x, y] \<longleftrightarrow> xs = [x] \<and> ys = [y]"
	using assms
	proof (cases xs)
	case (Cons z zs)
	thus ?thesis using assms by (cases zs) auto
	qed simp

	lemma segments_of_aform_line_segment:
	assumes "segments_of_aform X = [x, y]"
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "aform_val e X \<in> closed_segment (fst x) (snd x)"
	proof -
	from pdevs_val_pdevs_of_list_inl2E[OF \<open>e \<in> _\<close>, of "snd X"]
	obtain e' where e': "pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (inl (snd X)))"
	"e' \<in> UNIV \<rightarrow> {- 1..1}" .
	from e' have "0 \<le> 1 + e' 0" by (auto simp: Pi_iff dest!: spec[where x=0])
	with assms e' show ?thesis
	by (auto simp: segments_of_aform_def Let_def append_eq_2 half_segments_of_aform_def
	polychain_of_singleton_iff mirror_point_def ccw.selsort_singleton_iff lowest_vertex_def
	aform_val_def sum_list_nlex_eq_sum_list_inl closed_segment_def Pi_iff
	intro!: exI[where x="(1 + e' 0) / 2"])
	(auto simp: algebra_simps)
	qed


	subsection \<open>Continuous Generalization\<close>

	lemma LIMSEQ_minus_fract_mult:
	"(\<lambda>n. r * (1 - 1 / real (Suc (Suc n)))) \<longlonglongrightarrow> r"
	by (rule tendsto_eq_rhs[OF tendsto_mult[where a=r and b = 1]])
	(auto simp: inverse_eq_divide[symmetric] simp del: of_nat_Suc
	intro: filterlim_compose[OF LIMSEQ_inverse_real_of_nat filterlim_Suc] tendsto_eq_intros)

	lemma det3_nonneg_segments_of_aform:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	shows "list_all (\<lambda>seg. det3 (fst seg) (snd seg) (aform_val e X) \<ge> 0) (segments_of_aform X)"
	unfolding list_all_iff
	proof safe
	fix a b c d
	assume seg: "((a, b), c, d) \<in> set (segments_of_aform X)" (is "?seg \<in> _")
	define normal_of_segment
	where "normal_of_segment = (\<lambda>((a0, a1), b0, b1). (b1 - a1, a0 - b0)::real*real)"
	define support_of_segment
	where "support_of_segment = (\<lambda>(a, b). normal_of_segment (a, b) \<bullet> a)"
	have "closed ((\<lambda>x. x \<bullet> normal_of_segment ?seg) -` {..support_of_segment ?seg})" (is "closed ?cl")
	by (auto intro!: continuous_intros closed_vimage)
	moreover
	define f where "f n i = e i * ( 1 - 1 / (Suc (Suc n)))" for n i
	have "\<forall>n. aform_val (f n) X \<in> ?cl"
	proof
	fix n
	have "f n \<in> UNIV \<rightarrow> {-1 <..< 1}"
	using assms
	by (auto simp: f_def Pi_iff intro!: less_one_multI minus_one_less_multI)
	from list_allD[OF segments_of_aform_strict[OF this assms(2)] seg]
	show "aform_val (f n) X \<in> (\<lambda>x. x \<bullet> normal_of_segment ((a, b), c, d)) -`
	{..support_of_segment ((a, b), c, d)}"
	by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def
	det3_def' field_simps inner_prod_def ccw'_def)
	qed
	moreover
	have "\<And>i. (\<lambda>n. f n i) \<longlonglongrightarrow> e i"
	unfolding f_def
	by (rule LIMSEQ_minus_fract_mult)
	hence "(\<lambda>n. aform_val (f n) X) \<longlonglongrightarrow> aform_val e X"
	by (auto simp: aform_val_def pdevs_val_sum intro!: tendsto_intros)
	ultimately have "aform_val e X \<in> ?cl"
	by (rule closed_sequentially)
	thus "det3 (fst ?seg) (snd ?seg) (aform_val e X) \<ge> 0"
	by (auto simp: list_all_iff normal_of_segment_def support_of_segment_def det3_def' field_simps
	inner_prod_def)
	qed

	lemma det3_nonneg_segments_of_aformI:
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes "length (half_segments_of_aform X) \<noteq> 1"
	assumes "seg \<in> set (segments_of_aform X)"
	shows "det3 (fst seg) (snd seg) (aform_val e X) \<ge> 0"
	using assms det3_nonneg_segments_of_aform by (auto simp: list_all_iff)


	subsection \<open>Intersection of Vertical Line with Segment\<close>

	fun intersect_segment_xline'::"nat \<Rightarrow> point * point \<Rightarrow> real \<Rightarrow> point option"
	where "intersect_segment_xline' p ((x0, y0), (x1, y1)) xl =
	(if x0 \<le> xl \<and> xl \<le> x1 then
	if x0 = x1 then Some ((min y0 y1), (max y0 y1))
	else
	let
	yl = truncate_down p (truncate_down p (real_divl p (y1 - y0) (x1 - x0) * (xl - x0)) + y0);
	yr = truncate_up p (truncate_up p (real_divr p (y1 - y0) (x1 - x0) * (xl - x0)) + y0)
	in Some (yl, yr)
	else None)"

	lemma norm_pair_fst0[simp]: "norm (0, x) = norm x"
	by (auto simp: norm_prod_def)

	lemmas add_right_mono_le = order_trans[OF add_right_mono]
	lemmas mult_right_mono_le = order_trans[OF mult_right_mono]

	lemmas add_right_mono_ge = order_trans[OF _ add_right_mono]
	lemmas mult_right_mono_ge = order_trans[OF _ mult_right_mono]

	lemma dest_segment:
	fixes x b::real
	assumes "(x, b) \<in> closed_segment (x0, y0) (x1, y1)"
	assumes "x0 \<noteq> x1"
	shows "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0"
	proof -
	from assms obtain u where u: "x = x0 \<^sub>R (1 - u) + u x1" "b = y0 \<^sub>R (1 - u) + u y1" "0 \<le> u" "u \<le> 1"
	by (auto simp: closed_segment_def algebra_simps)
	show "b = (y1 - y0) * (x - x0) / (x1 - x0) + y0 "
	using assms by (auto simp: closed_segment_def field_simps u)
	qed

	lemma intersect_segment_xline':
	assumes "intersect_segment_xline' prec (p0, p1) x = Some (m, M)"
	shows "closed_segment p0 p1 \<inter> {p. fst p = x} \<subseteq> {(x, m) .. (x, M)}"
	using assms
	proof (cases p0)
	case (Pair x0 y0) note p0 = this
	show ?thesis
	proof (cases p1)
	case (Pair x1 y1) note p1 = this
	{
	assume "x0 = x1" "x = x1" "m = min y0 y1" "M = max y0 y1"
	hence ?thesis
	by (force simp: abs_le_iff p0 p1 min_def max_def algebra_simps dest: segment_bound
	split: if_split_asm)
	} thus ?thesis
	using assms
	by (auto simp: abs_le_iff p0 p1 split: if_split_asm
	intro!: truncate_up_le truncate_down_le
	add_right_mono_le[OF truncate_down]
	add_right_mono_le[OF real_divl]
	add_right_mono_le[OF mult_right_mono_le[OF real_divl]]
	add_right_mono_ge[OF _ truncate_up]
	add_right_mono_ge[OF _ mult_right_mono_ge[OF _ real_divr]]
	dest!: dest_segment)
	qed
	qed

	lemma
	in_segment_fst_le:
	fixes x0 x1 b::real
	assumes "x0 \<le> x1" "(x, b) \<in> closed_segment (x0, y0) (x1, y1)"
	shows "x \<le> x1"
	using assms using mult_left_mono[OF \<open>x0 \<le> x1\<close>, where c="1 - u" for u]
	by (force simp add: min_def max_def split: if_split_asm
	simp add: algebra_simps not_le closed_segment_def)

	lemma
	in_segment_fst_ge:
	fixes x0 x1 b::real
	assumes "x0 \<le> x1" "(x, b) \<in> closed_segment (x0, y0) (x1, y1)"
	shows "x0 \<le> x"
	using assms using mult_left_mono[OF \<open>x0 \<le> x1\<close>]
	by (force simp add: min_def max_def split: if_split_asm
	simp add: algebra_simps not_le closed_segment_def)

	lemma intersect_segment_xline'_eq_None:
	assumes "intersect_segment_xline' prec (p0, p1) x = None"
	assumes "fst p0 \<le> fst p1"
	shows "closed_segment p0 p1 \<inter> {p. fst p = x} = {}"
	using assms
	by (cases p0, cases p1)
	(auto simp: abs_le_iff split: if_split_asm dest: in_segment_fst_le in_segment_fst_ge)

	fun intersect_segment_xline
	where "intersect_segment_xline prec ((a, b), (c, d)) x =
	(if a \<le> c then intersect_segment_xline' prec ((a, b), (c, d)) x
	else intersect_segment_xline' prec ((c, d), (a, b)) x)"

	lemma closed_segment_commute: "closed_segment a b = closed_segment b a"
	by (meson convex_contains_segment convex_closed_segment dual_order.antisym ends_in_segment)

	lemma intersect_segment_xline:
	assumes "intersect_segment_xline prec (p0, p1) x = Some (m, M)"
	shows "closed_segment p0 p1 \<inter> {p. fst p = x} \<subseteq> {(x, m) .. (x, M)}"
	using assms
	by (cases p0, cases p1)
	(auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps
	dest!: intersect_segment_xline')

	lemma intersect_segment_xline_fst_snd:
	assumes "intersect_segment_xline prec seg x = Some (m, M)"
	shows "closed_segment (fst seg) (snd seg) \<inter> {p. fst p = x} \<subseteq> {(x, m) .. (x, M)}"
	using intersect_segment_xline[of prec "fst seg" "snd seg" x m M] assms
	by simp

	lemma intersect_segment_xline_eq_None:
	assumes "intersect_segment_xline prec (p0, p1) x = None"
	shows "closed_segment p0 p1 \<inter> {p. fst p = x} = {}"
	using assms
	by (cases p0, cases p1)
	(auto simp: closed_segment_commute split: if_split_asm simp del: intersect_segment_xline'.simps
	dest!: intersect_segment_xline'_eq_None)

	lemma inter_image_empty_iff: "(X \<inter> {p. f p = x} = {}) \<longleftrightarrow> (x \<notin> f ` X)"
	by auto

	lemma fst_closed_segment[simp]: "fst ` closed_segment a b = closed_segment (fst a) (fst b)"
	by (force simp: closed_segment_def)

	lemma intersect_segment_xline_eq_empty:
	fixes p0 p1::"real * real"
	assumes "closed_segment p0 p1 \<inter> {p. fst p = x} = {}"
	shows "intersect_segment_xline prec (p0, p1) x = None"
	using assms
	by (cases p0, cases p1)
	(auto simp: inter_image_empty_iff closed_segment_eq_real_ivl split: if_split_asm)

	lemma intersect_segment_xline_le:
	assumes "intersect_segment_xline prec y xl = Some (m0, M0)"
	shows "m0 \<le> M0"
	using assms
	by (cases y) (auto simp: min_def split: if_split_asm intro!: truncate_up_le truncate_down_le
	order_trans[OF real_divl] order_trans[OF _ real_divr] mult_right_mono)

	lemma intersect_segment_xline_None_iff:
	fixes p0 p1::"real * real"
	shows "intersect_segment_xline prec (p0, p1) x = None \<longleftrightarrow> closed_segment p0 p1 \<inter> {p. fst p = x} = {}"
	by (auto intro!: intersect_segment_xline_eq_empty dest!: intersect_segment_xline_eq_None)


	subsection \<open>Bounds on Vertical Intersection with Oriented List of Segments\<close>

	primrec bound_intersect_2d where
	"bound_intersect_2d prec [] x = None"
	\| "bound_intersect_2d prec (X # Xs) xl =
	(case bound_intersect_2d prec Xs xl of
	None \<Rightarrow> intersect_segment_xline prec X xl
	\| Some (m, M) \<Rightarrow>
	(case intersect_segment_xline prec X xl of
	None \<Rightarrow> Some (m, M)
	\| Some (m', M') \<Rightarrow> Some (min m' m, max M' M)))"

	lemma
	bound_intersect_2d_eq_None:
	assumes "bound_intersect_2d prec Xs x = None"
	assumes "X \<in> set Xs"
	shows "intersect_segment_xline prec X x = None"
	using assms by (induct Xs) (auto split: option.split_asm)

	lemma bound_intersect_2d_upper:
	assumes "bound_intersect_2d prec Xs x = Some (m, M)"
	obtains X m' where "X \<in> set Xs" "intersect_segment_xline prec X x = Some (m', M)"
	"\<And>X m' M' . X \<in> set Xs \<Longrightarrow> intersect_segment_xline prec X x = Some (m', M') \<Longrightarrow> M' \<le> M"
	proof atomize_elim
	show "\<exists>X m'. X \<in> set Xs \<and> intersect_segment_xline prec X x = Some (m', M) \<and>
	(\<forall>X m' M'. X \<in> set Xs \<longrightarrow> intersect_segment_xline prec X x = Some (m', M') \<longrightarrow> M' \<le> M)"
	using assms
	proof (induct Xs arbitrary: m M)
	case Nil thus ?case by (simp add: bound_intersect_2d_def)
	next
	case (Cons X Xs)
	show ?case
	proof (cases "bound_intersect_2d prec Xs x")
	case None
	thus ?thesis using Cons
	by (intro exI[where x=X] exI[where x=m])
	(simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None)
	next
	case (Some mM)
	note Some1=this
	then obtain m' M' where mM: "mM = (m', M')" by (cases mM)
	from Cons(1)[OF Some[unfolded mM]]
	obtain X' m'' where X': "X' \<in> set Xs"
	and m'': "intersect_segment_xline prec X' x = Some (m'', M')"
	and max: "\<And>X m' M'a. X \<in> set Xs \<Longrightarrow> intersect_segment_xline prec X x = Some (m', M'a) \<Longrightarrow>
	M'a \<le> M'"
	by auto
	show ?thesis
	proof (cases "intersect_segment_xline prec X x")
	case None thus ?thesis using Some1 mM Cons(2) X' m'' max
	by (intro exI[where x= X'] exI[where x= m''])
	(auto simp del: intersect_segment_xline.simps split: option.split_asm)
	next
	case (Some mM''')
	thus ?thesis using Some1 mM Cons(2) X' m''
	by (cases mM''')
	(force simp: max_def min_def simp del: intersect_segment_xline.simps
	split: option.split_asm if_split_asm dest!: max
	intro!: exI[where x= "if M' \<ge> snd mM''' then X' else X"]
	exI[where x= "if M' \<ge> snd mM''' then m'' else fst mM'''"])
	qed
	qed
	qed
	qed

	lemma bound_intersect_2d_lower:
	assumes "bound_intersect_2d prec Xs x = Some (m, M)"
	obtains X M' where "X \<in> set Xs" "intersect_segment_xline prec X x = Some (m, M')"
	"\<And>X m' M' . X \<in> set Xs \<Longrightarrow> intersect_segment_xline prec X x = Some (m', M') \<Longrightarrow> m \<le> m'"
	proof atomize_elim
	show "\<exists>X M'. X \<in> set Xs \<and> intersect_segment_xline prec X x = Some (m, M') \<and>
	(\<forall>X m' M'. X \<in> set Xs \<longrightarrow> intersect_segment_xline prec X x = Some (m', M') \<longrightarrow> m \<le> m')"
	using assms
	proof (induct Xs arbitrary: m M)
	case Nil thus ?case by (simp add: bound_intersect_2d_def)
	next
	case (Cons X Xs)
	show ?case
	proof (cases "bound_intersect_2d prec Xs x")
	case None
	thus ?thesis using Cons
	by (intro exI[where x= X])
	(simp del: intersect_segment_xline.simps add: bound_intersect_2d_eq_None)
	next
	case (Some mM)
	note Some1=this
	then obtain m' M' where mM: "mM = (m', M')" by (cases mM)
	from Cons(1)[OF Some[unfolded mM]]
	obtain X' M'' where X': "X' \<in> set Xs"
	and M'': "intersect_segment_xline prec X' x = Some (m', M'')"
	and min: "\<And>X m'a M'. X \<in> set Xs \<Longrightarrow> intersect_segment_xline prec X x = Some (m'a, M') \<Longrightarrow>
	m' \<le> m'a"
	by auto
	show ?thesis
	proof (cases "intersect_segment_xline prec X x")
	case None thus ?thesis using Some1 mM Cons(2) X' M'' min
	by (intro exI[where x= X'] exI[where x= M''])
	(auto simp del: intersect_segment_xline.simps split: option.split_asm)
	next
	case (Some mM''')
	thus ?thesis using Some1 mM Cons(2) X' M'' min
	by (cases mM''')
	(force simp: max_def min_def
	simp del: intersect_segment_xline.simps
	split: option.split_asm if_split_asm
	dest!: min
	intro!: exI[where x= "if m' \<le> fst mM''' then X' else X"]
	exI[where x= "if m' \<le> fst mM''' then M'' else snd mM'''"])
	qed
	qed
	qed
	qed

	lemma bound_intersect_2d:
	assumes "bound_intersect_2d prec Xs x = Some (m, M)"
	shows "(\<Union>(p1, p2) \<in> set Xs. closed_segment p1 p2) \<inter> {p. fst p = x} \<subseteq> {(x, m) .. (x, M)}"
	proof (clarsimp, safe)
	fix b x0 y0 x1 y1
	assume H: "((x0, y0), x1, y1) \<in> set Xs" "(x, b) \<in> closed_segment (x0, y0) (x1, y1)"
	hence "intersect_segment_xline prec ((x0, y0), x1, y1) x \<noteq> None"
	by (intro notI)
	(auto dest!: intersect_segment_xline_eq_None simp del: intersect_segment_xline.simps)
	then obtain e f where ef: "intersect_segment_xline prec ((x0, y0), x1, y1) x = Some (e, f)"
	by auto
	with H have "m \<le> e"
	by (auto intro: bound_intersect_2d_lower[OF assms])
	also have "\<dots> \<le> b"
	using intersect_segment_xline[OF ef] H
	by force
	finally show "m \<le> b" .
	have "b \<le> f"
	using intersect_segment_xline[OF ef] H
	by force
	also have "\<dots> \<le> M"
	using H ef by (auto intro: bound_intersect_2d_upper[OF assms])
	finally show "b \<le> M" .
	qed

	lemma bound_intersect_2d_eq_None_iff:
	"bound_intersect_2d prec Xs x = None \<longleftrightarrow> (\<forall>X\<in>set Xs. intersect_segment_xline prec X x = None)"
	by (induct Xs) (auto simp: split: option.split_asm)

	lemma bound_intersect_2d_nonempty:
	assumes "bound_intersect_2d prec Xs x = Some (m, M)"
	shows "(\<Union>(p1, p2) \<in> set Xs. closed_segment p1 p2) \<inter> {p. fst p = x} \<noteq> {}"
	proof -
	from assms have "bound_intersect_2d prec Xs x \<noteq> None" by simp
	then obtain p1 p2 where "(p1, p2) \<in> set Xs" "intersect_segment_xline prec (p1, p2) x \<noteq> None"
	unfolding bound_intersect_2d_eq_None_iff by auto
	hence "closed_segment p1 p2 \<inter> {p. fst p = x} \<noteq> {}"
	by (simp add: intersect_segment_xline_None_iff)
	thus ?thesis using \<open>(p1, p2) \<in> set Xs\<close> by auto
	qed

	lemma bound_intersect_2d_le:
	assumes "bound_intersect_2d prec Xs x = Some (m, M)" shows "m \<le> M"
	proof -
	from bound_intersect_2d_nonempty[OF assms] bound_intersect_2d[OF assms]
	show "m \<le> M" by auto
	qed


	subsection \<open>Bounds on Vertical Intersection with General List of Segments\<close>

	definition "bound_intersect_2d_ud prec X xl =
	(case segments_of_aform X of
	[] \<Rightarrow> if fst (fst X) = xl then let m = snd (fst X) in Some (m, m) else None
	\| [x, y] \<Rightarrow> intersect_segment_xline prec x xl
	\| xs \<Rightarrow>
	(case bound_intersect_2d prec (filter (\<lambda>((x1, y1), x2, y2). x1 < x2) xs) xl of
	Some (m, M') \<Rightarrow>
	(case bound_intersect_2d prec (filter (\<lambda>((x1, y1), x2, y2). x1 > x2) xs) xl of
	Some (m', M) \<Rightarrow> Some (min m m', max M M')
	\| None \<Rightarrow> None)
	\| None \<Rightarrow> None))"

	lemma list_cases4:
	"\<And>x P. (x = [] \<Longrightarrow> P) \<Longrightarrow> (\<And>y. x = [y] \<Longrightarrow> P) \<Longrightarrow>
	(\<And>y z. x = [y, z] \<Longrightarrow> P) \<Longrightarrow>
	(\<And>w y z zs. x = w # y # z # zs \<Longrightarrow> P) \<Longrightarrow> P"
	by (metis list.exhaust)

	lemma bound_intersect_2d_ud_segments_of_aform_le:
	"bound_intersect_2d_ud prec X xl = Some (m0, M0) \<Longrightarrow> m0 \<le> M0"
	by (cases "segments_of_aform X" rule: list_cases4)
	(auto simp: Let_def bound_intersect_2d_ud_def min_def max_def intersect_segment_xline_le
	if_split_eq1 split: option.split_asm prod.split_asm list.split_asm
	dest!: bound_intersect_2d_le)

	lemma pdevs_domain_eq_empty_iff[simp]: "pdevs_domain (snd X) = {} \<longleftrightarrow> snd X = zero_pdevs"
	by (auto simp: intro!: pdevs_eqI)

	lemma ccw_contr_on_line_left:
	assumes "det3 (a, b) (x, c) (x, d) \<ge> 0" "a > x"
	shows "d \<le> c"
	proof -
	from assms have "d * (a - x) \<le> c * (a - x)"
	by (auto simp: det3_def' algebra_simps)
	with assms show "c \<ge> d" by auto
	qed

	lemma ccw_contr_on_line_right:
	assumes "det3 (a, b) (x, c) (x, d) \<ge> 0" "a < x"
	shows "d \<ge> c"
	proof -
	from assms have "c * (x - a) \<le> d * (x - a)"
	by (auto simp: det3_def' algebra_simps)
	with assms show "d \<ge> c" by auto
	qed

	lemma singleton_contrE:
	assumes "\<And>x y. x \<noteq> y \<Longrightarrow> x \<in> X \<Longrightarrow> y \<in> X \<Longrightarrow> False"
	assumes "X \<noteq> {}"
	obtains x where "X = {x}"
	using assms by blast

	lemma segment_intersection_singleton:
	fixes xl and a b::"real * real"
	defines "i \<equiv> closed_segment a b \<inter> {p. fst p = xl}"
	assumes ne1: "fst a \<noteq> fst b"
	assumes upper: "i \<noteq> {}"
	obtains p1 where "i = {p1}"
	proof (rule singleton_contrE[OF _ upper])
	fix x y assume H: "x \<noteq> y" "x \<in> i" "y \<in> i"
	then obtain u v where uv: "x = u \<^sub>R b + (1 - u) \<^sub>R a" "y = v \<^sub>R b + (1 - v) \<^sub>R a"
	"0 \<le> u" "u \<le> 1" "0 \<le> v" "v \<le> 1"
	by (auto simp add: closed_segment_def i_def field_simps)
	then have "x + u \<^sub>R a = a + u \<^sub>R b" "y + v \<^sub>R a = a + v \<^sub>R b"
	by simp_all
	then have "fst (x + u \<^sub>R a) = fst (a + u \<^sub>R b)" "fst (y + v \<^sub>R a) = fst (a + v \<^sub>R b)"
	by simp_all
	then have "u = v * (fst a - fst b) / (fst a - fst b)"
	using ne1 H(2,3) \<open>0 \<le> u\<close> \<open>u \<le> 1\<close> \<open>0 \<le> v\<close> \<open>v \<le> 1\<close>
	by (simp add: closed_segment_def i_def field_simps)
	then have "u = v"
	by (simp add: ne1)
	then show False using H uv
	by simp
	qed

	lemma bound_intersect_2d_ud_segments_of_aform:
	assumes "bound_intersect_2d_ud prec X xl = Some (m0, M0)"
	assumes "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	shows "{aform_val e X} \<inter> {x. fst x = xl} \<subseteq> {(xl, m0) .. (xl, M0)}"
	proof safe
	fix a b
	assume safeassms: "(a, b) = aform_val e X" "xl = fst (a, b)"
	hence fst_aform_val: "fst (aform_val e X) = xl"
	by simp
	{
	assume len: "length (segments_of_aform X) > 2"
	with assms obtain m M m' M'
	where lb: "bound_intersect_2d prec
	[((x1, y1), x2, y2)\<leftarrow>segments_of_aform X . x1 < x2] xl = Some (m, M')"
	and ub: "bound_intersect_2d prec
	[((x1, y1), x2, y2)\<leftarrow>segments_of_aform X . x2 < x1] xl = Some (m', M)"
	and minmax: "m0 = min m m'" "M0 = max M M'"
	by (auto simp: bound_intersect_2d_ud_def split: option.split_asm list.split_asm )
	from bound_intersect_2d_upper[OF ub] obtain X1 m1
	where upper:
	"X1 \<in> set [((x1, y1), x2, y2)\<leftarrow>segments_of_aform X . x2 < x1]"
	"intersect_segment_xline prec X1 xl = Some (m1, M)"
	by metis
	from bound_intersect_2d_lower[OF lb] obtain X2 M2
	where lower:
	"X2 \<in> set [((x1, y1), x2, y2)\<leftarrow>segments_of_aform X . x1 < x2]"
	"intersect_segment_xline prec X2 xl = Some (m, M2)"
	by metis
	from upper(1) lower(1)
	have X1: "X1 \<in> set (segments_of_aform X)" "fst (fst X1) > fst (snd X1)"
	and X2: "X2 \<in> set (segments_of_aform X)" "fst (fst X2) < fst (snd X2)"
	by auto
	note upper_seg = intersect_segment_xline_fst_snd[OF upper(2)]
	note lower_seg = intersect_segment_xline_fst_snd[OF lower(2)]
	from len have lh: "length (half_segments_of_aform X) \<noteq> 1"
	by (auto simp: segments_of_aform_def Let_def)
	from X1 have ne1: "fst (fst X1) \<noteq> fst (snd X1)"
	by simp
	moreover have "closed_segment (fst X1) (snd X1) \<inter> {p. fst p = xl} \<noteq> {}"
	using upper(2)
	by (simp add: intersect_segment_xline_None_iff[of prec, symmetric])
	ultimately obtain p1 where p1: "closed_segment (fst X1) (snd X1) \<inter> {p. fst p = xl} = {p1}"
	by (rule segment_intersection_singleton)
	then obtain u where u: "p1 = (1 - u) \<^sub>R fst X1 + u \<^sub>R (snd X1)" "0 \<le> u" "u \<le> 1"
	by (auto simp: closed_segment_def algebra_simps)
	have coll1: "det3 (fst X1) p1 (aform_val e X) \<ge> 0"
	and coll1': "det3 p1 (snd X1) (aform_val e X) \<ge> 0"
	unfolding atomize_conj
	using u
	by (cases "u = 0 \<or> u = 1")
	(auto simp: u(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2
	det3_nonneg_segments_of_aformI[OF \<open>e \<in> _\<close> lh X1(1)])

	from X2 have ne2: "fst (fst X2) \<noteq> fst (snd X2)" by simp
	moreover
	have "closed_segment (fst X2) (snd X2) \<inter> {p. fst p = xl} \<noteq> {}"
	using lower(2)
	by (simp add: intersect_segment_xline_None_iff[of prec, symmetric])
	ultimately
	obtain p2 where p2: "closed_segment (fst X2) (snd X2) \<inter> {p. fst p = xl} = {p2}"
	by (rule segment_intersection_singleton)
	then obtain v where v: "p2 = (1 - v) \<^sub>R fst X2 + v \<^sub>R (snd X2)" "0 \<le> v" "v \<le> 1"
	by (auto simp: closed_segment_def algebra_simps)
	have coll2: "det3 (fst X2) p2 (aform_val e X) \<ge> 0"
	and coll2': "det3 p2 (snd X2) (aform_val e X) \<ge> 0"
	unfolding atomize_conj
	using v
	by (cases "v = 0 \<or> v = 1")
	(auto simp: v(1) intro: det3_nonneg_scaleR_segment1 det3_nonneg_scaleR_segment2
	det3_nonneg_segments_of_aformI[OF \<open>e \<in> _\<close> lh X2(1)])

	from in_set_segments_of_aform_aform_valE
	[of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)]
	obtain e1s where e1s: "snd X1 = aform_val e1s X" "e1s \<in> UNIV \<rightarrow> {- 1..1}" .
	from previous_segments_of_aformE
	[of "fst X1" "snd X1" X, unfolded prod.collapse, OF X1(1)]
	obtain fX0 where "(fX0, fst X1) \<in> set (segments_of_aform X)" .
	from in_set_segments_of_aform_aform_valE[OF this]
	obtain e1f where e1f: "fst X1 = aform_val e1f X" "e1f \<in> UNIV \<rightarrow> {- 1..1}" .
	have "p1 \<in> closed_segment (aform_val e1f X) (aform_val e1s X)"
	using p1 by (auto simp: e1s e1f)
	with segment_in_aform_val[OF e1s(2) e1f(2), of X]
	obtain ep1 where ep1: "ep1 \<in> UNIV \<rightarrow> {-1 .. 1}" "p1 = aform_val ep1 X"
	by (auto simp: Affine_def valuate_def closed_segment_commute)

	from in_set_segments_of_aform_aform_valE
	[of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)]
	obtain e2s where e2s: "snd X2 = aform_val e2s X" "e2s \<in> UNIV \<rightarrow> {- 1..1}" .
	from previous_segments_of_aformE
	[of "fst X2" "snd X2" X, unfolded prod.collapse, OF X2(1)]
	obtain fX02 where "(fX02, fst X2) \<in> set (segments_of_aform X)" .
	from in_set_segments_of_aform_aform_valE[OF this]
	obtain e2f where e2f: "fst X2 = aform_val e2f X" "e2f \<in> UNIV \<rightarrow> {- 1..1}" .
	have "p2 \<in> closed_segment (aform_val e2f X) (aform_val e2s X)"
	using p2 by (auto simp: e2s e2f)
	with segment_in_aform_val[OF e2f(2) e2s(2), of X]
	obtain ep2 where ep2: "ep2 \<in> UNIV \<rightarrow> {-1 .. 1}" "p2 = aform_val ep2 X"
	by (auto simp: Affine_def valuate_def)

	from det3_nonneg_segments_of_aformI[OF ep2(1), of X "(fst X1, snd X1)", unfolded prod.collapse,
	OF lh X1(1), unfolded ep2(2)[symmetric]]
	have c2: "det3 (fst X1) (snd X1) p2 \<ge> 0" .
	hence c12: "det3 (fst X1) p1 p2 \<ge> 0"
	using u by (cases "u = 0") (auto simp: u(1) det3_nonneg_scaleR_segment2)
	from det3_nonneg_segments_of_aformI[OF ep1(1), of X "(fst X2, snd X2)", unfolded prod.collapse,
	OF lh X2(1), unfolded ep1(2)[symmetric]]
	have c1: "det3 (fst X2) (snd X2) p1 \<ge> 0" .
	hence c21: "det3 (fst X2) p2 p1 \<ge> 0"
	using v by (cases "v = 0") (auto simp: v(1) det3_nonneg_scaleR_segment2)
	from p1 p2 have p1p2xl: "fst p1 = xl" "fst p2 = xl"
	by (auto simp: det3_def')
	from upper_seg p1 have "snd p1 \<le> M" by (auto simp: less_eq_prod_def)
	from lower_seg p2 have "m \<le> snd p2" by (auto simp: less_eq_prod_def)

	{
	have *: "(fst p1, snd (aform_val e X)) = aform_val e X"
	by (simp add: prod_eq_iff p1p2xl fst_aform_val)
	hence coll:
	"det3 (fst (fst X1), snd (fst X1)) (fst p1, snd p1) (fst p1, snd (aform_val e X)) \<ge> 0"
	and coll':
	"det3 (fst (snd X1), snd (snd X1)) (fst p1, snd (aform_val e X)) (fst p1, snd p1) \<ge> 0"
	using coll1 coll1'
	by (auto simp: det3_rotate)
	have "snd (aform_val e X) \<le> M"
	proof (cases "fst (fst X1) = xl")
	case False
	have "fst (fst X1) \<ge> fst p1"
	unfolding u using X1
	by (auto simp: algebra_simps intro!: mult_left_mono u)
	moreover
	have "fst (fst X1) \<noteq> fst p1"
	using False
	by (simp add: p1p2xl)
	ultimately
	have "fst (fst X1) > fst p1" by simp
	from ccw_contr_on_line_left[OF coll this]
	show ?thesis using \<open>snd p1 \<le> M\<close> by simp
	next
	case True
	have "fst (snd X1) * (1 - u) \<le> fst (fst X1) * (1 - u)"
	using X1 u
	by (auto simp: intro!: mult_right_mono)
	hence "fst (snd X1) \<le> fst p1"
	unfolding u by (auto simp: algebra_simps)
	moreover
	have "fst (snd X1) \<noteq> fst p1"
	using True ne1
	by (simp add: p1p2xl)
	ultimately
	have "fst (snd X1) < fst p1" by simp
	from ccw_contr_on_line_right[OF coll' this]
	show ?thesis using \<open>snd p1 \<le> M\<close> by simp
	qed
	} moreover {
	have "(fst p2, snd (aform_val e X)) = aform_val e X"
	by (simp add: prod_eq_iff p1p2xl fst_aform_val)
	hence coll:
	"det3 (fst (fst X2), snd (fst X2)) (fst p2, snd p2) (fst p2, snd (aform_val e X)) \<ge> 0"
	and coll':
	"det3 (fst (snd X2), snd (snd X2)) (fst p2, snd (aform_val e X)) (fst p2, snd p2) \<ge> 0"
	using coll2 coll2'
	by (auto simp: det3_rotate)
	have "m \<le> snd (aform_val e X)"
	proof (cases "fst (fst X2) = xl")
	case False
	have "fst (fst X2) \<le> fst p2"
	unfolding v using X2
	by (auto simp: algebra_simps intro!: mult_left_mono v)
	moreover
	have "fst (fst X2) \<noteq> fst p2"
	using False
	by (simp add: p1p2xl)
	ultimately
	have "fst (fst X2) < fst p2" by simp
	from ccw_contr_on_line_right[OF coll this]
	show ?thesis using \<open>m \<le> snd p2\<close> by simp
	next
	case True
	have "(1 - v) * fst (snd X2) \<ge> (1 - v) * fst (fst X2)"
	using X2 v
	by (auto simp: intro!: mult_left_mono)
	hence "fst (snd X2) \<ge> fst p2"
	unfolding v by (auto simp: algebra_simps)
	moreover
	have "fst (snd X2) \<noteq> fst p2"
	using True ne2
	by (simp add: p1p2xl)
	ultimately
	have "fst (snd X2) > fst p2" by simp
	from ccw_contr_on_line_left[OF coll' this]
	show ?thesis using \<open>m \<le> snd p2\<close> by simp
	qed
	} ultimately have "aform_val e X \<in> {(xl, m) .. (xl, M)}"
	by (auto simp: less_eq_prod_def fst_aform_val)
	hence "aform_val e X \<in> {(xl, m0) .. (xl, M0)}"
	by (auto simp: minmax less_eq_prod_def)
	} moreover {
	assume "length (segments_of_aform X) = 2"
	then obtain a b where s: "segments_of_aform X = [a, b]"
	by (auto simp: numeral_2_eq_2 length_Suc_conv)
	from segments_of_aform_line_segment[OF this assms(2)]
	have "aform_val e X \<in> closed_segment (fst a) (snd a)" .
	moreover
	from assms
	have "intersect_segment_xline prec a xl = Some (m0, M0)"
	by (auto simp: bound_intersect_2d_ud_def s)
	note intersect_segment_xline_fst_snd[OF this]
	ultimately
	have "aform_val e X \<in> {(xl, m0) .. (xl, M0)}"
	by (auto simp: less_eq_prod_def fst_aform_val)
	} moreover {
	assume "length (segments_of_aform X) = 1"
	from polychain_of_segments_of_aform1[OF this]
	have "aform_val e X \<in> {(xl, m0) .. (xl, M0)}" by auto
	} moreover {
	assume len: "length (segments_of_aform X) = 0"
	hence "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = []"
	by (simp add: segments_of_aform_def Let_def half_segments_of_aform_def inl_def)
	hence "snd X = zero_pdevs"
	by (subst (asm) independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def)
	hence "aform_val e X = fst X"
	by (simp add: aform_val_def)
	with len assms have "aform_val e X \<in> {(xl, m0) .. (xl, M0)}"
	by (auto simp: bound_intersect_2d_ud_def Let_def split: if_split_asm)
	} ultimately have "aform_val e X \<in> {(xl, m0)..(xl, M0)}"
	by arith
	thus "(a, b) \<in> {(fst (a, b), m0)..(fst (a, b), M0)}"
	using safeassms
	by simp
	qed


	subsection \<open>Approximation from Orthogonal Directions\<close>

	definition inter_aform_plane_ortho::
	"nat \<Rightarrow> 'a::executable_euclidean_space aform \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a aform option"
	where
	"inter_aform_plane_ortho p Z n g = do {
	mMs \<leftarrow> those (map (\<lambda>b. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list);
	let l = (\<Sum>(b, m)\<leftarrow>zip Basis_list (map fst mMs). m *\<^sub>R b);
	let u = (\<Sum>(b, M)\<leftarrow>zip Basis_list (map snd mMs). M *\<^sub>R b);
	Some (aform_of_ivl l u)
	}"

	lemma
	those_eq_SomeD:
	assumes "those (map f xs) = Some ys"
	shows "ys = map (the o f) xs \<and> (\<forall>i.\<exists>y. i < length xs \<longrightarrow> f (xs ! i) = Some y)"
	using assms
	by (induct xs arbitrary: ys) (auto split: option.split_asm simp: o_def nth_Cons split: nat.split)

	lemma
	sum_list_zip_map:
	assumes "distinct xs"
	shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
	by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
	in_set_zip in_set_conv_nth inj_on_convol_ident
	intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])

	lemma
	inter_aform_plane_ortho_overappr:
	assumes "inter_aform_plane_ortho p Z n g = Some X"
	shows "{x. \<forall>i \<in> Basis. x \<bullet> i \<in> {y. (g, y) \<in> (\<lambda>x. (x \<bullet> n, x \<bullet> i)) ` Affine Z}} \<subseteq> Affine X"
	proof -
	let ?inter = "(\<lambda>b. bound_intersect_2d_ud p (inner2_aform Z n b) g)"
	obtain xs
	where xs: "those (map ?inter Basis_list) = Some xs"
	using assms by (cases "those (map ?inter Basis_list)") (auto simp: inter_aform_plane_ortho_def)

	from those_eq_SomeD[OF this]
	obtain y' where xs_eq: "xs = map (the \<circ> ?inter) Basis_list"
	and y': "\<And>i. i < length (Basis_list::'a list) \<Longrightarrow> ?inter (Basis_list ! i) = Some (y' i)"
	by metis
	have "\<forall>(i::'a) \<in> Basis. \<exists>j<length (Basis_list::'a list). i = Basis_list ! j"
	by (metis Basis_list in_set_conv_nth)
	then obtain j where j:
	"\<And>i::'a. i\<in>Basis \<Longrightarrow> j i < length (Basis_list::'a list)"
	"\<And>i::'a. i\<in>Basis \<Longrightarrow> i = Basis_list ! j i"
	by metis
	define y where "y = y' o j"
	with y' j have y: "\<And>i. i \<in> Basis \<Longrightarrow> ?inter i = Some (y i)"
	by (metis comp_def)
	hence y_le: "\<And>i. i \<in> Basis \<Longrightarrow> fst (y i) \<le> snd (y i)"
	by (auto intro!: bound_intersect_2d_ud_segments_of_aform_le)
	hence "(\<Sum>b\<in>Basis. fst (y b) \<^sub>R b) \<le> (\<Sum>b\<in>Basis. snd (y b) \<^sub>R b)"
	by (auto simp: eucl_le[where 'a='a])
	with assms have X: "Affine X = {\<Sum>b\<in>Basis. fst (y b) \<^sub>R b..\<Sum>b\<in>Basis. snd (y b) \<^sub>R b}"
	by (auto simp: inter_aform_plane_ortho_def sum_list_zip_map xs xs_eq y Affine_aform_of_ivl)

	show ?thesis
	proof safe
	fix x assume x: "\<forall>i\<in>Basis. x \<bullet> i \<in> {y. (g, y) \<in> (\<lambda>x. (x \<bullet> n, x \<bullet> i)) ` Affine Z}"
	{
	fix i::'a assume i: "i \<in> Basis"
	from x i have x_in2: "(g, x \<bullet> i) \<in> (\<lambda>x. (x \<bullet> n, x \<bullet> i)) ` Affine Z"
	by auto
	from x_in2 obtain e
	where e: "e \<in> UNIV \<rightarrow> {- 1..1}"
	and g: "g = aform_val e Z \<bullet> n"
	and x: "x \<bullet> i = aform_val e Z \<bullet> i"
	by (auto simp: Affine_def valuate_def)
	have "{aform_val e (inner2_aform Z n i)} = {aform_val e (inner2_aform Z n i)} \<inter> {x. fst x = g}"
	by (auto simp: g inner2_def)
	also
	from y[OF \<open>i \<in> Basis\<close>]
	have "?inter i = Some (fst (y i), snd (y i))" by simp
	note bound_intersect_2d_ud_segments_of_aform[OF this e]
	finally have "x \<bullet> i \<in> {fst (y i) .. snd (y i)}"
	by (auto simp: x inner2_def)
	} thus "x \<in> Affine X"
	unfolding X
	by (auto simp: eucl_le[where 'a='a])
	qed
	qed

	lemma inter_proj_eq:
	fixes n g l
	defines "G \<equiv> {x. x \<bullet> n = g}"
	shows "(\<lambda>x. x \<bullet> l) ` (Z \<inter> G) =
	{y. (g, y) \<in> (\<lambda>x. (x \<bullet> n, x \<bullet> l)) ` Z}"
	by (auto simp: G_def)

	lemma
	inter_overappr:
	fixes n \<gamma> l
	shows "Z \<inter> {x. x \<bullet> n = g} \<subseteq> {x. \<forall>i \<in> Basis. x \<bullet> i \<in> {y. (g, y) \<in> (\<lambda>x. (x \<bullet> n, x \<bullet> i)) ` Z}}"
	by auto

	lemma inter_inter_aform_plane_ortho:
	assumes "inter_aform_plane_ortho p Z n g = Some X"
	shows "Affine Z \<inter> {x. x \<bullet> n = g} \<subseteq> Affine X"
	proof -
	note inter_overappr[of "Affine Z" n g]
	also note inter_aform_plane_ortho_overappr[OF assms]
	finally show ?thesis .
	qed

	subsection \<open>``Completeness'' of Intersection\<close>

	abbreviation "encompasses x seg \<equiv> det3 (fst seg) (snd seg) x \<ge> 0"

	lemma encompasses_cases:
	"encompasses x seg \<or> encompasses x (snd seg, fst seg)"
	by (auto simp: det3_def' algebra_simps)

	lemma list_all_encompasses_cases:
	assumes "list_all (encompasses p) (x # y # zs)"
	obtains "list_all (encompasses p) [x, y, (snd y, fst x)]"
	\| "list_all (encompasses p) ((fst x, snd y)#zs)"
	using encompasses_cases
	proof
	assume "encompasses p (snd y, fst x)"
	hence "list_all (encompasses p) [x, y, (snd y, fst x)]"
	using assms by (auto simp: list_all_iff)
	thus ?thesis ..
	next
	assume "encompasses p (snd (snd y, fst x), fst (snd y, fst x))"
	hence "list_all (encompasses p) ((fst x, snd y)#zs)"
	using assms by (auto simp: list_all_iff)
	thus ?thesis ..
	qed

	lemma triangle_encompassing_polychain_of:
	assumes "det3 p a b \<ge> 0" "det3 p b c \<ge> 0" "det3 p c a \<ge> 0"
	assumes "ccw' a b c"
	shows "p \<in> convex hull {a, b, c}"
	proof -
	from assms have nn: "det3 b c p \<ge> 0" "det3 c a p \<ge> 0" "det3 a b p \<ge> 0" "det3 a b c \<ge> 0"
	by (auto simp: det3_def' algebra_simps)
	have "det3 a b c \<^sub>R p = det3 b c p \<^sub>R a + det3 c a p \<^sub>R b + det3 a b p \<^sub>R c"
	by (auto simp: det3_def' algebra_simps prod_eq_iff)
	hence "inverse (det3 a b c) \<^sub>R (det3 a b c \<^sub>R p) =
	inverse (det3 a b c) \<^sub>R (det3 b c p \<^sub>R a + det3 c a p \<^sub>R b + det3 a b p \<^sub>R c)"
	by simp
	with assms have p_eq: "p =
	(det3 b c p / det3 a b c) \<^sub>R a + (det3 c a p / det3 a b c) \<^sub>R b + (det3 a b p / det3 a b c) *\<^sub>R c"
	(is "_ = scaleR ?u _ + scaleR ?v _ + scaleR ?w _")
	by (simp add: inverse_eq_divide algebra_simps ccw'_def)
	have det_eq: "det3 b c p / det3 a b c + det3 c a p / det3 a b c + det3 a b p / det3 a b c = 1"
	using assms(4)
	by (simp add: add_divide_distrib[symmetric] det3_def' algebra_simps ccw'_def)
	show ?thesis
	unfolding convex_hull_3
	using assms(4)
	by (blast intro: exI[where x="?u"] exI[where x="?v"] exI[where x="?w"]
	intro!: p_eq divide_nonneg_nonneg nn det_eq)
	qed

	lemma encompasses_convex_polygon3:
	assumes "list_all (encompasses p) (x#y#z#zs)"
	assumes "convex_polygon (x#y#z#zs)"
	assumes "ccw'.sortedP (fst x) (map snd (butlast (x#y#z#zs)))"
	shows "p \<in> convex hull (set (map fst (x#y#z#zs)))"
	using assms
	proof (induct zs arbitrary: x y z p)
	case Nil
	thus ?case
	by (auto simp: det3_def' algebra_simps
	elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil
	intro!: triangle_encompassing_polychain_of)
	next
	case (Cons w ws)
	from Cons.prems(2) have "snd y = fst z" by auto
	from Cons.prems(1)
	show ?case
	proof (rule list_all_encompasses_cases)
	assume "list_all (encompasses p) [x, y, (snd y, fst x)]"
	hence "p \<in> convex hull {fst x, fst y, snd y}"
	using Cons.prems
	by (auto simp: det3_def' algebra_simps
	elim!: ccw'.sortedP_Cons ccw'.sortedP_Nil
	intro!: triangle_encompassing_polychain_of)
	thus ?case
	by (rule rev_subsetD[OF _ hull_mono]) (auto simp: \<open>snd y = fst z\<close>)
	next
	assume *: "list_all (encompasses p) ((fst x, snd y) # z # w # ws)"
	from Cons.prems
	have enc: "ws \<noteq> [] \<Longrightarrow> encompasses p (last ws)"
	by (auto simp: list_all_iff)
	have "set (map fst ((fst x, snd y)#z#w#ws)) \<subseteq> set (map fst (x # y # z # w # ws))"
	by auto
	moreover
	{
	note *
	moreover
	have "convex_polygon ((fst x, snd y) # z # w # ws)"
	by (metis convex_polygon_skip Cons.prems(2,3))
	moreover
	have "ccw'.sortedP (fst (fst x, snd y)) (map snd (butlast ((fst x, snd y) # z # w # ws)))"
	using Cons.prems(3)
	by (auto elim!: ccw'.sortedP_Cons intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil
	split: if_split_asm)
	ultimately have "p \<in> convex hull set (map fst ((fst x, snd y)#z#w#ws))"
	by (rule Cons.hyps)
	}
	ultimately
	show "p \<in> convex hull set (map fst (x # y # z # w # ws))"
	by (rule subsetD[OF hull_mono])
	qed
	qed

	lemma segments_of_aform_empty_Affine_eq:
	assumes "segments_of_aform X = []"
	shows "Affine X = {fst X}"
	proof -
	have "independent_pdevs (map snd (list_of_pdevs (nlex_pdevs (snd X)))) = [] \<longleftrightarrow>
	(list_of_pdevs (nlex_pdevs (snd X))) = []"
	by (subst independent_pdevs_eq_Nil_iff) (auto simp: list_all_iff list_of_pdevs_def )
	with assms show ?thesis
	by (force simp: aform_val_def list_of_pdevs_def Affine_def valuate_def segments_of_aform_def
	Let_def half_segments_of_aform_def inl_def)
	qed

	lemma not_segments_of_aform_singleton: "segments_of_aform X \<noteq> [x]"
	by (auto simp: segments_of_aform_def Let_def add_is_1 dest!: arg_cong[where f=length])

	lemma encompasses_segments_of_aform_in_AffineI:
	assumes "length (segments_of_aform X) > 2"
	assumes "list_all (encompasses p) (segments_of_aform X)"
	shows "p \<in> Affine X"
	proof -
	from assms(1) obtain x y z zs where eq: "segments_of_aform X = x#y#z#zs"
	by (cases "segments_of_aform X" rule: list_cases4) auto
	hence "fst x = fst (hd (half_segments_of_aform X))"
	by (metis segments_of_aform_def hd_append list.map_disc_iff list.sel(1))
	also have "\<dots> = lowest_vertex (fst X, nlex_pdevs (snd X))"
	using assms
	by (intro fst_hd_half_segments_of_aform) (auto simp: segments_of_aform_def)
	finally have fstx: "fst x = lowest_vertex (fst X, nlex_pdevs (snd X))" .
	have "p \<in> convex hull (set (map fst (segments_of_aform X)))"
	using assms(2)
	unfolding eq
	proof (rule encompasses_convex_polygon3)
	show "convex_polygon (x # y # z # zs)"
	using assms(1) unfolding eq[symmetric]
	by (intro convex_polygon_segments_of_aform) (simp add: segments_of_aform_def Let_def)
	show "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # zs)))"
	using assms(1)
	unfolding fstx map_butlast eq[symmetric]
	by (intro ccw'_sortedP_snd_segments_of_aform)
	(simp add: segments_of_aform_def Let_def half_segments_of_aform_def)
	qed
	also have "\<dots> \<subseteq> convex hull (Affine X)"
	proof (rule hull_mono, safe)
	fix a b assume "(a, b) \<in> set (map fst (segments_of_aform X))"
	then obtain c d where "((a, b), c, d) \<in> set (segments_of_aform X)" by auto
	from previous_segments_of_aformE[OF this]
	obtain x where "(x, a, b) \<in> set (segments_of_aform X)" by auto
	from in_set_segments_of_aform_aform_valE[OF this]
	obtain e where "(a, b) = aform_val e X" "e \<in> UNIV \<rightarrow> {- 1..1}" by auto
	thus "(a, b) \<in> Affine X"
	by (auto simp: Affine_def valuate_def image_iff)
	qed
	also have "\<dots> = Affine X"
	by (simp add: convex_Affine convex_hull_eq)
	finally show ?thesis .
	qed

	end
	diff --git a/thys/Affine_Arithmetic/Polygon.thy b/thys/Affine_Arithmetic/Polygon.thy
	--- a/thys/Affine_Arithmetic/Polygon.thy
	+++ b/thys/Affine_Arithmetic/Polygon.thy
	@@ -1,465 +1,465 @@
	theory Polygon
	imports Counterclockwise_2D_Strict
	begin

	subsection \<open>Polygonal chains\<close>

	definition "polychain xs = (\<forall>i. Suc i<length xs \<longrightarrow> snd (xs ! i) = (fst (xs ! Suc i)))"

	lemma polychainI:
	assumes "\<And>i. Suc i < length xs \<Longrightarrow> snd (xs ! i) = fst (xs ! Suc i)"
	shows "polychain xs"
	by (auto intro!: assms simp: polychain_def)

	lemma polychain_Nil[simp]: "polychain [] = True"
	and polychain_singleton[simp]: "polychain [x] = True"
	by (auto simp: polychain_def)

	lemma polychain_Cons:
	"polychain (y # ys) = (if ys = [] then True else snd y = fst (ys ! 0) \<and> polychain ys)"
	by (auto simp: polychain_def nth_Cons split: nat.split)

	lemma polychain_appendI:
	"polychain xs \<Longrightarrow> polychain ys \<Longrightarrow> (xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> snd (last xs) = fst (hd ys)) \<Longrightarrow>
	polychain (xs @ ys)"
	by (induct xs arbitrary: ys)
	(auto simp add: polychain_Cons nth_append hd_conv_nth split: if_split_asm)

	fun pairself where "pairself f (x, y) = (f x, f y)"

	lemma pairself_apply: "pairself f x = (f (fst x), f (snd x))"
	by (cases x, simp)

	lemma polychain_map_pairself: "polychain xs \<Longrightarrow> polychain (map (pairself f) xs)"
	by (auto simp: polychain_def pairself_apply)

	definition "convex_polychain xs \<longleftrightarrow>
	(polychain xs \<and>
	(\<forall>i. Suc i < length xs \<longrightarrow> det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0))"

	lemma convex_polychain_Cons2[simp]:
	"convex_polychain (x#y#zs) \<longleftrightarrow>
	snd x = fst y \<and> det3 (fst x) (fst y) (snd y) > 0 \<and> convex_polychain (y#zs)"
	by (auto simp add: convex_polychain_def polychain_def nth_Cons split: nat.split)

	lemma convex_polychain_ConsD:
	assumes "convex_polychain (x#xs)"
	shows "convex_polychain xs"
	using assms by (auto simp: convex_polychain_def polychain_def nth_Cons split: nat.split)

	definition
	"convex_polygon xs \<longleftrightarrow> (convex_polychain xs \<and> (xs \<noteq> [] \<longrightarrow> fst (hd xs) = snd (last xs)))"

	lemma convex_polychain_Nil[simp]: "convex_polychain [] = True"
	and convex_polychain_Cons[simp]: "convex_polychain [x] = True"
	by (auto simp: convex_polychain_def)

	lemma convex_polygon_Cons2[simp]:
	"convex_polygon (x#y#zs) \<longleftrightarrow> fst x = snd (last (y#zs)) \<and> convex_polychain (x#y#zs)"
	by (auto simp: convex_polygon_def convex_polychain_def polychain_def nth_Cons)

	lemma polychain_append_connected:
	"polychain (xs @ ys) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> fst (hd ys) = snd (last xs)"
	by (auto simp: convex_polychain_def nth_append not_less polychain_def last_conv_nth hd_conv_nth
	dest!: spec[where x = "length xs - 1"])

	lemma convex_polychain_appendI:
	assumes cxs: "convex_polychain xs"
	assumes cys: "convex_polychain ys"
	assumes pxy: "polychain (xs @ ys)"
	assumes "xs \<noteq> [] \<Longrightarrow> ys \<noteq> [] \<Longrightarrow> det3 (fst (last xs)) (snd (last xs)) (snd (hd ys)) > 0"
	shows "convex_polychain (xs @ ys)"
	proof -
	{
	fix i
	assume "i < length xs" "length xs \<le> Suc i" "Suc i < length xs + length ys"
	hence "xs \<noteq> []" "ys \<noteq> []" "i = length xs - 1" by auto
	}
	thus ?thesis
	using assms
	by (auto simp: hd_conv_nth convex_polychain_def nth_append Suc_diff_le last_conv_nth )
	qed

	lemma convex_polychainI:
	assumes "polychain xs"
	assumes "\<And>i. Suc i < length xs \<Longrightarrow> det3 (fst (xs ! i)) (snd (xs ! i)) (snd (xs ! Suc i)) > 0"
	shows "convex_polychain xs"
	by (auto intro!: assms simp: convex_polychain_def ccw'_def)

	lemma convex_polygon_skip:
	assumes "convex_polygon (x # y # z # w # ws)"
	assumes "ccw'.sortedP (fst x) (map snd (butlast (x # y # z # w # ws)))"
	shows "convex_polygon ((fst x, snd y) # z # w # ws)"
	using assms by (auto elim!: ccw'.sortedP_Cons simp: ccw'_def[symmetric])


	primrec polychain_of::"'a::ab_group_add \<Rightarrow> 'a list \<Rightarrow> ('a*'a) list" where
	"polychain_of xc [] = []"
	\| "polychain_of xc (xm#xs) = (xc, xc + xm)#polychain_of (xc + xm) xs"

	lemma in_set_polychain_ofD: "ab \<in> set (polychain_of x xs) \<Longrightarrow> (snd ab - fst ab) \<in> set xs"
	by (induct xs arbitrary: x) auto

	lemma fst_polychain_of_nth_0[simp]: "xs \<noteq> [] \<Longrightarrow> fst ((polychain_of p xs) ! 0) = p"
	by (cases xs) (auto simp: Let_def)

	lemma fst_hd_polychain_of: "xs \<noteq> [] \<Longrightarrow> fst (hd (polychain_of x xs)) = x"
	- by (cases xs) (auto simp: )
	+ by (cases xs) auto

	lemma length_polychain_of_eq[simp]:
	shows "length (polychain_of p qs) = length qs"
	by (induct qs arbitrary: p) simp_all

	lemma
	polychain_of_subsequent_eq:
	assumes "Suc i < length qs"
	shows "snd (polychain_of p qs ! i) = fst (polychain_of p qs ! Suc i)"
	using assms
	by (induct qs arbitrary: p i) (auto simp add: nth_Cons split: nat.split)

	lemma polychain_of_eq_empty_iff[simp]: "polychain_of p xs = [] \<longleftrightarrow> xs = []"
	by (cases xs) (auto simp: Let_def)

	lemma in_set_polychain_of_imp_sum_list:
	assumes "z \<in> set (polychain_of Pc Ps)"
	obtains d where "z = (Pc + sum_list (take d Ps), Pc + sum_list (take (Suc d) Ps))"
	using assms
	apply atomize_elim
	proof (induction Ps arbitrary: Pc z)
	case Nil thus ?case by simp
	next
	case (Cons P Ps)
	hence "z = (Pc, Pc + P) \<or> z \<in> set (polychain_of (Pc + P) Ps)"
	by auto
	thus ?case
	proof
	assume "z \<in> set ((polychain_of (Pc + P) Ps))"
	from Cons.IH[OF this]
	obtain d
	where "z = (Pc + P + sum_list (take d Ps), Pc + P + sum_list (take (Suc d) Ps))"
	by auto
	thus ?case
	by (auto intro!: exI[where x="Suc d"])
	qed (auto intro!: exI[where x=0])
	qed

	lemma last_polychain_of: "length xs > 0 \<Longrightarrow> snd (last (polychain_of p xs)) = p + sum_list xs"
	by (induct xs arbitrary: p) simp_all

	lemma polychain_of_singleton_iff: "polychain_of p xs = [a] \<longleftrightarrow> fst a = p \<and> xs = [(snd a - p)]"
	by (induct xs) auto

	lemma polychain_of_add: "polychain_of (x + y) xs = map (((+) (y, y))) (polychain_of x xs)"
	by (induct xs arbitrary: x y) (auto simp: algebra_simps)

	subsection \<open>Dirvec: Inverse of Polychain\<close>

	primrec dirvec where "dirvec (x, y) = (y - x)"

	lemma dirvec_minus: "dirvec x = snd x - fst x"
	by (cases x) simp

	lemma dirvec_nth_polychain_of: "n < length xs \<Longrightarrow> dirvec ((polychain_of p xs) ! n ) = (xs ! n)"
	by (induct xs arbitrary: p n) (auto simp: nth_Cons split: nat.split)

	lemma dirvec_hd_polychain_of: "xs \<noteq> [] \<Longrightarrow> dirvec (hd (polychain_of p xs)) = (hd xs)"
	by (simp add: hd_conv_nth dirvec_nth_polychain_of)

	lemma dirvec_last_polychain_of: "xs \<noteq> [] \<Longrightarrow> dirvec (last (polychain_of p xs)) = (last xs)"
	by (simp add: last_conv_nth dirvec_nth_polychain_of)

	lemma map_dirvec_polychain_of[simp]: "map dirvec (polychain_of x xs) = xs"
	by (induct xs arbitrary: x) simp_all


	subsection \<open>Polychain of Sorted (@{term polychain_of}, @{term ccw'.sortedP})\<close>

	lemma ccw'_sortedP_translateD:
	"linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs) \<Longrightarrow>
	linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)"
	proof (induct xs arbitrary: x0 x)
	case Nil thus ?case by (auto simp: linorder_list0.sortedP.Nil)
	next
	case (Cons a xs x0 x)
	hence "\<forall>y\<in>set xs. ccw' (x0 - x) (g a) (g y)"
	by (auto elim!: linorder_list0.sortedP_Cons simp: ccw'.translate_origin algebra_simps)
	thus ?case
	using Cons.prems(1)
	by (auto elim!: linorder_list0.sortedP_Cons intro!: linorder_list0.sortedP.Cons simp: Cons.hyps)
	qed

	lemma ccw'_sortedP_translateI:
	"linorder_list0.sortedP (ccw' (x0 - x)) (map g xs) \<Longrightarrow>
	linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs)"
	using ccw'_sortedP_translateD[of "x0 - x" "-x" "(+) x o g" xs]
	by (simp add: o_def)

	lemma ccw'_sortedP_translate_comp[simp]:
	"linorder_list0.sortedP (ccw' x0) (map ((+) x \<circ> g) xs) \<longleftrightarrow>
	linorder_list0.sortedP (ccw' (x0 - x)) (map g xs)"
	by (metis ccw'_sortedP_translateD ccw'_sortedP_translateI)

	lemma snd_plus_commute: "snd \<circ> (+) (x0, x0) = (+) x0 o snd"
	by auto

	lemma ccw'_sortedP_renormalize:
	"ccw'.sortedP a (map snd (polychain_of (x0 + x) xs)) \<longleftrightarrow>
	ccw'.sortedP (a - x0) (map snd (polychain_of x xs))"
	by (simp add: polychain_of_add add.commute snd_plus_commute)

	lemma ccw'_sortedP_polychain_of01:
	shows "ccw'.sortedP 0 [u] \<Longrightarrow> ccw'.sortedP x0 (map snd (polychain_of x0 [u]))"
	and "ccw'.sortedP 0 [] \<Longrightarrow> ccw'.sortedP x0 (map snd (polychain_of x0 []))"
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons simp: ac_simps)

	lemma ccw'_sortedP_polychain_of2:
	assumes "ccw'.sortedP 0 [u, v]"
	shows "ccw'.sortedP x0 (map snd (polychain_of x0 [u, v]))"
	using assms
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin)

	lemma ccw'_sortedP_polychain_of3:
	assumes "ccw'.sortedP 0 (u#v#w#xs)"
	shows "ccw'.sortedP x0 (map snd (polychain_of x0 (u#v#w#xs)))"
	using assms
	proof (induct xs arbitrary: x0 u v w)
	case Nil
	then have *: "ccw' 0 u v" "ccw' 0 v w" "ccw' 0 u w"
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ac_simps)
	moreover have "ccw' 0 (u + v) (u + (v + w))"
	by (metis add.assoc ccw'.add1 ccw'.add3_self *(2-))
	ultimately show ?case
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ac_simps ccw'.translate_origin ccw'.add3)
	next
	case (Cons y ys)
	have s1: "linorder_list0.sortedP (ccw' 0) ((u + v)#w#y#ys)" using Cons.prems
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ccw'.add1)
	have s2: "linorder_list0.sortedP (ccw' 0) (u#(v + w)#y#ys)" using Cons.prems
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1)
	have s3: "linorder_list0.sortedP (ccw' 0) (u#v#(w + y)#ys)" using Cons.prems
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ccw'.add3 ccw'.add1)
	show ?case
	using Cons.hyps[OF s1, of x0] Cons.hyps[OF s2, of x0] Cons.hyps[OF s3, of x0] Cons.prems
	by (auto intro!: linorder_list0.sortedP.Nil linorder_list0.sortedP.Cons
	elim!: linorder_list0.sortedP_Cons simp: ac_simps)
	qed

	lemma ccw'_sortedP_polychain_of_snd:
	assumes "ccw'.sortedP 0 xs"
	shows "ccw'.sortedP x0 (map snd (polychain_of x0 xs))"
	using assms
	by (metis ccw'_sortedP_polychain_of01 ccw'_sortedP_polychain_of2 ccw'_sortedP_polychain_of3
	list.exhaust)

	lemma ccw'_sortedP_implies_distinct:
	assumes "ccw'.sortedP x qs"
	shows "distinct qs"
	using assms
	proof induct
	case Cons thus ?case by (meson ccw'_contra distinct.simps(2))
	qed simp

	lemma ccw'_sortedP_implies_nonaligned:
	assumes "ccw'.sortedP x qs"
	assumes "y \<in> set qs" "z \<in> set qs" "y \<noteq> z"
	shows "\<not> coll x y z"
	using assms
	by induct (force simp: ccw'_def det3_def' algebra_simps)+

	lemma list_all_mp: "list_all P xs \<Longrightarrow> (\<And>x. x \<in> set xs \<Longrightarrow> P x \<Longrightarrow> Q x) \<Longrightarrow> list_all Q xs"
	by (auto simp: list_all_iff)

	lemma
	ccw'_scale_origin:
	assumes "e \<in> UNIV \<rightarrow> {0<..<1}"
	assumes "x \<in> set (polychain_of Pc (P # QRRs))"
	assumes "ccw'.sortedP 0 (P # QRRs)"
	assumes "ccw' (fst x) (snd x) (P + (Pc + (\<Sum>P\<in>set QRRs. e P *\<^sub>R P)))"
	shows "ccw' (fst x) (snd x) (e P \<^sub>R P + (Pc + (\<Sum>P\<in>set QRRs. e P \<^sub>R P)))"
	proof -
	from assms(2) have "fst x = Pc \<and> snd x = Pc + P \<or> x \<in> set (polychain_of (Pc + P) QRRs)" by auto
	thus ?thesis
	proof
	assume x: "x \<in> set (polychain_of (Pc + P) QRRs)"
	define q where "q = snd x - fst x"
	from Polygon.in_set_polychain_of_imp_sum_list[OF x]
	obtain d where d: "fst x = (Pc + P + sum_list (take d QRRs))" by (auto simp: prod_eq_iff)
	from in_set_polychain_ofD[OF x]
	have q_in: "q \<in> set QRRs" by (simp add: q_def)
	define R where "R = set QRRs - {q}"
	hence QRRs: "set QRRs = R \<union> {q}" "q \<notin> R" "finite R" using q_in by auto
	have "ccw' 0 q (-P)"
	using assms(3)
	by (auto simp: ccw'.sortedP_Cons_iff q_in)
	hence "ccw' 0 q ((1 - e P) *\<^sub>R (-P))"
	using assms(1) by (subst ccw'.scaleR2_eq) (auto simp: algebra_simps)
	moreover
	from assms(4) have "ccw' 0 q ((\<Sum>P\<in>set QRRs. e P *\<^sub>R P) - sum_list (take d QRRs))"
	by (auto simp: q_def ccw'.translate_origin d)
	ultimately
	have "ccw' 0 q ((1 - e P) \<^sub>R (-P) + ((\<Sum>P\<in>set QRRs. e P \<^sub>R P) - sum_list (take d QRRs)))"
	by (intro ccw'.add3) auto
	thus ?thesis
	by (auto simp: ccw'.translate_origin q_def algebra_simps d)
	qed (metis (no_types, lifting) add.left_commute assms(4) ccw'.add3_self ccw'.scale_add3
	ccw'.translate)
	qed

	lemma polychain_of_ccw_convex:
	assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
	assumes sorted: "linorder_list0.sortedP (ccw' 0) (P#Q#Ps)"
	shows "list_all
	(\<lambda>(xi, xj). ccw' xi xj (Pc + (\<Sum>P \<in> set (P#Q#Ps). e P *\<^sub>R P)))
	(polychain_of Pc (P#Q#Ps))"
	using assms(1) assms(2)
	proof (induct Ps arbitrary: P Q Pc)
	case Nil
	have eq: "e P \<^sub>R P + e Q \<^sub>R Q - P = (1 - e P) \<^sub>R (- P) + e Q \<^sub>R Q"
	using \<open>e \<in> _\<close>
	by (auto simp add: algebra_simps)
	from Nil ccw'_sortedP_implies_distinct[OF Nil(2)]
	have "P \<noteq> Q" "e P < 1" "0 < e Q" "ccw' 0 P Q"
	by (auto elim!: linorder_list0.sortedP_Cons)
	thus ?case
	by (auto simp: ccw'_not_coll ccw'.translate_origin eq)
	next
	case (Cons R Rs)
	hence "ccw' 0 P Q" "P \<noteq> Q" using ccw'_sortedP_implies_distinct[OF Cons(3)]
	by (auto elim!: linorder_list0.sortedP_Cons)
	have "list_all (\<lambda>(xi, xj). ccw' xi xj ((Pc + P) + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
	(polychain_of (Pc + P) (Q # R # Rs))"
	using Cons(2-)
	by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons)
	also have "polychain_of (Pc + P) (Q # R # Rs) = tl (polychain_of Pc (P # Q # R # Rs))"
	by simp
	finally have "list_all (\<lambda>(xi, xj). ccw' xi xj (Pc + P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
	(tl (polychain_of Pc (P # Q # R # Rs)))" .
	moreover
	have "list_all
	(\<lambda>(xi, xj). ccw' xi xj (P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
	(polychain_of P (Q # R # Rs))"
	using Cons(2-)
	by (intro Cons(1)) (auto elim: linorder_list0.sortedP_Cons)
	have "(\<lambda>(xi, xj). ccw' xi xj (Pc + P + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P)))
	(hd (polychain_of Pc (P # Q # R # Rs)))"
	using ccw'_sortedP_implies_nonaligned[OF Cons(3), of P Q]
	ccw'_sortedP_implies_nonaligned[OF Cons(3), of Q R]
	ccw'_sortedP_implies_nonaligned[OF Cons(3), of P R]
	Cons(2,3)
	by (auto simp add: Pi_iff add.assoc simp del: scaleR_Pair intro!: ccw'.sum
	elim!: linorder_list0.sortedP_Cons)
	ultimately
	have "list_all
	(\<lambda>(xi, xj). ccw' xi xj (P + (Pc + (\<Sum>P\<in>set (Q # R # Rs). e P *\<^sub>R P))))
	(polychain_of Pc (P # Q # R # Rs))"
	by (simp add: ac_simps)
	hence "list_all
	(\<lambda>(xi, xj). ccw' xi xj (e P \<^sub>R P + (Pc + (\<Sum>P\<in>set (Q # R # Rs). e P \<^sub>R P))))
	(polychain_of Pc (P # Q # R # Rs))"
	unfolding split_beta'
	by (rule list_all_mp, intro ccw'_scale_origin[OF assms(1)])
	(auto intro!: ccw'_scale_origin Cons(3))
	thus ?case
	using ccw'_sortedP_implies_distinct[OF Cons(3)] Cons
	by (simp add: ac_simps)
	qed

	lemma polychain_of_ccw:
	assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
	assumes sorted: "ccw'.sortedP 0 qs"
	assumes qs: "length qs \<noteq> 1"
	shows "list_all (\<lambda>(xi, xj). ccw' xi xj (Pc + (\<Sum>P \<in> set qs. e P *\<^sub>R P))) (polychain_of Pc qs)"
	using assms
	proof (cases qs)
	case (Cons Q Qs)
	note CQ = this
	show ?thesis using assms
	proof (cases Qs)
	case (Cons R Rs)
	thus ?thesis using assms
	unfolding CQ Cons
	by (intro polychain_of_ccw_convex) (auto simp: CQ Cons intro!: polychain_of_ccw_convex)
	qed (auto simp: CQ)
	qed simp

	lemma in_polychain_of_ccw:
	assumes "e \<in> UNIV \<rightarrow> {0 <..< 1}"
	assumes "ccw'.sortedP 0 qs"
	assumes "length qs \<noteq> 1"
	assumes "seg \<in> set (polychain_of Pc qs)"
	shows "ccw' (fst seg) (snd seg) (Pc + (\<Sum>P \<in> set qs. e P *\<^sub>R P))"
	using polychain_of_ccw[OF assms(1,2,3)] assms(4)
	by (simp add: list_all_iff split_beta)

	lemma distinct_butlast_ne_last: "distinct xs \<Longrightarrow> x \<in> set (butlast xs) \<Longrightarrow> x \<noteq> last xs"
	by (metis append_butlast_last_id distinct_butlast empty_iff in_set_butlastD list.set(1)
	not_distinct_conv_prefix)

	lemma
	ccw'_sortedP_convex_rotate_aux:
	assumes "ccw'.sortedP 0 (zs)" "ccw'.sortedP x (map snd (polychain_of x (zs)))"
	shows "ccw'.sortedP (snd (last (polychain_of x (zs)))) (map snd (butlast (polychain_of x (zs))))"
	using assms
	proof (induct zs arbitrary: x rule: list.induct)
	case (Cons z zs)
	{
	assume "zs \<noteq> []"
	have "ccw'.sortedP (snd (last (polychain_of (x + z) zs)))
	(map snd (butlast (polychain_of (x + z) zs)))"
	using Cons.prems
	by (auto elim!: ccw'.sortedP_Cons intro!: ccw'_sortedP_polychain_of_snd Cons.hyps)
	from _ this
	have "linorder_list0.sortedP (ccw' (snd (last (polychain_of (x + z) zs))))
	((x + z) # map snd (butlast (polychain_of (x + z) zs)))"
	proof (rule ccw'.sortedP.Cons, safe)
	fix c d
	assume cd: "(c, d) \<in> set (map snd (butlast (polychain_of (x + z) zs)))"
	then obtain a b where ab: "((a, b), c, d) \<in> set (butlast (polychain_of (x + z) zs))"
	by auto
	have cd': "(c, d) \<in> set (butlast (map snd (polychain_of (x + z) zs)))" using cd
	by (auto simp: map_butlast)
	have "ccw' (x + z) (c, d) (last (map snd (polychain_of (x + z) zs)))"
	proof (rule ccw'.sortedP_right_of_last)
	show "ccw'.sortedP (x + z) (map snd (polychain_of (x + z) zs))"
	using Cons
	by (force intro!: ccw'.sortedP.Cons ccw'.sortedP.Nil ccw'_sortedP_polychain_of_snd
	elim!: ccw'.sortedP_Cons)
	show "(c, d) \<in> set (map snd (polychain_of (x + z) zs))"
	using in_set_butlastD[OF ab]
	by force
	from Cons(3) cd'
	show "(c, d) \<noteq> last (map snd (polychain_of (x + z) zs))"
	by (intro distinct_butlast_ne_last ccw'_sortedP_implies_distinct[where x=x])
	(auto elim!: ccw'.sortedP_Cons)
	qed
	thus "ccw' (snd (last (polychain_of (x + z) zs))) (x + z) (c, d)"
	by (auto simp: last_map[symmetric, where f= snd] \<open>zs \<noteq> []\<close> intro: ccw'.cyclicI)
	qed
	}
	thus ?case
	by (auto simp: ccw'.sortedP.Nil)
	qed (simp add: ccw'.sortedP.Nil)

	lemma ccw'_polychain_of_sorted_center_last:
	assumes set_butlast: "(c, d) \<in> set (butlast (polychain_of x0 xs))"
	assumes sorted: "ccw'.sortedP 0 xs"
	assumes ne: "xs \<noteq> []"
	shows "ccw' x0 d (snd (last (polychain_of x0 xs)))"
	proof -
	from ccw'_sortedP_polychain_of_snd[OF sorted, of x0]
	have "ccw'.sortedP x0 (map snd (polychain_of x0 xs))" .
	also
	from set_butlast obtain ys zs where "butlast (polychain_of x0 xs) = ys@((c, d)#zs)"
	by (auto simp add: in_set_conv_decomp)
	hence "polychain_of x0 xs = ys @ (c, d) # zs @ [last (polychain_of x0 xs)]"
	by (metis append_Cons append_assoc append_butlast_last_id ne polychain_of_eq_empty_iff)
	finally show ?thesis by (auto elim!: ccw'.sortedP_Cons simp: ccw'.sortedP_append_iff)
	qed

	end
	diff --git a/thys/Affine_Arithmetic/Straight_Line_Program.thy b/thys/Affine_Arithmetic/Straight_Line_Program.thy
	--- a/thys/Affine_Arithmetic/Straight_Line_Program.thy
	+++ b/thys/Affine_Arithmetic/Straight_Line_Program.thy
	@@ -1,993 +1,993 @@
	section \<open>Straight Line Programs\<close>
	theory Straight_Line_Program
	imports
	Floatarith_Expression
	Deriving.Derive
	"HOL-Library.Monad_Syntax"
	"HOL-Library.RBT_Mapping"
	begin

	unbundle floatarith_notation

	derive (linorder) compare_order float

	derive linorder floatarith

	subsection \<open>Definition\<close>

	type_synonym slp = "floatarith list"

	primrec interpret_slp::"slp \<Rightarrow> real list \<Rightarrow> real list" where
	"interpret_slp [] = (\<lambda>xs. xs)"
	\| "interpret_slp (ea # eas) = (\<lambda>xs. interpret_slp eas (interpret_floatarith ea xs#xs))"

	subsection \<open>Reification as straight line program (with common subexpression elimination)\<close>

	definition "slp_index vs i = (length vs - Suc i)"

	definition "slp_index_lookup vs M a = slp_index vs (the (Mapping.lookup M a))"

	definition
	"slp_of_fa_bin Binop a b M slp M2 slp2 =
	(case Mapping.lookup M (Binop a b) of
	Some i \<Rightarrow> (Mapping.update (Binop a b) (length slp) M, slp@[Var (slp_index slp i)])
	\| None \<Rightarrow> (Mapping.update (Binop a b) (length slp2) M2,
	slp2@[Binop (Var (slp_index_lookup slp2 M2 a)) (Var (slp_index_lookup slp2 M2 b))]))"

	definition
	"slp_of_fa_un Unop a M slp M1 slp1 =
	(case Mapping.lookup M (Unop a) of
	Some i \<Rightarrow> (Mapping.update (Unop a) (length slp) M, slp@[Var (slp_index slp i)])
	\| None \<Rightarrow> (Mapping.update (Unop a) (length slp1) M1,
	slp1@[Unop (Var (slp_index_lookup slp1 M1 a))]))"

	definition
	"slp_of_fa_cnst Const Const' M vs =
	(Mapping.update Const (length vs) M,
	vs @ [case Mapping.lookup M Const of Some i \<Rightarrow> Var (slp_index vs i) \| None \<Rightarrow> Const'])"

	fun slp_of_fa :: "floatarith \<Rightarrow> (floatarith, nat) mapping \<Rightarrow> floatarith list \<Rightarrow>
	((floatarith, nat) mapping \<times> floatarith list)" where
	"slp_of_fa (Add a b) M slp =
	(let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
	slp_of_fa_bin Add a b M slp M2 slp2)"
	\| "slp_of_fa (Mult a b) M slp =
	(let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
	slp_of_fa_bin Mult a b M slp M2 slp2)"
	\| "slp_of_fa (Min a b) M slp =
	(let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
	slp_of_fa_bin Min a b M slp M2 slp2)"
	\| "slp_of_fa (Max a b) M slp =
	(let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
	slp_of_fa_bin Max a b M slp M2 slp2)"
	\| "slp_of_fa (Powr a b) M slp =
	(let (M1, slp1) = slp_of_fa a M slp; (M2, slp2) = slp_of_fa b M1 slp1 in
	slp_of_fa_bin Powr a b M slp M2 slp2)"
	\| "slp_of_fa (Inverse a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Inverse a M slp M1 slp1)"
	\| "slp_of_fa (Cos a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Cos a M slp M1 slp1)"
	\| "slp_of_fa (Arctan a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Arctan a M slp M1 slp1)"
	\| "slp_of_fa (Abs a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Abs a M slp M1 slp1)"
	\| "slp_of_fa (Sqrt a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Sqrt a M slp M1 slp1)"
	\| "slp_of_fa (Exp a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Exp a M slp M1 slp1)"
	\| "slp_of_fa (Ln a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Ln a M slp M1 slp1)"
	\| "slp_of_fa (Minus a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Minus a M slp M1 slp1)"
	\| "slp_of_fa (Floor a) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un Floor a M slp M1 slp1)"
	\| "slp_of_fa (Power a n) M slp =
	(let (M1, slp1) = slp_of_fa a M slp in slp_of_fa_un (\<lambda>a. Power a n) a M slp M1 slp1)"
	\| "slp_of_fa Pi M slp = slp_of_fa_cnst Pi Pi M slp"
	\| "slp_of_fa (Var v) M slp = slp_of_fa_cnst (Var v) (Var (v + length slp)) M slp"
	\| "slp_of_fa (Num n) M slp = slp_of_fa_cnst (Num n) (Num n) M slp"

	lemma interpret_slp_snoc[simp]:
	"interpret_slp (slp @ [fa]) xs = interpret_floatarith fa (interpret_slp slp xs)#interpret_slp slp xs"
	by (induction slp arbitrary: fa xs) auto

	lemma
	binop_slp_of_fa_induction_step:
	assumes
	Binop_IH1:
	"\<And>M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) \<Longrightarrow>
	subterms fa1 \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	and
	Binop_IH2:
	"\<And>M slp M' slp'. slp_of_fa fa2 M slp = (M', slp') \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) \<Longrightarrow>
	subterms fa2 \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	and Binop_prems:
	"(case slp_of_fa fa1 M slp of
	(M1, slp1) \<Rightarrow>
	case slp_of_fa fa2 M1 slp1 of (x, xa) \<Rightarrow> slp_of_fa_bin Binop fa1 fa2 M slp x xa) = (M', slp')"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
	assumes subterms_Binop[simp]:
	"\<And>a b. subterms (Binop a b) = insert (Binop a b) (subterms a \<union> subterms b)"
	assumes interpret_Binop[simp]:
	"\<And>a b xs. interpret_floatarith (Binop a b) xs = binop (interpret_floatarith a xs) (interpret_floatarith b xs)"
	shows "insert (Binop fa1 fa2) (subterms fa1 \<union> subterms fa2) \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	proof -
	from Binop_prems
	obtain M1 slp1 M2 slp2 where *:
	"slp_of_fa fa1 M slp = (M1, slp1)"
	"slp_of_fa fa2 M1 slp1 = (M2, slp2)"
	"slp_of_fa_bin Binop fa1 fa2 M slp M2 slp2 = (M', slp')"
	by (auto split: prod.splits)
	from Binop_IH1[OF *(1) Binop_prems(2) Binop_prems(3) Binop_prems(4), simplified]
	have IH1:
	"f \<in> subterms fa1 \<Longrightarrow> f \<in> Mapping.keys M1"
	"f \<in> Mapping.keys M \<Longrightarrow> f \<in> Mapping.keys M1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> subterms f \<subseteq> Mapping.keys M1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> the (Mapping.lookup M1 f) < length slp1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f = interpret_floatarith f xs"
	for f
	by (auto simp: subset_iff)
	from Binop_IH2[OF *(2) IH1(3) IH1(4) IH1(5)]
	have IH2:
	"f \<in> subterms fa2 \<Longrightarrow> f \<in> Mapping.keys M2"
	"f \<in> Mapping.keys M1 \<Longrightarrow> f \<in> Mapping.keys M2"
	"f \<in> Mapping.keys M2 \<Longrightarrow> subterms f \<subseteq> Mapping.keys M2"
	"f \<in> Mapping.keys M2 \<Longrightarrow> the (Mapping.lookup M2 f) < length slp2"
	"f \<in> Mapping.keys M2 \<Longrightarrow> interpret_slp slp2 xs ! slp_index_lookup slp2 M2 f = interpret_floatarith f xs"
	for f
	by (auto simp: subset_iff)
	show ?thesis
	proof (cases "Mapping.lookup M (Binop fa1 fa2)")
	case None
	then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp2) M2"
	and slp': "slp' = slp2 @ [Binop (Var (slp_index_lookup slp2 M2 fa1)) (Var (slp_index_lookup slp2 M2 fa2))]"
	using *
	by (auto simp: slp_of_fa_bin_def)
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	using IH1 IH2
	by (auto simp: M')
	have "Binop fa1 fa2 \<in> Mapping.keys M'"
	using M' by auto
	have M'_0: "Mapping.lookup M' (Binop fa1 fa2) = Some (length slp2)"
	by (auto simp: M' lookup_update)
	have fa1: "fa1 \<in> Mapping.keys M2" and fa2: "fa2 \<in> Mapping.keys M2"
	by (force intro: IH2 IH1)+
	have rew: "binop (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa1) (interpret_slp slp2 xs ! slp_index_lookup slp2 M2 fa2) =
	binop (interpret_floatarith fa1 xs) (interpret_floatarith fa2 xs)"
	by (auto simp: IH2 fa1)
	show ?thesis
	apply (auto )
	subgoal by fact
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	apply (rule disjI2)
	apply (rule IH2(2))
	apply (rule IH1) apply simp
	done
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	apply (rule disjI2)
	apply (rule IH2)
	by simp
	subgoal
	unfolding M'
	apply simp
	apply (rule disjI2)
	apply (rule IH2(2))
	apply (rule IH1(2))
	by simp
	subgoal
	unfolding M'
	apply auto
	apply (simp add: IH1(1) IH2(2))
	apply (simp add: IH1(2) IH2(1))
	using IH2(3)
	by auto
	subgoal for f
	unfolding M' slp'
	apply simp
	apply (auto simp add: lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
	by (simp add: IH2(4) less_Suc_eq)
	subgoal for f
	unfolding M' slp'
	apply simp
	apply (subst rew)
	apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
	apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def
	split: nat.splits)
	using IH2(4) apply fastforce
	by (metis IH2(4) IH2(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def)
	done
	next
	case (Some C)
	then have M': "M' = Mapping.update (Binop fa1 fa2) (length slp) M"
	and slp': "slp' = slp @ [Var (slp_index slp C)]"
	and Binop_keys: "(Binop fa1 fa2) \<in> Mapping.keys M"
	using *
	by (auto simp: slp_of_fa_bin_def keys_dom_lookup)
	have "subterms (Binop fa1 fa2) \<subseteq> Mapping.keys M'"
	using Binop_keys assms(4)
	by (force simp: M')
	moreover
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	using Binop_keys
	by (auto simp add: M')
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> interpret_slp slp' xs ! slp_index_lookup slp' M' f =
	interpret_floatarith f xs" for f
	apply (auto simp add: M' lookup_map_values lookup_update' slp' Binop_prems slp_index_def
	slp_index_lookup_def)
	apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def)
	apply (metis Binop_keys Some assms(6) interpret_Binop option.sel slp_index_def slp_index_lookup_def)
	apply (metis assms(6) slp_index_def slp_index_lookup_def)
	done
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> subterms f \<subseteq> Mapping.keys M'" for f
	using Binop_keys Some assms(4,6)
	by (auto simp add: M' lookup_map_values)
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> the (Mapping.lookup M' f) < length slp'" for f
	using Binop_keys Some assms(5,7) IH1 IH2
	by (auto simp add: M' lookup_map_values lookup_update' Binop_prems slp' less_SucI)
	ultimately
	show ?thesis
	by auto
	qed
	qed

	lemma
	unop_slp_of_fa_induction_step:
	assumes
	Unop_IH1:
	"\<And>M slp M' slp'. slp_of_fa fa1 M slp = (M', slp') \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp) \<Longrightarrow>
	(\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs) \<Longrightarrow>
	subterms fa1 \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	and Unop_prems:
	"(case slp_of_fa fa1 M slp of (M1, slp1) \<Rightarrow> slp_of_fa_un Unop fa1 M slp M1 slp1) = (M', slp')"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
	assumes subterms_Unop[simp]:
	"\<And>a b. subterms (Unop a) = insert (Unop a) (subterms a)"
	assumes interpret_Unop[simp]:
	"\<And>a b xs. interpret_floatarith (Unop a) xs = unop (interpret_floatarith a xs)"
	shows "insert (Unop fa1) (subterms fa1) \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	proof -
	from Unop_prems
	obtain M1 slp1 where *:
	"slp_of_fa fa1 M slp = (M1, slp1)"
	"slp_of_fa_un Unop fa1 M slp M1 slp1 = (M', slp')"
	by (auto split: prod.splits)
	from Unop_IH1[OF *(1) Unop_prems(2) Unop_prems(3) Unop_prems(4), simplified]
	have IH1:
	"f \<in> subterms fa1 \<Longrightarrow> f \<in> Mapping.keys M1"
	"f \<in> Mapping.keys M \<Longrightarrow> f \<in> Mapping.keys M1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> subterms f \<subseteq> Mapping.keys M1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> the (Mapping.lookup M1 f) < length slp1"
	"f \<in> Mapping.keys M1 \<Longrightarrow> interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f = interpret_floatarith f xs"
	for f
	by (auto simp: subset_iff)
	show ?thesis
	proof (cases "Mapping.lookup M (Unop fa1)")
	case None
	then have M': "M' = Mapping.update (Unop fa1) (length slp1) M1 "
	and slp': "slp' = slp1 @ [Unop (Var (slp_index_lookup slp1 M1 fa1))]"
	using *
	by (auto simp: slp_of_fa_un_def)
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	using IH1
	by (auto simp: M')
	have "Unop fa1 \<in> Mapping.keys M'"
	using M' by auto
	have fa1: "fa1 \<in> Mapping.keys M1"
	by (force intro: IH1)+
	have rew: "interpret_slp slp1 xs ! slp_index_lookup slp1 M1 fa1 = interpret_floatarith fa1 xs"
	by (auto simp: IH1 fa1)
	show ?thesis
	apply (auto )
	subgoal by fact
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	apply (rule disjI2)
	apply (rule IH1) apply simp
	done
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	apply (rule disjI2)
	by (rule IH1) simp
	subgoal
	using IH1(3) M' \<open>\<And>x. x \<in> subterms fa1 \<Longrightarrow> x \<in> Mapping.keys M'\<close> by fastforce
	subgoal for f
	unfolding M' slp'
	apply simp
	apply (auto simp add: lookup_update' rew lookup_map_values)
	by (simp add: IH1(4) less_SucI)
	subgoal for f
	unfolding M' slp'
	apply simp
	apply (subst rew)
	apply (auto simp add: fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def)
	apply (auto simp add: nth_Cons fa1 lookup_update' rew lookup_map_values slp_index_lookup_def slp_index_def
	split: nat.splits)
	using IH1(4) apply fastforce
	by (metis IH1(4) IH1(5) Suc_diff_Suc Suc_inject slp_index_def slp_index_lookup_def)
	done
	next
	case (Some C)
	then have M': "M' = Mapping.update (Unop fa1) (length slp) M"
	and slp': "slp' = slp @ [Var (slp_index slp C)]"
	and Unop_keys: "(Unop fa1) \<in> Mapping.keys M"
	using *
	by (auto simp: slp_of_fa_un_def keys_dom_lookup)
	have "subterms (Unop fa1) \<subseteq> Mapping.keys M'"
	using Unop_keys assms(3)
	by (force simp: M')
	moreover
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	using Unop_keys assms(5)
	by (force simp: M' IH1)
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> interpret_slp slp' xs ! slp_index_lookup slp' M' f =
	interpret_floatarith f xs" for f
	apply (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems slp_index_def slp_index_lookup_def)
	apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
	apply (metis Unop_keys Some assms(5) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
	apply (metis assms(5) slp_index_def slp_index_lookup_def)
	done
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> subterms f \<subseteq> Mapping.keys M'" for f
	using Unop_keys Some assms(3,5)
	by (auto simp add: M' lookup_map_values)
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> the (Mapping.lookup M' f) < length slp'" for f
	by (auto simp add: M' lookup_map_values lookup_update' slp' Unop_prems IH1 less_SucI)
	ultimately
	show ?thesis
	by auto
	qed
	qed

	lemma
	cnst_slp_of_fa_induction_step:
	assumes *:
	"slp_of_fa_cnst Unop Unop' M slp = (M', slp')"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp"
	"\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
	assumes subterms_Unop[simp]:
	"\<And>a b. subterms (Unop) = {Unop}"
	assumes interpret_Unop[simp]:
	"interpret_floatarith Unop xs = unop xs"
	"interpret_floatarith Unop' (interpret_slp slp xs) = unop xs"
	assumes ui: "unop (interpret_slp slp xs) = unop xs"
	shows "{Unop} \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	proof -
	show ?thesis
	proof (cases "Mapping.lookup M Unop")
	case None
	then have M': "M' = Mapping.update Unop (length slp) M"
	and slp': "slp' = slp @ [Unop']"
	using *
	by (auto simp: slp_of_fa_cnst_def)
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	by (auto simp: M')
	have "Unop \<in> Mapping.keys M'"
	using M' by auto
	show ?thesis
	apply (auto )
	subgoal by fact
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	done
	subgoal
	unfolding M'
	- apply (simp add: )
	+ apply simp
	using assms by auto
	subgoal
	unfolding M' slp'
	apply simp
	apply (auto simp add: lookup_update' ui lookup_map_values)
	using interpret_Unop apply auto[1]
	by (simp add: assms(3) less_Suc_eq)
	subgoal for f
	unfolding M' slp'
	apply simp
	apply (auto simp add: lookup_update' ui lookup_map_values slp_index_lookup_def slp_index_def)
	using interpret_Unop apply auto[1]
	apply (auto simp: nth_Cons split: nat.splits)
	using assms(3) leD apply blast
	by (metis Suc_diff_Suc Suc_inject assms(3) assms(4) slp_index_def slp_index_lookup_def)
	done
	next
	case (Some C)
	then have M': "M' = Mapping.update Unop (length slp) M"
	and slp': "slp' = slp @ [Var (slp_index slp C)]"
	and Unop_keys: "(Unop) \<in> Mapping.keys M"
	using *
	by (auto simp: slp_of_fa_cnst_def keys_dom_lookup)
	have "subterms (Unop) \<subseteq> Mapping.keys M'"
	using Unop_keys
	by (fastforce simp: M')
	moreover
	have "Mapping.keys M \<subseteq> Mapping.keys M'"
	using Unop_keys assms(5)
	by (force simp: M')
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs" for f
	apply (auto simp add: M' lookup_map_values lookup_update' slp' slp_index_lookup_def slp_index_def)
	apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
	apply (metis Some Unop_keys assms(4) interpret_Unop option.sel slp_index_def slp_index_lookup_def)
	by (metis Suc_diff_Suc assms(3) assms(4) nth_Cons_Suc slp_index_def slp_index_lookup_def)
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> subterms f \<subseteq> Mapping.keys M'" for f
	using assms by (auto simp add: M' lookup_map_values lookup_update' slp')
	moreover have "f\<in>Mapping.keys M' \<Longrightarrow> the (Mapping.lookup M' f) < length slp'" for f
	using assms
	by (auto simp add: M' lookup_map_values lookup_update' slp' less_SucI)
	ultimately
	show ?thesis
	by auto
	qed
	qed

	lemma interpret_slp_nth:
	"n \<ge> length slp \<Longrightarrow> interpret_slp slp xs ! n = xs ! (n - length slp)"
	by (induction slp arbitrary: xs n) auto

	theorem
	interpret_slp_of_fa:
	assumes "slp_of_fa fa M slp = (M', slp')"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> (the (Mapping.lookup M f)) < length slp"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
	shows "subterms fa \<subseteq> Mapping.keys M' \<and> Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f \<in> Mapping.keys M'.
	subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	(interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))"
	using assms
	proof (induction fa arbitrary: M' slp' M slp)
	case *: (Add fa1 fa2)
	show ?case
	unfolding subterms.simps
	by (rule binop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Mult fa1 fa2)
	show ?case
	unfolding subterms.simps
	by (rule binop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Min fa1 fa2)
	show ?case
	unfolding subterms.simps
	by (rule binop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Max fa1 fa2)
	show ?case
	unfolding subterms.simps
	by (rule binop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Powr fa1 fa2)
	show ?case
	unfolding subterms.simps
	by (rule binop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Minus fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Inverse fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Arctan fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Floor fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Cos fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Ln fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Power fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Abs fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Sqrt fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Exp fa1)
	show ?case
	unfolding subterms.simps
	by (rule unop_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: Pi
	show ?case
	unfolding subterms.simps
	by (rule cnst_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: Num
	show ?case
	unfolding subterms.simps
	by (rule cnst_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]]) auto
	next
	case *: (Var n)
	show ?case
	unfolding subterms.simps
	by (rule cnst_slp_of_fa_induction_step[OF
	*[unfolded subterms.simps slp_of_fa.simps Let_def]])
	(auto simp: interpret_slp_nth)
	qed

	primrec slp_of_fas' where
	"slp_of_fas' [] M slp = (M, slp)"
	\| "slp_of_fas' (fa#fas) M slp = (let (M, slp) = slp_of_fa fa M slp in slp_of_fas' fas M slp)"

	theorem
	interpret_slp_of_fas':
	assumes "slp_of_fas' fas M slp = (M', slp')"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> subterms f \<subseteq> Mapping.keys M"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> the (Mapping.lookup M f) < length slp"
	assumes "\<And>f. f \<in> Mapping.keys M \<Longrightarrow> interpret_slp slp xs ! slp_index_lookup slp M f = interpret_floatarith f xs"
	shows "\<Union>(subterms ` set fas) \<subseteq> Mapping.keys M' \<and> Mapping.keys M \<subseteq> Mapping.keys M' \<and>
	(\<forall>f \<in> Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	(the (Mapping.lookup M' f) < length slp') \<and>
	(interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs))"
	using assms
	proof (induction fas arbitrary: M slp)
	case Nil then show ?case
	by auto
	next
	case (Cons fa fas)
	from \<open>slp_of_fas' (fa # fas) M slp = (M', slp')\<close>
	obtain M1 slp1 where
	fa: "slp_of_fa fa M slp = (M1, slp1)"
	and fas: "slp_of_fas' fas M1 slp1 = (M', slp')"
	by (auto split: prod.splits)
	have "subterms fa \<subseteq> Mapping.keys M1 \<and>
	Mapping.keys M \<subseteq> Mapping.keys M1 \<and>
	(\<forall>f\<in>Mapping.keys M1. subterms f \<subseteq> Mapping.keys M1 \<and>
	the (Mapping.lookup M1 f) < length slp1 \<and>
	interpret_slp slp1 xs ! slp_index_lookup slp1 M1 f= interpret_floatarith f xs)"
	apply (rule interpret_slp_of_fa[OF fa, of xs])
	using Cons.prems
	by (auto split: prod.splits simp: trans_less_add2)
	moreover
	then have "(\<Union>a\<in>set fas. subterms a) \<subseteq> Mapping.keys M' \<and>
	Mapping.keys M1 \<subseteq> Mapping.keys M' \<and>
	(\<forall>f\<in>Mapping.keys M'. subterms f \<subseteq> Mapping.keys M' \<and>
	the (Mapping.lookup M' f) < length slp' \<and>
	interpret_slp slp' xs ! slp_index_lookup slp' M' f = interpret_floatarith f xs)"
	using Cons.prems
	by (intro Cons.IH[OF fas])
	(auto split: prod.splits simp: trans_less_add2)
	ultimately
	show ?case
	by auto
	qed

	definition "slp_of_fas fas =
	(let
	(M, slp) = slp_of_fas' fas Mapping.empty [];
	fasi = map (the o Mapping.lookup M) fas;
	fasi' = map (\<lambda>(a, b). Var (length slp + a - Suc b)) (zip [0..<length fasi] (rev fasi))
	in slp @ fasi')"

	lemma length_interpret_slp[simp]:
	"length (interpret_slp slp xs) = length slp + length xs"
	by (induct slp arbitrary: xs) auto

	lemma length_interpret_floatariths[simp]:
	"length (interpret_floatariths slp xs) = length slp"
	by (induct slp arbitrary: xs) auto

	lemma interpret_slp_append[simp]:
	"interpret_slp (slp1 @ slp2) xs =
	interpret_slp slp2 (interpret_slp slp1 xs)"
	by (induction slp1 arbitrary: slp2 xs) auto

	lemma "interpret_slp (map Var [a + 0, b + 1, c + 2, d + 3]) xs =
	(rev (map (\<lambda>(i, e). xs ! (e - i)) (zip [0..<4] [a + 0, b + 1, c + 2, d + 3])))@xs"
	by (auto simp: numeral_eq_Suc)

	lemma aC_eq_aa: "xs @ y # zs = (xs @ [y]) @ zs"
	by simp

	lemma
	interpret_slp_map_Var:
	assumes "\<And>i. i < length is \<Longrightarrow> is ! i \<ge> i"
	assumes "\<And>i. i < length is \<Longrightarrow> (is ! i - i) < length xs"
	shows "interpret_slp (map Var is) xs =
	(rev (map (\<lambda>(i, e). xs ! (e - i)) (zip [0..<length is] is)))
	@
	xs"
	using assms
	proof (induction "is" arbitrary: xs)
	case Nil
	then show ?case by simp
	next
	case (Cons a "is")
	show ?case
	unfolding interpret_slp.simps list.map
	apply (subst Cons.IH)
	subgoal using Cons.prems by force
	subgoal using Cons.prems by force
	subgoal
	apply (subst aC_eq_aa)
	apply (subst rev.simps(2)[symmetric])
	apply (rule arg_cong[where f="\<lambda>a. a @ xs"])
	apply (rule arg_cong[where f="rev"])
	unfolding interpret_floatarith.simps
	apply auto
	apply (rule nth_equalityI)
	apply force
	apply auto
	using Cons.prems
	apply (auto simp: nth_append nth_Cons split: nat.splits)
	subgoal
	by (metis Suc_leI le_imp_less_Suc not_le old.nat.simps(5))
	subgoal
	by (simp add: minus_nat.simps(2))
	subgoal
	by (metis Suc_lessI minus_nat.simps(2) old.nat.simps(5))
	done
	done
	qed

	theorem slp_of_fas:
	"take (length fas) (interpret_slp (slp_of_fas fas) xs) = interpret_floatariths fas xs"
	proof -
	obtain M slp where Mslp:
	"slp_of_fas' fas Mapping.empty [] = (M, slp)"
	using old.prod.exhaust by blast
	have M: "\<Union>(subterms ` (set fas)) \<subseteq> Mapping.keys M \<and>
	Mapping.keys (Mapping.empty::(floatarith, nat) mapping) \<subseteq> Mapping.keys M \<and>
	(\<forall>f\<in>Mapping.keys M.
	subterms f \<subseteq> Mapping.keys M \<and>
	the (Mapping.lookup M f) < length slp \<and>
	interpret_slp slp xs ! slp_index_lookup slp M f =
	interpret_floatarith f xs)"
	by (rule interpret_slp_of_fas'[OF Mslp]) auto
	have map_eq:
	"map (\<lambda>(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map ((\<lambda>x. the o (Mapping.lookup x)) M) fas)))
	= map Var (map (\<lambda>(a, b). (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (the \<circ> Mapping.lookup M) fas))))"
	unfolding split_beta'
	by (simp add: split_beta')
	have "take (length fas)
	(interpret_slp
	(slp @
	map (\<lambda>(a, b). Var (length slp + a - Suc b)) (zip [0..<length fas] (rev (map (((\<lambda>x. the o (Mapping.lookup x))) M) fas))))
	xs) =
	interpret_floatariths fas xs"
	apply simp
	unfolding map_eq
	apply (subst interpret_slp_map_Var)
	apply (auto simp: rev_nth)
	subgoal premises prems for i
	proof -
	from prems have " (length fas - Suc i) < length fas" using prems by auto
	then have "fas ! (length fas - Suc i) \<in> set fas"
	by simp
	also have "\<dots> \<subseteq> Mapping.keys M"
	using M by force
	finally have "fas ! (length fas - Suc i) \<in> Mapping.keys M" .
	with M
	show ?thesis
	by auto
	qed
	subgoal premises prems for i
	proof -
	from prems have " (length fas - Suc i) < length fas" using prems by auto
	then have "fas ! (length fas - Suc i) \<in> set fas"
	by simp
	also have "\<dots> \<subseteq> Mapping.keys M"
	using M by force
	finally have "fas ! (length fas - Suc i) \<in> Mapping.keys M" .
	with M
	show ?thesis
	by auto
	qed
	subgoal
	apply (rule nth_equalityI, auto)
	subgoal premises prems for i
	proof -
	from prems have "fas ! i \<in> set fas"
	by simp
	also have "\<dots> \<subseteq> Mapping.keys M"
	using M by force
	finally have "fas ! i \<in> Mapping.keys M" .
	from M[THEN conjunct2, THEN conjunct2, rule_format, OF this]
	show ?thesis
	using prems
	by (auto simp: rev_nth interpret_floatariths_nth slp_index_lookup_def slp_index_def)
	qed
	done
	done
	then show ?thesis
	by (auto simp: slp_of_fas_def Let_def Mslp)
	qed


	subsection \<open>better code equations for construction of large programs\<close>

	definition "slp_indexl slpl i = slpl - Suc i"
	definition "slp_indexl_lookup vsl M a = slp_indexl vsl (the (Mapping.lookup M a))"

	definition
	"slp_of_fa_rev_bin Binop a b M slp slpl M2 slp2 slpl2 =
	(case Mapping.lookup M (Binop a b) of
	Some i \<Rightarrow> (Mapping.update (Binop a b) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl)
	\| None \<Rightarrow> (Mapping.update (Binop a b) (slpl2) M2,
	Binop (Var (slp_indexl_lookup slpl2 M2 a)) (Var (slp_indexl_lookup slpl2 M2 b))#slp2,
	Suc slpl2))"

	definition
	"slp_of_fa_rev_un Unop a M slp slpl M1 slp1 slpl1 =
	(case Mapping.lookup M (Unop a) of
	Some i \<Rightarrow> (Mapping.update (Unop a) (slpl) M, Var (slp_indexl slpl i)#slp, Suc slpl)
	\| None \<Rightarrow> (Mapping.update (Unop a) (slpl1) M1,
	Unop (Var (slp_indexl_lookup slpl1 M1 a))#slp1, Suc slpl1))"

	definition
	"slp_of_fa_rev_cnst Const Const' M vs vsl =
	(Mapping.update Const vsl M,
	(case Mapping.lookup M Const of Some i \<Rightarrow> Var (slp_indexl vsl i) \| None \<Rightarrow> Const')#vs, Suc vsl)"

	fun slp_of_fa_rev :: "floatarith \<Rightarrow> (floatarith, nat) mapping \<Rightarrow> floatarith list \<Rightarrow> nat \<Rightarrow>
	((floatarith, nat) mapping \<times> floatarith list \<times> nat)" where
	"slp_of_fa_rev (Add a b) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
	slp_of_fa_rev_bin Add a b M slp slpl M2 slp2 slpl2)"
	\| "slp_of_fa_rev (Mult a b) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
	slp_of_fa_rev_bin Mult a b M slp slpl M2 slp2 slpl2)"
	\| "slp_of_fa_rev (Min a b) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
	slp_of_fa_rev_bin Min a b M slp slpl M2 slp2 slpl2)"
	\| "slp_of_fa_rev (Max a b) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
	slp_of_fa_rev_bin Max a b M slp slpl M2 slp2 slpl2)"
	\| "slp_of_fa_rev (Powr a b) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl; (M2, slp2, slpl2) = slp_of_fa_rev b M1 slp1 slpl1 in
	slp_of_fa_rev_bin Powr a b M slp slpl M2 slp2 slpl2)"
	\| "slp_of_fa_rev (Inverse a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Inverse a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Cos a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Cos a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Arctan a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Arctan a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Abs a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Abs a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Sqrt a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Sqrt a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Exp a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Exp a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Ln a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Ln a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Minus a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Minus a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Floor a) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un Floor a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev (Power a n) M slp slpl =
	(let (M1, slp1, slpl1) = slp_of_fa_rev a M slp slpl in slp_of_fa_rev_un (\<lambda>a. Power a n) a M slp slpl M1 slp1 slpl1)"
	\| "slp_of_fa_rev Pi M slp slpl = slp_of_fa_rev_cnst Pi Pi M slp slpl"
	\| "slp_of_fa_rev (Var v) M slp slpl = slp_of_fa_rev_cnst (Var v) (Var (v + slpl)) M slp slpl"
	\| "slp_of_fa_rev (Num n) M slp slpl = slp_of_fa_rev_cnst (Num n) (Num n) M slp slpl"

	lemma slp_indexl_length[simp]: "slp_indexl (length xs) i = slp_index xs i"
	by (auto simp: slp_index_def slp_indexl_def)

	lemma slp_indexl_lookup_length[simp]: "slp_indexl_lookup (length xs) i = slp_index_lookup xs i"
	by (auto simp: slp_index_lookup_def slp_indexl_lookup_def)

	lemma slp_index_rev[simp]: "slp_index (rev xs) i = slp_index xs i"
	by (auto simp: slp_index_def slp_indexl_def)

	lemma slp_index_lookup_rev[simp]: "slp_index_lookup (rev xs) i = slp_index_lookup xs i"
	by (auto simp: slp_index_lookup_def slp_indexl_lookup_def)

	lemma slp_of_fa_bin_slp_of_fa_rev_bin:
	"slp_of_fa_rev_bin Binop a b M slp (length slp) M2 slp2 (length slp2) =
	(let (M, slp') = slp_of_fa_bin Binop a b M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))"
	by (auto simp: slp_of_fa_rev_bin_def slp_of_fa_bin_def
	split: prod.splits option.splits)

	lemma slp_of_fa_un_slp_of_fa_rev_un:
	"slp_of_fa_rev_un Binop a M slp (length slp) M2 slp2 (length slp2) =
	(let (M, slp') = slp_of_fa_un Binop a M (rev slp) M2 (rev slp2) in (M, rev slp', length slp'))"
	by (auto simp: slp_of_fa_rev_un_def slp_of_fa_un_def split: prod.splits option.splits)

	lemma slp_of_fa_cnst_slp_of_fa_rev_cnst:
	"slp_of_fa_rev_cnst Cnst Cnst' M slp (length slp) =
	(let (M, slp') = slp_of_fa_cnst Cnst Cnst' M (rev slp) in (M, rev slp', length slp'))"
	by (auto simp: slp_of_fa_rev_cnst_def slp_of_fa_cnst_def
	split: prod.splits option.splits)

	lemma slp_of_fa_rev:
	"slp_of_fa_rev fa M slp (length slp) = (let (M, slp') = slp_of_fa fa M (rev slp) in (M, rev slp', length slp'))"
	proof (induction fa arbitrary: M slp)
	case (Add fa1 fa2)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
	next
	case (Minus fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Mult fa1 fa2)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
	next
	case (Inverse fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Cos fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Arctan fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Abs fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Max fa1 fa2)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
	next
	case (Min fa1 fa2)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
	next
	case Pi
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Sqrt fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Exp fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Powr fa1 fa2)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (no_types, lifting) Pair_inject length_rev prod.simps(2) rev_rev_ident slp_of_fa_bin_slp_of_fa_rev_bin)
	next
	case (Ln fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Power fa x2a)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Floor fa)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	(metis (mono_tags, lifting) length_rev prod.simps(2) rev_swap slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Var x)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	next
	case (Num x)
	then show ?case
	by (auto split: prod.splits simp: Let_def
	slp_of_fa_cnst_slp_of_fa_rev_cnst slp_of_fa_bin_slp_of_fa_rev_bin slp_of_fa_un_slp_of_fa_rev_un)
	qed

	lemma slp_of_fa_code[code]:
	"slp_of_fa fa M slp = (let (M, slp', _) = slp_of_fa_rev fa M (rev slp) (length slp) in (M, rev slp'))"
	using slp_of_fa_rev[of fa M "rev slp"]
	by (auto split: prod.splits)

	definition "norm2_slp n = slp_of_fas [floatarith.Inverse (norm2\<^sub>e n)]"

	unbundle no_floatarith_notation

	end
	diff --git a/thys/Amicable_Numbers/Amicable_Numbers.thy b/thys/Amicable_Numbers/Amicable_Numbers.thy
	--- a/thys/Amicable_Numbers/Amicable_Numbers.thy
	+++ b/thys/Amicable_Numbers/Amicable_Numbers.thy
	@@ -1,1537 +1,1537 @@
	(*Author: Angeliki Koutsoukou-Argyraki, University of Cambridge.
	Date: 3 August 2020.

	text\<open>This is a formalisation of Amicable Numbers, involving some relevant material including
	Euler's sigma function, some relevant definitions, results and examples as well as rules such as
	Th\={a}bit ibn Qurra's Rule, Euler's Rule, te Riele's Rule and Borho's Rule with breeders.\<close>*)

	theory "Amicable_Numbers"
	imports "HOL-Number_Theory.Number_Theory"
	"HOL-Computational_Algebra.Computational_Algebra"
	Pratt_Certificate.Pratt_Certificate_Code
	Polynomial_Factorization.Prime_Factorization

	begin

	section\<open>Miscellaneous\<close>

	lemma mult_minus_eq_nat:
	fixes x::nat and y ::nat and z::nat
	assumes " x+y = z"
	shows " -x-y = -z "
	using assms by linarith

	lemma minus_eq_nat_subst: fixes A::nat and B::nat and C::nat and D::nat and E::nat
	assumes "A = B-C-D" and " -E = -C-D"
	shows " A = B-E"
	using assms by linarith

	lemma minus_eq_nat_subst_order: fixes A::nat and B::nat and C::nat and D::nat and E::nat
	assumes "B-C-D > 0" and "A = B-C-D+B" shows "A = 2*B-C-D"
	using assms by auto

	lemma auxiliary_ineq: fixes x::nat assumes "x \<ge> (2::nat)"
	shows " x+1 < (2::nat)*x"
	using assms by linarith

	(* TODO The following three auxiliary lemmas are by Lawrence Paulson. To be added to the library. *)

	lemma sum_strict_mono:
	fixes A :: "nat set"
	assumes "finite B" "A \<subset> B" "0 \<notin> B"
	shows "\<Sum> A < \<Sum> B"
	proof -
	have "B - A \<noteq> {}"
	using assms(2) by blast
	with assms DiffE have "\<Sum> (B-A) > 0"
	by fastforce
	moreover have "\<Sum> B = \<Sum> A + \<Sum> (B-A)"
	by (metis add.commute assms(1) assms(2) psubsetE sum.subset_diff)
	ultimately show ?thesis
	by linarith
	qed

	lemma sum_image_eq:
	assumes "inj_on f A"
	shows "\<Sum> (f ` A) = (\<Sum> i \<in> A. f i)"
	using assms sum.reindex_cong by fastforce

	lemma coprime_dvd_aux:
	assumes "gcd m n = Suc 0" "na dvd n" "ma dvd m" "mb dvd m" "nb dvd n" and eq: "ma * na = mb * nb"
	shows "ma = mb"
	proof -
	have "gcd na mb = 1"
	using assms by (metis One_nat_def gcd.commute gcd_nat.mono is_unit_gcd_iff)
	moreover have "gcd nb ma = 1"
	using assms by (metis One_nat_def gcd.commute gcd_nat.mono is_unit_gcd_iff)
	ultimately show "ma = mb"
	by (metis eq gcd_mult_distrib_nat mult.commute nat_mult_1_right)
	qed

	section\<open>Amicable Numbers\<close>

	subsection\<open>Preliminaries\<close>

	definition divisor :: "nat \<Rightarrow>nat \<Rightarrow> bool" (infixr "divisor" 80)
	where "n divisor m \<equiv>(n \<ge> 1 \<and> n \<le> m \<and> n dvd m)"

	definition divisor_set: "divisor_set m = {n. n divisor m}"

	lemma def_equiv_divisor_set: "divisor_set (n::nat) = set(divisors_nat n)"
	using divisors_nat_def divisors_nat divisor_set divisor_def by auto

	definition proper_divisor :: "nat \<Rightarrow>nat \<Rightarrow> bool" (infixr "properdiv" 80)
	where "n properdiv m \<equiv>(n \<ge> 1 \<and> n < m \<and> n dvd m)"

	definition properdiv_set: "properdiv_set m = {n. n properdiv m}"

	lemma example1_divisor: shows "(2::nat) \<in> divisor_set (4::nat)"
	using divisor_set divisor_def by force

	lemma example2_properdiv_set: "properdiv_set (Suc (Suc (Suc 0))) = {(1::nat)}"
	by (auto simp: properdiv_set proper_divisor_def less_Suc_eq dvd_def; presburger)

	lemma divisor_set_not_empty: fixes m::nat assumes "m \<ge>1"
	shows "m \<in> divisor_set m"
	using assms divisor_set divisor_def by force

	lemma finite_divisor_set [simp]: "finite(divisor_set n)"
	using divisor_def divisor_set by simp

	lemma finite_properdiv_set[simp]: shows "finite(properdiv_set m)"
	using properdiv_set proper_divisor_def by simp

	lemma divisor_set_mult:
	"divisor_set (mn) = {ij\| i j. (i \<in> divisor_set m)\<and>(j \<in> divisor_set n)}"
	using divisor_set divisor_def
	by (fastforce simp add: divisor_set divisor_def dest: division_decomp)

	lemma divisor_set_1 [simp]: "divisor_set (Suc 0) = {Suc 0}"
	by (simp add: divisor_set divisor_def cong: conj_cong)

	lemma divisor_set_one: shows "divisor_set 1 ={1}"
	using divisor_set divisor_def by auto

	lemma union_properdiv_set: assumes "n\<ge>1" shows "divisor_set n =(properdiv_set n)\<union>{n}"
	using divisor_set properdiv_set proper_divisor_def assms divisor_def by auto

	lemma prime_div_set: assumes "prime n" shows "divisor_set n = {n, 1}"
	using divisor_def assms divisor_set prime_nat_iff by auto

	lemma div_set_prime:
	assumes "prime n"
	shows "properdiv_set n = {1}"
	using assms properdiv_set prime_nat_iff proper_divisor_def
	by (metis (no_types, lifting) Collect_cong One_nat_def divisor_def divisor_set divisor_set_one
	dvd_1_left empty_iff insert_iff mem_Collect_eq order_less_irrefl)

	lemma prime_gcd: fixes m::nat and n::nat assumes "prime m" and "prime n"
	and "m \<noteq> n" shows "gcd m n =1 " using prime_def
	by (simp add: assms primes_coprime)

	text\<open>We refer to definitions from \cite{aliquotwiki}:\<close>

	definition aliquot_sum :: "nat \<Rightarrow> nat"
	where "aliquot_sum n \<equiv> \<Sum>(properdiv_set n)"

	definition deficient_number :: "nat \<Rightarrow> bool"
	where "deficient_number n \<equiv> (n > aliquot_sum n)"

	definition abundant_number :: "nat \<Rightarrow> bool"
	where "abundant_number n \<equiv> (n < aliquot_sum n)"

	definition perfect_number :: "nat \<Rightarrow> bool"
	where "perfect_number n \<equiv> (n = aliquot_sum n)"

	lemma example_perfect_6: shows "perfect_number 6"

	proof-
	have a: "set(divisors_nat 6) = {1, 2, 3, 6}" by eval
	have b: "divisor_set (6) = {1, 2, 3, 6}"
	using a def_equiv_divisor_set by simp
	have c: "properdiv_set (6) = {1, 2, 3}"
	using b union_properdiv_set properdiv_set proper_divisor_def by auto
	show ?thesis using aliquot_sum_def c
	by (simp add: numeral_3_eq_3 perfect_number_def)
	qed


	subsection\<open>Euler's sigma function and properties\<close>

	text\<open>The sources of the following useful material on Euler's sigma function are \cite{garciaetal1},
	\cite{garciaetal2}, \cite{sandifer} and \cite{escott}.\<close>

	definition Esigma :: "nat \<Rightarrow> nat"
	where "Esigma n \<equiv> \<Sum>(divisor_set n)"

	lemma Esigma_properdiv_set:
	assumes "m \<ge> 1"
	shows "Esigma m = (aliquot_sum m) + m"
	using assms divisor_set properdiv_set proper_divisor_def union_properdiv_set Esigma_def
	aliquot_sum_def by fastforce

	lemma Esigmanotzero:
	assumes "n \<ge> 1"
	shows "Esigma n \<ge> 1"
	using Esigma_def assms Esigma_properdiv_set by auto

	lemma prime_sum_div:
	assumes "prime n"
	shows " Esigma n = n +(1::nat)"
	proof -
	have "1 \<le> n"
	using assms prime_ge_1_nat by blast
	then show ?thesis using Esigma_properdiv_set assms div_set_prime
	by (simp add: Esigma_properdiv_set aliquot_sum_def assms div_set_prime)
	qed

	lemma sum_div_is_prime:
	assumes "Esigma n = n +(1::nat)" and "n \<ge>1"
	shows "prime n"

	proof (rule ccontr)
	assume F: " \<not> (prime n)"
	have " n divisor n" using assms divisor_def by simp
	have " (1::nat) divisor n"using assms divisor_def by simp

	have "n \<noteq> Suc 0"
	using Esigma_def assms(1) by auto
	then have r: " \<exists>( m::nat). m \<in> divisor_set n \<and> m\<noteq> (1::nat) \<and> m \<noteq> n"
	using assms F
	apply (clarsimp simp add: Esigma_def divisor_set divisor_def prime_nat_iff)
	by (meson Suc_le_eq dvd_imp_le dvd_pos_nat)

	have "Suc n = \<Sum>{n,1}"
	by (simp add: \<open>n \<noteq> Suc 0\<close>)
	moreover
	have "divisor_set n \<supset> {n,1}"
	using assms divisor_set r \<open>1 divisor n\<close> divisor_set_not_empty by auto
	then have "\<Sum>(divisor_set n) > \<Sum>{n,1}"
	apply (rule sum_strict_mono [OF finite_divisor_set])
	by (simp add: divisor_def divisor_set)
	ultimately
	show False
	using Esigma_def assms(1) by presburger
	qed

	lemma Esigma_prime_sum:
	fixes k:: nat assumes "prime m" "k \<ge>1"
	shows "Esigma (m^k) =( m^(k+(1::nat)) -(1::nat)) /(m-1)"

	proof-
	have "m > 1"
	using \<open>prime m\<close> prime_gt_1_nat by blast

	have A: " Esigma (m^k) =( \<Sum> j= 0..k.( m^j)) "
	proof-
	have AA: "divisor_set (m^k) = (\<lambda>j. m ^ j) ` {0..k}"
	using assms prime_ge_1_nat
	by (auto simp add: power_increasing prime_ge_Suc_0_nat divisor_set divisor_def image_iff
	divides_primepow_nat)

	have \<section>: "\<Sum> ((\<lambda>j. m ^ j) ` {..k}) = sum (\<lambda>j. m ^ j) {0..k}" for k
	proof (induction k)
	case (Suc k)
	then show ?case
	apply (clarsimp simp: atMost_Suc)
	by (smt add.commute add_le_same_cancel1 assms(1) atMost_iff finite_atMost finite_imageI
	image_iff le_zero_eq power_add power_one_right prime_power_inj sum.insert zero_neq_one)
	qed auto
	show ?thesis
	by (metis "\<section>" AA Esigma_def atMost_atLeast0)
	qed
	have B: "(\<Sum> i\<le>k.( m^i)) = ( m^Suc k -(1::nat)) /(m-(1::nat))"

	using assms \<open>m > 1\<close> Set_Interval.geometric_sum [of m "Suc k"]
	- apply (simp add: )
	+ apply simp
	by (metis One_nat_def lessThan_Suc_atMost nat_one_le_power of_nat_1 of_nat_diff of_nat_mult
	of_nat_power one_le_mult_iff prime_ge_Suc_0_nat sum.lessThan_Suc)
	show ?thesis using A B assms
	by (metis Suc_eq_plus1 atMost_atLeast0 of_nat_1 of_nat_diff prime_ge_1_nat)
	qed

	lemma prime_Esigma_mult: assumes "prime m" and "prime n" and "m \<noteq> n"
	shows "Esigma (mn) = (Esigma n)(Esigma m)"

	proof-
	have "m divisor (m*n)" using divisor_def assms
	by (simp add: dvd_imp_le prime_gt_0_nat)
	moreover have "\<not>(\<exists> k::nat. k divisor (mn) \<and> k\<noteq>(1::nat)\<and> k \<noteq> m \<and> k \<noteq> n \<and> k\<noteq> mn)"
	using assms unfolding divisor_def
	by (metis One_nat_def division_decomp nat_mult_1 nat_mult_1_right prime_nat_iff)
	ultimately have c: "divisor_set (mn) = {m, n, mn, 1}"
	using divisor_set assms divisor_def by auto
	obtain "m\<noteq>1" "n\<noteq>1"
	using assms not_prime_1 by blast
	then have dd: "Esigma (mn) = m + n +m n +1"
	using assms by (simp add: Esigma_def c)
	then show ?thesis
	using prime_sum_div assms by simp
	qed

	lemma gcd_Esigma_mult:
	assumes "gcd m n = 1"
	shows "Esigma (mn) = (Esigma m)(Esigma n)"

	proof-
	have "Esigma (mn) = \<Sum> {ij\| i j. i \<in> divisor_set m \<and> j \<in> divisor_set n}"
	by (simp add: divisor_set_mult Esigma_def)
	also have "... = (\<Sum>i \<in> divisor_set m. \<Sum>j \<in> divisor_set n. i*j)"
	proof-
	have "inj_on (\<lambda>(i,j). i*j) (divisor_set m \<times> divisor_set n)"
	using assms
	apply (simp add: inj_on_def divisor_set divisor_def)
	by (metis assms coprime_dvd_aux mult_left_cancel not_one_le_zero)
	moreover have
	"{ij\| i j. i \<in> divisor_set m \<and> j \<in> divisor_set n}= (\<lambda>(i,j). ij)`(divisor_set m \<times> divisor_set n)"
	by auto
	ultimately show ?thesis
	by (simp add: sum.cartesian_product sum_image_eq)
	qed
	also have "... = \<Sum>( divisor_set m)* \<Sum>( divisor_set n)"
	by (simp add: sum_product)
	also have "... = Esigma m * Esigma n"
	by (simp add: Esigma_def)
	finally show ?thesis .
	qed

	lemma deficient_Esigma:
	assumes "Esigma m < 2*m" and "m \<ge>1"
	shows "deficient_number m"
	using Esigma_properdiv_set assms deficient_number_def by auto

	lemma abundant_Esigma:
	assumes "Esigma m > 2*m" and "m \<ge>1"
	shows "abundant_number m"
	using Esigma_properdiv_set assms abundant_number_def by auto

	lemma perfect_Esigma:
	assumes "Esigma m = 2*m" and "m \<ge>1"
	shows "perfect_number m"
	using Esigma_properdiv_set assms perfect_number_def by auto

	subsection\<open>Amicable Numbers; definitions, some lemmas and examples\<close>

	definition Amicable_pair :: "nat \<Rightarrow>nat \<Rightarrow> bool" (infixr "Amic" 80)
	where "m Amic n \<equiv> ((m = aliquot_sum n) \<and> (n = aliquot_sum m)) "

	lemma Amicable_pair_sym: fixes m::nat and n ::nat
	assumes "m Amic n " shows "n Amic m "
	using Amicable_pair_def assms by blast

	lemma Amicable_pair_equiv_def:
	assumes "(m Amic n)" and "m \<ge>1" and "n \<ge>1"
	shows "(Esigma m = Esigma n)\<and>(Esigma m = m+n)"
	using assms Amicable_pair_def
	by (metis Esigma_properdiv_set add.commute)

	lemma Amicable_pair_equiv_def_conv:
	assumes "m\<ge>1" and "n\<ge>1" and "(Esigma m = Esigma n)\<and>(Esigma m = m+n)"
	shows "(m Amic n)"
	using assms Amicable_pair_def Esigma_properdiv_set
	by (metis add_right_imp_eq add.commute )

	definition typeAmic :: "nat \<Rightarrow> nat \<Rightarrow> nat list"
	where "typeAmic n m =
	[(card {i. \<exists> N. n = N*(gcd n m) \<and> prime i \<and> i dvd N \<and> \<not> i dvd (gcd n m)}),
	(card {j. \<exists> M. m = M*(gcd n m) \<and> prime j \<and> j dvd M \<and> \<not> j dvd (gcd n m)})]"

	lemma Amicable_pair_deficient: assumes "m > n" and "m Amic n"
	shows "deficient_number m"
	using assms deficient_number_def Amicable_pair_def by metis

	lemma Amicable_pair_abundant: assumes "m > n" and "m Amic n"
	shows "abundant_number n"
	using assms abundant_number_def Amicable_pair_def by metis

	lemma even_even_amicable: assumes "m Amic n" and "m \<ge>1" and "n \<ge>1" and "even m" and "even n"
	shows "(2*m \<noteq> n)"

	proof( rule ccontr )
	have a: "Esigma m = Esigma n" using \<open>m Amic n\<close> Amicable_pair_equiv_def Amicable_pair_def
	assms by blast

	assume "\<not> (2*m \<noteq> n)"
	have "(2m = n)" using \<open>\<not> (2m \<noteq> n)\<close> by simp
	have d:"Esigma n = Esigma (2m)" using \<open>\<not> (2m \<noteq> n)\<close> by simp

	then show False

	proof-
	have w: "2m \<in> divisor_set (2m)" using divisor_set assms divisor_set_not_empty
	by auto
	have w1: "2*m \<notin> divisor_set (m)" using divisor_set assms
	by (simp add: divisor_def)
	have w2: "\<forall> n::nat. n divisor m \<longrightarrow> n divisor (2*m)"
	using assms divisor_def by auto
	have w3: "divisor_set (2*m) \<supset> divisor_set m" using divisor_set divisor_def assms w w1 w2
	by blast
	have v: "( \<Sum> i \<in> ( divisor_set (2*m)).i)> ( \<Sum> i \<in> ( divisor_set m).i)"
	using w3 sum_strict_mono by (simp add: divisor_def divisor_set)
	show ?thesis using v d Esigma_def a by auto
	qed
	qed


	subsubsection\<open>Regular Amicable Pairs\<close>

	definition regularAmicPair :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
	"regularAmicPair n m \<longleftrightarrow> (n Amic m \<and>
	(\<exists>M N g. g = gcd m n \<and> m = Mg \<and> n = Ng \<and> squarefree M \<and>
	squarefree N \<and> gcd g M = 1 \<and> gcd g N = 1))"

	lemma regularAmicPair_sym:
	assumes "regularAmicPair n m" shows "regularAmicPair m n"

	proof-
	have "gcd m n = gcd n m"
	by (metis (no_types) gcd.commute)
	then show ?thesis
	using Amicable_pair_sym assms regularAmicPair_def by auto
	qed

	definition irregularAmicPair :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
	"irregularAmicPair n m \<longleftrightarrow> (( n Amic m) \<and> \<not> regularAmicPair n m)"

	lemma irregularAmicPair_sym:
	assumes "irregularAmicPair n m"
	shows "irregularAmicPair m n"
	using irregularAmicPair_def regularAmicPair_sym Amicable_pair_sym assms by blast


	subsubsection\<open>Twin Amicable Pairs\<close>

	text \<open>We refer to the definition in \cite{amicwiki}:\<close>

	definition twinAmicPair :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
	"twinAmicPair n m \<longleftrightarrow>
	(n Amic m) \<and> (\<not>(\<exists>k l. k > Min {n, m} \<and> k < Max {n, m}\<and> k Amic l))"

	lemma twinAmicPair_sym:
	assumes "twinAmicPair n m"
	shows "twinAmicPair m n"
	using assms twinAmicPair_def Amicable_pair_sym assms by auto

	subsubsection\<open>Isotopic Amicable Pairs\<close>

	text\<open>A way of generating an amicable pair from a given amicable pair under certain conditions is
	given below. Such amicable pairs are called Isotopic \cite{garciaetal1}.\<close>

	lemma isotopic_amicable_pair:
	fixes m n g h M N :: nat
	assumes "m Amic n" and "m \<ge> 1" and "n \<ge> 1"and "m= gM" and "n = gN"
	and "Esigma h = (h/g) * Esigma g" and "h \<noteq> g" and "h > 1" and "g > 1"
	and "gcd g M = 1" and "gcd g N = 1" and "gcd h M = 1" and "gcd h N = 1"
	shows "(hM) Amic (hN)"

	proof-
	have a: "Esigma m = Esigma n" using \<open> m Amic n\<close> Amicable_pair_equiv_def assms
	by blast
	have b: "Esigma m = m + n" using \<open> m Amic n\<close> Amicable_pair_equiv_def assms
	by blast
	have c: "Esigma (hM) = (Esigma h)(Esigma M)"

	proof-
	have "h \<noteq> M"
	using assms Esigmanotzero gcd_Esigma_mult gcd_nat.idem b mult_eq_self_implies_10
	by (metis less_irrefl)

	show ?thesis using \<open>h \<noteq> M\<close> gcd_Esigma_mult assms
	by auto
	qed

	have d: "Esigma (gM) = (Esigma g)(Esigma M)"

	proof-
	have "g\<noteq>M" using assms gcd_nat.idem by (metis less_irrefl)
	show ?thesis using \<open>g\<noteq>M\<close> gcd_Esigma_mult assms by auto
	qed

	have e: "Esigma (gN) = (Esigma g)(Esigma N)"

	proof-
	have "g\<noteq>N" using assms by auto
	show ?thesis using \<open>g\<noteq>N\<close> gcd_Esigma_mult assms by auto
	qed

	have p1: "Esigma m = (Esigma g)*(Esigma M)" using assms d by simp
	have p2: "Esigma n = (Esigma g)*(Esigma N)" using assms e by simp
	have p3: "Esigma (hN) = (Esigma h)(Esigma N)"

	proof-
	have "h\<noteq>N" using assms \<open> gcd h N =1\<close> a b p2 by fastforce
	show ?thesis using \<open>h \<noteq> N\<close> gcd_Esigma_mult assms by auto
	qed

	have A: "Esigma (hM) = Esigma (hN)"
	using c p3 d e p1 p2 a assms Esigmanotzero by fastforce

	have B: "Esigma (hM)=(hM)+(h*N)"
	proof-
	have s: "Esigma (hM) = (h/g)(m+n)" using b c p1 Esigmanotzero assms by simp
	have s1: "Esigma (hM) = h(m/g+n/g)" using s assms
	by (metis add_divide_distrib b of_nat_add semiring_normalization_rules(7)
	times_divide_eq_left times_divide_eq_right)
	have s2: " Esigma (hM) = h(M+N)"
	proof-
	have v: "m/g = M" using assms by simp
	have v1:"n/g = N" using assms by simp
	show ?thesis using s1 v v1 assms
	using of_nat_eq_iff by fastforce
	qed
	show ?thesis using s2 assms
	by (simp add: add_mult_distrib2)
	qed
	show ?thesis using Amicable_pair_equiv_def_conv A B assms one_le_mult_iff One_nat_def Suc_leI
	by (metis (no_types, opaque_lifting) nat_less_le)
	qed


	lemma isotopic_pair_example1:
	assumes "(3^351117227) Amic (3^35233753)"
	shows "(3^27131117227) Amic (3^2713233753)"

	proof-
	obtain m where o1: "m = (3::nat)^351117227" by simp
	obtain n where o2: "n = (3::nat)^35233753" by simp
	obtain g where o3: "g = (3::nat)^3*5" by simp
	obtain h where o4: "h = (3::nat)^2713" by simp
	obtain M where o5: "M = (11::nat)17227" by simp
	obtain N where o6: "N = (23::nat)3753" by simp
	have "prime(3::nat)" by simp
	have "prime(5::nat)" by simp
	have "prime(7::nat)" by simp
	have "prime(13::nat)" by simp

	have v: "m Amic n" using o1 o2 assms by simp
	have v1: "m = g*M" using o1 o3 o5 by simp
	have v2: "n = g*N" using o2 o3 o6 by simp
	have v3: "h >0" using o4 by simp
	have w: "g >0" using o3 by simp
	have w1: "h \<noteq> g" using o4 o3 by simp
	have "h = 819" using o4 by simp
	have "g = 135" using o3 by simp

	have w2: "Esigma h = (h/g)*Esigma g"

	proof-
	have B: "Esigma h = 1456"
	proof-
	have R: "set(divisors_nat 819) ={1, 3, 7, 9, 13, 21, 39, 63, 91, 117, 273, 819}"
	by eval
	have RR: "set( divisors_nat(819)) = divisor_set (819)"
	using def_equiv_divisor_set by simp

	show?thesis using Esigma_def RR R \<open> h = 819\<close> divisor_def divisors_nat divisors_nat_def by auto
	qed

	have C: "Esigma g = 240"
	proof-
	have G: "set(divisors_nat 135) = {1, 3, 5, 9, 15, 27, 45, 135}"
	by eval
	have GG: "set(divisors_nat 135) = divisor_set 135"
	using def_equiv_divisor_set by simp

	show ?thesis using G GG Esigma_def \<open> g = 135\<close>
	properdiv_set proper_divisor_def
	by simp
	qed
	have D: "(Esigma h) * g = (Esigma g) * h"

	proof-
	have A: "(Esigma h) * g = 196560"
	using B o3 by simp
	have AA: "(Esigma g) * h = 196560" using C o4 by simp
	show ?thesis using A AA by simp
	qed
	show ?thesis using D
	by (metis mult.commute nat_neq_iff nonzero_mult_div_cancel_right
	of_nat_eq_0_iff of_nat_mult times_divide_eq_left w)

	qed

	have w4: "gcd g M =1"

	proof-
	have "coprime g M"

	proof-
	have "\<not> g dvd M" using o3 o5 by auto
	moreover have "\<not> 3 dvd M" using o5 by auto
	moreover have "\<not> 5 dvd M" using o5 by auto
	ultimately show ?thesis using o5 o3
	gcd_nat.absorb_iff2 prime_nat_iff \<open> prime(3::nat)\<close> \<open> prime(5::nat)\<close>
	by (metis coprime_commute
	coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat)
	qed
	show ?thesis using \<open>coprime g M\<close> by simp
	qed

	have s: " gcd g N =1"

	proof-
	have "coprime g N"

	proof-
	have "\<not> g dvd N"
	using o3 o6 by auto
	moreover have "\<not> 3 dvd N" using o6 by auto
	moreover have "\<not> 5 dvd N" using o6 by auto
	ultimately show ?thesis using o3 gcd_nat.absorb_iff2 prime_nat_iff \<open> prime(3::nat)\<close>
	\<open> prime(5::nat)\<close>
	by (metis coprime_commute
	coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat)
	qed
	show ?thesis using \<open>coprime g N\<close> by simp
	qed

	have s1: "gcd h M =1"

	proof-
	have "coprime h M"

	proof-
	have "\<not> h dvd M" using o4 o5 by auto
	moreover have "\<not> 3 dvd M" using o5 by auto
	moreover have "\<not> 7 dvd M" using o5 by auto
	moreover have "\<not> 13 dvd M" using o5 by auto
	ultimately show ?thesis using o4 gcd_nat.absorb_iff2 prime_nat_iff \<open> prime(3::nat)\<close>
	\<open> prime(13::nat)\<close> \<open> prime(7::nat)\<close>

	by (metis coprime_commute
	coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat)
	qed

	show ?thesis using \<open>coprime h M\<close> by simp
	qed

	have s2: "gcd h N =1"

	proof-
	have "coprime h N"

	proof-
	have "\<not> h dvd N" using o4 o6 by auto
	moreover have "\<not> 3 dvd N" using o6 by auto
	moreover have "\<not> 7 dvd N" using o6 by auto
	moreover have "\<not> 13 dvd N" using o6 by auto
	ultimately show ?thesis using o4
	gcd_nat.absorb_iff2 prime_nat_iff \<open> prime(3::nat)\<close>\<open> prime(13::nat)\<close> \<open> prime(7::nat)\<close>

	by (metis coprime_commute
	coprime_mult_left_iff prime_imp_coprime_nat prime_imp_power_coprime_nat)
	qed

	show ?thesis using \<open>coprime h N\<close> by simp
	qed

	have s4: "(hM) Amic (hN)" using isotopic_amicable_pair v v1 v2 v3 w4 s s1 s2 w w1 w2
	by (metis One_nat_def Suc_leI le_eq_less_or_eq nat_1_eq_mult_iff
	num.distinct(3) numeral_eq_one_iff one_le_mult_iff one_le_numeral o3 o4 o5 o6)

	show ?thesis using s4 o4 o5 o6 by simp
	qed


	subsubsection\<open>Betrothed (Quasi-Amicable) Pairs\<close>

	text\<open>We refer to the definition in \cite{betrothedwiki}:\<close>

	definition QuasiAmicable_pair :: "nat \<Rightarrow> nat \<Rightarrow> bool" (infixr "QAmic" 80)
	where "m QAmic n \<longleftrightarrow> (m + 1 = aliquot_sum n) \<and> (n + 1 = aliquot_sum m)"

	lemma QuasiAmicable_pair_sym :
	assumes "m QAmic n " shows "n QAmic m "
	using QuasiAmicable_pair_def assms by blast

	lemma QuasiAmicable_example:
	shows "48 QAmic 75"

	proof-
	have a: "set(divisors_nat 48) = {1, 2, 3, 4, 6, 8, 12, 16, 24, 48}" by eval
	have b: "divisor_set (48) = {1, 2, 3, 4, 6, 8, 12, 16, 24, 48}"
	using a def_equiv_divisor_set by simp
	have c: "properdiv_set (48) = {1, 2, 3, 4, 6, 8, 12, 16, 24}"
	using b union_properdiv_set properdiv_set proper_divisor_def by auto
	have e: "aliquot_sum (48) = 75+1" using aliquot_sum_def c
	by simp
	have i: "set(divisors_nat 75) = {1, 3, 5, 15, 25, 75}" by eval
	have ii: "divisor_set (75) = {1, 3, 5, 15, 25, 75}"
	using i def_equiv_divisor_set by simp
	have iii: "properdiv_set (75) = {1, 3, 5, 15, 25}"
	using ii union_properdiv_set properdiv_set proper_divisor_def by auto
	have iv: "aliquot_sum (75) = 48+1" using aliquot_sum_def iii
	by simp
	show ?thesis using e iv QuasiAmicable_pair_def by simp
	qed


	subsubsection\<open>Breeders\<close>

	definition breeder_pair :: "nat \<Rightarrow>nat \<Rightarrow> bool" (infixr "breeder" 80)
	where "m breeder n \<equiv> (\<exists>x\<in>\<nat>. x > 0 \<and> Esigma m = m + nx \<and> Esigma m = (Esigma n)(x+1))"

	lemma breederAmic:
	fixes x :: nat
	assumes "x > 0" and "Esigma n = n + mx" and "Esigma n = Esigma m (x+1)"
	and "prime x" and "\<not>( x dvd m)"
	shows " n Amic (m*x)"

	proof-
	have A: "Esigma n = Esigma (m*x)"
	proof-
	have "gcd m x =1" using assms gcd_nat.absorb_iff2 prime_nat_iff by blast

	have A1: "Esigma (mx) = (Esigma m)(Esigma x)"
	using \<open>gcd m x =1\<close> gcd_Esigma_mult by simp
	have A2: "Esigma (mx) = (Esigma m)(x+1)"
	using \<open>prime x\<close> prime_Esigma_mult A1
	by (simp add: prime_sum_div)
	show ?thesis using A2 assms by simp
	qed

	have B: "Esigma n = n+m*x" using assms by simp
	show ?thesis using A B Amicable_pair_equiv_def
	by (smt Amicable_pair_equiv_def_conv Esigma_properdiv_set
	One_nat_def Suc_leI add_cancel_left_left add_le_same_cancel1 add_mult_distrib2 assms
	dvd_triv_right le_add2 nat_0_less_mult_iff not_gr_zero not_le semiring_normalization_rules(1))
	qed


	subsubsection\<open>More examples\<close>

	text\<open>The first odd-odd amicable pair was discovered by Euler \cite{garciaetal1}. In the following
	proof, amicability is shown using the properties of Euler's sigma function.\<close>

	lemma odd_odd_amicable_Euler: "69615 Amic 87633"
	proof-
	have "prime(5::nat)" by simp
	have "prime(17::nat)" by simp
	have "\<not> (517)dvd((3::nat)^27*13)" by auto
	have "\<not> 5 dvd((3::nat)^2713)" by auto
	have "\<not> 17 dvd((3::nat)^2713)" by auto
	have A1: "Esigma(69615) = Esigma(3^2713517)" by simp
	have A2: "Esigma(3^2713517) = Esigma(3^2713)Esigma(517)"

	proof-
	have A111: "coprime ((3::nat)^2713) ((5::nat)*17)"
	using \<open>\<not> 17 dvd((3::nat)^2713)\<close> \<open>\<not> 5 dvd((3::nat)^2713)\<close> \<open>prime (17::nat)\<close>
	\<open>prime (5::nat)\<close> coprime_commute coprime_mult_left_iff prime_imp_coprime_nat by blast

	have "gcd (3^2713)((5::nat)*17) =1"
	using A111 coprime_imp_gcd_eq_1 by blast
	show ?thesis using \<open>gcd (3^2713)((5::nat)*17) =1 \<close>
	gcd_Esigma_mult
	by (smt semiring_normalization_rules(18) semiring_normalization_rules(7))
	qed
	have "prime (7::nat)" by simp
	have "\<not> 7 dvd ((3::nat)^2)" by simp
	have "prime (13::nat)" by simp
	have " \<not> 13 dvd ((3::nat)^2*7)" by simp
	have "gcd ((3::nat)^2*7) 13 =1"
	using \<open>prime (13::nat)\<close> \<open>\<not> 13 dvd ((3::nat)^2*7)\<close> gcd_nat.absorb_iff2 prime_nat_iff
	by blast
	have A3: " Esigma(3^2 * 713) = Esigma(3^27)*Esigma(13)"
	using \<open>gcd (3^2 *7) 13 =1\<close> gcd_Esigma_mult
	by (smt semiring_normalization_rules(18) semiring_normalization_rules(7))
	have "gcd ((3::nat)^2) 7 = 1"
	using \<open>prime (7::nat)\<close> \<open> \<not> 7 dvd ((3::nat)^2 )\<close> gcd_nat.absorb_iff2 prime_nat_iff
	by blast
	have A4: " Esigma(3^27) = Esigma(3^2) Esigma (7)"
	using \<open>gcd ((3::nat)^2) 7 =1\<close> gcd_Esigma_mult
	by (smt semiring_normalization_rules(18) semiring_normalization_rules(7))
	have A5: "Esigma(3^2) = 13"
	proof-
	have "(3::nat)^2 =9" by auto
	have A55:"divisor_set 9 = {1, 3, 9}"
	proof-
	have A555: "set(divisors_nat (9)) = {1, 3, 9}" by eval
	show ?thesis using def_equiv_divisor_set A555 by simp
	qed
	show ?thesis using A55 \<open>(3::nat)^2 =9\<close> Esigma_def by simp
	qed
	have "prime( 13::nat)" by simp
	have A6: "Esigma (13) = 14"
	using prime_sum_div \<open>prime( 13::nat)\<close> by auto
	have "prime( 7::nat)" by simp
	have A7: "Esigma (7) = 8"
	using prime_sum_div \<open>prime( 7::nat)\<close> by auto
	have "prime (5::nat)" by simp
	have "prime (17::nat)" by simp
	have A8: "Esigma(517) = Esigma(5) Esigma (17)"
	using prime_Esigma_mult \<open>prime (5::nat)\<close> \<open>prime (17::nat)\<close>
	by (metis arith_simps(2) mult.commute num.inject(2) numeral_eq_iff semiring_norm(83))
	have A9: "Esigma(69615) = Esigma(3^2)Esigma (7) Esigma (13) * Esigma(5) * Esigma (17)"
	using A1 A2 A3 A4 A5 A6 A7 A8 by (metis mult.assoc)
	have A10: "Esigma (5)=6"
	using prime_sum_div \<open>prime(5::nat)\<close> by auto
	have A11: "Esigma (17)=18"
	using prime_sum_div \<open>prime(17::nat)\<close> by auto
	have AA: "Esigma(69615)=13814618" using A1 A2 A3 A4 A5 A6 A7 A8 A9 A10 A11
	by simp
	have AAA: "Esigma(69615) =157248" using AA by simp

	have AA1: "Esigma(87633) = Esigma (3^2713*107)" by simp
	have "prime (107::nat)" by simp
	have AA2: "Esigma (3^2713107) = Esigma (3^2713)Esigma(107)"

	proof-
	have "\<not> (107::nat) dvd (3^2713)" by auto
	have "gcd ((3::nat)^2713) 107 =1" using \<open>prime (107::nat)\<close>
	\<open> \<not> (107::nat) dvd (3^2713)\<close>

	using gcd_nat.absorb_iff2 prime_nat_iff by blast

	show ?thesis using \<open>gcd (3^2 713) 107 =1\<close> gcd_Esigma_mult by (smt mult.commute)
	qed
	have AA3: "Esigma (107) =108"
	using prime_sum_div \<open>prime(107::nat)\<close> by auto
	have AA4: "Esigma(3^2713) = 13814"
	using A3 A4 A5 A6 A7 by auto
	have AA5 : "Esigma (3^2713107) = 13814108"
	using AA2 AA3 AA4 by auto
	have AA6: "Esigma (3^2713*107) = 157248" using AA5 by simp
	have A:"Esigma(69615) = Esigma(87633)"
	using AAA AA6 AA5 AA1 by linarith
	have B: " Esigma(87633) = 69615 + 87633"
	using AAA \<open>Esigma 69615 = Esigma 87633\<close> by linarith
	show ?thesis using A B Amicable_pair_def Amicable_pair_equiv_def_conv by auto
	qed

	text\<open>The following is the smallest odd-odd amicable pair \cite{garciaetal1}. In the following proof,
	amicability is shown directly by evaluating the sets of divisors.\<close>

	lemma Amicable_pair_example_smallest_odd_odd: "12285 Amic 14595"
	proof-
	have A: "set(divisors_nat (12285)) = {1, 3, 5, 7, 9, 13, 15, 21, 27, 35, 39, 45, 63, 65, 91,
	105, 117, 135, 189, 195, 273, 315, 351, 455, 585, 819, 945, 1365, 1755, 2457, 4095, 12285}"
	by eval
	have A1: "set(divisors_nat (12285)) = divisor_set 12285"
	using def_equiv_divisor_set by simp
	have A2: "\<Sum>{1, 3, 5, 7, 9, 13, 15, 21, 27, 35, 39, 45, 63, 65, 91, 105, 117, 135, 189, 195, 273,
	315, 351, 455, 585, 819, 945, 1365, 1755, 2457, 4095, 12285} = (26880::nat)" by eval
	have A3: "Esigma 12285 = 26880" using A A1 A2 Esigma_def by simp
	have Q:"Esigma 12285 = Esigma 14595"
	proof-
	have N: "set(divisors_nat (14595)) =
	{ 1, 3, 5, 7, 15, 21, 35, 105, 139, 417, 695, 973, 2085, 2919, 4865, 14595}"
	by eval
	have N1: "set(divisors_nat (14595)) = divisor_set 14595"
	using def_equiv_divisor_set by simp
	have N2:
	"\<Sum>{ 1, 3, 5, 7, 15, 21, 35, 105, 139, 417, 695, 973, 2085, 2919, 4865, 14595} = (26880::nat)"
	by eval
	show ?thesis using A3 N N1 N2 Esigma_def by simp
	qed
	have B:"Esigma (12285) = 12285 + 14595" using A3 by auto
	show ?thesis using B Q Amicable_pair_def
	using Amicable_pair_equiv_def_conv one_le_numeral by blast
	qed


	section\<open>Euler's Rule\<close>

	text\<open>We present Euler's Rule as in \cite{garciaetal1}. The proof has been reconstructed.\<close>

	theorem Euler_Rule_Amicable:
	fixes k l f p q r m n :: nat
	assumes "k > l" and "l \<ge> 1" and "f = 2^l+1"
	and "prime p" and "prime q" and "prime r"
	and "p = 2^(k-l) * f - 1" and "q = 2^k * f - 1" and "r = 2^(2k-l) f^2 - 1"
	and "m = 2^k * p * q" and "n = 2^k * r"
	shows "m Amic n"

	proof-
	note [[linarith_split_limit = 50]]
	have A1: "(p+1)*(q+1) = (r+1)"
	proof-
	have a: "p+1 = (2^(k-l))*f" using assms by simp
	have b: "q+1 = (2^(k))*f" using assms by simp
	have c: "r+1 = (2^(2k-l))(f^2)" using assms by simp
	have d: "(p+1)(q+1) = (2^(k-l))(2^(k))*f^2"
	using a b by (simp add: power2_eq_square)
	show ?thesis using d c
	by (metis Nat.add_diff_assoc add.commute assms(1) less_imp_le_nat mult_2 power_add)
	qed
	have aa: "Esigma p = p+1" using assms \<open>prime p\<close> prime_sum_div by simp
	have bb: "Esigma q = q+1" using \<open>prime q\<close> prime_sum_div assms by simp
	have cc: "Esigma r = r+1" using \<open>prime r\<close> prime_sum_div assms by simp
	have A2: "(Esigma p)*(Esigma q) = Esigma r"
	using aa bb cc A1 by simp
	have A3: "Esigma (2^k)(Esigma p)(Esigma q) = Esigma(2^k)*(Esigma r)"
	using A2 by simp
	have A4: "Esigma(( 2^k)r) = (Esigma(2^k))(Esigma r)"
	proof-
	have Z0: "gcd ((2::nat)^k)r =1" using assms \<open>prime r\<close> by simp
	have A: "(2::nat)^k \<ge> 1" using assms by simp
	have Ab: "(2::nat)^k \<noteq> r" using assms
	by (metis gcd_nat.idem numeral_le_one_iff prime_ge_2_nat semiring_norm(69) Z0)
	show ?thesis using Z0 gcd_Esigma_mult assms A Ab by metis
	qed

	have A5: "Esigma((2^k)pq) =(Esigma(2^k))(Esigma p)(Esigma q)"
	proof-
	have "(2::nat)^k \<ge>1" using assms by simp
	have A: "gcd (2^k) p =1" using assms \<open>prime p\<close> by simp
	have B: "gcd (2^k) q =1" using assms \<open>prime q\<close> by simp
	have BB: "gcd (2^k) (p*q) =1" using assms A B by fastforce
	have C: "p*q \<ge>1" using assms One_nat_def one_le_mult_iff prime_ge_1_nat by metis
	have A6: " Esigma((2^k)(pq))=( Esigma(2^k))(Esigma(pq))"
	proof-
	have "(( 2::nat)^k) \<noteq> (p*q)" using assms
	by (metis BB Nat.add_0_right gcd_idem_nat less_add_eq_less
	not_add_less1 power_inject_exp prime_gt_1_nat semiring_normalization_rules(32)
	two_is_prime_nat )
	show ?thesis using \<open>(( 2::nat)^k) \<noteq> (p*q)\<close>
	\<open>( 2::nat)^k \<ge>1\<close> gcd_Esigma_mult assms C BB
	by metis
	qed
	have A7:"Esigma(pq) = (Esigma p)(Esigma q)"
	proof-
	have "p \<noteq> q" using assms One_nat_def Suc_pred add_gr_0 add_is_0 diff_commute diff_diff_cancel
	diff_is_0_eq nat_0_less_mult_iff nat_mult_eq_cancel_disj
	numeral_One prime_gt_1_nat power_inject_exp
	semiring_normalization_rules(7) two_is_prime_nat zero_less_numeral zero_less_power
	zero_neq_numeral by (smt less_imp_le_nat)

	show ?thesis using \<open>p \<noteq> q\<close>
	\<open>prime p\<close> \<open>prime q\<close> C prime_Esigma_mult assms
	by (metis mult.commute)
	qed

	have A8: "Esigma((2^k)( pq))=(Esigma(2^k))(Esigma p)(Esigma q)" by (simp add: A6 A7)
	show ?thesis using A8 by (simp add: mult.assoc)
	qed

	have Z: "Esigma((2^k)pq) = Esigma ((2^k)*r)" using A1 A2 A3 A4 A5 by simp

	have Z1: "Esigma ((2^k)pq) = 2^k pq + 2^k*r"

	proof-
	have "prime (2::nat)" by simp
	have s: "Esigma (2^k) =((2::nat)^(k+1)-1)/(2-1)"
	using \<open>prime (2::nat)\<close> assms Esigma_prime_sum by auto
	have ss: "Esigma (2^k) =(2^(k+1)-1)" using s by simp
	have J: "(k+1+k-l+k)= 3*k +1-l" using assms by linarith
	have JJ: "(2^(k-l))(2^k) = (2::nat)^(2k-l)"
	apply (simp add: algebra_simps)
	by (metis Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2_right power_add)
	have "Esigma((2^k)pq)= (Esigma(2^k))(Esigma p)(Esigma q)" using A5 by simp
	also have "\<dots> = (2^(k+1)-1)(p+1)(q+1)" using assms ss aa bb by metis
	also have "\<dots> = (2^(k+1)-1)((2^(k-l))f)((2^k)f)" using assms by simp
	also have "\<dots> = (2^(k+1)-1)(2^(k-l))(2^k)*f^2"
	by (simp add: power2_eq_square)
	also have "\<dots> = (2^(k+1))(2^(k-l))(2^k)f^2-(2^(k-l))(2^k)*f^2"
	by (smt left_diff_distrib' mult.commute mult_numeral_1_right numeral_One)
	also have "\<dots> = (2^(k+1+k-l+k))f^2-(2^(k-l))(2^k)*f^2"
	by (metis Nat.add_diff_assoc assms(1) less_imp_le_nat power_add)
	also have "\<dots> = (2^(3k+1-l))f^2-(2^(k-l))(2^k)f^2"
	using J by auto
	also have "\<dots> = (2^(3k+1-l))f^2-(2^(2k-l))f^2"
	using JJ by simp
	finally
	have YY:" Esigma((2^k)pq)= (2^(3k+1-l))f^2-(2^(2k-l))f^2" .

	have auxicalc: "(2^(2k-l))(f^2)=(2^(2k-l))f +(2^(2k))f"

	proof-
	have i: "(2^(2k-l))f = (2^(2k-l))(2^l+1)"
	using assms \<open>f = 2^l+1\<close> by simp
	have ii: "( 2^(2k-l))f = (2^(2k-l))( 2^l)+(2^(2*k-l))"
	using i by simp
	have iii: "(2^(2k-l))f = (2^(2k-l+l))+(2^(2k-l))"
	using ii by (simp add: power_add)
	have iv: "( 2^(2k-l))ff =(((2^(2k))+(2^(2k-l))))f"
	using iii assms by simp
	have v: "(2^(2k-l))f f =((2^(2k)))f+((2^(2k-l)))*f"
	using iv assms comm_monoid_mult_axioms power2_eq_square semiring_normalization_rules(18)
	semiring_normalization_rules by (simp add: add_mult_distrib assms) (slow)
	show ?thesis using v by (simp add: power2_eq_square semiring_normalization_rules(18))
	qed

	have W1: "2^kpq + 2^kr = 2^k (p*q +r) "
	by (simp add: add_mult_distrib2)

	have W2: "2^k(pq +r)= 2^k ((2^(k-l)f-1)((2^k)f-1)+(2^(2k-l))f^2-1)"
	using assms by simp

	have W3: "2^k((2^(k-l)f-1)((2^k)f-1)+(2^(2k-l))f^2-1)=
	2^k((2^(k-l)f-1)((2^k)f)-(2^(k-l)f-1)+(2^(2k-l))*f^2-1)"
	by (simp add: right_diff_distrib')

	have W4: "2^k((2^(k-l)f-1)((2^k)f)-(2^(k-l)f-1)+(2^(2k-l))*f^2-1) =
	2^k((2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f-1)+(2^(2k-l))f^2-1)"
	using assms by (simp add: diff_mult_distrib)

	have W5: " 2^k((2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f-1)+(2^(2k-l))f^2-1) =
	2^k (( 2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f)+1 +(2^(2k-l))f^2-1)"
	using assms less_imp_le_nat less_imp_le_nat prime_ge_1_nat
	by (smt Nat.add_diff_assoc2 Nat.diff_diff_right One_nat_def Suc_leI Suc_pred W3 W4
	add_diff_cancel_right' add_gr_0 le_Suc_ex less_numeral_extra(1) mult_cancel1
	nat_0_less_mult_iff zero_less_diff zero_less_numeral zero_less_power)

	have W6: "2^k((2^(k-l) f)((2^k)f)-((2^k)f)-(2^(k-l)f)+1+(2^(2k-l))f^2-1 ) =
	2^k((2^(k-l)f)((2^k)f)-((2^k )f)-(2^(k-l)f)+(2^(2k-l))f^2)"
	by simp

	have W7: "2^k((2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f)+(2^(2k-l))f^2) =
	2^k ((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)* f))"

	proof-
	have a: "(2^(k-l)f)(2^k * f) = (2^(k-l)f(f*(2^k))) "
	using assms by simp
	have b: "(2^(k-l)f)(f(2^k)) = 2^(k-l)(ff)(2^k)"
	using assms by linarith
	have c: "2^(k-l)(ff)(2^k) = 2^(k-l+k)(f^2)"
	using Semiring_Normalization.comm_semiring_1_class.semiring_normalization_rules(16)
	Semiring_Normalization.comm_semiring_1_class.semiring_normalization_rules(29)
	by (simp add: power_add)

	have d: "2^(k-l+k) (f^2) = 2^(2k-l) *(f^2)"
	by (simp add: JJ power_add)

	have e: "(2^(2k-l))f^2 + (2^(2k-l))f^2 = 2^(2k-l +1)(f^2)"
	by simp

	have f1: "((2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f)+(2^(2k-l))*f^2) =
	(2^(2k-l)(f^2)-((2^k)f)-(2^(k-l)f)+(2^(2k-l))f^2)"
	using a b c d e by simp

	have f2:"((2^(k-l)f)((2^k)f)-((2^k)f)-(2^(k-l)f))+(2^(2k-l))*f^2
	= ((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)f))"

	proof-
	have aa: "f > 1" using assms by simp
	have a: "((2::nat)^(2k-l))f^2-((2::nat)^(k-l)*f)>0"
	proof-
	have b: "(2::nat)^(2*k-l) > 2^(k-l)" using assms by simp
	have c: "(2::nat)^(2k-l)f > 2^(k-l)*f" using a assms
	by (metis One_nat_def add_gr_0 b lessI mult_less_mono1)
	show ?thesis
	using c auxicalc by linarith
	qed

	have aaa: "(2^(2k-l))f^2 -(2^(k-l)f)-((2^k)f) >0"

	proof-
	have A: "(2^(2k-l))f-(2^(k-l))-(( 2^k)) >0"

	proof-
	have A_1 : "(2^(2k-l))f > (2^(k-l))+((2^k))"

	proof-
	have A_2: "(2^(2k-l))f = 2^(k)2^(k-l)f"
	by (metis JJ semiring_normalization_rules(7))

	have df1: "(2^(k-l))+((2^k))< ((2::nat)^(2*k-l))+((2^k))"
	using \<open>l < k\<close> by (simp add: algebra_simps)

	have df2: "((2::nat)^(2k-l))+((2^k)) < ((2::nat)^(2k-l))*f"
	proof-
	have "k >1" using assms by simp
	have df: "((2::nat)^(k-l))+(1::nat) < ((2::nat)^(k-l))*f"
	proof-
	obtain x::nat where xx: "x=(2::nat)^(k-l)" by simp
	have xxx: "x \<ge>( 2::nat)" using assms xx
	by (metis One_nat_def Suc_leI one_le_numeral power_increasing
	semiring_normalization_rules(33) zero_less_diff)

	have c: "xf \<ge> x(2::nat)" using aa by simp

	have c1: "x+(1::nat) < x*(2::nat)"
	using auxiliary_ineq xxx by linarith
	have c2: "((2::nat)^(k-l))+(1::nat) < ((2::nat)^(k-l))*(2::nat)"
	using c1 xx by blast
	show ?thesis using c2 c xx
	by (metis diff_is_0_eq' le_trans nat_less_le zero_less_diff)
	qed

	show ?thesis using df aa assms
	by (smt JJ add.commute mult_less_cancel2 semiring_normalization_rules
	zero_less_numeral zero_less_power)
	qed
	show ?thesis using A_2 df1 df2 by linarith
	qed

	show ?thesis using assms A_1
	using diff_diff_left zero_less_diff by presburger
	qed

	show ?thesis using A aa assms
	by (metis (no_types, opaque_lifting) a nat_0_less_mult_iff right_diff_distrib'
	semiring_normalization_rules(18) semiring_normalization_rules(29)
	semiring_normalization_rules(7))
	qed

	have b3: "((2^(2k-l)(f^2))-((2^k)f)-(2^(k-l)f)+(2^(2k-l))f^2) =
	(2(2^(2k-l)(f^2))-((2^k)f)-(2^(k-l)*f))"
	using a aa assms minus_eq_nat_subst_order by (smt aaa diff_commute)

	show ?thesis using f1 by (metis b3 e mult_2)

	qed
	show ?thesis using f2 by simp
	qed

	have W8: "2^k((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)f)) = (2^(3k+1-l))f^2-(2^(2k-l))*f^2"

	proof-
	have a: "2^k(2^(2k-l+1)f^2-2^kf-2^(k-l)f) = 2^k(2^(2k-l+1)f^2)-2^k(2^kf)-2^k(2^(k-l)f)"
	by (simp add: algebra_simps)

	have b: "2^k(2^(2k-l+1)f^2)-2^k(2^kf)-2^k(2^(k-l)*f) =
	2^k(2^(2k-l+1)f^2)-2^k(2^kf)-2^k(2^(k-l)*f)"
	by (simp add: algebra_simps)

	have c: "2^k(2^(2k-l+1)f^2)-2^k(2^kf)-2^k(2^(k-l)*f) =
	2^(2k+1-l+k)f^2-2^k(2^kf)-2^k(2^(k-l)f)"
	apply (simp add: algebra_simps power_add)
	by (smt Groups.mult_ac(1) Groups.mult_ac(2) Nat.diff_add_assoc assms(1) le_simps(1)
	mult_2_right plus_nat.simps(2) power.simps(2))

	have d: "2^k(2^(2k-l+1)(f^2))= (2^(3k+1-l))*f^2"

	using power_add Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2
	semiring_normalization_rules(18) semiring_normalization_rules(23)
	by (smt J)

	have e: "2^k((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)*f)) =
	(2^(3k+1-l))f^2-(2^k)((2^k)f)-(2^k)(2^(k-l)f)"

	using a b c d One_nat_def one_le_mult_iff
	Nat.add_diff_assoc assms(1) less_imp_le_nat by metis

	have ee: "2^k((2^(2k-l+1)(f^2))-((2^k)f)-((2::nat)^(k-l)*f))
	= (2^(3k+1-l))f^2-( 2^k)((2^k)f)-(2^(2k-l)f)"

	using e power_add Nat.add_diff_assoc assms(1) less_imp_le_nat mult_2
	semiring_normalization_rules
	by (smt J)

	have eee :
	"-(( 2::nat)^(2k-l))(f^(2::nat)) =(-(( 2::nat)^(2k))f-(( 2::nat)^(2k-l))f)"
	using auxicalc mult_minus_eq_nat mult_minus_left of_nat_mult by smt

	have e4: "2^k((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)f))=(2^(3k+1-l))f^2-(2^(2k-l))*(f^2)"

	proof-
	define A where A: "A = 2^k((2^(2k-l+1)(f^2))-((2^k)f)-(2^(k-l)*f))"
	define B where B: "B = (2^(3k+(1::nat)-l))f^2"
	define C where C: "C = (2^k)((2^k)f)"
	define D where D: "D = (2^(2k-l)f)"
	define E where E: "E = (2^(2k-l))(f^2)"
	have wq: "A = B-C-D" using ee A B C D by simp
	have wq1: "-E = -C-D" using eee C D E
	by (simp add: semiring_normalization_rules(36))
	have wq2: "A = B-E" using wq wq1 minus_eq_nat_subst by blast
	show ?thesis using wq2 A B E
	by metis
	qed
	show ?thesis using e4 by simp
	qed

	have Y: "2^kpq+2^kr = (2^(3k+1-l))f^2-(2^(2k-l))*f^2"
	using W1 W2 W3 W4 W5 W6 W7 W8 by linarith
	show ?thesis using Y YY auxicalc by simp
	qed

	show ?thesis using Z Z1 Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff
	one_le_numeral less_imp_le_nat one_le_power
	by (metis prime_ge_1_nat)
	qed

	text\<open>Another approach by Euler \cite{garciaetal1}:\<close>

	theorem Euler_Rule_Amicable_1:
	fixes m n a :: nat
	assumes "m \<ge> 1" and "n \<ge> 1" and "a \<ge> 1"
	and "Esigma m = Esigma n" and "Esigma a * Esigma m = a*(m+n)"
	and "gcd a m =1" and "gcd a n =1"
	shows "(am) Amic (an)"

	proof-
	have a: "Esigma (am) =(Esigma a)(Esigma m)"
	using assms gcd_Esigma_mult by (simp add: mult.commute)

	have b: "Esigma (am) = Esigma (an)"

	proof-
	have c: "Esigma (an) = (Esigma a)(Esigma n)"
	using gcd_Esigma_mult \<open>gcd a n =1\<close>
	by (metis assms(4) a )
	show ?thesis using c a assms by simp
	qed

	have d: " Esigma (am) = am + a*n "
	using a assms by (simp add: add_mult_distrib2)
	show ?thesis using a b d Amicable_pair_equiv_def_conv assms by (simp add: Suc_leI)
	qed


	section\<open>Th\={a}bit ibn Qurra's Rule and more examples\<close>

	text\<open>Euler's Rule (theorem Euler\_Rule\_Amicable) is actually a generalisation of the following
	rule by Th\={a}bit ibn Qurra from the 9th century \cite{garciaetal1}. Th\={a}bit ibn Qurra's Rule is
	the special case for $l=1$ thus $f=3$.\<close>

	corollary Thabit_ibn_Qurra_Rule_Amicable:
	fixes k l f p q r :: nat
	assumes "k > 1" and "prime p" and "prime q" and "prime r"
	and "p = 2^(k-1) * 3 - 1" and "q = 2^k * 3 - 1" and "r = 2^(2k-1) 9 - 1"
	shows "((2^k)pq) Amic ((2^k)*r)"

	proof-
	obtain l where l:"l = (1::nat)" by simp
	obtain f where f:"f = (3::nat)" by simp
	have "k >l" using l assms by simp
	have "f =2^1+1" using f by simp
	have " r =(2^(2k-1))(3^2)-1" using assms by simp
	show ?thesis using assms Euler_Rule_Amicable \<open>f =2^1 +1\<close>
	\<open> r =(2^(2k -1))(3^2) -1\<close> l f
	by (metis le_numeral_extra(4))
	qed

	text\<open>In the following three example of amicable pairs, instead of evaluating the sum of the divisors
	or using the properties of Euler's sigma function as it was done in the previous examples, we
	prove amicability more directly as we can apply Th\={a}bit ibn Qurra's Rule.\<close>

	text\<open>The following is the first example of an amicable pair known to the Pythagoreans and can be
	derived from Th\={a}bit ibn Qurra's Rule with $k=2$ \cite{garciaetal1}.\<close>

	lemma Amicable_Example_Pythagoras:
	shows "220 Amic 284"

	proof-
	have a: "(2::nat)>1" by simp
	have b: "prime((3::nat)*(2^(2-1))-1)" by simp
	have c: "prime((3::nat)*(2^2)-1)" by simp
	have d: "prime((9::nat)(2^(22-1))-1)" by simp
	have e: "((2^2)(3(2^(2-1))-1)(3(2^2)-1))Amic((2^2)(9(2^(2*2-1))-1))"
	using Thabit_ibn_Qurra_Rule_Amicable a b c d
	by (metis mult.commute)

	have f: "((2::nat)^2)511 = 220" by simp
	have g: "((2::nat)^2)*71 = 284" by simp
	show ?thesis using e f g by simp
	qed

	text\<open>The following example of an amicable pair was (re)discovered by Fermat and can be derived from
	Th\={a}bit ibn Qurra's Rule with $k=4$ \cite{garciaetal1}.\<close>

	lemma Amicable_Example_Fermat:
	shows "17296 Amic 18416"

	proof-
	have a: "(4::nat)>1" by simp
	have b: "prime((3::nat)*(2^(4-1))-1)" by simp
	have c: "prime((3::nat)*(2^4)-1)" by simp
	have d: "prime (1151::nat)" by (pratt (code))
	have e: "(1151::nat) = 9(2^(24-1))-1" by simp
	have f: "prime((9::nat)(2^(24-1))-1)" using d e by metis
	have g: "((2^4)(3(2^(4-1))-1)(3(2^4)-1)) Amic((2^4)(9(2^(2*4-1))-1))"
	using Thabit_ibn_Qurra_Rule_Amicable a b c f by (metis mult.commute)
	have h: "((2::nat)^4)2347 = 17296" by simp
	have i: "(((2::nat)^4)*1151) = 18416" by simp

	show ?thesis using g h i by simp
	qed

	text\<open>The following example of an amicable pair was (re)discovered by Descartes and can be derived
	from Th\={a}bit ibn Qurra's Rule with $k=7$ \cite{garciaetal1}.\<close>

	lemma Amicable_Example_Descartes:
	shows "9363584 Amic 9437056"

	proof-
	have a: "(7::nat)>1" by simp
	have b: "prime (191::nat)" by (pratt (code))
	have c: "((3::nat)* (2^(7-1))-1) =191" by simp
	have d: "prime((3::nat)* (2^(7-1))-1)" using b c by metis
	have e: "prime (383::nat)" by (pratt (code))
	have f: "(3::nat)*(2^7)-1 = 383" by simp
	have g: "prime ((3::nat)*(2^7)-1)" using e f by metis
	have h: "prime (73727::nat)" by (pratt (code))
	have i: "(9::nat)(2^(27-1))-1 = 73727" by simp
	have j: "prime ((9::nat)(2^(27-1))-1)" using i h by metis
	have k: "((2^7)(3(2^(7-1))-1)(3(2^7)-1))Amic((2^7)(9(2^(2*7-1))-1))"
	using Thabit_ibn_Qurra_Rule_Amicable a d g j by (metis mult.commute)
	have l: "((2::nat)^7)* 191* 383 = 9363584" by simp
	have m: "(((2::nat)^7)* 73727) = 9437056" by simp

	show ?thesis using a k l by simp
	qed


	text\<open>In fact, the Amicable Pair (220, 284) is Regular and of type (2,1):\<close>

	lemma regularAmicPairExample: "regularAmicPair 220 284 \<and> typeAmic 220 284 = [2, 1]"
	proof-
	have a: "220 Amic 284" using Amicable_Example_Pythagoras by simp
	have b: "gcd (220::nat) (284::nat) = 4" by eval
	have c: "(220::nat) = 55*4" by simp
	have d: "(284::nat) = 71*4" by simp
	have e: "squarefree (55::nat)" using squarefree_def by eval
	have f: "squarefree (71::nat)" using squarefree_def by eval
	have g: "gcd (4::nat) (55::nat) =1" by eval
	have h: "gcd (4::nat) (71::nat) =1" by eval

	have A: "regularAmicPair 220 284"
	by (simp add: a b e g f h gcd.commute regularAmicPair_def)
	have B: "(card {i.\<exists> N. ( 220::nat) = N*(4::nat) \<and> prime i \<and> i dvd N \<and> \<not> i dvd 4}) = 2"

	proof-
	obtain N::nat where N: "(220::nat) = N* 4"
	by (metis c)
	have NN:"N=55" using N by simp
	have K1: "prime(5::nat)" by simp
	have K2: "prime(11::nat)" by simp
	have KK2: " \<not> prime (55::nat)" by simp
	have KK3: " \<not> prime (1::nat)" by simp
	have K: "set(divisors_nat 55 ) = {1, 5, 11, 55}" by eval
	have KK: "{i. i dvd (55::nat)} = {1, 5, 11, 55}"
	using K divisors_nat divisors_nat_def by auto
	have K3 : "\<not> (5::nat) dvd 4" by simp
	have K4 : "\<not> (11::nat) dvd 4" by simp
	have K55: "(1::nat) \<notin> {i. prime i \<and> i dvd 55}" using KK3 by simp
	have K56: "(55::nat) \<notin> {i. prime i \<and> i dvd 55}" using KK2 by simp
	have K57: "(5::nat) \<in> {i. prime i \<and> i dvd 55}" using K1 by simp
	have K58: "(11::nat) \<in> {i. prime i \<and> i dvd 55}" using K2 by simp
	have K5: "{i.( prime i \<and> i dvd (55::nat) \<and> \<not> i dvd 4)} = {5, 11}"

	proof-
	have K66: "{i.(prime i \<and> i dvd (55::nat) \<and> \<not> i dvd 4)}=
	{i. prime i} \<inter> {i. i dvd 55} \<inter> { i. \<not> i dvd 4}"
	by blast
	show ?thesis using K66 K K1 K2 KK2 KK3 K3 K4 KK K55 K56 K57 K58 divisors_nat_def
	divisors_nat by auto (slow)
	qed
	have K6: "card ({(5::nat), (11::nat)}) = 2" by simp
	show ?thesis using K5 K6 by simp
	qed

	have C: "(card {i. \<exists>N. (284::nat) = N*4 \<and> prime i \<and> i dvd N \<and> \<not> i dvd 4} ) = 1"
	proof-
	obtain N::nat where N: "284 = N*4"
	by (metis d)
	have NN: "N= 71" using N by simp
	have K: "set(divisors_nat 71 ) = {1, 71 }" by eval
	have KK: "{i. i dvd (71::nat)} = {1, 71}"
	using K divisors_nat divisors_nat_def by auto

	have K55:"(1::nat) \<notin> {i. prime i \<and> i dvd 71}" by simp
	have K58: "(71::nat) \<in> {i. prime i \<and> i dvd 71}" by simp
	have K5: "{i. prime i \<and> i dvd 71 \<and> \<not> i dvd 4} = {(71::nat)}"
	proof-
	have K66: "{i. prime i \<and> i dvd 71 \<and> \<not> i dvd 4}=
	{i. prime i} \<inter> {i. i dvd 71} \<inter> { i. \<not> i dvd 4}"
	by blast
	show ?thesis using K KK K55 K58
	by (auto simp add: divisors_nat_def K66 divisors_nat)
	qed
	have K6: "card ({(71::nat)}) = 1" by simp
	show ?thesis using K5 K6 by simp
	qed

	show ?thesis using A B C
	by (simp add: typeAmic_def b)
	qed

	lemma abundant220ex: "abundant_number 220"
	proof-
	have "220 Amic 284" using Amicable_Example_Pythagoras by simp
	moreover have "(220::nat) < 284" by simp
	ultimately show ?thesis using Amicable_pair_abundant Amicable_pair_sym
	by blast
	qed

	lemma deficient284ex: "deficient_number 284"
	proof-
	have "220 Amic 284" using Amicable_Example_Pythagoras by simp
	moreover have "(220::nat) < 284" by simp
	ultimately show ?thesis using Amicable_pair_deficient Amicable_pair_sym
	by blast
	qed


	section\<open>Te Riele's Rule and Borho's Rule with breeders\<close>

	text\<open>With the following rule \cite{garciaetal1} we can get an amicable pair from a known amicable
	pair under certain conditions.\<close>

	theorem teRiele_Rule_Amicable:
	fixes a u p r c q :: nat
	assumes "a \<ge> 1" and "u \<ge> 1"
	and "prime p" and "prime r" and "prime c" and "prime q" and "r \<noteq> c"
	and "\<not>(p dvd a)" and "(au) Amic (ap)" and "gcd a (r*c)=1"
	and "q = r+c+u" and "gcd (au) q =1" and "rc = p*(r +c+ u) + p+u"
	shows "(auq) Amic (arc)"

	proof-
	have "p+1 >0" using assms by simp
	have Z1: " rc = pq+p+u" using assms by auto
	have Z2: "(r+1)(c+1) = (q+1)(p+1)"
	proof-
	have y: "(q+1)(p+1) = qp + q+ p+1 " by simp
	have yy: "(r+1)(c+1) = rc + r+ c+1" by simp
	show ?thesis using assms y Z1 yy by simp
	qed

	have "Esigma(a) = (a*(u+p)/(p+1))"
	proof-
	have d: "Esigma (ap) = (Esigma a)(Esigma p)"
	using assms gcd_Esigma_mult \<open>prime p\<close> \<open>\<not> (p dvd a)\<close>
	by (metis gcd_unique_nat prime_nat_iff)
	have dd : "Esigma (ap) =(Esigma a)(p+1)"
	using d assms prime_sum_div by simp
	have ddd: "Esigma (ap) = a(u+p)" using assms Amicable_pair_def
	Amicable_pair_equiv_def
	by (smt One_nat_def add_mult_distrib2 one_le_mult_iff prime_ge_1_nat)

	show ?thesis using d dd ddd Esigmanotzero assms(3) dvd_triv_right
	nonzero_mult_div_cancel_right prime_nat_iff prime_sum_div real_of_nat_div
	by (metis \<open>0 < p + 1\<close> neq0_conv)
	qed

	have "Esigma(r) = (r+1)" using assms prime_sum_div by blast
	have "Esigma(c) = (c+1)" using assms prime_sum_div by blast
	have "Esigma (arc) = (Esigma a)(Esigma r)(Esigma c)"
	proof-
	have h: "Esigma (arc) = (Esigma a)(Esigma (rc))"
	using assms gcd_Esigma_mult
	by (metis mult.assoc mult.commute)
	have hh: " Esigma (rc) = (Esigma r)(Esigma c)" using assms prime_Esigma_mult
	by (metis semiring_normalization_rules(7))

	show ?thesis using h hh by auto
	qed

	have A: "Esigma (auq) = Esigma (arc)"
	proof-
	have wk: "Esigma (auq) = Esigma (au)(q+1)"
	using assms gcd_Esigma_mult by (simp add: prime_sum_div)
	have wk1: "Esigma (au) = a(u+p)" using assms Amicable_pair_equiv_def
	by (smt One_nat_def add_mult_distrib2 one_le_mult_iff prime_ge_1_nat)

	have w3: "Esigma (auq) = a(u+p)(q+1)" using wk wk1 by simp
	have w4: "Esigma (arc) =(Esigma a)(r+1) (c+1)" using assms
	by (simp add: \<open>Esigma (arc) = Esigma a * Esigma r * Esigma c\<close> \<open>Esigma c = c + 1\<close>
	\<open>Esigma r = r+1\<close>)

	have we: "a(u+p)(q+1) = (Esigma a)(r+1)(c+1)"
	proof-
	have we1: "(Esigma a)(r+1)(c+1) = (a(u+p)/(p+1))(r+1)*(c+1)"
	by (metis \<open>real (Esigma a) = real (a*(u+p))/real(p+1)\<close> of_nat_mult)
	have we12: " (Esigma a)(r+1)(c+1) = (a(u+p)/(p+1))(q+1)*(p+1)" using we1 Z2
	by (metis of_nat_mult semiring_normalization_rules(18))
	show ?thesis using we12 assms
	by (smt nonzero_mult_div_cancel_right of_nat_1 of_nat_add of_nat_eq_iff of_nat_le_iff
	of_nat_mult prime_ge_1_nat times_divide_eq_left)
	qed

	show ?thesis using we w3 w4 by simp
	qed

	have B : "Esigma (arc) = (auq)+(arc)"
	proof-
	have a1: "(u+p)(q+1) = (uq+p*q+p+u)" using assms add_mult_distrib by auto
	have a2: "(u+p)(q+1)(p+1) = (uq+pq+p+u)*(p+1)" using a1 assms by metis
	have a3: "(u+p)(r+1)(c+1) = (uq+pq+p+u)*(p+1)" using assms a2 Z2
	by (metis semiring_normalization_rules(18))
	have a4: "a(u+p) (r+1)(c+1) = a(uq+ pq+p+u)*(p+1)" using assms a3
	by (metis semiring_normalization_rules(18))
	have a5: "a(u+p)(r+1)(c+1) = a(uq+rc)*(p+1)" using assms a4 Z1
	by (simp add: semiring_normalization_rules(21))
	have a6: "(a(u+p)(r+1)(c+1))/(p+1) =(a(uq+ rc)* (p+1))/(p+1)" using assms a5
	semiring_normalization_rules(21) \<open>p+1 >0\<close> by auto
	have a7: "(a(u+p)(r+1)(c+1))/(p+1) =(a(uq+ rc))" using assms a6 \<open>p+1 >0\<close>
	by (metis neq0_conv nonzero_mult_div_cancel_right of_nat_eq_0_iff of_nat_mult)
	have a8:"(a(u+p)/(p+1))(r+1)(c+1) = a(uq+rc)" using assms a7 \<open>p+1 >0\<close>
	by (metis of_nat_mult times_divide_eq_left)
	have a9: "(Esigma a)* Esigma(r)* Esigma(c) = a(uq+ r*c)" using a8 assms
	\<open> Esigma(r) = (r+1)\<close> \<open> Esigma(c) = (c+1)\<close>
	by (metis \<open>real (Esigma a) = real (a*(u + p))/real(p + 1)\<close> of_nat_eq_iff of_nat_mult)
	have a10: " Esigma(arc) = a(uq+ r*c)" using a9 assms
	\<open>Esigma (arc) = (Esigma a)(Esigma r)(Esigma c)\<close> by simp

	show ?thesis using a10 assms
	by (simp add: add_mult_distrib2 mult.assoc)
	qed

	show ?thesis using A B Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff
	by (smt prime_ge_1_nat)
	qed

	text \<open>By replacing the assumption that \<open>(au) Amic (ap)\<close> in the above rule by te Riele with the
	assumption that \<open>(a*u) breeder u\<close>, we obtain Borho's Rule with breeders \cite{garciaetal1}.\<close>

	theorem Borho_Rule_breeders_Amicable:
	fixes a u r c q x :: nat
	assumes "x \<ge> 1" and "a \<ge> 1" and "u \<ge> 1"
	and "prime r" and "prime c" and "prime q" and "r \<noteq> c"
	and "Esigma (au) = au + ax" "Esigma (au) = (Esigma a)(x+1)" and "gcd a (r c) =1"
	and "gcd (au) q = 1" and "r c = x+u + xu +rx +x*c" and "q = r+c+u"
	shows "(auq) Amic (arc)"

	proof-
	have a: "Esigma(auq) = Esigma(au)Esigma(q)"
	using assms gcd_Esigma_mult by simp
	have a1: "Esigma(arc) = (Esigma a)Esigma(rc)"
	using assms gcd_Esigma_mult by (metis mult.assoc mult.commute)
	have a2: "Esigma(arc) = (Esigma a)(r+1)(c+1)"
	using a1 assms
	by (metis mult.commute mult.left_commute prime_Esigma_mult prime_sum_div)

	have A: "Esigma (auq) = Esigma(arc)"
	proof-
	have d: "Esigma(a)(r+1)(c+1) = Esigma(au)(q+1)"
	proof-
	have d1: "(r+1)(c+1) =(x+1)(q+1)"
	proof-
	have ce: "(r+1)(c+1) = rc+r+c+1" by simp
	have ce1: "(r+1)(c+1) = x+u+xu+rx+xc+r+c+1"
	using ce assms by simp
	have de: "(x+1)(q+1) = xq +1+x+q" by simp
	have de1: "(x+1)(q+1) = x(r+c+u)+1+x+ r+c+u"
	using assms de by simp
	show ?thesis using de1 ce1 add_mult_distrib2 by auto
	qed

	show ?thesis using d1 assms
	by (metis semiring_normalization_rules(18))
	qed

	show ?thesis using d a2
	by (simp add: a assms(6) prime_sum_div)
	qed

	have B: "Esigma (auq) = auq + arc"
	proof-
	have i: "Esigma (auq) = Esigma(au)(q+1)"
	using a assms
	by (simp add: prime_sum_div)

	have ii:"Esigma (auq) = (au+ ax)*(q+1)"
	using assms i by auto

	have iii:"Esigma (auq) = auq +au+ axq+ ax"
	using assms ii add_mult_distrib by simp
	show ?thesis using iii assms
	by (smt distrib_left semiring_normalization_rules)
	qed

	show ?thesis using A B assms Amicable_pair_equiv_def_conv assms One_nat_def one_le_mult_iff
	by (smt prime_ge_1_nat)
	qed

	no_notation divisor (infixr "divisor" 80)


	section\<open>Acknowledgements\<close>

	text
	\<open>The author was supported by the ERC Advanced Grant ALEXANDRIA (Project 742178) funded by the
	European Research Council and led by Professor Lawrence Paulson at the University of Cambridge, UK.
	Many thanks to Lawrence Paulson for his help and suggestions. Number divisors were initially looked
	up on \<^url>\<open>https://onlinemathtools.com/find-all-divisors\<close>.\<close>

	end
	diff --git a/thys/Collections/Examples/Autoref/Simple_DFS.thy b/thys/Collections/Examples/Autoref/Simple_DFS.thy
	--- a/thys/Collections/Examples/Autoref/Simple_DFS.thy
	+++ b/thys/Collections/Examples/Autoref/Simple_DFS.thy
	@@ -1,492 +1,492 @@
	section \<open>\isaheader{Simple DFS Algorithm}\<close>
	theory Simple_DFS
	imports
	Collections.Refine_Dflt
	begin



	section \<open>Graphs Implemented by Successor Function\<close>
	subsection \<open>Refinement relation\<close>
	definition "E_of_succ succ \<equiv> {(u,v). v\<in>succ u}"
	definition [to_relAPP]: "succg_rel R \<equiv> (R \<rightarrow> \<langle>R\<rangle>list_set_rel) O br E_of_succ (\<lambda>_. True)"


	consts i_graph :: "interface \<Rightarrow> interface"
	\<comment> \<open>Define the conceptual type of graphs.\<close>

	lemmas [autoref_rel_intf] = REL_INTFI[of "succg_rel" i_graph]
	\<comment> \<open>Declare \<open>succg_rel\<close> to be a relator for graphs.\<close>


	lemma in_id_succg_rel_iff: "(s,E)\<in>\<langle>Id\<rangle>succg_rel \<longleftrightarrow> (\<forall>v. distinct (s v) \<and> set (s v) = E``{v})"
	\<comment> \<open>Simplification in case of identity refinements for nodes\<close>
	unfolding succg_rel_def br_def E_of_succ_def list_set_rel_def
	by (auto; force dest: fun_relD)


	subsection \<open>Successor Operation\<close>
	definition [simp]: "op_succ E u \<equiv> E``{u}"
	\<comment> \<open>Define the abstract successor operation.\<close>

	context begin interpretation autoref_syn .
	lemma [autoref_op_pat]: "E``{v} \<equiv> op_succ$E$v" by simp
	\<comment> \<open>Declare a rewrite rule to operation identification.\<close>
	end

	lemma refine_succg_succs[autoref_rules]:
	"(\<lambda>succs v. succs v,op_succ)\<in>\<langle>R\<rangle>succg_rel\<rightarrow>R\<rightarrow>\<langle>R\<rangle>list_set_rel"
	\<comment> \<open>Declare implementation of successor function to Autoref.\<close>
	apply (intro fun_relI)
	apply (auto simp add: succg_rel_def br_def E_of_succ_def dest: fun_relD)
	done

	section \<open>DFS Algorithm\<close>
	text \<open>
	We define a simple DFS-algorithm, prove a simple correctness
	property, and do data refinement to an efficient implementation.
	\<close>

	subsection \<open>Definition\<close>

	text \<open>Recursive DFS-Algorithm.
	\<open>E\<close> is the edge relation of the graph, \<open>tgt\<close> the node to
	search for, and \<open>src\<close> the start node.
	Already explored nodes are
	stored in \<open>V\<close>.\<close>

	context
	fixes E :: "('v\<times>'v) set" and src :: 'v and tgt :: 'v
	begin
	definition dfs :: "bool nres" where
	"dfs \<equiv> do {
	(_,r) \<leftarrow> RECT (\<lambda>dfs (V,v).
	if v=tgt then RETURN (V,True)
	else do {
	let V = insert v V;
	FOREACHc (E``{v}) (\<lambda>(V,brk). \<not>brk) (\<lambda>v' (V,brk).
	if v'\<notin>V then dfs (V,v') else RETURN (V,False)
	) (V,False)
	}) ({},src);
	RETURN r
	}"

	definition "reachable \<equiv> {v. (src,v)\<in>E\<^sup>*}"

	subsection \<open>Correctness Proof\<close>
	lemma dfs_correct:
	assumes FIN: "finite (E\<^sup>*``{src})"
	shows "dfs \<le> SPEC (\<lambda>r. r \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*)"
	proof -
	from FIN have [simp, intro!]: "finite reachable"
	unfolding reachable_def by (auto simp: Image_def)

	text \<open>We first define the (inductive) pre and postconditions for
	the recursion, and the loop invariant\<close>

	define rpre where "rpre \<equiv> \<lambda>S (V,v).
	v\<in>reachable - V
	\<and> V\<subseteq>reachable
	\<and> S\<subseteq>V
	\<and> tgt\<notin>V
	\<and> E``(V-S) \<subseteq> V"

	define rpost where "rpost \<equiv> \<lambda>S (V,v) (V',r).
	(r\<longrightarrow>tgt\<in>reachable)
	\<and> (\<not>r \<longrightarrow>
	tgt\<notin>V'
	\<and> V\<subseteq>V'
	\<and> v\<in>V'
	\<and> V'\<subseteq>reachable
	\<and> E``(V'-S) \<subseteq> V'
	)
	"

	define fe_inv where "fe_inv \<equiv> \<lambda>S V v it (V',r).
	(r\<longrightarrow>tgt\<in>reachable)
	\<and> (\<not>r \<longrightarrow>
	tgt \<notin> V'
	\<and> insert v V\<subseteq>V'
	\<and> E``{v} - it \<subseteq> V'
	\<and> V'\<subseteq>reachable
	\<and> S\<subseteq>insert v V
	\<and> E``(V'-S) \<subseteq> V' \<union> it
	\<and> E``(V'-insert v S) \<subseteq> V'
	)"

	text \<open>Then we prove the verification conditions that our VCG will generate as separate facts.
	Of course, the workflow is to first let run the VCG, and then extract these facts from
	its output. This way, we can make explicit the ideas of the proof, and present them separately
	from the mainly technical VC generation.
	\<close>

	have vc_pre_initial: "rpre {} ({}, src)"
	by (auto simp: rpre_def reachable_def)

	{
	(* Case: Found node *)
	fix S V
	assume "rpre S (V,tgt)"
	hence "rpost S (V,tgt) (insert tgt V, True)"
	unfolding rpre_def rpost_def
	by auto
	} note vc_node_found = this

	{ (* The set of nodes that the foreach loop iterates over is finite *)
	fix S V v
	assume "rpre S (V, v)"
	hence "finite (E``{v})"
	unfolding rpre_def reachable_def
	using FIN
	apply auto
	by (meson finite_Image_subset finite_reachable_advance r_le_rtrancl)
	} note vc_foreach_finite = this

	{
	(* fe_inv initial *)
	fix S V v
	assume A: "v \<notin> V" "v \<noteq> tgt"
	and PRE: "rpre S (V, v)"
	hence "fe_inv S V v (E``{v}) (insert v V, False)"
	- unfolding fe_inv_def rpre_def by (auto simp: )
	+ unfolding fe_inv_def rpre_def by auto
	} note vc_enter_foreach = this

	{
	(* fe_inv ensures rpre *)
	fix S V v v' it V'
	assume A: "v'\<notin>V'" "v' \<in> it" "it \<subseteq> E``{v}"
	and FEI: "fe_inv S V v it (V', False)"
	and PRE: "rpre S (V, v)"

	from A have "(v,v')\<in>E" by auto
	moreover from PRE have "v \<in> reachable" by (auto simp: rpre_def)
	hence "E``{v} \<subseteq> reachable" by (auto simp: reachable_def)
	ultimately have [simp]: "v'\<in>reachable" by blast

	from A FEI PRE have "rpre (insert v S) (V', v')"
	unfolding rpre_def fe_inv_def by auto
	} note vc_rec_pre = this

	{
	(* rpost implies fe_inv *)
	fix S V V' v v' it Vr''
	assume "fe_inv S V v it (V', False)"
	and "rpost (insert v S) (V', v') Vr''"
	hence "fe_inv S V v (it - {v'}) Vr''"
	unfolding rpre_def rpost_def fe_inv_def by clarsimp (auto; blast)
	} note vc_iterate_foreach = this

	{ (* Recursive call in variant relation *)
	fix S V V' v it
	assume "rpre S (V, v)"
	and "fe_inv S V v it (V', False)"
	hence "(V',V)\<in>finite_psupset local.reachable"
	unfolding fe_inv_def rpre_def
	by (auto simp: finite_psupset_def)

	} note vc_rec_var = this

	{
	(* fe_inv preserved if ignoring visitied node*)
	fix S V V' v v' it Vr''
	assume "fe_inv S V v it (V', False)"
	and "v'\<in>V'"
	hence "fe_inv S V v (it - {v'}) (V', False)"
	unfolding fe_inv_def by auto
	} note vc_foreach_ignore = this


	{
	(* fe_inv (completed) implies rpost *)
	fix S V v V'
	assume FEI: "fe_inv S V v {} (V', False)"
	have "rpost S (V, v) (V', False)"
	unfolding rpost_def
	using FEI by (auto simp: fe_inv_def) []
	} note vc_foreach_completed_imp_post = this

	{
	(* fe_inv (interrupted) implies rpost *)
	fix S V v V' it
	assume FEI: "fe_inv S V v it (V', True)"
	hence "rpost S (V, v) (V', True)"
	by (auto simp add: rpost_def fe_inv_def) []
	} note vc_foreach_interrupted_imp_post = this

	{ (* The postcondition of the recursion implies our desired specification *)
	fix V r
	assume "rpost {} ({}, src) (V, r)"
	hence "r = ((src, tgt) \<in> E\<^sup>*)"
	by (auto
	simp: rpost_def reachable_def
	dest: Image_closed_trancl
	intro: rev_ImageI)
	} note vc_rpost_imp_spec = this

	text \<open>The verification condition generation is technical. We invoke the VCG,
	and discharge the generated VCs. The trivial ones are discharged on the spot, the
	more complicated ones have been extracted to separate facts, that we use in the proof
	text below.
	\<close>
	show ?thesis
	unfolding dfs_def
	apply (refine_vcg RECT_rule_arb[
	where
	pre=rpre and arb="{}"
	and M="\<lambda>a x. SPEC (rpost a x)"
	and V="inv_image (finite_psupset reachable) fst",
	THEN order_trans
	])
	subgoal by blast (* Well-Foundedness *)
	subgoal by (rule vc_pre_initial)
	subgoal by (auto simp add: rpre_def rpost_def) (* Found tgt node *)

	subgoal for f S _ V v (* Entering inner FOREACH loop *)
	apply (refine_rcg refine_vcg
	FOREACHc_rule'[where I="fe_inv S V v" (for S V)]
	)
	apply clarsimp_all

	subgoal by (simp add: vc_foreach_finite) (* Finiteness of iteration set *)

	subgoal by (rule vc_enter_foreach) (simp add: rpre_def) (* Loop invar holds initially*)
	subgoal (* Loop invar preserved by inner recursion *)
	apply (rule order_trans, rprems) (* Applying recursion induction hypothesis *)
	apply (erule (4) vc_rec_pre; fail) (* Precondition of inner recursion holds*)
	apply (simp add: vc_rec_var; fail) (* Parameters are smaller wrt termination ordering *)
	apply (auto simp: vc_iterate_foreach; fail) (* Postcondition of inner rec implies loop invar again *)
	done

	subgoal by (rule vc_foreach_ignore; auto) (* Node already visited: invariant is preserved *)
	subgoal by (auto simp: vc_foreach_completed_imp_post) (* Foreach loop terminated normally: Implies postcondition *)
	subgoal by (auto simp: vc_foreach_interrupted_imp_post) (* Foreach loop interrupted (tgt found): Implies postcondition *)
	done
	subgoal by (auto simp add: vc_rpost_imp_spec) (* Postcondition implies our specification *)
	done
	qed

	end


	subsection \<open>Data Refinement and Determinization\<close>

	text \<open>
	Next, we use automatic data refinement and transfer to generate an
	executable algorithm. We fix the node-type to natural numbers,
	and the successor-function to return a list-set.
	The implementation of the visited set is left open, and Autoref's heuristics
	will choose one (default for nat set: red-black-trees).
	\<close>

	text \<open>In our first example, we use \<open>autoref_monadic\<close>, which combines the
	Autoref tool and the determinization of the Monadic Refinement Framework.\<close>

	schematic_goal dfs_impl_refine_aux:
	fixes succi and E :: "('a::linorder \<times> 'a) set" and tgt src :: 'a
	assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
	notes [autoref_rules] = IdI[of src] IdI[of tgt]
	shows "RETURN (?f::?'c) \<le> \<Down>?R (dfs E src tgt)"
	unfolding dfs_def by autoref_monadic

	text \<open>We define a new constant from the synthesis result\<close>
	concrete_definition dfs_impl for succi src tgt uses dfs_impl_refine_aux
	text \<open>Set up code equations for the recursion combinators\<close>
	prepare_code_thms dfs_impl_def
	text \<open>And export the algorithm to all supported target languages\<close>
	export_code dfs_impl in Haskell
	export_code dfs_impl checking SML OCaml? Haskell? Scala


	text \<open>Chaining the refinement theorems, we get correctness arguments that
	are almost independent of the refinement framework:\<close>

	lemma succ_ran_fin:
	assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
	assumes "v\<in>Range Rv"
	shows "finite (E``{v})"
	using assms
	unfolding succg_rel_def br_def E_of_succ_def
	apply clarsimp
	apply (drule (1) fun_relD)
	using list_set_rel_range[of Rv]
	by auto

	lemma run_ran_aux:
	assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
	assumes REACH: "(src,v)\<in>E\<^sup>*"
	assumes R0: "(v0i,src) \<in> Rv"
	shows "v \<in> Range Rv"
	using REACH R0
	proof (induction arbitrary: v0i rule: converse_rtrancl_induct)
	case base thus ?case by auto
	next
	case (step src v')
	from \<open>(src, v') \<in> E\<close> have "v' \<in> Range Rv" using R list_set_rel_range[of Rv]
	apply (clarsimp simp: succg_rel_def br_def E_of_succ_def)
	apply (drule fun_relD[OF _ \<open>(v0i, src) \<in> Rv\<close>])
	by auto
	with step.IH show ?thesis by blast
	qed

	lemma run_ran_fin:
	assumes R: "(succi,E) \<in> \<langle>Rv\<rangle>succg_rel"
	assumes R0: "(v0i,src) \<in> Rv"
	shows "\<forall>v. (src,v)\<in>E\<^sup>* \<longrightarrow> finite (E``{v})"
	using succ_ran_fin run_ran_aux assms by metis

	text \<open>Correctness theorem presented in the paper:\<close>
	theorem dfs_code_correct:
	assumes SUCCI: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
	assumes FIN: "finite (E\<^sup>*``{src})"
	shows "dfs_impl succi src tgt \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
	proof -
	note dfs_impl.refine[OF SUCCI, of src tgt]
	also note dfs_correct[OF FIN]
	finally show ?thesis by (auto simp: split: dres.split)
	qed

	subsubsection \<open>Using only Autoref\<close>

	text \<open>Here we show the result of Autoref, without the determinization phase of
	the Monadic Refinement Framework: \<close>
	schematic_goal
	fixes succi and E :: "('a::linorder \<times> 'a) set" and tgt src :: 'a
	assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
	notes [autoref_rules] = IdI[of src] IdI[of tgt]
	shows "(?f::?'c, dfs E src tgt) \<in> ?R"
	unfolding dfs_def[abs_def]
	apply (autoref (trace))
	done

	subsubsection \<open>Choosing Different Implementations\<close>
	text \<open>Ad-hoc override of implementation selection heuristics: Using hashset for the visited set\<close>
	schematic_goal dfs_impl_refine_aux2:
	fixes succi and E :: "(('a::hashable) \<times> 'a) set" and tgt src :: 'a
	assumes [autoref_rules]: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
	notes [autoref_rules] = IdI[of src] IdI[of tgt]
	notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Id\<rangle>dflt_ahs_rel"]
	shows "(?f::?'c, dfs E src tgt) \<in> ?R"
	unfolding dfs_def[abs_def]
	apply autoref_monadic
	done


	text \<open>We can also leave the type of the nodes and its implementation
	unspecified. However, we need a comparison operator on nodes\<close>

	(* With linorder typeclass on abstract type *)
	schematic_goal dfs_impl_refine_aux3:
	fixes succi and E :: "('a::linorder \<times> 'a) set"
	and Rv :: "('ai\<times>'a) set"
	assumes [autoref_rules_raw]: "(cmpk, dflt_cmp (\<le>) (<))\<in>(Rv\<rightarrow>Rv\<rightarrow>Id)"
	notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Rv\<rangle>dflt_rs_rel"]
	assumes P_REF[autoref_rules]:
	"(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
	"(vdi,tgt::'a)\<in>Rv"
	"(v0i,src)\<in>Rv"
	shows "(RETURN (?f::?'c), dfs E src tgt)\<in>?R"
	unfolding dfs_def[abs_def]
	by autoref_monadic

	(* With arbitrary cmpk' operator on abstract type, not forcing a linorder typeclass instance.
	Useful if there are multiple possible instantiations of a typeclass (eg for product ordering),
	and one does not want to commit to one.
	*)
	schematic_goal dfs_impl_refine_aux3':
	fixes succi and E :: "('a \<times> 'a) set"
	and Rv :: "('ai\<times>'a) set"
	assumes [autoref_ga_rules]: "eq_linorder cmpk'"
	assumes [autoref_rules_raw]: "(cmpk, cmpk')\<in>(Rv\<rightarrow>Rv\<rightarrow>comp_res_rel)"
	notes [autoref_tyrel] = ty_REL[where 'a="'a set" and R="\<langle>Rv\<rangle>map2set_rel (rbt_map_rel (comp2lt cmpk'))"]
	assumes P_REF[autoref_rules]:
	"(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
	"(vdi,tgt::'a)\<in>Rv"
	"(v0i,src)\<in>Rv"
	shows "(RETURN (?f::?'c), dfs E src tgt)\<in>?R"
	unfolding dfs_def[abs_def]
	by autoref_monadic


	text \<open>We also generate code for the alternative implementations\<close>
	concrete_definition dfs_impl2 for succi src tgt uses dfs_impl_refine_aux2
	concrete_definition dfs_impl3 for cmpk succi v0i vdi uses dfs_impl_refine_aux3
	concrete_definition dfs_impl3' for cmpk succi v0i vdi uses dfs_impl_refine_aux3'

	prepare_code_thms dfs_impl2_def
	prepare_code_thms dfs_impl3_def
	prepare_code_thms dfs_impl3'_def

	export_code dfs_impl dfs_impl2 dfs_impl3 dfs_impl3' checking SML OCaml? Haskell? Scala

	text \<open>And we prove the alternative implementations correct \<close>

	theorem dfs_code2_correct:
	assumes SUCCI: "(succi,E)\<in>\<langle>Id\<rangle>succg_rel"
	assumes FIN: "finite (E\<^sup>*``{src})"
	shows "dfs_impl2 succi src tgt \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
	proof -
	note dfs_impl2.refine[OF SUCCI, of src tgt, THEN nres_relD]
	also note dfs_correct[OF FIN]
	finally show ?thesis by (auto simp: split: dres.split)
	qed

	theorem dfs_code3_correct:
	fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
	and Rv :: "('ai\<times>'a) set"
	assumes V0: "(v0i,src)\<in>Rv"
	assumes VD: "(vdi,tgt)\<in>Rv"
	assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
	assumes CMP: "(cmpk, dflt_cmp (\<le>) (<))\<in>(Rv\<rightarrow>Rv\<rightarrow>Id)"
	assumes FIN: "finite (E\<^sup>*``{src})"
	shows "dfs_impl3 cmpk succi v0i vdi \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
	proof -
	note dfs_impl3.refine[OF CMP SUCCI VD V0, THEN nres_relD]
	also note dfs_correct[OF FIN]
	finally show ?thesis by (auto simp: split: dres.split)
	qed

	theorem dfs_code3'_correct:
	fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
	and Rv :: "('ai\<times>'a) set"
	assumes V0: "(v0i,src)\<in>Rv"
	assumes VD: "(vdi,tgt)\<in>Rv"
	assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
	assumes CGA: "eq_linorder cmpk'"
	assumes CMP: "(cmpk, cmpk') \<in> Rv\<rightarrow>Rv\<rightarrow>comp_res_rel"
	assumes FIN: "finite (E\<^sup>*``{src})"
	shows "dfs_impl3' cmpk succi v0i vdi \<longleftrightarrow> (src,tgt)\<in>E\<^sup>*"
	proof -
	note dfs_impl3'.refine[OF CGA CMP SUCCI VD V0, THEN nres_relD]
	also note dfs_correct[OF FIN]
	finally show ?thesis by (auto simp: split: dres.split)
	qed


	(* Reachability *)

	definition [simp]: "op_reachable E u v \<equiv> (u,v)\<in>E\<^sup>*"
	context begin interpretation autoref_syn .
	lemma [autoref_op_pat]: "(u,v)\<in>E\<^sup>* \<equiv> op_reachable$E$u$v" by simp


	(* We use a quite general setup here, working with any linearly ordered
	abstract node type, refined by any relation. *)
	theorem dfs_code3_correct_rl[autoref_rules]:
	fixes succi and succ :: "'a::linorder \<Rightarrow> 'a set"
	and Rv :: "('ai\<times>'a) set"
	assumes V0: "(v0i,src)\<in>Rv"
	assumes VD: "(vdi,tgt)\<in>Rv"
	assumes SUCCI: "(succi,E)\<in>\<langle>Rv\<rangle>succg_rel"
	assumes CGA: "SIDE_GEN_ALGO (eq_linorder cmpk')"
	assumes CMP: "GEN_OP cmpk cmpk' (Rv\<rightarrow>Rv\<rightarrow>comp_res_rel)"
	assumes FIN: "SIDE_PRECOND (finite (E\<^sup>*``{src}))"
	shows "(dfs_impl3' cmpk succi v0i vdi,
	(OP op_reachable ::: \<langle>Rv\<rangle>succg_rel \<rightarrow> Rv \<rightarrow> Rv \<rightarrow> bool_rel)$E$src$tgt)
	\<in> bool_rel"
	using dfs_code3'_correct[OF V0 VD SUCCI, of cmpk' cmpk] CGA CMP FIN
	unfolding autoref_tag_defs by simp

	end


	end
	diff --git a/thys/Complex_Bounded_Operators/Cblinfun_Code.thy b/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
	--- a/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
	+++ b/thys/Complex_Bounded_Operators/Cblinfun_Code.thy
	@@ -1,661 +1,661 @@
	section \<open>\<open>Cblinfun_Code\<close> -- Support for code generation\<close>

	text \<open>This theory provides support for code generation involving on complex vector spaces and
	bounded operators (e.g., types \<open>cblinfun\<close> and \<open>ell2\<close>).
	To fully support code generation, in addition to importing this theory,
	one need to activate support for code generation (import theory \<open>Jordan_Normal_Form.Matrix_Impl\<close>)
	and for real and complex numbers (import theory \<open>Real_Impl.Real_Impl\<close> for support of reals of the
	form \<open>a + b * sqrt c\<close> or \<open>Algebraic_Numbers.Real_Factorization\<close> (much slower) for support of algebraic reals;
	support of complex numbers comes "for free").

	The builtin support for real and complex numbers (in \<open>Complex_Main\<close>) is not sufficient because it
	does not support the computation of square-roots which are used in the setup below.

	It is also recommended to import \<open>HOL-Library.Code_Target_Numeral\<close> for faster support of nats
	and integers.\<close>

	theory Cblinfun_Code
	imports
	Cblinfun_Matrix Containers.Set_Impl Jordan_Normal_Form.Matrix_Kernel
	begin

	no_notation "Lattice.meet" (infixl "\<sqinter>\<index>" 70)
	no_notation "Lattice.join" (infixl "\<squnion>\<index>" 65)
	hide_const (open) Coset.kernel
	hide_const (open) Matrix_Kernel.kernel
	hide_const (open) Order.bottom Order.top

	unbundle lattice_syntax
	unbundle jnf_notation
	unbundle cblinfun_notation



	subsection \<open>Code equations for cblinfun operators\<close>

	text \<open>In this subsection, we define the code for all operations involving only
	operators (no combinations of operators/vectors/subspaces)\<close>


	text \<open>The following lemma registers cblinfun as an abstract datatype with
	constructor \<^const>\<open>cblinfun_of_mat\<close>.
	That means that in generated code, all cblinfun operators will be represented
	as \<^term>\<open>cblinfun_of_mat X\<close> where X is a matrix.
	In code equations for operations involving operators (e.g., +), we
	can then write the equation directly in terms of matrices
	by writing, e.g., \<^term>\<open>mat_of_cblinfun (A+B)\<close> in the lhs,
	and in the rhs we define the matrix that corresponds to the sum of A,B.
	In the rhs, we can access the matrices corresponding to A,B by
	writing \<^term>\<open>mat_of_cblinfun B\<close>.
	(See, e.g., lemma \<open>cblinfun_of_mat_plusOp\<close> below).

	See @{cite "code-generation-tutorial"} for more information on
	@{theory_text \<open>[code abstype]\<close>}.\<close>

	declare mat_of_cblinfun_inverse [code abstype]


	text \<open>This lemma defines addition. By writing \<^term>\<open>mat_of_cblinfun (M + N)\<close>
	on the left hand side, we get access to the\<close>


	declare mat_of_cblinfun_plus[code]
	\<comment> \<open>Code equation for addition of cblinfuns\<close>

	declare mat_of_cblinfun_id[code]
	\<comment> \<open>Code equation for computing the identity operator\<close>

	declare mat_of_cblinfun_1[code]
	\<comment> \<open>Code equation for computing the one-dimensional identity\<close>

	declare mat_of_cblinfun_zero[code]
	\<comment> \<open>Code equation for computing the zero operator\<close>


	declare mat_of_cblinfun_uminus[code]
	\<comment> \<open>Code equation for computing the unary minus on cblinfun's\<close>


	declare mat_of_cblinfun_minus[code]
	\<comment> \<open>Code equation for computing the difference of cblinfun's\<close>


	declare mat_of_cblinfun_classical_operator[code]
	\<comment> \<open>Code equation for computing the "classical operator"\<close>

	declare mat_of_cblinfun_compose[code]
	\<comment> \<open>Code equation for computing the composition/product of cblinfun's\<close>

	declare mat_of_cblinfun_scaleC[code]
	\<comment> \<open>Code equation for multiplication with complex scalar\<close>

	declare mat_of_cblinfun_scaleR[code]
	\<comment> \<open>Code equation for multiplication with real scalar\<close>

	declare mat_of_cblinfun_adj[code]
	\<comment> \<open>Code equation for computing the adj\<close>

	text \<open>This instantiation defines a code equation for equality tests for cblinfun.\<close>
	instantiation cblinfun :: (onb_enum,onb_enum) equal begin
	definition [code]: "equal_cblinfun M N \<longleftrightarrow> mat_of_cblinfun M = mat_of_cblinfun N"
	for M N :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
	instance
	apply intro_classes
	unfolding equal_cblinfun_def
	using mat_of_cblinfun_inj injD by fastforce
	end

	subsection \<open>Vectors\<close>

	text \<open>In this section, we define code for operations on vectors. As with operators above,
	we do this by using an isomorphism between finite vectors
	(i.e., types T of sort \<open>complex_vector\<close>) and the type \<^typ>\<open>complex vec\<close> from
	\<^session>\<open>Jordan_Normal_Form\<close>. We have developed such an isomorphism in
	theory \<open>Cblinfun_Matrix\<close> for
	any type T of sort \<open>onb_enum\<close> (i.e., any type with a finite canonical orthonormal basis)
	as was done above for bounded operators.
	Unfortunately, we cannot declare code equations for a type class,
	code equations must be related to a specific type constructor.
	So we give code definition only for vectors of type \<^typ>\<open>'a ell2\<close> (where \<^typ>\<open>'a\<close>
	must be of sort \<open>enum\<close> to make make sure that \<^typ>\<open>'a ell2\<close> is finite dimensional).

	The isomorphism between \<^typ>\<open>'a ell2\<close> is given by the constants \<open>ell2_of_vec\<close>
	and \<open>vec_of_ell2\<close> which are copies of the more general \<^const>\<open>basis_enum_of_vec\<close>
	and \<^const>\<open>vec_of_basis_enum\<close> but with a more restricted type to be usable in our code equations.
	\<close>

	definition ell2_of_vec :: "complex vec \<Rightarrow> 'a::enum ell2" where "ell2_of_vec = basis_enum_of_vec"
	definition vec_of_ell2 :: "'a::enum ell2 \<Rightarrow> complex vec" where "vec_of_ell2 = vec_of_basis_enum"

	text \<open>The following theorem registers the isomorphism \<open>ell2_of_vec\<close>/\<open>vec_of_ell2\<close>
	for code generation. From now on,
	code for operations on \<^typ>\<open>_ ell2\<close> can be expressed by declarations such
	as \<^term>\<open>vec_of_ell2 (f a b) = g (vec_of_ell2 a) (vec_of_ell2 b)\<close>
	if the operation f on \<^typ>\<open>_ ell2\<close> corresponds to the operation g on
	\<^typ>\<open>complex vec\<close>.\<close>

	lemma vec_of_ell2_inverse [code abstype]:
	"ell2_of_vec (vec_of_ell2 B) = B"
	unfolding ell2_of_vec_def vec_of_ell2_def
	by (rule vec_of_basis_enum_inverse)

	text \<open>This instantiation defines a code equation for equality tests for ell2.\<close>
	instantiation ell2 :: (enum) equal begin
	definition [code]: "equal_ell2 M N \<longleftrightarrow> vec_of_ell2 M = vec_of_ell2 N"
	for M N :: "'a::enum ell2"
	instance
	apply intro_classes
	unfolding equal_ell2_def
	by (metis vec_of_ell2_inverse)
	end

	lemma vec_of_ell2_zero[code]:
	\<comment> \<open>Code equation for computing the zero vector\<close>
	"vec_of_ell2 (0::'a::enum ell2) = zero_vec (CARD('a))"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_zero)

	lemma vec_of_ell2_ket[code]:
	\<comment> \<open>Code equation for computing a standard basis vector\<close>
	"vec_of_ell2 (ket i) = unit_vec (CARD('a)) (enum_idx i)"
	for i::"'a::enum"
	using vec_of_ell2_def vec_of_basis_enum_ket by metis

	lemma vec_of_ell2_timesScalarVec[code]:
	\<comment> \<open>Code equation for multiplying a vector with a complex scalar\<close>
	"vec_of_ell2 (scaleC a \<psi>) = smult_vec a (vec_of_ell2 \<psi>)"
	for \<psi> :: "'a::enum ell2"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleC)

	lemma vec_of_ell2_scaleR[code]:
	\<comment> \<open>Code equation for multiplying a vector with a real scalar\<close>
	"vec_of_ell2 (scaleR a \<psi>) = smult_vec (complex_of_real a) (vec_of_ell2 \<psi>)"
	for \<psi> :: "'a::enum ell2"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_scaleR)

	lemma ell2_of_vec_plus[code]:
	\<comment> \<open>Code equation for adding vectors\<close>
	"vec_of_ell2 (x + y) = (vec_of_ell2 x) + (vec_of_ell2 y)" for x y :: "'a::enum ell2"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_add)

	lemma ell2_of_vec_minus[code]:
	\<comment> \<open>Code equation for subtracting vectors\<close>
	"vec_of_ell2 (x - y) = (vec_of_ell2 x) - (vec_of_ell2 y)" for x y :: "'a::enum ell2"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_minus)

	lemma ell2_of_vec_uminus[code]:
	\<comment> \<open>Code equation for negating a vector\<close>
	"vec_of_ell2 (- y) = - (vec_of_ell2 y)" for y :: "'a::enum ell2"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_uminus)

	lemma cinner_ell2_code' [code]: "cinner \<psi> \<phi> = cscalar_prod (vec_of_ell2 \<phi>) (vec_of_ell2 \<psi>)"
	\<comment> \<open>Code equation for the inner product of vectors\<close>
	by (simp add: cscalar_prod_vec_of_basis_enum vec_of_ell2_def)

	lemma norm_ell2_code [code]:
	\<comment> \<open>Code equation for the norm of a vector\<close>
	"norm \<psi> = (let \<psi>' = vec_of_ell2 \<psi> in
	sqrt (\<Sum> i \<in> {0 ..< dim_vec \<psi>'}. let z = vec_index \<psi>' i in (Re z)\<^sup>2 + (Im z)\<^sup>2))"
	by (simp add: norm_ell2_vec_of_basis_enum vec_of_ell2_def)

	lemma times_ell2_code'[code]:
	\<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
	fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
	shows "vec_of_ell2 (\<psi> * \<phi>)
	= vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 * vec_index (vec_of_ell2 \<phi>) 0]"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_times)

	lemma divide_ell2_code'[code]:
	\<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
	fixes \<psi> \<phi> :: "'a::{CARD_1,enum} ell2"
	shows "vec_of_ell2 (\<psi> / \<phi>)
	= vec_of_list [vec_index (vec_of_ell2 \<psi>) 0 / vec_index (vec_of_ell2 \<phi>) 0]"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_divide)

	lemma inverse_ell2_code'[code]:
	\<comment> \<open>Code equation for the product in the algebra of one-dimensional vectors\<close>
	fixes \<psi> :: "'a::{CARD_1,enum} ell2"
	shows "vec_of_ell2 (inverse \<psi>)
	= vec_of_list [inverse (vec_index (vec_of_ell2 \<psi>) 0)]"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_to_inverse)

	lemma one_ell2_code'[code]:
	\<comment> \<open>Code equation for the unit in the algebra of one-dimensional vectors\<close>
	"vec_of_ell2 (1 :: 'a::{CARD_1,enum} ell2) = vec_of_list [1]"
	by (simp add: vec_of_ell2_def vec_of_basis_enum_1)

	subsection \<open>Vector/Matrix\<close>

	text \<open>We proceed to give code equations for operations involving both
	operators (cblinfun) and vectors. As explained above, we have to restrict
	the equations to vectors of type \<^typ>\<open>'a ell2\<close> even though the theory is available
	for any type of class \<^class>\<open>onb_enum\<close>. As a consequence, we run into an
	addition technicality now. For example, to define a code equation for applying
	an operator to a vector, we might try to give the following lemma:

	\<^theory_text>\<open>lemma cblinfun_apply_code[code]:
	"vec_of_ell2 (M *\<^sub>V x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
	by (simp add: mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)\<close>

	Unfortunately, this does not work, Isabelle produces the warning
	"Projection as head in equation", most likely due to the fact that
	the type of \<^term>\<open>(*\<^sub>V)\<close> in the equation is less general than the type of
	\<^term>\<open>(*\<^sub>V)\<close> (it is restricted to @{type ell2}). We overcome this problem
	by defining a constant \<open>cblinfun_apply_code\<close> which is equal to \<^term>\<open>(*\<^sub>V)\<close>
	but has a more restricted type. We then instruct the code generation
	to replace occurrences of \<^term>\<open>(*\<^sub>V)\<close> by \<open>cblinfun_apply_code\<close> (where possible),
	and we add code generation for \<open>cblinfun_apply_code\<close> instead of \<^term>\<open>(*\<^sub>V)\<close>.
	\<close>


	definition cblinfun_apply_code :: "'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'b ell2"
	where [code del, code_abbrev]: "cblinfun_apply_code = (*\<^sub>V)"
	\<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
	rhs \<^term>\<open>(*\<^sub>V)\<close> by the lhs \<^term>\<open>cblinfun_apply_code\<close> before starting
	the actual code generation.\<close>

	lemma cblinfun_apply_code[code]:
	\<comment> \<open>Code equation for \<^term>\<open>cblinfun_apply_code\<close>, i.e., for applying an operator
	to an \<^type>\<open>ell2\<close> vector\<close>
	"vec_of_ell2 (cblinfun_apply_code M x) = (mult_mat_vec (mat_of_cblinfun M) (vec_of_ell2 x))"
	by (simp add: cblinfun_apply_code_def mat_of_cblinfun_cblinfun_apply vec_of_ell2_def)

	text \<open>For the constant \<^term>\<open>vector_to_cblinfun\<close> (canonical isomorphism from
	vectors to operators), we have the same problem and define a constant
	\<open>vector_to_cblinfun_code\<close> with more restricted type\<close>

	definition vector_to_cblinfun_code :: "'a ell2 \<Rightarrow> 'b::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a ell2" where
	[code del,code_abbrev]: "vector_to_cblinfun_code = vector_to_cblinfun"
	\<comment> \<open>@{attribute code_abbrev} instructs the code generation to replace the
	rhs \<^term>\<open>vector_to_cblinfun\<close> by the lhs \<^term>\<open>vector_to_cblinfun_code\<close>
	before starting the actual code generation.\<close>

	lemma vector_to_cblinfun_code[code]:
	\<comment> \<open>Code equation for translating a vector into an operation (single-column matrix)\<close>
	"mat_of_cblinfun (vector_to_cblinfun_code \<psi>) = mat_of_cols (CARD('a)) [vec_of_ell2 \<psi>]"
	for \<psi>::"'a::enum ell2"
	by (simp add: mat_of_cblinfun_vector_to_cblinfun vec_of_ell2_def vector_to_cblinfun_code_def)

	subsection \<open>Subspaces\<close>

	text \<open>In this section, we define code equations for handling subspaces, i.e.,
	values of type \<^typ>\<open>'a ccsubspace\<close>. We choose to computationally represent
	a subspace by a list of vectors that span the subspace. That is,
	if \<^term>\<open>vecs\<close> are vectors (type \<^typ>\<open>complex vec\<close>), \<open>SPAN vecs\<close> is defined to be their
	span. Then the code generation can simply represent all subspaces in this form, and
	we need to define the operations on subspaces in terms of list of vectors
	(e.g., the closed union of two subspaces would be computed as the concatenation
	of the two lists, to give one of the simplest examples).

	To support this, \<open>SPAN\<close> is declared as a "\<open>code_datatype\<close>".
	(Not as an abstract datatype like \<^term>\<open>cblinfun_of_mat\<close>/\<^term>\<open>mat_of_cblinfun\<close>
	because that would require \<open>SPAN\<close> to be injective.)

	Then all code equations for different operations need to be formulated as
	functions of values of the form \<open>SPAN x\<close>. (E.g., \<open>SPAN x + SPAN y = SPAN (\<dots>)\<close>.)\<close>

	definition [code del]: "SPAN x = (let n = length (canonical_basis :: 'a::onb_enum list) in
	ccspan (basis_enum_of_vec ` Set.filter (\<lambda>v. dim_vec v = n) (set x)) :: 'a ccsubspace)"
	\<comment> \<open>The SPAN of vectors x, as a \<^type>\<open>ccsubspace\<close>.
	We filter out vectors of the wrong dimension because \<open>SPAN\<close> needs to have
	well-defined behavior even in cases that would not actually occur in an execution.\<close>
	code_datatype SPAN

	text \<open>We first declare code equations for \<^term>\<open>Proj\<close>, i.e., for
	turning a subspace into a projector. This means, we would need a code equation
	of the form \<open>mat_of_cblinfun (Proj (SPAN S)) = \<dots>\<close>. However, this equation is
	not accepted by the code generation for reasons we do not understand. But
	if we define an auxiliary constant \<open>mat_of_cblinfun_Proj_code\<close> that stands for
	\<open>mat_of_cblinfun (Proj _)\<close>, define a code equation for \<open>mat_of_cblinfun_Proj_code\<close>,
	and then define a code equation for \<open>mat_of_cblinfun (Proj S)\<close> in terms of
	\<open>mat_of_cblinfun_Proj_code\<close>, Isabelle accepts the code equations.\<close>

	definition "mat_of_cblinfun_Proj_code S = mat_of_cblinfun (Proj S)"
	declare mat_of_cblinfun_Proj_code_def[symmetric, code]

	lemma mat_of_cblinfun_Proj_code_code[code]:
	\<comment> \<open>Code equation for computing a projector onto a set S of vectors.
	We first make the vectors S into an orthonormal basis using
	the Gram-Schmidt procedure and then compute the projector
	as the sum of the "butterflies" \<open>x * x*\<close> of the vectors \<open>x\<in>S\<close>
	(done by \<^term>\<open>mk_projector_orthog\<close>).\<close>
	"mat_of_cblinfun_Proj_code (SPAN S :: 'a::onb_enum ccsubspace) =
	(let d = length (canonical_basis :: 'a list) in mk_projector_orthog d
	(gram_schmidt0 d (filter (\<lambda>v. dim_vec v = d) S)))"
	proof -
	have *: "map_option vec_of_basis_enum (if dim_vec x = length (canonical_basis :: 'a list) then Some (basis_enum_of_vec x :: 'a) else None)
	= (if dim_vec x = length (canonical_basis :: 'a list) then Some x else None)" for x
	by auto
	show ?thesis
	unfolding SPAN_def mat_of_cblinfun_Proj_code_def
	using mat_of_cblinfun_Proj_ccspan[where S =
	"map basis_enum_of_vec (filter (\<lambda>v. dim_vec v = (length (canonical_basis :: 'a list))) S) :: 'a list"]
	apply (simp only: Let_def map_filter_map_filter filter_set image_set map_map_filter o_def)
	unfolding *
	by (simp add: map_filter_map_filter[symmetric])
	qed

	lemma top_ccsubspace_code[code]:
	\<comment> \<open>Code equation for \<^term>\<open>top\<close>, the subspace containing everything.
	Top is represented as the span of the standard basis vectors.\<close>
	"(top::'a ccsubspace) =
	(let n = length (canonical_basis :: 'a::onb_enum list) in SPAN (unit_vecs n))"
	unfolding SPAN_def
	apply (simp only: index_unit_vec Let_def map_filter_map_filter filter_set image_set map_map_filter
	map_filter_map o_def unit_vecs_def)
	apply (simp add: basis_enum_of_vec_unit_vec)
	apply (subst nth_image)
	- by (auto simp: )
	+ by auto

	lemma bot_as_span[code]:
	\<comment> \<open>Code equation for \<^term>\<open>bot\<close>, the subspace containing everything.
	Top is represented as the span of the standard basis vectors.\<close>
	"(bot::'a::onb_enum ccsubspace) = SPAN []"
	unfolding SPAN_def by (auto simp: Set.filter_def)


	lemma sup_spans[code]:
	\<comment> \<open>Code equation for the join (lub) of two subspaces (union of the generating lists)\<close>
	"SPAN A \<squnion> SPAN B = SPAN (A @ B)"
	unfolding SPAN_def
	by (auto simp: ccspan_union image_Un filter_Un Let_def)

	text \<open>We do not need an equation for \<^term>\<open>(+)\<close> because \<^term>\<open>(+)\<close>
	is defined in terms of \<^term>\<open>(\<squnion>)\<close> (for \<^type>\<open>ccsubspace\<close>), thus the code generation automatically
	computes \<^term>\<open>(+)\<close> in terms of the code for \<^term>\<open>(\<squnion>)\<close>\<close>

	definition [code del,code_abbrev]: "Span_code (S::'a::enum ell2 set) = (ccspan S)"
	\<comment> \<open>A copy of \<^term>\<open>ccspan\<close> with restricted type. For analogous reasons as
	\<^term>\<open>cblinfun_apply_code\<close>, see there for explanations\<close>

	lemma span_Set_Monad[code]: "Span_code (Set_Monad l) = (SPAN (map vec_of_ell2 l))"
	\<comment> \<open>Code equation for the span of a finite set. (\<^term>\<open>Set_Monad\<close> is a datatype
	constructor that represents sets as lists in the computation.)\<close>
	apply (simp add: Span_code_def SPAN_def Let_def)
	apply (subst Set_filter_unchanged)
	apply (auto simp add: vec_of_ell2_def)[1]
	by (metis (no_types, lifting) ell2_of_vec_def image_image map_idI set_map vec_of_ell2_inverse)

	text \<open>This instantiation defines a code equation for equality tests for \<^type>\<open>ccsubspace\<close>.
	The actual code for equality tests is given below (lemma \<open>equal_ccsubspace_code\<close>).\<close>
	instantiation ccsubspace :: (onb_enum) equal begin
	definition [code del]: "equal_ccsubspace (A::'a ccsubspace) B = (A=B)"
	instance apply intro_classes unfolding equal_ccsubspace_def by simp
	end

	lemma leq_ccsubspace_code[code]:
	\<comment> \<open>Code equation for deciding inclusion of one space in another.
	Uses the constant \<^term>\<open>is_subspace_of_vec_list\<close> which implements the actual
	computation by checking for each generator of A whether it is in the
	span of B (by orthogonal projection onto an orthonormal basis of B
	which is computed using Gram-Schmidt).\<close>
	"SPAN A \<le> (SPAN B :: 'a::onb_enum ccsubspace)
	\<longleftrightarrow> (let d = length (canonical_basis :: 'a list) in
	is_subspace_of_vec_list d
	(filter (\<lambda>v. dim_vec v = d) A)
	(filter (\<lambda>v. dim_vec v = d) B))"
	proof -
	define d A' B' where "d = length (canonical_basis :: 'a list)"
	and "A' = filter (\<lambda>v. dim_vec v = d) A"
	and "B' = filter (\<lambda>v. dim_vec v = d) B"

	show ?thesis
	unfolding SPAN_def d_def[symmetric] filter_set Let_def
	A'_def[symmetric] B'_def[symmetric] image_set
	apply (subst ccspan_leq_using_vec)
	unfolding d_def[symmetric] map_map o_def
	apply (subst map_cong[where xs=A', OF refl])
	apply (rule basis_enum_of_vec_inverse)
	apply (simp add: A'_def d_def)
	apply (subst map_cong[where xs=B', OF refl])
	apply (rule basis_enum_of_vec_inverse)
	by (simp_all add: B'_def d_def)
	qed

	lemma equal_ccsubspace_code[code]:
	\<comment> \<open>Code equation for equality test. By checking mutual inclusion
	(for which we have code by the preceding code equation).\<close>
	"HOL.equal (A::_ ccsubspace) B = (A\<le>B \<and> B\<le>A)"
	unfolding equal_ccsubspace_def by auto

	lemma apply_cblinfun_code[code]:
	\<comment> \<open>Code equation for applying an operator \<^term>\<open>A\<close> to a subspace.
	Simply by multiplying each generator with \<^term>\<open>A\<close>\<close>
	"A *\<^sub>S SPAN S = (let d = length (canonical_basis :: 'a list) in
	SPAN (map (mult_mat_vec (mat_of_cblinfun A))
	(filter (\<lambda>v. dim_vec v = d) S)))"
	for A::"'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L'b::onb_enum"
	proof -
	define dA dB S'
	where "dA = length (canonical_basis :: 'a list)"
	and "dB = length (canonical_basis :: 'b list)"
	and "S' = filter (\<lambda>v. dim_vec v = dA) S"

	have "cblinfun_image A (SPAN S) = A *\<^sub>S ccspan (set (map basis_enum_of_vec S'))"
	unfolding SPAN_def dA_def[symmetric] Let_def S'_def filter_set
	by simp
	also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec
	(mat_of_cblinfun A *\<^sub>v vec_of_basis_enum (basis_enum_of_vec x :: 'a))) ` set S')"
	apply (subst cblinfun_apply_ccspan_using_vec)
	by (simp add: image_image)
	also have "\<dots> = ccspan ((\<lambda>x. basis_enum_of_vec (mat_of_cblinfun A *\<^sub>v x)) ` set S')"
	apply (subst image_cong[OF refl])
	apply (subst basis_enum_of_vec_inverse)
	by (auto simp add: S'_def dA_def)
	also have "\<dots> = SPAN (map (mult_mat_vec (mat_of_cblinfun A)) S')"
	unfolding SPAN_def dB_def[symmetric] Let_def filter_set
	apply (subst filter_True)
	by (simp_all add: dB_def mat_of_cblinfun_def image_image)

	finally show ?thesis
	unfolding dA_def[symmetric] S'_def[symmetric] Let_def
	by simp
	qed

	definition [code del, code_abbrev]: "range_cblinfun_code A = A *\<^sub>S top"
	\<comment> \<open>A new constant for the special case of applying an operator to the subspace \<^term>\<open>top\<close>
	(i.e., for computing the range of the operator). We do this to be able to give
	more specialized code for this specific situation. (The generic code for
	\<^term>\<open>(*\<^sub>S)\<close> would work but is less efficient because it involves repeated matrix
	multiplications. @{attribute code_abbrev} makes sure occurrences of \<^term>\<open>A *\<^sub>S top\<close>
	are replaced before starting the actual code generation.\<close>

	lemma range_cblinfun_code[code]:
	\<comment> \<open>Code equation for computing the range of an operator \<^term>\<open>A\<close>.
	Returns the columns of the matrix representation of \<^term>\<open>A\<close>.\<close>
	fixes A :: "'a::onb_enum \<Rightarrow>\<^sub>C\<^sub>L 'b::onb_enum"
	shows "range_cblinfun_code A = SPAN (cols (mat_of_cblinfun A))"
	proof -
	define dA dB
	where "dA = length (canonical_basis :: 'a list)"
	and "dB = length (canonical_basis :: 'b list)"
	have carrier_A: "mat_of_cblinfun A \<in> carrier_mat dB dA"
	unfolding mat_of_cblinfun_def dA_def dB_def by simp

	have "range_cblinfun_code A = A *\<^sub>S SPAN (unit_vecs dA)"
	unfolding range_cblinfun_code_def
	by (metis dA_def top_ccsubspace_code)
	also have "\<dots> = SPAN (map (\<lambda>i. mat_of_cblinfun A *\<^sub>v unit_vec dA i) [0..<dA])"
	unfolding apply_cblinfun_code dA_def[symmetric] Let_def
	apply (subst filter_True)
	apply (meson carrier_vecD subset_code(1) unit_vecs_carrier)
	by (simp add: unit_vecs_def o_def)
	also have "\<dots> = SPAN (map (\<lambda>x. mat_of_cblinfun A *\<^sub>v col (1\<^sub>m dA) x) [0..<dA])"
	apply (subst map_cong[OF refl])
	by auto
	also have "\<dots> = SPAN (map (col (mat_of_cblinfun A * 1\<^sub>m dA)) [0..<dA])"
	apply (subst map_cong[OF refl])
	apply (subst col_mult2[symmetric])
	apply (rule carrier_A)
	by auto
	also have "\<dots> = SPAN (cols (mat_of_cblinfun A))"
	unfolding cols_def dA_def[symmetric]
	apply (subst right_mult_one_mat[OF carrier_A])
	using carrier_A by blast
	finally show ?thesis
	by -
	qed


	lemma uminus_Span_code[code]: "- X = range_cblinfun_code (id_cblinfun - Proj X)"
	\<comment> \<open>Code equation for the orthogonal complement of a subspace \<^term>\<open>X\<close>.
	Computed as the range of one minus the projector on \<^term>\<open>X\<close>\<close>
	unfolding range_cblinfun_code_def
	by (metis Proj_ortho_compl Proj_range)

	lemma kernel_code[code]:
	\<comment> \<open>Computes the kernel of an operator \<^term>\<open>A\<close>.
	This is implemented using the existing functions
	for transforming a matrix into row echelon form (\<^term>\<open>gauss_jordan_single\<close>)
	and for computing a basis of the kernel of such a matrix
	(\<^term>\<open>find_base_vectors\<close>)\<close>
	"kernel A = SPAN (find_base_vectors (gauss_jordan_single (mat_of_cblinfun A)))"
	for A::"('a::onb_enum,'b::onb_enum) cblinfun"
	proof -
	define dA dB Am Ag base
	where "dA = length (canonical_basis :: 'a list)"
	and "dB = length (canonical_basis :: 'b list)"
	and "Am = mat_of_cblinfun A"
	and "Ag = gauss_jordan_single Am"
	and "base = find_base_vectors Ag"

	interpret complex_vec_space dA.

	have Am_carrier: "Am \<in> carrier_mat dB dA"
	unfolding Am_def mat_of_cblinfun_def dA_def dB_def by simp

	have row_echelon: "row_echelon_form Ag"
	unfolding Ag_def
	using Am_carrier refl by (rule gauss_jordan_single)

	have Ag_carrier: "Ag \<in> carrier_mat dB dA"
	unfolding Ag_def
	using Am_carrier refl by (rule gauss_jordan_single(2))

	have base_carrier: "set base \<subseteq> carrier_vec dA"
	unfolding base_def
	using find_base_vectors(1)[OF row_echelon Ag_carrier]
	using Ag_carrier mat_kernel_def by blast

	interpret k: kernel dB dA Ag
	apply standard using Ag_carrier by simp

	have basis_base: "kernel.basis dA Ag (set base)"
	using row_echelon Ag_carrier unfolding base_def
	by (rule find_base_vectors(3))


	have "space_as_set (SPAN base)
	= space_as_set (ccspan (basis_enum_of_vec ` set base :: 'a set))"
	unfolding SPAN_def dA_def[symmetric] Let_def filter_set
	apply (subst filter_True)
	using base_carrier by auto

	also have "\<dots> = cspan (basis_enum_of_vec ` set base)"
	apply transfer apply (subst closure_finite_cspan)
	by simp_all

	also have "\<dots> = basis_enum_of_vec ` span (set base)"
	apply (subst basis_enum_of_vec_span)
	using base_carrier dA_def by auto

	also have "\<dots> = basis_enum_of_vec ` mat_kernel Ag"
	using basis_base k.Ker.basis_def k.span_same by auto

	also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Ag *\<^sub>v v = 0\<^sub>v dB}"
	apply (rule arg_cong[where f="\<lambda>x. basis_enum_of_vec ` x"])
	unfolding mat_kernel_def using Ag_carrier
	by simp

	also have "\<dots> = basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}"
	using gauss_jordan_single(1)[OF Am_carrier Ag_def[symmetric]]
	by auto

	also have "\<dots> = {w. A *\<^sub>V w = 0}"
	proof -
	have "basis_enum_of_vec ` {v \<in> carrier_vec dA. Am *\<^sub>v v = 0\<^sub>v dB}
	= basis_enum_of_vec ` {v \<in> carrier_vec dA. A *\<^sub>V basis_enum_of_vec v = 0}"
	apply (rule arg_cong[where f="\<lambda>t. basis_enum_of_vec ` t"])
	apply (rule Collect_cong)
	apply (simp add: Am_def)
	by (metis Am_carrier Am_def carrier_matD(2) carrier_vecD dB_def mat_carrier
	mat_of_cblinfun_def mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_inverse
	basis_enum_of_vec_inverse vec_of_basis_enum_zero)
	also have "\<dots> = {w \<in> basis_enum_of_vec ` carrier_vec dA. A *\<^sub>V w = 0}"
	apply (subst Compr_image_eq[symmetric])
	by simp
	also have "\<dots> = {w. A *\<^sub>V w = 0}"
	apply auto
	by (metis (no_types, lifting) Am_carrier Am_def carrier_matD(2) carrier_vec_dim_vec dim_vec_of_basis_enum' image_iff mat_carrier mat_of_cblinfun_def vec_of_basis_enum_inverse)
	finally show ?thesis
	by -
	qed

	also have "\<dots> = space_as_set (kernel A)"
	apply transfer by auto

	finally have "SPAN base = kernel A"
	by (simp add: space_as_set_inject)
	then show ?thesis
	by (simp add: base_def Ag_def Am_def)
	qed

	lemma inf_ccsubspace_code[code]:
	\<comment> \<open>Code equation for intersection of subspaces.
	Reduced to orthogonal complement and sum of subspaces
	for which we already have code equations.\<close>
	"(A::'a::onb_enum ccsubspace) \<sqinter> B = - (- A \<squnion> - B)"
	by (subst ortho_involution[symmetric], subst compl_inf, simp)

	lemma Sup_ccsubspace_code[code]:
	\<comment> \<open>Supremum (sum) of a set of subspaces. Implemented
	by repeated pairwise sum.\<close>
	"Sup (Set_Monad l :: 'a::onb_enum ccsubspace set) = fold sup l bot"
	unfolding Set_Monad_def
	by (simp add: Sup_set_fold)


	lemma Inf_ccsubspace_code[code]:
	\<comment> \<open>Infimum (intersection) of a set of subspaces.
	Implemented by the orthogonal complement of the supremum.\<close>
	"Inf (Set_Monad l :: 'a::onb_enum ccsubspace set)
	= - Sup (Set_Monad (map uminus l))"
	unfolding Set_Monad_def
	apply (induction l)
	by auto

	subsection \<open>Miscellanea\<close>

	text \<open>This is a hack to circumvent a bug in the code generation. The automatically
	generated code for the class \<^class>\<open>uniformity\<close> has a type that is different from
	what the generated code later assumes, leading to compilation errors (in ML at least)
	in any expression involving \<^typ>\<open>_ ell2\<close> (even if the constant \<^const>\<open>uniformity\<close> is
	not actually used).

	The fragment below circumvents this by forcing Isabelle to use the right type.
	(The logically useless fragment "\<open>let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_)\<close>" achieves this.)\<close>
	lemma uniformity_ell2_code[code]: "(uniformity :: ('a ell2 * _) filter) = Filter.abstract_filter (%_.
	Code.abort STR ''no uniformity'' (%_.
	let x = ((=)::'a\<Rightarrow>_\<Rightarrow>_) in uniformity))"
	by simp

	text \<open>Code equation for \<^term>\<open>UNIV\<close>.
	It is now implemented via type class \<^class>\<open>enum\<close>
	(which provides a list of all values).\<close>
	declare [[code drop: UNIV]]
	declare enum_class.UNIV_enum[code]

	text \<open>Setup for code generation involving sets of \<^type>\<open>ell2\<close>/\<^type>\<open>ccsubspace\<close>.
	This configures to use lists for representing sets in code.\<close>
	derive (eq) ceq ccsubspace
	derive (no) ccompare ccsubspace
	derive (monad) set_impl ccsubspace
	derive (eq) ceq ell2
	derive (no) ccompare ell2
	derive (monad) set_impl ell2


	unbundle no_lattice_syntax
	unbundle no_jnf_notation
	unbundle no_cblinfun_notation

	end
	diff --git a/thys/Complex_Bounded_Operators/One_Dimensional_Spaces.thy b/thys/Complex_Bounded_Operators/One_Dimensional_Spaces.thy
	--- a/thys/Complex_Bounded_Operators/One_Dimensional_Spaces.thy
	+++ b/thys/Complex_Bounded_Operators/One_Dimensional_Spaces.thy
	@@ -1,287 +1,287 @@
	section \<open>\<open>One_Dimensional_Spaces\<close> -- One dimensional complex vector spaces\<close>

	theory One_Dimensional_Spaces
	imports
	Complex_Inner_Product
	"Complex_Bounded_Operators.Extra_Operator_Norm"
	begin

	text \<open>The class \<open>one_dim\<close> applies to one-dimensional vector spaces.
	Those are additionally interpreted as \<^class>\<open>complex_algebra_1\<close>s
	via the canonical isomorphism between a one-dimensional vector space and
	\<^typ>\<open>complex\<close>.\<close>
	class one_dim = onb_enum + one + times + complex_inner + inverse +
	assumes one_dim_canonical_basis[simp]: "canonical_basis = [1]"
	assumes one_dim_prod_scale1: "(a \<^sub>C 1) (b \<^sub>C 1) = (ab) *\<^sub>C 1"
	assumes divide_inverse: "x / y = x * inverse y"
	assumes one_dim_inverse: "inverse (a \<^sub>C 1) = inverse a \<^sub>C 1"

	hide_fact (open) divide_inverse (* divide_inverse from field_class, instantiated below, subsumed this one *)

	instance complex :: one_dim
	apply intro_classes
	unfolding canonical_basis_complex_def is_ortho_set_def
	by (auto simp: divide_complex_def)

	lemma one_cinner_one[simp]: \<open>\<langle>(1::('a::one_dim)), 1\<rangle> = 1\<close>
	proof-
	include notation_norm
	have \<open>(canonical_basis::'a list) = [1::('a::one_dim)]\<close>
	by (simp add: one_dim_canonical_basis)
	hence \<open>\<parallel>1::'a::one_dim\<parallel> = 1\<close>
	by (metis is_normal list.set_intros(1))
	hence \<open>\<parallel>1::'a::one_dim\<parallel>^2 = 1\<close>
	by simp
	moreover have \<open>\<parallel>(1::('a::one_dim))\<parallel>^2 = \<langle>(1::('a::one_dim)), 1\<rangle>\<close>
	by (metis cnorm_eq_square)
	ultimately show ?thesis by simp
	qed

	lemma one_cinner_a_scaleC_one[simp]: \<open>\<langle>1::('a::one_dim), a\<rangle> *\<^sub>C 1 = a\<close>
	proof-
	have \<open>(canonical_basis::'a list) = [1]\<close>
	by (simp add: one_dim_canonical_basis)
	hence r2: \<open>a \<in> complex_vector.span ({1::'a})\<close>
	using iso_tuple_UNIV_I empty_set is_generator_set list.simps(15)
	by metis
	have "(1::'a) \<notin> {}"
	by (metis equals0D)
	hence r1: \<open>\<exists> s. a = s *\<^sub>C 1\<close>
	by (metis Diff_insert_absorb r2 complex_vector.span_breakdown
	complex_vector.span_empty eq_iff_diff_eq_0 singleton_iff)
	then obtain s where s_def: \<open>a = s *\<^sub>C 1\<close>
	by blast
	have \<open>\<langle>(1::'a), a\<rangle> = \<langle>(1::'a), s *\<^sub>C 1\<rangle>\<close>
	using \<open>a = s *\<^sub>C 1\<close>
	by simp
	also have \<open>\<dots> = s * \<langle>(1::'a), 1\<rangle>\<close>
	by simp
	also have \<open>\<dots> = s\<close>
	using one_cinner_one by auto
	finally show ?thesis
	by (simp add: s_def)
	qed

	lemma one_dim_apply_is_times_def:
	"\<psi> * \<phi> = (\<langle>1, \<psi>\<rangle> * \<langle>1, \<phi>\<rangle>) *\<^sub>C 1" for \<psi> :: \<open>'a::one_dim\<close>
	by (metis one_cinner_a_scaleC_one one_dim_prod_scale1)

	instance one_dim \<subseteq> complex_algebra_1
	proof
	fix x y z :: \<open>'a::one_dim\<close> and c :: complex
	show "(x * y) * z = x * (y * z)"
	by (simp add: one_dim_apply_is_times_def[where ?'a='a])
	show "(x + y) * z = x * z + y * z"
	by (metis (no_types, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) complex_vector.vector_space_assms(3) one_dim_apply_is_times_def)
	show "x * (y + z) = x * y + x * z"
	by (metis (mono_tags, lifting) cinner_simps(2) complex_vector.vector_space_assms(2) distrib_left one_dim_apply_is_times_def)
	show "(c \<^sub>C x) y = c \<^sub>C (x y)"
	by (simp add: one_dim_apply_is_times_def[where ?'a='a])
	show "x * (c \<^sub>C y) = c \<^sub>C (x * y)"
	by (simp add: one_dim_apply_is_times_def[where ?'a='a])
	show "1 * x = x"
	by (metis mult.left_neutral one_cinner_a_scaleC_one one_cinner_one one_dim_apply_is_times_def)
	show "x * 1 = x"
	by (simp add: one_dim_apply_is_times_def [where ?'a = 'a])
	show "(0::'a) \<noteq> 1"
	by (metis cinner_eq_zero_iff one_cinner_one zero_neq_one)
	qed

	instance one_dim \<subseteq> complex_normed_algebra
	proof
	fix x y :: \<open>'a::one_dim\<close>
	show "norm (x * y) \<le> norm x * norm y"
	proof-
	have r1: "cmod (\<langle>1::'a, x\<rangle>) \<le> norm (1::'a) * norm x"
	by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
	have r2: "cmod (\<langle>1::'a, y\<rangle>) \<le> norm (1::'a) * norm y"
	by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)

	have q1: "\<langle>(1::'a), 1\<rangle> = 1"
	- by (simp add: )
	+ by simp
	hence "(norm (1::'a))^2 = 1"
	by (simp add: cnorm_eq_1 power2_eq_1_iff)
	hence "norm (1::'a) = 1"
	by (smt abs_norm_cancel power2_eq_1_iff)
	hence "cmod (\<langle>1::'a, x\<rangle> * \<langle>1::'a, y\<rangle>) * norm (1::'a) = cmod (\<langle>1::'a, x\<rangle> * \<langle>1::'a, y\<rangle>)"
	by simp
	also have "\<dots> = cmod (\<langle>1::'a, x\<rangle>) * cmod (\<langle>1::'a, y\<rangle>)"
	by (simp add: norm_mult)
	also have "\<dots> \<le> norm (1::'a) * norm x * norm (1::'a) * norm y"
	by (smt \<open>norm 1 = 1\<close> mult.commute mult_cancel_right1 norm_scaleC one_cinner_a_scaleC_one)
	also have "\<dots> = norm x * norm y"
	by (simp add: \<open>norm 1 = 1\<close>)
	finally show ?thesis
	by (simp add: one_dim_apply_is_times_def[where ?'a='a])
	qed
	qed

	instance one_dim \<subseteq> complex_normed_algebra_1
	proof intro_classes
	show "norm (1::'a) = 1"
	by (metis complex_inner_1_left norm_eq_sqrt_cinner norm_one one_cinner_one)
	qed


	text \<open>This is the canonical isomorphism between any two one dimensional spaces. Specifically,
	if 1 denotes the element of the canonical basis (which is specified by type class \<^class>\<open>basis_enum\<close>,
	then \<^term>\<open>one_dim_iso\<close> is the unique isomorphism that maps 1 to 1.\<close>
	definition one_dim_iso :: "'a::one_dim \<Rightarrow> 'b::one_dim"
	where "one_dim_iso a = of_complex (\<langle>1, a\<rangle>)"

	lemma one_dim_iso_idem[simp]: "one_dim_iso (one_dim_iso x) = one_dim_iso x"
	by (simp add: one_dim_iso_def)

	lemma one_dim_iso_id[simp]: "one_dim_iso = id"
	unfolding one_dim_iso_def
	by (auto simp add: of_complex_def)

	lemma one_dim_iso_adjoint[simp]: \<open>cadjoint one_dim_iso = one_dim_iso\<close>
	apply (rule cadjoint_eqI)
	by (simp add: one_dim_iso_def of_complex_def)

	lemma one_dim_iso_is_of_complex[simp]: "one_dim_iso = of_complex"
	unfolding one_dim_iso_def by auto

	lemma of_complex_one_dim_iso[simp]: "of_complex (one_dim_iso \<psi>) = one_dim_iso \<psi>"
	by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

	lemma one_dim_iso_of_complex[simp]: "one_dim_iso (of_complex c) = of_complex c"
	by (metis one_dim_iso_is_of_complex one_dim_iso_idem)

	lemma one_dim_iso_add[simp]:
	\<open>one_dim_iso (a + b) = one_dim_iso a + one_dim_iso b\<close>
	by (simp add: cinner_simps(2) one_dim_iso_def)

	lemma one_dim_iso_minus[simp]:
	\<open>one_dim_iso (a - b) = one_dim_iso a - one_dim_iso b\<close>
	by (simp add: cinner_simps(3) one_dim_iso_def)

	lemma one_dim_iso_scaleC[simp]: "one_dim_iso (c \<^sub>C \<psi>) = c \<^sub>C one_dim_iso \<psi>"
	by (metis cinner_scaleC_right of_complex_mult one_dim_iso_def scaleC_conv_of_complex)

	lemma clinear_one_dim_iso[simp]: "clinear one_dim_iso"
	by (rule clinearI, auto)

	lemma bounded_clinear_one_dim_iso[simp]: "bounded_clinear one_dim_iso"
	proof (rule bounded_clinear_intro [where K = 1] , auto)
	fix x :: \<open>'a::one_dim\<close>
	show "norm (one_dim_iso x) \<le> norm x"
	by (metis (full_types) norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def
	order_refl)
	qed

	lemma one_dim_iso_of_one[simp]: "one_dim_iso 1 = 1"
	by (simp add: one_dim_iso_def)

	lemma onorm_one_dim_iso[simp]: "onorm one_dim_iso = 1"
	proof (rule onormI [where b = 1 and x = 1])
	fix x :: \<open>'a::one_dim\<close>
	have "norm (one_dim_iso x ::'b) \<le> norm x"
	by (metis eq_iff norm_of_complex of_complex_def one_cinner_a_scaleC_one one_dim_iso_def)
	thus "norm (one_dim_iso (x::'a)::'b) \<le> 1 * norm x"
	by auto
	show "(1::'a) \<noteq> 0"
	by simp
	show "norm (one_dim_iso (1::'a)::'b) = 1 * norm (1::'a)"
	by auto
	qed

	lemma one_dim_iso_times[simp]: "one_dim_iso (\<psi> * \<phi>) = one_dim_iso \<psi> * one_dim_iso \<phi>"
	by (metis mult.left_neutral mult_scaleC_left of_complex_def one_cinner_a_scaleC_one one_dim_iso_def one_dim_iso_scaleC)

	lemma one_dim_iso_of_zero[simp]: "one_dim_iso 0 = 0"
	by (simp add: complex_vector.linear_0)

	lemma one_dim_iso_of_zero': "one_dim_iso x = 0 \<Longrightarrow> x = 0"
	by (metis of_complex_def of_complex_eq_0_iff one_cinner_a_scaleC_one one_dim_iso_def)

	lemma one_dim_scaleC_1[simp]: "one_dim_iso x *\<^sub>C 1 = x"
	by (simp add: one_dim_iso_def)

	lemma one_dim_clinear_eqI:
	assumes "(x::'a::one_dim) \<noteq> 0" and "clinear f" and "clinear g" and "f x = g x"
	shows "f = g"
	proof (rule ext)
	fix y :: 'a
	from \<open>f x = g x\<close>
	have \<open>one_dim_iso x \<^sub>C f 1 = one_dim_iso x \<^sub>C g 1\<close>
	by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
	hence "f 1 = g 1"
	using assms(1) one_dim_iso_of_zero' by auto
	then show "f y = g y"
	by (metis assms(2) assms(3) complex_vector.linear_scale one_dim_scaleC_1)
	qed

	lemma one_dim_norm: "norm x = cmod (one_dim_iso x)"
	proof (subst one_dim_scaleC_1 [symmetric])
	show "norm (one_dim_iso x *\<^sub>C (1::'a)) = cmod (one_dim_iso x)"
	by (metis norm_of_complex of_complex_def)
	qed

	lemma one_dim_onorm:
	fixes f :: "'a::one_dim \<Rightarrow> 'b::complex_normed_vector"
	assumes "clinear f"
	shows "onorm f = norm (f 1)"
	proof (rule onormI[where x=1])
	fix x :: 'a
	have "norm x * norm (f 1) \<le> norm (f 1) * norm x"
	by simp
	hence "norm (f (one_dim_iso x \<^sub>C 1)) \<le> norm (f 1) norm x"
	by (metis (mono_tags, lifting) assms complex_vector.linear_scale norm_scaleC one_dim_norm)
	thus "norm (f x) \<le> norm (f 1) * norm x"
	by (subst one_dim_scaleC_1 [symmetric])
	qed auto

	lemma one_dim_onorm':
	fixes f :: "'a::one_dim \<Rightarrow> 'b::one_dim"
	assumes "clinear f"
	shows "onorm f = cmod (one_dim_iso (f 1))"
	using assms one_dim_norm one_dim_onorm by fastforce

	instance one_dim \<subseteq> zero_neq_one ..

	lemma one_dim_iso_inj: "one_dim_iso x = one_dim_iso y \<Longrightarrow> x = y"
	by (metis one_dim_iso_idem one_dim_scaleC_1)

	instance one_dim \<subseteq> comm_ring
	proof intro_classes
	fix x y z :: 'a
	show "x * y = y * x"
	by (metis one_dim_apply_is_times_def ordered_field_class.sign_simps(5))
	show "(x + y) * z = x * z + y * z"
	by (simp add: ring_class.ring_distribs(2))
	qed

	instance one_dim \<subseteq> field
	proof intro_classes
	fix x y z :: \<open>'a::one_dim\<close>
	show "1 * x = x"
	by simp

	have "(inverse \<langle>1, x\<rangle> * \<langle>1, x\<rangle>) *\<^sub>C (1::'a) = 1" if "x \<noteq> 0"
	by (metis left_inverse of_complex_def one_cinner_a_scaleC_one one_dim_iso_of_zero
	one_dim_iso_is_of_complex one_dim_iso_of_one that)
	hence "inverse (\<langle>1, x\<rangle> \<^sub>C 1) \<langle>1, x\<rangle> *\<^sub>C 1 = (1::'a)" if "x \<noteq> 0"
	by (metis one_dim_inverse one_dim_prod_scale1 that)
	hence "inverse (\<langle>1, x\<rangle> \<^sub>C 1) x = 1" if "x \<noteq> 0"
	using one_cinner_a_scaleC_one[of x, symmetric] that by auto
	thus "inverse x * x = 1" if "x \<noteq> 0"
	by (simp add: that)
	show "x / y = x * inverse y"
	by (simp add: one_dim_class.divide_inverse)
	show "inverse (0::'a) = 0"
	by (subst complex_vector.scale_zero_left[symmetric], subst one_dim_inverse, simp)
	qed


	instance one_dim \<subseteq> complex_normed_field
	proof intro_classes
	fix x y :: 'a
	show "norm (x * y) = norm x * norm y"
	by (metis norm_mult one_dim_iso_times one_dim_norm)
	qed

	instance one_dim \<subseteq> chilbert_space..

	end
	diff --git a/thys/Complx/OG_Soundness.thy b/thys/Complx/OG_Soundness.thy
	--- a/thys/Complx/OG_Soundness.thy
	+++ b/thys/Complx/OG_Soundness.thy
	@@ -1,2036 +1,2036 @@
	(*
	* Copyright 2016, Data61, CSIRO
	*
	* This software may be distributed and modified according to the terms of
	* the BSD 2-Clause license. Note that NO WARRANTY is provided.
	* See "LICENSE_BSD2.txt" for details.
	*
	* @TAG(DATA61_BSD)
	*)
	section \<open>Soundness proof of Owicki-Gries w.r.t.
	COMPLX small-step semantics\<close>

	theory OG_Soundness
	imports
	OG_Hoare
	SeqCatch_decomp
	begin

	lemma pre_weaken_pre:
	" x \<in> pre P \<Longrightarrow> x \<in> pre (weaken_pre P P')"
	by (induct P, clarsimp+)

	lemma oghoare_Skip[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = Skip \<longrightarrow>
	(\<exists>P'. P = AnnExpr P' \<and> P' \<subseteq> Q)"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'')
	apply(case_tac P, simp_all)
	by force

	lemma oghoare_Throw[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = Throw \<longrightarrow>
	(\<exists>P'. P = AnnExpr P' \<and> P' \<subseteq> A)"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'')
	apply(case_tac P, simp_all)
	by force

	lemma oghoare_Basic[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = Basic f \<longrightarrow>
	(\<exists>P'. P = AnnExpr P' \<and> P' \<subseteq> {x. f x \<in> Q})"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'')
	apply(case_tac P, simp_all)
	by force

	lemma oghoare_Spec[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = Spec r \<longrightarrow>
	(\<exists>P'. P = AnnExpr P' \<and> P' \<subseteq> {s. (\<forall>t. (s, t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s, t) \<in> r)})"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'')
	apply(case_tac P, simp_all)
	by force

	lemma oghoare_DynCom[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = (DynCom c') \<longrightarrow>
	(\<exists>r ad. P = (AnnRec r ad) \<and> r \<subseteq> pre ad \<and> (\<forall>s\<in>r. \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> ad (c' s) Q,A))"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'' x)
	apply(case_tac P, simp_all)
	apply clarsimp
	apply (rename_tac P s)
	apply (drule_tac x=s in bspec, simp)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	done

	lemma oghoare_Guard[rule_format, OF _ refl]:
	"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow> c = Guard f g d \<longrightarrow>
	(\<exists>P' r . P = AnnRec r P' \<and>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' d Q,A \<and>
	r \<inter> g \<subseteq> pre P' \<and>
	(r \<inter> -g \<noteq> {} \<longrightarrow> f \<in> F))"
	apply (induct rule: oghoare_induct, simp_all)
	apply force
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P Q A P' Q' A' P'' r)
	apply (case_tac P, simp_all)
	apply clarsimp
	apply (rename_tac r)
	apply(rule conjI)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (rule_tac x="Q'" in exI)
	apply (rule_tac x="A'" in exI)
	apply (clarsimp)
	apply (case_tac "(r \<union> P') \<inter> g \<noteq> {}")
	apply fast
	apply clarsimp
	apply(drule equalityD1, force)
	done

	lemma oghoare_Await[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta>\<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow> \<forall>b c. x = Await b c \<longrightarrow>
	(\<exists>r P' Q' A'. P = AnnRec r P' \<and> \<Gamma>, \<Theta>\<tturnstile>\<^bsub>/F\<^esub>(r \<inter> b) P' c Q',A' \<and> atom_com c
	\<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
	supply [[simproc del: defined_all]]
	apply (induct rule: oghoare_induct, simp_all)
	apply (rename_tac \<Gamma> \<Theta> F r P Q A)
	apply (rule_tac x=Q in exI)
	apply (rule_tac x=A in exI)
	apply clarsimp
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp

	apply(case_tac P, simp_all)
	apply (rename_tac P'' Q'' A'' x y)
	apply (rule_tac x=Q'' in exI)
	apply (rule_tac x=A'' in exI)
	apply clarsimp
	apply (rule conjI[rotated])
	apply blast
	apply (erule SeqConseq[rotated])
	apply simp
	apply simp
	apply blast
	done

	lemma oghoare_Seq[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow> \<forall>p1 p2. x = Seq p1 p2 \<longrightarrow>
	(\<exists> P\<^sub>1 P\<^sub>2 P' Q' A'. P = AnnComp P\<^sub>1 P\<^sub>2 \<and> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 p1 P', A' \<and> P' \<subseteq> pre P\<^sub>2 \<and>
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 p2 Q',A' \<and>
	Q' \<subseteq> Q \<and> A' \<subseteq> A)"
	apply (induct rule: oghoare_induct, simp_all)
	apply blast
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp
	apply (rename_tac P'' Q'' A'')
	apply(case_tac P, simp_all)
	apply clarsimp
	apply (rule_tac x="P''" in exI)
	apply (rule_tac x="Q''" in exI)
	apply (rule_tac x="A''" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule Conseq)
	apply (rule_tac x="P'" in exI)
	apply (rule_tac x="P''" in exI)
	apply (rule_tac x="A''" in exI)
	apply simp
	apply fastforce
	done

	lemma oghoare_Catch[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow> \<forall>p1 p2. x = Catch p1 p2 \<longrightarrow>
	(\<exists> P\<^sub>1 P\<^sub>2 P' Q' A'. P = AnnComp P\<^sub>1 P\<^sub>2 \<and> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 p1 Q', P' \<and> P' \<subseteq> pre P\<^sub>2 \<and>
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 p2 Q',A' \<and>
	Q' \<subseteq> Q \<and> A' \<subseteq> A)"
	apply (induct rule: oghoare_induct, simp_all)
	apply blast
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp
	apply(case_tac P, simp_all)
	apply clarsimp
	apply (rename_tac P'' Q'' A'' x)
	apply (rule_tac x="P''" in exI)
	apply (rule_tac x="Q''" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule Conseq)
	apply (rule_tac x=P' in exI)
	apply fastforce
	apply (rule_tac x="A''" in exI)
	apply clarsimp
	apply fastforce
	done

	lemma oghoare_Cond[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow>
	\<forall>c\<^sub>1 c\<^sub>2 b. x = (Cond b c\<^sub>1 c\<^sub>2) \<longrightarrow>
	(\<exists>P' P\<^sub>1 P\<^sub>2 Q' A'. P = (AnnBin P' P\<^sub>1 P\<^sub>2) \<and>
	P' \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>pre P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>pre P\<^sub>2)} \<and>
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q',A' \<and>
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q',A' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A)"
	apply (induct rule: oghoare_induct, simp_all)
	apply (rule conjI)
	apply fastforce
	apply (rename_tac Q A P\<^sub>2 c\<^sub>2 r b)
	apply (rule_tac x=Q in exI)
	apply (rule_tac x=A in exI)
	apply fastforce
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp
	apply (case_tac P, simp_all)
	apply fastforce
	done

	lemma oghoare_While[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow>
	\<forall> b c. x = While b c \<longrightarrow>
	(\<exists> r i P' A' Q'. P = AnnWhile r i P' \<and>
	\<Gamma>, \<Theta>\<turnstile>\<^bsub>/F\<^esub> P' c i,A' \<and>
	r \<subseteq> i \<and>
	i \<inter> b \<subseteq> pre P' \<and>
	i \<inter> -b \<subseteq> Q' \<and>
	Q' \<subseteq> Q \<and> A' \<subseteq> A)"
	apply (induct rule: oghoare_induct, simp_all)
	apply blast
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp
	apply (rename_tac P' Q' A' b ca r i P'' A'' Q'')
	apply (case_tac P; simp)
	apply (rule_tac x= A'' in exI)
	apply (rule conjI)
	apply blast
	apply clarsimp
	apply (rule_tac x= "Q'" in exI)
	by fast


	lemma oghoare_Call:
	"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow>
	\<forall>p. x = Call p \<longrightarrow>
	(\<exists>r n.
	P = (AnnCall r n) \<and>
	(\<exists>as P' f b.
	\<Theta> p = Some as \<and>
	(as ! n) = P' \<and>
	r \<subseteq> pre P' \<and>
	\<Gamma> p = Some b \<and>
	n < length as \<and>
	\<Gamma>,\<Theta> \<turnstile>\<^bsub>/F\<^esub> P' b Q,A))"
	apply (induct rule: oghoare_induct, simp_all)
	apply (rename_tac \<Gamma> \<Theta> F P c Q A)
	apply clarsimp
	apply (case_tac P, simp_all)
	apply clarsimp
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply force
	done

	lemma oghoare_Parallel[rule_format, OF _ refl]:
	"\<Gamma>, \<Theta>\<turnstile>\<^bsub>/F\<^esub> P x Q,A \<Longrightarrow> \<forall>cs. x = Parallel cs \<longrightarrow>
	(\<exists>as. P = AnnPar as \<and>
	length as = length cs \<and>
	\<Inter>(set (map postcond as)) \<subseteq> Q \<and>
	\<Union>(set (map abrcond as)) \<subseteq> A \<and>
	(\<forall>i<length cs. \<exists>Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (pres (as!i)) (cs!i) Q', A' \<and>
	Q' \<subseteq> postcond (as!i) \<and> A' \<subseteq> abrcond (as!i)) \<and>
	interfree \<Gamma> \<Theta> F as cs)"
	apply (induct rule: oghoare_induct, simp_all)
	apply clarsimp
	apply (drule_tac x=i in spec)
	apply fastforce
	apply clarsimp
	apply (case_tac P, simp_all)
	apply blast
	done

	lemma ann_matches_weaken[OF _ refl]:
	" ann_matches \<Gamma> \<Theta> X c \<Longrightarrow> X = (weaken_pre P P') \<Longrightarrow> ann_matches \<Gamma> \<Theta> P c"
	apply (induct arbitrary: P P' rule: ann_matches.induct)
	apply (case_tac P, simp_all, fastforce simp add: ann_matches.intros)+
	done


	lemma oghoare_seq_imp_ann_matches:
	" \<Gamma>,\<Theta>\<tturnstile>\<^bsub>/F\<^esub> P a c Q,A \<Longrightarrow> ann_matches \<Gamma> \<Theta> a c"
	apply (induct rule: oghoare_seq_induct, simp_all add: ann_matches.intros)
	apply (clarsimp, erule ann_matches_weaken)+
	done

	lemma oghoare_imp_ann_matches:
	" \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> a c Q,A \<Longrightarrow> ann_matches \<Gamma> \<Theta> a c"
	apply (induct rule: oghoare_induct, simp_all add: ann_matches.intros oghoare_seq_imp_ann_matches)
	apply (clarsimp, erule ann_matches_weaken)+
	done

	(* intros *)

	lemma SkipRule: "P \<subseteq> Q \<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnExpr P) Skip Q, A"
	apply (rule Conseq, simp)
	apply (rule exI, rule exI, rule exI)
	apply (rule conjI, rule Skip, auto)
	done

	lemma ThrowRule: "P \<subseteq> A \<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnExpr P) Throw Q, A"
	apply (rule Conseq, simp)
	apply (rule exI, rule exI, rule exI)
	apply (rule conjI, rule Throw, auto)
	done

	lemma BasicRule: "P \<subseteq> {s. (f s) \<in> Q} \<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnExpr P) (Basic f) Q, A"
	apply (rule Conseq, simp, rule exI[where x="{s. (f s) \<in> Q}"])
	apply (rule exI[where x=Q], rule exI[where x=A])
	apply simp
	apply (subgoal_tac "(P \<union> {s. f s \<in> Q}) = {s. f s \<in> Q}")
	apply (auto intro: Basic)
	done

	lemma SpecRule:
	"P \<subseteq> {s. (\<forall>t. (s, t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s, t) \<in> r)}
	\<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnExpr P) (Spec r) Q, A"
	apply (rule Conseq, simp, rule exI[where x="{s. (\<forall>t. (s, t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s, t) \<in> r) }"])
	apply (rule exI[where x=Q], rule exI[where x=A])
	apply simp
	apply (subgoal_tac "(P \<union> {s. (\<forall>t. (s, t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s, t) \<in> r)}) = {s. (\<forall>t. (s, t) \<in> r \<longrightarrow> t \<in> Q) \<and> (\<exists>t. (s, t) \<in> r)}")
	apply (auto intro: Spec)
	done

	lemma CondRule:
	"\<lbrakk> P \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>pre P\<^sub>1) \<and> (s\<notin>b \<longrightarrow> s\<in>pre P\<^sub>2)};
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A;
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A \<rbrakk>
	\<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnBin P P\<^sub>1 P\<^sub>2) (Cond b c\<^sub>1 c\<^sub>2) Q,A"
	by (auto intro: Cond)

	lemma WhileRule: "\<lbrakk> r \<subseteq> I; I \<inter> b \<subseteq> pre P; (I \<inter> -b) \<subseteq> Q;
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c I,A \<rbrakk>
	\<Longrightarrow> \<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnWhile r I P) (While b c) Q,A"
	by (simp add: While)

	lemma AwaitRule:
	"\<lbrakk>atom_com c ; \<Gamma>, \<Theta> \<tturnstile>\<^bsub>/F\<^esub>P a c Q,A ; (r \<inter> b) \<subseteq> P\<rbrakk> \<Longrightarrow>
	\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> (AnnRec r a) (Await b c) Q,A"
	apply (erule Await[rotated])
	apply (erule (1) SeqConseq, simp+)
	done

	lemma rtranclp_1n_induct [consumes 1, case_names base step]:
	"\<lbrakk>r\<^sup>\<^sup> a b; P a; \<And>y z. \<lbrakk>r y z; r\<^sup>\<^sup> z b; P y\<rbrakk> \<Longrightarrow> P z\<rbrakk> \<Longrightarrow> P b"
	by (induct rule: rtranclp.induct)
	(simp add: rtranclp.rtrancl_into_rtrancl)+

	lemmas rtranclp_1n_induct2[consumes 1, case_names base step] =
	rtranclp_1n_induct[of _ "(ax,ay)" "(bx,by)", split_rule]

	lemma oghoare_seq_valid:
	" \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c\<^sub>1 R,A \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> R c\<^sub>2 Q,A \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P Seq c\<^sub>1 c\<^sub>2 Q,A"
	apply (clarsimp simp add: valid_def)
	apply (rename_tac t c' s)
	apply (case_tac t)
	apply simp
	apply (drule (1) Seq_decomp_star)
	apply (erule disjE)
	apply fastforce
	apply clarsimp
	apply (rename_tac s1 t')
	apply (drule_tac x="Normal s" and y="Normal t'" in spec2)
	apply (erule_tac x="Skip" in allE)
	apply (fastforce simp: final_def)
	apply (clarsimp simp add: final_def)
	apply (drule Seq_decomp_star_Fault)
	apply (erule disjE)
	apply (rename_tac s2)
	apply (drule_tac x="Normal s" and y="Fault s2" in spec2)
	apply (erule_tac x="Skip" in allE)
	apply fastforce
	apply clarsimp
	apply (rename_tac s s2 s')
	apply (drule_tac x="Normal s" and y="Normal s'" in spec2)
	apply (erule_tac x="Skip" in allE)
	apply clarsimp
	apply (drule_tac x="Normal s'" and y="Fault s2" in spec2)
	apply (erule_tac x="Skip" in allE)
	apply clarsimp
	apply clarsimp
	apply (simp add: final_def)
	apply (drule Seq_decomp_star_Stuck)
	apply (erule disjE)
	apply fastforce
	apply clarsimp
	apply fastforce
	done

	lemma oghoare_if_valid:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,A \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A \<Longrightarrow>
	r \<inter> b \<subseteq> P\<^sub>1 \<Longrightarrow> r \<inter> - b \<subseteq> P\<^sub>2 \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> r Cond b c\<^sub>1 c\<^sub>2 Q,A"
	apply (simp (no_asm) add: valid_def)
	apply (clarsimp)
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply (erule step_Normal_elim_cases)
	apply (fastforce simp: valid_def[where c=c\<^sub>1])
	apply (fastforce simp: valid_def[where c=c\<^sub>2])
	done

	lemma Skip_normal_steps_end:
	"\<Gamma> \<turnstile> (Skip, Normal s) \<rightarrow>\<^sup>* (c, s') \<Longrightarrow> c = Skip \<and> s' = Normal s"
	apply (erule converse_rtranclpE)
	apply simp
	apply (erule step_Normal_elim_cases)
	done

	lemma Throw_normal_steps_end:
	"\<Gamma> \<turnstile> (Throw, Normal s) \<rightarrow>\<^sup>* (c, s') \<Longrightarrow> c = Throw \<and> s' = Normal s"
	apply (erule converse_rtranclpE)
	apply simp
	apply (erule step_Normal_elim_cases)
	done

	lemma while_relpower_induct:
	"\<And>t c' x .
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c i,A \<Longrightarrow>
	i \<inter> b \<subseteq> P \<Longrightarrow>
	i \<inter> - b \<subseteq> Q \<Longrightarrow>
	final (c', t) \<Longrightarrow>
	x \<in> i \<Longrightarrow>
	t \<notin> Fault ` F \<Longrightarrow>
	c' = Throw \<longrightarrow> t \<notin> Normal ` A \<Longrightarrow>
	(step \<Gamma> ^^ n) (While b c, Normal x) (c', t) \<Longrightarrow> c' = Skip \<and> t \<in> Normal ` Q"
	apply (induct n rule:less_induct)
	apply (rename_tac n t c' x)
	apply (case_tac n)
	apply (clarsimp simp: final_def)
	apply clarify
	apply (simp only: relpowp.simps)
	apply (subst (asm) relpowp_commute[symmetric])
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply clarsimp
	apply (rename_tac t c' x v)
	apply(case_tac "t")
	apply clarsimp
	apply(drule Seq_decomp_relpow)
	apply(simp add: final_def)
	apply(erule disjE, erule conjE)
	apply clarify
	apply(drule relpowp_imp_rtranclp)
	apply (simp add: valid_def)
	apply (rename_tac x n t' n1)
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="Normal t'" in spec)
	apply (drule spec[where x=Throw])
	apply (fastforce simp add: final_def)
	apply clarsimp
	apply (rename_tac c' x n t' t n1 n2)
	apply (drule_tac x=n2 and y="Normal t'" in meta_spec2)
	apply (drule_tac x=c' and y="t" in meta_spec2)
	apply (erule meta_impE, fastforce)
	apply (erule meta_impE, fastforce)
	apply (erule meta_impE)
	apply(drule relpowp_imp_rtranclp)
	apply (simp add: valid_def)
	apply (drule_tac x="Normal x" and y="Normal t" in spec2)
	apply (drule spec[where x=Skip])
	apply (fastforce simp add: final_def)
	apply assumption
	apply clarsimp
	apply (rename_tac c' s n f)
	apply (subgoal_tac "c' = Skip", simp)
	prefer 2
	apply (case_tac c'; fastforce simp: final_def)
	apply (drule Seq_decomp_relpowp_Fault)
	apply (erule disjE)
	apply (clarsimp simp: valid_def)
	apply (drule_tac x="Normal s" and y="Fault f" in spec2)
	apply (drule spec[where x=Skip])
	apply(drule relpowp_imp_rtranclp)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (rename_tac t n1 n2)
	apply (subgoal_tac "t \<in> i")
	prefer 2
	apply (fastforce dest:relpowp_imp_rtranclp simp: final_def valid_def)
	apply (drule_tac x=n2 in meta_spec)
	apply (drule_tac x="Fault f" in meta_spec)
	apply (drule meta_spec[where x=Skip])
	apply (drule_tac x=t in meta_spec)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (rename_tac c' s n)
	apply (subgoal_tac "c' = Skip", simp)
	prefer 2
	apply (case_tac c'; fastforce simp: final_def)
	apply (drule Seq_decomp_relpowp_Stuck)
	apply clarsimp
	apply (erule disjE)
	apply (simp add:valid_def)
	apply (drule_tac x="Normal s" and y="Stuck" in spec2)
	apply clarsimp
	apply (drule spec[where x=Skip])
	apply(drule relpowp_imp_rtranclp)
	apply (fastforce)
	apply clarsimp
	apply (rename_tac t n1 n2)
	apply (subgoal_tac "t \<in> i")
	prefer 2
	apply (fastforce dest:relpowp_imp_rtranclp simp: final_def valid_def)
	apply (drule_tac x=n2 in meta_spec)
	apply (drule meta_spec[where x=Stuck])
	apply (drule meta_spec[where x=Skip])
	apply (drule_tac x=t in meta_spec)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (drule relpowp_imp_rtranclp)
	apply (drule Skip_normal_steps_end)
	apply fastforce
	done

	lemma valid_weaken_pre:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
	P' \<subseteq> P \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P' c Q,A"
	by (fastforce simp: valid_def)

	lemma valid_strengthen_post:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
	Q \<subseteq> Q' \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q',A"
	by (fastforce simp: valid_def)

	lemma valid_strengthen_abr:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A \<Longrightarrow>
	A \<subseteq> A' \<Longrightarrow> \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c Q,A'"
	by (fastforce simp: valid_def)

	lemma oghoare_while_valid:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P c i,A \<Longrightarrow>
	i \<inter> b \<subseteq> P \<Longrightarrow>
	i \<inter> - b \<subseteq> Q \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> i While b c Q,A"
	apply (simp (no_asm) add: valid_def)
	apply (clarsimp simp add: )
	apply (drule rtranclp_imp_relpowp)
	apply (clarsimp)
	by (erule while_relpower_induct)

	lemma oghoare_catch_valid:
	"\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P\<^sub>1 c\<^sub>1 Q,P\<^sub>2 \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P\<^sub>2 c\<^sub>2 Q,A \<Longrightarrow>
	\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> P\<^sub>1 Catch c\<^sub>1 c\<^sub>2 Q,A"
	apply (clarsimp simp add: valid_def[where c="Catch _ _"])
	apply (rename_tac t c' s)
	apply (case_tac t)
	apply simp
	apply (drule Catch_decomp_star)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (erule disjE)
	apply (clarsimp simp add: valid_def[where c="c\<^sub>1"])
	apply (rename_tac s x t)
	apply (drule_tac x="Normal s" in spec)
	apply (drule_tac x="Normal t" in spec)
	apply (drule_tac x=Throw in spec)
	apply (fastforce simp: final_def valid_def)
	apply (clarsimp simp add: valid_def[where c="c\<^sub>1"])
	apply (rename_tac s t)
	apply (drule_tac x="Normal s" in spec)
	apply (drule_tac x="Normal t" in spec)
	apply (drule_tac x=Skip in spec)
	apply (fastforce simp: final_def)
	apply (rename_tac c' s t)
	apply (simp add: final_def)
	apply (drule Catch_decomp_star_Fault)
	apply clarsimp
	apply (erule disjE)
	apply (clarsimp simp: valid_def[where c=c\<^sub>1] final_def)
	apply (fastforce simp: valid_def final_def)
	apply (simp add: final_def)
	apply (drule Catch_decomp_star_Stuck)
	apply clarsimp
	apply (erule disjE)
	apply (clarsimp simp: valid_def[where c=c\<^sub>1] final_def)
	apply (fastforce simp: valid_def final_def)
	done

	lemma ann_matches_imp_assertionsR:
	"ann_matches \<Gamma> \<Theta> a c \<Longrightarrow> \<not> pre_par a \<Longrightarrow>
	assertionsR \<Gamma> \<Theta> Q A a c (pre a)"
	by (induct arbitrary: Q A rule: ann_matches.induct , (fastforce intro: assertionsR.intros )+)

	lemma ann_matches_imp_assertionsR':
	"ann_matches \<Gamma> \<Theta> a c \<Longrightarrow> a' \<in> pre_set a \<Longrightarrow>
	assertionsR \<Gamma> \<Theta> Q A a c a'"
	apply (induct arbitrary: Q A rule: ann_matches.induct)
	apply ((fastforce intro: assertionsR.intros )+)[12]
	apply simp
	apply (erule bexE)
	apply (simp only: in_set_conv_nth)
	apply (erule exE)
	apply (drule_tac x=i in spec)
	apply clarsimp
	apply (erule AsParallelExprs)
	apply simp
	done

	lemma rtranclp_conjD:
	"(\<lambda>x1 x2. r1 x1 x2 \<and> r2 x1 x2)\<^sup>\<^sup> x1 x2 \<Longrightarrow>
	r1\<^sup>\<^sup> x1 x2 \<and> r2\<^sup>\<^sup> x1 x2"
	by (metis (no_types, lifting) rtrancl_mono_proof)

	lemma rtranclp_mono' :
	"r\<^sup>\<^sup> a b \<Longrightarrow> r \<le> s \<Longrightarrow> s\<^sup>\<^sup> a b"
	by (metis rtrancl_mono_proof sup.orderE sup2CI)

	lemma state_upd_in_atomicsR[rule_format, OF _ refl refl]:
	"\<Gamma>\<turnstile> cf \<rightarrow> cf' \<Longrightarrow>
	cf = (c, Normal s) \<Longrightarrow>
	cf' = (c', Normal t) \<Longrightarrow>
	s \<noteq> t \<Longrightarrow>
	ann_matches \<Gamma> \<Theta> a c \<Longrightarrow>
	s \<in> pre a \<Longrightarrow>
	(\<exists>p cm x. atomicsR \<Gamma> \<Theta> a c (p, cm) \<and> s \<in> p \<and>
	\<Gamma> \<turnstile> (cm, Normal s) \<rightarrow> (x, Normal t) \<and> final (x, Normal t))"
	supply [[simproc del: defined_all]]
	apply (induct arbitrary: c c' s t a rule: step.induct, simp_all)
	apply clarsimp
	apply (erule ann_matches.cases, simp_all)
	apply (rule exI)+
	apply (rule conjI)
	apply (rule atomicsR.intros)
	apply clarsimp
	apply (rule_tac x="Skip" in exI)
	apply (simp add: final_def)
	apply (rule step.Basic)
	apply clarsimp
	apply (erule ann_matches.cases, simp_all)
	apply (rule exI)+
	apply (rule conjI)
	apply (rule atomicsR.intros)
	apply clarsimp
	apply (rule_tac x="Skip" in exI)
	apply (simp add: final_def)
	apply (erule step.Spec)
	apply clarsimp
	apply (erule ann_matches.cases, simp_all)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply clarsimp
	apply (erule (1) meta_impE)
	apply (erule meta_impE, fastforce)
	apply clarsimp
	apply (rule exI)+
	apply (rule conjI)
	apply (erule AtSeqExpr1)
	apply fastforce
	apply clarsimp
	apply (erule ann_matches.cases, simp_all)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply clarsimp
	apply (erule (1) meta_impE)
	apply (erule meta_impE, fastforce)
	apply clarsimp
	apply (rule exI)+
	apply (rule conjI)
	apply (erule AtCatchExpr1)
	apply fastforce
	apply (erule ann_matches.cases, simp_all)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply clarsimp
	apply (erule meta_impE)
	apply fastforce
	apply (erule meta_impE)
	apply (case_tac "i=0"; fastforce)
	apply clarsimp
	apply (rule exI)+
	apply (rule conjI)
	apply (erule AtParallelExprs)
	apply fastforce
	apply (drule_tac x=i in spec)
	apply clarsimp
	apply fastforce
	apply (erule ann_matches.cases, simp_all)
	apply clarsimp
	apply (rule exI)+
	apply (rule conjI)
	apply (rule AtAwait)
	apply clarsimp
	apply (rename_tac c' sa t aa e r ba)
	apply (rule_tac x=c' in exI)
	apply (rule conjI)
	apply (erule step.Await)
	apply (erule rtranclp_mono')
	apply clarsimp
	apply assumption+
	apply (simp add: final_def)
	done

	lemma oghoare_atom_com_sound:
	"\<Gamma>, \<Theta> \<tturnstile>\<^bsub>/F\<^esub>P a c Q,A \<Longrightarrow> atom_com c \<Longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> P c Q, A"
	unfolding valid_def
	proof (induct rule: oghoare_seq_induct)
	case SeqSkip thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases(1))
	next
	case SeqThrow thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases)
	next
	case SeqBasic thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases
	simp: final_def)
	next
	case (SeqSpec \<Gamma> \<Theta> F r Q A) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply (erule step_Normal_elim_cases)
	apply (fastforce elim!: converse_rtranclpE step_Normal_elim_cases)
	by clarsimp
	next
	case (SeqSeq \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 P\<^sub>2 A c\<^sub>2 Q) show ?case
	using SeqSeq
	by (fold valid_def)
	(fastforce intro: oghoare_seq_valid simp: valid_weaken_pre)
	next
	case (SeqCatch \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 Q P\<^sub>2 c\<^sub>2 A) thus ?case
	apply (fold valid_def)
	apply simp
	apply (fastforce elim: oghoare_catch_valid)+
	done
	next
	case (SeqCond \<Gamma> \<Theta> F P b c1 Q A c2) thus ?case
	by (fold valid_def)
	(fastforce intro:oghoare_if_valid)
	next
	case (SeqWhile \<Gamma> \<Theta> F P c A b) thus ?case
	by (fold valid_def)
	(fastforce elim: valid_weaken_pre[rotated] oghoare_while_valid)
	next
	case (SeqGuard \<Gamma> \<Theta> F P c Q A r g f) thus ?case
	apply (fold valid_def)
	apply (simp (no_asm) add: valid_def)
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply (fastforce dest: no_steps_final simp:final_def)
	apply (fastforce dest: no_steps_final simp:final_def)
	done
	next
	case (SeqCall \<Gamma> p f \<Theta> F P Q A) thus ?case
	by simp
	next

	case (SeqDynCom r fa \<Gamma> \<Theta> F P c Q A) thus ?case
	apply -
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply clarsimp
	apply (rename_tac t c' x)

	apply (drule_tac x=x in spec)
	apply (drule_tac x=x in bspec, fastforce)
	apply clarsimp
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="t" in spec)
	apply (drule_tac x="c'" in spec)
	apply fastforce+
	done
	next
	case (SeqConseq \<Gamma> \<Theta> F P c Q A) thus ?case
	apply (clarsimp)
	apply (rename_tac t c' x)
	apply (erule_tac x="Normal x" in allE)
	apply (erule_tac x="t" in allE)
	apply (erule_tac x="c'" in allE)
	apply (clarsimp simp: pre_weaken_pre)
	apply force
	done
	qed simp_all

	lemma ParallelRuleAnn:
	" length as = length cs \<Longrightarrow>
	\<forall>i<length cs. \<Gamma>,\<Theta> \<turnstile>\<^bsub>/F \<^esub>(pres (as ! i)) (cs ! i) (postcond (as ! i)),(abrcond (as ! i)) \<Longrightarrow>
	interfree \<Gamma> \<Theta> F as cs \<Longrightarrow>
	\<Inter>(set (map postcond as)) \<subseteq> Q \<Longrightarrow>
	\<Union>(set (map abrcond as)) \<subseteq> A \<Longrightarrow> \<Gamma>,\<Theta> \<turnstile>\<^bsub>/F \<^esub>(AnnPar as) (Parallel cs) Q,A"
	apply (erule (3) Parallel)
	apply auto
	done

	lemma oghoare_step[rule_format, OF _ refl refl]:
	shows
	"\<Gamma> \<turnstile> cf \<rightarrow> cf' \<Longrightarrow> cf = (c, Normal s) \<Longrightarrow> cf' = (c', Normal t) \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>a c Q,A \<Longrightarrow>
	s \<in> pre a \<Longrightarrow>
	\<exists>a'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>a' c' Q,A \<and> t \<in> pre a' \<and>
	(\<forall>as. assertionsR \<Gamma> \<Theta> Q A a' c' as \<longrightarrow> assertionsR \<Gamma> \<Theta> Q A a c as) \<and>
	(\<forall>pm cm. atomicsR \<Gamma> \<Theta> a' c' (pm, cm) \<longrightarrow> atomicsR \<Gamma> \<Theta> a c (pm, cm))"
	proof (induct arbitrary:c c' s a t Q A rule: step.induct)
	case (Parallel i cs s c' s' ca c'a sa a t Q A) thus ?case
	supply [[simproc del: defined_all]]
	apply (clarsimp simp:)
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac as)
	apply (frule_tac x=i in spec, erule (1) impE)
	apply (elim exE conjE)


	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply (erule meta_impE)
	apply (rule_tac P="(pres (as ! i))" in Conseq)
	apply (rule exI[where x="{}"])
	apply (rule_tac x="Q'" in exI)
	apply (rule_tac x="A'" in exI)
	apply (simp)
	apply (erule meta_impE, simp)
	apply clarsimp
	apply (rule_tac x="AnnPar (as[i:=(a',postcond(as!i), abrcond(as!i))])" in exI)
	apply (rule conjI)
	apply (rule ParallelRuleAnn, simp)
	apply clarsimp
	apply (rename_tac j)
	apply (drule_tac x=j in spec)
	apply clarsimp
	apply (case_tac "i = j")
	apply (clarsimp simp: )
	apply (rule Conseq)
	apply (rule exI[where x="{}"])
	apply (fastforce)
	- apply (simp add: )
	+ apply simp
	apply (clarsimp simp: interfree_def)
	apply (rename_tac i' j')
	apply (drule_tac x=i' and y=j' in spec2)
	apply clarsimp
	apply (case_tac "i = i'")
	apply clarsimp
	apply (simp add: interfree_aux_def prod.case_eq_if )
	apply clarsimp
	apply (case_tac "j' = i")
	apply (clarsimp)
	apply (simp add: interfree_aux_def prod.case_eq_if)
	apply clarsimp
	apply (clarsimp)
	apply (erule subsetD)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac a' x a b c i')
	apply (case_tac "i' = i")
	apply clarsimp
	apply (drule_tac x="(a', b, c)" in bspec, simp)
	apply (fastforce simp add: in_set_conv_nth)
	apply fastforce
	apply (drule_tac x="(a, b, c)" in bspec, simp)
	apply (simp add: in_set_conv_nth)
	apply (rule_tac x=i' in exI)
	apply clarsimp
	apply fastforce
	apply clarsimp
	apply (erule_tac A="(\<Union>x\<in>set as. abrcond x) " in subsetD)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac a b c j)
	apply (case_tac "j = i")
	apply clarsimp
	apply (rule_tac x="as!i" in bexI)
	apply simp
	apply clarsimp
	apply clarsimp
	apply (rule_tac x="(a,b,c)" in bexI)
	apply simp
	apply (clarsimp simp:in_set_conv_nth)
	apply (rule_tac x=j in exI)
	apply fastforce
	apply (rule conjI)
	apply (case_tac "s = Normal t")
	apply clarsimp
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac a b c j)
	apply (case_tac "j = i")
	apply clarsimp
	apply clarsimp
	apply (drule_tac x="as!j" in bspec)
	apply (clarsimp simp add: in_set_conv_nth)
	apply (rule_tac x=j in exI)
	apply fastforce
	apply clarsimp
	apply (frule state_upd_in_atomicsR, simp)
	apply (erule oghoare_imp_ann_matches)
	apply (clarsimp simp: in_set_conv_nth)
	apply fastforce
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac j)
	apply (case_tac "j = i")
	apply clarsimp
	apply clarsimp
	apply (thin_tac "\<Gamma>,\<Theta> \<turnstile>\<^bsub>/F \<^esub>a' c' (postcond (as ! i)),(abrcond (as ! i))")
	apply (simp add: interfree_def interfree_aux_def)
	apply (drule_tac x="j" and y=i in spec2)
	apply (simp add: prod.case_eq_if)
	apply (drule spec2, drule (1) mp)
	apply clarsimp
	apply (case_tac "pre_par a")
	apply (subst pre_set)
	apply clarsimp
	apply (drule_tac x="as!j" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=j in exI)
	apply fastforce
	apply clarsimp
	apply (frule (1) pre_imp_pre_set)
	apply (rename_tac as Q' A' a' a b c p cm x j X)
	apply (drule_tac x="X" in spec, erule_tac P="assertionsR \<Gamma> \<Theta> b c a (cs ! j) X" in impE)
	apply (rule ann_matches_imp_assertionsR')
	apply (drule_tac x=j in spec, clarsimp)
	apply (erule (1) oghoare_imp_ann_matches)
	apply (rename_tac a b c p cm x j X )
	apply (thin_tac "\<Gamma>\<Turnstile>\<^bsub>/F\<^esub> (b \<inter> p) cm b,b")
	apply (thin_tac " \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> (c \<inter> p) cm c,c")
	apply (simp add: valid_def)
	apply (drule_tac x="Normal sa" in spec)
	apply (drule_tac x="Normal t" in spec)
	apply (drule_tac x=x in spec)
	apply (erule impE, fastforce)
	apply force

	apply (drule_tac x=j in spec)
	apply clarsimp
	apply (rename_tac a b c p cm x j Q'' A'')
	apply (drule_tac x="pre a" in spec,erule impE, rule ann_matches_imp_assertionsR)
	apply (erule (1) oghoare_imp_ann_matches)
	apply (thin_tac " \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> (b \<inter> p) cm b,b")
	apply (thin_tac " \<Gamma>\<Turnstile>\<^bsub>/F\<^esub> (c \<inter> p) cm c,c")
	apply (simp add: valid_def)
	apply (drule_tac x="Normal sa" in spec)
	apply (drule_tac x="Normal t" in spec)
	apply (drule_tac x=x in spec)
	apply (erule impE, fastforce)
	apply clarsimp
	apply (drule_tac x="as ! j" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=j in exI, fastforce)
	apply clarsimp
	apply fastforce
	apply (rule conjI)
	apply (clarsimp simp: )
	apply (erule assertionsR.cases ; simp)
	apply (clarsimp simp: )
	apply (rename_tac j a)
	apply (case_tac "j = i")
	apply clarsimp
	apply (drule_tac x=a in spec, erule (1) impE)
	apply (erule (1) AsParallelExprs)
	apply (subst (asm) nth_list_update_neq, simp)
	apply (erule_tac i=j in AsParallelExprs)
	apply fastforce
	apply clarsimp
	apply (rule AsParallelSkips)
	apply (clarsimp simp:)
	apply (rule equalityI)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac a' x a b c j)
	apply (case_tac "j = i")
	apply (thin_tac "\<forall>a\<in>set as. sa \<in> precond a")
	apply clarsimp
	apply (drule_tac x="(a', b, c)" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x="i" in exI)
	apply fastforce
	apply fastforce
	apply (drule_tac x="as ! j" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=j in exI)
	apply fastforce
	apply clarsimp
	apply (drule_tac x=" as ! j" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=j in exI, fastforce)
	apply fastforce
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac x a b c j)
	apply (thin_tac "\<forall>a\<in>set as. sa \<in> precond a")
	apply (case_tac "j = i")
	apply clarsimp
	apply (drule_tac x="as!i" in bspec, fastforce)
	apply fastforce
	apply clarsimp
	apply (drule_tac x="as!j" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=j in exI, fastforce)
	apply fastforce
	apply clarsimp
	apply (erule atomicsR.cases ; simp)
	apply clarsimp
	apply (rename_tac j atc atp)
	apply (case_tac "j = i")
	apply clarsimp
	apply (drule_tac x=atc and y=atp in spec2, erule impE)
	apply (clarsimp)
	apply (erule (1) AtParallelExprs)
	apply (subst (asm) nth_list_update_neq, simp)
	apply (erule_tac i=j in AtParallelExprs)
	apply (clarsimp)
	done
	next
	case (Basic f s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Basic)
	apply clarsimp
	apply (rule_tac x="AnnExpr Q" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule SkipRule)
	apply fastforce
	apply (rule conjI)
	apply fastforce
	apply clarsimp
	apply (drule assertionsR.cases, simp_all)
	apply (rule assertionsR.AsBasicSkip)
	done
	next
	case (Spec s t r c c' sa a ta Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Spec)
	apply clarsimp
	apply (rule_tac x="AnnExpr Q" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule SkipRule)
	apply fastforce
	apply (rule conjI)
	apply force
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rule assertionsR.AsSpecSkip)
	done
	next
	case (Guard s g f c ca c' sa a t Q A) thus ?case
	apply -
	apply clarsimp
	apply (drule oghoare_Guard)
	apply clarsimp
	apply (rule exI, rule conjI, assumption)
	by (fastforce dest: oghoare_Guard
	intro:assertionsR.intros atomicsR.intros)
	next
	case (GuardFault s g f c ca c' sa a t Q A) thus ?case
	by (fastforce dest: oghoare_Guard
	intro:assertionsR.intros atomicsR.intros)
	next
	case (Seq c\<^sub>1 s c\<^sub>1' s' c\<^sub>2 c c' sa a t A Q) thus ?case
	supply [[simproc del: defined_all]]
	apply (clarsimp simp:)
	apply (drule oghoare_Seq)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply (erule meta_impE)
	apply (rule Conseq)
	apply (rule exI[where x="{}"])
	apply (rule exI)+
	apply (rule conjI)
	apply (simp)
	apply (erule (1) conjI)
	apply clarsimp
	apply (rule_tac x="AnnComp a' P\<^sub>2" in exI, rule conjI)
	apply (rule oghoare_oghoare_seq.Seq)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	apply clarsimp
	apply (rule conjI)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (drule_tac x=a in spec, simp)
	apply (erule AsSeqExpr1)
	apply clarsimp
	apply (erule AsSeqExpr2)
	apply clarsimp
	apply (erule atomicsR.cases, simp_all)
	apply clarsimp
	apply (drule_tac x="a" and y=b in spec2, simp)
	apply (erule AtSeqExpr1)
	apply clarsimp
	apply (erule AtSeqExpr2)
	done
	next
	case (SeqSkip c\<^sub>2 s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Seq)
	apply clarsimp
	apply (rename_tac P\<^sub>1 P\<^sub>2 P' Q' A')
	apply (rule_tac x=P\<^sub>2 in exI)
	apply (rule conjI, rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	apply (rule conjI)
	apply (drule oghoare_Skip)
	apply fastforce
	apply (rule conjI)
	apply clarsimp
	apply (erule assertionsR.AsSeqExpr2)
	apply clarsimp
	apply (fastforce intro: atomicsR.intros)
	done
	next
	case (SeqThrow c\<^sub>2 s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Seq)
	apply clarsimp
	apply (rename_tac P\<^sub>1 P\<^sub>2 P' Q' A')
	apply (rule_tac x=P\<^sub>1 in exI)
	apply (drule oghoare_Throw)
	apply clarsimp
	apply (rename_tac P'')
	apply (rule conjI, rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (rule_tac x="Q'" in exI)
	apply (rule_tac x="P''" in exI)
	apply (fastforce intro: Throw)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rule AsSeqExpr1)
	apply (rule AsThrow)
	done
	next
	case (CondTrue s b c\<^sub>1 c\<^sub>2 c sa c' s' ann) thus ?case
	apply (clarsimp)
	apply (drule oghoare_Cond)
	apply clarsimp
	apply (rename_tac P' P\<^sub>1 P\<^sub>2 Q' A')
	apply (rule_tac x= P\<^sub>1 in exI)
	apply (rule conjI)
	apply (rule Conseq, rule_tac x="{}" in exI, fastforce)
	apply (rule conjI, fastforce)
	apply (rule conjI)
	apply (fastforce elim: assertionsR.cases intro: AsCondExpr1)
	apply (fastforce elim: atomicsR.cases intro: AtCondExpr1)
	done
	next
	case (CondFalse s b c\<^sub>1 c\<^sub>2 c sa c' s' ann) thus ?case
	apply (clarsimp)
	apply (drule oghoare_Cond)
	apply clarsimp
	apply (rename_tac P' P\<^sub>1 P\<^sub>2 Q' A')
	apply (rule_tac x= P\<^sub>2 in exI)
	apply (rule conjI)
	apply (rule Conseq, rule_tac x="{}" in exI, fastforce)
	apply (rule conjI, fastforce)
	apply (rule conjI)
	apply (fastforce elim: assertionsR.cases intro: AsCondExpr2)
	apply (fastforce elim: atomicsR.cases intro: AtCondExpr2)
	done
	next
	case (WhileTrue s b c ca sa c' s' ann) thus ?case
	apply clarsimp
	apply (frule oghoare_While)
	apply clarsimp
	apply (rename_tac r i P' A' Q')
	apply (rule_tac x="AnnComp P' (AnnWhile i i P')" in exI)
	apply (rule conjI)
	apply (rule Seq)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (rule_tac x="i" in exI)
	apply (rule_tac x="A'" in exI)
	apply (subst weaken_pre_empty)
	apply clarsimp
	apply (rule While)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (rule_tac x="i" in exI)
	apply (rule_tac x="A'" in exI)
	apply (subst weaken_pre_empty)
	apply clarsimp
	apply clarsimp
	apply force
	apply simp
	apply simp
	apply (rule conjI)
	apply blast
	apply (rule conjI)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rule AsWhileExpr)
	apply clarsimp
	apply (erule assertionsR.cases,simp_all)
	apply clarsimp
	apply (erule AsWhileExpr)
	apply clarsimp
	apply (rule AsWhileInv)
	apply clarsimp
	apply (rule AsWhileInv)
	apply clarsimp
	apply (rule AsWhileSkip)
	apply clarsimp
	apply (erule atomicsR.cases, simp_all)
	apply clarsimp
	apply (rule AtWhileExpr)
	apply clarsimp+
	apply (erule atomicsR.cases, simp_all)
	apply clarsimp
	apply (erule AtWhileExpr)
	done
	next
	case (WhileFalse s b c ca sa c' ann s' Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_While)
	apply clarsimp
	apply (rule_tac x="AnnExpr Q" in exI)
	apply (rule conjI)
	apply (rule SkipRule)
	apply blast
	apply (rule conjI)
	apply fastforce
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply (drule sym, simp, rule AsWhileSkip)
	done
	next
	case (Call p bs s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Call)
	apply clarsimp
	apply (rename_tac n as)
	apply (rule_tac x="as ! n" in exI)
	apply clarsimp
	apply (rule conjI, fastforce)
	apply (rule conjI)
	apply clarsimp
	apply (erule (2) AsCallExpr)
	apply fastforce
	apply clarsimp
	apply (erule (2) AtCallExpr)
	apply simp
	done
	next
	case (DynCom c s ca c' sa a t Q A) thus ?case
	apply -
	apply clarsimp
	apply (drule oghoare_DynCom)
	apply clarsimp
	apply (drule_tac x=t in bspec, assumption)
	apply (rule exI)
	apply (erule conjI)
	apply (rule conjI, fastforce)
	apply (rule conjI)
	apply clarsimp
	apply (erule (1) AsDynComExpr)
	apply (clarsimp)
	apply (erule (1) AtDynCom)
	done
	next
	case (Catch c\<^sub>1 s c\<^sub>1' s' c\<^sub>2 c c' sa a t Q A) thus ?case
	supply [[simproc del: defined_all]]
	apply (clarsimp simp:)
	apply (drule oghoare_Catch)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply (erule meta_impE)
	apply (rule Conseq)
	apply (rule exI[where x="{}"])
	apply (rule exI)+
	apply (rule conjI)
	apply (simp)
	apply (erule (1) conjI)
	apply clarsimp
	apply (rename_tac P\<^sub>1 P\<^sub>2 P' Q' A' a')
	apply (rule_tac x="AnnComp a' P\<^sub>2" in exI, rule conjI)
	apply (rule oghoare_oghoare_seq.Catch)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce)
	apply clarsimp
	apply (rule conjI)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rename_tac a)
	apply (drule_tac x=a in spec, simp)
	apply (erule AsCatchExpr1)
	apply clarsimp
	apply (erule AsCatchExpr2)
	apply clarsimp
	apply (erule atomicsR.cases, simp_all)
	apply clarsimp
	apply (rename_tac a b a2)
	apply (drule_tac x="a" and y=b in spec2, simp)
	apply (erule AtCatchExpr1)
	apply clarsimp
	apply (erule AtCatchExpr2)
	done
	next
	case (CatchSkip c\<^sub>2 s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Catch, clarsimp)
	apply (rename_tac P\<^sub>1 P\<^sub>2 P' Q' A')
	apply (rule_tac x=P\<^sub>1 in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (drule oghoare_Skip)
	apply clarsimp
	apply (rule_tac x=Q' in exI)
	apply (rule_tac x=A' in exI)
	apply (rule conjI, erule SkipRule)
	apply clarsimp
	apply clarsimp
	apply (rule AsCatchExpr1)
	apply (erule assertionsR.cases, simp_all)
	apply (rule assertionsR.AsSkip)
	done
	next
	case (CatchThrow c\<^sub>2 s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Catch, clarsimp)
	apply (rename_tac P\<^sub>1 P\<^sub>2 P' Q' A')
	apply (rule_tac x=P\<^sub>2 in exI)
	apply (rule conjI)
	apply (rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (fastforce )
	apply (rule conjI)
	apply (drule oghoare_Throw)
	apply clarsimp
	apply fastforce
	apply (rule conjI)
	apply (clarsimp)
	apply (erule AsCatchExpr2)
	apply clarsimp
	apply (erule AtCatchExpr2)
	done
	next
	case (ParSkip cs s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac as)

	apply (rule_tac x="AnnExpr (\<Inter>x\<in>set as. postcond x)" in exI)
	apply (rule conjI, rule SkipRule)
	apply blast
	apply (rule conjI)
	apply simp
	apply clarsimp
	apply (simp only: in_set_conv_nth)
	apply clarsimp
	apply (drule_tac x="i" in spec)
	apply clarsimp
	apply (drule_tac x="cs!i" in bspec)
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_Skip)
	apply clarsimp
	apply (drule_tac x="as!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=i in exI, fastforce)
	apply clarsimp
	apply blast
	apply clarsimp
	apply (erule assertionsR.cases; simp)
	apply clarsimp
	apply (rule AsParallelSkips; clarsimp)
	done
	next
	case (ParThrow cs s c c' sa a t Q A) thus ?case
	apply clarsimp
	apply (drule oghoare_Parallel)
	apply (clarsimp simp: in_set_conv_nth)
	apply (drule_tac x=i in spec)
	apply clarsimp
	apply (drule oghoare_Throw)
	apply clarsimp
	apply (rename_tac i as Q' A' P')
	apply (rule_tac x="AnnExpr P'" in exI)
	apply (rule conjI)
	apply (rule ThrowRule)
	apply clarsimp
	apply (erule_tac A="(\<Union>x\<in>set as. abrcond x)" in subsetD[where B=A], force)
	apply (rule conjI)
	apply (drule_tac x="as!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=i in exI, fastforce)
	apply (fastforce)
	apply clarsimp
	apply (erule AsParallelExprs)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply (rule AsThrow)
	done
	next
	case (Await x b c c' x' c'' c''' x'' a x''' Q A) thus ?case
	apply (clarsimp)
	apply (drule oghoare_Await)
	apply clarsimp

	apply (drule rtranclp_conjD)
	apply clarsimp
	apply (erule disjE)
	apply clarsimp
	apply (rename_tac P' Q' A')
	apply (rule_tac x="AnnExpr Q" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule Skip)
	apply (rule conjI)
	apply (drule (1) oghoare_atom_com_sound)
	apply (fastforce simp: final_def valid_def)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rule AsAwaitSkip)

	apply (rule_tac x="AnnExpr A" in exI)
	apply clarsimp
	apply (rule conjI)
	apply (rule Throw)
	apply (rule conjI)
	apply (drule (1) oghoare_atom_com_sound)
	apply (fastforce simp: final_def valid_def)
	apply clarsimp
	apply (erule assertionsR.cases, simp_all)
	apply clarsimp
	apply (rule AsAwaitThrow)
	done
	qed simp_all

	lemma oghoare_steps[rule_format, OF _ refl refl]:
	"\<Gamma> \<turnstile> cf \<rightarrow>\<^sup>* cf' \<Longrightarrow> cf = (c, Normal s) \<Longrightarrow> cf' = (c', Normal t) \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>a c Q,A \<Longrightarrow>
	s \<in> pre a \<Longrightarrow>
	\<exists>a'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>a' c' Q,A \<and> t \<in> pre a' \<and>
	(\<forall>as. assertionsR \<Gamma> \<Theta> Q A a' c' as \<longrightarrow> assertionsR \<Gamma> \<Theta> Q A a c as) \<and>
	(\<forall>pm cm. atomicsR \<Gamma> \<Theta> a' c' (pm, cm) \<longrightarrow> atomicsR \<Gamma> \<Theta> a c (pm, cm))"
	apply (induct arbitrary: a c s c' t rule: converse_rtranclp_induct)
	supply [[simproc del: defined_all]]
	apply fastforce
	apply clarsimp
	apply (frule Normal_pre_star)
	apply clarsimp
	apply (drule (2) oghoare_step)
	apply clarsimp
	apply ((drule meta_spec)+, (erule meta_impE, rule conjI, (rule refl)+)+)
	apply (erule (1) meta_impE)+
	apply clarsimp
	apply (rule exI)
	apply (rule conjI, fastforce)+
	apply force
	done

	lemma oghoare_sound_Parallel_Normal_case[rule_format, OF _ refl refl]:
	"\<Gamma> \<turnstile> (c, s) \<rightarrow>\<^sup>* (c', t) \<Longrightarrow>
	\<forall>P x y cs. c = Parallel cs \<longrightarrow> s = Normal x \<longrightarrow>
	t = Normal y \<longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<longrightarrow> final (c', t) \<longrightarrow>
	x \<in> pre P \<longrightarrow> t \<notin> Fault ` F \<longrightarrow> (c' = Throw \<and> t \<in> Normal ` A) \<or> (c' = Skip \<and> t \<in> Normal ` Q)"
	apply(erule converse_rtranclp_induct2)
	apply (clarsimp simp: final_def)
	apply(erule step.cases, simp_all)
	\<comment> \<open>Parallel\<close>
	apply clarsimp
	apply (frule Normal_pre_star)
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac i cs c1' x y s' as)
	apply (subgoal_tac "\<Gamma>\<turnstile> (Parallel cs, Normal x) \<rightarrow> (Parallel (cs[i := c1']), Normal s')")
	apply (frule_tac c="Parallel cs" and
	a="AnnPar as" and
	Q="(\<Inter>x\<in>set as. postcond x)" and A ="(\<Union>x\<in>set as. abrcond x)"
	in oghoare_step[where \<Theta>=\<Theta> and F=F])
	apply(rule Parallel, simp)
	apply clarsimp
	apply (rule Conseq, rule exI[where x="{}"], fastforce)
	apply clarsimp
	apply force
	apply force
	apply clarsimp
	apply clarsimp
	apply (rename_tac a')
	apply (drule_tac x=a' in spec)
	apply (drule mp, rule Conseq)
	apply (rule_tac x="{}" in exI)
	apply (rule_tac x="(\<Inter>x\<in>set as. postcond x)" in exI)
	apply (rule_tac x="(\<Union>x\<in>set as. abrcond x)" in exI)
	apply (simp)
	apply clarsimp
	apply(erule (1) step.Parallel)
	\<comment> \<open>ParSkip\<close>
	apply (frule no_steps_final, simp add: final_def)
	apply clarsimp
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rule imageI)
	apply (erule subsetD)
	apply clarsimp
	apply (clarsimp simp: in_set_conv_nth)
	apply (rename_tac i)
	apply (frule_tac x="i" in spec)
	apply clarsimp
	apply (frule_tac x="cs!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x="i" in exI)
	apply clarsimp
	apply clarsimp
	apply (drule_tac x="as ! i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply fastforce
	apply (drule oghoare_Skip)
	apply fastforce
	\<comment> \<open>ParThrow\<close>
	apply clarsimp
	apply (frule no_steps_final, simp add: final_def)
	apply clarsimp
	apply (drule oghoare_Parallel)
	apply (clarsimp simp: in_set_conv_nth)
	apply (drule_tac x=i in spec)
	apply clarsimp
	apply (drule oghoare_Throw)
	apply clarsimp
	apply (rename_tac i as Q' A' P')
	apply (drule_tac x="as ! i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x=i in exI, fastforce)
	apply clarsimp
	apply (rule imageI)
	apply (erule_tac A="(\<Union>x\<in>set as. abrcond x)" in subsetD)
	apply clarsimp
	apply (rule_tac x="as!i" in bexI)
	apply blast
	apply clarsimp
	done

	lemma oghoare_step_Fault[rule_format, OF _ refl refl]:
	"\<Gamma>\<turnstile> cf \<rightarrow> cf' \<Longrightarrow>
	cf = (c, Normal x) \<Longrightarrow>
	cf' = (c', Fault f) \<Longrightarrow>
	x \<in> pre P \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<Longrightarrow> f \<in> F"
	supply [[simproc del: defined_all]]
	apply (induct arbitrary: x c c' P Q A f rule: step.induct, simp_all)
	apply clarsimp
	apply (drule oghoare_Guard)
	apply clarsimp
	apply blast
	apply clarsimp
	apply (drule oghoare_Seq)
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_Catch)
	apply clarsimp
	apply clarsimp
	apply (rename_tac i cs c' x P Q A f)
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac i cs c' x Q A f as)
	apply (drule_tac x="i" in spec)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, rule conjI, (rule refl)+)+
	apply (drule_tac x="as!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x="i" in exI, fastforce)
	apply (erule (1) meta_impE)
	apply (erule (2) meta_impE)
	apply clarsimp
	apply (drule rtranclp_conjD[THEN conjunct1])
	apply (drule oghoare_Await)
	apply clarsimp
	apply (rename_tac b c c' x Q A f r P' Q' A')
	apply (drule (1) oghoare_atom_com_sound)
	apply (simp add: valid_def)
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="Fault f" in spec)
	apply (drule_tac x=Skip in spec)
	apply clarsimp
	apply (erule impE)
	apply (cut_tac f=f and c=c' in steps_Fault[where \<Gamma>=\<Gamma>])
	apply fastforce
	apply (fastforce simp: final_def steps_Fault)
	done

	lemma oghoare_step_Stuck[rule_format, OF _ refl refl]:
	"\<Gamma>\<turnstile> cf \<rightarrow> cf' \<Longrightarrow>
	cf = (c, Normal x) \<Longrightarrow>
	cf' = (c', Stuck) \<Longrightarrow>
	x \<in> pre P \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<Longrightarrow> P'"
	apply (induct arbitrary: x c c' P Q A rule: step.induct, simp_all)
	apply clarsimp
	apply (drule oghoare_Spec)
	apply force
	apply clarsimp
	apply (drule oghoare_Seq)
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_Call)
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_Catch)
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac i cs c' x Q A as)
	apply (drule_tac x="i" in spec)
	apply clarsimp
	apply (drule meta_spec)+
	apply (drule_tac x="as!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x="i" in exI, fastforce)
	apply (erule meta_impE[OF _ refl])
	apply (erule (1) meta_impE)
	apply (erule (2) meta_impE)
	apply clarsimp
	apply (drule rtranclp_conjD[THEN conjunct1])
	apply (drule oghoare_Await)
	apply clarsimp
	apply (rename_tac b c c' x Q A r P'' Q' A')
	apply (drule (1) oghoare_atom_com_sound)
	apply (simp add: valid_def)
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x=Stuck in spec)
	apply (drule_tac x=Skip in spec)
	apply clarsimp
	apply (erule impE)
	apply (cut_tac c=c' in steps_Stuck[where \<Gamma>=\<Gamma>])
	apply fastforce
	apply (fastforce simp: final_def steps_Fault)
	apply clarsimp
	apply (drule oghoare_Await)
	apply clarsimp
	done

	lemma oghoare_steps_Fault[rule_format, OF _ refl refl]:
	"\<Gamma>\<turnstile> cf \<rightarrow>\<^sup>* cf' \<Longrightarrow>
	cf = (c, Normal x) \<Longrightarrow>
	cf' = (c', Fault f) \<Longrightarrow>
	x \<in> pre P \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<Longrightarrow> f \<in> F"
	apply (induct arbitrary: x c c' f rule: rtranclp_induct)
	supply [[simproc del: defined_all]]
	apply fastforce
	apply clarsimp
	apply (rename_tac b x c c' f)
	apply (case_tac b)
	apply clarsimp
	apply (drule (2) oghoare_steps)
	apply clarsimp
	apply (drule (3) oghoare_step_Fault)
	apply clarsimp
	apply (drule meta_spec)+
	apply (erule meta_impE, (rule conjI, (rule refl)+))+
	apply simp
	apply (drule step_Fault_prop ; simp)
	apply simp
	apply clarsimp
	apply (drule step_Stuck_prop ; simp)
	done

	lemma oghoare_steps_Stuck[rule_format, OF _ refl refl]:
	"\<Gamma>\<turnstile> cf \<rightarrow>\<^sup>* cf' \<Longrightarrow>
	cf = (c, Normal x) \<Longrightarrow>
	cf' = (c', Stuck) \<Longrightarrow>
	x \<in> pre P \<Longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<Longrightarrow> P'"
	apply (induct arbitrary: x c c' rule: rtranclp_induct)
	apply fastforce
	apply clarsimp
	apply (rename_tac b x c c')
	apply (case_tac b)
	apply clarsimp
	apply (drule (2) oghoare_steps)
	apply clarsimp
	apply (drule (3) oghoare_step_Stuck)
	apply clarsimp
	apply (drule step_Fault_prop ; simp)
	apply simp
	done

	lemma oghoare_sound_Parallel_Fault_case[rule_format, OF _ refl refl]:
	"\<Gamma> \<turnstile> (c, s) \<rightarrow>\<^sup>* (c', t) \<Longrightarrow>
	\<forall>P x f cs. c = Parallel cs \<longrightarrow> s = Normal x \<longrightarrow>
	x \<in> pre P \<longrightarrow> t = Fault f \<longrightarrow>
	\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P c Q,A \<longrightarrow> final (c', t) \<longrightarrow>
	f \<in> F"
	apply(erule converse_rtranclp_induct2)
	apply (clarsimp simp: final_def)
	apply clarsimp

	apply (rename_tac c s P x f cs)
	apply (case_tac s)
	apply clarsimp

	apply(erule step.cases, simp_all)
	apply (clarsimp simp: final_def)
	apply (drule oghoare_Parallel)
	apply clarsimp
	apply (rename_tac x f s' i cs c1' as)
	apply (subgoal_tac "\<Gamma>\<turnstile> (Parallel cs, Normal x) \<rightarrow> (Parallel (cs[i := c1']), Normal s')")
	apply (frule_tac c="Parallel cs" and a="AnnPar as" and
	Q="(\<Inter>x\<in>set as. postcond x)" and A="(\<Union>x\<in>set as. abrcond x)"
	in oghoare_step[where \<Theta>=\<Theta> and F=F])
	apply(rule Parallel)
	apply simp
	apply clarsimp
	apply (rule Conseq, rule exI[where x="{}"], fastforce)
	apply assumption
	apply clarsimp
	apply clarsimp
	apply simp
	apply clarsimp
	apply (rename_tac a')
	apply (drule_tac x=a' in spec)
	apply clarsimp
	apply (erule notE[where P="oghoare _ _ _ _ _ _ _"])
	apply (rule Conseq, rule exI[where x="{}"])
	apply (clarsimp)
	apply (rule_tac x="(\<Inter>x\<in>set as. postcond x)" in exI)
	apply (rule_tac x="(\<Union>x\<in>set as. abrcond x)" in exI ; simp)
	apply(erule (1) step.Parallel)
	apply clarsimp
	apply (fastforce dest: no_steps_final simp: final_def)+
	apply (clarsimp simp: final_def)
	apply (drule oghoare_Parallel)
	apply (erule step_Normal_elim_cases, simp_all)
	apply clarsimp
	apply (rename_tac f cs f' i c1' as)
	apply (drule_tac x="i" in spec)
	apply (erule impE, fastforce)
	apply clarsimp
	apply (drule_tac x="as!i" in bspec)
	apply (clarsimp simp: in_set_conv_nth)
	apply (rule_tac x="i" in exI, fastforce)
	apply (drule_tac P="pres (as ! i)" in oghoare_step_Fault[where \<Theta>=\<Theta> and F=F])
	apply assumption+
	apply (drule steps_Fault_prop ; simp)
	apply simp
	apply (drule steps_Stuck_prop ;simp)
	done

	lemma oghoare_soundness:
	"(\<Gamma>, \<Theta> \<turnstile>\<^bsub>/F\<^esub> P c Q,A \<longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> (pre P) c Q, A) \<and>
	(\<Gamma>, \<Theta> \<tturnstile>\<^bsub>/F\<^esub>P' P c Q,A \<longrightarrow> \<Gamma> \<Turnstile>\<^bsub>/F\<^esub> P' c Q, A)"
	unfolding valid_def
	proof (induct rule: oghoare_oghoare_seq.induct)
	case SeqSkip thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases(1))
	next
	case SeqThrow thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases)
	next
	case SeqBasic thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases
	simp: final_def)
	next
	case (SeqSpec \<Gamma> \<Theta> F r Q A) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply (erule step_Normal_elim_cases)
	apply (fastforce elim!: converse_rtranclpE step_Normal_elim_cases)
	by clarsimp
	next
	case (SeqSeq \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 P\<^sub>2 A c\<^sub>2 Q) show ?case
	using SeqSeq
	by (fold valid_def)
	(fastforce intro: oghoare_seq_valid simp: valid_weaken_pre)
	next
	case (SeqCatch \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 Q P\<^sub>2 c\<^sub>2 A) thus ?case
	by (fold valid_def)
	(fastforce elim: oghoare_catch_valid)+
	next
	case (SeqCond \<Gamma> \<Theta> F P b c1 Q A c2) thus ?case
	by (fold valid_def)
	(fastforce intro:oghoare_if_valid)
	next
	case (SeqWhile \<Gamma> \<Theta> F P c A b) thus ?case
	by (fold valid_def)
	(fastforce elim: valid_weaken_pre[rotated] oghoare_while_valid)
	next
	case (SeqGuard \<Gamma> \<Theta> F P c Q A r g f) thus ?case
	apply (fold valid_def)
	apply (simp (no_asm) add: valid_def)
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply (fastforce dest: no_steps_final simp:final_def)
	apply (fastforce dest: no_steps_final simp:final_def)
	done
	next
	case (SeqCall \<Gamma> p f \<Theta> F P Q A) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp add: final_def)
	apply (erule step_Normal_elim_cases)
	apply (clarsimp simp: final_def)
	apply fastforce
	apply fastforce
	done
	next
	case (SeqDynCom r P fa \<Gamma> \<Theta> F c Q A) thus ?case
	apply -
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply clarsimp
	apply (rename_tac t c' x)
	apply (drule_tac x=x in bspec, fastforce)
	apply clarsimp
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="t" in spec)
	apply (drule_tac x="c'" in spec)
	apply fastforce+
	done
	next
	case (SeqConseq \<Gamma> \<Theta> F P c Q A) thus ?case
	apply (clarsimp)
	apply (rename_tac t c' x)
	apply (erule_tac x="Normal x" in allE)
	apply (erule_tac x="t" in allE)
	apply (erule_tac x="c'" in allE)
	apply (clarsimp simp: pre_weaken_pre)
	apply force
	done
	next
	case (SeqParallel as P \<Gamma> \<Theta> F cs Q A) thus ?case
	by (fold valid_def)
	(erule (1) valid_weaken_pre)
	next
	case (Call \<Theta> p as n P Q A r \<Gamma> f F) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp add: final_def)
	apply (erule step_Normal_elim_cases)
	apply (clarsimp simp: final_def)
	apply (erule disjE)
	apply clarsimp
	apply fastforce
	apply fastforce
	apply fastforce
	done
	next
	case (Await \<Gamma> \<Theta> F P c Q A r b) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp add: final_def)
	apply (erule step_Normal_elim_cases)
	apply (erule converse_rtranclpE)
	apply (fastforce simp add: final_def )
	apply (force dest!:no_step_final simp: final_def)
	apply clarsimp
	apply (rename_tac x c'')
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="Stuck" in spec)
	apply (drule_tac x="Skip" in spec)
	apply (clarsimp simp: final_def)
	apply (erule impE[where P="rtranclp _ _ _"])
	apply (cut_tac c="c''" in steps_Stuck[where \<Gamma>=\<Gamma>])
	apply fastforce
	apply fastforce
	apply clarsimp
	apply (rename_tac x c'' f)
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="Fault f" in spec)
	apply (drule_tac x="Skip" in spec)
	apply (erule impE[where P="rtranclp _ _ _"])
	apply (cut_tac c="c''" and f=f in steps_Fault[where \<Gamma>=\<Gamma>])
	apply fastforce
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply fastforce
	apply (erule step_elim_cases)
	apply (fastforce)
	done
	next
	case (Parallel as cs \<Gamma> \<Theta> F Q A ) thus ?case
	apply (fold valid_def)
	apply (simp only:pre.simps)
	apply (simp (no_asm) only: valid_def)
	apply clarsimp
	apply (rename_tac t c' x')
	apply (case_tac t)
	apply clarsimp
	apply (drule oghoare_sound_Parallel_Normal_case[where \<Theta>=\<Theta> and Q=Q and A=A and F=F and P="AnnPar as", OF _ refl])
	apply (rule oghoare_oghoare_seq.Parallel)
	apply simp
	apply clarsimp
	apply assumption
	apply (clarsimp)
	apply clarsimp
	apply (clarsimp simp: final_def)
	apply (clarsimp )
	apply clarsimp
	apply clarsimp
	apply (drule oghoare_sound_Parallel_Fault_case[where \<Theta>=\<Theta> and Q=Q and A=A and F=F and P="AnnPar as", OF _ ])
	apply clarsimp
	apply assumption
	apply (rule oghoare_oghoare_seq.Parallel)
	apply simp
	apply clarsimp
	apply assumption
	apply clarsimp
	apply clarsimp
	apply (simp add: final_def)
	apply (fastforce simp add: final_def)
	apply (clarsimp simp: final_def)
	apply (erule oghoare_steps_Stuck[where \<Theta>=\<Theta> and F=F and Q=Q and A=A and P="AnnPar as"])
	apply simp
	apply (rule oghoare_oghoare_seq.Parallel)
	apply simp
	apply simp
	apply simp
	apply clarsimp
	apply clarsimp
	done
	next
	case Skip thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases(1))
	next
	case Basic thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases
	simp: final_def)
	next
	case (Spec \<Gamma> \<Theta> F r Q A) thus ?case
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply (erule step_Normal_elim_cases)
	apply (fastforce elim!: converse_rtranclpE step_Normal_elim_cases)
	by clarsimp
	next
	case (Seq \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 P\<^sub>2 A c\<^sub>2 Q) show ?case
	using Seq
	by (fold valid_def)
	(fastforce intro: oghoare_seq_valid simp: valid_weaken_pre)
	next
	case (Cond \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 Q A P\<^sub>2 c\<^sub>2 r b) thus ?case
	by (fold valid_def)
	(fastforce intro:oghoare_if_valid)
	next
	case (While \<Gamma> \<Theta> F P c i A b Q r) thus ?case
	by (fold valid_def)
	(fastforce elim: valid_weaken_pre[rotated] oghoare_while_valid)
	next
	case Throw thus ?case
	by (fastforce
	elim: converse_rtranclpE step_Normal_elim_cases)
	next
	case (Catch \<Gamma> \<Theta> F P\<^sub>1 c\<^sub>1 Q P\<^sub>2 c\<^sub>2 A) thus ?case
	apply (fold valid_def)
	apply (fastforce elim: oghoare_catch_valid)+
	done
	next
	case (Guard \<Gamma> \<Theta> F P c Q A r g f) thus ?case
	apply (fold valid_def)
	apply (simp)
	apply (frule (1) valid_weaken_pre[rotated])
	apply (simp (no_asm) add: valid_def)
	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (fastforce simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (fastforce simp: valid_def)
	apply clarsimp
	apply (case_tac "r \<inter> - g \<noteq> {}")
	apply clarsimp
	apply (fastforce dest: no_steps_final simp:final_def)
	apply (clarsimp simp: ex_in_conv[symmetric])
	done
	next
	case (DynCom r \<Gamma> \<Theta> F P c Q A) thus ?case

	apply clarsimp
	apply (erule converse_rtranclpE)
	apply (clarsimp simp: final_def)
	apply clarsimp
	apply (erule step_Normal_elim_cases)
	apply clarsimp
	apply (rename_tac t c' x)
	apply (erule_tac x=x in ballE)
	apply clarsimp
	apply (drule_tac x="Normal x" in spec)
	apply (drule_tac x="t" in spec)
	apply (drule_tac x="c'" in spec)

	apply fastforce+
	done
	next
	case (Conseq \<Gamma> \<Theta> F P c Q A) thus ?case
	apply (clarsimp)
	apply (rename_tac P' Q' A' t c' x)
	apply (erule_tac x="Normal x" in allE)
	apply (erule_tac x="t" in allE)
	apply (erule_tac x="c'" in allE)
	apply (clarsimp simp: pre_weaken_pre)
	apply force
	done
	qed

	lemmas oghoare_sound = oghoare_soundness[THEN conjunct1, rule_format]
	lemmas oghoare_seq_sound = oghoare_soundness[THEN conjunct2, rule_format]

	end
	diff --git a/thys/Complx/ex/Examples.thy b/thys/Complx/ex/Examples.thy
	--- a/thys/Complx/ex/Examples.thy
	+++ b/thys/Complx/ex/Examples.thy
	@@ -1,267 +1,267 @@
	(*
	* Copyright 2016, Data61, CSIRO
	*
	* This software may be distributed and modified according to the terms of
	* the BSD 2-Clause license. Note that NO WARRANTY is provided.
	* See "LICENSE_BSD2.txt" for details.
	*
	* @TAG(DATA61_BSD)
	*)
	section \<open>Examples\<close>

	theory Examples
	imports
	"../OG_Syntax"
	begin

	record test =
	x :: nat
	y :: nat

	text \<open>This is a sequence of two commands, the first being an assign
	protected by two guards. The guards use booleans as their faults.\<close>
	definition
	"test_guard \<equiv> \<lbrace>True\<rbrace> (True, \<lbrace>\<acute>x=0\<rbrace>),
	(False, \<lbrace>(0::nat)=0\<rbrace>) \<longmapsto> \<lbrace>True\<rbrace> \<acute>y := 0;;
	\<lbrace>True\<rbrace> \<acute>x := 0"

	lemma
	"\<Gamma>, \<Theta> \|\<turnstile>\<^bsub>/{True}\<^esub>
	COBEGIN test_guard \<lbrace>True\<rbrace>,\<lbrace>True\<rbrace>
	\<parallel> \<lbrace>True\<rbrace> \<acute>y:=0 \<lbrace>True\<rbrace>, \<lbrace>True\<rbrace>
	COEND \<lbrace>True\<rbrace>,\<lbrace>True\<rbrace>"
	unfolding test_guard_def
	apply oghoare (11 subgoals)
	apply simp_all
	done

	definition
	"test_try_throw \<equiv> TRY \<lbrace>True\<rbrace> \<acute>y := 0;;
	\<lbrace>True\<rbrace> THROW
	CATCH \<lbrace>True\<rbrace> \<acute>x := 0
	END"


	subsection \<open>Parameterized Examples\<close>

	subsubsection \<open>Set Elements of an Array to Zero\<close>

	record Example1 =
	ex1_a :: "nat \<Rightarrow> nat"

	lemma Example1:
	"\<Gamma>, \<Theta>\|\<tturnstile>\<^bsub>/F\<^esub>\<lbrace>True\<rbrace>
	COBEGIN SCHEME [0\<le>i<n] \<lbrace>True\<rbrace> \<acute>ex1_a:=\<acute>ex1_a (i:=0) \<lbrace>\<acute>ex1_a i=0\<rbrace>, \<lbrace>False\<rbrace> COEND
	\<lbrace>\<forall>i < n. \<acute>ex1_a i = 0\<rbrace>, X"
	apply oghoare (* 7 subgoals *)
	apply (simp ; fail)+
	done

	text \<open>Same example but with a Call.\<close>
	definition
	"Example1'a \<equiv> \<lbrace>True\<rbrace> \<acute>ex1_a:=\<acute>ex1_a (0:=0)"

	definition
	"Example1'b \<equiv> \<lbrace>True\<rbrace> \<acute>ex1_a:=\<acute>ex1_a (1:=0)"

	definition "Example1' \<equiv>
	COBEGIN Example1'a \<lbrace>\<acute>ex1_a 0=0\<rbrace>, \<lbrace>False\<rbrace>
	\<parallel>
	\<lbrace>True\<rbrace> SCALL 0 0
	\<lbrace>\<acute>ex1_a 1=0\<rbrace>, \<lbrace>False\<rbrace>
	COEND"

	definition "\<Gamma>' = Map.empty(0 \<mapsto> com Example1'b)"
	definition "\<Theta>' = Map.empty(0 :: nat \<mapsto> [ann Example1'b])"

	lemma Example1_proc_simp[unfolded Example1'b_def oghoare_simps]:
	"\<Gamma>' 0 = Some (com (Example1'b))"
	"\<Theta>' 0 = Some ([ ann(Example1'b)])"
	"[ ann(Example1'b)]!0 = ann(Example1'b)"
	by (simp add: \<Gamma>'_def \<Theta>'_def)+

	lemma Example1':
	notes Example1_proc_simp[proc_simp]
	shows
	"\<Gamma>', \<Theta>' \|\<turnstile>\<^bsub>/F\<^esub> Example1' \<lbrace>\<forall>i < 2. \<acute>ex1_a i = 0\<rbrace>, \<lbrace>False\<rbrace>"
	unfolding Example1'_def
	apply simp
	unfolding Example1'a_def Example1'b_def
	apply oghoare (12 subgoals)
	apply simp+
	using less_2_cases apply blast
	apply simp
	apply (erule disjE ; clarsimp)
	done

	type_synonym routine = nat

	text \<open>Same example but with a Call.\<close>
	record Example2 =
	ex2_n :: "routine \<Rightarrow> nat"
	ex2_a :: "nat \<Rightarrow> string"

	definition
	Example2'n :: "routine \<Rightarrow> (Example2, string \<times> nat, 'f) ann_com"
	where
	"Example2'n i \<equiv> \<lbrace>\<acute>ex2_n i= i\<rbrace> \<acute>ex2_a:=\<acute>ex2_a((\<acute>ex2_n i):='''')"

	lemma Example2'n_map_of_simps[simp]:
	"i < n \<Longrightarrow>
	map_of (map (\<lambda>i. ((p, i), g i)) [0..<n])
	(p, i) = Some (g i)"
	apply (rule map_of_is_SomeI)
	apply (clarsimp simp: distinct_map o_def)
	apply (meson inj_onI prod.inject)
	apply clarsimp
	done

	definition "\<Gamma>'' n \<equiv>
	map_of (map (\<lambda>i. ((''f'', i), com (Example2'n i))) [0..<n])"

	definition "\<Theta>'' n \<equiv>
	map_of (map (\<lambda>i. ((''f'', i), [ann (Example2'n i)])) [0..<n])"

	lemma Example2'n_proc_simp[unfolded Example2'n_def oghoare_simps]:
	"i<n \<Longrightarrow> \<Gamma>'' n (''f'',i) = Some ( com(Example2'n i))"
	"i<n \<Longrightarrow> \<Theta>'' n (''f'',i) = Some ([ ann(Example2'n i)])"
	"[ ann(Example2'n i)]!0 = ann(Example2'n i)"
	by (simp add: \<Gamma>''_def \<Theta>''_def)+

	lemmas Example2'n_proc_simp[proc_simp add]

	lemma Example2:
	notes Example2'n_proc_simp[proc_simp]
	shows
	"\<Gamma>'' n, \<Theta>'' n
	\|\<tturnstile>\<^bsub>/F\<^esub>\<lbrace>True\<rbrace>
	COBEGIN SCHEME [0\<le>i<n]
	\<lbrace>True\<rbrace>
	CALLX (\<lambda>s. s\<lparr>ex2_n:=(ex2_n s)(i:=i)\<rparr>) \<lbrace>\<acute>ex2_n i = i\<rbrace> (''f'', i) 0
	(\<lambda>s t. t\<lparr>ex2_n:= (ex2_n t)(i:=(ex2_n s) i)\<rparr>) (\<lambda>x y. Skip)
	\<lbrace>\<acute>ex2_a (\<acute>ex2_n i)='''' \<and> \<acute>ex2_n i = i\<rbrace> \<lbrace>\<acute>ex2_a i=''''\<rbrace> \<lbrace>False\<rbrace> \<lbrace>False\<rbrace>
	\<lbrace>\<acute>ex2_a i=''''\<rbrace>, \<lbrace>False\<rbrace>
	COEND
	\<lbrace>\<forall>i < n. \<acute>ex2_a i = ''''\<rbrace>, \<lbrace>False\<rbrace>"
	unfolding Example2'n_def ann_call_def call_def block_def
	apply oghoare (* 113 subgoals *)
	apply (clarsimp ; fail)+
	done

	lemmas Example2'n_proc_simp[proc_simp del]

	text \<open>Same example with lists as auxiliary variables.\<close>

	record Example2_list =
	ex2_A :: "nat list"

	lemma Example2_list:
	"\<Gamma>, \<Theta> \|\<tturnstile>\<^bsub>/F\<^esub>\<lbrace>n < length \<acute>ex2_A\<rbrace>
	COBEGIN
	SCHEME [0\<le>i<n] \<lbrace>n < length \<acute>ex2_A\<rbrace> \<acute>ex2_A:=\<acute>ex2_A[i:=0] \<lbrace>\<acute>ex2_A!i=0\<rbrace>,\<lbrace>False\<rbrace>
	COEND
	\<lbrace>\<forall>i < n. \<acute>ex2_A!i = 0\<rbrace>, X"
	apply oghoare (7 subgoals)
	apply force+
	done


	lemma exceptions_example:
	"\<Gamma>, \<Theta> \|\<turnstile>\<^bsub>/F\<^esub>
	TRY
	\<lbrace>True \<rbrace> \<acute>y := 0;;
	\<lbrace> \<acute>y = 0 \<rbrace> THROW
	CATCH
	\<lbrace>\<acute>y = 0\<rbrace> \<acute>x := \<acute>y + 1
	END
	\<lbrace> \<acute>x = 1 \<and> \<acute>y = 0\<rbrace>, \<lbrace>False\<rbrace>"
	by oghoare simp_all

	lemma guard_example:
	"\<Gamma>, \<Theta> \|\<turnstile>\<^bsub>/{42,66}\<^esub>
	\<lbrace>True\<rbrace> (42, \<lbrace>\<acute>x=0\<rbrace>),
	(66, \<lbrace>\<acute>y=0\<rbrace>) \<longmapsto> \<lbrace>\<acute>x = 0\<rbrace>
	\<acute>y := 0;;
	\<lbrace>True\<rbrace> \<acute>x := 0
	\<lbrace> \<acute>x = 0\<rbrace>, \<lbrace>False\<rbrace>"
	apply oghoare (6 subgoals)
	apply simp_all
	done

	subsubsection \<open>Peterson's mutex algorithm I (from Hoare-Parallel) \<close>

	text \<open>Eike Best. "Semantics of Sequential and Parallel Programs", page 217.\<close>

	record Petersons_mutex_1 =
	pr1 :: nat
	pr2 :: nat
	in1 :: bool
	in2 :: bool
	hold :: nat

	lemma peterson_thread_1:
	"\<Gamma>, \<Theta> \|\<turnstile>\<^bsub>/F\<^esub> \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace> WHILE True INV \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>
	DO
	\<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace> \<langle>\<acute>in1:=True,, \<acute>pr1:=1 \<rangle>;;
	\<lbrace>\<acute>pr1=1 \<and> \<acute>in1\<rbrace> \<langle>\<acute>hold:=1,, \<acute>pr1:=2 \<rangle>;;
	\<lbrace>\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)\<rbrace>
	AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN
	\<acute>pr1:=3
	END;;
	\<lbrace>\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)\<rbrace>
	\<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
	OD \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>,\<lbrace>False\<rbrace>
	"
	apply oghoare (7 subgoals)
	apply (((auto)[1]) ; fail)+
	done


	lemma peterson_thread_2:
	"\<Gamma>, \<Theta> \|\<turnstile>\<^bsub>/F\<^esub> \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
	WHILE True INV \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
	DO
	\<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace> \<langle>\<acute>in2:=True,, \<acute>pr2:=1 \<rangle>;;
	\<lbrace>\<acute>pr2=1 \<and> \<acute>in2\<rbrace> \<langle> \<acute>hold:=2,, \<acute>pr2:=2 \<rangle> ;;
	\<lbrace>\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
	AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
	\<lbrace>\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
	\<langle>\<acute>in2:=False,, \<acute>pr2:=0\<rangle>
	OD \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>,\<lbrace>False\<rbrace>
	"
	apply oghoare (7 subgoals)
	- apply (((auto simp: )[1]) ; fail)+
	+ apply ((auto[1]) ; fail)+
	done

	lemma Petersons_mutex_1:
	"\<Gamma>, \<Theta> \|\<tturnstile>\<^bsub>/F\<^esub> \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 \<rbrace>
	COBEGIN
	\<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1 \<rbrace> WHILE True INV \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>
	DO
	\<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace> \<langle> \<acute>in1:=True,, \<acute>pr1:=1 \<rangle>;;
	\<lbrace>\<acute>pr1=1 \<and> \<acute>in1\<rbrace> \<langle> \<acute>hold:=1,, \<acute>pr1:=2 \<rangle>;;
	\<lbrace>\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> (\<acute>hold=2 \<and> \<acute>pr2=2))\<rbrace>
	AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
	\<lbrace>\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> (\<acute>hold=2 \<and> \<acute>pr2=2))\<rbrace>
	\<langle> \<acute>in1:=False,, \<acute>pr1:=0\<rangle>
	OD \<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1\<rbrace>,\<lbrace>False\<rbrace>
	\<parallel>
	\<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
	WHILE True INV \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>
	DO
	\<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace> \<langle> \<acute>in2:=True,, \<acute>pr2:=1 \<rangle>;;
	\<lbrace>\<acute>pr2=1 \<and> \<acute>in2\<rbrace> \<langle> \<acute>hold:=2,, \<acute>pr2:=2 \<rangle> ;;
	\<lbrace>\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
	AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
	\<lbrace>\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))\<rbrace>
	\<langle> \<acute>in2:=False,, \<acute>pr2:=0\<rangle>
	OD \<lbrace>\<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>,\<lbrace>False\<rbrace>
	COEND
	\<lbrace>\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2\<rbrace>,\<lbrace>False\<rbrace>"
	apply oghoare
	\<comment> \<open>81 verification conditions.\<close>
	apply (((auto)[1]) ; fail)+
	done

	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,8045 +1,8045 @@
	(***********************************************************************************
	* 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)
	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
	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)
	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 \<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 (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 add: )
	+ using children' by simp
	have 7: "\|h' \<turnstile> get_disconnected_nodes xb\|\<^sub>r = disc_nodes'"
	- using disc_nodes' by (simp add: )
	+ 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 add: )
	+ bysimp
	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 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)
	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)
	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)
	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
	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

	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 ()"
	using assms(8)
	by (smt assms(5) assms(7) 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 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 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 \<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 set_disconnected_nodes_get_disconnected_nodes
	local.a_all_ptrs_in_heap_def local.get_child_nodes_ptr_in_heap 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 (smt 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 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 (smt 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/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)
	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
	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)
	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 add: )
	+ using children' by simp
	have 7: "\|h' \<turnstile> get_disconnected_nodes xb\|\<^sub>r = disc_nodes'"
	- using disc_nodes' by (simp add: )
	+ 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 add: )
	+ bysimp
	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)
	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)
	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)
	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
	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/Dirichlet_L/Dirichlet_L_Functions.thy b/thys/Dirichlet_L/Dirichlet_L_Functions.thy
	--- a/thys/Dirichlet_L/Dirichlet_L_Functions.thy
	+++ b/thys/Dirichlet_L/Dirichlet_L_Functions.thy
	@@ -1,1267 +1,1267 @@
	(*
	File: Dirichlet_L_Functions.thy
	Author: Manuel Eberl, TU München
	*)
	section \<open>Dirichlet $L$-functions\<close>
	theory Dirichlet_L_Functions
	imports
	Dirichlet_Characters
	"HOL-Library.Landau_Symbols"
	"Zeta_Function.Zeta_Function"
	begin

	text \<open>
	We can now define the Dirichlet $L$-functions. These are essentially the functions in the complex
	plane that the Dirichlet series $\sum_{k=1}^\infty \chi(k) k^{-s}$ converge to, for some fixed
	Dirichlet character $\chi$.

	First of all, we need to take care of a syntactical problem: The notation for vectors uses
	$\chi$ as syntax, which causes some annoyance to us, so we disable it locally.
	\<close>

	(<)
	bundle vec_lambda_notation
	begin
	notation vec_lambda (binder "\<chi>" 10)
	end

	bundle no_vec_lambda_notation
	begin
	no_notation vec_lambda (binder "\<chi>" 10)
	end
	(>)


	subsection \<open>Definition and basic properties\<close>

	(<)
	context
	includes no_vec_lambda_notation
	begin
	(>)

	text \<open>
	We now define Dirichlet $L$ functions as a finite linear combination of Hurwitz $\zeta$ functions.
	This has the advantage that we directly get the analytic continuation over the full domain
	and only need to prove that the series really converges to this definition whenever it
	does converge, which is not hard to do.
	\<close>
	definition Dirichlet_L :: "nat \<Rightarrow> (nat \<Rightarrow> complex) \<Rightarrow> complex \<Rightarrow> complex" where
	"Dirichlet_L m \<chi> s =
	(if s = 1 then
	if \<chi> = principal_dchar m then 0 else eval_fds (fds \<chi>) 1
	else
	of_nat m powr - s * (\<Sum>k = 1..m. \<chi> k * hurwitz_zeta (real k / real m) s))"

	lemma Dirichlet_L_conv_hurwitz_zeta_nonprincipal:
	assumes "s \<noteq> 1"
	shows "Dirichlet_L n \<chi> s =
	of_nat n powr -s * (\<Sum>k = 1..n. \<chi> k * hurwitz_zeta (real k / real n) s)"
	using assms by (simp add: Dirichlet_L_def)

	text \<open>
	Analyticity everywhere except $1$ is trivial by the above definition, since the
	Hurwitz $\zeta$ function is analytic everywhere except $1$. For $L$ functions of non
	principal characters, we will have to show the analyticity at $1$ separately later.
	\<close>
	lemma holomorphic_Dirichlet_L_weak:
	assumes "m > 0" "1 \<notin> A"
	shows "Dirichlet_L m \<chi> holomorphic_on A"
	proof -
	have "(\<lambda>s. of_nat m powr - s * (\<Sum>k = 1..m. \<chi> k * hurwitz_zeta (real k / real m) s))
	holomorphic_on A"
	using assms unfolding Dirichlet_L_def by (intro holomorphic_intros) auto
	also have "?this \<longleftrightarrow> ?thesis"
	using assms by (intro holomorphic_cong refl) (auto simp: Dirichlet_L_def)
	finally show ?thesis .
	qed

	(<)
	end
	(>)


	context dcharacter
	begin
	(<)
	context
	includes no_vec_lambda_notation dcharacter_syntax
	begin
	(>)

	text \<open>
	For a real value greater than 1, the formal Dirichlet series of an $L$ function
	for some character $\chi$ converges to the L function.
	\<close>
	lemma
	fixes s :: complex
	assumes s: "Re s > 1"
	shows abs_summable_Dirichlet_L: "summable (\<lambda>n. norm (\<chi> n * of_nat n powr -s))"
	and summable_Dirichlet_L: "summable (\<lambda>n. \<chi> n * of_nat n powr -s)"
	and sums_Dirichlet_L: "(\<lambda>n. \<chi> n * n powr -s) sums Dirichlet_L n \<chi> s"
	and Dirichlet_L_conv_eval_fds_weak: "Dirichlet_L n \<chi> s = eval_fds (fds \<chi>) s"
	proof -
	define L where "L = (\<Sum>n. \<chi> n * of_nat n powr -s)"
	show "summable (\<lambda>n. norm (\<chi> n * of_nat n powr -s))"
	by (subst summable_Suc_iff [symmetric],
	rule summable_comparison_test [OF _ summable_zeta_real[of "Re s"]])
	(insert s norm, auto intro!: exI[of _ 0] simp: norm_mult norm_powr_real_powr)
	thus summable: "summable (\<lambda>n. \<chi> n * of_nat n powr -s)"
	by (rule summable_norm_cancel)

	hence "(\<lambda>n. \<chi> n * of_nat n powr -s) sums L" by (simp add: L_def sums_iff)
	from this have "(\<lambda>m. \<Sum>k = m * n..<m * n + n. \<chi> k * of_nat k powr - s) sums L"
	by (rule sums_group) (use n in auto)
	also have "(\<lambda>m. \<Sum>k = m * n..<m * n + n. \<chi> k * of_nat k powr - s) =
	(\<lambda>m. of_nat n powr -s * (\<Sum>k = 1..n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s))"
	proof (rule ext, goal_cases)
	case (1 m)
	have "(\<Sum>k = m * n..<m * n + n. \<chi> k * of_nat k powr - s) =
	(\<Sum>k=0..<n. \<chi> (k + m * n) * of_nat (m * n + k) powr - s)"
	by (intro sum.reindex_bij_witness[of _ "\<lambda>k. k + m * n" "\<lambda>k. k - m * n"]) auto
	also have "\<dots> = (\<Sum>k=0..<n. \<chi> k * of_nat (m * n + k) powr - s)"
	by (simp add: periodic_mult)
	also have "\<dots> = (\<Sum>k=0..<n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s * of_nat n powr -s)"
	proof (intro sum.cong refl, goal_cases)
	case (1 k)
	have "of_nat (m * n + k) = (of_nat m + of_nat k / of_nat n :: complex) * of_nat n"
	using n by (simp add: divide_simps del: div_mult_self1 div_mult_self2 div_mult_self3 div_mult_self4)
	also have "\<dots> powr -s = (of_nat m + of_nat k / of_nat n) powr -s * of_nat n powr -s"
	by (rule powr_times_real) auto
	finally show ?case by simp
	qed
	also have "\<dots> = of_nat n powr -s * (\<Sum>k=0..<n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s)"
	by (subst sum_distrib_left) (simp_all add: mult_ac)
	also have "(\<Sum>k = 0..<n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s) =
	(\<Sum>k = 1..<n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s)"
	by (intro sum.mono_neutral_right) (auto simp: Suc_le_eq)
	also have "\<dots> = (\<Sum>k = 1..n. \<chi> k * (of_nat m + of_nat k / of_nat n) powr - s)"
	using periodic_mult[of 0 1] by (intro sum.mono_neutral_left) auto
	finally show ?case .
	qed
	finally have "\<dots> sums L" .
	moreover have "(\<lambda>m. of_nat n powr - s * (\<Sum>k=1..n. \<chi> k * (of_nat m + of_real (of_nat k / of_nat n)) powr - s)) sums
	(of_nat n powr - s * (\<Sum>k=1..n. \<chi> k * hurwitz_zeta (of_nat k / of_nat n) s))"
	using s by (intro sums_sum sums_mult sums_hurwitz_zeta) auto
	ultimately have "L = \<dots>"
	by (simp add: sums_iff)
	also have "\<dots> = Dirichlet_L n \<chi> s" using assms by (auto simp: Dirichlet_L_def)
	finally have "Dirichlet_L n \<chi> s = (\<Sum>n. \<chi> n * of_nat n powr -s)"
	by (simp add: L_def)
	with summable show "(\<lambda>n. \<chi> n * n powr -s) sums Dirichlet_L n \<chi> s"
	by (simp add: sums_iff L_def)
	thus "Dirichlet_L n \<chi> s = eval_fds (fds \<chi>) s"
	by (simp add: eval_fds_def sums_iff powr_minus field_simps fds_nth_fds')
	qed

	lemma fds_abs_converges_weak: "Re s > 1 \<Longrightarrow> fds_abs_converges (fds \<chi>) s"
	using abs_summable_Dirichlet_L[of s]
	by (simp add: fds_abs_converges_def powr_minus divide_simps fds_nth_fds')

	lemma abs_conv_abscissa_weak: "abs_conv_abscissa (fds \<chi>) \<le> 1"
	proof (rule abs_conv_abscissa_leI, goal_cases)
	case (1 c)
	thus ?case
	by (intro exI[of _ "of_real c"] conjI fds_abs_converges_weak) auto
	qed


	text \<open>
	Dirichlet $L$ functions have the Euler product expansion
	\[L(\chi, s) = \prod_p \left(1 - \frac{\chi(p)}{p^{-s}}\right)\]
	for all $s$ with $\mathfrak{R}(s) > 1$.
	\<close>
	lemma
	fixes s :: complex assumes s: "Re s > 1"
	shows Dirichlet_L_euler_product_LIMSEQ:
	"(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - \<chi> p / nat_power p s) else 1)
	\<longlonglongrightarrow> Dirichlet_L n \<chi> s" (is ?th1)
	and Dirichlet_L_abs_convergent_euler_product:
	"abs_convergent_prod (\<lambda>p. if prime p then inverse (1 - \<chi> p / p powr s) else 1)"
	(is ?th2)
	proof -
	have mult: "completely_multiplicative_function (fds_nth (fds \<chi>))"
	using mult.completely_multiplicative_function_axioms by (simp add: fds_nth_fds')
	have conv: "fds_abs_converges (fds \<chi>) s"
	using abs_summable_Dirichlet_L[OF s]
	by (simp add: fds_abs_converges_def fds_nth_fds' powr_minus divide_simps)
	have "(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - \<chi> p / nat_power p s) else 1)
	\<longlonglongrightarrow> eval_fds (fds \<chi>) s"
	using fds_euler_product_LIMSEQ' [OF mult conv] by (simp add: fds_nth_fds' cong: if_cong)
	also have "eval_fds (fds \<chi>) s = Dirichlet_L n \<chi> s"
	using sums_Dirichlet_L[OF s] unfolding eval_fds_def
	by (simp add: sums_iff fds_nth_fds' powr_minus divide_simps)
	finally show ?th1 .
	from fds_abs_convergent_euler_product' [OF mult conv] show ?th2
	by (simp add: fds_nth_fds cong: if_cong)
	qed

	lemma Dirichlet_L_Re_gt_1_nonzero:
	assumes "Re s > 1"
	shows "Dirichlet_L n \<chi> s \<noteq> 0"
	proof -
	have "completely_multiplicative_function (fds_nth (fds \<chi>))"
	by (simp add: fds_nth_fds' mult.completely_multiplicative_function_axioms)
	moreover have "fds_abs_converges (fds \<chi>) s"
	using abs_summable_Dirichlet_L[OF assms]
	by (simp add: fds_abs_converges_def fds_nth_fds' powr_minus divide_simps)
	ultimately have "(eval_fds (fds \<chi>) s = 0) \<longleftrightarrow> (\<exists>p. prime p \<and> fds_nth (fds \<chi>) p = nat_power p s)"
	by (rule fds_abs_convergent_zero_iff)
	also have "eval_fds (fds \<chi>) s = Dirichlet_L n \<chi> s"
	using Dirichlet_L_conv_eval_fds_weak[OF assms] by simp
	also have "\<not>(\<exists>p. prime p \<and> fds_nth (fds \<chi>) p = nat_power p s)"
	proof safe
	fix p :: nat assume p: "prime p" "fds_nth (fds \<chi>) p = nat_power p s"
	from p have "real 1 < real p" by (subst of_nat_less_iff) (auto simp: prime_gt_Suc_0_nat)
	also have "\<dots> = real p powr 1" by simp
	also from p and assms have "real p powr 1 \<le> real p powr Re s"
	by (intro powr_mono) (auto simp: real_of_nat_ge_one_iff prime_ge_Suc_0_nat)
	also have "\<dots> = norm (nat_power p s)" by (simp add: norm_nat_power norm_powr_real_powr)
	also have "nat_power p s = fds_nth (fds \<chi>) p" using p by simp
	also have "norm \<dots> \<le> 1" by (auto simp: fds_nth_fds' norm)
	finally show False by simp
	qed
	finally show ?thesis .
	qed

	lemma sum_dcharacter_antimono_bound:
	fixes x0 a b :: real and f f' :: "real \<Rightarrow> real"
	assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
	assumes x0: "x0 \<ge> 0" and ab: "x0 \<le> a" "a < b"
	assumes f': "\<And>x. x \<ge> x0 \<Longrightarrow> (f has_field_derivative f' x) (at x)"
	assumes f_nonneg: "\<And>x. x \<ge> x0 \<Longrightarrow> f x \<ge> 0"
	assumes f'_nonpos: "\<And>x. x \<ge> x0 \<Longrightarrow> f' x \<le> 0"
	shows "norm (\<Sum>n\<in>real -` {a<..b}. \<chi> n * (f (real n))) \<le> 2 * real (totient n) * f a"
	proof -
	note deriv = has_field_derivative_at_within [OF f']
	let ?A = "sum_upto \<chi>"
	have cont: "continuous_on {a..b} f"
	by (rule DERIV_continuous_on[OF deriv]) (use ab in auto)
	have I': "(f' has_integral (f b - f a)) {a..b}"
	using ab deriv by (intro fundamental_theorem_of_calculus)
	(auto simp: has_field_derivative_iff_has_vector_derivative [symmetric])

	define I where "I = integral {a..b} (\<lambda>t. ?A t * of_real (f' t))"
	define C where "C = real (totient n)"
	have C_nonneg: "C \<ge> 0" by (simp add: C_def)
	have C: "norm (?A x) \<le> C" for x
	proof -
	have "?A x = (\<Sum>k\<le>nat \<lfloor>x\<rfloor>. \<chi> k)" unfolding sum_upto_altdef
	by (intro sum.mono_neutral_left) auto
	also have "norm \<dots> \<le> C" unfolding C_def using nonprincipal
	by (rule sum_dcharacter_atMost_le)
	finally show ?thesis .
	qed

	have I: "((\<lambda>t. ?A t * f' t) has_integral ?A b * f b - ?A a * f a -
	(\<Sum>n\<in>real -` {a<..b}. \<chi> n * f (real n))) {a..b}" using ab x0 cont f'
	by (intro partial_summation_strong[of "{}"] has_vector_derivative_of_real) auto
	hence "(\<Sum>n\<in>real -` {a<..b}. \<chi> n * f (real n)) = ?A b * f b - ?A a * f a - I"
	by (simp add: has_integral_iff I_def)
	also have "norm \<dots> \<le> norm (?A b) * norm (f b) + norm (?A a) * norm (f a) + norm I"
	by (rule order.trans[OF norm_triangle_ineq4] add_mono)+ (simp_all add: norm_mult)
	also have "norm I \<le> integral {a..b} (\<lambda>t. of_real (-C) * of_real (f' t))"
	unfolding I_def using I I' f'_nonpos ab C
	by (intro integral_norm_bound_integral integrable_on_cmult_left)
	(simp_all add: has_integral_iff norm_mult mult_right_mono_neg)
	also have "\<dots> = - (C * (f b - f a))"
	using integral_linear[OF _ bounded_linear_of_real, of f' "{a..b}"] I'
	by (simp add: has_integral_iff o_def )
	also have "\<dots> = C * (f a - f b)" by (simp add: algebra_simps)
	also have "norm (sum_upto \<chi> b) \<le> C" by (rule C)
	also have "norm (sum_upto \<chi> a) \<le> C" by (rule C)
	also have "C * norm (f b) + C * norm (f a) + C * (f a - f b) = 2 * C * f a"
	using f_nonneg[of a] f_nonneg[of b] ab by (simp add: algebra_simps)
	finally show ?thesis by (simp add: mult_right_mono C_def)
	qed

	lemma summable_dcharacter_antimono:
	fixes x0 a b :: real and f f' :: "real \<Rightarrow> real"
	assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
	assumes f': "\<And>x. x \<ge> x0 \<Longrightarrow> (f has_field_derivative f' x) (at x)"
	assumes f_nonneg: "\<And>x. x \<ge> x0 \<Longrightarrow> f x \<ge> 0"
	assumes f'_nonpos: "\<And>x. x \<ge> x0 \<Longrightarrow> f' x \<le> 0"
	assumes lim: "(f \<longlongrightarrow> 0) at_top"
	shows "summable (\<lambda>n. \<chi> n * f n)"
	proof (rule summable_bounded_partials [where ?g = "\<lambda>x. 2 * real (totient n) * f x"], goal_cases)
	case 1
	from eventually_ge_at_top[of "nat \<lceil>x0\<rceil>"] show ?case
	proof eventually_elim
	case (elim x)
	show ?case
	proof (safe, goal_cases)
	case (1 a b)
	with elim have *: "max 0 x0 \<ge> 0" "max 0 x0 \<le> a" "real a < real b"
	by (simp_all add: nat_le_iff ceiling_le_iff)
	have "(\<Sum>n\<in>{a<..b}. \<chi> n * complex_of_real (f (real n))) =
	(\<Sum>n\<in>real -` {real a<..real b}. \<chi> n * complex_of_real (f (real n)))"
	by (intro sum.cong refl) auto
	also have "norm \<dots> \<le> 2 * real (totient n) * f a"
	using nonprincipal * f' f_nonneg f'_nonpos by (rule sum_dcharacter_antimono_bound) simp_all
	finally show ?case .
	qed
	qed
	qed (auto intro!: tendsto_mult_right_zero filterlim_compose[OF lim] filterlim_real_sequentially)

	lemma conv_abscissa_le_0:
	fixes s :: real
	assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
	shows "conv_abscissa (fds \<chi>) \<le> 0"
	proof (rule conv_abscissa_leI)
	fix s assume s: "0 < ereal s"
	have "summable (\<lambda>n. \<chi> n * of_real (n powr -s))"
	proof (rule summable_dcharacter_antimono[of 1])
	fix x :: real assume "x \<ge> 1"
	thus "((\<lambda>x. x powr -s) has_field_derivative (-s * x powr (-s-1))) (at x)"
	by (auto intro!: derivative_eq_intros)
	qed (insert s assms, auto intro!: tendsto_neg_powr filterlim_ident)
	thus "\<exists>s'::complex. s' \<bullet> 1 = s \<and> fds_converges (fds \<chi>) s'" using s
	by (intro exI[of _ "of_real s"])
	(auto simp: fds_converges_def powr_minus divide_simps powr_of_real [symmetric] fds_nth_fds')
	qed

	lemma summable_Dirichlet_L':
	assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
	assumes s: "Re s > 0"
	shows "summable (\<lambda>n. \<chi> n * of_nat n powr -s)"
	proof -
	from assms have "fds_converges (fds \<chi>) s"
	by (intro fds_converges le_less_trans[OF conv_abscissa_le_0]) auto
	thus ?thesis by (simp add: fds_converges_def powr_minus divide_simps fds_nth_fds')
	qed

	lemma
	assumes "\<chi> \<noteq> \<chi>\<^sub>0"
	shows Dirichlet_L_conv_eval_fds: "\<And>s. Re s > 0 \<Longrightarrow> Dirichlet_L n \<chi> s = eval_fds (fds \<chi>) s"
	and holomorphic_Dirichlet_L: "Dirichlet_L n \<chi> holomorphic_on A"
	proof -
	show eq: "Dirichlet_L n \<chi> s = eval_fds (fds \<chi>) s" (is "?f s = ?g s") if "Re s > 0" for s
	proof (cases "s = 1")
	case False
	show ?thesis
	proof (rule analytic_continuation_open[where ?f = ?f and ?g = ?g])
	show "{s. Re s > 1} \<subseteq> {s. Re s > 0} - {1}" by auto
	show "connected ({s. 0 < Re s} - {1})"
	using aff_dim_halfspace_gt[of 0 "1::complex"]
	by (intro connected_punctured_convex convex_halfspace_Re_gt) auto
	qed (insert that n assms False,
	auto intro!: convex_halfspace_Re_gt open_halfspace_Re_gt exI[of _ 2]
	holomorphic_intros holomorphic_Dirichlet_L_weak
	Dirichlet_L_conv_eval_fds_weak le_less_trans[OF conv_abscissa_le_0])
	qed (insert assms, simp_all add: Dirichlet_L_def)

	have "Dirichlet_L n \<chi> holomorphic_on UNIV"
	proof (rule no_isolated_singularity')
	from n show "Dirichlet_L n \<chi> holomorphic_on (UNIV - {1})"
	by (intro holomorphic_Dirichlet_L_weak) auto
	next
	fix s :: complex assume s: "s \<in> {1}"
	show "Dirichlet_L n \<chi> \<midarrow>s\<rightarrow> Dirichlet_L n \<chi> s"
	proof (rule Lim_transform_eventually)
	from assms have "continuous_on {s. Re s > 0} (eval_fds (fds \<chi>))"
	by (intro holomorphic_fds_eval holomorphic_on_imp_continuous_on)
	(auto intro: le_less_trans[OF conv_abscissa_le_0])
	hence "eval_fds (fds \<chi>) \<midarrow>s\<rightarrow> eval_fds (fds \<chi>) s" using s
	by (subst (asm) continuous_on_eq_continuous_at) (auto simp: open_halfspace_Re_gt isCont_def)
	also have "eval_fds (fds \<chi>) s = Dirichlet_L n \<chi> s"
	using assms s by (simp add: Dirichlet_L_def)
	finally show "eval_fds (fds \<chi>) \<midarrow>s\<rightarrow> Dirichlet_L n \<chi> s" .
	next
	have "eventually (\<lambda>z. z \<in> {z. Re z > 0}) (nhds s)" using s
	by (intro eventually_nhds_in_open) (auto simp: open_halfspace_Re_gt)
	hence "eventually (\<lambda>z. z \<in> {z. Re z > 0}) (at s)"
	unfolding eventually_at_filter by eventually_elim auto
	then show "eventually (\<lambda>z. eval_fds (fds \<chi>) z = Dirichlet_L n \<chi> z) (at s)"
	by eventually_elim (auto intro!: eq [symmetric])
	qed
	qed auto
	thus "Dirichlet_L n \<chi> holomorphic_on A" by (rule holomorphic_on_subset) auto
	qed

	lemma cnj_Dirichlet_L:
	"cnj (Dirichlet_L n \<chi> s) = Dirichlet_L n (inv_character \<chi>) (cnj s)"
	proof -
	{
	assume *: "\<chi> \<noteq> \<chi>\<^sub>0" "s = 1"
	with summable_Dirichlet_L'[of 1] have "(\<lambda>n. \<chi> n / n) sums eval_fds (fds \<chi>) 1"
	by (simp add: eval_fds_def fds_nth_fds' powr_minus sums_iff divide_simps)
	hence "(\<lambda>n. inv_character \<chi> n / n) sums cnj (eval_fds (fds \<chi>) 1)"
	by (subst (asm) sums_cnj [symmetric]) (simp add: inv_character_def)
	hence "eval_fds (fds (inv_character \<chi>)) 1 = cnj (eval_fds (fds \<chi>) 1)"
	by (simp add: eval_fds_def fds_nth_fds' inv_character_def sums_iff)
	}
	thus ?thesis by (auto simp add: Dirichlet_L_def cnj_powr eval_inv_character)
	qed

	(<)
	end
	(>)
	end

	(<)
	context
	includes no_vec_lambda_notation
	begin
	(>)

	lemma holomorphic_Dirichlet_L [holomorphic_intros]:
	assumes "n > 1" "\<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> 1 \<notin> A"
	shows "Dirichlet_L n \<chi> holomorphic_on A"
	using assms(2)
	proof
	assume "\<chi> = principal_dchar n \<and> 1 \<notin> A"
	with holomorphic_Dirichlet_L_weak[of n A "principal_dchar n"] assms(1) show ?thesis by auto
	qed (insert dcharacter.holomorphic_Dirichlet_L[of n \<chi> A], auto)

	lemma holomorphic_Dirichlet_L' [holomorphic_intros]:
	assumes "n > 1" "f holomorphic_on A"
	"\<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> (\<forall>x\<in>A. f x \<noteq> 1)"
	shows "(\<lambda>s. Dirichlet_L n \<chi> (f s)) holomorphic_on A"
	using holomorphic_on_compose[OF assms(2) holomorphic_Dirichlet_L[OF assms(1), of \<chi>]] assms
	by (auto simp: o_def image_iff)

	lemma continuous_on_Dirichlet_L:
	assumes "n > 1" "\<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> 1 \<notin> A"
	shows "continuous_on A (Dirichlet_L n \<chi>)"
	using assms by (intro holomorphic_on_imp_continuous_on holomorphic_intros)

	lemma continuous_on_Dirichlet_L' [continuous_intros]:
	assumes "continuous_on A f" "n > 1"
	and "\<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> (\<forall>x\<in>A. f x \<noteq> 1)"
	shows "continuous_on A (\<lambda>x. Dirichlet_L n \<chi> (f x))"
	using continuous_on_compose2[OF continuous_on_Dirichlet_L[of n \<chi> "f ` A"] assms(1)] assms
	by (auto simp: image_iff)

	corollary continuous_Dirichlet_L [continuous_intros]:
	"n > 1 \<Longrightarrow> \<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> s \<noteq> 1 \<Longrightarrow>
	continuous (at s within A) (Dirichlet_L n \<chi>)"
	by (rule continuous_within_subset[of _ UNIV])
	(insert continuous_on_Dirichlet_L[of n \<chi> "(if \<chi> = principal_dchar n then -{1} else UNIV)"],
	auto simp: continuous_on_eq_continuous_at open_Compl)

	corollary continuous_Dirichlet_L' [continuous_intros]:
	"n > 1 \<Longrightarrow> continuous (at s within A) f \<Longrightarrow>
	\<chi> \<noteq> principal_dchar n \<and> dcharacter n \<chi> \<or> \<chi> = principal_dchar n \<and> f s \<noteq> 1 \<Longrightarrow>
	continuous (at s within A) (\<lambda>x. Dirichlet_L n \<chi> (f x))"
	by (rule continuous_within_compose3[OF continuous_Dirichlet_L]) auto

	(<)
	end
	(>)


	context residues_nat
	begin
	(<)
	context
	includes no_vec_lambda_notation dcharacter_syntax
	begin
	(>)

	text \<open>
	Applying the above to the $L(\chi_0,s)$, the $L$ function of the principal character, we find
	that it differs from the Riemann $\zeta$ function only by multiplication with a constant that
	depends only on the modulus $n$. They therefore have the same analytic properties as the $\zeta$
	function itself.
	\<close>
	lemma Dirichlet_L_principal:
	fixes s :: complex
	shows "Dirichlet_L n \<chi>\<^sub>0 s = (\<Prod>p \| prime p \<and> p dvd n. (1 - 1 / p powr s)) * zeta s"
	(is "?f s = ?g s")
	proof (cases "s = 1")
	case False
	show ?thesis
	proof (rule analytic_continuation_open[where ?f = ?f and ?g = ?g])
	show "{s. Re s > 1} \<subseteq> - {1}" by auto
	show "?f s = ?g s" if "s \<in> {s. Re s > 1}" for s
	proof -
	from that have s: "Re s > 1" by simp
	let ?P = "(\<Prod>p \| prime p \<and> p dvd n. (1 - 1 / p powr s))"
	have "(\<lambda>n. \<Prod>p\<le>n. if prime p then inverse (1 - \<chi>\<^sub>0 p / nat_power p s) else 1)
	\<longlonglongrightarrow> Dirichlet_L n \<chi>\<^sub>0 s"
	using s by (rule principal.Dirichlet_L_euler_product_LIMSEQ)
	also have "?this \<longleftrightarrow> (\<lambda>n. ?P * (\<Prod>p\<le>n. if prime p then inverse (1 - 1 / of_nat p powr s) else 1))
	\<longlonglongrightarrow> Dirichlet_L n \<chi>\<^sub>0 s" (is "_ = filterlim ?g _ _")
	proof (intro tendsto_cong eventually_mono [OF eventually_ge_at_top, of n], goal_cases)
	case (1 m)
	let ?f = "\<lambda>p. inverse (1 - 1 / p powr s)"
	have "(\<Prod>p\<le>m. if prime p then inverse (1 - \<chi>\<^sub>0 p / nat_power p s) else 1) =
	(\<Prod>p \| p \<le> m \<and> prime p \<and> coprime p n. ?f p)" (is "_ = prod _ ?A")
	by (intro prod.mono_neutral_cong_right) (auto simp: principal_dchar_def)
	also have "?A = {p. p \<le> m \<and> prime p} - {p. prime p \<and> p dvd n}"
	(is "_ = ?B - ?C") using n by (auto dest: prime_imp_coprime simp: coprime_absorb_left)
	also {
	have : "(\<Prod>p\<in>?B. ?f p) = (\<Prod>p\<in>?B - ?C. ?f p) (\<Prod>p\<in>?C. ?f p)"
	using 1 n by (intro prod.subset_diff) (auto dest: dvd_imp_le)
	have "(\<Prod>p\<in>?B. ?f p) * ?P = (\<Prod>p\<in>?B - ?C. ?f p) * ((\<Prod>p\<in>?C. ?f p) * ?P)"
	by (subst *) (simp add: mult_ac)
	also have "(\<Prod>p\<in>?C. ?f p) * ?P = (\<Prod>p\<in>?C. 1)"
	by (subst prod.distrib [symmetric], rule prod.cong)
	(insert s, auto simp: divide_simps powr_def exp_eq_1)
	also have "\<dots> = 1" by simp
	finally have "(\<Prod>p\<in>?B - ?C. ?f p) = (\<Prod>p\<in>?B. ?f p) * ?P" by simp
	}
	also have "(\<Prod>p\<in>?B. ?f p) = (\<Prod>p\<le>m. if prime p then ?f p else 1)"
	by (intro prod.mono_neutral_cong_left) auto
	finally show ?case by (simp only: mult_ac)
	qed
	finally have "?g \<longlonglongrightarrow> Dirichlet_L n \<chi>\<^sub>0 s" .
	moreover have "?g \<longlonglongrightarrow> ?P * zeta s"
	by (intro tendsto_mult tendsto_const euler_product_zeta s)
	ultimately show "Dirichlet_L n \<chi>\<^sub>0 s = ?P * zeta s"
	by (rule LIMSEQ_unique)
	qed
	qed (insert \<open>s \<noteq> 1\<close> n, auto intro!: holomorphic_intros holomorphic_Dirichlet_L_weak
	open_halfspace_Re_gt exI[of _ 2] connected_punctured_universe)
	qed (simp_all add: Dirichlet_L_def zeta_1)

	(<)
	end
	(>)
	end



	subsection \<open>The non-vanishing for $\mathfrak{R}(s)\geq 1$\<close>

	lemma coprime_prime_exists:
	assumes "n > (0 :: nat)"
	obtains p where "prime p" "coprime p n"
	proof -
	from bigger_prime[of n] obtain p where p: "prime p" "p > n" by auto
	with assms have "\<not>p dvd n" by (auto dest: dvd_imp_le)
	with p have "coprime p n" by (intro prime_imp_coprime)
	with that[of p] and p show ?thesis by auto
	qed

	text \<open>
	The case of the principal character is trivial, since it differs from the Riemann $\zeta(s)$
	only in a multiplicative factor that is clearly non-zero for $\mathfrak{R}(s) \geq 1$.
	\<close>
	theorem (in residues_nat) Dirichlet_L_Re_ge_1_nonzero_principal:
	assumes "Re s \<ge> 1" "s \<noteq> 1"
	shows "Dirichlet_L n (principal_dchar n) s \<noteq> 0"
	proof -
	have "(\<Prod>p \| prime p \<and> p dvd n. 1 - 1 / p powr s) \<noteq> (0 :: complex)"
	proof (subst prod_zero_iff)
	from n show "finite {p. prime p \<and> p dvd n}" by (intro finite_prime_divisors) auto
	show "\<not>(\<exists>p\<in>{p. prime p \<and> p dvd n}. 1 - 1 / p powr s = 0)"
	proof safe
	fix p assume p: "prime p" "p dvd n" and "1 - 1 / p powr s = 0"
	hence "norm (p powr s) = 1" by simp
	also have "norm (p powr s) = real p powr Re s" by (simp add: norm_powr_real_powr)
	finally show False using p assms by (simp add: powr_def prime_gt_0_nat)
	qed
	qed
	with zeta_Re_ge_1_nonzero[OF assms] show ?thesis by (simp add: Dirichlet_L_principal)
	qed

	text \<open>
	The proof for non-principal character is quite involved and is typically very complicated
	and technical in most textbooks. For instance, Apostol~\cite{apostol1976analytic} proves the
	result separately for real and non-real characters, where the non-real case is relatively short
	and nice, but the real case involves a number of complicated asymptotic estimates.

	The following proof, on the other hand -- like our proof of the analogous result for the
	Riemann $\zeta$ function -- is based on Newman's book~\cite{newman1998analytic}. Newman gives
	a very short, concise, and high-level sketch that we aim to reproduce faithfully here.
	\<close>
	context dcharacter
	begin
	(<)
	context
	includes no_vec_lambda_notation dcharacter_syntax
	begin
	(>)

	theorem Dirichlet_L_Re_ge_1_nonzero_nonprincipal:
	assumes "\<chi> \<noteq> \<chi>\<^sub>0" and "Re u \<ge> 1"
	shows "Dirichlet_L n \<chi> u \<noteq> 0"
	proof (cases "Re u > 1")
	include dcharacter_syntax
	case False
	define a where "a = -Im u"
	from False and assms have "Re u = 1" by simp
	hence [simp]: "u = 1 - \<i> * a" by (simp add: a_def complex_eq_iff)

	show ?thesis
	proof
	assume "Dirichlet_L n \<chi> u = 0"
	hence zero: "Dirichlet_L n \<chi> (1 - \<i> * a) = 0" by simp
	define \<chi>' where [simp]: "\<chi>' = inv_character \<chi>"

	\<comment> \<open>We define the function $Z(s)$, which is the product of all the Dirichlet $L$ functions,
	and its Dirichlet series. Then, similarly to the proof of the non-vanishing of the
	Riemann $\zeta$ function for $\mathfrak{R}(s) \geq 1$, we define
	$Q(s) = Z(s) Z(s + ia) Z(s - ia)$. Our objective is to show that the Dirichlet series
	of this function $Q$ converges everywhere.\<close>
	define Z where "Z = (\<lambda>s. \<Prod>\<chi>\<in>dcharacters n. Dirichlet_L n \<chi> s)"
	define Z_fds where "Z_fds = (\<Prod>\<chi>\<in>dcharacters n. fds \<chi>)"
	define Q where "Q = (\<lambda>s. Z s ^ 2 * Z (s + \<i> * a) * Z (s - \<i> * a))"
	define Q_fds where "Q_fds = Z_fds ^ 2 * fds_shift (\<i> * a) Z_fds * fds_shift (-\<i> * a) Z_fds"
	let ?sings = "{1, 1 + \<i> * a, 1 - \<i> * a}"

	\<comment> \<open>Some preliminary auxiliary facts\<close>
	define P where "P = (\<lambda>s. (\<Prod>x\<in>{p. prime p \<and> p dvd n}. 1 - 1 / of_nat x powr s :: complex))"
	have \<chi>\<^sub>0: "\<chi>\<^sub>0 \<in> dcharacters n" by (auto simp: principal.dcharacter_axioms dcharacters_def)
	have [continuous_intros]: "continuous_on A P" for A unfolding P_def
	by (intro continuous_intros) (auto simp: prime_gt_0_nat)
	from this[of UNIV] have [continuous_intros]: "isCont P s" for s
	by (auto simp: continuous_on_eq_continuous_at)
	have \<chi>: "\<chi> \<in> dcharacters n" "\<chi>' \<in> dcharacters n" using dcharacter_axioms
	by (auto simp add: dcharacters_def dcharacter.dcharacter_inv_character)
	from zero dcharacter.cnj_Dirichlet_L[of n \<chi> "1 - \<i> * a"] dcharacter_axioms
	have zero': "Dirichlet_L n \<chi>' (1 + \<i> * a) = 0" by simp

	have "Z = (\<lambda>s. Dirichlet_L n \<chi>\<^sub>0 s * (\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0}. Dirichlet_L n \<chi> s))"
	unfolding Z_def using \<chi>\<^sub>0 by (intro ext prod.remove) auto
	also have "\<dots> = (\<lambda>s. P s * zeta s * (\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0}. Dirichlet_L n \<chi> s))"
	by (simp add: Dirichlet_L_principal P_def)
	finally have Z_eq: "Z = (\<lambda>s. P s * zeta s * (\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0}. Dirichlet_L n \<chi> s))" .

	have Z_eq': "Z = (\<lambda>s. P s * zeta s * Dirichlet_L n \<chi> s *
	(\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0} - {\<chi>}. Dirichlet_L n \<chi> s))"
	if "\<chi> \<in> dcharacters n" "\<chi> \<noteq> \<chi>\<^sub>0" for \<chi>
	proof (rule ext, goal_cases)
	case (1 s)
	from that have \<chi>: "\<chi> \<in> dcharacters n" by (simp add: dcharacters_def)
	have "Z s = P s * zeta s *
	(\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0}. Dirichlet_L n \<chi> s)" by (simp add: Z_eq)
	also have "(\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0}. Dirichlet_L n \<chi> s) = Dirichlet_L n \<chi> s *
	(\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0} - {\<chi>}. Dirichlet_L n \<chi> s)"
	using assms \<chi> that by (intro prod.remove) auto
	finally show ?case by (simp add: mult_ac)
	qed

	\<comment> \<open>We again show that @{term Q} is locally bounded everywhere by showing that every
	singularity is cancelled by some zero. Since now, @{term a} can be zero, we do a
	case distinction here to make things a bit easier.\<close>
	have Q_bigo_1: "Q \<in> O[at s](\<lambda>_. 1)" for s
	proof (cases "a = 0")
	case True
	have "(\<lambda>s. Dirichlet_L n \<chi> s - Dirichlet_L n \<chi> 1) \<in> O[at 1](\<lambda>s. s - 1)" using \<chi> assms n
	by (intro taylor_bigo_linear holomorphic_on_imp_differentiable_at[of _ UNIV]
	holomorphic_intros) (auto simp: dcharacters_def)
	hence *: "Dirichlet_L n \<chi> \<in> O[at 1](\<lambda>s. s - 1)" using zero True by simp
	have "Z = (\<lambda>s. P s * zeta s * Dirichlet_L n \<chi> s *
	(\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0} - {\<chi>}. Dirichlet_L n \<chi> s))"
	using \<chi> assms by (intro Z_eq') auto
	also have "\<dots> \<in> O[at 1](\<lambda>s. 1 * (1 / (s - 1)) * (s - 1) * 1)" using n \<chi>
	by (intro landau_o.big.mult continuous_imp_bigo_1 zeta_bigo_at_1 continuous_intros *)
	(auto simp: dcharacters_def)
	also have "(\<lambda>s::complex. 1 * (1 / (s - 1)) * (s - 1) * 1) \<in> \<Theta>[at 1](\<lambda>_. 1)"
	by (intro bigthetaI_cong) (auto simp: eventually_at_filter)
	finally have Z_at_1: "Z \<in> O[at 1](\<lambda>_. 1)" .

	have "Z \<in> O[at s](\<lambda>_. 1)"
	proof (cases "s = 1")
	case False
	thus ?thesis unfolding Z_def using n \<chi>
	by (intro continuous_imp_bigo_1 continuous_intros) (auto simp: dcharacters_def)
	qed (insert Z_at_1, auto)

	from \<open>a = 0\<close> have "Q = (\<lambda>s. Z s * Z s * Z s * Z s)"
	by (simp add: Q_def power2_eq_square)
	also have "\<dots> \<in> O[at s](\<lambda>_. 1 * 1 * 1 * 1)"
	by (intro landau_o.big.mult) fact+
	finally show ?thesis by simp
	next
	case False
	have bigo1: "(\<lambda>s. Z s * Z (s - \<i> * a)) \<in> O[at 1](\<lambda>_. 1)"
	if "Dirichlet_L n \<chi> (1 - \<i> * a) = 0" "a \<noteq> 0" "\<chi> \<in> dcharacters n" "\<chi> \<noteq> \<chi>\<^sub>0"
	for a :: real and \<chi>
	proof -
	have "(\<lambda>s. Dirichlet_L n \<chi> (s - \<i> * a) - Dirichlet_L n \<chi> (1 - \<i> * a)) \<in> O[at 1](\<lambda>s. s - 1)"
	using assms n that
	by (intro taylor_bigo_linear holomorphic_on_imp_differentiable_at[of _ UNIV]
	holomorphic_intros) (auto simp: dcharacters_def)
	hence : "(\<lambda>s. Dirichlet_L n \<chi> (s - \<i> a)) \<in> O[at 1](\<lambda>s. s - 1)" using that by simp

	have "(\<lambda>s. Z (s - \<i>a)) = (\<lambda>s. P (s - \<i>a) * zeta (s - \<i>a) Dirichlet_L n \<chi> (s - \<i>*a)
	* (\<Prod>\<chi>\<in>dcharacters n - {\<chi>\<^sub>0} - {\<chi>}. Dirichlet_L n \<chi> (s - \<i>*a)))"
	using that by (subst Z_eq'[of \<chi>]) auto
	also have "\<dots> \<in> O[at 1](\<lambda>s. 1 * 1 * (s - 1) * 1)" unfolding P_def using that n
	by (intro landau_o.big.mult continuous_imp_bigo_1 continuous_intros *)
	(auto simp: prime_gt_0_nat dcharacters_def)
	finally have "(\<lambda>s. Z (s - \<i> * a)) \<in> O[at 1](\<lambda>s. s - 1)" by simp
	moreover have "Z \<in> O[at 1](\<lambda>s. 1 * (1 / (s - 1)) * 1)" unfolding Z_eq using n that
	by (intro landau_o.big.mult zeta_bigo_at_1 continuous_imp_bigo_1 continuous_intros)
	(auto simp: dcharacters_def)
	hence "Z \<in> O[at 1](\<lambda>s. 1 / (s - 1))" by simp
	ultimately have "(\<lambda>s. Z s * Z (s - \<i> * a)) \<in> O[at 1](\<lambda>s. 1 / (s - 1) * (s - 1))"
	by (intro landau_o.big.mult)
	also have "(\<lambda>s. 1 / (s - 1) * (s - 1)) \<in> \<Theta>[at 1](\<lambda>_. 1)"
	by (intro bigthetaI_cong) (auto simp add: eventually_at_filter)
	finally show ?thesis .
	qed

	have bigo1': "(\<lambda>s. Z s * Z (s + \<i> * a)) \<in> O[at 1](\<lambda>_. 1)"
	if "Dirichlet_L n \<chi> (1 - \<i> * a) = 0" "a \<noteq> 0" "\<chi> \<in> dcharacters n" "\<chi> \<noteq> \<chi>\<^sub>0"
	for a :: real and \<chi>
	proof -
	from that interpret dcharacter n G \<chi> by (simp_all add: dcharacters_def G_def)
	from bigo1[of "inv_character \<chi>" "-a"] that cnj_Dirichlet_L[of "1 - \<i> * a"] show ?thesis
	by (simp add: dcharacters_def dcharacter_inv_character)
	qed

	have bigo2: "(\<lambda>s. Z s * Z (s - \<i> * a)) \<in> O[at (1 + \<i> * a)](\<lambda>_. 1)"
	if "Dirichlet_L n \<chi> (1 - \<i> * a) = 0" "a \<noteq> 0" "\<chi> \<in> dcharacters n" "\<chi> \<noteq> \<chi>\<^sub>0"
	for a :: real and \<chi>
	proof -
	have "(\<lambda>s. Z s * Z (s - \<i> * a)) \<in> O[filtermap (\<lambda>s. s + \<i> * a) (at 1)](\<lambda>_. 1)"
	using bigo1'[of \<chi> a] that by (simp add: mult.commute landau_o.big.in_filtermap_iff)
	also have "filtermap (\<lambda>s. s + \<i> * a) (at 1) = at (1 + \<i> * a)"
	using filtermap_at_shift[of "-\<i> * a" 1] by simp
	finally show ?thesis .
	qed

	have bigo2': "(\<lambda>s. Z s * Z (s + \<i> * a)) \<in> O[at (1 - \<i> * a)](\<lambda>_. 1)"
	if "Dirichlet_L n \<chi> (1 - \<i> * a) = 0" "a \<noteq> 0" "\<chi> \<in> dcharacters n" "\<chi> \<noteq> \<chi>\<^sub>0"
	for a :: real and \<chi>
	proof -
	from that interpret dcharacter n G \<chi> by (simp_all add: dcharacters_def G_def)
	from bigo2[of "inv_character \<chi>" "-a"] that cnj_Dirichlet_L[of "1 - \<i> * a"] show ?thesis
	by (simp add: dcharacters_def dcharacter_inv_character)
	qed

	have Q_eq: "Q = (\<lambda>s. (Z s * Z (s + \<i> * a)) * (Z s * Z (s - \<i> * a)))"
	by (simp add: Q_def power2_eq_square mult_ac)

	consider "s = 1" \| "s = 1 + \<i> * a" \| "s = 1 - \<i> * a" \| "s \<notin> ?sings" by blast
	thus ?thesis
	proof cases
	case 1
	have "Q \<in> O[at 1](\<lambda>_. 1 * 1)"
	unfolding Q_eq using assms zero zero' False \<chi>
	by (intro landau_o.big.mult bigo1[of \<chi> a] bigo1'[of \<chi> a]; simp)+
	with 1 show ?thesis by simp
	next
	case 2
	have "Q \<in> O[at (1 + \<i> * a)](\<lambda>_. 1 * 1)" unfolding Q_eq
	using assms zero zero' False \<chi> n
	by (intro landau_o.big.mult bigo2[of \<chi> a] continuous_imp_bigo_1)
	(auto simp: Z_def dcharacters_def intro!: continuous_intros)
	with 2 show ?thesis by simp
	next
	case 3
	have "Q \<in> O[at (1 - \<i> * a)](\<lambda>_. 1 * 1)" unfolding Q_eq
	using assms zero zero' False \<chi> n
	by (intro landau_o.big.mult bigo2'[of \<chi> a] continuous_imp_bigo_1)
	(auto simp: Z_def dcharacters_def intro!: continuous_intros)
	with 3 show ?thesis by simp
	next
	case 4
	thus ?thesis unfolding Q_def Z_def using n
	by (intro continuous_imp_bigo_1 continuous_intros)
	(auto simp: dcharacters_def complex_eq_iff)
	qed
	qed

	\<comment> \<open>Again, we can remove the singularities from @{term Q} and extend it to an entire function.\<close>
	have "\<exists>Q'. Q' holomorphic_on UNIV \<and> (\<forall>z\<in>UNIV - ?sings. Q' z = Q z)"
	using n by (intro removable_singularities Q_bigo_1)
	(auto simp: Q_def Z_def dcharacters_def complex_eq_iff intro!: holomorphic_intros)
	then obtain Q' where Q': "Q' holomorphic_on UNIV" "\<And>z. z \<notin> ?sings \<Longrightarrow> Q' z = Q z" by blast

	\<comment> \<open>@{term Q'} constitutes an analytic continuation of the Dirichlet series of @{term Q}.\<close>
	have eval_Q_fds: "eval_fds Q_fds s = Q' s" if "Re s > 1" for s
	proof -
	have [simp]: "dcharacter n \<chi>" if "\<chi> \<in> dcharacters n" for \<chi>
	using that by (simp add: dcharacters_def)
	from that have "abs_conv_abscissa (fds \<chi>) < ereal (Re s)" if "\<chi> \<in> dcharacters n" for \<chi>
	using that by (intro le_less_trans[OF dcharacter.abs_conv_abscissa_weak[of n \<chi>]]) auto
	hence "eval_fds Q_fds s = Q s" using that
	by (simp add: Q_fds_def Q_def eval_fds_mult eval_fds_power fds_abs_converges_mult
	eval_fds_prod fds_abs_converges_prod dcharacter.Dirichlet_L_conv_eval_fds_weak
	fds_abs_converges_power eval_fds_zeta Z_fds_def Z_def fds_abs_converges)
	also from that have "\<dots> = Q' s" by (subst Q') auto
	finally show ?thesis .
	qed

	\<comment> \<open>Since the characters are completely multiplicative, the series for this logarithm can
	be rewritten like this:\<close>
	define I where "I = (\<lambda>k. if [k = 1] (mod n) then totient n else 0 :: real)"
	have ln_Q_fds_eq:
	"fds_ln 0 Q_fds = fds (\<lambda>k. of_real (2 * I k * mangoldt k / ln k * (1 + cos (a * ln k))))"
	proof -
	have nz: "\<chi> (Suc 0) = 1" if "\<chi> \<in> dcharacters n" for \<chi>
	using dcharacter.Suc_0[of n \<chi>] that by (simp add: dcharacters_def)
	note simps = fds_ln_mult[where l' = 0 and l'' = 0] fds_ln_power[where l' = 0]
	fds_ln_prod[where l' = "\<lambda>_. 0"]
	have "fds_ln 0 Q_fds = (\<Sum>\<chi>\<in>dcharacters n. 2 * fds_ln 0 (fds \<chi>) +
	fds_shift (\<i> * a) (fds_ln 0 (fds \<chi>)) + fds_shift (-\<i> * a) (fds_ln 0 (fds \<chi>)))"
	by (auto simp: Q_fds_def Z_fds_def simps nz sum.distrib sum_distrib_left)
	also have "\<dots> = (\<Sum>\<chi>\<in>dcharacters n.
	fds (\<lambda>k. \<chi> k * of_real (2 * mangoldt k / ln k * (1 + cos (a * ln k)))))"
	(is "(\<Sum>\<chi>\<in>_. ?l \<chi>) = _")
	proof (intro sum.cong refl, goal_cases)
	case (1 \<chi>)
	then interpret dcharacter n G \<chi> by (simp_all add: dcharacters_def G_def)
	have mult: "completely_multiplicative_function (fds_nth (fds \<chi>))"
	by (simp add: fds_nth_fds' mult.completely_multiplicative_function_axioms)
	have : "fds_ln 0 (fds \<chi>) = fds (\<lambda>n. \<chi> n mangoldt n /\<^sub>R ln (real n))"
	by (simp add: fds_ln_completely_multiplicative[OF mult] fds_nth_fds' fds_eq_iff)
	have "?l \<chi> = fds (\<lambda>k. \<chi> k * mangoldt k /\<^sub>R ln k * (2 + k powr (\<i> * a) + k powr (-\<i> * a)))"
	by (unfold *, rule fds_eqI) (simp add: algebra_simps scaleR_conv_of_real numeral_fds)
	also have "\<dots> = fds (\<lambda>k. \<chi> k * 2 * mangoldt k /\<^sub>R ln k * (1 + cos (of_real(a * ln k))))"
	unfolding cos_exp_eq by (intro fds_eqI) (simp add: powr_def algebra_simps)
	also have "\<dots> = fds (\<lambda>k. \<chi> k * of_real (2 * mangoldt k / ln k * (1 + cos (a * ln k))))"
	unfolding cos_of_real by (simp add: field_simps scaleR_conv_of_real)
	finally show ?case .
	qed
	also have "\<dots> = fds (\<lambda>k. (\<Sum>\<chi>\<in>dcharacters n. \<chi> k) * of_real (2 * mangoldt k / ln k *
	(1 + cos (a * ln k))))"
	by (simp add: sum_distrib_right sum_divide_distrib scaleR_conv_of_real sum_distrib_left)
	also have "\<dots> = fds (\<lambda>k. of_real (2 * I k * mangoldt k / ln k * (1 + cos (a * ln k))))"
	by (intro fds_eqI, subst sum_dcharacters) (simp_all add: I_def algebra_simps)
	finally show ?thesis .
	qed
	\<comment> \<open>The coefficients of that logarithm series are clearly nonnegative:\<close>
	have "nonneg_dirichlet_series (fds_ln 0 Q_fds)"
	proof
	show "fds_nth (fds_ln 0 Q_fds) k \<in> \<real>\<^sub>\<ge>\<^sub>0" for k
	proof (cases "k < 2")
	case False
	have cos: "1 + cos x \<ge> 0" for x :: real
	using cos_ge_minus_one[of x] by linarith
	have "fds_nth (fds_ln 0 Q_fds) k =
	of_real (2 * I k * mangoldt k / ln k * (1 + cos (a * ln k)))"
	by (auto simp: fds_nth_fds' ln_Q_fds_eq)
	also have "\<dots> \<in> \<real>\<^sub>\<ge>\<^sub>0" using False unfolding I_def
	by (subst nonneg_Reals_of_real_iff)
	(intro mult_nonneg_nonneg divide_nonneg_pos cos mangoldt_nonneg, auto)
	finally show ?thesis .
	qed (cases k; auto simp: ln_Q_fds_eq)
	qed
	\<comment> \<open>Therefore @{term Q_fds} also has non-negative coefficients.\<close>
	hence nonneg: "nonneg_dirichlet_series Q_fds"
	proof (rule nonneg_dirichlet_series_lnD)
	have "(\<Prod>x\<in>dcharacters n. x (Suc 0)) = 1"
	by (intro prod.neutral) (auto simp: dcharacters_def dcharacter.Suc_0)
	thus "exp 0 = fds_nth Q_fds (Suc 0)" by (simp add: Q_fds_def Z_fds_def)
	qed

	\<comment> \<open>And by Pringsheim--Landau, we get that the Dirichlet series of @{term Q} converges
	everywhere.\<close>
	have "abs_conv_abscissa Q_fds \<le> 1" unfolding Q_fds_def Z_fds_def fds_shift_prod
	by (intro abs_conv_abscissa_power_leI abs_conv_abscissa_mult_leI abs_conv_abscissa_prod_le)
	(auto simp: dcharacters_def dcharacter.abs_conv_abscissa_weak)
	with nonneg and eval_Q_fds and \<open>Q' holomorphic_on UNIV\<close>
	have abscissa: "abs_conv_abscissa Q_fds = -\<infinity>"
	by (intro entire_continuation_imp_abs_conv_abscissa_MInfty[where g = Q' and c = 1])
	(auto simp: one_ereal_def)

	\<comment> \<open>Again, similarly to the proof for $\zeta$, we select a subseries of @{term Q}. This time
	we cannot simply pick powers of 2, since 2 might not be coprime to @{term n}, in which
	case the subseries would simply be 1 everywhere, which is not helpful. However, it is
	clear that there \emph{is} always some prime $p$ that is coprime to @{term n}, so we
	just use the subseries @{term Q} that corresponds to powers of $p$.\<close>
	from n obtain p where p: "prime p" "coprime p n"
	using coprime_prime_exists[of n] by auto
	define R_fds where "R_fds = fds_primepow_subseries p Q_fds"
	have "conv_abscissa R_fds \<le> abs_conv_abscissa R_fds" by (rule conv_le_abs_conv_abscissa)
	also have "abs_conv_abscissa R_fds \<le> abs_conv_abscissa Q_fds"
	unfolding R_fds_def by (rule abs_conv_abscissa_restrict)
	also have "\<dots> = -\<infinity>" by (simp add: abscissa)
	finally have abscissa': "conv_abscissa R_fds = -\<infinity>" by simp

	\<comment> \<open>The following function $g(a,s)$ is the denominator in the Euler product expansion of
	the subseries of $Z(s + ia)$. It is clear that it is entire and non-zero for
	$\mathfrak{R}(s) > 0$ and all real $a$.\<close>
	define g :: "real \<Rightarrow> complex \<Rightarrow> complex"
	where "g = (\<lambda>a s. (\<Prod>\<chi>\<in>dcharacters n. (1 - \<chi> p * p powr (-s + \<i> * of_real a))))"
	have g_nz: "g a s \<noteq> 0" if "Re s > 0" for s a unfolding g_def
	proof (subst prod_zero_iff[OF finite_dcharacters], safe)
	fix \<chi> assume "\<chi> \<in> dcharacters n" and : "1 - \<chi> p p powr (-s + \<i>*a) = 0"
	then interpret dcharacter n G \<chi> by (simp_all add: dcharacters_def G_def)
	from p have "real p > real 1" by (subst of_nat_less_iff) (auto simp: prime_gt_Suc_0_nat)
	hence "real p powr - Re s < real p powr 0"
	- using p that by (intro powr_less_mono) (auto simp: )
	+ using p that by (intro powr_less_mono) auto
	hence "0 < norm (1 :: complex) - norm (\<chi> p * p powr (-s + \<i>*a))"
	using p by (simp add: norm_mult norm norm_powr_real_powr)
	also have "\<dots> \<le> norm (1 - \<chi> p * p powr (-s + \<i>*a))"
	by (rule norm_triangle_ineq2)
	finally show False by (subst (asm) *) simp_all
	qed
	have [holomorphic_intros]: "g a holomorphic_on A" for a A unfolding g_def
	using p by (intro holomorphic_intros)

	\<comment> \<open>By taking Euler product expansions of every factor, we get
	\[R(s) = \frac{1}{g(0,s)^2 g(a,s) g(-a,s)} =
	(1 - 2^{-s})^{-2} (1 - 2^{-s+ia})^{-1} (1 - 2^{-s-ia})^{-1}\]
	for every $s$ with $\mathfrak{R}(s) > 1$, and by analytic continuation also for
	$\mathfrak{R}(s) > 0$.\<close>

	have eval_R: "eval_fds R_fds s = 1 / (g 0 s ^ 2 * g a s * g (-a) s)"
	(is "_ = ?f s") if "Re s > 0" for s :: complex
	proof -
	show ?thesis
	proof (rule analytic_continuation_open[where f = "eval_fds R_fds"])
	show "?f holomorphic_on {s. Re s > 0}" using p g_nz[of 0] g_nz[of a] g_nz[of "-a"]
	by (intro holomorphic_intros) (auto simp: g_nz)
	next
	fix z assume z: "z \<in> {s. Re s > 1}"
	have [simp]: "completely_multiplicative_function \<chi>" "fds_nth (fds \<chi>) = \<chi>"
	if "\<chi> \<in> dcharacters n" for \<chi>
	proof -
	from that interpret dcharacter n G \<chi> by (simp_all add: G_def dcharacters_def)
	show "completely_multiplicative_function \<chi>" "fds_nth (fds \<chi>) = \<chi>"
	by (simp_all add: fds_nth_fds' mult.completely_multiplicative_function_axioms)
	qed
	have [simp]: "dcharacter n \<chi>" if "\<chi> \<in> dcharacters n" for \<chi>
	using that by (simp add: dcharacters_def)
	from that have "abs_conv_abscissa (fds \<chi>) < ereal (Re z)" if "\<chi> \<in> dcharacters n" for \<chi>
	using that z by (intro le_less_trans[OF dcharacter.abs_conv_abscissa_weak[of n \<chi>]]) auto
	thus "eval_fds R_fds z = ?f z" using z p
	by (simp add: R_fds_def Q_fds_def Z_fds_def eval_fds_mult eval_fds_prod eval_fds_power
	fds_abs_converges_mult fds_abs_converges_power fds_abs_converges_prod g_def mult_ac
	fds_primepow_subseries_euler_product_cm powr_minus powr_diff powr_add prod_dividef
	fds_abs_summable_zeta g_nz fds_abs_converges power_one_over divide_inverse [symmetric])
	qed (insert that abscissa', auto intro!: exI[of _ 2] convex_connected open_halfspace_Re_gt
	convex_halfspace_Re_gt holomorphic_intros)
	qed

	\<comment> \<open>We again have our contradiction: $R(s)$ is entire, but the right-hand side has a pole at 0
	since $g(0,0) = 0$.\<close>
	show False
	proof (rule not_tendsto_and_filterlim_at_infinity)
	have g_limit: "(g a \<longlongrightarrow> g a 0) (at 0 within {s. Re s > 0})" for a
	proof -
	have "continuous_on UNIV (g a)" by (intro holomorphic_on_imp_continuous_on holomorphic_intros)
	hence "isCont (g a) 0" by (rule continuous_on_interior) auto
	hence "continuous (at 0 within {s. Re s > 0}) (g a)" by (rule continuous_within_subset) auto
	thus ?thesis by (auto simp: continuous_within)
	qed
	have "((\<lambda>s. g 0 s ^ 2 * g a s * g (-a) s) \<longlongrightarrow> g 0 0 ^ 2 * g a 0 * g (-a) 0)
	(at 0 within {s. Re s > 0})" by (intro tendsto_intros g_limit)
	also have "g 0 0 = 0" unfolding g_def
	proof (rule prod_zero)
	from p and \<chi>\<^sub>0 show "\<exists>\<chi>\<in>dcharacters n. 1 - \<chi> p * of_nat p powr (- 0 + \<i> * of_real 0) = 0"
	by (intro bexI[of _ \<chi>\<^sub>0]) (auto simp: principal_dchar_def)
	qed auto
	moreover have "eventually (\<lambda>s. s \<in> {s. Re s > 0}) (at 0 within {s. Re s > 0})"
	by (auto simp: eventually_at_filter)
	hence "eventually (\<lambda>s. g 0 s ^ 2 * g a s * g (-a) s \<noteq> 0) (at 0 within {s. Re s > 0})"
	by eventually_elim (auto simp: g_nz)
	ultimately have "filterlim (\<lambda>s. g 0 s ^ 2 * g a s * g (-a) s) (at 0)
	(at 0 within {s. Re s > 0})" by (simp add: filterlim_at)
	hence "filterlim ?f at_infinity (at 0 within {s. Re s > 0})" (is ?lim)
	by (intro filterlim_divide_at_infinity[OF tendsto_const]
	tendsto_mult_filterlim_at_infinity) auto
	also have ev: "eventually (\<lambda>s. Re s > 0) (at 0 within {s. Re s > 0})"
	by (auto simp: eventually_at intro!: exI[of _ 1])
	have "?lim \<longleftrightarrow> filterlim (eval_fds R_fds) at_infinity (at 0 within {s. Re s > 0})"
	by (intro filterlim_cong refl eventually_mono[OF ev]) (auto simp: eval_R)
	finally show \<dots> .
	next
	have "continuous (at 0 within {s. Re s > 0}) (eval_fds R_fds)"
	by (intro continuous_intros) (auto simp: abscissa')
	thus "((eval_fds R_fds \<longlongrightarrow> eval_fds R_fds 0)) (at 0 within {s. Re s > 0})"
	by (auto simp: continuous_within)
	next
	have "0 \<in> {s. Re s \<ge> 0}" by simp
	also have "{s. Re s \<ge> 0} = closure {s. Re s > 0}"
	using closure_halfspace_gt[of "1::complex" 0] by (simp add: inner_commute)
	finally have "0 \<in> \<dots>" .
	thus "at 0 within {s. Re s > 0} \<noteq> bot"
	by (subst at_within_eq_bot_iff) auto
	qed
	qed
	qed (fact Dirichlet_L_Re_gt_1_nonzero)


	subsection \<open>Asymptotic bounds on partial sums of Dirichlet $L$ functions\<close>

	text \<open>
	The following are some bounds on partial sums of the $L$-function of a character that are
	useful for asymptotic reasoning, particularly for Dirichlet's Theorem.
	\<close>
	lemma sum_upto_dcharacter_le:
	assumes "\<chi> \<noteq> \<chi>\<^sub>0"
	shows "norm (sum_upto \<chi> x) \<le> totient n"
	proof -
	have "sum_upto \<chi> x = (\<Sum>k\<le>nat \<lfloor>x\<rfloor>. \<chi> k)" unfolding sum_upto_altdef
	by (intro sum.mono_neutral_left) auto
	also have "norm \<dots> \<le> totient n"
	by (rule sum_dcharacter_atMost_le) fact
	finally show ?thesis .
	qed

	lemma Dirichlet_L_minus_partial_sum_bound:
	fixes s :: complex and x :: real
	assumes "\<chi> \<noteq> \<chi>\<^sub>0" and "Re s > 0" and "x > 0"
	defines "\<sigma> \<equiv> Re s"
	shows "norm (sum_upto (\<lambda>n. \<chi> n * n powr -s) x - Dirichlet_L n \<chi> s) \<le>
	real (totient n) * (2 + cmod s / \<sigma>) / x powr \<sigma>"
	proof (rule Lim_norm_ubound)
	from assms have "summable (\<lambda>n. \<chi> n * of_nat n powr -s)"
	by (intro summable_Dirichlet_L')
	with assms have "(\<lambda>n. \<chi> n * of_nat n powr -s) sums Dirichlet_L n \<chi> s"
	using Dirichlet_L_conv_eval_fds[OF assms(1,2)]
	by (simp add: sums_iff eval_fds_def powr_minus divide_simps fds_nth_fds')
	hence "(\<lambda>m. \<Sum>k\<le>m. \<chi> k * of_nat k powr -s) \<longlonglongrightarrow> Dirichlet_L n \<chi> s"
	by (simp add: sums_def' atLeast0AtMost)
	thus "(\<lambda>m. sum_upto (\<lambda>k. \<chi> k * of_nat k powr -s) x - (\<Sum>k\<le>m. \<chi> k * of_nat k powr -s))
	\<longlonglongrightarrow> sum_upto (\<lambda>k. \<chi> k * of_nat k powr -s) x - Dirichlet_L n \<chi> s"
	by (intro tendsto_intros)
	next
	define M where "M = sum_upto \<chi>"
	have le: "norm (\<Sum>n\<in>real-`{x<..y}. \<chi> n * of_nat n powr - s)
	\<le> real (totient n) * (2 + cmod s / \<sigma>) / x powr \<sigma>" if xy: "0 < x" "x < y" for x y
	proof -
	from xy have I: "((\<lambda>t. M t * (-s * t powr (-s-1))) has_integral
	M y * of_real y powr - s - M x * of_real x powr - s -
	(\<Sum>n\<in>real-`{x<..y}. \<chi> n * of_real (real n) powr -s)) {x..y}" unfolding M_def
	by (intro partial_summation_strong [of "{}"])
	(auto intro!: has_vector_derivative_real_field derivative_eq_intros continuous_intros)
	hence "(\<Sum>n\<in>real-`{x<..y}. \<chi> n * real n powr -s) =
	M y * of_real y powr - s - M x * of_real x powr - s -
	integral {x..y} (\<lambda>t. M t * (-s * t powr (-s-1)))"
	by (simp add: has_integral_iff)
	also have "norm \<dots> \<le> norm (M y * of_real y powr -s) + norm (M x * of_real x powr -s) +
	norm (integral {x..y} (\<lambda>t. M t * (-s * t powr (-s-1))))"
	by (intro order.trans[OF norm_triangle_ineq4] add_mono order.refl)
	also have "norm (M y * of_real y powr -s) \<le> totient n * y powr -\<sigma>"
	using xy assms unfolding norm_mult M_def \<sigma>_def
	by (intro mult_mono sum_upto_dcharacter_le) (auto simp: norm_powr_real_powr)
	also have "\<dots> \<le> totient n * x powr -\<sigma>"
	using assms xy by (intro mult_left_mono powr_mono2') (auto simp: \<sigma>_def)
	also have "norm (M x * of_real x powr -s) \<le> totient n * x powr -\<sigma>"
	using xy assms unfolding norm_mult M_def \<sigma>_def
	by (intro mult_mono sum_upto_dcharacter_le) (auto simp: norm_powr_real_powr)
	also have "norm (integral {x..y} (\<lambda>t. M t * (- s * of_real t powr (-s-1)))) \<le>
	integral {x..y} (\<lambda>t. real (totient n) * norm s * t powr (-\<sigma>-1))"
	proof (rule integral_norm_bound_integral integrable_on_cmult_left)
	show "(\<lambda>t. real (totient n) * norm s * t powr (- \<sigma> - 1)) integrable_on {x..y}"
	using xy by (intro integrable_continuous_real continuous_intros) auto
	next
	fix t assume t: "t \<in> {x..y}"
	have "norm (M t * (-s * of_real t powr (-s-1))) \<le>
	real (totient n) * (norm s * t powr (-\<sigma>-1))"
	unfolding norm_mult M_def \<sigma>_def using xy t assms
	by (intro mult_mono sum_upto_dcharacter_le) (auto simp: norm_mult norm_powr_real_powr)
	thus "norm (M t * (-s * of_real t powr (-s-1))) \<le> real (totient n) * norm s * t powr (-\<sigma>-1)"
	by (simp add: algebra_simps)
	qed (insert I, auto simp: has_integral_iff)
	also have "\<dots> = real (totient n) * norm s * integral {x..y} (\<lambda>t. t powr (-\<sigma>-1))"
	by simp
	also have "((\<lambda>t. t powr (-\<sigma>-1)) has_integral (y powr -\<sigma> / (-\<sigma>) - x powr -\<sigma> / (-\<sigma>))) {x..y}"
	using xy assms
	by (intro fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros
	simp: has_field_derivative_iff_has_vector_derivative [symmetric] \<sigma>_def)
	hence "integral {x..y} (\<lambda>t. t powr (-\<sigma>-1)) = y powr -\<sigma> / (-\<sigma>) - x powr -\<sigma> / (-\<sigma>)"
	by (simp add: has_integral_iff)
	also from assms have "\<dots> \<le> x powr -\<sigma> / \<sigma>" by (simp add: \<sigma>_def)
	also have "real (totient n) * x powr -\<sigma> + real (totient n) * x powr -\<sigma> +
	real (totient n) * norm s * (x powr -\<sigma> / \<sigma>) =
	real (totient n) * (2 + norm s / \<sigma>) / x powr \<sigma>"
	using xy by (simp add: field_simps powr_minus)
	finally show ?thesis by (simp add: mult_left_mono)
	qed

	show "eventually (\<lambda>m. norm (sum_upto (\<lambda>k. \<chi> k * of_nat k powr - s) x -
	(\<Sum>k\<le>m. \<chi> k * of_nat k powr - s))
	\<le> real (totient n) * (2 + cmod s / \<sigma>) / x powr \<sigma>) at_top"
	using eventually_gt_at_top[of "nat \<lfloor>x\<rfloor>"]
	proof eventually_elim
	case (elim m)
	have "(\<Sum>k\<le>m. \<chi> k * of_nat k powr - s) - sum_upto (\<lambda>k. \<chi> k * of_nat k powr - s) x =
	(\<Sum>k\<in>{..m} - {k. 0 < k \<and> real k \<le> x}. \<chi> k * of_nat k powr -s)" unfolding sum_upto_def
	using elim \<open>x > 0\<close> by (intro Groups_Big.sum_diff [symmetric])
	(auto simp: nat_less_iff floor_less_iff)
	also have "\<dots> = (\<Sum>k\<in>{..m} - {k. real k \<le> x}. \<chi> k * of_nat k powr -s)"
	by (intro sum.mono_neutral_right) auto
	also have "{..m} - {k. real k \<le> x} = real -` {x<..real m}"
	using elim \<open>x > 0\<close> by (auto simp: nat_less_iff floor_less_iff not_less)
	also have "norm (\<Sum>k\<in>\<dots>. \<chi> k * of_nat k powr -s) \<le>
	real (totient n) * (2 + cmod s / \<sigma>) / x powr \<sigma>"
	using elim \<open>x > 0\<close> by (intro le) (auto simp: nat_less_iff floor_less_iff)
	finally show ?case by (simp add: norm_minus_commute)
	qed
	qed auto

	lemma partial_Dirichlet_L_sum_bigo:
	fixes s :: complex and x :: real
	assumes "\<chi> \<noteq> \<chi>\<^sub>0" "Re s > 0"
	shows "(\<lambda>x. sum_upto (\<lambda>n. \<chi> n * n powr -s) x - Dirichlet_L n \<chi> s) \<in> O(\<lambda>x. x powr -s)"
	proof (rule bigoI)
	show "eventually (\<lambda>x. norm (sum_upto (\<lambda>n. \<chi> n * of_nat n powr -s) x - Dirichlet_L n \<chi> s)
	\<le> real (totient n) * (2 + norm s / Re s) * norm (of_real x powr - s)) at_top"
	using eventually_gt_at_top[of 0]
	proof eventually_elim
	case (elim x)
	have "norm (sum_upto (\<lambda>n. \<chi> n * of_nat n powr -s) x - Dirichlet_L n \<chi> s)
	\<le> real (totient n) * (2 + norm s / Re s) / x powr Re s"
	using elim assms by (intro Dirichlet_L_minus_partial_sum_bound) auto
	thus ?case using elim assms
	by (simp add: norm_powr_real_powr powr_minus divide_simps norm_divide
	del: div_mult_self1 div_mult_self2 div_mult_self3 div_mult_self4)
	qed
	qed

	(<)
	end
	(>)
	end


	subsection \<open>Evaluation of $L(\chi, 0)$\<close>

	context residues_nat
	begin
	(<)
	context
	includes no_vec_lambda_notation dcharacter_syntax
	begin
	(>)

	lemma Dirichlet_L_0_principal [simp]: "Dirichlet_L n \<chi>\<^sub>0 0 = 0"
	proof -
	have "Dirichlet_L n \<chi>\<^sub>0 0 = -1/2 * (\<Prod>p \| prime p \<and> p dvd n. 1 - 1 / p powr 0)"
	by (simp add: Dirichlet_L_principal prime_gt_0_nat)
	also have "(\<Prod>p \| prime p \<and> p dvd n. 1 - 1 / p powr 0) = (\<Prod>p \| prime p \<and> p dvd n. 0 :: complex)"
	by (intro prod.cong) (auto simp: prime_gt_0_nat)
	also have "(\<Prod>p \| prime p \<and> p dvd n. 0 :: complex) = 0"
	using prime_divisor_exists[of n] n by (auto simp: card_gt_0_iff)
	finally show ?thesis by simp
	qed

	end
	(<)
	end
	(>)

	context dcharacter
	begin
	(<)
	context
	includes no_vec_lambda_notation dcharacter_syntax
	begin
	(>)

	lemma Dirichlet_L_0_nonprincipal:
	assumes nonprincipal: "\<chi> \<noteq> \<chi>\<^sub>0"
	shows "Dirichlet_L n \<chi> 0 = -(\<Sum>k=1..<n. of_nat k * \<chi> k) / of_nat n"
	proof -
	have "Dirichlet_L n \<chi> 0 = (\<Sum>k=1..n. \<chi> k * (1 / 2 - of_nat k / of_nat n))"
	using assms n by (simp add: Dirichlet_L_conv_hurwitz_zeta_nonprincipal)
	also have "\<dots> = -1/n * (\<Sum>k=1..n. of_nat k * \<chi> k)"
	using assms by (simp add: algebra_simps sum_subtractf sum_dcharacter_block'
	sum_divide_distrib [symmetric])
	also have "(\<Sum>k=1..n. of_nat k * \<chi> k) = (\<Sum>k=1..<n. of_nat k * \<chi> k)"
	using n by (intro sum.mono_neutral_right) (auto simp: eq_zero_iff)
	finally show eq: "Dirichlet_L n \<chi> 0 = -(\<Sum>k=1..<n. of_nat k * \<chi> k) / of_nat n"
	by simp
	qed

	lemma Dirichlet_L_0_even [simp]:
	assumes "\<chi> (n - 1) = 1"
	shows "Dirichlet_L n \<chi> 0 = 0"
	proof (cases "\<chi> = \<chi>\<^sub>0")
	case False
	hence "Dirichlet_L n \<chi> 0 = -(\<Sum>k=Suc 0..<n. of_nat k * \<chi> k) / of_nat n"
	by (simp add: Dirichlet_L_0_nonprincipal)
	also have "\<dots> = 0"
	using assms False by (subst even_dcharacter_linear_sum_eq_0) auto
	finally show "Dirichlet_L n \<chi> 0 = 0" .
	qed auto

	lemma Dirichlet_L_0:
	"Dirichlet_L n \<chi> 0 = (if \<chi> (n - 1) = 1 then 0 else -(\<Sum>k=1..<n. of_nat k * \<chi> k) / of_nat n)"
	by (cases "\<chi> = \<chi>\<^sub>0") (auto simp: Dirichlet_L_0_nonprincipal)

	(<)
	end
	(>)
	end


	subsection \<open>Properties of $L(\chi, s)$ for real $\chi$\<close>

	(<)
	unbundle no_vec_lambda_notation
	(>)

	locale real_dcharacter = dcharacter +
	assumes real: "\<chi> k \<in> \<real>"
	begin

	lemma Im_eq_0 [simp]: "Im (\<chi> k) = 0"
	using real[of k] by (auto elim!: Reals_cases)

	lemma of_real_Re [simp]: "of_real (Re (\<chi> k)) = \<chi> k"
	by (simp add: complex_eq_iff)

	lemma char_cases: "\<chi> k \<in> {-1, 0, 1}"
	proof -
	from norm[of k] have "Re (\<chi> k) \<in> {-1,0,1}"
	by (auto simp: cmod_def split: if_splits)
	hence "of_real (Re (\<chi> k)) \<in> {-1, 0, 1}" by auto
	also have "of_real (Re (\<chi> k)) = \<chi> k" by (simp add: complex_eq_iff)
	finally show ?thesis .
	qed

	lemma cnj [simp]: "cnj (\<chi> k) = \<chi> k"
	by (simp add: complex_eq_iff)

	lemma inv_character_id [simp]: "inv_character \<chi> = \<chi>"
	by (simp add: inv_character_def fun_eq_iff)

	lemma Dirichlet_L_in_Reals:
	assumes "s \<in> \<real>"
	shows "Dirichlet_L n \<chi> s \<in> \<real>"
	proof -
	have "cnj (Dirichlet_L n \<chi> s) = Dirichlet_L n \<chi> s"
	using assms by (subst cnj_Dirichlet_L) (auto elim!: Reals_cases)
	thus ?thesis using Reals_cnj_iff by blast
	qed

	text \<open>
	The following property of real characters is used by Apostol to show the non-vanishing of
	$L(\chi, 1)$. We have already shown this in a much easier way, but this particular result is
	still of general interest.
	\<close>
	lemma
	assumes k: "k > 0"
	shows sum_char_divisors_ge: "Re (\<Sum>d \| d dvd k. \<chi> d) \<ge> 0" (is "Re (?A k) \<ge> 0")
	and sum_char_divisors_square_ge: "is_square k \<Longrightarrow> Re (\<Sum>d \| d dvd k. \<chi> d) \<ge> 1"
	proof -
	interpret sum: multiplicative_function ?A
	by (fact mult.multiplicative_sum_divisors)

	have A: "?A k \<in> \<real>" for k by (intro sum_in_Reals real)
	hence [simp]: "Im (?A k) = 0" for k by (auto elim!: Reals_cases)
	have *: "Re (?A (p ^ m)) \<ge> (if even m then 1 else 0)" if p: "prime p" for p m
	proof -
	have sum_neg1: "(\<Sum>i\<le>m. (-1) ^ i) = (if even m then 1 else (0::real))"
	by (induction m) auto
	from p have "?A (p ^ m) = (\<Sum>k\<le>m. \<chi> (p ^ k))"
	by (intro sum.reindex_bij_betw [symmetric] bij_betw_prime_power_divisors)
	also have "Re \<dots> = (\<Sum>k\<le>m. Re (\<chi> p) ^ k)" by (simp add: mult.power)
	also have "\<dots> \<ge> (if even m then 1 else 0)"
	using sum_neg1 char_cases[of p] by (auto simp: power_0_left)
	finally show ?thesis .
	qed
	have *: "Re (?A (p ^ m)) \<ge> 0" "even m \<Longrightarrow> Re (?A (p ^ m)) \<ge> 1" if "prime p" for p m
	using *[of p m] that by (auto split: if_splits)

	have eq: "Re (?A k) = (\<Prod>p\<in>prime_factors k. Re (?A (p ^ multiplicity p k)))"
	using k A by (subst sum.prod_prime_factors) (auto simp: Re_prod_Reals)
	show "Re (\<Sum>d \| d dvd k. \<chi> d) \<ge> 0" by (subst eq, intro prod_nonneg ballI *) auto

	assume "is_square k"
	then obtain m where m: "k = m ^ 2" by (auto elim!: is_nth_powerE)
	have "even (multiplicity p k)" if "prime p" for p using k that unfolding m
	by (subst prime_elem_multiplicity_power_distrib) (auto intro!: Nat.gr0I)
	thus "Re (\<Sum>d \| d dvd k. \<chi> d) \<ge> 1"
	by (subst eq, intro prod_ge_1 ballI *) auto
	qed

	end

	(<)
	unbundle vec_lambda_notation
	(>)

	end
	diff --git a/thys/Dynamic_Tables/Tables_nat.thy b/thys/Dynamic_Tables/Tables_nat.thy
	--- a/thys/Dynamic_Tables/Tables_nat.thy
	+++ b/thys/Dynamic_Tables/Tables_nat.thy
	@@ -1,581 +1,581 @@
	theory Tables_nat
	imports Tables_real
	begin

	declare le_of_int_ceiling[simp] (* MOVE *)

	(* Final version with l :: nat in fully localized form, no duplication *)

	locale TableInv = Table0 f1 f2 f1' f2' e c for f1 f2 f1' f2' e c :: real +
	fixes l0 :: nat
	assumes l0f2e: "l0 \<ge> 1/(f2 * (e-1))"
	assumes l0f1c: "l0 \<ge> 1/(f1 * (c-1))"

	assumes l0f2f1e: "l0 \<ge> f1/(f2 - f1*e)"
	assumes l0f2f1c: "l0 \<ge> f2/(f2 - f1*c)"
	begin

	lemma l0_gr0[arith]: "l0 > 0"
	proof -
	have "0 < 1/(f2*(e-1))" by(simp)
	also note l0f2e
	finally show ?thesis by simp
	qed

	lemma f1_l0: assumes "l0 \<le> l/c" shows "f1(l/c) \<le> f1l - 1"
	proof -
	have "1 = f1((c-1)/c)(c(1/(f1(c-1))))"
	using f1'_le_f2' f2'_less_f2 by(simp add: field_simps)
	also note l0f1c
	also have l': "c*l0 \<le> l" using assms(1) by(simp add: field_simps)
	finally show ?thesis by(simp add: divide_le_cancel) (simp add: field_simps)
	qed

	fun nxt :: "op\<^sub>t\<^sub>b \<Rightarrow> natnat \<Rightarrow> natnat" where
	"nxt Ins (n,l) =
	(n+1, if n+1 \<le> f2l then l else nat\<lceil>el\<rceil>)" \|
	"nxt Del (n,l) =
	(n-1, if f1*l \<le> real(n-1) then l else if l0 \<le> \<lfloor>l/c\<rfloor> then nat\<lfloor>l/c\<rfloor> else l)"

	fun T :: "op\<^sub>t\<^sub>b \<Rightarrow> nat*nat \<Rightarrow> real" where
	"T Ins (n,l) = (if n+1 \<le> f2*l then 1 else n+1)" \|
	"T Del (n,l) = (if f1*l \<le> real(n-1) then 1 else if l0 \<le> \<lfloor>l/c\<rfloor> then n else 1)"

	fun invar :: "nat * nat \<Rightarrow> bool" where
	"invar(n,l) = (l \<ge> l0 \<and> (\<lfloor>l/c\<rfloor> \<ge> l0 \<longrightarrow> f1l \<le> n) \<and> n \<le> f2l)"

	lemma invar_init: "invar (0,l0)"
	by (auto simp: le_floor_iff field_simps)

	lemma invar_pres: assumes "invar s" shows "invar(nxt f s)"
	proof -
	obtain n l where [simp]: "s = (n,l)" by fastforce
	from assms have "l0 \<le> l" and "n \<le> f2*l" by auto
	show ?thesis
	proof (cases f)
	case [simp]: Ins
	show ?thesis
	proof cases
	assume "n+1 \<le> f2*l" thus ?thesis using assms by (auto)
	next
	assume 0: "\<not> n+1 \<le> f2*l"
	have f1: "f1 * \<lceil>e*l\<rceil> \<le> n+1"
	proof -
	have "\<lceil>el\<rceil> \<le> el + 1" by linarith
	hence "f1 * \<lceil>el\<rceil> \<le> f1 (e*l + 1)" by simp
	also have "\<dots> \<le> f2*l"
	proof -
	have "f1 \<le> (f2 - f1e)l0"
	using l0f2f1e f1f2e by(simp add: field_simps)
	also note \<open>l0 \<le> l\<close>
	finally show ?thesis using f1f2e[simplified field_simps]
	by (simp add:ac_simps mult_left_mono) (simp add:algebra_simps)
	qed
	finally show ?thesis using 0 by linarith
	qed
	have "n+1 \<le> f2el"
	proof -
	have "n+1 \<le> f2l+1" using \<open>n \<le> f2l\<close> by linarith
	also have "1 = f2(e-1)(1/(f2*(e-1)))" by(simp)
	also note l0f2e
	also note \<open>l0 \<le> l\<close>
	finally show ?thesis by simp (simp add: algebra_simps)
	qed
	also have "f2el \<le> f2\<lceil>el\<rceil>" by simp
	finally have f2: "n+1 \<le> f2\<lceil>el\<rceil>" .
	have "l < e*l" using \<open>l0 \<le> l\<close> by simp
	hence "l0 \<le> e*l" using \<open>l0\<le>l\<close> by linarith
	with 0 f1 f2 show ?thesis by (auto simp add: field_simps) linarith
	qed
	next
	case [simp]: Del
	show ?thesis
	proof cases
	assume "f1*l \<le> real n - 1"
	thus ?thesis using assms by(auto)
	next
	assume 0: "\<not> f1*l \<le> real n - 1"
	show ?thesis
	proof cases
	assume "n=0" thus ?thesis using 0 assms by(simp add: field_simps)
	next
	assume "n \<noteq> 0"
	show ?thesis
	proof cases
	assume l: "l0 \<le> \<lfloor>l/c\<rfloor>"
	hence l': "l0 \<le> l/c" by linarith
	have "f1 * \<lfloor>l/c\<rfloor> \<le> f1*(l/c)" by(simp del: times_divide_eq_right)
	hence f1: "f1*\<lfloor>l/c\<rfloor> \<le> n-1" using l' f1_l0[OF l'] assms \<open>n \<noteq> 0\<close>
	by(simp add: le_floor_iff)
	have "n-1 \<le> f2 * \<lfloor>l/c\<rfloor>"
	proof -
	have "n-1 < f1*l" using 0 \<open>n \<noteq> 0\<close> by linarith
	also have "f1l \<le> f2(l/c) - f2"
	proof -
	have "(f2 - f1c)l0 \<ge> f2"
	using l0f2f1c f1cf2 by(simp add: field_simps)
	with mult_left_mono[OF \<open>l0 \<le> l/c\<close>, of "f2-f1*c"] f1cf2
	have "(f2 - f1c)(l/c) \<ge> f2" by linarith
	thus ?thesis by(simp add: field_simps)
	qed
	also have "\<dots> \<le> f2*\<lfloor>l/c\<rfloor>"
	proof -
	have "l/c - 1 \<le> \<lfloor>l/c\<rfloor>" by linarith
	from mult_left_mono[OF this, of f2] show ?thesis
	by(simp add: algebra_simps)
	qed
	finally show ?thesis using 0 \<open>n \<noteq> 0\<close> by linarith
	qed
	with l 0 f1 \<open>n \<noteq> 0\<close> show ?thesis by (auto)
	next
	assume "\<not> l0 \<le> \<lfloor>l/c\<rfloor>"
	with 0 assms show ?thesis by (auto simp add: field_simps)
	qed
	qed
	qed
	qed
	qed

	end

	locale Table1 = TableInv +
	assumes f2f2': "l0 \<ge> 1/(f2 - f2')"
	assumes f1'f1: "l0 \<ge> 1/((f1' - f1)*c)"
	begin

	definition "ai = f2/(f2-f2')"
	definition "ad = f1/(f1'-f1)"

	lemma aigr0[arith]: "ai > 1"
	using f2'_less_f2 by(simp add: ai_def field_simps)

	lemma adgr0[arith]: "ad > 0"
	using f1_less_f1' by(simp add: ad_def field_simps)

	lemma f1'ad[arith]: "f1'*ad > 0"
	by simp

	lemma f2'ai[arith]: "f2'*ai > 0"
	by simp

	fun \<Phi> :: "nat * nat \<Rightarrow> real" where
	"\<Phi> (n,l) = (if n \<ge> f2'l then ai(n - f2'*l) else
	if n \<le> f1'l \<and> l0 \<le> \<lfloor>l/c\<rfloor> then ad(f1'*l - n) else 0)"

	lemma Phi_Psi: "\<Phi> (n,l) = \<Psi> (l0 \<le> \<lfloor>l/c\<rfloor>) ai ad (f1'l) (f2'l) n"
	by(simp)

	abbreviation "U \<equiv> \<lambda>f _. case f of Ins \<Rightarrow> ai+1 + f1'ad \| Del \<Rightarrow> ad+1 + f2'ai"

	interpretation tb: Amortized
	where init = "(0,l0)" and nxt = nxt
	and inv = invar
	and T = T and \<Phi> = \<Phi>
	and U = U
	proof (standard, goal_cases)
	case 1 show ?case by (fact invar_init)
	next
	case 2 thus ?case by(fact invar_pres)
	next
	case (3 s) thus ?case by(cases s)(simp split: if_splits)
	next
	case 4 show ?case
	by(auto simp: field_simps mult_le_0_iff le_floor_iff)
	next
	case (5 s f)
	obtain n l where [simp]: "s = (n,l)" by fastforce
	show ?case
	proof (cases f)
	case [simp]: Ins
	show ?thesis (is "?A \<le> _")
	proof cases
	assume "n+1 \<le> f2*l"
	hence "?A \<le> ai+1" by(simp del: \<Phi>.simps \<Psi>.simps add: Phi_Psi Psi_diff_Ins)
	thus ?thesis by simp
	next
	assume [arith]: "\<not> n+1 \<le> f2*l"
	have [arith]: "l \<ge> l0" "n \<le> f2*l" using 5 by auto
	have "(f2 - f2')*l \<ge> 1"
	using mult_mono[OF order_refl, of l0 l "f2-f2'"] f2'_less_f2 f2f2'
	by (simp add: field_simps)
	hence "n \<ge> f2'*l" by(simp add: algebra_simps)
	hence Phi: "\<Phi> s = ai * (n - f2'*l)" by simp
	have [simp]: "real (nat \<lceil>el\<rceil>) = real_of_int \<lceil>el\<rceil>"
	by (simp add: order.order_iff_strict)
	have "?A \<le> n - ai(f2 - f2')l + ai + 1 + f1'*ad" (is "_ \<le> ?R")
	proof cases
	assume f2': "n+1 < f2'\<lceil>el\<rceil>"
	show ?thesis
	proof cases
	assume "n+1 \<le> f1'\<lceil>el\<rceil>"
	hence "?A \<le> n+1 + ad(f1'\<lceil>el\<rceil>-(n+1)) - ai(n - f2'*l)"
	- using Phi f2' by (simp add: )
	+ using Phi f2' by simp
	also have "f1'\<lceil>el\<rceil> - (n+1) \<le> f1'"
	proof -
	have "f1'\<lceil>el\<rceil> \<le> f1'(el + 1)" by(simp)
	also have "\<dots> = f1'el + f1'" by(simp add: algebra_simps)
	also have "f1'el \<le> f2*l" using f1'ef2 by(simp)
	finally show ?thesis by linarith
	qed
	also have "n+1+adf1'-ai(n-f2'l) = n+ai(-real(n+1)+f2'l)+ai+f1'ad+1"
	by(simp add: algebra_simps)
	also have "-real(n+1) \<le> -f2*l" by linarith
	finally show ?thesis by(simp add: algebra_simps) (* f1'ad )
	next
	assume "\<not> n+1 \<le> f1'\<lceil>el\<rceil>"
	hence "?A = n+1 - ai(n - f2'l)" using Phi f2' by (simp)
	also have "n+1-ai(n-f2'l) = n+ai(-real(n+1)+f2'l)+ai+1"
	by(simp add: algebra_simps)
	also have "-real(n+1) \<le> -f2*l" by linarith
	also have "n+ai(-f2l+f2'*l)+ai+1 \<le> ?R"
	by(simp add: algebra_simps)
	finally show ?thesis by(simp)
	qed
	next
	assume "\<not> n+1 < f2'\<lceil>el\<rceil>"
	hence "?A = n + ai(-f2'\<lceil>el\<rceil> + f2'l) + ai+1" using Phi
	by(simp add: algebra_simps)
	also have "-f2'\<lceil>el\<rceil> \<le> -f2'el" by(simp)
	also have "-f2'*e \<le> -f2" using f2_le_f2'e by linarith
	also have "n+ai(-f2l+f2'*l)+ai+1 \<le> ?R" by(simp add: algebra_simps)
	finally show ?thesis by(simp)
	qed
	also have "\<dots> = n - f2l + ai+f1'ad+1" using f2'_less_f2
	by(simp add: ai_def)
	finally show ?thesis by simp
	qed
	next
	case [simp]: Del
	have [arith]: "l \<ge> l0" using 5 by simp
	show ?thesis
	proof cases
	assume "n=0" with 5 show ?thesis
	by(simp add: mult_le_0_iff field_simps)
	next
	assume [arith]: "n\<noteq>0"
	show ?thesis (is "?A \<le> _")
	proof cases
	assume "real n - 1 \<ge> f1*l \<or> \<lfloor>l/c\<rfloor> < l0"
	hence "?A \<le> ad+1" using f1'_le_f2'
	by(auto simp del: \<Phi>.simps \<Psi>.simps simp add: Phi_Psi Psi_diff_Del)
	thus ?thesis by simp
	next
	assume "\<not> (real n - 1 \<ge> f1*l \<or> \<lfloor>l/c\<rfloor> < l0)"
	hence n: "real n - 1 < f1*l" and lc': "\<lfloor>l/c\<rfloor> \<ge> l0" and lc: "l/c \<ge> l0"
	by linarith+
	have "f1'l \<le> f2'l" using f1'_le_f2' by simp
	have "(f1' - f1)*l \<ge> 1" using mult_mono[OF order_refl, of l0 "l/c" "f1'-f1"]
	lc f1_less_f1' f1'f1 by (simp add: field_simps)
	hence "n < f1'*l" using n by(simp add: algebra_simps)
	hence Phi: "\<Phi> s = ad(f1'l - n)"
	apply(simp) using \<open>f1'l \<le> f2'l\<close> lc by linarith
	have "?A \<le> n - ad(f1' - f1)l + ad + f2'*ai" (is "_ \<le> ?R + _")
	proof cases
	assume f2': "n-1 < f2'*\<lfloor>l/c\<rfloor>"
	show ?thesis
	proof cases
	assume "n-1 < f1'*\<lfloor>l/c\<rfloor> \<and> \<lfloor>\<lfloor>l/c\<rfloor>/c\<rfloor> \<ge> l0"
	hence "\<Phi> (nxt f s) = ad(f1'\<lfloor>l/c\<rfloor> - (n-1))" using f2' n lc' by(auto)
	hence "?A = n + ad(f1'\<lfloor>l/c\<rfloor> - (n-1)) - (ad(f1'l - n))"
	using Phi n lc' by (simp add: algebra_simps)
	also have "\<lfloor>l/c\<rfloor> \<le> l/c" by(simp)
	also have "n+ad(f1'(l/c)-(n-1))-(ad(f1'l-n)) = n+ad(f1'/c-f1')l+ad"
	by(simp add: algebra_simps)
	also note f1'c_le_f1
	finally have "?A \<le> ?R" by(simp add: algebra_simps)
	thus ?thesis by linarith
	next
	assume "\<not>(n-1 < f1'*\<lfloor>l/c\<rfloor> \<and> \<lfloor>\<lfloor>l/c\<rfloor>/c\<rfloor> \<ge> l0)"
	hence "\<Phi> (nxt f s) = 0" using f2' n lc' by(auto)
	hence "?A = n + ad(n - f1'l)" using Phi n lc'
	by (simp add: algebra_simps)
	also have "\<dots> = n + ad(n-1 - f1'l) + ad" by(simp add: algebra_simps)
	also have "n-1 \<le> f1*l" using n by linarith
	finally have "?A \<le> ?R" by (simp add: algebra_simps)
	thus ?thesis by linarith
	qed
	next
	assume f2': "\<not> n-1 < f2'*\<lfloor>l/c\<rfloor>"
	hence "?A = n + ai(n-1-f2'\<lfloor>l/c\<rfloor>) - ad(f1'l - n)"
	using Phi n lc' by (simp)
	also have "n-1-f2'*\<lfloor>l/c\<rfloor> \<le> f2'"
	proof -
	have "f1l \<le> f2'(l/c)" using f1f2'c by(simp add: field_simps)
	hence "n-1 < f2'*(l/c)" using n by linarith
	also have "l/c \<le> \<lfloor>l/c\<rfloor> + 1" by linarith
	finally show ?thesis by(fastforce simp: algebra_simps)
	qed
	also have "n+aif2'-ad(f1'l-n) = n + ad(n-1 - f1'l) + ad + f2'ai"
	by(simp add: algebra_simps)
	also have "n-1 \<le> f1*l" using n by linarith
	finally show ?thesis by(simp add: algebra_simps)
	qed
	also have "\<dots> = n - f1l + ad + f2'ai" using f1_less_f1' by(simp add: ad_def)
	finally show ?thesis using n by simp
	qed
	qed
	qed
	qed

	end

	locale Table2_f1f2'' = TableInv +
	fixes f1'' f2'' :: real

	locale Table2 = Table2_f1f2'' +
	assumes f2f2'': "(f2 - f2'')*l0 \<ge> 1"
	assumes f1''f1: "(f1'' - f1)cl0 \<ge> 1"

	assumes f1_less_f1'': "f1 < f1''"
	assumes f1''_less_f1': "f1'' < f1'"
	assumes f2'_less_f2'': "f2' < f2''"
	assumes f2''_less_f2: "f2'' < f2"
	assumes f1''_f1': "l \<ge> real l0 \<Longrightarrow> f1'' * (l+1) \<le> f1'*l"
	assumes f2'_f2'': "l \<ge> real l0 \<Longrightarrow> f2' * l \<le> f2'' * (l-1)"
	begin

	definition "ai = f2 / (f2 - f2'')"
	definition "ad = f1 / (f1'' - f1)"

	lemma f1''_gr0[arith]: "f1'' > 0"
	using f1_less_f1'' f1 by linarith

	lemma f2''_gr0[arith]: "f2'' > 0"
	using f2' f2'_less_f2'' by linarith

	lemma aigr0[arith]: "ai > 0"
	using f2''_less_f2 by(simp add: ai_def field_simps)

	lemma adgr0[arith]: "ad > 0"
	using f1_less_f1'' by(simp add: ad_def field_simps)

	fun \<Phi> :: "nat * nat \<Rightarrow> real" where
	"\<Phi>(n,l) = (if n \<ge> f2''l then ai(n - f2''*l) else
	if n \<le> f1''l \<and> l0 \<le> \<lfloor>l/c\<rfloor> then ad(f1''*l - n) else 0)"

	lemma Phi_Psi: "\<Phi> (n,l) = \<Psi> (l0 \<le> \<lfloor>l/c\<rfloor>) ai ad (f1''l) (f2''l) n"
	by(simp)

	abbreviation "U \<equiv> \<lambda>f _. case f of Ins \<Rightarrow> ai+1 \| Del \<Rightarrow> ad+1"

	interpretation tb: Amortized
	where init = "(0,l0)" and nxt = nxt
	and inv = invar
	and T = T and \<Phi> = \<Phi>
	and U = U
	proof (standard, goal_cases)
	case 1 show ?case by (fact invar_init)
	next
	case 2 thus ?case by(fact invar_pres)
	next
	case (3 s) thus ?case by(cases s)(simp split: if_splits)
	next
	case 4 show ?case
	by(auto simp: field_simps mult_le_0_iff le_floor_iff)
	next
	case (5 s f)
	obtain n l where [simp]: "s = (n,l)" by fastforce
	show ?case
	proof (cases f)
	case [simp]: Ins
	show ?thesis (is "?L \<le> _")
	proof cases
	assume "n+1 \<le> f2*l"
	thus ?thesis by(simp del: \<Phi>.simps \<Psi>.simps add: Phi_Psi Psi_diff_Ins)
	next
	assume [arith]: "\<not> n+1 \<le> f2*l"
	have [arith]: "l \<ge> l0" "n \<le> f2*l" using 5 by auto
	have "l0 \<le> e*l" using \<open>l0 \<le> l\<close> e1 mult_mono[of 1 e l0 l] by simp
	have "(f2 - f2'')*l \<ge> 1"
	using mult_mono[OF order_refl, of l0 l "f2-f2''"] f2''_less_f2 f2f2''
	by (simp add: algebra_simps)
	hence "n \<ge> f2''*l" by(simp add: algebra_simps)
	hence Phi: "\<Phi> s = ai * (n - f2''*l)" by simp
	have [simp]: "real (nat \<lceil>el\<rceil>) = real_of_int \<lceil>el\<rceil>"
	by (simp add: order.order_iff_strict)
	have "?L \<le> n - ai(f2 - f2'')l + ai + 1" (is "_ \<le> ?R")
	proof cases
	assume f2'': "n+1 < f2''\<lceil>el\<rceil>"
	have "f1''\<lceil>el\<rceil> \<le> f1''(el + 1)" by(simp)
	also note f1''_f1'[OF \<open>l0 \<le> e*l\<close>]
	also have "f1'(el) \<le> f2*l" using f1'ef2 by(simp)
	also have "f2*l \<le> n+1" by linarith
	finally have "?L \<le> n+1 - ai(n - f2''l)"
	using Phi f2'' by (simp)
	also have "n+1-ai(n-f2''l) = n+ai(-real(n+1)+f2''l)+ai+1"
	by(simp add: algebra_simps)
	also have "-real(n+1) \<le> -f2*l" by linarith
	finally show ?thesis by(simp add: algebra_simps)
	next
	assume "\<not> n+1 < f2''\<lceil>el\<rceil>"
	hence "?L = n + ai(-f2''\<lceil>el\<rceil> + f2''l) + ai+1" using Phi
	by(simp add: algebra_simps)
	also have "-f2''\<lceil>el\<rceil> \<le> -f2''el" by(simp)
	also have "-f2''e \<le> -f2'e" using f2'_less_f2'' by(simp)
	also have "-f2'*e \<le> -f2" using f2_le_f2'e by(simp)
	also have "n+ai(-f2l+f2''*l)+ai+1 \<le> ?R" by(simp add: algebra_simps)
	finally show ?thesis by(simp)
	qed
	also have "\<dots> = n - f2*l + ai+1" using f2''_less_f2
	by(simp add: ai_def)
	finally show ?thesis by simp
	qed
	next
	case [simp]: Del
	have [arith]: "l \<ge> l0" using 5 by simp
	show ?thesis
	proof cases
	assume "n=0" with 5 show ?thesis
	by(simp add: mult_le_0_iff field_simps)
	next
	assume [arith]: "n\<noteq>0"
	show ?thesis (is "?A \<le> _")
	proof cases
	assume "real n - 1 \<ge> f1*l \<or> \<lfloor>l/c\<rfloor> < l0"
	thus ?thesis using f1''_less_f1' f1'_le_f2' f2'_less_f2''
	by(auto simp del: \<Phi>.simps \<Psi>.simps simp add: Phi_Psi Psi_diff_Del)
	next
	assume "\<not> (real n - 1 \<ge> f1*l \<or> \<lfloor>l/c\<rfloor> < l0)"
	hence n: "real n - 1 < f1*l" and lc': "\<lfloor>l/c\<rfloor> \<ge> l0" and lc: "l/c \<ge> l0"
	by linarith+
	have "f1''l \<le> f2''l"
	using f1''_less_f1' f1'_le_f2' f2'_less_f2'' by simp
	have "(f1'' - f1)*l \<ge> 1"
	using mult_mono[OF order_refl, of l0 "l/c" "f1''-f1"] lc f1_less_f1'' f1''f1
	by (simp add: field_simps)
	hence "n < f1''*l" using n by(simp add: algebra_simps)
	hence Phi: "\<Phi> s = ad(f1''l - n)"
	apply(simp) using \<open>f1''l \<le> f2''l\<close> lc by linarith
	have f2': "n-1 < f2''*\<lfloor>l/c\<rfloor>"
	proof -
	have "n-1 < f1*l" using n by linarith
	also have "f1l \<le> f2'(l/c)" using f1f2'c by(auto simp: field_simps)
	also note f2'_f2''[OF \<open>l/c\<ge>l0\<close>]
	also have "f2''(l/c - 1) \<le> f2''\<lfloor>l/c\<rfloor>" by simp
	finally show ?thesis by(simp)
	qed
	have "?A \<le> n - ad(f1'' - f1)l + ad"
	proof cases
	assume "n-1 < f1''*\<lfloor>l/c\<rfloor> \<and> \<lfloor>\<lfloor>l/c\<rfloor>/c\<rfloor> \<ge> l0"
	hence "\<Phi> (nxt f s) = ad(f1''\<lfloor>l/c\<rfloor> - (n-1))" using f2' n lc' by(auto)
	hence "?A = n + ad(f1''\<lfloor>l/c\<rfloor> - (n-1)) - (ad(f1''l - n))"
	using Phi n lc' by (simp add: algebra_simps)
	also have "\<lfloor>l/c\<rfloor> \<le> l/c" by(simp)
	also have "n+ad(f1''(l/c)-(n-1))-(ad(f1''l-n)) = n+ad(f1''/c-f1'')l+ad"
	by(simp add: algebra_simps)
	also have "f1''/c \<le> f1'/c" using f1''_less_f1' by(simp add: field_simps)
	also note f1'c_le_f1
	finally show ?thesis by(simp add: algebra_simps)
	next
	assume "\<not>(n-1 < f1''*\<lfloor>l/c\<rfloor> \<and> \<lfloor>\<lfloor>l/c\<rfloor>/c\<rfloor> \<ge> l0)"
	hence "\<Phi> (nxt f s) = 0" using f2' n lc' by(auto)
	hence "?A = n + ad(n - f1''l)" using Phi n lc'
	by (simp add: algebra_simps)
	also have "\<dots> = n + ad(n-1 - f1''l) + ad" by(simp add: algebra_simps)
	also have "n-1 \<le> f1*l" using n by linarith
	finally show ?thesis by (simp add: algebra_simps)
	qed
	also have "\<dots> = n - f1*l + ad" using f1_less_f1'' by(simp add: ad_def)
	finally show ?thesis using n by simp
	qed
	qed
	qed
	qed

	end


	locale Table3 = Table2_f1f2'' +
	assumes f1''_def: "f1'' = (f1'::real)*l0/(l0+1)"
	assumes f2''_def: "f2'' = (f2'::real)*l0/(l0-1)"

	(* they imply (f2 - f2'')l0 \<ge> 1 and (f1 - f1'')l0c \<ge> 1 )
	assumes l0_f2f2': "l0 \<ge> (f2+1)/(f2-f2')"
	assumes l0_f1f1': "l0 \<ge> (f1'c+1)/((f1'-f1)c)"

	(* they imply f1<f1'' and f2'<f2'' and l0 > 1 *)
	assumes l0_f1_f1': "l0 > f1/((f1'-f1))"
	assumes l0_f2_f2': "l0 > f2/(f2-f2')"
	begin

	lemma l0_gr1: "l0 > 1"
	proof -
	have "f2/(f2-f2') \<ge> 1" using f2'_less_f2 by(simp add: field_simps)
	thus ?thesis using l0_f2_f2' f2'_less_f2 by linarith
	qed

	lemma f1''_less_f1': "f1'' < f1'"
	by(simp add: f1''_def field_simps)

	lemma f1_less_f1'': "f1 < f1''"
	proof -
	have "1 + l0 > 0" by (simp add: add_pos_pos)
	hence "f1''> f1 \<longleftrightarrow> l0 > f1/((f1'-f1))"
	using f1_less_f1' by(simp add: f1''_def field_simps)
	also have "\<dots> \<longleftrightarrow> True" using l0_f1_f1' by blast
	finally show ?thesis by blast
	qed

	lemma f2'_less_f2'': "f2' < f2''"
	using l0_gr1 by(simp add: f2''_def field_simps)

	lemma f2''_less_f2: "f2'' < f2"
	proof -
	have "f2''< f2 \<longleftrightarrow> l0 > f2/(f2-f2')"
	using f2'_less_f2 l0_gr1 by(simp add: f2''_def field_simps)
	also have "\<dots> \<longleftrightarrow> True" using l0_f2_f2' by blast
	finally show ?thesis by blast
	qed

	(* This is the real constraint we want, not l0_f2f2',
	but it involves f2'', which depends on l0 *)
	lemma f2f2'': "(f2 - f2'')*l0 \<ge> 1"
	proof -
	have "(f2 - f2'')*(l0-1) \<ge> 1"
	using l0_gr1 l0_f2f2' f2'_less_f2
	by(simp add: f2''_def algebra_simps del: of_nat_diff) (simp add: field_simps)
	thus ?thesis using f2''_less_f2 by (simp add: algebra_simps)
	qed

	(* This is the real constraint we want, not l0_f1f1',
	but it involves f1'', which depends on l0 *)
	lemma f1''f1: "(f1'' - f1)cl0 \<ge> 1"
	proof -
	have "1 \<le> (f1' - f1)cl0 - f1'*c" using l0_f1f1' f1_less_f1'
	by(simp add: field_simps)
	also have "\<dots> = (f1'((l0-1)/l0) - f1)c*l0"
	by(simp add: field_simps)
	also have "(l0-1)/l0 \<le> l0/(l0+1)"
	by(simp add: field_simps)
	also have "f1'(l0/(l0+1)) = f1'l0/(l0+1)"
	by(simp add: algebra_simps)
	also note f1''_def[symmetric]
	finally show ?thesis by(simp)
	qed

	lemma f1''_f1': assumes "l \<ge> real l0" shows "f1''(l+1) \<le> f1' l"
	proof -
	have "f1''(l+1) = f1'(l0/(l0+1))*(l+1)"
	by(simp add: f1''_def field_simps)
	also have "l0/(l0+1) \<le> l/(l+1)" using assms
	by(simp add: field_simps)
	finally show ?thesis using \<open>l0 \<le> l\<close> by(simp)
	qed

	lemma f2'_f2'': assumes "l \<ge> real l0" shows "f2' * l \<le> f2'' * (l-1)"
	proof -
	have "f2' * l = f2' * l + f2'*((l0-1)/(l0-1) - 1)" using l0_gr1 by simp
	also have "(l0-1)/(l0-1) \<le> (l-1)/(l0-1)" using \<open>l\<ge>l0\<close> by(simp)
	also have "f2'l + f2'((l-1)/(l0-1) - 1) = f2''*(l-1)"
	using l0_gr1 by(simp add: f2''_def field_simps)
	finally show ?thesis by simp
	qed


	sublocale Table2
	proof
	qed (fact f1_less_f1'' f1''_less_f1' f2'_less_f2'' f2''_less_f2 f1''f1 f2f2'' f1''_f1' f2'_f2'')+

	end

	end
	diff --git a/thys/Extended_Finite_State_Machines/EFSM_LTL.thy b/thys/Extended_Finite_State_Machines/EFSM_LTL.thy
	--- a/thys/Extended_Finite_State_Machines/EFSM_LTL.thy
	+++ b/thys/Extended_Finite_State_Machines/EFSM_LTL.thy
	@@ -1,281 +1,281 @@
	section\<open>LTL for EFSMs\<close>
	text\<open>This theory builds off the \texttt{Linear\_Temporal\_Logic\_on\_Streams} theory from the HOL
	library and defines functions to ease the expression of LTL properties over EFSMs. Since the LTL
	operators effectively act over traces of models we must find a way to express models as streams.\<close>

	theory EFSM_LTL
	imports "Extended_Finite_State_Machines.EFSM" "HOL-Library.Linear_Temporal_Logic_on_Streams"
	begin

	text_raw\<open>\snip{statedef}{1}{2}{%\<close>
	record state =
	statename :: "nat option"
	datastate :: registers
	action :: action
	"output" :: outputs
	text_raw\<open>}%endsnip\<close>

	text_raw\<open>\snip{whitebox}{1}{2}{%\<close>
	type_synonym whitebox_trace = "state stream"
	text_raw\<open>}%endsnip\<close>

	type_synonym property = "whitebox_trace \<Rightarrow> bool"

	abbreviation label :: "state \<Rightarrow> String.literal" where
	"label s \<equiv> fst (action s)"

	abbreviation inputs :: "state \<Rightarrow> value list" where
	"inputs s \<equiv> snd (action s)"

	text_raw\<open>\snip{ltlStep}{1}{2}{%\<close>
	fun ltl_step :: "transition_matrix \<Rightarrow> cfstate option \<Rightarrow> registers \<Rightarrow> action \<Rightarrow> (nat option \<times> outputs \<times> registers)" where
	"ltl_step _ None r _ = (None, [], r)" \|
	"ltl_step e (Some s) r (l, i) = (let possibilities = possible_steps e s r l i in
	if possibilities = {\|\|} then (None, [], r)
	else
	let (s', t) = Eps (\<lambda>x. x \|\<in>\| possibilities) in
	(Some s', (evaluate_outputs t i r), (evaluate_updates t i r))
	)"
	text_raw\<open>}%endsnip\<close>

	lemma ltl_step_singleton:
	"\<exists>t. possible_steps e n r (fst v) (snd v) = {\|(aa, t)\|} \<and> evaluate_outputs t (snd v) r = b \<and> evaluate_updates t (snd v) r = c\<Longrightarrow>
	ltl_step e (Some n) r v = (Some aa, b, c)"
	apply (cases v)
	by auto

	lemma ltl_step_none: "possible_steps e s r a b = {\|\|} \<Longrightarrow> ltl_step e (Some s) r (a, b) = (None, [], r)"
	by simp

	lemma ltl_step_none_2: "possible_steps e s r (fst ie) (snd ie) = {\|\|} \<Longrightarrow> ltl_step e (Some s) r ie = (None, [], r)"
	by (metis ltl_step_none prod.exhaust_sel)

	lemma ltl_step_alt: "ltl_step e (Some s) r t = (
	let possibilities = possible_steps e s r (fst t) (snd t) in
	if possibilities = {\|\|} then
	(None, [], r)
	else
	let (s', t') = Eps (\<lambda>x. x \|\<in>\| possibilities) in
	(Some s', (apply_outputs (Outputs t') (join_ir (snd t) r)), (apply_updates (Updates t') (join_ir (snd t) r) r))
	)"
	by (case_tac t, simp add: Let_def)

	lemma ltl_step_some:
	assumes "possible_steps e s r l i = {\|(s', t)\|}"
	and "evaluate_outputs t i r = p"
	and "evaluate_updates t i r = r'"
	shows "ltl_step e (Some s) r (l, i) = (Some s', p, r')"
	by (simp add: assms)

	lemma ltl_step_cases:
	assumes invalid: "P (None, [], r)"
	and valid: "\<forall>(s', t) \|\<in>\| (possible_steps e s r l i). P (Some s', (evaluate_outputs t i r), (evaluate_updates t i r))"
	shows "P (ltl_step e (Some s) r (l, i))"
	apply simp
	apply (case_tac "possible_steps e s r l i")
	apply (simp add: invalid)
	apply simp
	subgoal for x S'
	apply (case_tac "SOME xa. xa = x \<or> xa \|\<in>\| S'")
	apply simp
	apply (insert assms(2))
	apply (simp add: fBall_def Ball_def fmember_def)
	by (metis (mono_tags, lifting) fst_conv prod.case_eq_if snd_conv someI_ex)
	done

	text\<open>The \texttt{make\_full\_observation} function behaves similarly to \texttt{observe\_execution}
	from the \texttt{EFSM} theory. The main difference in behaviour is what is recorded. While the
	observe execution function simply observes an execution of the EFSM to produce the corresponding
	output for each action, the intention here is to record every detail of execution, including the
	values of internal variables.

	Thinking of each action as a step forward in time, there are five components which characterise
	a given point in the execution of an EFSM. At each point, the model has a current control state and
	data state. Each action has a label and some input parameters, and its execution may produce
	some observableoutput. It is therefore sufficient to provide a stream of 5-tuples containing the
	current control state, data state, the label and inputs of the action, and computed output. The
	make full observation function can then be defined as in Figure 9.1, with an additional
	function watch defined on top of this which starts the make full observation off in the
	initial control state with the empty data state.

	Careful inspection of the definition reveals another way that \texttt{make\_full\_observation}
	differs from \texttt{observe\_execution}. Rather than taking a cfstate, it takes a cfstate option.
	The reason for this is that we need to make our EFSM models complete. That is, we need them to be
	able to respond to every action from every state like a DFA. If a model does not recognise a given
	action in a given state, we cannot simply stop processing because we are working with necessarily
	infinite traces. Since these traces are generated by observing action sequences, the make full
	observation function must keep processing whether there is a viable transition or not.

	To support this, the make full observation adds an implicit ``sink state'' to every EFSM it
	processes by lifting control flow state indices from \texttt{nat} to \texttt{nat option} such that
	state $n$ is seen as state \texttt{Some} $n$. The control flow state \texttt{None} represents a sink
	state. If a model is unable to recognise a particular action from its current state, it moves into
	the \texttt{None} state. From here, the behaviour is constant for the rest of the time --- the
	control flow state remains None; the data state does not change, and no output is produced.\<close>

	text_raw\<open>\snip{makeFullObservation}{1}{2}{%\<close>
	primcorec make_full_observation :: "transition_matrix \<Rightarrow> cfstate option \<Rightarrow> registers \<Rightarrow> outputs \<Rightarrow> action stream \<Rightarrow> whitebox_trace" where
	"make_full_observation e s d p i = (
	let (s', o', d') = ltl_step e s d (shd i) in
	\<lparr>statename = s, datastate = d, action=(shd i), output = p\<rparr>##(make_full_observation e s' d' o' (stl i))
	)"
	text_raw\<open>}%endsnip\<close>

	text_raw\<open>\snip{watch}{1}{2}{%\<close>
	abbreviation watch :: "transition_matrix \<Rightarrow> action stream \<Rightarrow> whitebox_trace" where
	"watch e i \<equiv> (make_full_observation e (Some 0) <> [] i)"
	text_raw\<open>}%endsnip\<close>

	subsection\<open>Expressing Properties\<close>
	text\<open>In order to simplify the expression and understanding of properties, this theory defines a
	number of named functions which can be used to express certain properties of EFSMs.\<close>

	subsubsection\<open>State Equality\<close>
	text\<open>The \textsc{state\_eq} takes a cfstate option representing a control flow state index and
	returns true if this is the control flow state at the head of the full observation.\<close>

	abbreviation state_eq :: "cfstate option \<Rightarrow> whitebox_trace \<Rightarrow> bool" where
	"state_eq v s \<equiv> statename (shd s) = v"

	lemma state_eq_holds: "state_eq s = holds (\<lambda>x. statename x = s)"
	apply (rule ext)
	by (simp add: holds_def)

	lemma state_eq_None_not_Some: "state_eq None s \<Longrightarrow> \<not> state_eq (Some n) s"
	by simp

	subsubsection\<open>Label Equality\<close>
	text\<open>The \textsc{label\_eq} function takes a string and returns true if this is equal to the label
	at the head of the full observation.\<close>

	abbreviation "label_eq v s \<equiv> fst (action (shd s)) = (String.implode v)"

	lemma watch_label: "label_eq l (watch e t) = (fst (shd t) = String.implode l)"
	- by (simp add: )
	+ by simp

	subsubsection\<open>Input Equality\<close>
	text\<open>The \textsc{input\_eq} function takes a value list and returns true if this is equal to the
	input at the head of the full observation.\<close>

	abbreviation "input_eq v s \<equiv> inputs (shd s) = v"

	subsubsection\<open>Action Equality\<close>
	text\<open>The \textsc{action\_eq} function takes a (label, value list) pair and returns true if this is
	equal to the action at the head of the full observation. This effectively combines
	\texttt{label\_eq} and \texttt{input\_eq} into one function.\<close>

	abbreviation "action_eq e \<equiv> label_eq (fst e) aand input_eq (snd e)"

	subsubsection\<open>Output Equality\<close>
	text\<open>The \textsc{output\_eq} function takes a takes a value option list and returns true if this is
	equal to the output at the head of the full observation.\<close>

	abbreviation "output_eq v s \<equiv> output (shd s) = v"

	text_raw\<open>\snip{ltlVName}{1}{2}{%\<close>
	datatype ltl_vname = Ip nat \| Op nat \| Rg nat
	text_raw\<open>}%endsnip\<close>

	subsubsection\<open>Checking Arbitrary Expressions\<close>
	text\<open>The \textsc{check\_exp} function takes a guard expression and returns true if the guard
	expression evaluates to true in the given state.\<close>

	type_synonym ltl_gexp = "ltl_vname gexp"

	definition join_iro :: "value list \<Rightarrow> registers \<Rightarrow> outputs \<Rightarrow> ltl_vname datastate" where
	"join_iro i r p = (\<lambda>x. case x of
	Rg n \<Rightarrow> r $ n \|
	Ip n \<Rightarrow> Some (i ! n) \|
	Op n \<Rightarrow> p ! n
	)"

	lemma join_iro_R [simp]: "join_iro i r p (Rg n) = r $ n"
	by (simp add: join_iro_def)

	abbreviation "check_exp g s \<equiv> (gval g (join_iro (snd (action (shd s))) (datastate (shd s)) (output (shd s))) = trilean.true)"

	lemma alw_ev: "alw f = not (ev (\<lambda>s. \<not>f s))"
	by simp

	lemma alw_state_eq_smap:
	"alw (state_eq s) ss = alw (\<lambda>ss. shd ss = s) (smap statename ss)"
	apply standard
	apply (simp add: alw_iff_sdrop )
	by (simp add: alw_mono alw_smap )

	subsection\<open>Sink State\<close>
	text\<open>Once the sink state is entered, it cannot be left and there are no outputs or updates
	henceforth.\<close>

	lemma shd_state_is_none: "(state_eq None) (make_full_observation e None r p t)"
	- by (simp add: )
	+ by simp

	lemma unfold_observe_none: "make_full_observation e None d p t = (\<lparr>statename = None, datastate = d, action=(shd t), output = p\<rparr>##(make_full_observation e None d [] (stl t)))"
	by (simp add: stream.expand)

	lemma once_none_always_none_aux:
	assumes "\<exists> p r i. j = (make_full_observation e None r p) i"
	shows "alw (state_eq None) j"
	using assms apply coinduct
	apply simp
	by fastforce

	lemma once_none_always_none: "alw (state_eq None) (make_full_observation e None r p t)"
	using once_none_always_none_aux by blast

	lemma once_none_nxt_always_none: "alw (nxt (state_eq None)) (make_full_observation e None r p t)"
	using once_none_always_none
	by (simp add: alw_iff_sdrop del: sdrop.simps)

	lemma snth_sconst: "(\<forall>i. s !! i = h) = (s = sconst h)"
	by (auto simp add: sconst_alt sset_range)

	lemma alw_sconst: "(alw (\<lambda>xs. shd xs = h) t) = (t = sconst h)"
	by (simp add: snth_sconst[symmetric] alw_iff_sdrop)

	lemma smap_statename_None: "smap statename (make_full_observation e None r p i) = sconst None"
	by (meson EFSM_LTL.alw_sconst alw_state_eq_smap once_none_always_none)

	lemma alw_not_some: "alw (\<lambda>xs. statename (shd xs) \<noteq> Some s) (make_full_observation e None r p t)"
	by (metis (mono_tags, lifting) alw_mono once_none_always_none option.distinct(1) )

	lemma state_none: "((state_eq None) impl nxt (state_eq None)) (make_full_observation e s r p t)"
	- by (simp add: )
	+ by simp

	lemma state_none_2:
	"(state_eq None) (make_full_observation e s r p t) \<Longrightarrow>
	(state_eq None) (make_full_observation e s r p (stl t))"
	- by (simp add: )
	+ by simp

	lemma no_output_none_aux:
	assumes "\<exists> p r i. j = (make_full_observation e None r []) i"
	shows "alw (output_eq []) j"
	using assms apply coinduct
	apply simp
	by fastforce

	lemma no_output_none: "nxt (alw (output_eq [])) (make_full_observation e None r p t)"
	using no_output_none_aux by auto

	lemma nxt_alw: "nxt (alw P) s \<Longrightarrow> alw (nxt P) s"
	by (simp add: alw_iff_sdrop)

	lemma no_output_none_nxt: "alw (nxt (output_eq [])) (make_full_observation e None r p t)"
	using nxt_alw no_output_none by blast

	lemma no_output_none_if_empty: "alw (output_eq []) (make_full_observation e None r [] t)"
	by (metis (mono_tags, lifting) alw_nxt make_full_observation.simps(1) no_output_none state.select_convs(4))

	lemma no_updates_none_aux:
	assumes "\<exists> p i. j = (make_full_observation e None r p) i"
	shows "alw (\<lambda>x. datastate (shd x) = r) j"
	using assms apply coinduct
	by fastforce

	lemma no_updates_none: "alw (\<lambda>x. datastate (shd x) = r) (make_full_observation e None r p t)"
	using no_updates_none_aux by blast

	lemma action_components: "(label_eq l aand input_eq i) s = (action (shd s) = (String.implode l, i))"
	by (metis fst_conv prod.collapse snd_conv)

	end
	diff --git a/thys/Extended_Finite_State_Machines/examples/Drinks_Machine_LTL.thy b/thys/Extended_Finite_State_Machines/examples/Drinks_Machine_LTL.thy
	--- a/thys/Extended_Finite_State_Machines/examples/Drinks_Machine_LTL.thy
	+++ b/thys/Extended_Finite_State_Machines/examples/Drinks_Machine_LTL.thy
	@@ -1,342 +1,342 @@
	section\<open>Temporal Properties\<close>
	text\<open>This theory presents some examples of temporal properties over the simple drinks machine.\<close>

	theory Drinks_Machine_LTL
	imports "Drinks_Machine" "Extended_Finite_State_Machines.EFSM_LTL"
	begin

	declare One_nat_def [simp del]

	lemma P_ltl_step_0:
	assumes invalid: "P (None, [], <>)"
	assumes select: "l = STR ''select'' \<longrightarrow> P (Some 1, [], <1 $:= Some (hd i), 2 $:= Some (Num 0)>)"
	shows "P (ltl_step drinks (Some 0) <> (l, i))"
	proof-
	have length_i: "\<exists>d. (l, i) = (STR ''select'', [d]) \<Longrightarrow> length i = 1"
	by (induct i, auto)
	have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
	by (induct i, auto)
	show ?thesis
	apply (case_tac "\<exists>d. (l, i) = (STR ''select'', [d])")
	apply (simp add: possible_steps_0 length_i select_def apply_updates_def)
	using select apply auto[1]
	by (simp add: possible_steps_0_invalid length_i_2 invalid)
	qed

	lemma P_ltl_step_1:
	assumes invalid: "P (None, [], r)"
	assumes coin: "l = STR ''coin'' \<longrightarrow> P (Some 1, [value_plus (r $ 2) (Some (hd i))], r(2 $:= value_plus (r $ 2) (Some (i ! 0))))"
	assumes vend_fail: "value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 1, [],r)"
	assumes vend: "\<not>? value_gt (Some (Num 100)) (r $ 2) = trilean.true \<longrightarrow> P (Some 2, [r$1], r)"
	shows "P (ltl_step drinks (Some 1) r (l, i))"
	proof-
	have length_i: "\<And>s. \<exists>d. (l, i) = (s, [d]) \<Longrightarrow> length i = 1"
	by (induct i, auto)
	have length_i_2: "\<forall>d. i \<noteq> [d] \<Longrightarrow> length i \<noteq> 1"
	by (induct i, auto)
	show ?thesis
	apply (case_tac "\<exists>d. (l, i) = (STR ''coin'', [d])")
	apply (simp add: possible_steps_1_coin length_i coin_def apply_outputs_def apply_updates_def)
	using coin apply auto[1]
	apply (case_tac "(l, i) = (STR ''vend'', [])")
	apply (case_tac "\<exists>n. r $ 2 = Some (Num n)")
	apply clarsimp
	subgoal for n
	apply (case_tac "n \<ge> 100")
	apply (simp add: drinks_vend_sufficient vend_def apply_updates_def apply_outputs_def)
	apply (metis finfun_upd_triv possible_steps_2_vend vend vend_ge_100)
	apply (simp add: drinks_vend_insufficient vend_fail_def apply_updates_def apply_outputs_def)
	apply (metis MaybeBoolInt.simps(1) finfun_upd_triv not_less value_gt_def vend_fail)
	done
	apply (simp add: drinks_vend_invalid invalid)
	by (simp add: drinks_no_possible_steps_1 length_i_2 invalid)
	qed

	lemma LTL_r2_not_always_gt_100: "not (alw (check_exp (Gt (V (Rg 2)) (L (Num 100))))) (watch drinks i)"
	using value_gt_def by auto

	lemma drinks_step_2_none: "ltl_step drinks (Some 2) r e = (None, [], r)"
	by (simp add: drinks_end ltl_step_none_2)

	lemma one_before_two_2:
	"alw (\<lambda>x. statename (shd (stl x)) = Some 2 \<longrightarrow> statename (shd x) = Some 1) (make_full_observation drinks (Some 2) r [r $ 1] x2a)"
	proof(coinduction)
	case alw
	then show ?case
	apply (simp add: drinks_step_2_none)
	by (metis (mono_tags, lifting) alw_mono nxt.simps once_none_nxt_always_none option.distinct(1))
	qed

	lemma one_before_two_aux:
	assumes "\<exists> p r i. j = nxt (make_full_observation drinks (Some 1) r p) i"
	shows "alw (\<lambda>x. nxt (state_eq (Some 2)) x \<longrightarrow> state_eq (Some 1) x) j"
	using assms apply(coinduct)
	apply simp
	apply clarify
	apply standard
	apply simp
	apply simp
	subgoal for r i
	apply (case_tac "shd (stl i)")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_1)
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (state_eq None)"])
	apply (simp add: once_none_nxt_always_none)
	apply simp
	apply auto[1]
	apply auto[1]
	apply simp
	by (simp add: one_before_two_2)
	done

	lemma LTL_nxt_2_means_vend:
	"alw (nxt (state_eq (Some 2)) impl (state_eq (Some 1))) (watch drinks i)"
	proof(coinduction)
	case alw
	then show ?case
	apply (case_tac "shd i")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_0)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (state_eq None)"])
	apply (simp add: once_none_nxt_always_none)
	using one_before_two_aux by auto
	qed

	lemma costsMoney_aux:
	assumes "\<exists>p r i. j = (nxt (make_full_observation drinks (Some 1) r p) i)"
	shows "alw (\<lambda>xs. nxt (state_eq (Some 2)) xs \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
	using assms apply coinduct
	apply clarsimp
	subgoal for r i
	apply (case_tac "shd (stl i)")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_1)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (state_eq None)"])
	apply (simp add: once_none_nxt_always_none)
	apply simp
	apply auto[1]
	apply auto[1]
	apply simp
	apply standard
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (state_eq None)"])
	apply (metis (no_types, lifting) drinks_step_2_none fst_conv make_full_observation.sel(2) nxt.simps nxt_alw once_none_always_none_aux)
	by simp
	done

	(* costsMoney: THEOREM drinks \|- G(X(cfstate=State_2) => gval(value_ge(r_2, Some(NUM(100))))); *)
	lemma LTL_costsMoney:
	"(alw (nxt (state_eq (Some 2)) impl (check_exp (Ge (V (Rg 2)) (L (Num 100)))))) (watch drinks i)"
	proof(coinduction)
	case alw
	then show ?case
	apply (cases "shd i")
	subgoal for l ip
	apply (case_tac "l = STR ''select'' \<and> length ip = 1")
	defer
	apply (simp add: possible_steps_0_invalid)
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (state_eq None)"])
	apply (simp add: once_none_nxt_always_none)
	- apply (simp add: )
	+ apply simp
	apply (simp add: possible_steps_0 select_def)
	apply (rule disjI2)
	apply (simp only: nxt.simps[symmetric])
	using costsMoney_aux by auto
	done
	qed

	lemma LTL_costsMoney_aux:
	"(alw (not (check_exp (Ge (V (Rg 2)) (L (Num 100)))) impl (not (nxt (state_eq (Some 2)))))) (watch drinks i)"
	by (metis (no_types, lifting) LTL_costsMoney alw_mono)

	lemma implode_select: "String.implode ''select'' = STR ''select''"
	by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

	lemma implode_coin: "String.implode ''coin'' = STR ''coin''"
	by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

	lemma implode_vend: "String.implode ''vend'' = STR ''vend''"
	by (metis Literal.rep_eq String.implode_explode_eq zero_literal.rep_eq)

	lemmas implode_labels = implode_select implode_coin implode_vend

	lemma LTL_neverReachS2:"(((((action_eq (''select'', [Str ''coke''])))
	aand
	(nxt ((action_eq (''coin'', [Num 100])))))
	aand
	(nxt (nxt((label_eq ''vend'' aand (input_eq []))))))
	impl
	(nxt (nxt (nxt (state_eq (Some 2))))))
	(watch drinks i)"
	apply (simp add: implode_labels)
	apply (cases i)
	apply clarify
	apply simp
	apply (simp add: possible_steps_0 select_def)
	apply (case_tac "shd x2", clarify)
	apply (simp add: possible_steps_1_coin coin_def value_plus_def finfun_update_twist apply_updates_def)
	apply (case_tac "shd (stl x2)", clarify)
	by (simp add: drinks_vend_sufficient )

	lemma ltl_step_not_select:
	"\<nexists>i. e = (STR ''select'', [i]) \<Longrightarrow>
	ltl_step drinks (Some 0) r e = (None, [], r)"
	apply (cases e, clarify)
	subgoal for a b
	apply (rule ltl_step_none)
	apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def select_def)
	by (cases e, case_tac b, auto)
	done

	lemma ltl_step_select:
	"ltl_step drinks (Some 0) <> (STR ''select'', [i]) = (Some 1, [], <1 $:= Some i, 2 $:= Some (Num 0)>)"
	apply (rule ltl_step_some[of _ _ _ _ _ _ select])
	apply (simp add: possible_steps_0)
	apply (simp add: select_def)
	by (simp add: select_def finfun_update_twist apply_updates_def)

	lemma ltl_step_not_coin_or_vend:
	"\<nexists>i. e = (STR ''coin'', [i]) \<Longrightarrow>
	e \<noteq> (STR ''vend'', []) \<Longrightarrow>
	ltl_step drinks (Some 1) r e = (None, [], r)"
	apply (cases e)
	subgoal for a b
	apply (simp del: ltl_step.simps)
	apply (rule ltl_step_none)
	apply (simp add: possible_steps_empty drinks_def can_take_transition_def can_take_def transitions)
	by (case_tac e, case_tac b, auto)
	done

	lemma ltl_step_coin:
	"\<exists>p r'. ltl_step drinks (Some 1) r (STR ''coin'', [i]) = (Some 1, p, r')"
	by (simp add: possible_steps_1_coin)

	lemma alw_tl:
	"alw \<phi> (make_full_observation e (Some 0) <> [] xs) \<Longrightarrow>
	alw \<phi>
	(make_full_observation e (fst (ltl_step e (Some 0) <> (shd xs))) (snd (snd (ltl_step e (Some 0) <> (shd xs))))
	(fst (snd (ltl_step e (Some 0) <> (shd xs)))) (stl xs))"
	by auto

	lemma stop_at_none:
	"alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs)
	(make_full_observation drinks None r p t)"
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: no_output_none_nxt)
	by simp

	lemma drink_costs_money_aux:
	assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
	shows "alw (\<lambda>xs. output (shd (stl xs)) = [Some (EFSM.Str drink)] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
	using assms apply coinduct
	apply clarsimp
	apply (case_tac "shd t")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_1)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: no_output_none_nxt)
	apply simp
	apply (simp add: Str_def value_plus_never_string)
	apply auto[1]
	apply auto[1]
	apply simp
	apply standard
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
	by simp

	lemma LTL_drinks_cost_money:
	"alw (nxt (output_eq [Some (Str drink)]) impl (check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
	proof(coinduction)
	case alw
	then show ?case
	apply (case_tac "shd t")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_0)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: no_output_none_nxt)
	apply simp
	apply simp
	using drink_costs_money_aux
	apply simp
	by blast
	qed

	lemma steps_1_invalid:
	"\<nexists>i. (a, b) = (STR ''coin'', [i]) \<Longrightarrow>
	\<nexists>i. (a, b) = (STR ''vend'', []) \<Longrightarrow>
	possible_steps drinks 1 r a b = {\|\|}"
	apply (simp add: possible_steps_empty drinks_def transitions can_take_transition_def can_take_def)
	by (induct b, auto)

	lemma output_vend_aux:
	assumes "\<exists>p r t. j = make_full_observation drinks (Some 1) r p t"
	shows "alw (\<lambda>xs. label_eq ''vend'' xs \<and> output (shd (stl xs)) = [Some d] \<longrightarrow> check_exp (Ge (V (Rg 2)) (L (Num 100))) xs) j"
	using assms apply coinduct
	apply clarsimp
	subgoal for r t
	apply (case_tac "shd t")
	apply (simp add: implode_vend del: ltl_step.simps)
	apply (rule P_ltl_step_1)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: no_output_none_nxt)
	apply simp
	apply auto[1]
	apply auto[1]
	apply simp
	apply standard
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: drinks_step_2_none no_output_none_if_empty nxt_alw)
	by simp
	done

	text_raw\<open>\snip{outputVend}{1}{2}{%\<close>
	lemma LTL_output_vend:
	"alw (((label_eq ''vend'') aand (nxt (output_eq [Some d]))) impl
	(check_exp (Ge (V (Rg 2)) (L (Num 100))))) (watch drinks t)"
	text_raw\<open>}%endsnip\<close>
	proof(coinduction)
	case alw
	then show ?case
	apply (simp add: implode_vend)
	apply (case_tac "shd t")
	apply (simp del: ltl_step.simps)
	apply (rule P_ltl_step_0)
	apply simp
	apply (rule disjI2)
	apply (rule alw_mono[of "nxt (output_eq [])"])
	apply (simp add: no_output_none_nxt)
	apply simp
	apply simp
	subgoal for a b
	using output_vend_aux[of "(make_full_observation drinks (Some 1)
	<1 $:= Some (hd b), 2 $:= Some (Num 0)> [] (stl t))" d]
	using implode_vend by auto
	done
	qed

	text_raw\<open>\snip{outputVendUnfolded}{1}{2}{%\<close>
	lemma LTL_output_vend_unfolded:
	"alw (\<lambda>xs. (label (shd xs) = STR ''vend'' \<and>
	nxt (\<lambda>s. output (shd s) = [Some d]) xs) \<longrightarrow>
	\<not>? value_gt (Some (Num 100)) (datastate (shd xs) $ 2) = trilean.true)
	(watch drinks t)"
	text_raw\<open>}%endsnip\<close>
	apply (insert LTL_output_vend[of d t])
	by (simp add: implode_vend)

	end
	diff --git a/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy b/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy
	--- a/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy
	+++ b/thys/FO_Theory_Rewriting/Util/Multihole_Context.thy
	@@ -1,803 +1,803 @@
	(*
	Author: Bertram Felgenhauer <bertram.felgenhauer@uibk.ac.at> (2015)
	Author: Christian Sternagel <c.sternagel@gmail.com> (2013-2016)
	Author: Martin Avanzini <martin.avanzini@uibk.ac.at> (2014)
	Author: René Thiemann <rene.thiemann@uibk.ac.at> (2013-2015)
	Author: Julian Nagele <julian.nagele@uibk.ac.at> (2016)
	License: LGPL (see file COPYING.LESSER)
	*)

	section \<open>Preliminaries\<close>
	subsection \<open>Multihole Contexts\<close>

	theory Multihole_Context
	imports
	Utils
	begin

	unbundle lattice_syntax

	subsubsection \<open>Partitioning lists into chunks of given length\<close>

	lemma concat_nth:
	assumes "m < length xs" and "n < length (xs ! m)"
	and "i = sum_list (map length (take m xs)) + n"
	shows "concat xs ! i = xs ! m ! n"
	using assms
	proof (induct xs arbitrary: m n i)
	case (Cons x xs)
	show ?case
	proof (cases m)
	case 0
	then show ?thesis using Cons by (simp add: nth_append)
	next
	case (Suc k)
	with Cons(1) [of k n "i - length x"] and Cons(2-)
	show ?thesis by (simp_all add: nth_append)
	qed
	qed simp

	lemma sum_list_take_eq:
	fixes xs :: "nat list"
	shows "k < i \<Longrightarrow> i < length xs \<Longrightarrow> sum_list (take i xs) =
	sum_list (take k xs) + xs ! k + sum_list (take (i - Suc k) (drop (Suc k) xs))"
	by (subst id_take_nth_drop [of k]) (auto simp: min_def drop_take)

	fun partition_by where
	"partition_by xs [] = []" \|
	"partition_by xs (y#ys) = take y xs # partition_by (drop y xs) ys"

	lemma partition_by_map0_append [simp]:
	"partition_by xs (map (\<lambda>x. 0) ys @ zs) = replicate (length ys) [] @ partition_by xs zs"
	by (induct ys) simp_all

	lemma concat_partition_by [simp]:
	"sum_list ys = length xs \<Longrightarrow> concat (partition_by xs ys) = xs"
	by (induct ys arbitrary: xs) simp_all

	definition partition_by_idx where
	"partition_by_idx l ys i j = partition_by [0..<l] ys ! i ! j"

	lemma partition_by_nth_nth_old:
	assumes "i < length (partition_by xs ys)"
	and "j < length (partition_by xs ys ! i)"
	and "sum_list ys = length xs"
	shows "partition_by xs ys ! i ! j = xs ! (sum_list (map length (take i (partition_by xs ys))) + j)"
	using concat_nth [OF assms(1, 2) refl]
	unfolding concat_partition_by [OF assms(3)] by simp

	lemma map_map_partition_by:
	"map (map f) (partition_by xs ys) = partition_by (map f xs) ys"
	by (induct ys arbitrary: xs) (auto simp: take_map drop_map)

	lemma length_partition_by [simp]:
	"length (partition_by xs ys) = length ys"
	by (induct ys arbitrary: xs) simp_all

	lemma partition_by_Nil [simp]:
	"partition_by [] ys = replicate (length ys) []"
	by (induct ys) simp_all

	lemma partition_by_concat_id [simp]:
	assumes "length xss = length ys"
	and "\<And>i. i < length ys \<Longrightarrow> length (xss ! i) = ys ! i"
	shows "partition_by (concat xss) ys = xss"
	using assms by (induct ys arbitrary: xss) (simp, case_tac xss, simp, fastforce)

	lemma partition_by_nth:
	"i < length ys \<Longrightarrow> partition_by xs ys ! i = take (ys ! i) (drop (sum_list (take i ys)) xs)"
	by (induct ys arbitrary: xs i) (simp, case_tac i, simp_all add: ac_simps)

	lemma partition_by_nth_less:
	assumes "k < i" and "i < length zs"
	and "length xs = sum_list (take i zs) + j"
	shows "partition_by (xs @ y # ys) zs ! k = take (zs ! k) (drop (sum_list (take k zs)) xs)"
	proof -
	have "partition_by (xs @ y # ys) zs ! k =
	take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
	using assms by (auto simp: partition_by_nth)
	moreover have "zs ! k + sum_list (take k zs) \<le> length xs"
	using assms by (simp add: sum_list_take_eq)
	ultimately show ?thesis by simp
	qed

	lemma partition_by_nth_greater:
	assumes "i < k" and "k < length zs" and "j < zs ! i"
	and "length xs = sum_list (take i zs) + j"
	shows "partition_by (xs @ y # ys) zs ! k =
	take (zs ! k) (drop (sum_list (take k zs) - 1) (xs @ ys))"
	proof -
	have "partition_by (xs @ y # ys) zs ! k =
	take (zs ! k) (drop (sum_list (take k zs)) (xs @ y # ys))"
	using assms by (auto simp: partition_by_nth)
	moreover have "sum_list (take k zs) > length xs"
	using assms by (auto simp: sum_list_take_eq)
	ultimately show ?thesis by (auto) (metis Suc_diff_Suc drop_Suc_Cons)
	qed

	lemma length_partition_by_nth:
	"sum_list ys = length xs \<Longrightarrow> i < length ys \<Longrightarrow> length (partition_by xs ys ! i) = ys ! i"
	by (induct ys arbitrary: xs i; case_tac i) auto

	lemma partition_by_nth_nth_elem:
	assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
	shows "partition_by xs ys ! i ! j \<in> set xs"
	proof -
	from assms have "j < length (partition_by xs ys ! i)" by (simp only: length_partition_by_nth)
	then have "partition_by xs ys ! i ! j \<in> set (partition_by xs ys ! i)" by auto
	with assms(2) have "partition_by xs ys ! i ! j \<in> set (concat (partition_by xs ys))" by auto
	then show ?thesis using assms by simp
	qed

	lemma partition_by_nth_nth:
	assumes "sum_list ys = length xs" "i < length ys" "j < ys ! i"
	shows "partition_by xs ys ! i ! j = xs ! partition_by_idx (length xs) ys i j"
	"partition_by_idx (length xs) ys i j < length xs"
	unfolding partition_by_idx_def
	proof -
	let ?n = "partition_by [0..<length xs] ys ! i ! j"
	show "?n < length xs"
	using partition_by_nth_nth_elem[OF _ assms(2,3), of "[0..<length xs]"] assms(1) by simp
	have li: "i < length (partition_by [0..<length xs] ys)" using assms(2) by simp
	have lj: "j < length (partition_by [0..<length xs] ys ! i)"
	using assms by (simp add: length_partition_by_nth)
	have "partition_by (map ((!) xs) [0..<length xs]) ys ! i ! j = xs ! ?n"
	by (simp only: map_map_partition_by[symmetric] nth_map[OF li] nth_map[OF lj])
	then show "partition_by xs ys ! i ! j = xs ! ?n" by (simp add: map_nth)
	qed

	lemma map_length_partition_by [simp]:
	"sum_list ys = length xs \<Longrightarrow> map length (partition_by xs ys) = ys"
	by (intro nth_equalityI, auto simp: length_partition_by_nth)

	lemma map_partition_by_nth [simp]:
	"i < length ys \<Longrightarrow> map f (partition_by xs ys ! i) = partition_by (map f xs) ys ! i"
	by (induct ys arbitrary: i xs) (simp, case_tac i, simp_all add: take_map drop_map)

	lemma sum_list_partition_by [simp]:
	"sum_list ys = length xs \<Longrightarrow>
	sum_list (map (\<lambda>x. sum_list (map f x)) (partition_by xs ys)) = sum_list (map f xs)"
	by (induct ys arbitrary: xs) (simp_all, metis append_take_drop_id sum_list_append map_append)

	lemma partition_by_map_conv:
	"partition_by xs ys = map (\<lambda>i. take (ys ! i) (drop (sum_list (take i ys)) xs)) [0 ..< length ys]"
	by (rule nth_equalityI) (simp_all add: partition_by_nth)

	lemma UN_set_partition_by_map:
	"sum_list ys = length xs \<Longrightarrow> (\<Union>x\<in>set (partition_by (map f xs) ys). \<Union> (set x)) = \<Union>(set (map f xs))"
	by (induct ys arbitrary: xs)
	(simp_all add: drop_map take_map, metis UN_Un append_take_drop_id set_append)

	lemma UN_set_partition_by:
	"sum_list ys = length xs \<Longrightarrow> (\<Union>zs \<in> set (partition_by xs ys). \<Union>x \<in> set zs. f x) = (\<Union>x \<in> set xs. f x)"
	by (induct ys arbitrary: xs) (simp_all, metis UN_Un append_take_drop_id set_append)

	lemma Ball_atLeast0LessThan_partition_by_conv:
	"(\<forall>i\<in>{0..<length ys}. \<forall>x\<in>set (partition_by xs ys ! i). P x) =
	(\<forall>x \<in> \<Union>(set (map set (partition_by xs ys))). P x)"
	by auto (metis atLeast0LessThan in_set_conv_nth length_partition_by lessThan_iff)

	lemma Ball_set_partition_by:
	"sum_list ys = length xs \<Longrightarrow>
	(\<forall>x \<in> set (partition_by xs ys). \<forall>y \<in> set x. P y) = (\<forall>x \<in> set xs. P x)"
	proof (induct ys arbitrary: xs)
	case (Cons y ys)
	then show ?case
	apply (subst (2) append_take_drop_id [of y xs, symmetric])
	apply (simp only: set_append)
	apply auto
	done
	qed simp

	lemma partition_by_append2:
	"partition_by xs (ys @ zs) = partition_by (take (sum_list ys) xs) ys @ partition_by (drop (sum_list ys) xs) zs"
	by (induct ys arbitrary: xs) (auto simp: drop_take ac_simps split: split_min)

	lemma partition_by_concat2:
	"partition_by xs (concat ys) =
	concat (map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys])"
	proof -
	have *: "map (\<lambda>i . partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys] =
	map (\<lambda>(x,y). partition_by x y) (zip (partition_by xs (map sum_list ys)) ys)"
	using zip_nth_conv[of "partition_by xs (map sum_list ys)" ys] by auto
	show ?thesis unfolding * by (induct ys arbitrary: xs) (auto simp: partition_by_append2)
	qed

	lemma partition_by_partition_by:
	"length xs = sum_list (map sum_list ys) \<Longrightarrow>
	partition_by (partition_by xs (concat ys)) (map length ys) =
	map (\<lambda>i. partition_by (partition_by xs (map sum_list ys) ! i) (ys ! i)) [0..<length ys]"
	by (auto simp: partition_by_concat2 intro: partition_by_concat_id)

	subsubsection \<open>Multihole contexts definition and functionalities\<close>
	datatype ('f, vars_mctxt : 'v) mctxt = MVar 'v \| MHole \| MFun 'f "('f, 'v) mctxt list"

	subsubsection \<open>Conversions from and to multihole contexts\<close>

	primrec mctxt_of_term :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt" where
	"mctxt_of_term (Var x) = MVar x" \|
	"mctxt_of_term (Fun f ts) = MFun f (map mctxt_of_term ts)"

	primrec term_of_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term" where
	"term_of_mctxt (MVar x) = Var x" \|
	"term_of_mctxt (MFun f Cs) = Fun f (map term_of_mctxt Cs)"

	fun num_holes :: "('f, 'v) mctxt \<Rightarrow> nat" where
	"num_holes (MVar _) = 0" \|
	"num_holes MHole = 1" \|
	"num_holes (MFun _ ctxts) = sum_list (map num_holes ctxts)"

	fun ground_mctxt :: "('f, 'v) mctxt \<Rightarrow> bool" where
	"ground_mctxt (MVar _) = False" \|
	"ground_mctxt MHole = True" \|
	"ground_mctxt (MFun f Cs) = Ball (set Cs) ground_mctxt"

	fun map_mctxt :: "('f \<Rightarrow> 'g) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('g, 'v) mctxt"
	where
	"map_mctxt _ (MVar x) = (MVar x)" \|
	"map_mctxt _ (MHole) = MHole" \|
	"map_mctxt fg (MFun f Cs) = MFun (fg f) (map (map_mctxt fg) Cs)"

	abbreviation "partition_holes xs Cs \<equiv> partition_by xs (map num_holes Cs)"
	abbreviation "partition_holes_idx l Cs \<equiv> partition_by_idx l (map num_holes Cs)"

	fun fill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term list \<Rightarrow> ('f, 'v) term" where
	"fill_holes (MVar x) _ = Var x" \|
	"fill_holes MHole [t] = t" \|
	"fill_holes (MFun f cs) ts = Fun f (map (\<lambda> i. fill_holes (cs ! i)
	(partition_holes ts cs ! i)) [0 ..< length cs])"

	fun fill_holes_mctxt :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) mctxt list \<Rightarrow> ('f, 'v) mctxt" where
	"fill_holes_mctxt (MVar x) _ = MVar x" \|
	"fill_holes_mctxt MHole [] = MHole" \|
	"fill_holes_mctxt MHole [t] = t" \|
	"fill_holes_mctxt (MFun f cs) ts = (MFun f (map (\<lambda> i. fill_holes_mctxt (cs ! i)
	(partition_holes ts cs ! i)) [0 ..< length cs]))"


	fun unfill_holes :: "('f, 'v) mctxt \<Rightarrow> ('f, 'v) term \<Rightarrow> ('f, 'v) term list" where
	"unfill_holes MHole t = [t]"
	\| "unfill_holes (MVar w) (Var v) = (if v = w then [] else undefined)"
	\| "unfill_holes (MFun g Cs) (Fun f ts) = (if f = g \<and> length ts = length Cs then
	concat (map (\<lambda>i. unfill_holes (Cs ! i) (ts ! i)) [0..<length ts]) else undefined)"

	fun funas_mctxt where
	"funas_mctxt (MFun f Cs) = {(f, length Cs)} \<union> \<Union>(funas_mctxt ` set Cs)" \|
	"funas_mctxt _ = {}"

	fun split_vars :: "('f, 'v) term \<Rightarrow> (('f, 'v) mctxt \<times> 'v list)" where
	"split_vars (Var x) = (MHole, [x])" \|
	"split_vars (Fun f ts) = (MFun f (map (fst \<circ> split_vars) ts), concat (map (snd \<circ> split_vars) ts))"


	fun hole_poss_list :: "('f, 'v) mctxt \<Rightarrow> pos list" where
	"hole_poss_list (MVar x) = []" \|
	"hole_poss_list MHole = [[]]" \|
	"hole_poss_list (MFun f cs) = concat (poss_args hole_poss_list cs)"

	fun map_vars_mctxt :: "('v \<Rightarrow> 'w) \<Rightarrow> ('f, 'v) mctxt \<Rightarrow> ('f, 'w) mctxt"
	where
	"map_vars_mctxt vw MHole = MHole" \|
	"map_vars_mctxt vw (MVar v) = (MVar (vw v))" \|
	"map_vars_mctxt vw (MFun f Cs) = MFun f (map (map_vars_mctxt vw) Cs)"

	inductive eq_fill :: "('f, 'v) term \<Rightarrow> ('f, 'v) mctxt \<times> ('f, 'v) term list \<Rightarrow> bool" ("(_/ =\<^sub>f _)" [51, 51] 50)
	where
	eqfI [intro]: "t = fill_holes D ss \<Longrightarrow> num_holes D = length ss \<Longrightarrow> t =\<^sub>f (D, ss)"

	subsubsection \<open>Semilattice Structures\<close>

	instantiation mctxt :: (type, type) inf

	begin

	fun inf_mctxt :: "('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt \<Rightarrow> ('a, 'b) mctxt"
	where
	"MHole \<sqinter> D = MHole" \|
	"C \<sqinter> MHole = MHole" \|
	"MVar x \<sqinter> MVar y = (if x = y then MVar x else MHole)" \|
	"MFun f Cs \<sqinter> MFun g Ds =
	(if f = g \<and> length Cs = length Ds then MFun f (map (case_prod (\<sqinter>)) (zip Cs Ds))
	else MHole)" \|
	"C \<sqinter> D = MHole"

	instance ..

	end

	lemma inf_mctxt_idem [simp]:
	fixes C :: "('f, 'v) mctxt"
	shows "C \<sqinter> C = C"
	by (induct C) (auto simp: zip_same_conv_map intro: map_idI)

	lemma inf_mctxt_MHole2 [simp]:
	"C \<sqinter> MHole = MHole"
	by (induct C) simp_all

	lemma inf_mctxt_comm [ac_simps]:
	"(C :: ('f, 'v) mctxt) \<sqinter> D = D \<sqinter> C"
	by (induct C D rule: inf_mctxt.induct) (fastforce simp: in_set_conv_nth intro!: nth_equalityI)+

	lemma inf_mctxt_assoc [ac_simps]:
	fixes C :: "('f, 'v) mctxt"
	shows "C \<sqinter> D \<sqinter> E = C \<sqinter> (D \<sqinter> E)"
	apply (induct C D arbitrary: E rule: inf_mctxt.induct)
	- apply (auto simp: )
	+ apply auto
	apply (case_tac E, auto)+
	apply (fastforce simp: in_set_conv_nth intro!: nth_equalityI)
	apply (case_tac E, auto)+
	done

	instantiation mctxt :: (type, type) order
	begin

	definition "(C :: ('a, 'b) mctxt) \<le> D \<longleftrightarrow> C \<sqinter> D = C"
	definition "(C :: ('a, 'b) mctxt) < D \<longleftrightarrow> C \<le> D \<and> \<not> D \<le> C"

	instance
	by (standard, simp_all add: less_eq_mctxt_def less_mctxt_def ac_simps, metis inf_mctxt_assoc)

	end

	inductive less_eq_mctxt' :: "('f, 'v) mctxt \<Rightarrow> ('f,'v) mctxt \<Rightarrow> bool" where
	"less_eq_mctxt' MHole u"
	\| "less_eq_mctxt' (MVar v) (MVar v)"
	\| "length cs = length ds \<Longrightarrow> (\<And>i. i < length cs \<Longrightarrow> less_eq_mctxt' (cs ! i) (ds ! i)) \<Longrightarrow> less_eq_mctxt' (MFun f cs) (MFun f ds)"


	subsubsection \<open>Lemmata\<close>

	lemma partition_holes_fill_holes_conv:
	"fill_holes (MFun f cs) ts =
	Fun f [fill_holes (cs ! i) (partition_holes ts cs ! i). i \<leftarrow> [0 ..< length cs]]"
	by (simp add: partition_by_nth take_map)

	lemma partition_holes_fill_holes_mctxt_conv:
	"fill_holes_mctxt (MFun f Cs) ts =
	MFun f [fill_holes_mctxt (Cs ! i) (partition_holes ts Cs ! i). i \<leftarrow> [0 ..< length Cs]]"
	by (simp add: partition_by_nth take_map)

	text \<open>The following induction scheme provides the @{term MFun} case with the list argument split
	according to the argument contexts. This feature is quite delicate: its benefit can be
	destroyed by premature simplification using the @{thm concat_partition_by} simplification rule.\<close>

	lemma fill_holes_induct2[consumes 2, case_names MHole MVar MFun]:
	fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> bool"
	assumes len1: "num_holes C = length xs" and len2: "num_holes C = length ys"
	and Hole: "\<And>x y. P MHole [x] [y]"
	and Var: "\<And>v. P (MVar v) [] []"
	and Fun: "\<And>f Cs xs ys. sum_list (map num_holes Cs) = length xs \<Longrightarrow>
	sum_list (map num_holes Cs) = length ys \<Longrightarrow>
	(\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i) (partition_holes ys Cs ! i)) \<Longrightarrow>
	P (MFun f Cs) (concat (partition_holes xs Cs)) (concat (partition_holes ys Cs))"
	shows "P C xs ys"
	proof (insert len1 len2, induct C arbitrary: xs ys)
	case MHole then show ?case using Hole by (cases xs; cases ys) auto
	next
	case (MVar v) then show ?case using Var by auto
	next
	case (MFun f Cs) then show ?case using Fun[of Cs xs ys f] by (auto simp: length_partition_by_nth)
	qed

	lemma fill_holes_induct[consumes 1, case_names MHole MVar MFun]:
	fixes P :: "('f,'v) mctxt \<Rightarrow> 'a list \<Rightarrow> bool"
	assumes len: "num_holes C = length xs"
	and Hole: "\<And>x. P MHole [x]"
	and Var: "\<And>v. P (MVar v) []"
	and Fun: "\<And>f Cs xs. sum_list (map num_holes Cs) = length xs \<Longrightarrow>
	(\<And>i. i < length Cs \<Longrightarrow> P (Cs ! i) (partition_holes xs Cs ! i)) \<Longrightarrow>
	P (MFun f Cs) (concat (partition_holes xs Cs))"
	shows "P C xs"
	using fill_holes_induct2[of C xs xs "\<lambda> C xs _. P C xs"] assms by simp

	lemma length_partition_holes_nth [simp]:
	assumes "sum_list (map num_holes cs) = length ts"
	and "i < length cs"
	shows "length (partition_holes ts cs ! i) = num_holes (cs ! i)"
	using assms by (simp add: length_partition_by_nth)

	(some compatibility lemmas (which should be dropped eventually))
	lemmas
	map_partition_holes_nth [simp] =
	map_partition_by_nth [of _ "map num_holes Cs" for Cs, unfolded length_map] and
	length_partition_holes [simp] =
	length_partition_by [of _ "map num_holes Cs" for Cs, unfolded length_map]

	lemma fill_holes_term_of_mctxt:
	"num_holes C = 0 \<Longrightarrow> fill_holes C [] = term_of_mctxt C"
	by (induct C) (auto simp add: map_eq_nth_conv)

	lemma fill_holes_MHole:
	"length ts = Suc 0 \<Longrightarrow> ts ! 0 = u \<Longrightarrow> fill_holes MHole ts = u"
	by (cases ts) simp_all

	lemma fill_holes_arbitrary:
	assumes lCs: "length Cs = length ts"
	and lss: "length ss = length ts"
	and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> f (Cs ! i) (ss ! i) = ts ! i"
	shows "map (\<lambda>i. f (Cs ! i) (partition_holes (concat ss) Cs ! i)) [0 ..< length Cs] = ts"
	proof -
	have "sum_list (map num_holes Cs) = length (concat ss)" using assms
	by (auto simp: length_concat map_nth_eq_conv intro: arg_cong[of _ _ "sum_list"])
	moreover have "partition_holes (concat ss) Cs = ss"
	using assms by (auto intro: partition_by_concat_id)
	ultimately show ?thesis using assms by (auto intro: nth_equalityI)
	qed

	lemma fill_holes_MFun:
	assumes lCs: "length Cs = length ts"
	and lss: "length ss = length ts"
	and rec: "\<And> i. i < length ts \<Longrightarrow> num_holes (Cs ! i) = length (ss ! i) \<and> fill_holes (Cs ! i) (ss ! i) = ts ! i"
	shows "fill_holes (MFun f Cs) (concat ss) = Fun f ts"
	unfolding fill_holes.simps term.simps
	by (rule conjI[OF refl], rule fill_holes_arbitrary[OF lCs lss rec])

	lemma eqfE:
	assumes "t =\<^sub>f (D, ss)" shows "t = fill_holes D ss" "num_holes D = length ss"
	using assms[unfolded eq_fill.simps] by auto

	lemma eqf_MFunE:
	assumes "s =\<^sub>f (MFun f Cs,ss)"
	obtains ts sss where "s = Fun f ts" "length ts = length Cs" "length sss = length Cs"
	"\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
	"ss = concat sss"
	proof -
	from eqfE[OF assms] have fh: "s = fill_holes (MFun f Cs) ss"
	and nh: "sum_list (map num_holes Cs) = length ss" by auto
	from fh obtain ts where s: "s = Fun f ts" by (cases s, auto)
	from fh[unfolded s]
	have ts: "ts = map (\<lambda>i. fill_holes (Cs ! i) (partition_holes ss Cs ! i)) [0..<length Cs]"
	(is "_ = map (?f Cs ss) _")
	by auto
	let ?sss = "partition_holes ss Cs"
	from nh
	have *: "length ?sss = length Cs" "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, ?sss ! i)" "ss = concat ?sss"
	by (auto simp: ts)
	have len: "length ts = length Cs" unfolding ts by auto
	assume ass: "\<And>ts sss. s = Fun f ts \<Longrightarrow>
	length ts = length Cs \<Longrightarrow>
	length sss = length Cs \<Longrightarrow> (\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)) \<Longrightarrow> ss = concat sss \<Longrightarrow> thesis"
	show thesis
	by (rule ass[OF s len *])
	qed

	lemma eqf_MFunI:
	assumes "length sss = length Cs"
	and "length ts = length Cs"
	and"\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)"
	shows "Fun f ts =\<^sub>f (MFun f Cs, concat sss)"
	proof
	have "num_holes (MFun f Cs) = sum_list (map num_holes Cs)" by simp
	also have "map num_holes Cs = map length sss"
	by (rule nth_equalityI, insert assms eqfE[OF assms(3)], auto)
	also have "sum_list (\<dots>) = length (concat sss)" unfolding length_concat ..
	finally show "num_holes (MFun f Cs) = length (concat sss)" .
	show "Fun f ts = fill_holes (MFun f Cs) (concat sss)"
	by (rule fill_holes_MFun[symmetric], insert assms(1,2) eqfE[OF assms(3)], auto)
	qed

	lemma split_vars_ground_vars:
	assumes "ground_mctxt C" and "num_holes C = length xs"
	shows "split_vars (fill_holes C (map Var xs)) = (C, xs)" using assms
	proof (induct C arbitrary: xs)
	case (MHole xs)
	then show ?case by (cases xs, auto)
	next
	case (MFun f Cs xs)
	have "fill_holes (MFun f Cs) (map Var xs) =\<^sub>f (MFun f Cs, map Var xs)"
	by (rule eqfI, insert MFun(3), auto)
	from eqf_MFunE[OF this]
	obtain ts xss where fh: "fill_holes (MFun f Cs) (map Var xs) = Fun f ts"
	and lent: "length ts = length Cs"
	and lenx: "length xss = length Cs"
	and args: "\<And>i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, xss ! i)"
	and id: "map Var xs = concat xss" by auto
	from arg_cong[OF id, of "map the_Var"] have id2: "xs = concat (map (map the_Var) xss)"
	by (metis map_concat length_map map_nth_eq_conv term.sel(1))
	{
	fix i
	assume i: "i < length Cs"
	then have mem: "Cs ! i \<in> set Cs" by auto
	with MFun(2) have ground: "ground_mctxt (Cs ! i)" by auto
	have "map Var (map the_Var (xss ! i)) = map id (xss ! i)" unfolding map_map o_def map_eq_conv
	proof
	fix x
	assume "x \<in> set (xss ! i)"
	with lenx i have "x \<in> set (concat xss)" by auto
	from this[unfolded id[symmetric]] show "Var (the_Var x) = id x" by auto
	qed
	then have idxss: "map Var (map the_Var (xss ! i)) = xss ! i" by auto
	note rec = eqfE[OF args[OF i]]
	note IH = MFun(1)[OF mem ground, of "map the_Var (xss ! i)", unfolded rec(2) idxss rec(1)[symmetric]]
	from IH have "split_vars (ts ! i) = (Cs ! i, map the_Var (xss ! i))" by auto
	note this idxss
	}
	note IH = this
	have "?case = (map fst (map split_vars ts) = Cs \<and> concat (map snd (map split_vars ts)) = concat (map (map the_Var) xss))"
	unfolding fh unfolding id2 by auto
	also have "\<dots>"
	proof (rule conjI[OF nth_equalityI arg_cong[of _ _ concat, OF nth_equalityI, rule_format]], unfold length_map lent lenx)
	fix i
	assume i: "i < length Cs"
	with arg_cong[OF IH(2)[OF this], of "map the_Var"]
	IH[OF this] show "map snd (map split_vars ts) ! i = map (map the_Var) xss ! i" using lent lenx by auto
	qed (insert IH lent, auto)
	finally show ?case .
	qed auto


	lemma split_vars_vars_term_list: "snd (split_vars t) = vars_term_list t"
	proof (induct t)
	case (Fun f ts)
	then show ?case by (auto simp: vars_term_list.simps o_def, induct ts, auto)
	qed (auto simp: vars_term_list.simps)


	lemma split_vars_num_holes: "num_holes (fst (split_vars t)) = length (snd (split_vars t))"
	proof (induct t)
	case (Fun f ts)
	then show ?case by (induct ts, auto)
	qed simp

	lemma ground_eq_fill: "t =\<^sub>f (C,ss) \<Longrightarrow> ground t = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
	proof (induct C arbitrary: t ss)
	case (MVar x)
	from eqfE[OF this] show ?case by simp
	next
	case (MHole t ss)
	from eqfE[OF this] show ?case by (cases ss, auto)
	next
	case (MFun f Cs s ss)
	from eqf_MFunE[OF MFun(2)] obtain ts sss where s: "s = Fun f ts" and len: "length ts = length Cs" "length sss = length Cs"
	and IH: "\<And> i. i < length Cs \<Longrightarrow> ts ! i =\<^sub>f (Cs ! i, sss ! i)" and ss: "ss = concat sss" by metis
	{
	fix i
	assume i: "i < length Cs"
	then have "Cs ! i \<in> set Cs" by simp
	from MFun(1)[OF this IH[OF i]]
	have "ground (ts ! i) = (ground_mctxt (Cs ! i) \<and> (\<forall>a\<in>set (sss ! i). ground a))" .
	} note IH = this
	note conv = set_conv_nth
	have "?case = ((\<forall>x\<in>set ts. ground x) = ((\<forall>x\<in>set Cs. ground_mctxt x) \<and> (\<forall>a\<in>set sss. \<forall>x\<in>set a. ground x)))"
	unfolding s ss by simp
	also have "..." unfolding conv[of ts] conv[of Cs] conv[of sss] len using IH by auto
	finally show ?case by simp
	qed

	lemma ground_fill_holes:
	assumes nh: "num_holes C = length ss"
	shows "ground (fill_holes C ss) = (ground_mctxt C \<and> (\<forall> s \<in> set ss. ground s))"
	by (rule ground_eq_fill[OF eqfI[OF refl nh]])

	lemma split_vars_ground' [simp]:
	"ground_mctxt (fst (split_vars t))"
	by (induct t) auto

	lemma split_vars_funas_mctxt [simp]:
	"funas_mctxt (fst (split_vars t)) = funas_term t"
	by (induct t) auto


	lemma less_eq_mctxt_prime: "C \<le> D \<longleftrightarrow> less_eq_mctxt' C D"
	proof
	assume "less_eq_mctxt' C D" then show "C \<le> D"
	by (induct C D rule: less_eq_mctxt'.induct) (auto simp: less_eq_mctxt_def intro: nth_equalityI)
	next
	assume "C \<le> D" then show "less_eq_mctxt' C D" unfolding less_eq_mctxt_def
	by (induct C D rule: inf_mctxt.induct)
	(auto split: if_splits simp: set_zip intro!: less_eq_mctxt'.intros nth_equalityI elim!: nth_equalityE, metis)
	qed

	lemmas less_eq_mctxt_induct = less_eq_mctxt'.induct[folded less_eq_mctxt_prime, consumes 1]
	lemmas less_eq_mctxt_intros = less_eq_mctxt'.intros[folded less_eq_mctxt_prime]

	lemma less_eq_mctxt_MHoleE2:
	assumes "C \<le> MHole"
	obtains (MHole) "C = MHole"
	using assms unfolding less_eq_mctxt_prime by (cases C, auto)

	lemma less_eq_mctxt_MVarE2:
	assumes "C \<le> MVar v"
	obtains (MHole) "C = MHole" \| (MVar) "C = MVar v"
	using assms unfolding less_eq_mctxt_prime by (cases C) auto

	lemma less_eq_mctxt_MFunE2:
	assumes "C \<le> MFun f ds"
	obtains (MHole) "C = MHole"
	\| (MFun) cs where "C = MFun f cs" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
	using assms unfolding less_eq_mctxt_prime by (cases C) auto

	lemmas less_eq_mctxtE2 = less_eq_mctxt_MHoleE2 less_eq_mctxt_MVarE2 less_eq_mctxt_MFunE2


	lemma less_eq_mctxt_MVarE1:
	assumes "MVar v \<le> D"
	obtains (MVar) "D = MVar v"
	using assms by (cases D) (auto elim: less_eq_mctxtE2)

	lemma MHole_Bot [simp]: "MHole \<le> D"
	by (simp add: less_eq_mctxt_intros(1))

	lemma less_eq_mctxt_MFunE1:
	assumes "MFun f cs \<le> D"
	obtains (MFun) ds where "D = MFun f ds" "length cs = length ds" "\<And>i. i < length cs \<Longrightarrow> cs ! i \<le> ds ! i"
	using assms by (cases D) (auto elim: less_eq_mctxtE2)


	lemma length_unfill_holes [simp]:
	assumes "C \<le> mctxt_of_term t"
	shows "length (unfill_holes C t) = num_holes C"
	using assms
	proof (induct C t rule: unfill_holes.induct)
	case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
	by (auto simp: less_eq_mctxt_def length_concat
	intro!: cong[of sum_list, OF refl] nth_equalityI elim!: nth_equalityE)
	qed (auto simp: less_eq_mctxt_def)

	lemma map_vars_mctxt_id [simp]:
	"map_vars_mctxt (\<lambda> x. x) C = C"
	by (induct C, auto intro: nth_equalityI)


	lemma split_vars_eqf_subst_map_vars_term:
	"t \<cdot> \<sigma> =\<^sub>f (map_vars_mctxt vw (fst (split_vars t)), map \<sigma> (snd (split_vars t)))"
	proof (induct t)
	case (Fun f ts)
	have "?case = (Fun f (map (\<lambda>t. t \<cdot> \<sigma>) ts)
	=\<^sub>f (MFun f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts), concat (map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts)))"
	by (simp add: map_concat)
	also have "..."
	proof (rule eqf_MFunI, simp, simp, unfold length_map)
	fix i
	assume i: "i < length ts"
	then have mem: "ts ! i \<in> set ts" by auto
	show "map (\<lambda>t. t \<cdot> \<sigma>) ts ! i =\<^sub>f (map (map_vars_mctxt vw \<circ> (fst \<circ> split_vars)) ts ! i, map (map \<sigma> \<circ> (snd \<circ> split_vars)) ts ! i)"
	using Fun[OF mem] i by auto
	qed
	finally show ?case by simp
	qed auto

	lemma split_vars_eqf_subst: "t \<cdot> \<sigma> =\<^sub>f (fst (split_vars t), (map \<sigma> (snd (split_vars t))))"
	using split_vars_eqf_subst_map_vars_term[of t \<sigma> "\<lambda> x. x"] by simp

	lemma split_vars_fill_holes:
	assumes "C = fst (split_vars s)" and "ss = map Var (snd (split_vars s))"
	shows "fill_holes C ss = s" using assms
	by (metis eqfE(1) split_vars_eqf_subst subst_apply_term_empty)


	lemma fill_unfill_holes:
	assumes "C \<le> mctxt_of_term t"
	shows "fill_holes C (unfill_holes C t) = t"
	using assms
	proof (induct C t rule: unfill_holes.induct)
	case (3 f Cs g ts) with 3(1)[OF _ nth_mem] 3(2) show ?case
	by (auto simp: less_eq_mctxt_def intro!: fill_holes_arbitrary elim!: nth_equalityE)
	qed (auto simp: less_eq_mctxt_def split: if_splits)


	lemma hole_poss_list_length:
	"length (hole_poss_list D) = num_holes D"
	by (induct D) (auto simp: length_concat intro!: nth_sum_listI)

	lemma unfill_holles_hole_poss_list_length:
	assumes "C \<le> mctxt_of_term t"
	shows "length (unfill_holes C t) = length (hole_poss_list C)" using assms
	proof (induct C arbitrary: t)
	case (MVar x)
	then have [simp]: "t = Var x" by (cases t) (auto dest: less_eq_mctxt_MVarE1)
	show ?case by simp
	next
	case (MFun f ts) then show ?case
	by (cases t) (auto simp: length_concat comp_def
	elim!: less_eq_mctxt_MFunE1 less_eq_mctxt_MVarE1 intro!: nth_sum_listI)
	qed auto

	lemma unfill_holes_to_subst_at_hole_poss:
	assumes "C \<le> mctxt_of_term t"
	shows "unfill_holes C t = map ((\|_) t) (hole_poss_list C)" using assms
	proof (induct C arbitrary: t)
	case (MVar x)
	then show ?case by (cases t) (auto elim: less_eq_mctxt_MVarE1)
	next
	case (MFun f ts)
	from MFun(2) obtain ss where [simp]: "t = Fun f ss" and l: "length ts = length ss"
	by (cases t) (auto elim: less_eq_mctxt_MFunE1)
	let ?ts = "map (\<lambda>i. unfill_holes (ts ! i) (ss ! i)) [0..<length ts]"
	let ?ss = "map (\<lambda> x. map ((\|_) (Fun f ss)) (case x of (x, y) \<Rightarrow> map ((#) x) (hole_poss_list y))) (zip [0..<length ts] ts)"
	have eq_l [simp]: "length (concat ?ts) = length (concat ?ss)" using MFun
	by (auto simp: length_concat comp_def elim!: less_eq_mctxt_MFunE1 split!: prod.splits intro!: nth_sum_listI)
	{fix i assume ass: "i < length (concat ?ts)"
	then have lss: "i < length (concat ?ss)" by auto
	obtain m n where [simp]: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
	then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass, of ?ss 0] MFun(2)
	by (auto simp: unfill_holles_hole_poss_list_length[of "ts ! i" "ss ! i" for i]
	simp del: length_unfill_holes elim!: less_eq_mctxt_MFunE1)
	from concat_index_split_less_length_concat(2-)[OF ass ] concat_index_split_less_length_concat(2-)[OF lss]
	have "concat ?ts ! i = concat ?ss! i" using MFun(1)[OF nth_mem, of m "ss ! m"] MFun(2)
	by (auto elim!: less_eq_mctxt_MFunE1)} note nth = this
	show ?case using MFun
	by (auto simp: comp_def map_concat length_concat
	elim!: less_eq_mctxt_MFunE1 split!: prod.splits
	intro!: nth_equalityI nth_sum_listI nth)
	qed auto

	lemma hole_poss_split_varposs_list_length [simp]:
	"length (hole_poss_list (fst (split_vars t))) = length (varposs_list t)"
	by (induct t)(auto simp: length_concat comp_def intro!: nth_sum_listI)

	lemma hole_poss_split_vars_varposs_list:
	"hole_poss_list (fst (split_vars t)) = varposs_list t"
	proof (induct t)
	case (Fun f ts)
	let ?ts = "poss_args hole_poss_list (map (fst \<circ> split_vars) ts)"
	let ?ss = "poss_args varposs_list ts"
	have len: "length (concat ?ts) = length (concat ?ss)" "length ?ts = length ?ss"
	"\<forall> i < length ?ts. length (?ts ! i) = length (?ss ! i)" by (auto intro: eq_length_concat_nth)
	{fix i assume ass: "i < length (concat ?ts)"
	then have lss: "i < length (concat ?ss)" using len by auto
	obtain m n where int: "concat_index_split (0, i) ?ts = (m, n)" by fastforce
	then have [simp]: "concat_index_split (0, i) ?ss = (m, n)" using concat_index_split_unique[OF ass len(2-)] by auto
	from concat_index_split_less_length_concat(2-)[OF ass int] concat_index_split_less_length_concat(2-)[OF lss]
	have "concat ?ts ! i = concat ?ss! i" using Fun[OF nth_mem, of m] by auto}
	then show ?case using len by (auto intro: nth_equalityI)
	qed auto



	lemma funas_term_fill_holes_iff: "num_holes C = length ts \<Longrightarrow>
	g \<in> funas_term (fill_holes C ts) \<longleftrightarrow> g \<in> funas_mctxt C \<or> (\<exists>t \<in> set ts. g \<in> funas_term t)"
	proof (induct C ts rule: fill_holes_induct)
	case (MFun f Cs ts)
	have "(\<exists>i < length Cs. g \<in> funas_term (fill_holes (Cs ! i) (partition_holes (concat (partition_holes ts Cs)) Cs ! i)))
	\<longleftrightarrow> (\<exists>C \<in> set Cs. g \<in> funas_mctxt C) \<or> (\<exists>us \<in> set (partition_holes ts Cs). \<exists>t \<in> set us. g \<in> funas_term t)"
	using MFun by (auto simp: ex_set_conv_ex_nth) blast
	then show ?case by auto
	qed auto

	lemma vars_term_fill_holes [simp]:
	"num_holes C = length ts \<Longrightarrow> ground_mctxt C \<Longrightarrow>
	vars_term (fill_holes C ts) = \<Union>(vars_term ` set ts)"
	proof (induct C arbitrary: ts)
	case MHole
	then show ?case by (cases ts) simp_all
	next
	case (MFun f Cs)
	then have *: "length (partition_holes ts Cs) = length Cs" by simp
	let ?f = "\<lambda>x. \<Union>y \<in> set x. vars_term y"
	show ?case
	using MFun
	unfolding partition_holes_fill_holes_conv
	by (simp add: UN_upt_len_conv [OF *, of ?f] UN_set_partition_by)
	qed simp



	lemma funas_mctxt_fill_holes [simp]:
	assumes "num_holes C = length ts"
	shows "funas_term (fill_holes C ts) = funas_mctxt C \<union> \<Union>(set (map funas_term ts))"
	using funas_term_fill_holes_iff[OF assms] by auto

	lemma funas_mctxt_fill_holes_mctxt [simp]:
	assumes "num_holes C = length Ds"
	shows "funas_mctxt (fill_holes_mctxt C Ds) = funas_mctxt C \<union> \<Union>(set (map funas_mctxt Ds))"
	(is "?f C Ds = ?g C Ds")
	using assms
	proof (induct C arbitrary: Ds)
	case MHole
	then show ?case by (cases Ds) simp_all
	next
	case (MFun f Cs)
	then have num_holes: "sum_list (map num_holes Cs) = length Ds" by simp
	let ?ys = "partition_holes Ds Cs"
	have "\<And>i. i < length Cs \<Longrightarrow> ?f (Cs ! i) (?ys ! i) = ?g (Cs ! i) (?ys ! i)"
	using MFun by (metis nth_mem num_holes.simps(3) length_partition_holes_nth)
	then have "(\<Union>i \<in> {0 ..< length Cs}. ?f (Cs ! i) (?ys ! i)) =
	(\<Union>i \<in> {0 ..< length Cs}. ?g (Cs ! i) (?ys ! i))" by simp
	then show ?case
	using num_holes
	unfolding partition_holes_fill_holes_mctxt_conv
	by (simp add: UN_Un_distrib UN_upt_len_conv [of _ _ "\<lambda>x. \<Union>(set x)"] UN_set_partition_by_map)
	qed simp

	end
	diff --git a/thys/Flow_Networks/Residual_Graph.thy b/thys/Flow_Networks/Residual_Graph.thy
	--- a/thys/Flow_Networks/Residual_Graph.thy
	+++ b/thys/Flow_Networks/Residual_Graph.thy
	@@ -1,368 +1,368 @@
	section \<open>Residual Graph\<close>
	theory Residual_Graph
	imports Network
	begin
	text \<open>
	In this theory, we define the residual graph.
	\<close>

	subsection \<open>Definition\<close>
	text \<open>The \<^emph>\<open>residual graph\<close> of a network and a flow indicates how much
	flow can be effectively pushed along or reverse to a network edge,
	by increasing or decreasing the flow on that edge:\<close>
	definition residualGraph :: "_ graph \<Rightarrow> _ flow \<Rightarrow> _ graph"
	where "residualGraph c f \<equiv> \<lambda>(u, v).
	if (u, v) \<in> Graph.E c then
	c (u, v) - f (u, v)
	else if (v, u) \<in> Graph.E c then
	f (v, u)
	else
	0"

	context Network begin

	abbreviation "cf_of \<equiv> residualGraph c"
	abbreviation "cfE_of f \<equiv> Graph.E (cf_of f)"

	text \<open>The edges of the residual graph are either parallel or reverse
	to the edges of the network.\<close>
	lemma cfE_of_ss_invE: "cfE_of cf \<subseteq> E \<union> E\<inverse>"
	unfolding residualGraph_def Graph.E_def
	by auto

	lemma cfE_of_ss_VxV: "cfE_of f \<subseteq> V\<times>V"
	unfolding V_def
	unfolding residualGraph_def Graph.E_def
	by auto

	lemma cfE_of_finite[simp, intro!]: "finite (cfE_of f)"
	using finite_subset[OF cfE_of_ss_VxV] by auto

	lemma cf_no_self_loop: "(u,u)\<notin>cfE_of f"
	proof
	assume a1: "(u, u) \<in> cfE_of f"
	have "(u, u) \<notin> E"
	using no_parallel_edge by blast
	then show False
	using a1 unfolding Graph.E_def residualGraph_def by fastforce
	qed

	end



	text \<open>Let's fix a network with a preflow @{term f} on it\<close>
	context NPreflow
	begin
	text \<open>We abbreviate the residual graph by @{term cf}.\<close>
	abbreviation "cf \<equiv> residualGraph c f"
	sublocale cf: Graph cf .
	lemmas cf_def = residualGraph_def[of c f]

	subsection \<open>Properties\<close>

	lemmas cfE_ss_invE = cfE_of_ss_invE[of f]
	(*lemma cfE_ss_invE: "Graph.E cf \<subseteq> E \<union> E\<inverse>"
	unfolding residualGraph_def Graph.E_def
	by auto*)

	text \<open>The nodes of the residual graph are exactly the nodes of the network.\<close>
	lemma resV_netV[simp]: "cf.V = V"
	proof
	show "V \<subseteq> Graph.V cf"
	proof
	fix u
	assume "u \<in> V"
	then obtain v where "(u, v) \<in> E \<or> (v, u) \<in> E" unfolding V_def by auto
	(* TODO: Use nifty new Isabelle2016 case-distinction features here! *)
	moreover {
	assume "(u, v) \<in> E"
	then have "(u, v) \<in> Graph.E cf \<or> (v, u) \<in> Graph.E cf"
	proof (cases)
	assume "f (u, v) = 0"
	then have "cf (u, v) = c (u, v)"
	unfolding residualGraph_def using \<open>(u, v) \<in> E\<close> by (auto simp:)
	then have "cf (u, v) \<noteq> 0" using \<open>(u, v) \<in> E\<close> unfolding E_def by auto
	thus ?thesis unfolding Graph.E_def by auto
	next
	assume "f (u, v) \<noteq> 0"
	then have "cf (v, u) = f (u, v)" unfolding residualGraph_def
	using \<open>(u, v) \<in> E\<close> no_parallel_edge by auto
	then have "cf (v, u) \<noteq> 0" using \<open>f (u, v) \<noteq> 0\<close> by auto
	thus ?thesis unfolding Graph.E_def by auto
	qed
	} moreover {
	assume "(v, u) \<in> E"
	then have "(v, u) \<in> Graph.E cf \<or> (u, v) \<in> Graph.E cf"
	proof (cases)
	assume "f (v, u) = 0"
	then have "cf (v, u) = c (v, u)"
	unfolding residualGraph_def using \<open>(v, u) \<in> E\<close> by (auto)
	then have "cf (v, u) \<noteq> 0" using \<open>(v, u) \<in> E\<close> unfolding E_def by auto
	thus ?thesis unfolding Graph.E_def by auto
	next
	assume "f (v, u) \<noteq> 0"
	then have "cf (u, v) = f (v, u)" unfolding residualGraph_def
	using \<open>(v, u) \<in> E\<close> no_parallel_edge by auto
	then have "cf (u, v) \<noteq> 0" using \<open>f (v, u) \<noteq> 0\<close> by auto
	thus ?thesis unfolding Graph.E_def by auto
	qed
	} ultimately show "u\<in>cf.V" unfolding cf.V_def by auto
	qed
	next
	show "Graph.V cf \<subseteq> V" using cfE_ss_invE unfolding Graph.V_def by auto
	qed

	text \<open>Note, that Isabelle is powerful enough to prove the above case
	distinctions completely automatically, although it takes some time:\<close>
	lemma "cf.V = V"
	unfolding residualGraph_def Graph.E_def Graph.V_def
	using no_parallel_edge[unfolded E_def]
	by auto

	text \<open>As the residual graph has the same nodes as the network, it is also finite:\<close>
	sublocale cf: Finite_Graph cf
	by unfold_locales auto

	text \<open>The capacities on the edges of the residual graph are non-negative\<close>
	lemma resE_nonNegative: "cf e \<ge> 0"
	proof (cases e; simp)
	fix u v
	{
	assume "(u, v) \<in> E"
	then have "cf (u, v) = c (u, v) - f (u, v)" unfolding cf_def by auto
	hence "cf (u,v) \<ge> 0"
	using capacity_const cap_non_negative by auto
	} moreover {
	assume "(v, u) \<in> E"
	then have "cf (u,v) = f (v, u)"
	using no_parallel_edge unfolding cf_def by auto
	hence "cf (u,v) \<ge> 0"
	using capacity_const by auto
	} moreover {
	assume "(u, v) \<notin> E" "(v, u) \<notin> E"
	hence "cf (u,v) \<ge> 0" unfolding residualGraph_def by simp
	} ultimately show "cf (u,v) \<ge> 0" by blast
	qed

	text \<open>Again, there is an automatic proof\<close>
	lemma "cf e \<ge> 0"
	apply (cases e)
	unfolding residualGraph_def
	using no_parallel_edge capacity_const cap_positive
	by auto

	text \<open>All edges of the residual graph are labeled with positive capacities:\<close>
	corollary resE_positive: "e \<in> cf.E \<Longrightarrow> cf e > 0"
	proof -
	assume "e \<in> cf.E"
	hence "cf e \<noteq> 0" unfolding cf.E_def by auto
	thus ?thesis using resE_nonNegative by (meson eq_iff not_le)
	qed

	(* TODO: Only one usage: Move or remove! *)
	lemma reverse_flow: "Preflow cf s t f' \<Longrightarrow> \<forall>(u, v) \<in> E. f' (v, u) \<le> f (u, v)"
	proof -
	assume asm: "Preflow cf s t f'"
	then interpret f': Preflow cf s t f' .

	{
	fix u v
	assume "(u, v) \<in> E"

	then have "cf (v, u) = f (u, v)"
	unfolding residualGraph_def using no_parallel_edge by auto
	moreover have "f' (v, u) \<le> cf (v, u)" using f'.capacity_const by auto
	ultimately have "f' (v, u) \<le> f (u, v)" by metis
	}
	thus ?thesis by auto
	qed


	definition (in Network) "flow_of_cf cf e \<equiv> (if (e\<in>E) then c e - cf e else 0)"

	(* TODO: We have proved/used this fact already for Edka-Analysis! (uE) *)
	lemma (in NPreflow) E_ss_cfinvE: "E \<subseteq> Graph.E cf \<union> (Graph.E cf)\<inverse>"
	unfolding residualGraph_def Graph.E_def
	apply (clarsimp)
	using no_parallel_edge (* Speed optimization: Adding this directly takes very long *)
	unfolding E_def
	- apply (simp add: )
	+ apply simp
	done


	text \<open>Nodes with positive excess must have an outgoing edge in the
	residual graph.

	Intuitively: The excess flow must come from somewhere.\<close>
	lemma active_has_cf_outgoing: "excess f u > 0 \<Longrightarrow> cf.outgoing u \<noteq> {}"
	unfolding excess_def
	proof -
	assume "0 < sum f (incoming u) - sum f (outgoing u)"
	hence "0 < sum f (incoming u)"
	by (metis diff_gt_0_iff_gt linorder_neqE_linordered_idom linorder_not_le
	sum_f_non_negative)
	with f_non_negative obtain e where "e\<in>incoming u" "f e > 0"
	by (meson not_le sum_nonpos)
	then obtain v where "(v,u)\<in>E" "f (v,u) > 0" unfolding incoming_def by auto
	hence "cf (u,v) > 0" unfolding residualGraph_def by auto
	thus ?thesis unfolding cf.outgoing_def cf.E_def by fastforce
	qed



	end \<comment> \<open>Network with preflow\<close>


	locale RPreGraph \<comment> \<open>Locale that characterizes a residual graph of a network\<close>
	= Network +
	fixes cf
	assumes EX_RPG: "\<exists>f. NPreflow c s t f \<and> cf = residualGraph c f"
	begin

	lemma this_loc_rpg: "RPreGraph c s t cf"
	by unfold_locales

	definition "f \<equiv> flow_of_cf cf"

	lemma f_unique:
	assumes "NPreflow c s t f'"
	assumes A: "cf = residualGraph c f'"
	shows "f' = f"
	proof -
	interpret f': NPreflow c s t f' by fact

	show ?thesis
	unfolding f_def[abs_def] flow_of_cf_def[abs_def]
	unfolding A residualGraph_def
	apply (rule ext)
	using f'.capacity_const unfolding E_def
	apply (auto split: prod.split)
	by (metis antisym)
	qed

	lemma is_NPreflow: "NPreflow c s t (flow_of_cf cf)"
	apply (fold f_def)
	using EX_RPG f_unique by metis

	sublocale f: NPreflow c s t f unfolding f_def by (rule is_NPreflow)

	lemma rg_is_cf[simp]: "residualGraph c f = cf"
	using EX_RPG f_unique by auto

	lemma rg_fo_inv[simp]: "residualGraph c (flow_of_cf cf) = cf"
	using rg_is_cf
	unfolding f_def
	.


	sublocale cf: Graph cf .

	lemma resV_netV[simp]: "cf.V = V"
	using f.resV_netV by simp

	sublocale cf: Finite_Graph cf
	apply unfold_locales
	apply simp
	done

	lemma E_ss_cfinvE: "E \<subseteq> cf.E \<union> cf.E\<inverse>"
	using f.E_ss_cfinvE by simp

	lemma cfE_ss_invE: "cf.E \<subseteq> E \<union> E\<inverse>"
	using f.cfE_ss_invE by simp

	lemma resE_nonNegative: "cf e \<ge> 0"
	using f.resE_nonNegative by auto

	end

	context NPreflow begin
	lemma is_RPreGraph: "RPreGraph c s t cf"
	apply unfold_locales
	apply (rule exI[where x=f])
	apply (safe; unfold_locales)
	done

	lemma fo_rg_inv: "flow_of_cf cf = f"
	unfolding flow_of_cf_def[abs_def]
	unfolding residualGraph_def
	apply (rule ext)
	using capacity_const unfolding E_def
	apply (clarsimp split: prod.split)
	by (metis antisym)

	end

	(* For snippet*)
	lemma (in NPreflow)
	"flow_of_cf (residualGraph c f) = f"
	by (rule fo_rg_inv)


	locale RGraph \<comment> \<open>Locale that characterizes a residual graph of a network\<close>
	= Network +
	fixes cf
	assumes EX_RG: "\<exists>f. NFlow c s t f \<and> cf = residualGraph c f"
	begin
	sublocale RPreGraph
	proof
	from EX_RG obtain f where
	"NFlow c s t f" and [simp]: "cf = residualGraph c f" by auto
	then interpret NFlow c s t f by simp

	show "\<exists>f. NPreflow c s t f \<and> cf = residualGraph c f"
	apply (rule exI[where x="f"])
	apply simp
	by unfold_locales
	qed

	lemma this_loc: "RGraph c s t cf"
	by unfold_locales
	lemma this_loc_rpg: "RPreGraph c s t cf"
	by unfold_locales

	lemma is_NFlow: "NFlow c s t (flow_of_cf cf)"
	using EX_RG f_unique is_NPreflow NFlow.axioms(1)
	apply (fold f_def) by force

	sublocale f: NFlow c s t f unfolding f_def by (rule is_NFlow)
	end

	context NFlow begin

	lemma is_RGraph: "RGraph c s t cf"
	apply unfold_locales
	apply (rule exI[where x=f])
	apply (safe; unfold_locales)
	done

	text \<open>The value of the flow can be computed from the residual graph.\<close>
	lemma val_by_cf: "val = (\<Sum>(u,v)\<in>outgoing s. cf (v,u))"
	proof -
	have "f (s,v) = cf (v,s)" for v
	unfolding cf_def by auto
	thus ?thesis
	unfolding val_alt outgoing_def
	by (auto intro!: sum.cong)
	qed

	end \<comment> \<open>Network with Flow\<close>

	lemma (in RPreGraph) maxflow_imp_rgraph:
	assumes "isMaxFlow (flow_of_cf cf)"
	shows "RGraph c s t cf"
	proof -
	from assms interpret Flow c s t f
	unfolding isMaxFlow_def by (simp add: f_def)

	interpret NFlow c s t f by unfold_locales

	show ?thesis
	apply unfold_locales
	apply (rule exI[of _ f])
	apply (simp add: NFlow_axioms)
	done
	qed

	end \<comment> \<open>Theory\<close>
	diff --git a/thys/Goedel_HFSet_Semanticless/Sigma.thy b/thys/Goedel_HFSet_Semanticless/Sigma.thy
	--- a/thys/Goedel_HFSet_Semanticless/Sigma.thy
	+++ b/thys/Goedel_HFSet_Semanticless/Sigma.thy
	@@ -1,424 +1,424 @@
	chapter \<open>Sigma-Formulas and Theorem 2.5\<close>

	theory Sigma
	imports Predicates
	begin

	section\<open>Ground Terms and Formulas\<close>

	definition ground_aux :: "tm \<Rightarrow> atom set \<Rightarrow> bool"
	where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

	abbreviation ground :: "tm \<Rightarrow> bool"
	where "ground t \<equiv> ground_aux t {}"

	definition ground_fm_aux :: "fm \<Rightarrow> atom set \<Rightarrow> bool"
	where "ground_fm_aux A S \<equiv> (supp A \<subseteq> S)"

	abbreviation ground_fm :: "fm \<Rightarrow> bool"
	where "ground_fm A \<equiv> ground_fm_aux A {}"

	lemma ground_aux_simps[simp]:
	"ground_aux Zero S = True"
	"ground_aux (Var k) S = (if atom k \<in> S then True else False)"
	"ground_aux (Eats t u) S = (ground_aux t S \<and> ground_aux u S)"
	unfolding ground_aux_def
	by (simp_all add: supp_at_base)

	lemma ground_fm_aux_simps[simp]:
	"ground_fm_aux Fls S = True"
	"ground_fm_aux (t IN u) S = (ground_aux t S \<and> ground_aux u S)"
	"ground_fm_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
	"ground_fm_aux (A OR B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (A AND B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (A IFF B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (Neg A) S = (ground_fm_aux A S)"
	"ground_fm_aux (Ex x A) S = (ground_fm_aux A (S \<union> {atom x}))"
	by (auto simp: ground_fm_aux_def ground_aux_def supp_conv_fresh)

	lemma ground_fresh[simp]:
	"ground t \<Longrightarrow> atom i \<sharp> t"
	"ground_fm A \<Longrightarrow> atom i \<sharp> A"
	unfolding ground_aux_def ground_fm_aux_def fresh_def
	by simp_all


	section\<open>Sigma Formulas\<close>

	text\<open>Section 2 material\<close>

	subsection \<open>Strict Sigma Formulas\<close>

	text\<open>Definition 2.1\<close>
	inductive ss_fm :: "fm \<Rightarrow> bool" where
	MemI: "ss_fm (Var i IN Var j)"
	\| DisjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A OR B)"
	\| ConjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A AND B)"
	\| ExI: "ss_fm A \<Longrightarrow> ss_fm (Ex i A)"
	\| All2I: "ss_fm A \<Longrightarrow> atom j \<sharp> (i,A) \<Longrightarrow> ss_fm (All2 i (Var j) A)"

	equivariance ss_fm

	nominal_inductive ss_fm
	avoids ExI: "i" \| All2I: "i"
	by (simp_all add: fresh_star_def)

	declare ss_fm.intros [intro]


	definition Sigma_fm :: "fm \<Rightarrow> bool"
	where "Sigma_fm A \<longleftrightarrow> (\<exists>B. ss_fm B \<and> supp B \<subseteq> supp A \<and> {} \<turnstile> A IFF B)"

	lemma Sigma_fm_Iff: "\<lbrakk>{} \<turnstile> B IFF A; supp A \<subseteq> supp B; Sigma_fm A\<rbrakk> \<Longrightarrow> Sigma_fm B"
	by (metis Sigma_fm_def Iff_trans order_trans)

	lemma ss_fm_imp_Sigma_fm [intro]: "ss_fm A \<Longrightarrow> Sigma_fm A"
	by (metis Iff_refl Sigma_fm_def order_refl)

	lemma Sigma_fm_Fls [iff]: "Sigma_fm Fls"
	by (rule Sigma_fm_Iff [of _ "Ex i (Var i IN Var i)"]) auto

	subsection\<open>Closure properties for Sigma-formulas\<close>

	lemma
	assumes "Sigma_fm A" "Sigma_fm B"
	shows Sigma_fm_AND [intro!]: "Sigma_fm (A AND B)"
	and Sigma_fm_OR [intro!]: "Sigma_fm (A OR B)"
	and Sigma_fm_Ex [intro!]: "Sigma_fm (Ex i A)"
	proof -
	obtain SA SB where "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
	and "ss_fm SB" "{} \<turnstile> B IFF SB" "supp SB \<subseteq> supp B"
	using assms by (auto simp add: Sigma_fm_def)
	then show "Sigma_fm (A AND B)" "Sigma_fm (A OR B)" "Sigma_fm (Ex i A)"
	apply (auto simp: Sigma_fm_def)
	apply (metis ss_fm.ConjI Conj_cong Un_mono supp_Conj)
	apply (metis ss_fm.DisjI Disj_cong Un_mono fm.supp(3))
	apply (rule exI [where x = "Ex i SA"])
	apply (auto intro!: Ex_cong)
	done
	qed

	lemma Sigma_fm_All2_Var:
	assumes H0: "Sigma_fm A" and ij: "atom j \<sharp> (i,A)"
	shows "Sigma_fm (All2 i (Var j) A)"
	proof -
	obtain SA where SA: "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
	using H0 by (auto simp add: Sigma_fm_def)
	show "Sigma_fm (All2 i (Var j) A)"
	apply (rule Sigma_fm_Iff [of _ "All2 i (Var j) SA"])
	apply (metis All2_cong Refl SA(2) emptyE)
	using SA ij
	apply (auto simp: supp_conv_fresh subset_iff)
	apply (metis ss_fm.All2I fresh_Pair ss_fm_imp_Sigma_fm)
	done
	qed


	section\<open>Lemma 2.2: Atomic formulas are Sigma-formulas\<close>

	lemma Eq_Eats_Iff:
	assumes [unfolded fresh_Pair, simp]: "atom i \<sharp> (z,x,y)"
	shows "{} \<turnstile> z EQ Eats x y IFF (All2 i z (Var i IN x OR Var i EQ y)) AND x SUBS z AND y IN z"
	proof (rule Iff_I, auto)
	have "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN Eats x y"
	by (metis Assume Iff_MP_left Iff_sym Mem_cong Refl)
	then show "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN x OR Var i EQ y"
	by (metis Iff_MP_same Mem_Eats_Iff)
	next
	show "{z EQ Eats x y} \<turnstile> x SUBS z"
	by (metis Iff_MP2_same Subset_cong [OF Refl Assume] Subset_Eats_I)
	next
	show "{z EQ Eats x y} \<turnstile> y IN z"
	by (metis Iff_MP2_same Mem_cong Assume Refl Mem_Eats_I2)
	next
	show "{x SUBS z, y IN z, All2 i z (Var i IN x OR Var i EQ y)} \<turnstile> z EQ Eats x y"
	(is "{_, _, ?allHyp} \<turnstile> _")
	apply (rule Eq_Eats_iff [OF assms, THEN Iff_MP2_same], auto)
	apply (rule Ex_I [where x="Var i"])
	apply (auto intro: Subset_D Mem_cong [OF Assume Refl, THEN Iff_MP2_same])
	done
	qed

	lemma Subset_Zero_sf: "Sigma_fm (Var i SUBS Zero)"
	proof -
	obtain j::name where j: "atom j \<sharp> i"
	by (rule obtain_fresh)
	hence Subset_Zero_Iff: "{} \<turnstile> Var i SUBS Zero IFF (All2 j (Var i) Fls)"
	by (auto intro!: Subset_I [of j] intro: Eq_Zero_D Subset_Zero_D All2_E [THEN rotate2])
	thus ?thesis using j
	by (auto simp: supp_conv_fresh
	intro!: Sigma_fm_Iff [OF Subset_Zero_Iff] Sigma_fm_All2_Var)
	qed

	lemma Eq_Zero_sf: "Sigma_fm (Var i EQ Zero)"
	proof -
	obtain j::name where "atom j \<sharp> i"
	by (rule obtain_fresh)
	thus ?thesis
	by (auto simp add: supp_conv_fresh
	intro!: Sigma_fm_Iff [OF _ _ Subset_Zero_sf] Subset_Zero_D EQ_imp_SUBS)
	qed

	lemma theorem_sf: assumes "{} \<turnstile> A" shows "Sigma_fm A"
	proof -
	obtain i::name and j::name
	where ij: "atom i \<sharp> (j,A)" "atom j \<sharp> A"
	by (metis obtain_fresh)
	show ?thesis
	apply (rule Sigma_fm_Iff [where A = "Ex i (Ex j (Var i IN Var j))"])
	using ij
	- apply (auto simp: )
	+ apply auto
	apply (rule Ex_I [where x=Zero], simp)
	apply (rule Ex_I [where x="Eats Zero Zero"])
	apply (auto intro: Mem_Eats_I2 assms thin0)
	done
	qed

	text \<open>The subset relation\<close>
	lemma Var_Subset_sf: "Sigma_fm (Var i SUBS Var j)"
	proof -
	obtain k::name where k: "atom (k::name) \<sharp> (i,j)"
	by (metis obtain_fresh)
	thus ?thesis
	proof (cases "i=j")
	case True thus ?thesis using k
	by (auto intro!: theorem_sf Subset_I [where i=k])
	next
	case False thus ?thesis using k
	by (auto simp: ss_fm_imp_Sigma_fm Subset.simps [of k] ss_fm.intros)
	qed
	qed

	lemma Zero_Mem_sf: "Sigma_fm (Zero IN Var i)"
	proof -
	obtain j::name where "atom j \<sharp> i"
	by (rule obtain_fresh)
	hence Zero_Mem_Iff: "{} \<turnstile> Zero IN Var i IFF (Ex j (Var j EQ Zero AND Var j IN Var i))"
	by (auto intro: Ex_I [where x = Zero] Mem_cong [OF Assume Refl, THEN Iff_MP_same])
	show ?thesis
	by (auto intro!: Sigma_fm_Iff [OF Zero_Mem_Iff] Eq_Zero_sf)
	qed

	lemma ijk: "i + k < Suc (i + j + k)"
	by arith

	lemma All2_term_Iff_fresh: "i\<noteq>j \<Longrightarrow> atom j' \<sharp> (i,j,A) \<Longrightarrow>
	{} \<turnstile> (All2 i (Var j) A) IFF Ex j' (Var j EQ Var j' AND All2 i (Var j') A)"
	apply auto
	apply (rule Ex_I [where x="Var j"], auto)
	apply (rule Ex_I [where x="Var i"], auto intro: ContraProve Mem_cong [THEN Iff_MP_same])
	done

	lemma Sigma_fm_All2_fresh:
	assumes "Sigma_fm A" "i\<noteq>j"
	shows "Sigma_fm (All2 i (Var j) A)"
	proof -
	obtain j'::name where j': "atom j' \<sharp> (i,j,A)"
	by (metis obtain_fresh)
	show "Sigma_fm (All2 i (Var j) A)"
	apply (rule Sigma_fm_Iff [OF All2_term_Iff_fresh [OF _ j']])
	using assms j'
	apply (auto simp: supp_conv_fresh Var_Subset_sf
	intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
	done
	qed

	lemma Subset_Eats_sf:
	assumes "\<And>j::name. Sigma_fm (Var j IN t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Var i SUBS Eats t u)"
	proof -
	obtain k::name where k: "atom k \<sharp> (t,u,Var i)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Var i SUBS Eats t u IFF All2 k (Var i) (Var k IN t OR Var k EQ u)"
	apply (auto simp: fresh_Pair intro: Set_MP Disj_I1 Disj_I2)
	apply (force intro!: Subset_I [where i=k] intro: All2_E' [OF Hyp] Mem_Eats_I1 Mem_Eats_I2)
	done
	thus ?thesis
	apply (rule Sigma_fm_Iff)
	using k
	apply (auto intro!: Sigma_fm_All2_fresh simp add: assms fresh_Pair supp_conv_fresh fresh_at_base)
	done
	qed

	lemma Eq_Eats_sf:
	assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Var i EQ Eats t u)"
	proof -
	obtain j::name and k::name and l::name
	where atoms: "atom j \<sharp> (t,u,i)" "atom k \<sharp> (t,u,i,j)" "atom l \<sharp> (t,u,i,j,k)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Var i EQ Eats t u IFF
	Ex j (Ex k (Var i EQ Eats (Var j) (Var k) AND Var j EQ t AND Var k EQ u))"
	apply auto
	apply (rule Ex_I [where x=t], simp)
	apply (rule Ex_I [where x=u], auto intro: Trans Eats_cong)
	done
	thus ?thesis
	apply (rule Sigma_fm_Iff)
	apply (auto simp: assms supp_at_base)
	apply (rule Sigma_fm_Iff [OF Eq_Eats_Iff [of l]])
	using atoms
	apply (auto simp: supp_conv_fresh fresh_at_base Var_Subset_sf
	intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
	done
	qed

	lemma Eats_Mem_sf:
	assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Eats t u IN Var i)"
	proof -
	obtain j::name where j: "atom j \<sharp> (t,u,Var i)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Eats t u IN Var i IFF
	Ex j (Var j IN Var i AND Var j EQ Eats t u)"
	apply (auto simp: fresh_Pair intro: Ex_I [where x="Eats t u"])
	apply (metis Assume Mem_cong [OF _ Refl, THEN Iff_MP_same] rotate2)
	done
	thus ?thesis
	by (rule Sigma_fm_Iff) (auto simp: assms supp_conv_fresh Eq_Eats_sf)
	qed

	lemma Subset_Mem_sf_lemma:
	"size t + size u < n \<Longrightarrow> Sigma_fm (t SUBS u) \<and> Sigma_fm (t IN u)"
	proof (induction n arbitrary: t u rule: less_induct)
	case (less n t u)
	show ?case
	proof
	show "Sigma_fm (t SUBS u)"
	proof (cases t rule: tm.exhaust)
	case Zero thus ?thesis
	by (auto intro: theorem_sf)
	next
	case (Var i) thus ?thesis using less.prems
	apply (cases u rule: tm.exhaust)
	apply (auto simp: Subset_Zero_sf Var_Subset_sf)
	apply (force simp: supp_conv_fresh less.IH
	intro: Subset_Eats_sf Sigma_fm_Iff [OF Extensionality])
	done
	next
	case (Eats t1 t2) thus ?thesis using less.IH [OF _ ijk] less.prems
	by (auto intro!: Sigma_fm_Iff [OF Eats_Subset_Iff] simp: supp_conv_fresh)
	(metis add.commute)
	qed
	next
	show "Sigma_fm (t IN u)"
	proof (cases u rule: tm.exhaust)
	case Zero show ?thesis
	by (rule Sigma_fm_Iff [where A=Fls]) (auto simp: supp_conv_fresh Zero)
	next
	case (Var i) show ?thesis
	proof (cases t rule: tm.exhaust)
	case Zero thus ?thesis using \<open>u = Var i\<close>
	by (auto intro: Zero_Mem_sf)
	next
	case (Var j)
	thus ?thesis using \<open>u = Var i\<close>
	by auto
	next
	case (Eats t1 t2) thus ?thesis using \<open>u = Var i\<close> less.prems
	by (force intro: Eats_Mem_sf Sigma_fm_Iff [OF Extensionality _ _]
	simp: supp_conv_fresh less.IH [THEN conjunct1])
	qed
	next
	case (Eats t1 t2) thus ?thesis using less.prems
	by (force intro: Sigma_fm_Iff [OF Mem_Eats_Iff] Sigma_fm_Iff [OF Extensionality _ _]
	simp: supp_conv_fresh less.IH)
	qed
	qed
	qed

	lemma Subset_sf [iff]: "Sigma_fm (t SUBS u)"
	by (metis Subset_Mem_sf_lemma [OF lessI])

	lemma Mem_sf [iff]: "Sigma_fm (t IN u)"
	by (metis Subset_Mem_sf_lemma [OF lessI])

	text \<open>The equality relation is a Sigma-Formula\<close>
	lemma Equality_sf [iff]: "Sigma_fm (t EQ u)"
	by (auto intro: Sigma_fm_Iff [OF Extensionality] simp: supp_conv_fresh)


	section\<open>Universal Quantification Bounded by an Arbitrary Term\<close>

	lemma All2_term_Iff: "atom i \<sharp> t \<Longrightarrow> atom j \<sharp> (i,t,A) \<Longrightarrow>
	{} \<turnstile> (All2 i t A) IFF Ex j (Var j EQ t AND All2 i (Var j) A)"
	apply auto
	apply (rule Ex_I [where x=t], auto)
	apply (rule Ex_I [where x="Var i"])
	apply (auto intro: ContraProve Mem_cong [THEN Iff_MP2_same])
	done

	lemma Sigma_fm_All2 [intro!]:
	assumes "Sigma_fm A" "atom i \<sharp> t"
	shows "Sigma_fm (All2 i t A)"
	proof -
	obtain j::name where j: "atom j \<sharp> (i,t,A)"
	by (metis obtain_fresh)
	show "Sigma_fm (All2 i t A)"
	apply (rule Sigma_fm_Iff [OF All2_term_Iff [of i t j]])
	using assms j
	apply (auto simp: supp_conv_fresh Sigma_fm_All2_Var)
	done
	qed


	section \<open>Lemma 2.3: Sequence-related concepts are Sigma-formulas\<close>

	lemma OrdP_sf [iff]: "Sigma_fm (OrdP t)"
	proof -
	obtain z::name and y::name where "atom z \<sharp> t" "atom y \<sharp> (t, z)"
	by (metis obtain_fresh)
	thus ?thesis
	by (auto simp: OrdP.simps)
	qed

	lemma OrdNotEqP_sf [iff]: "Sigma_fm (OrdNotEqP t u)"
	by (auto simp: OrdNotEqP.simps)

	lemma HDomain_Incl_sf [iff]: "Sigma_fm (HDomain_Incl t u)"
	proof -
	obtain x::name and y::name and z::name
	where "atom x \<sharp> (t,u,y,z)" "atom y \<sharp> (t,u,z)" "atom z \<sharp> (t,u)"
	by (metis obtain_fresh)
	thus ?thesis
	by auto
	qed

	lemma HFun_Sigma_Iff:
	assumes "atom z \<sharp> (r,z',x,y,x',y')" "atom z' \<sharp> (r,x,y,x',y')"
	"atom x \<sharp> (r,y,x',y')" "atom y \<sharp> (r,x',y')"
	"atom x' \<sharp> (r,y')" "atom y' \<sharp> (r)"
	shows
	"{} \<turnstile>HFun_Sigma r IFF
	All2 z r (All2 z' r (Ex x (Ex y (Ex x' (Ex y'
	(Var z EQ HPair (Var x) (Var y) AND Var z' EQ HPair (Var x') (Var y')
	AND OrdP (Var x) AND OrdP (Var x') AND
	((Var x NEQ Var x') OR (Var y EQ Var y'))))))))"
	apply (simp add: HFun_Sigma.simps [OF assms])
	apply (rule Iff_refl All_cong Imp_cong Ex_cong)+
	apply (rule Conj_cong [OF Iff_refl])
	apply (rule Conj_cong [OF Iff_refl], auto)
	apply (blast intro: Disj_I1 Neg_D OrdNotEqP_I)
	apply (blast intro: Disj_I2)
	apply (blast intro: OrdNotEqP_E rotate2)
	done

	lemma HFun_Sigma_sf [iff]: "Sigma_fm (HFun_Sigma t)"
	proof -
	obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
	where atoms: "atom z \<sharp> (t,z',x,y,x',y')" "atom z' \<sharp> (t,x,y,x',y')"
	"atom x \<sharp> (t,y,x',y')" "atom y \<sharp> (t,x',y')"
	"atom x' \<sharp> (t,y')" "atom y' \<sharp> (t)"
	by (metis obtain_fresh)
	show ?thesis
	by (auto intro!: Sigma_fm_Iff [OF HFun_Sigma_Iff [OF atoms]] simp: supp_conv_fresh atoms)
	qed

	lemma LstSeqP_sf [iff]: "Sigma_fm (LstSeqP t u v)"
	by (auto simp: LstSeqP.simps)

	end

	diff --git a/thys/Graph_Theory/Digraph_Isomorphism.thy b/thys/Graph_Theory/Digraph_Isomorphism.thy
	--- a/thys/Graph_Theory/Digraph_Isomorphism.thy
	+++ b/thys/Graph_Theory/Digraph_Isomorphism.thy
	@@ -1,561 +1,561 @@
	theory Digraph_Isomorphism imports
	Arc_Walk
	Digraph
	Digraph_Component
	begin

	section \<open>Isomorphisms of Digraphs\<close>

	record ('a,'b,'aa,'bb) digraph_isomorphism =
	iso_verts :: "'a \<Rightarrow> 'aa"
	iso_arcs :: "'b \<Rightarrow> 'bb"
	iso_head :: "'bb \<Rightarrow> 'aa"
	iso_tail :: "'bb \<Rightarrow> 'aa"

	definition (in pre_digraph) digraph_isomorphism :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> bool" where
	"digraph_isomorphism hom \<equiv>
	wf_digraph G \<and>
	inj_on (iso_verts hom) (verts G) \<and>
	inj_on (iso_arcs hom) (arcs G) \<and>
	(\<forall>a \<in> arcs G.
	iso_verts hom (tail G a) = iso_tail hom (iso_arcs hom a) \<and>
	iso_verts hom (head G a) = iso_head hom (iso_arcs hom a))"

	definition (in pre_digraph) inv_iso :: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('aa,'bb,'a,'b) digraph_isomorphism" where
	"inv_iso hom \<equiv> \<lparr>
	iso_verts = the_inv_into (verts G) (iso_verts hom),
	iso_arcs = the_inv_into (arcs G) (iso_arcs hom),
	iso_head = head G,
	iso_tail = tail G
	\<rparr>"

	definition app_iso
	:: "('a,'b,'aa,'bb) digraph_isomorphism \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> ('aa,'bb) pre_digraph" where
	"app_iso hom G \<equiv> \<lparr> verts = iso_verts hom ` verts G, arcs = iso_arcs hom ` arcs G,
	tail = iso_tail hom, head = iso_head hom \<rparr>"

	definition digraph_iso :: "('a,'b) pre_digraph \<Rightarrow> ('c,'d) pre_digraph \<Rightarrow> bool" where
	"digraph_iso G H \<equiv> \<exists>f. pre_digraph.digraph_isomorphism G f \<and> H = app_iso f G"

	lemma verts_app_iso: "verts (app_iso hom G) = iso_verts hom ` verts G"
	and arcs_app_iso: "arcs (app_iso hom G) = iso_arcs hom `arcs G"
	and tail_app_iso: "tail (app_iso hom G) = iso_tail hom"
	and head_app_iso: "head (app_iso hom G) = iso_head hom"
	by (auto simp: app_iso_def)

	lemmas app_iso_simps[simp] = verts_app_iso arcs_app_iso tail_app_iso head_app_iso

	context pre_digraph begin

	lemma
	assumes "digraph_isomorphism hom"
	shows iso_verts_inv_iso: "\<And>u. u \<in> verts G \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom u) = u"
	and iso_arcs_inv_iso: "\<And>a. a \<in> arcs G \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom a) = a"
	and iso_verts_iso_inv: "\<And>u. u \<in> verts (app_iso hom G) \<Longrightarrow> iso_verts hom (iso_verts (inv_iso hom) u) = u"
	and iso_arcs_iso_inv: "\<And>a. a \<in> arcs (app_iso hom G) \<Longrightarrow> iso_arcs hom (iso_arcs (inv_iso hom) a) = a"
	and iso_tail_inv_iso: "iso_tail (inv_iso hom) = tail G"
	and iso_head_inv_iso: "iso_head (inv_iso hom) = head G"
	and verts_app_inv_iso:"iso_verts (inv_iso hom) ` iso_verts hom ` verts G = verts G"
	and arcs_app_inv_iso:"iso_arcs (inv_iso hom) ` iso_arcs hom ` arcs G = arcs G"
	using assms by (auto simp: inv_iso_def digraph_isomorphism_def the_inv_into_f_f)

	lemmas iso_inv_simps[simp] =
	iso_verts_inv_iso iso_verts_iso_inv
	iso_arcs_inv_iso iso_arcs_iso_inv
	verts_app_inv_iso arcs_app_inv_iso
	iso_tail_inv_iso iso_head_inv_iso

	lemma app_iso_inv[simp]:
	assumes "digraph_isomorphism hom"
	shows "app_iso (inv_iso hom) (app_iso hom G) = G"
	using assms by (intro pre_digraph.equality) (auto intro: rev_image_eqI)

	lemma iso_verts_eq_iff[simp]:
	assumes "digraph_isomorphism hom" "u \<in> verts G" "v \<in> verts G"
	shows "iso_verts hom u = iso_verts hom v \<longleftrightarrow> u = v"
	using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

	lemma iso_arcs_eq_iff[simp]:
	assumes "digraph_isomorphism hom" "e1 \<in> arcs G" "e2 \<in> arcs G"
	shows "iso_arcs hom e1 = iso_arcs hom e2 \<longleftrightarrow> e1 = e2"
	using assms by (auto simp: digraph_isomorphism_def dest: inj_onD)

	lemma
	assumes "digraph_isomorphism hom" "e \<in> arcs G"
	shows iso_verts_tail: "iso_tail hom (iso_arcs hom e) = iso_verts hom (tail G e)"
	and iso_verts_head: "iso_head hom (iso_arcs hom e) = iso_verts hom (head G e)"
	using assms unfolding digraph_isomorphism_def by auto

	lemma digraph_isomorphism_inj_on_arcs:
	"digraph_isomorphism hom \<Longrightarrow> inj_on (iso_arcs hom) (arcs G)"
	by (auto simp: digraph_isomorphism_def)

	lemma digraph_isomorphism_inj_on_verts:
	"digraph_isomorphism hom \<Longrightarrow> inj_on (iso_verts hom) (verts G)"
	by (auto simp: digraph_isomorphism_def)

	end

	lemma (in wf_digraph) wf_digraphI_app_iso[intro?]:
	assumes "digraph_isomorphism hom"
	shows "wf_digraph (app_iso hom G)"
	proof unfold_locales
	fix e assume "e \<in> arcs (app_iso hom G)"
	then obtain e' where e': "e' \<in> arcs G" "iso_arcs hom e' = e"
	by auto
	then have "iso_verts hom (head G e') \<in> verts (app_iso hom G)"
	"iso_verts hom (tail G e') \<in> verts (app_iso hom G)"
	by auto
	then show "tail (app_iso hom G) e \<in> verts (app_iso hom G)"
	"head (app_iso hom G) e \<in> verts (app_iso hom G)"
	using e' assms by (auto simp: iso_verts_tail iso_verts_head)
	qed

	lemma (in fin_digraph) fin_digraphI_app_iso[intro?]:
	assumes "digraph_isomorphism hom"
	shows "fin_digraph (app_iso hom G)"
	proof -
	interpret H: wf_digraph "app_iso hom G" using assms ..
	show ?thesis by unfold_locales auto
	qed

	context wf_digraph begin

	lemma digraph_isomorphism_invI:
	assumes "digraph_isomorphism hom" shows "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
	proof (unfold pre_digraph.digraph_isomorphism_def, safe)
	show "inj_on (iso_verts (inv_iso hom)) (verts (app_iso hom G))"
	"inj_on (iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"
	using assms unfolding pre_digraph.digraph_isomorphism_def inv_iso_def
	by (auto intro: inj_on_the_inv_into)
	next
	show "wf_digraph (app_iso hom G)" using assms ..
	next
	fix a assume "a \<in> arcs (app_iso hom G)"
	then obtain b where B: "a = iso_arcs hom b" "b \<in> arcs G"
	by auto

	with assms have [simp]:
	"iso_tail hom (iso_arcs hom b) = iso_verts hom (tail G b)"
	"iso_head hom (iso_arcs hom b) = iso_verts hom (head G b)"
	"inj_on (iso_arcs hom) (arcs G)"
	"inj_on (iso_verts hom) (verts G)"
	by (auto simp: digraph_isomorphism_def)

	from B show "iso_verts (inv_iso hom) (tail (app_iso hom G) a)
	= iso_tail (inv_iso hom) (iso_arcs (inv_iso hom) a)"
	by (auto simp: inv_iso_def the_inv_into_f_f)
	from B show "iso_verts (inv_iso hom) (head (app_iso hom G) a)
	= iso_head (inv_iso hom) (iso_arcs (inv_iso hom) a)"
	by (auto simp: inv_iso_def the_inv_into_f_f)
	qed


	lemma awalk_app_isoI:
	assumes "awalk u p v" and hom: "digraph_isomorphism hom"
	shows "pre_digraph.awalk (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..
	from assms show ?thesis
	by (induct p arbitrary: u)
	(auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
	qed

	lemma awalk_app_isoD:
	assumes w: "pre_digraph.awalk (app_iso hom G) u p v" and hom: "digraph_isomorphism hom"
	shows "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..
	from assms show ?thesis
	by (induct p arbitrary: u)
	(force simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)+
	qed

	lemma awalk_verts_app_iso_eq:
	assumes "digraph_isomorphism hom" and "awalk u p v"
	shows "pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom u) (map (iso_arcs hom) p)
	= map (iso_verts hom) (awalk_verts u p)"
	using assms
	by (induct p arbitrary: u)
	(auto simp: pre_digraph.awalk_verts.simps iso_verts_head iso_verts_tail awalk_Cons_iff)

	(*
	lemma awalk_verts_app_iso_eq':
	assumes hom: "digraph_isomorphism hom" and w: "pre_digraph.awalk (app_iso hom G) u p v"
	shows "pre_digraph.awalk_verts (app_iso hom G) u p
	= map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..
	have w': "awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
	using w hom by (rule awalk_app_isoD)
	have "pre_digraph.awalk_verts (app_iso hom G) u p =
	pre_digraph.awalk_verts (app_iso hom G) (iso_verts hom (iso_verts (inv_iso hom) u)) (map (iso_arcs hom) (map (iso_arcs (inv_iso hom)) p))"
	using hom w by (auto simp add: o_def subsetD cong: map_cong)
	also have "\<dots> = map (iso_verts hom) (awalk_verts (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p))"
	using hom w' by (rule awalk_verts_app_iso_eq)
	finally show ?thesis .
	qed
	*)

	lemma arcs_ends_app_iso_eq:
	assumes "digraph_isomorphism hom"
	shows "arcs_ends (app_iso hom G) = (\<lambda>(u,v). (iso_verts hom u, iso_verts hom v)) ` arcs_ends G"
	using assms by (auto simp: arcs_ends_conv image_image iso_verts_head iso_verts_tail
	intro!: rev_image_eqI)

	lemma in_arcs_app_iso_eq:
	assumes "digraph_isomorphism hom" and "u \<in> verts G"
	shows "in_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` in_arcs G u"
	using assms unfolding in_arcs_def by (auto simp: iso_verts_head)

	lemma out_arcs_app_iso_eq:
	assumes "digraph_isomorphism hom" and "u \<in> verts G"
	shows "out_arcs (app_iso hom G) (iso_verts hom u) = iso_arcs hom ` out_arcs G u"
	using assms unfolding out_arcs_def by (auto simp: iso_verts_tail)

	lemma in_degree_app_iso_eq:
	assumes "digraph_isomorphism hom" and "u \<in> verts G"
	shows "in_degree (app_iso hom G) (iso_verts hom u) = in_degree G u"
	unfolding in_degree_def in_arcs_app_iso_eq[OF assms]
	proof (rule card_image)
	from assms show "inj_on (iso_arcs hom) (in_arcs G u)"
	unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
	qed

	lemma out_degree_app_iso_eq:
	assumes "digraph_isomorphism hom" and "u \<in> verts G"
	shows "out_degree (app_iso hom G) (iso_verts hom u) = out_degree G u"
	unfolding out_degree_def out_arcs_app_iso_eq[OF assms]
	proof (rule card_image)
	from assms show "inj_on (iso_arcs hom) (out_arcs G u)"
	unfolding digraph_isomorphism_def by - (rule subset_inj_on, auto)
	qed

	lemma in_arcs_app_iso_eq':
	assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
	shows "in_arcs (app_iso hom G) u = iso_arcs hom ` in_arcs G (iso_verts (inv_iso hom) u)"
	using assms in_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

	lemma out_arcs_app_iso_eq':
	assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
	shows "out_arcs (app_iso hom G) u = iso_arcs hom ` out_arcs G (iso_verts (inv_iso hom) u)"
	using assms out_arcs_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

	lemma in_degree_app_iso_eq':
	assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
	shows "in_degree (app_iso hom G) u = in_degree G (iso_verts (inv_iso hom) u)"
	using assms in_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

	lemma out_degree_app_iso_eq':
	assumes "digraph_isomorphism hom" and "u \<in> verts (app_iso hom G)"
	shows "out_degree (app_iso hom G) u = out_degree G (iso_verts (inv_iso hom) u)"
	using assms out_degree_app_iso_eq[of hom "iso_verts (inv_iso hom) u"] by auto

	lemmas app_iso_eq =
	awalk_verts_app_iso_eq
	arcs_ends_app_iso_eq
	in_arcs_app_iso_eq'
	out_arcs_app_iso_eq'
	in_degree_app_iso_eq'
	out_degree_app_iso_eq'

	lemma reachableI_app_iso:
	assumes r: "u \<rightarrow>\<^sup>* v" and hom: "digraph_isomorphism hom"
	shows "(iso_verts hom u) \<rightarrow>\<^sup>*\<^bsub>app_iso hom G\<^esub> (iso_verts hom v)"
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..
	from r obtain p where "awalk u p v" by (auto simp: reachable_awalk)
	then have "H.awalk (iso_verts hom u) (map (iso_arcs hom) p) (iso_verts hom v)"
	using hom by (rule awalk_app_isoI)
	then show ?thesis by (auto simp: H.reachable_awalk)
	qed

	lemma awalk_app_iso_eq:
	assumes hom: "digraph_isomorphism hom"
	assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G" "set p \<subseteq> iso_arcs hom ` arcs G"
	shows "pre_digraph.awalk (app_iso hom G) u p v
	\<longleftrightarrow> awalk (iso_verts (inv_iso hom) u) (map (iso_arcs (inv_iso hom)) p) (iso_verts (inv_iso hom) v)"
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..
	from assms show ?thesis
	by (induct p arbitrary: u)
	(auto simp: awalk_simps H.awalk_simps iso_verts_head iso_verts_tail)
	qed

	lemma reachable_app_iso_eq:
	assumes hom: "digraph_isomorphism hom"
	assumes "u \<in> iso_verts hom ` verts G" "v \<in> iso_verts hom ` verts G"
	shows "u \<rightarrow>\<^sup>\<^bsub>app_iso hom G\<^esub> v \<longleftrightarrow> iso_verts (inv_iso hom) u \<rightarrow>\<^sup> iso_verts (inv_iso hom) v" (is "?L \<longleftrightarrow> ?R")
	proof -
	interpret H: wf_digraph "app_iso hom G" using hom ..

	show ?thesis
	proof
	assume ?L
	then obtain p where "H.awalk u p v" by (auto simp: H.reachable_awalk)
	moreover
	then have "set p \<subseteq> iso_arcs hom ` arcs G" by (simp add: H.awalk_def)
	ultimately
	show ?R using assms by (auto simp: awalk_app_iso_eq reachable_awalk)
	next
	assume ?R
	then obtain p0 where "awalk (iso_verts (inv_iso hom) u) p0 (iso_verts (inv_iso hom) v)"
	by (auto simp: reachable_awalk)
	moreover
	then have "set p0 \<subseteq> arcs G" by (simp add: awalk_def)
	define p where "p = map (iso_arcs hom) p0"
	have "set p \<subseteq> iso_arcs hom ` arcs G" "p0 = map (iso_arcs (inv_iso hom)) p"
	using \<open>set p0 \<subseteq> _\<close> hom by (auto simp: p_def map_idI subsetD)
	ultimately
	show ?L using assms by (auto simp: awalk_app_iso_eq[symmetric] H.reachable_awalk)
	qed
	qed

	lemma connectedI_app_iso:
	assumes c: "connected G" and hom: "digraph_isomorphism hom"
	shows "connected (app_iso hom G)"
	proof -
	have *: "symcl (arcs_ends (app_iso hom G)) = (\<lambda>(u,v). (iso_verts hom u, iso_verts hom v)) ` symcl (arcs_ends G)"
	using hom by (auto simp add: app_iso_eq symcl_def)
	{ fix u v assume "(u,v) \<in> rtrancl_on (verts G) (symcl (arcs_ends G))"
	then have "(iso_verts hom u, iso_verts hom v) \<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
	proof induct
	case (step x y)
	have "(iso_verts hom x, iso_verts hom y)
	\<in> rtrancl_on (verts (app_iso hom G)) (symcl (arcs_ends (app_iso hom G)))"
	using step by (rule_tac rtrancl_on_into_rtrancl_on[where b="iso_verts hom x"]) (auto simp: *)
	then show ?case
	by (rule rtrancl_on_trans) (rule step)
	qed auto }
	with c show ?thesis unfolding connected_conv by auto
	qed

	end

	lemma digraph_iso_swap:
	assumes "wf_digraph G" "digraph_iso G H" shows "digraph_iso H G"
	proof -
	from assms obtain f where "pre_digraph.digraph_isomorphism G f" "H = app_iso f G"
	unfolding digraph_iso_def by auto
	then have "pre_digraph.digraph_isomorphism H (pre_digraph.inv_iso G f)" "app_iso (pre_digraph.inv_iso G f) H = G"
	using assms by (simp_all add: wf_digraph.digraph_isomorphism_invI pre_digraph.app_iso_inv)
	then show ?thesis unfolding digraph_iso_def by auto
	qed

	definition
	o_iso :: "('c,'d,'e,'f) digraph_isomorphism \<Rightarrow> ('a,'b,'c,'d) digraph_isomorphism \<Rightarrow> ('a,'b,'e,'f) digraph_isomorphism"
	where
	"o_iso hom2 hom1 = \<lparr>
	iso_verts = iso_verts hom2 o iso_verts hom1,
	iso_arcs = iso_arcs hom2 o iso_arcs hom1,
	iso_head = iso_head hom2,
	iso_tail = iso_tail hom2
	\<rparr>"

	lemma digraph_iso_trans[trans]:
	assumes "digraph_iso G H" "digraph_iso H I" shows "digraph_iso G I"
	proof -
	from assms obtain hom1 where "pre_digraph.digraph_isomorphism G hom1" "H = app_iso hom1 G"
	by (auto simp: digraph_iso_def)
	moreover
	from assms obtain hom2 where "pre_digraph.digraph_isomorphism H hom2" "I = app_iso hom2 H"
	by (auto simp: digraph_iso_def)
	ultimately
	have "pre_digraph.digraph_isomorphism G (o_iso hom2 hom1)" "I = app_iso (o_iso hom2 hom1) G"
	apply (auto simp: o_iso_def app_iso_def pre_digraph.digraph_isomorphism_def)
	apply (rule comp_inj_on)
	apply auto
	apply (rule comp_inj_on)
	apply auto
	done
	then show ?thesis by (auto simp: digraph_iso_def)
	qed

	lemma (in pre_digraph) digraph_isomorphism_subgraphI:
	assumes "digraph_isomorphism hom"
	assumes "subgraph H G"
	shows "pre_digraph.digraph_isomorphism H hom"
	using assms by (auto simp: pre_digraph.digraph_isomorphism_def subgraph_def compatible_def intro: subset_inj_on)

	(* XXX move *)
	lemma (in wf_digraph) verts_app_inv_iso_subgraph:
	assumes hom: "digraph_isomorphism hom" and "V \<subseteq> verts G"
	shows "iso_verts (inv_iso hom) ` iso_verts hom ` V = V"
	proof -
	have "\<And>x. x \<in> V \<Longrightarrow> iso_verts (inv_iso hom) (iso_verts hom x) = x"
	using assms by auto
	then show ?thesis by (auto simp: image_image cong: image_cong)
	qed

	(* XXX move *)
	lemma (in wf_digraph) arcs_app_inv_iso_subgraph:
	assumes hom: "digraph_isomorphism hom" and "A \<subseteq> arcs G"
	shows "iso_arcs (inv_iso hom) ` iso_arcs hom ` A = A"
	proof -
	have "\<And>x. x \<in> A \<Longrightarrow> iso_arcs (inv_iso hom) (iso_arcs hom x) = x"
	using assms by auto
	then show ?thesis by (auto simp: image_image cong: image_cong)
	qed

	(* XXX move *)
	lemma (in pre_digraph) app_iso_inv_subgraph[simp]:
	assumes "digraph_isomorphism hom" "subgraph H G"
	shows "app_iso (inv_iso hom) (app_iso hom H) = H"
	proof -
	from assms interpret wf_digraph G by auto
	have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> arcs G"
	using assms by auto
	with assms show ?thesis
	by (intro pre_digraph.equality) (auto simp: verts_app_inv_iso_subgraph
	arcs_app_inv_iso_subgraph compatible_def)
	qed

	lemma (in wf_digraph) app_iso_iso_inv_subgraph[simp]:
	assumes "digraph_isomorphism hom"
	assumes subg: "subgraph H (app_iso hom G)"
	shows "app_iso hom (app_iso (inv_iso hom) H) = H"
	proof -
	have "\<And>u. u \<in> verts H \<Longrightarrow> u \<in> iso_verts hom ` verts G" "\<And>a. a \<in> arcs H \<Longrightarrow> a \<in> iso_arcs hom ` arcs G"
	using assms by (auto simp: subgraph_def)
	with assms show ?thesis
	by (intro pre_digraph.equality) (auto simp: compatible_def image_image cong: image_cong)
	qed

	lemma (in pre_digraph) subgraph_app_isoI':
	assumes hom: "digraph_isomorphism hom"
	assumes subg: "subgraph H H'" "subgraph H' G"
	shows "subgraph (app_iso hom H) (app_iso hom H')"
	proof -
	have "subgraph H G" using subg by (rule subgraph_trans)
	then have "pre_digraph.digraph_isomorphism H hom" "pre_digraph.digraph_isomorphism H' hom"
	using assms by (auto intro: digraph_isomorphism_subgraphI)
	then show ?thesis
	using assms by (auto simp: subgraph_def wf_digraph.wf_digraphI_app_iso compatible_def
	intro: digraph_isomorphism_subgraphI)
	qed

	lemma (in pre_digraph) subgraph_app_isoI:
	assumes "digraph_isomorphism hom"
	assumes "subgraph H G"
	shows "subgraph (app_iso hom H) (app_iso hom G)"
	using assms by (auto intro: subgraph_app_isoI' wf_digraph.subgraph_refl)

	lemma (in pre_digraph) app_iso_eq_conv:
	assumes "digraph_isomorphism hom"
	assumes "subgraph H1 G" "subgraph H2 G"
	shows "app_iso hom H1 = app_iso hom H2 \<longleftrightarrow> H1 = H2" (is "?L \<longleftrightarrow> ?R")
	proof
	assume ?L
	then have "app_iso (inv_iso hom) (app_iso hom H1) = app_iso (inv_iso hom) (app_iso hom H2)"
	by simp
	with assms show ?R by auto
	qed simp

	lemma in_arcs_app_iso_cases:
	assumes "a \<in> arcs (app_iso hom G)"
	obtains a0 where "a = iso_arcs hom a0" "a0 \<in> arcs G"
	using assms by auto

	lemma in_verts_app_iso_cases:
	assumes "v \<in> verts (app_iso hom G)"
	obtains v0 where "v = iso_verts hom v0" "v0 \<in> verts G"
	using assms by auto

	lemma (in wf_digraph) max_subgraph_iso:
	assumes hom: "digraph_isomorphism hom"
	assumes subg: "subgraph H (app_iso hom G)"
	shows "pre_digraph.max_subgraph (app_iso hom G) P H
	\<longleftrightarrow> max_subgraph (P o app_iso hom) (app_iso (inv_iso hom) H)"
	proof -
	have hom_inv: "pre_digraph.digraph_isomorphism (app_iso hom G) (inv_iso hom)"
	using hom by (rule digraph_isomorphism_invI)
	interpret aG: wf_digraph "app_iso hom G" using hom ..

	have *: "subgraph (app_iso (inv_iso hom) H) G"
	using hom pre_digraph.subgraph_app_isoI'[OF hom_inv subg aG.subgraph_refl] by simp
	define H0 where "H0 = app_iso (inv_iso hom) H"
	then have H0: "H = app_iso hom H0" "subgraph H0 G"
	- using hom subg \<open>subgraph _ G\<close> by (auto simp: )
	+ using hom subg \<open>subgraph _ G\<close> by auto

	show ?thesis (is "?L \<longleftrightarrow> ?R")
	proof
	assume ?L then show ?R using assms H0
	by (auto simp: max_subgraph_def aG.max_subgraph_def pre_digraph.subgraph_app_isoI'
	subgraph_refl pre_digraph.app_iso_eq_conv)
	next
	assume ?R
	then show ?L
	using assms hom_inv pre_digraph.subgraph_app_isoI[OF hom_inv]
	apply (auto simp: max_subgraph_def aG.max_subgraph_def)
	apply (erule allE[of _ "app_iso (inv_iso hom) H'" for H'])
	apply (auto simp: pre_digraph.subgraph_app_isoI' pre_digraph.app_iso_eq_conv)
	done
	qed
	qed

	lemma (in pre_digraph) max_subgraph_cong:
	assumes "H = H'" "\<And>H''. subgraph H' H'' \<Longrightarrow> subgraph H'' G \<Longrightarrow> P H'' = P' H''"
	shows "max_subgraph P H = max_subgraph P' H'"
	using assms by (auto simp: max_subgraph_def intro: wf_digraph.subgraph_refl)

	lemma (in pre_digraph) inj_on_app_iso:
	assumes hom: "digraph_isomorphism hom"
	assumes "S \<subseteq> {H. subgraph H G}"
	shows "inj_on (app_iso hom) S"
	using assms by (intro inj_onI) (subst (asm) app_iso_eq_conv, auto)



	subsection \<open>Graph Invariants\<close>

	context
	fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
	begin

	interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

	lemma card_verts_iso[simp]: "card (iso_verts hom ` verts G) = card (verts G)"
	using hom by (intro card_image digraph_isomorphism_inj_on_verts)

	lemma card_arcs_iso[simp]: "card (iso_arcs hom ` arcs G) = card (arcs G)"
	using hom by (intro card_image digraph_isomorphism_inj_on_arcs)

	lemma strongly_connected_iso[simp]: "strongly_connected (app_iso hom G) \<longleftrightarrow> strongly_connected G"
	using hom by (auto simp: strongly_connected_def reachable_app_iso_eq)

	lemma subgraph_strongly_connected_iso:
	assumes "subgraph H G"
	shows "strongly_connected (app_iso hom H) \<longleftrightarrow> strongly_connected H"
	proof -
	interpret H: wf_digraph H using \<open>subgraph H G\<close> ..
	have "H.digraph_isomorphism hom" using hom assms by (rule digraph_isomorphism_subgraphI)
	then show ?thesis
	using assms by (auto simp: strongly_connected_def H.reachable_app_iso_eq)
	qed

	lemma sccs_iso[simp]: "pre_digraph.sccs (app_iso hom G) = app_iso hom ` sccs" (is "?L = ?R")
	proof (intro set_eqI iffI)
	fix x assume "x \<in> ?L"
	then have "subgraph x (app_iso hom G)"
	by (auto simp: pre_digraph.sccs_def)
	then show "x \<in> ?R"
	using \<open>x \<in> ?L\<close> hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso
	subgraph_strongly_connected_iso cong: max_subgraph_cong intro: rev_image_eqI)
	next
	fix x assume "x \<in> ?R"
	then obtain x0 where "x0 \<in> sccs" "x = app_iso hom x0" by auto
	then show "x \<in> ?L"
	using hom by (auto simp: pre_digraph.sccs_altdef2 max_subgraph_iso subgraph_app_isoI
	subgraphI_max_subgraph subgraph_strongly_connected_iso cong: max_subgraph_cong)
	qed

	lemma card_sccs_iso[simp]: "card (app_iso hom ` sccs) = card sccs"
	apply (rule card_image)
	using hom
	apply (rule inj_on_app_iso)
	apply auto
	done

	end

	end
	diff --git a/thys/Graph_Theory/Kuratowski.thy b/thys/Graph_Theory/Kuratowski.thy
	--- a/thys/Graph_Theory/Kuratowski.thy
	+++ b/thys/Graph_Theory/Kuratowski.thy
	@@ -1,1518 +1,1518 @@
	(* Title: Kuratowski.thy
	Author: Lars Noschinski, TU München
	*)

	theory Kuratowski
	imports
	Arc_Walk
	Digraph_Component
	Subdivision
	"HOL-Library.Rewrite"
	begin

	section \<open>Kuratowski Subgraphs\<close>

	text \<open>
	We consider the underlying undirected graphs. The underlying undirected graph is represented as a
	symmetric digraph.
	\<close>

	subsection \<open>Public definitions\<close>

	definition complete_digraph :: "nat \<Rightarrow> ('a,'b) pre_digraph \<Rightarrow> bool" ("K\<^bsub>_\<^esub>") where
	"complete_digraph n G \<equiv> graph G \<and> card (verts G) = n \<and> arcs_ends G = {(u,v). (u,v) \<in> verts G \<times> verts G \<and> u \<noteq> v}"

	definition complete_bipartite_digraph :: "nat \<Rightarrow> nat \<Rightarrow> ('a, 'b) pre_digraph \<Rightarrow> bool" ("K\<^bsub>_,_\<^esub>") where
	"complete_bipartite_digraph m n G \<equiv> graph G \<and> (\<exists>U V. verts G = U \<union> V \<and> U \<inter> V = {}
	\<and> card U = m \<and> card V = n \<and> arcs_ends G = U \<times> V \<union> V \<times> U)"

	definition kuratowski_planar :: "('a,'b) pre_digraph \<Rightarrow> bool" where
	"kuratowski_planar G \<equiv> \<not>(\<exists>H. subgraph H G \<and> (\<exists>K rev_K rev_H. subdivision (K, rev_K) (H, rev_H) \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)))"

	lemma complete_digraph_pair_def: "K\<^bsub>n\<^esub> (with_proj G)
	\<longleftrightarrow> finite (pverts G) \<and> card (pverts G) = n \<and> parcs G = {(u,v). (u,v) \<in> (pverts G \<times> pverts G) \<and> u \<noteq> v}" (is "_ = ?R")
	proof
	assume A: "K\<^bsub>n\<^esub> G"
	then interpret graph "with_proj G" by (simp add: complete_digraph_def)
	show ?R using A finite_verts by (auto simp: complete_digraph_def)
	next
	assume A: ?R
	moreover
	then have "finite (pverts G \<times> pverts G)" "parcs G \<subseteq> pverts G \<times> pverts G"
	by auto
	then have "finite (parcs G)" by (rule rev_finite_subset)
	ultimately interpret pair_graph G
	by unfold_locales (auto simp: symmetric_def split: prod.splits intro: symI)
	show "K\<^bsub>n\<^esub> G" using A finite_verts by (auto simp: complete_digraph_def)
	qed

	lemma complete_bipartite_digraph_pair_def: "K\<^bsub>m,n\<^esub> (with_proj G) \<longleftrightarrow> finite (pverts G)
	\<and> (\<exists>U V. pverts G = U \<union> V \<and> U \<inter> V = {} \<and> card U = m \<and> card V = n \<and> parcs G = U \<times> V \<union> V \<times> U)" (is "_ = ?R")
	proof
	assume A: "K\<^bsub>m,n\<^esub> G"
	then interpret graph G by (simp add: complete_bipartite_digraph_def)
	show ?R using A finite_verts by (auto simp: complete_bipartite_digraph_def)
	next
	assume A: ?R
	then interpret pair_graph G
	by unfold_locales (fastforce simp: complete_bipartite_digraph_def symmetric_def split: prod.splits intro: symI)+
	show "K\<^bsub>m,n\<^esub> G" using A by (auto simp: complete_bipartite_digraph_def)
	qed

	lemma pair_graphI_complete:
	assumes "K\<^bsub>n\<^esub> (with_proj G)"
	shows "pair_graph G"
	proof -
	from assms interpret graph "with_proj G" by (simp add: complete_digraph_def)
	show "pair_graph G"
	using finite_arcs finite_verts sym_arcs wellformed no_loops by unfold_locales simp_all
	qed

	lemma pair_graphI_complete_bipartite:
	assumes "K\<^bsub>m,n\<^esub> (with_proj G)"
	shows "pair_graph G"
	proof -
	from assms interpret graph "with_proj G" by (simp add: complete_bipartite_digraph_def)
	show "pair_graph G"
	using finite_arcs finite_verts sym_arcs wellformed no_loops by unfold_locales simp_all
	qed



	subsection \<open>Inner vertices of a walk\<close>

	context pre_digraph begin

	definition (in pre_digraph) inner_verts :: "'b awalk \<Rightarrow> 'a list" where
	"inner_verts p \<equiv> tl (map (tail G) p)"

	lemma inner_verts_Nil[simp]: "inner_verts [] = []" by (auto simp: inner_verts_def)

	lemma inner_verts_singleton[simp]: "inner_verts [x] = []" by (auto simp: inner_verts_def)

	lemma (in wf_digraph) inner_verts_Cons:
	assumes "awalk u (e # es) v"
	shows "inner_verts (e # es) = (if es \<noteq> [] then head G e # inner_verts es else [])"
	using assms by (induct es) (auto simp: inner_verts_def)

	lemma (in - ) inner_verts_with_proj_def:
	"pre_digraph.inner_verts (with_proj G) p = tl (map fst p)"
	unfolding pre_digraph.inner_verts_def by simp

	lemma inner_verts_conv: "inner_verts p = butlast (tl (awalk_verts u p))"
	unfolding inner_verts_def awalk_verts_conv by simp

	lemma (in pre_digraph) inner_verts_empty[simp]:
	assumes "length p < 2" shows "inner_verts p = []"
	using assms by (cases p) (auto simp: inner_verts_def)

	lemma (in wf_digraph) set_inner_verts:
	assumes "apath u p v"
	shows "set (inner_verts p) = set (awalk_verts u p) - {u,v}"
	proof (cases "length p < 2")
	case True with assms show ?thesis
	by (cases p) (auto simp: inner_verts_conv[of _ u] apath_def)
	next
	case False
	have "awalk_verts u p = u # inner_verts p @ [v]"
	using assms False length_awalk_verts[of u p] inner_verts_conv[of p u]
	by (cases "awalk_verts u p") (auto simp: apath_def awalk_conv)
	then show ?thesis using assms by (auto simp: apath_def)
	qed

	lemma in_set_inner_verts_appendI_l:
	assumes "u \<in> set (inner_verts p)"
	shows "u \<in> set (inner_verts (p @ q))"
	using assms
	by (induct p) (auto simp: inner_verts_def)

	lemma in_set_inner_verts_appendI_r:
	assumes "u \<in> set (inner_verts q)"
	shows "u \<in> set (inner_verts (p @ q))"
	using assms
	by (induct p) (auto simp: inner_verts_def dest: list_set_tl)

	end


	subsection \<open>Progressing Walks\<close>

	text \<open>
	We call a walk \emph{progressing} if it does not contain the sequence
	@{term "[(x,y), (y,x)]"}. This concept is relevant in particular
	for @{term iapath}s: If all of the inner vertices have degree at
	most 2 this implies that such a walk is a trail and even a path.
	\<close>

	definition progressing :: "('a \<times> 'a) awalk \<Rightarrow> bool" where
	"progressing p \<equiv> \<forall>xs x y ys. p \<noteq> xs @ (x,y) # (y,x) # ys"

	lemma progressing_Nil: "progressing []"
	by (auto simp: progressing_def)

	lemma progressing_single: "progressing [e]"
	by (auto simp: progressing_def)

	lemma progressing_ConsD:
	assumes "progressing (e # es)" shows "progressing es"
	using assms unfolding progressing_def by (metis (no_types) append_eq_Cons_conv)

	lemma progressing_Cons:
	"progressing (x # xs) \<longleftrightarrow> (xs = [] \<or> (xs \<noteq> [] \<and> \<not>(fst x = snd (hd xs) \<and> snd x = fst (hd xs)) \<and> progressing xs))" (is "?L = ?R")
	proof
	assume ?L
	show ?R
	proof (cases xs)
	case Nil then show ?thesis by auto
	next
	case (Cons x' xs')
	then have "\<And>u v. (x # x' # xs') \<noteq> [] @ (u,v) # (v,u) # xs'" using \<open>?L\<close> unfolding progressing_def by metis
	then have "\<not>(fst x = snd x' \<and> snd x = fst x')" by (cases x) (cases x', auto)
	with Cons show ?thesis using \<open>?L\<close> by (auto dest: progressing_ConsD)
	qed
	next
	assume ?R then show ?L unfolding progressing_def
	by (auto simp add: Cons_eq_append_conv)
	qed

	lemma progressing_Cons_Cons:
	"progressing ((u,v) # (v,w) # es) \<longleftrightarrow> u \<noteq> w \<and> progressing ((v,w) # es)" (is "?L \<longleftrightarrow> ?R")
	by (auto simp: progressing_Cons)

	lemma progressing_appendD1:
	assumes "progressing (p @ q)" shows "progressing p"
	using assms unfolding progressing_def by (metis append_Cons append_assoc)

	lemma progressing_appendD2:
	assumes "progressing (p @ q)" shows "progressing q"
	using assms unfolding progressing_def by (metis append_assoc)

	lemma progressing_rev_path:
	"progressing (rev_path p) = progressing p" (is "?L = ?R")
	proof
	assume ?L
	show ?R unfolding progressing_def
	proof (intro allI notI)
	fix xs x y ys l1 l2 assume "p = xs @ (x,y) # (y,x) # ys"
	then have "rev_path p = rev_path ys @ (x,y) # (y,x) # rev_path xs"
	by simp
	then show False using \<open>?L\<close> unfolding progressing_def by auto
	qed
	next
	assume ?R
	show ?L unfolding progressing_def
	proof (intro allI notI)
	fix xs x y ys l1 l2 assume "rev_path p = xs @ (x,y) # (y,x) # ys"
	then have "rev_path (rev_path p) = rev_path ys @ (x,y) # (y,x) # rev_path xs"
	by simp
	then show False using \<open>?R\<close> unfolding progressing_def by auto
	qed
	qed

	lemma progressing_append_iff:
	shows "progressing (xs @ ys) \<longleftrightarrow> progressing xs \<and> progressing ys
	\<and> (xs \<noteq> [] \<and> ys \<noteq> [] \<longrightarrow> (fst (last xs) \<noteq> snd (hd ys) \<or> snd (last xs) \<noteq> fst (hd ys)))"
	proof (induct ys arbitrary: xs)
	case Nil then show ?case by (auto simp: progressing_Nil)
	next
	case (Cons y' ys')
	let "_ = ?R" = ?case
	have *: "xs \<noteq> [] \<Longrightarrow> hd (rev_path xs) = prod.swap (last xs)" by (induct xs) auto

	have "progressing (xs @ y' # ys') \<longleftrightarrow> progressing ((xs @ [y']) @ ys')"
	by simp
	also have "\<dots> \<longleftrightarrow> progressing (xs @ [y']) \<and> progressing ys' \<and> (ys' \<noteq> [] \<longrightarrow> (fst y' \<noteq> snd (hd ys') \<or> snd y' \<noteq> fst (hd ys')))"
	by (subst Cons) simp
	also have "\<dots> \<longleftrightarrow> ?R"
	by (auto simp: progressing_Cons progressing_Nil progressing_rev_path[where p="xs @ _",symmetric] * progressing_rev_path prod.swap_def)
	finally show ?case .
	qed



	subsection \<open>Walks with Restricted Vertices\<close>

	definition verts3 :: "('a, 'b) pre_digraph \<Rightarrow> 'a set" where
	"verts3 G \<equiv> {v \<in> verts G. 2 < in_degree G v}"

	text \<open>A path were only the end nodes may be in @{term V}\<close>

	definition (in pre_digraph) gen_iapath :: "'a set \<Rightarrow> 'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
	"gen_iapath V u p v \<equiv> u \<in> V \<and> v \<in> V \<and> apath u p v \<and> set (inner_verts p) \<inter> V = {} \<and> p \<noteq> []"

	abbreviation (in pre_digraph) (input) iapath :: "'a \<Rightarrow> 'b awalk \<Rightarrow> 'a \<Rightarrow> bool" where
	"iapath u p v \<equiv> gen_iapath (verts3 G) u p v"

	definition gen_contr_graph :: "('a,'b) pre_digraph \<Rightarrow> 'a set \<Rightarrow> 'a pair_pre_digraph" where
	"gen_contr_graph G V \<equiv> \<lparr>
	pverts = V,
	parcs = {(u,v). \<exists>p. pre_digraph.gen_iapath G V u p v}
	\<rparr>"

	abbreviation (input) contr_graph :: "'a pair_pre_digraph \<Rightarrow> 'a pair_pre_digraph" where
	"contr_graph G \<equiv> gen_contr_graph G (verts3 G)"



	subsection \<open>Properties of subdivisions\<close>

	lemma (in pair_sym_digraph) verts3_subdivide:
	assumes "e \<in> parcs G" "w \<notin> pverts G"
	shows"verts3 (subdivide G e w) = verts3 G"
	proof -
	let ?sG = "subdivide G e w"
	obtain u v where e_conv[simp]: "e = (u,v)" by (cases e) auto

	from \<open>w \<notin> pverts G\<close>
	have w_arcs: "(u,w) \<notin> parcs G" "(v,w) \<notin> parcs G" "(w,u) \<notin> parcs G" "(w,v) \<notin> parcs G"
	by (auto dest: wellformed)
	have G_arcs: "(u,v) \<in> parcs G" "(v,u) \<in> parcs G"
	using \<open>e \<in> parcs G\<close> by (auto simp: arcs_symmetric)

	have "{v \<in> pverts G. 2 < in_degree G v} = {v \<in> pverts G. 2 < in_degree ?sG v}"
	proof -
	{ fix x assume "x \<in> pverts G"
	define card_eq where "card_eq x \<longleftrightarrow> in_degree ?sG x = in_degree G x" for x

	have "in_arcs ?sG u = (in_arcs G u - {(v,u)}) \<union> {(w,u)}"
	"in_arcs ?sG v = (in_arcs G v - {(u,v)}) \<union> {(w,v)}"
	using w_arcs G_arcs by auto
	then have "card_eq u" "card_eq v"
	unfolding card_eq_def in_degree_def using w_arcs G_arcs
	apply -
	apply (cases "finite (in_arcs G u)"; simp add: card_Suc_Diff1 del: card_Diff_insert)
	apply (cases "finite (in_arcs G v)"; simp add: card_Suc_Diff1 del: card_Diff_insert)
	done
	moreover
	have "x \<notin> {u,v} \<Longrightarrow> in_arcs ?sG x = in_arcs G x"
	- using \<open>x \<in> pverts G\<close> \<open>w \<notin> pverts G\<close> by (auto simp: )
	+ using \<open>x \<in> pverts G\<close> \<open>w \<notin> pverts G\<close> by auto
	then have "x \<notin> {u,v} \<Longrightarrow> card_eq x" by (simp add: in_degree_def card_eq_def)
	ultimately have "card_eq x" by fast
	then have "in_degree G x = in_degree ?sG x"
	unfolding card_eq_def by simp }
	then show ?thesis by auto
	qed
	also have "\<dots> = {v\<in>pverts ?sG. 2 < in_degree ?sG v}"
	proof -
	have "in_degree ?sG w \<le> 2"
	proof -
	have "in_arcs ?sG w = {(u,w), (v,w)}"
	using \<open>w \<notin> pverts G\<close> G_arcs(1) by (auto simp: wellformed')
	then show ?thesis
	unfolding in_degree_def by (auto simp: card_insert_if)
	qed
	then show ?thesis using G_arcs assms by auto
	qed
	finally show ?thesis by (simp add: verts3_def)
	qed

	lemma sd_path_Nil_iff:
	"sd_path e w p = [] \<longleftrightarrow> p = []"
	by (cases "(e,w,p)" rule: sd_path.cases) auto

	lemma (in pair_sym_digraph) gen_iapath_sd_path:
	fixes e :: "'a \<times> 'a" and w :: 'a
	assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
	assumes V: "V \<subseteq> pverts G"
	assumes path: "gen_iapath V u p v"
	shows "pre_digraph.gen_iapath (subdivide G e w) V u (sd_path e w p) v"
	proof -
	obtain x y where e_conv: "e = (x,y)" by (cases e) auto
	interpret S: pair_sym_digraph "subdivide G e w"
	using elems by (auto intro: pair_sym_digraph_subdivide)

	from path have "apath u p v" by (auto simp: gen_iapath_def)
	then have apath_sd: "S.apath u (sd_path e w p) v" and
	set_ev_sd: "set (S.awalk_verts u (sd_path e w p)) \<subseteq> set (awalk_verts u p) \<union> {w}"
	using elems by (rule apath_sd_path set_awalk_verts_sd_path)+
	have "w \<notin> {u,v}" using elems \<open>apath u p v\<close>
	by (auto simp: apath_def awalk_hd_in_verts awalk_last_in_verts)

	have "set (S.inner_verts (sd_path e w p)) = set (S.awalk_verts u (sd_path e w p)) - {u,v}"
	using apath_sd by (rule S.set_inner_verts)
	also have "\<dots> \<subseteq> set (awalk_verts u p) \<union> {w} - {u,v}"
	using set_ev_sd by auto
	also have "\<dots> = set (inner_verts p) \<union> {w}"
	using set_inner_verts[OF \<open>apath u p v\<close>] \<open>w \<notin> {u,v}\<close> by blast
	finally have "set (S.inner_verts (sd_path e w p)) \<inter> V \<subseteq> (set (inner_verts p) \<union> {w}) \<inter> V"
	using V by blast
	also have "\<dots> \<subseteq> {}"
	using path elems V unfolding gen_iapath_def by auto
	finally show ?thesis
	using apath_sd elems path by (auto simp: gen_iapath_def S.gen_iapath_def sd_path_Nil_iff)
	qed

	lemma (in pair_sym_digraph)
	assumes elems: "e \<in> parcs G" "w \<notin> pverts G"
	assumes V: "V \<subseteq> pverts G"
	assumes path: "pre_digraph.gen_iapath (subdivide G e w) V u p v"
	shows gen_iapath_co_path: "gen_iapath V u (co_path e w p) v" (is ?thesis_path)
	and set_awalk_verts_co_path': "set (awalk_verts u (co_path e w p)) = set (awalk_verts u p) - {w}" (is ?thesis_set)
	proof -
	interpret S: pair_sym_digraph "subdivide G e w"
	using elems by (rule pair_sym_digraph_subdivide)

	have uv: "u \<in> pverts G" "v \<in> pverts G" "S.apath u p v" using V path by (auto simp: S.gen_iapath_def)
	note co = apath_co_path[OF elems uv] set_awalk_verts_co_path[OF elems uv]

	show ?thesis_set by (fact co)
	show ?thesis_path using co path unfolding gen_iapath_def S.gen_iapath_def using elems
	by (clarsimp simp add: set_inner_verts[of u] S.set_inner_verts[of u]) blast
	qed



	subsection \<open>Pair Graphs\<close>

	context pair_sym_digraph begin

	lemma gen_iapath_rev_path:
	"gen_iapath V v (rev_path p) u = gen_iapath V u p v" (is "?L = ?R")
	proof -
	{ fix u p v assume "gen_iapath V u p v"
	then have "butlast (tl (awalk_verts v (rev_path p))) = rev (butlast (tl (awalk_verts u p)))"
	by (auto simp: tl_rev butlast_rev butlast_tl awalk_verts_rev_path gen_iapath_def apath_def)
	with \<open>gen_iapath V u p v\<close> have "gen_iapath V v (rev_path p) u"
	by (auto simp: gen_iapath_def apath_def inner_verts_conv[symmetric] awalk_verts_rev_path) }
	note RL = this
	show ?thesis by (auto dest: RL intro: RL)
	qed

	lemma inner_verts_rev_path:
	assumes "awalk u p v"
	shows "inner_verts (rev_path p) = rev (inner_verts p)"
	by (metis assms butlast_rev butlast_tl awalk_verts_rev_path inner_verts_conv tl_rev)

	end

	context pair_pseudo_graph begin

	lemma apath_imp_progressing:
	assumes "apath u p v" shows "progressing p"
	proof (rule ccontr)
	assume "\<not>?thesis"
	then obtain xs x y ys where *: "p = xs @ (x,y) # (y,x) # ys"
	unfolding progressing_def by auto
	then have "\<not>apath u p v"
	by (simp add: apath_append_iff apath_simps hd_in_awalk_verts)
	then show False using assms by auto
	qed

	lemma awalk_Cons_deg2_unique:
	assumes "awalk u p v" "p \<noteq> []"
	assumes "in_degree G u \<le> 2"
	assumes "awalk u1 (e1 # p) v" "awalk u2 (e2 # p) v"
	assumes "progressing (e1 # p)" "progressing (e2 # p)"
	shows "e1 = e2"
	proof (cases p)
	case (Cons e es)
	show ?thesis
	proof (rule ccontr)
	assume "e1 \<noteq> e2"
	define x where "x = snd e"
	then have e_unf:"e = (u,x)" using \<open>awalk u p v\<close> Cons by (auto simp: awalk_simps)
	then have ei_unf: "e1 = (u1, u)" "e2 = (u2, u)"
	using Cons assms by (auto simp: apath_simps prod_eqI)
	with Cons assms \<open>e = (u,x)\<close> \<open>e1 \<noteq> e2\<close> have "u1 \<noteq> u2" "x \<noteq> u1" "x \<noteq> u2"
	by (auto simp: progressing_Cons_Cons)
	moreover have "{(u1, u), (u2, u), (x,u)} \<subseteq> parcs G"
	using e_unf ei_unf Cons assms by (auto simp: awalk_simps intro: arcs_symmetric)
	then have "finite (in_arcs G u)"
	and "{(u1, u), (u2, u), (x,u)} \<subseteq> in_arcs G u" by auto
	then have "card ({(u1, u), (u2, u), (x,u)}) \<le> in_degree G u"
	unfolding in_degree_def by (rule card_mono)
	ultimately show "False" using \<open>in_degree G u \<le> 2\<close> by auto
	qed
	qed (simp add: \<open>p \<noteq> []\<close>)

	lemma same_awalk_by_same_end:
	assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
	and walk: "awalk u p v" "awalk u q w" "hd p = hd q" "p \<noteq> []" "q \<noteq> []"
	and progress: "progressing p" "progressing q"
	and tail: "v \<in> V" "w \<in> V"
	and inner_verts: "set (inner_verts p) \<inter> V = {}"
	"set (inner_verts q) \<inter> V = {}"
	shows "p = q"
	using walk progress inner_verts
	proof (induct p q arbitrary: u rule: list_induct2'[case_names Nil_Nil Cons_Nil Nil_Cons Cons_Cons])
	case (Cons_Cons a as b bs)
	from \<open>hd (a # _) = hd _\<close> have "a = b" by simp

	{ fix a as v b bs w
	assume A: "awalk u (a # as) v" "awalk u (b # bs) w"
	"set (inner_verts (b # bs)) \<inter> V = {}" "v \<in> V" "a = b" "as = []"
	then have "bs = []" by - (rule ccontr, auto simp: inner_verts_Cons awalk_simps)
	} note Nil_imp_Nil = this

	show ?case
	proof (cases "as = []")
	case True
	then have "bs = []" using Cons_Cons.prems \<open>a = b\<close> tail by (metis Nil_imp_Nil)
	then show ?thesis using True \<open>a = b\<close> by simp
	next
	case False
	then have "bs \<noteq> []" using Cons_Cons.prems \<open>a = b\<close> tail by (metis Nil_imp_Nil)

	obtain a' as' where "as = a' # as'" using \<open>as \<noteq> []\<close> by (cases as) simp
	obtain b' bs' where "bs = b' # bs'" using \<open>bs \<noteq> []\<close> by (cases bs) simp

	let ?arcs = "{(fst a, snd a), (snd a', snd a), (snd b', snd a)}"

	have "card {fst a, snd a', snd b'} = card (fst ` ?arcs)" by auto
	also have "\<dots> = card ?arcs" by (rule card_image) (cases a, auto)
	also have "\<dots> \<le> in_degree G (snd a)"
	proof -
	have "?arcs \<subseteq> in_arcs G (snd a)"
	using \<open>progressing (a # as)\<close> \<open>progressing (b # bs)\<close> \<open>awalk _ (a # as) _\<close> \<open>awalk _ (b # bs) _\<close>
	unfolding \<open>a = b\<close> \<open>as = _\<close> \<open>bs = _\<close>
	by (cases b; cases a') (auto simp: progressing_Cons_Cons awalk_simps intro: arcs_symmetric)
	with _show ?thesis unfolding in_degree_def by (rule card_mono) auto
	qed
	also have "\<dots> \<le> 2"
	proof -
	have "snd a \<notin> V" "snd a \<in> pverts G"
	using Cons_Cons.prems \<open>as \<noteq> []\<close> by (auto simp: inner_verts_Cons)
	then show ?thesis using V by (auto simp: verts3_def)
	qed
	finally have "fst a = snd a' \<or> fst a = snd b' \<or> snd a' = snd b'"
	by (auto simp: card_insert_if split: if_splits)
	then have "hd as = hd bs"
	using \<open>progressing (a # as)\<close> \<open>progressing (b # bs)\<close> \<open>awalk _ (a # as) _\<close> \<open>awalk _ (b # bs) _\<close>
	unfolding \<open>a = b\<close> \<open>as = _\<close> \<open>bs = _\<close>
	by (cases b, cases a', cases b') (auto simp: progressing_Cons_Cons awalk_simps)
	then show ?thesis
	using \<open>as \<noteq> []\<close> \<open>bs \<noteq> []\<close> Cons_Cons.prems
	by (auto dest: progressing_ConsD simp: awalk_simps inner_verts_Cons intro!: Cons_Cons)
	qed
	qed simp_all

	lemma same_awalk_by_common_arc:
	assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
	assumes walk: "awalk u p v" "awalk w q x"
	assumes progress: "progressing p" "progressing q"
	assumes iv_not_in_V: "set (inner_verts p) \<inter> V = {}" "set (inner_verts q) \<inter> V = {}"
	assumes ends_in_V: "{u,v,w,x} \<subseteq> V"
	assumes arcs: "e \<in> set p" "e \<in> set q"
	shows "p = q"
	proof -
	from arcs obtain p1 p2 where p_decomp: "p = p1 @ e # p2" by (metis in_set_conv_decomp_first)
	from arcs obtain q1 q2 where q_decomp: "q = q1 @ e # q2" by (metis in_set_conv_decomp_first)

	{ define p1' q1' where "p1' = rev_path (p1 @ [e])" and "q1' = rev_path (q1 @ [e])"
	then have decomp: "p = rev_path p1' @ p2" "q = rev_path q1' @ q2"
	and "awlast u (rev_path p1') = snd e" "awlast w (rev_path q1') = snd e"
	using p_decomp q_decomp walk by (auto simp: awlast_append awalk_verts_rev_path)
	then have walk': "awalk (snd e) p1' u" "awalk (snd e) q1' w"
	using walk by auto
	moreover have "hd p1' = hd q1'" "p1' \<noteq> []" "q1' \<noteq> []" by (auto simp: p1'_def q1'_def)
	moreover have "progressing p1'" "progressing q1'"
	using progress unfolding decomp by (auto dest: progressing_appendD1 simp: progressing_rev_path)
	moreover
	have "set (inner_verts (rev_path p1')) \<inter> V = {}" "set (inner_verts (rev_path q1')) \<inter> V = {}"
	using iv_not_in_V unfolding decomp
	by (auto intro: in_set_inner_verts_appendI_l in_set_inner_verts_appendI_r)
	then have "u \<in> V" "w \<in> V" "set (inner_verts p1') \<inter> V = {}" "set (inner_verts q1') \<inter> V = {}"
	using ends_in_V iv_not_in_V walk unfolding decomp
	by (auto simp: inner_verts_rev_path)
	ultimately have "p1' = q1'" by (rule same_awalk_by_same_end[OF V]) }
	moreover
	{ define p2' q2' where "p2' = e # p2" and "q2' = e # q2"
	then have decomp: "p = p1 @ p2'" "q = q1 @ q2'"
	using p_decomp q_decomp by (auto simp: awlast_append)
	moreover
	have "awlast u p1 = fst e" "awlast w q1 = fst e"
	using p_decomp q_decomp walk by auto
	ultimately
	have *: "awalk (fst e) p2' v" "awalk (fst e) q2' x"
	using walk by auto
	moreover have "hd p2' = hd q2'" "p2' \<noteq> []" "q2' \<noteq> []" by (auto simp: p2'_def q2'_def)
	moreover have "progressing p2'" "progressing q2'"
	using progress unfolding decomp by (auto dest: progressing_appendD2)
	moreover
	have "v \<in> V" "x \<in> V" "set (inner_verts p2') \<inter> V = {}" "set (inner_verts q2') \<inter> V = {}"
	using ends_in_V iv_not_in_V unfolding decomp
	by (auto intro: in_set_inner_verts_appendI_l in_set_inner_verts_appendI_r)
	ultimately have "p2' = q2'" by (rule same_awalk_by_same_end[OF V]) }
	ultimately
	show "p = q" using p_decomp q_decomp by (auto simp: rev_path_eq)
	qed

	lemma same_gen_iapath_by_common_arc:
	assumes V: "verts3 G \<subseteq> V" "V \<subseteq> pverts G"
	assumes path: "gen_iapath V u p v" "gen_iapath V w q x"
	assumes arcs: "e \<in> set p" "e \<in> set q"
	shows "p = q"
	proof -
	from path have awalk: "awalk u p v" "awalk w q x" "progressing p" "progressing q"
	and in_V: "set (inner_verts p) \<inter> V = {}" "set (inner_verts q) \<inter> V = {}" "{u,v,w,x} \<subseteq> V"
	by (auto simp: gen_iapath_def apath_imp_progressing apath_def)
	from V awalk in_V arcs show ?thesis by (rule same_awalk_by_common_arc)
	qed


	end



	subsection \<open>Slim graphs\<close>

	text \<open>
	We define the notion of a slim graph. The idea is that for a slim graph @{term G}, @{term G}
	is a subdivision of @{term "contr_graph G"}.
	\<close>

	context pair_pre_digraph begin

	definition (in pair_pre_digraph) is_slim :: "'a set \<Rightarrow> bool" where
	"is_slim V \<equiv>
	(\<forall>v \<in> pverts G. v \<in> V \<or>
	in_degree G v \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> v \<in> set (awalk_verts x p))) \<and>
	(\<forall>e \<in> parcs G. fst e \<noteq> snd e \<and> (\<exists>x p y. gen_iapath V x p y \<and> e \<in> set p)) \<and>
	(\<forall>u v p q. (gen_iapath V u p v \<and> gen_iapath V u q v) \<longrightarrow> p = q) \<and>
	V \<subseteq> pverts G"

	definition direct_arc :: "'a \<times> 'a \<Rightarrow> 'a \<times> 'a" where
	"direct_arc uv \<equiv> SOME e. {fst uv , snd uv} = {fst e, snd e}"

	definition choose_iapath :: "'a \<Rightarrow> 'a \<Rightarrow> ('a \<times> 'a) awalk" where
	"choose_iapath u v \<equiv> (let
	chosen_path = (\<lambda>u v. SOME p. iapath u p v)
	in if direct_arc (u,v) = (u,v) then chosen_path u v else rev_path (chosen_path v u))"

	(* XXX: Replace "parcs (contr_graph G)" by its definition *)
	definition slim_paths :: "('a \<times> ('a \<times> 'a) awalk \<times> 'a) set" where
	"slim_paths \<equiv> (\<lambda>e. (fst e, choose_iapath (fst e) (snd e), snd e)) ` parcs (contr_graph G)"

	definition slim_verts :: "'a set" where
	"slim_verts \<equiv> verts3 G \<union> (\<Union>(u,p,_) \<in> slim_paths. set (awalk_verts u p))"

	definition slim_arcs :: "'a rel" where
	"slim_arcs \<equiv> \<Union>(_,p,_) \<in> slim_paths. set p"

	text \<open>Computes a slim subgraph for an arbitrary @{term pair_digraph}\<close>
	definition slim :: "'a pair_pre_digraph" where
	"slim \<equiv> \<lparr> pverts = slim_verts, parcs = slim_arcs \<rparr>"

	end

	lemma (in wf_digraph) iapath_dist_ends: "\<And>u p v. iapath u p v \<Longrightarrow> u \<noteq> v"
	unfolding pre_digraph.gen_iapath_def by (metis apath_ends)


	context pair_sym_digraph begin

	lemma choose_iapath:
	assumes "\<exists>p. iapath u p v"
	shows "iapath u (choose_iapath u v) v"
	proof (cases "direct_arc (u,v) = (u,v)")
	define chosen where "chosen u v = (SOME p. iapath u p v)" for u v
	{ case True
	have "iapath u (chosen u v) v"
	unfolding chosen_def by (rule someI_ex) (rule assms)
	then show ?thesis using True by (simp add: choose_iapath_def chosen_def) }

	{ case False
	from assms obtain p where "iapath u p v" by auto
	then have "iapath v (rev_path p) u"
	by (simp add: gen_iapath_rev_path)
	then have "iapath v (chosen v u) u"
	unfolding chosen_def by (rule someI)
	then show ?thesis using False
	by (simp add: choose_iapath_def chosen_def gen_iapath_rev_path) }
	qed

	lemma slim_simps: "pverts slim = slim_verts" "parcs slim = slim_arcs"
	by (auto simp: slim_def)

	lemma slim_paths_in_G_E:
	assumes "(u,p,v) \<in> slim_paths" obtains "iapath u p v" "u \<noteq> v"
	using assms choose_iapath
	by (fastforce simp: gen_contr_graph_def slim_paths_def dest: iapath_dist_ends)

	lemma verts_slim_in_G: "pverts slim \<subseteq> pverts G"
	by (auto simp: slim_simps slim_verts_def verts3_def gen_iapath_def apath_def
	elim!: slim_paths_in_G_E elim!: awalkE)

	lemma verts3_in_slim_G[simp]:
	assumes "x \<in> verts3 G" shows "x \<in> pverts slim"
	using assms by (auto simp: slim_simps slim_verts_def)

	lemma arcs_slim_in_G: "parcs slim \<subseteq> parcs G"
	by (auto simp: slim_simps slim_arcs_def gen_iapath_def apath_def
	elim!: slim_paths_in_G_E elim!: awalkE)

	lemma slim_paths_in_slimG:
	assumes "(u,p,v) \<in> slim_paths"
	shows "pre_digraph.gen_iapath slim (verts3 G) u p v \<and> p \<noteq> []"
	proof -
	from assms have arcs: "\<And>e. e \<in> set p \<Longrightarrow> e \<in> parcs slim"
	by (auto simp: slim_simps slim_arcs_def)
	moreover
	from assms have "gen_iapath (verts3 G) u p v" and "p \<noteq> []"
	by (auto simp: gen_iapath_def elim!: slim_paths_in_G_E)
	ultimately show ?thesis
	by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
	inner_verts_with_proj_def)
	qed

	lemma direct_arc_swapped:
	"direct_arc (u,v) = direct_arc (v,u)"
	by (simp add: direct_arc_def insert_commute)

	lemma direct_arc_chooses:
	fixes u v :: 'a shows "direct_arc (u,v) = (u,v) \<or> direct_arc (u,v) = (v,u)"
	proof -
	define f :: "'a set \<Rightarrow> 'a \<times> 'a"
	where "f X = (SOME e. X = {fst e,snd e})" for X

	have "\<exists>p::'a \<times> 'a. {u,v} = {fst p, snd p}" by (rule exI[where x="(u,v)"]) auto
	then have "{u,v} = {fst (f {u,v}), snd (f {u,v})}"
	unfolding f_def by (rule someI_ex)
	then have "f {u,v} = (u,v) \<or> f {u,v} = (v,u)"
	by (auto simp: doubleton_eq_iff prod_eq_iff)
	then show ?thesis by (auto simp: direct_arc_def f_def)
	qed

	lemma rev_path_choose_iapath:
	assumes "u \<noteq> v"
	shows "rev_path (choose_iapath u v) = choose_iapath v u"
	using assms direct_arc_chooses[of u v]
	by (auto simp: choose_iapath_def direct_arc_swapped)

	lemma no_loops_in_iapath: "gen_iapath V u p v \<Longrightarrow> a \<in> set p \<Longrightarrow> fst a \<noteq> snd a"
	by (auto simp: gen_iapath_def no_loops_in_apath)

	lemma pair_bidirected_digraph_slim: "pair_bidirected_digraph slim"
	proof
	fix e assume A: "e \<in> parcs slim"
	then obtain u p v where "(u,p,v) \<in> slim_paths" "e \<in> set p" by (auto simp: slim_simps slim_arcs_def)
	with A have "iapath u p v" by (auto elim: slim_paths_in_G_E)
	with \<open>e \<in> set p\<close> have "fst e \<in> set (awalk_verts u p)" "snd e \<in> set (awalk_verts u p)"
	by (auto simp: set_awalk_verts gen_iapath_def apath_def)
	moreover
	from \<open>_ \<in> slim_paths\<close> have "set (awalk_verts u p) \<subseteq> pverts slim"
	by (auto simp: slim_simps slim_verts_def)
	ultimately
	show "fst e \<in> pverts slim" "snd e \<in> pverts slim" by auto

	show "fst e \<noteq> snd e"
	using \<open>iapath u p v\<close> \<open>e \<in> set p \<close> by (auto dest: no_loops_in_iapath)
	next
	{ fix e assume "e \<in> parcs slim"
	then obtain u p v where "(u,p,v) \<in> slim_paths" and "e \<in> set p"
	by (auto simp: slim_simps slim_arcs_def)
	moreover
	then have "iapath u p v" and "p \<noteq> []" and "u \<noteq> v" by (auto elim: slim_paths_in_G_E)
	then have "iapath v (rev_path p) u" and "rev_path p \<noteq> []" and "v \<noteq> u"
	by (auto simp: gen_iapath_rev_path)
	then have "(v,u) \<in> parcs (contr_graph G)"
	by (auto simp: gen_contr_graph_def)
	moreover
	from \<open>iapath u p v\<close> have "u \<noteq> v"
	by (auto simp: gen_iapath_def dest: apath_nonempty_ends)
	ultimately
	have "(v, rev_path p, u) \<in> slim_paths"
	by (auto simp: slim_paths_def rev_path_choose_iapath intro: rev_image_eqI)
	moreover
	from \<open>e \<in> set p\<close> have "(snd e, fst e) \<in> set (rev_path p)"
	by (induct p) auto
	ultimately have "(snd e, fst e) \<in> parcs slim"
	by (auto simp: slim_simps slim_arcs_def) }
	then show "symmetric slim"
	unfolding symmetric_conv by simp (metis fst_conv snd_conv)
	qed


	lemma (in pair_pseudo_graph) pair_graph_slim: "pair_graph slim"
	proof -
	interpret slim: pair_bidirected_digraph slim by (rule pair_bidirected_digraph_slim)
	show ?thesis
	proof
	show "finite (pverts slim)"
	using verts_slim_in_G finite_verts by (rule finite_subset)
	show "finite (parcs slim)"
	using arcs_slim_in_G finite_arcs by (rule finite_subset)
	qed
	qed

	lemma subgraph_slim: "subgraph slim G"
	proof (rule subgraphI)
	interpret H: pair_bidirected_digraph "slim"
	by (rule pair_bidirected_digraph_slim) intro_locales

	show "verts slim \<subseteq> verts G" "arcs slim \<subseteq> arcs G"
	by (auto simp: verts_slim_in_G arcs_slim_in_G)
	show "compatible G slim" ..
	show "wf_digraph slim" "wf_digraph G"
	by unfold_locales
	qed

	lemma giapath_if_slim_giapath:
	assumes "pre_digraph.gen_iapath slim (verts3 G) u p v"
	shows "gen_iapath (verts3 G) u p v"
	using assms verts_slim_in_G arcs_slim_in_G
	by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
	inner_verts_with_proj_def)

	lemma slim_giapath_if_giapath:
	assumes "gen_iapath (verts3 G) u p v"
	shows "\<exists>p. pre_digraph.gen_iapath slim (verts3 G) u p v" (is "\<exists>p. ?P p")
	proof
	from assms have choose_arcs: "\<And>e. e \<in> set (choose_iapath u v) \<Longrightarrow> e \<in> parcs slim"
	by (fastforce simp: slim_simps slim_arcs_def slim_paths_def gen_contr_graph_def)
	moreover
	from assms have choose: "iapath u (choose_iapath u v) v"
	by (intro choose_iapath) (auto simp: gen_iapath_def)
	ultimately show "?P (choose_iapath u v)"
	by (auto simp: pre_digraph.gen_iapath_def pre_digraph.apath_def pre_digraph.awalk_def
	inner_verts_with_proj_def)
	qed

	lemma contr_graph_slim_eq:
	"gen_contr_graph slim (verts3 G) = contr_graph G"
	using giapath_if_slim_giapath slim_giapath_if_giapath by (fastforce simp: gen_contr_graph_def)

	end

	context pair_pseudo_graph begin

	lemma verts3_slim_in_verts3:
	assumes "v \<in> verts3 slim" shows "v \<in> verts3 G"
	proof -
	from assms have "2 < in_degree slim v" by (auto simp: verts3_def)
	also have "\<dots> \<le> in_degree G v" using subgraph_slim by (rule subgraph_in_degree)
	finally show ?thesis using assms subgraph_slim by (fastforce simp: verts3_def)
	qed

	lemma slim_is_slim:
	"pair_pre_digraph.is_slim slim (verts3 G)"
	proof (unfold pair_pre_digraph.is_slim_def, safe)
	interpret S: pair_graph slim by (rule pair_graph_slim)
	{ fix v assume "v \<in> pverts slim" "v \<notin> verts3 G"
	then have "in_degree G v \<le> 2"
	using verts_slim_in_G by (auto simp: verts3_def)
	then show "in_degree slim v \<le> 2"
	using subgraph_in_degree[OF subgraph_slim, of v] by fastforce
	next
	fix w assume "w \<in> pverts slim" "w \<notin> verts3 G"
	then obtain u p v where upv: "(u, p, v) \<in> slim_paths" "w \<in> set (awalk_verts u p)"
	by (auto simp: slim_simps slim_verts_def)
	moreover
	then have "S.gen_iapath (verts3 G) u p v"
	using slim_paths_in_slimG by auto
	ultimately
	show "\<exists>x q y. S.gen_iapath (verts3 G) x q y
	\<and> w \<in> set (awalk_verts x q)"
	by auto
	next
	fix u v assume "(u,v) \<in> parcs slim"
	then obtain x p y where "(x, p, y) \<in> slim_paths" "(u,v) \<in> set p"
	by (auto simp: slim_simps slim_arcs_def)
	then have "S.gen_iapath (verts3 G) x p y \<and> (u,v) \<in> set p"
	using slim_paths_in_slimG by auto
	then show "\<exists>x p y. S.gen_iapath (verts3 G) x p y \<and> (u,v) \<in> set p"
	by blast
	next
	fix u v assume "(u,v) \<in> parcs slim" "fst (u,v) = snd (u,v)"
	then show False by (auto simp: S.no_loops')
	next
	fix u v p q
	assume paths: "S.gen_iapath (verts3 G) u p v"
	"S.gen_iapath (verts3 G) u q v"

	have V: "verts3 slim \<subseteq> verts3 G" "verts3 G \<subseteq> pverts slim"
	by (auto simp: verts3_slim_in_verts3)

	have "p = [] \<or> q = [] \<Longrightarrow> p = q" using paths
	by (auto simp: S.gen_iapath_def dest: S.apath_ends)
	moreover
	{ assume "p \<noteq> []" "q \<noteq> []"
	{ fix u p v assume "p \<noteq> []" and path: "S.gen_iapath (verts3 G) u p v"
	then obtain e where "e \<in> set p" by (metis last_in_set)
	then have "e \<in> parcs slim" using path by (auto simp: S.gen_iapath_def S.apath_def)
	then obtain x r y where "(x,r,y) \<in> slim_paths" "e \<in> set r"
	by (auto simp: slim_simps slim_arcs_def)
	then have "S.gen_iapath (verts3 G) x r y" by (metis slim_paths_in_slimG)
	with \<open>e \<in> set r\<close> \<open>e \<in> set p\<close> path have "p = r"
	by (auto intro: S.same_gen_iapath_by_common_arc[OF V])
	then have "x = u" "y = v" using path \<open>S.gen_iapath (verts3 G) x r y\<close> \<open>p = r\<close> \<open>p \<noteq> []\<close>
	by (auto simp: S.gen_iapath_def S.apath_def dest: S.awalk_ends)
	then have "(u,p,v) \<in> slim_paths" using \<open>p = r\<close> \<open>(x,r,y) \<in> slim_paths\<close> by simp }
	note obt = this
	from \<open>p \<noteq> []\<close> \<open>q \<noteq> []\<close> paths have "(u,p,v) \<in> slim_paths" "(u,q,v) \<in> slim_paths"
	by (auto intro: obt)
	then have "p = q" by (auto simp: slim_paths_def)
	}
	ultimately show "p = q" by metis
	}
	qed auto

	end

	context pair_sym_digraph begin

	lemma
	assumes p: "gen_iapath (pverts G) u p v"
	shows gen_iapath_triv_path: "p = [(u,v)]"
	and gen_iapath_triv_arc: "(u,v) \<in> parcs G"
	proof -
	have "set (inner_verts p) = {}"
	proof -
	have *: "\<And>A B :: 'a set. \<lbrakk>A \<subseteq> B; A \<inter> B = {}\<rbrakk> \<Longrightarrow> A = {}" by blast
	have "set (inner_verts p) = set (awalk_verts u p) - {u, v}"
	using p by (simp add: set_inner_verts gen_iapath_def)
	also have "\<dots> \<subseteq> pverts G"
	using p unfolding gen_iapath_def apath_def awalk_conv by auto
	finally show ?thesis
	using p by (rule_tac *) (auto simp: gen_iapath_def)
	qed
	then have "inner_verts p = []" by simp
	then show "p = [(u,v)]" using p
	by (cases p) (auto simp: gen_iapath_def apath_def inner_verts_def split: if_split_asm)
	then show "(u,v) \<in> parcs G"
	using p by (auto simp: gen_iapath_def apath_def)
	qed

	lemma gen_contr_triv:
	assumes "is_slim V" "pverts G = V" shows "gen_contr_graph G V = G"
	proof -
	let ?gcg = "gen_contr_graph G V"

	from assms have "pverts ?gcg = pverts G"
	by (auto simp: gen_contr_graph_def is_slim_def)
	moreover
	have "parcs ?gcg = parcs G"
	proof (rule set_eqI, safe)
	fix u v assume "(u,v) \<in> parcs ?gcg"
	then obtain p where "gen_iapath V u p v"
	by (auto simp: gen_contr_graph_def)
	then show "(u,v) \<in> parcs G"
	using gen_iapath_triv_arc \<open>pverts G = V\<close> by auto
	next
	fix u v assume "(u,v) \<in> parcs G"
	with assms obtain x p y where path: "gen_iapath V x p y" "(u,v) \<in> set p" "u \<noteq> v"
	by (auto simp: is_slim_def)
	with \<open>pverts G = V\<close> have "p = [(x,y)]" by (intro gen_iapath_triv_path) auto
	then show "(u,v) \<in> parcs ?gcg"
	using path by (auto simp: gen_contr_graph_def)
	qed
	ultimately
	show "?gcg = G" by auto
	qed

	lemma is_slim_no_loops:
	assumes "is_slim V" "a \<in> arcs G" shows "fst a \<noteq> snd a"
	using assms by (auto simp: is_slim_def)

	end



	subsection \<open>Contraction Preserves Kuratowski-Subgraph-Property\<close>

	lemma (in pair_pseudo_graph) in_degree_contr:
	assumes "v \<in> V" and V: "verts3 G \<subseteq> V" "V \<subseteq> verts G"
	shows "in_degree (gen_contr_graph G V) v \<le> in_degree G v"
	proof -
	have fin: "finite {(u, p). gen_iapath V u p v}"
	proof -
	have "{(u, p). gen_iapath V u p v} \<subseteq> (\<lambda>(u,p,_). (u,p)) ` {(u,p,v). apath u p v}"
	by (force simp: gen_iapath_def)
	with apaths_finite_triple show ?thesis by (rule finite_surj)
	qed

	have io_snd: "inj_on snd {(u,p). gen_iapath V u p v}"
	by (rule inj_onI) (auto simp: gen_iapath_def apath_def dest: awalk_ends)

	have io_last: "inj_on last {p. \<exists>u. gen_iapath V u p v}"
	proof (rule inj_onI, safe)
	fix u1 u2 p1 p2
	assume A: "last p1 = last p2" and B: "gen_iapath V u1 p1 v" "gen_iapath V u2 p2 v"
	from B have "last p1 \<in> set p1" "last p2 \<in> set p2" by (auto simp: gen_iapath_def)
	with A have "last p1 \<in> set p1" "last p1 \<in> set p2" by simp_all
	with V[simplified] B show "p1 = p2" by (rule same_gen_iapath_by_common_arc)
	qed

	have "in_degree (gen_contr_graph G V) v = card ((\<lambda>(u,_). (u,v)) ` {(u,p). gen_iapath V u p v})"
	proof -
	have "in_arcs (gen_contr_graph G V) v = (\<lambda>(u,_). (u,v)) ` {(u,p). gen_iapath V u p v}"
	by (auto simp: gen_contr_graph_def)
	then show ?thesis unfolding in_degree_def by simp
	qed
	also have "\<dots> \<le> card {(u,p). gen_iapath V u p v}"
	using fin by (rule card_image_le)
	also have "\<dots> = card (snd ` {(u,p). gen_iapath V u p v})"
	using io_snd by (rule card_image[symmetric])
	also have "snd ` {(u,p). gen_iapath V u p v} = {p. \<exists>u. gen_iapath V u p v}"
	by (auto intro: rev_image_eqI)
	also have "card \<dots> = card (last ` ...)"
	using io_last by (rule card_image[symmetric])
	also have "\<dots> \<le> in_degree G v"
	unfolding in_degree_def
	proof (rule card_mono)
	show "last ` {p. \<exists>u. gen_iapath V u p v} \<subseteq> in_arcs G v"
	proof -
	have "\<And>u p. awalk u p v \<Longrightarrow> p \<noteq> [] \<Longrightarrow> last p \<in> parcs G"
	by (auto simp: awalk_def)
	moreover
	{ fix u p assume "awalk u p v" "p \<noteq> []"
	then have "snd (last p) = v" by (induct p arbitrary: u) (auto simp: awalk_simps) }
	ultimately
	show ?thesis unfolding in_arcs_def by (auto simp: gen_iapath_def apath_def)
	qed
	qed auto
	finally show ?thesis .
	qed

	lemma (in pair_graph) contracted_no_degree2_simp:
	assumes subd: "subdivision_pair G H"
	assumes two_less_deg2: "verts3 G = pverts G"
	shows "contr_graph H = G"
	using subd
	proof (induct rule: subdivision_pair_induct)
	case base

	{ fix e assume "e \<in> parcs G"
	then have "gen_iapath (pverts G) (fst e) [(fst e, snd e)] (snd e)" "e \<in> set [(fst e, snd e)]"
	using no_loops[of "(fst e, snd e)"] by (auto simp: gen_iapath_def apath_simps )
	then have "\<exists>u p v. gen_iapath (pverts G) u p v \<and> e \<in> set p" by blast }
	moreover
	{ fix u p v assume "gen_iapath (pverts G) u p v"
	from \<open>gen_iapath _ u p v\<close> have "p = [(u,v)]"
	unfolding gen_iapath_def apath_def
	by safe (cases p, case_tac [2] list, auto simp: awalk_simps inner_verts_def) }
	ultimately have "is_slim (verts3 G)" unfolding is_slim_def two_less_deg2
	by (blast dest: no_loops_in_iapath)
	then show ?case by (simp add: gen_contr_triv two_less_deg2)
	next
	case (divide e w H)
	let ?sH = "subdivide H e w"
	from \<open>subdivision_pair G H\<close> interpret H: pair_bidirected_digraph H
	by (rule bidirected_digraphI_subdivision)
	from divide(1,2) interpret S: pair_sym_digraph ?sH by (rule H.pair_sym_digraph_subdivide)
	obtain u v where e_conv:"e = (u,v)" by (cases e) auto
	have "contr_graph ?sH = contr_graph H"
	proof -
	have V_cond: "verts3 H \<subseteq> pverts H" by (auto simp: verts3_def)
	have "verts3 H = verts3 ?sH"
	using divide by (simp add: H.verts3_subdivide)
	then have v: "pverts (contr_graph ?sH) = pverts (contr_graph H)"
	by (auto simp: gen_contr_graph_def)
	moreover
	then have "parcs (contr_graph ?sH) = parcs (contr_graph H)"
	unfolding gen_contr_graph_def
	by (auto dest: H.gen_iapath_co_path[OF divide(1,2) V_cond]
	H.gen_iapath_sd_path[OF divide(1,2) V_cond])
	ultimately show ?thesis by auto
	qed
	then show ?case using divide by simp
	qed

	(* could be generalized *)
	lemma verts3_K33:
	assumes "K\<^bsub>3,3\<^esub> (with_proj G)"
	shows "verts3 G = verts G"
	proof -
	{ fix v assume "v \<in> pverts G"
	from assms obtain U V where cards: "card U = 3" "card V=3"
	and UV: "U \<inter> V = {}" "pverts G = U \<union> V" "parcs G = U \<times> V \<union> V \<times> U"
	unfolding complete_bipartite_digraph_pair_def by blast
	have "2 < in_degree G v"
	proof (cases "v \<in> U")
	case True
	then have "in_arcs G v = V \<times> {v}" using UV by fastforce
	then show ?thesis using cards by (auto simp: card_cartesian_product in_degree_def)
	next
	case False
	then have "in_arcs G v = U \<times> {v}" using \<open>v \<in> _\<close> UV by fastforce
	then show ?thesis using cards by (auto simp: card_cartesian_product in_degree_def)
	qed }
	then show ?thesis by (auto simp: verts3_def)
	qed

	(* could be generalized *)
	lemma verts3_K5:
	assumes "K\<^bsub>5\<^esub> (with_proj G)"
	shows "verts3 G = verts G"
	proof -
	interpret pgG: pair_graph G using assms by (rule pair_graphI_complete)
	{ fix v assume "v \<in> pverts G"
	have "2 < (4 :: nat)" by simp
	also have "4 = card (pverts G - {v})"
	using assms \<open>v \<in> pverts G\<close> unfolding complete_digraph_def by auto
	also have "pverts G - {v} = {u \<in> pverts G. u \<noteq> v}"
	by auto
	also have "card \<dots> = card ({u \<in> pverts G. u \<noteq> v} \<times> {v})" (is "_ = card ?A")
	by auto
	also have "?A = in_arcs G v"
	using assms \<open>v \<in> pverts G\<close> unfolding complete_digraph_def by safe auto
	also have "card \<dots> = in_degree G v"
	unfolding in_degree_def ..
	finally have "2 < in_degree G v" . }
	then show ?thesis unfolding verts3_def by auto
	qed

	lemma K33_contractedI:
	assumes subd: "subdivision_pair G H"
	assumes k33: "K\<^bsub>3,3\<^esub> G"
	shows "K\<^bsub>3,3\<^esub> (contr_graph H)"
	proof -
	interpret pgG: pair_graph G using k33 by (rule pair_graphI_complete_bipartite)
	show ?thesis
	using assms by (auto simp: pgG.contracted_no_degree2_simp verts3_K33)
	qed

	lemma K5_contractedI:
	assumes subd: "subdivision_pair G H"
	assumes k5: "K\<^bsub>5\<^esub> G"
	shows "K\<^bsub>5\<^esub> (contr_graph H)"
	proof -
	interpret pgG: pair_graph G using k5 by (rule pair_graphI_complete)
	show ?thesis
	using assms by (auto simp add: pgG.contracted_no_degree2_simp verts3_K5)
	qed



	subsection \<open>Final proof\<close>

	context pair_sym_digraph begin


	lemma gcg_subdivide_eq:
	assumes mem: "e \<in> parcs G" "w \<notin> pverts G"
	assumes V: "V \<subseteq> pverts G"
	shows "gen_contr_graph (subdivide G e w) V = gen_contr_graph G V"
	proof -
	interpret sdG: pair_sym_digraph "subdivide G e w"
	using mem by (rule pair_sym_digraph_subdivide)
	{ fix u p v assume "sdG.gen_iapath V u p v"
	have "gen_iapath V u (co_path e w p) v"
	using mem V \<open>sdG.gen_iapath V u p v\<close> by (rule gen_iapath_co_path)
	then have "\<exists>p. gen_iapath V u p v" ..
	} note A = this
	moreover
	{ fix u p v assume "gen_iapath V u p v"
	have "sdG.gen_iapath V u (sd_path e w p) v"
	using mem V \<open>gen_iapath V u p v\<close> by (rule gen_iapath_sd_path)
	then have "\<exists>p. sdG.gen_iapath V u p v" ..
	} note B = this
	ultimately show ?thesis using assms by (auto simp: gen_contr_graph_def)
	qed

	lemma co_path_append:
	assumes "[last p1, hd p2] \<notin> {[(fst e,w),(w,snd e)], [(snd e,w),(w,fst e)]}"
	shows "co_path e w (p1 @ p2) = co_path e w p1 @ co_path e w p2"
	using assms
	proof (induct p1 rule: co_path_induct)
	case single then show ?case by (cases p2) auto
	next
	case (co e1 e2 es) then show ?case by (cases es) auto
	next
	case (corev e1 e2 es) then show ?case by (cases es) auto
	qed auto

	lemma exists_co_path_decomp1:
	assumes mem: "e \<in> parcs G" "w \<notin> pverts G"
	assumes p: "pre_digraph.apath (subdivide G e w) u p v" "(fst e, w) \<in> set p" "w \<noteq> v"
	shows "\<exists>p1 p2. p = p1 @ (fst e, w) # (w, snd e) # p2"
	proof -
	let ?sdG = "subdivide G e w"
	interpret sdG: pair_sym_digraph ?sdG
	using mem by (rule pair_sym_digraph_subdivide)
	obtain p1 p2 z where p_decomp: "p = p1 @ (fst e, w) # (w, z) # p2" "fst e \<noteq> z" "w \<noteq> z"
	by atomize_elim (rule sdG.apath_succ_decomp[OF p])
	then have "(fst e,w) \<in> parcs ?sdG" "(w, z) \<in> parcs ?sdG"
	using p by (auto simp: sdG.apath_def)
	with \<open>fst e \<noteq> z\<close> have "z = snd e"
	using mem by (cases e) (auto simp: wellformed')
	with p_decomp show ?thesis by fast
	qed

	lemma is_slim_if_subdivide:
	assumes "pair_pre_digraph.is_slim (subdivide G e w) V"
	assumes mem1: "e \<in> parcs G" "w \<notin> pverts G" and mem2: "w \<notin> V"
	shows "is_slim V"
	proof -
	let ?sdG = "subdivide G e w"
	interpret sdG: pair_sym_digraph "subdivide G e w"
	using mem1 by (rule pair_sym_digraph_subdivide)
	obtain u v where "e = (u,v)" by (cases e) auto
	with mem1 have "u \<in> pverts G" "v \<in> pverts G" by (auto simp: wellformed')
	with mem1 have "u \<noteq> w" "v \<noteq> w" by auto

	let ?w_parcs = "{(u,w), (v,w), (w,u), (w, v)}"
	have sdg_new_parcs: "?w_parcs \<subseteq> parcs ?sdG"
	using \<open>e = (u,v)\<close> by auto
	have sdg_no_parcs: "(u,v) \<notin> parcs ?sdG" "(v,u) \<notin> parcs ?sdG"
	using \<open>e = (u,v)\<close> \<open>u \<noteq> w\<close> \<open>v \<noteq> w\<close> by auto

	{ fix z assume A: "z \<in> pverts G"
	have "in_degree ?sdG z = in_degree G z"
	proof -
	{ assume "z \<noteq> u" "z \<noteq> v"
	then have "in_arcs ?sdG z = in_arcs G z"
	using \<open>e = (u,v)\<close> mem1 A by auto
	then have "in_degree ?sdG z = in_degree G z" by (simp add: in_degree_def) }
	moreover
	{ assume "z = u"
	then have "in_arcs G z = in_arcs ?sdG z \<union> {(v,u)} - {(w,u)}"
	using \<open>e = (u,v)\<close> mem1 by (auto simp: intro: arcs_symmetric wellformed')
	moreover
	have "card (in_arcs ?sdG z \<union> {(v,u)} - {(w,u)}) = card (in_arcs ?sdG z)"
	using sdg_new_parcs sdg_no_parcs \<open>z = u\<close> by (cases "finite (in_arcs ?sdG z)") (auto simp: in_arcs_def)
	ultimately have "in_degree ?sdG z= in_degree G z" by (simp add: in_degree_def) }
	moreover
	{ assume "z = v"
	then have "in_arcs G z = in_arcs ?sdG z \<union> {(u,v)} - {(w,v)}"
	using \<open>e = (u,v)\<close> mem1 A by (auto simp: wellformed')
	moreover
	have "card (in_arcs ?sdG z \<union> {(u,v)} - {(w,v)}) = card (in_arcs ?sdG z)"
	using sdg_new_parcs sdg_no_parcs \<open>z = v\<close> by (cases "finite (in_arcs ?sdG z)") (auto simp: in_arcs_def)
	ultimately have "in_degree ?sdG z= in_degree G z" by (simp add: in_degree_def) }
	ultimately show ?thesis by metis
	qed }
	note in_degree_same = this

	have V_G: "V \<subseteq> pverts G" "verts3 G \<subseteq> V"
	proof -
	have "V \<subseteq> pverts ?sdG" "pverts ?sdG = pverts G \<union> {w}" "verts3 ?sdG \<subseteq> V" "verts3 G \<subseteq> verts3 ?sdG"
	using \<open>sdG.is_slim V\<close> \<open>e = (u,v)\<close> in_degree_same mem1
	unfolding sdG.is_slim_def verts3_def
	by (fast, simp, fastforce, force)
	then show "V \<subseteq> pverts G" "verts3 G \<subseteq> V" using \<open>w \<notin> V\<close> by auto
	qed

	have pverts: "\<forall>v\<in>pverts G. v \<in> V \<or> in_degree G v \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> v \<in> set (awalk_verts x p))"
	proof -
	{ fix z assume A: "z \<in> pverts G" "z \<notin> V"
	have "z \<in> pverts ?sdG" using \<open>e = (u,v)\<close> A mem1 by auto
	then have "in_degree ?sdG z \<le> 2"
	using \<open>sdG.is_slim V\<close> A by (auto simp: sdG.is_slim_def)
	with in_degree_same[OF \<open>z \<in> pverts G\<close>] have idg: "in_degree G z \<le> 2" by auto

	from A have "z \<in> pverts ?sdG" "z \<notin> V" using \<open>e = (u,v)\<close> mem1 by auto
	then obtain x' q y' where "sdG.gen_iapath V x' q y'" "z \<in> set (sdG.awalk_verts x' q)"
	using \<open>sdG.is_slim V\<close> unfolding sdG.is_slim_def by metis
	then have "gen_iapath V x' (co_path e w q) y'" "z \<in> set (awalk_verts x' (co_path e w q))"
	using A mem1 V_G by (auto simp: set_awalk_verts_co_path' intro: gen_iapath_co_path)
	with idg have "in_degree G z \<le> 2 \<and> (\<exists>x p y. gen_iapath V x p y \<and> z \<in> set (awalk_verts x p))"
	by metis }
	then show ?thesis by auto
	qed

	have parcs: "\<forall>e\<in>parcs G. fst e \<noteq> snd e \<and> (\<exists>x p y. gen_iapath V x p y \<and> e \<in> set p)"
	proof (intro ballI conjI)
	fix e' assume "e' \<in> parcs G"

	show "(\<exists>x p y. gen_iapath V x p y \<and> e' \<in> set p)"
	proof (cases "e' \<in> parcs ?sdG")
	case True
	then obtain x p y where "sdG.gen_iapath V x p y" "e' \<in> set p"
	using \<open>sdG.is_slim V\<close> by (auto simp: sdG.is_slim_def)
	with \<open>e \<in> parcs G\<close> \<open>w \<notin> pverts G\<close> V_G have "gen_iapath V x (co_path e w p) y"
	by (auto intro: gen_iapath_co_path)

	from \<open>e' \<in> parcs G\<close> have "e' \<notin> ?w_parcs" using mem1 by (auto simp: wellformed')
	with \<open>e' \<in> set p\<close> have "e' \<in> set (co_path e w p)"
	by (induct p rule: co_path_induct) (force simp: \<open>e = (u,v)\<close>)+
	then show "\<exists>x p y. gen_iapath V x p y \<and> e' \<in> set p "
	using \<open>gen_iapath V x (co_path e w p) y\<close> by fast
	next
	assume "e' \<notin> parcs ?sdG"
	define a b where "a = fst e'" and "b = snd e'"
	then have "e' = (a,b)" and ab: "(a,b) = (u,v) \<or> (a,b) = (v,u)"
	using \<open>e' \<in> parcs G\<close> \<open>e' \<notin> parcs ?sdG\<close> \<open>e = (u,v)\<close> mem1 by auto
	obtain x p y where "sdG.gen_iapath V x p y" "(a,w) \<in> set p"
	using \<open>sdG.is_slim V\<close> sdg_new_parcs ab by (auto simp: sdG.is_slim_def)
	with \<open>e \<in> parcs G\<close> \<open>w \<notin> pverts G\<close> V_G have "gen_iapath V x (co_path e w p) y"
	by (auto intro: gen_iapath_co_path)

	have "(a,b) \<in> parcs G" "subdivide G (a,b) w = subdivide G e w"
	using mem1 \<open>e = (u,v)\<close> \<open>e' = (a,b)\<close> ab
	by (auto intro: arcs_symmetric simp: subdivide.simps)
	then have "pre_digraph.apath (subdivide G (a,b) w) x p y" "w \<noteq> y"
	using mem2 \<open>sdG.gen_iapath V x p y\<close> by (auto simp: sdG.gen_iapath_def)
	then obtain p1 p2 where p: "p = p1 @ (a,w) # (w,b) # p2"
	using exists_co_path_decomp1 \<open>(a,b) \<in> parcs G\<close> \<open>w \<notin> pverts G\<close> \<open>(a,w) \<in> set p\<close> \<open>w \<noteq> y\<close>
	by atomize_elim auto
	moreover
	from p have "co_path e w ((a,w) # (w,b) # p2) = (a,b) # co_path e w p2"
	unfolding \<open>e = (u,v)\<close> using ab by auto
	ultimately
	have "(a,b) \<in> set (co_path e w p)"
	unfolding \<open>e = (u,v)\<close> using ab \<open>u \<noteq> w\<close> \<open>v \<noteq> w\<close>
	by (induct p rule: co_path_induct) (auto simp: co_path_append)
	then show ?thesis
	using \<open>gen_iapath V x (co_path e w p) y\<close> \<open>e' = (a,b)\<close> by fast
	qed
	then show "fst e' \<noteq> snd e'" by (blast dest: no_loops_in_iapath)
	qed

	have unique: "\<forall>u v p q. (gen_iapath V u p v \<and> gen_iapath V u q v) \<longrightarrow> p = q"
	proof safe
	fix x y p q assume A: "gen_iapath V x p y" "gen_iapath V x q y"
	then have "set p \<subseteq> parcs G" "set q \<subseteq> parcs G"
	by (auto simp: gen_iapath_def apath_def)
	then have w_p: "(u,w) \<notin> set p" "(v,w) \<notin> set p" and w_q: "(u,w) \<notin> set q" "(v,w) \<notin> set q"
	using mem1 by (auto simp: wellformed')

	from A have "sdG.gen_iapath V x (sd_path e w p) y" "sdG.gen_iapath V x (sd_path e w q) y"
	using mem1 V_G by (auto intro: gen_iapath_sd_path)
	then have "sd_path e w p = sd_path e w q"
	using \<open>sdG.is_slim V\<close> unfolding sdG.is_slim_def by metis
	then have "co_path e w (sd_path e w p) = co_path e w (sd_path e w q)" by simp
	then show "p = q" using w_p w_q \<open>e = (u,v)\<close> by (simp add: co_sd_id)
	qed

	from pverts parcs V_G unique show ?thesis by (auto simp: is_slim_def)
	qed

	end

	context pair_pseudo_graph begin

	lemma subdivision_gen_contr:
	assumes "is_slim V"
	shows "subdivision_pair (gen_contr_graph G V) G"
	using assms using pair_pseudo_graph
	proof (induct "card (pverts G - V)" arbitrary: G)
	case 0
	interpret G: pair_pseudo_graph G by fact
	have "pair_bidirected_digraph G"
	using G.pair_sym_arcs 0 by unfold_locales (auto simp: G.is_slim_def)
	with 0 show ?case
	by (auto intro: subdivision_pair_intros simp: G.gen_contr_triv G.is_slim_def)
	next
	case (Suc n)
	interpret G: pair_pseudo_graph G by fact

	from \<open>Suc n = card (pverts G - V)\<close>
	have "pverts G - V \<noteq> {}"
	by (metis Nat.diff_le_self Suc_n_not_le_n card_Diff_subset_Int diff_Suc_Suc empty_Diff finite.emptyI inf_bot_left)
	then obtain w where "w \<in> pverts G - V" by auto
	then obtain x q y where q: "G.gen_iapath V x q y" "w \<in> set (G.awalk_verts x q)" "in_degree G w \<le> 2"
	using \<open>G.is_slim V\<close> by (auto simp: G.is_slim_def)
	then have "w \<noteq> x" "w \<noteq> y" "w \<notin> V" using \<open>w \<in> pverts G - V\<close> by (auto simp: G.gen_iapath_def)
	then obtain e where "e \<in> set q" "snd e = w"
	using \<open>w \<in> pverts G - V\<close> q
	unfolding G.gen_iapath_def G.apath_def G.awalk_conv
	by (auto simp: G.awalk_verts_conv')
	moreover define u where "u = fst e"
	ultimately obtain q1 q2 v where q_decomp: "q = q1 @ (u, w) # (w, v) # q2" "u \<noteq> v" "w \<noteq> v"
	using q \<open>w \<noteq> y\<close> unfolding G.gen_iapath_def by atomize_elim (rule G.apath_succ_decomp, auto)
	with q have qi_walks: "G.awalk x q1 u" "G.awalk v q2 y"
	by (auto simp: G.gen_iapath_def G.apath_def G.awalk_Cons_iff)

	from q q_decomp have uvw_arcs1: "(u,w) \<in> parcs G" "(w,v) \<in> parcs G"
	by (auto simp: G.gen_iapath_def G.apath_def)
	then have uvw_arcs2: "(w,u) \<in> parcs G" "(v,w) \<in> parcs G"
	by (blast intro: G.arcs_symmetric)+

	have "u \<noteq> w" "v \<noteq> w" using q_decomp q
	by (auto simp: G.gen_iapath_def G.apath_append_iff G.apath_simps)

	have in_arcs: "in_arcs G w = {(u,w), (v,w)}"
	proof -
	have "{(u,w), (v,w)} \<subseteq> in_arcs G w"
	- using uvw_arcs1 uvw_arcs2 by (auto simp: )
	+ using uvw_arcs1 uvw_arcs2 by auto
	moreover note \<open>in_degree G w \<le> 2\<close>
	moreover have "card {(u,w), (v,w)} = 2" using \<open>u \<noteq> v\<close> by auto
	ultimately
	show ?thesis by - (rule card_seteq[symmetric], auto simp: in_degree_def)
	qed
	have out_arcs: "out_arcs G w \<subseteq> {(w,u), (w,v)}" (is "?L \<subseteq> ?R")
	proof
	fix e assume "e \<in> out_arcs G w"
	then have "(snd e, fst e) \<in> in_arcs G w"
	by (auto intro: G.arcs_symmetric)
	then show "e \<in> {(w, u), (w, v)}" using in_arcs by auto
	qed

	have "(u,v) \<notin> parcs G"
	proof
	assume "(u,v) \<in> parcs G"
	have "G.gen_iapath V x (q1 @ (u,v) # q2) y"
	proof -
	have awalk': "G.awalk x (q1 @ (u,v) # q2) y"
	using qi_walks \<open>(u,v) \<in> parcs G\<close>
	by (auto simp: G.awalk_simps)

	have "G.awalk x q y" using \<open>G.gen_iapath V x q y\<close> by (auto simp: G.gen_iapath_def G.apath_def)

	have "distinct (G.awalk_verts x (q1 @ (u,v) # q2))"
	using awalk' \<open>G.gen_iapath V x q y\<close> unfolding q_decomp
	by (auto simp: G.gen_iapath_def G.apath_def G.awalk_verts_append)
	moreover
	have "set (G.inner_verts (q1 @ (u,v) # q2)) \<subseteq> set (G.inner_verts q)"
	using awalk' \<open>G.awalk x q y\<close> unfolding q_decomp
	by (auto simp: butlast_append G.inner_verts_conv[of _ x] G.awalk_verts_append
	intro: in_set_butlast_appendI)
	then have "set (G.inner_verts (q1 @ (u,v) # q2)) \<inter> V = {}"
	using \<open>G.gen_iapath V x q y\<close> by (auto simp: G.gen_iapath_def)
	ultimately show ?thesis using awalk' \<open>G.gen_iapath V x q y\<close> by (simp add: G.gen_iapath_def G.apath_def)
	qed
	then have "(q1 @ (u,v) # q2) = q"
	using \<open>G.gen_iapath V x q y\<close> \<open>G.is_slim V\<close> unfolding G.is_slim_def by metis
	then show False unfolding q_decomp by simp
	qed
	then have "(v,u) \<notin> parcs G" by (auto intro: G.arcs_symmetric)

	define G' where "G' = \<lparr>pverts = pverts G - {w},
	parcs = {(u,v), (v,u)} \<union> (parcs G - {(u,w), (w,u), (v,w), (w,v)})\<rparr>"

	have mem_G': "(u,v) \<in> parcs G'" "w \<notin> pverts G'" by (auto simp: G'_def)

	interpret pd_G': pair_fin_digraph G'
	proof
	fix e assume A: "e \<in> parcs G'"
	have "e \<in> parcs G \<and> e \<noteq> (u, w) \<and> e \<noteq> (w, u) \<and> e \<noteq> (v, w) \<and> e \<noteq> (w, v) \<Longrightarrow> fst e \<noteq> w"
	"e \<in> parcs G \<and> e \<noteq> (u, w) \<and> e \<noteq> (w, u) \<and> e \<noteq> (v, w) \<and> e \<noteq> (w, v) \<Longrightarrow> snd e \<noteq> w"
	using out_arcs in_arcs by auto
	with A uvw_arcs1 show "fst e \<in> pverts G'" "snd e \<in> pverts G'"
	using \<open>u \<noteq> w\<close> \<open>v \<noteq> w\<close> by (auto simp: G'_def G.wellformed')
	next
	qed (auto simp: G'_def arc_to_ends_def)

	interpret spd_G': pair_pseudo_graph G'
	proof (unfold_locales, simp add: symmetric_def)
	have "sym {(u,v), (v,u)}" "sym (parcs G)" "sym {(u, w), (w, u), (v, w), (w, v)}"
	using G.sym_arcs by (auto simp: symmetric_def sym_def)
	then have "sym ({(u,v), (v,u)} \<union> (parcs G - {(u,w), (w,u), (v,w), (w,v)}))"
	by (intro sym_Un) (auto simp: sym_diff)
	then show "sym (parcs G')" unfolding G'_def by simp
	qed

	have card_G': "n = card (pverts G' - V)"
	proof -
	have "pverts G - V = insert w (pverts G' - V)"
	using \<open>w \<in> pverts G - V\<close> by (auto simp: G'_def)
	then show ?thesis using \<open>Suc n = card (pverts G - V)\<close> mem_G' by simp
	qed

	have G_is_sd: "G = subdivide G' (u,v) w" (is "_ = ?sdG'")
	using \<open>w \<in> pverts G - V\<close> \<open>(u,v) \<notin> parcs G\<close> \<open>(v,u) \<notin> parcs G\<close> uvw_arcs1 uvw_arcs2
	by (intro pair_pre_digraph.equality) (auto simp: G'_def)

	have gcg_sd: "gen_contr_graph (subdivide G' (u,v) w) V = gen_contr_graph G' V"
	proof -
	have "V \<subseteq> pverts G"
	using \<open>G.is_slim V\<close> by (auto simp: G.is_slim_def verts3_def)
	moreover
	have "verts3 G' = verts3 G"
	by (simp only: G_is_sd spd_G'.verts3_subdivide[OF \<open>(u,v) \<in> parcs G'\<close> \<open>w \<notin> pverts G'\<close>])
	ultimately
	have V: "V \<subseteq> pverts G'"
	using \<open>w \<in> pverts G - V\<close> by (auto simp: G'_def)
	with mem_G' show ?thesis by (rule spd_G'.gcg_subdivide_eq)
	qed

	have is_slim_G': "pd_G'.is_slim V" using \<open>G.is_slim V\<close> mem_G' \<open>w \<notin> V\<close>
	unfolding G_is_sd by (rule spd_G'.is_slim_if_subdivide)
	with mem_G' have "subdivision_pair (gen_contr_graph G' V) (subdivide G' (u, v) w)"
	by (intro Suc card_G' subdivision_pair_intros) auto
	then show ?case by (simp add: gcg_sd G_is_sd)
	qed

	lemma contr_is_subgraph_subdivision:
	shows "\<exists>H. subgraph (with_proj H) G \<and> subdivision_pair (contr_graph G) H"
	proof -
	interpret sG: pair_graph slim by (rule pair_graph_slim)

	have "subdivision_pair (gen_contr_graph slim (verts3 G)) slim "
	by (rule sG.subdivision_gen_contr) (rule slim_is_slim)
	then show ?thesis unfolding contr_graph_slim_eq by (blast intro: subgraph_slim)
	qed

	theorem kuratowski_contr:
	fixes K :: "'a pair_pre_digraph"
	assumes subgraph_K: "subgraph K G"
	assumes spd_K: "pair_pseudo_graph K"
	assumes kuratowski: "K\<^bsub>3,3\<^esub> (contr_graph K) \<or> K\<^bsub>5\<^esub> (contr_graph K)"
	shows "\<not>kuratowski_planar G"
	proof -
	interpret spd_K: pair_pseudo_graph K by (fact spd_K)
	obtain H where subgraph_H: "subgraph (with_proj H) K"
	and subdiv_H:"subdivision_pair (contr_graph K) H"
	by atomize_elim (rule spd_K.contr_is_subgraph_subdivision)
	have grI: "\<And>K. (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K) \<Longrightarrow> graph K"
	by (auto simp: complete_digraph_def complete_bipartite_digraph_def)
	from subdiv_H and kuratowski
	have "\<exists>K. subdivision_pair K H \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)" by blast
	then have "\<exists>K rev_K rev_H. subdivision (K, rev_K) (H, rev_H) \<and> (K\<^bsub>3,3\<^esub> K \<or> K\<^bsub>5\<^esub> K)"
	by (auto intro: grI pair_graphI_graph)
	then show ?thesis using subgraph_H subgraph_K
	unfolding kuratowski_planar_def by (auto intro: subgraph_trans)
	qed

	theorem certificate_characterization:
	defines "kuratowski \<equiv> \<lambda>G :: 'a pair_pre_digraph. K\<^bsub>3,3\<^esub> G \<or> K\<^bsub>5\<^esub> G"
	shows "kuratowski (contr_graph G)
	\<longleftrightarrow> (\<exists>H. kuratowski H \<and> subdivision_pair H slim \<and> verts3 G = verts3 slim)" (is "?L \<longleftrightarrow> ?R")
	proof
	assume ?L
	interpret S: pair_graph slim by (rule pair_graph_slim)
	have "subdivision_pair (contr_graph G) slim"
	proof -
	have *: "S.is_slim (verts3 G)" by (rule slim_is_slim)
	show ?thesis using contr_graph_slim_eq S.subdivision_gen_contr[OF *] by auto
	qed
	moreover
	have "verts3 slim = verts3 G" (is "?l = ?r")
	proof safe
	fix v assume "v \<in> ?l" then show "v \<in> ?r"
	using verts_slim_in_G verts3_slim_in_verts3 by auto
	next
	fix v assume "v \<in> ?r"
	have "v \<in> verts3 (contr_graph G)"
	proof -
	have "v \<in> verts (contr_graph G)"
	using \<open>v \<in> ?r\<close> by (auto simp: verts3_def gen_contr_graph_def)
	then show ?thesis
	using \<open>?L\<close> unfolding kuratowski_def by (auto simp: verts3_K33 verts3_K5)
	qed
	then have "v \<in> verts3 (gen_contr_graph slim (verts3 G))" unfolding contr_graph_slim_eq .
	then have "2 < in_degree (gen_contr_graph slim (verts3 G)) v"
	unfolding verts3_def by auto
	also have "\<dots> \<le> in_degree slim v"
	using \<open>v \<in> ?r\<close> verts3_slim_in_verts3 by (auto intro: S.in_degree_contr)
	finally show "v \<in> verts3 slim"
	using verts3_in_slim_G \<open>v \<in> ?r\<close> unfolding verts3_def by auto
	qed
	ultimately show ?R using \<open>?L\<close> by auto
	next
	assume ?R
	then have "kuratowski (gen_contr_graph slim (verts3 G))"
	unfolding kuratowski_def
	by (auto intro: K33_contractedI K5_contractedI)
	then show ?L unfolding contr_graph_slim_eq .
	qed

	definition (in pair_pre_digraph) certify :: "'a pair_pre_digraph \<Rightarrow> bool" where
	"certify cert \<equiv> let C = contr_graph cert in subgraph cert G \<and> (K\<^bsub>3,3\<^esub> C \<or> K\<^bsub>5\<^esub>C)"

	theorem certify_complete:
	assumes "pair_pseudo_graph cert"
	assumes "subgraph cert G"
	assumes "\<exists>H. subdivision_pair H cert \<and> (K\<^bsub>3,3\<^esub> H \<or> K\<^bsub>5\<^esub> H)"
	shows "certify cert"
	unfolding certify_def
	using assms by (auto simp: Let_def intro: K33_contractedI K5_contractedI)

	theorem certify_sound:
	assumes "pair_pseudo_graph cert"
	assumes "certify cert"
	shows" \<not>kuratowski_planar G"
	using assms by (intro kuratowski_contr) (auto simp: certify_def Let_def)

	theorem certify_characterization:
	assumes "pair_pseudo_graph cert"
	shows "certify cert \<longleftrightarrow> subgraph cert G \<and> verts3 cert = verts3 (pair_pre_digraph.slim cert)
	\<and>(\<exists>H. (K\<^bsub>3,3\<^esub> (with_proj H) \<or> K\<^bsub>5\<^esub> H) \<and> subdivision_pair H (pair_pre_digraph.slim cert))"
	(is "?L \<longleftrightarrow> ?R")
	by (auto simp only: simp_thms certify_def Let_def pair_pseudo_graph.certificate_characterization[OF assms])


	end

	end
	diff --git a/thys/Green/Integrals.thy b/thys/Green/Integrals.thy
	--- a/thys/Green/Integrals.thy
	+++ b/thys/Green/Integrals.thy
	@@ -1,946 +1,946 @@
	theory Integrals
	imports "HOL-Analysis.Analysis" General_Utils
	begin

	lemma gauge_integral_Fubini_universe_x:
	fixes f :: "('a::euclidean_space * 'b::euclidean_space) \<Rightarrow> 'c::euclidean_space"
	assumes fun_lesbegue_integrable: "integrable lborel f" and
	x_axis_integral_measurable: "(\<lambda>x. integral UNIV (\<lambda>y. f(x, y))) \<in> borel_measurable lborel"
	shows "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x,y)))"
	"(\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) integrable_on UNIV"
	proof -
	have f_is_measurable: "f \<in> borel_measurable lborel"
	using fun_lesbegue_integrable and borel_measurable_integrable
	by auto
	have fun_lborel_prod_integrable:
	"integrable (lborel \<Otimes>\<^sub>M lborel) f"
	using fun_lesbegue_integrable
	by (simp add: lborel_prod)
	then have region_integral_is_one_twoD_integral:
	"LBINT x. LBINT y. f (x, y) = integral\<^sup>L (lborel \<Otimes>\<^sub>M lborel) f"
	using lborel_pair.integral_fst'
	by auto
	then have AE_one_D_integrals_eq: "AE x in lborel. LBINT y. f (x, y) = integral UNIV (\<lambda>y. f(x,y))"
	proof -
	have "AE x in lborel. integrable lborel (\<lambda>y. f(x,y))"
	using lborel_pair.AE_integrable_fst' and fun_lborel_prod_integrable
	by blast
	then show ?thesis
	using integral_lborel and always_eventually
	and AE_mp
	by fastforce
	qed
	have one_D_integral_measurable:
	"(\<lambda>x. LBINT y. f (x, y)) \<in> borel_measurable lborel"
	using f_is_measurable and lborel.borel_measurable_lebesgue_integral
	by auto
	then have second_lesbegue_integral_eq:
	"LBINT x. LBINT y. f (x, y) = LBINT x. (integral UNIV (\<lambda>y. f(x,y)))"
	using x_axis_integral_measurable and integral_cong_AE and AE_one_D_integrals_eq
	by blast
	have "integrable lborel (\<lambda>x. LBINT y. f (x, y))"
	using fun_lborel_prod_integrable and lborel_pair.integrable_fst'
	by auto
	then have oneD_gauge_integral_lesbegue_integrable:
	"integrable lborel (\<lambda>x. integral UNIV (\<lambda>y. f(x,y)))"
	using x_axis_integral_measurable and AE_one_D_integrals_eq and integrable_cong_AE_imp
	by blast
	then show one_D_gauge_integral_integrable:
	"(\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) integrable_on UNIV"
	using integrable_on_lborel
	by auto
	have "LBINT x. (integral UNIV (\<lambda>y. f(x,y))) = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x, y)))"
	using integral_lborel oneD_gauge_integral_lesbegue_integrable
	by fastforce
	then have twoD_lesbeuge_eq_twoD_gauge:
	"LBINT x. LBINT y. f (x, y) = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x, y)))"
	using second_lesbegue_integral_eq
	by auto
	then show "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x,y)))"
	using fun_lesbegue_integrable and integral_lborel and region_integral_is_one_twoD_integral
	by (metis lborel_prod)
	qed

	lemma gauge_integral_Fubini_universe_y:
	fixes f :: "('a::euclidean_space * 'b::euclidean_space) \<Rightarrow> 'c::euclidean_space"
	assumes fun_lesbegue_integrable: "integrable lborel f" and
	y_axis_integral_measurable: "(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) \<in> borel_measurable lborel"
	shows "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	"(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) integrable_on UNIV"
	proof -
	have f_is_measurable: "f \<in> borel_measurable lborel"
	using fun_lesbegue_integrable and borel_measurable_integrable
	by auto
	have fun_lborel_prod_integrable:
	"integrable (lborel \<Otimes>\<^sub>M lborel) f"
	using fun_lesbegue_integrable
	by (simp add: lborel_prod)
	then have region_integral_is_one_twoD_integral:
	"LBINT x. LBINT y. f (y, x) = integral\<^sup>L (lborel \<Otimes>\<^sub>M lborel) f"
	using lborel_pair.integral_fst'
	f_is_measurable lborel_pair.integrable_product_swap lborel_pair.integral_fst lborel_pair.integral_product_swap lborel_prod
	by force
	then have AE_one_D_integrals_eq: "AE x in lborel. LBINT y. f (y, x) = integral UNIV (\<lambda>y. f(y,x))"
	proof -
	have "AE x in lborel. integrable lborel (\<lambda>y. f(y,x))"
	using lborel_pair.AE_integrable_fst' and fun_lborel_prod_integrable
	lborel_pair.AE_integrable_fst lborel_pair.integrable_product_swap
	by blast
	then show ?thesis
	using integral_lborel and always_eventually
	and AE_mp
	by fastforce
	qed
	have one_D_integral_measurable:
	"(\<lambda>x. LBINT y. f (y, x)) \<in> borel_measurable lborel"
	using f_is_measurable and lborel.borel_measurable_lebesgue_integral
	by auto
	then have second_lesbegue_integral_eq:
	"LBINT x. LBINT y. f (y, x) = LBINT x. (integral UNIV (\<lambda>y. f(y, x)))"
	using y_axis_integral_measurable and integral_cong_AE and AE_one_D_integrals_eq
	by blast
	have "integrable lborel (\<lambda>x. LBINT y. f (y, x))"
	using fun_lborel_prod_integrable and lborel_pair.integrable_fst'
	by (simp add: lborel_pair.integrable_fst lborel_pair.integrable_product_swap)
	then have oneD_gauge_integral_lesbegue_integrable:
	"integrable lborel (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	using y_axis_integral_measurable and AE_one_D_integrals_eq and integrable_cong_AE_imp
	by blast
	then show one_D_gauge_integral_integrable:
	"(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) integrable_on UNIV"
	using integrable_on_lborel
	by auto
	have "LBINT x. (integral UNIV (\<lambda>y. f(y, x))) = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	using integral_lborel oneD_gauge_integral_lesbegue_integrable
	by fastforce
	then have twoD_lesbeuge_eq_twoD_gauge:
	"LBINT x. LBINT y. f (y, x) = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	using second_lesbegue_integral_eq
	by auto
	then show "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	using fun_lesbegue_integrable and integral_lborel and region_integral_is_one_twoD_integral
	by (metis lborel_prod)
	qed

	lemma gauge_integral_Fubini_curve_bounded_region_x:
	fixes f g :: "('a::euclidean_space * 'b::euclidean_space) \<Rightarrow> 'c::euclidean_space" and
	g1 g2:: "'a \<Rightarrow> 'b" and
	s:: "('a * 'b) set"
	assumes fun_lesbegue_integrable: "integrable lborel f" and
	x_axis_gauge_integrable: "\<And>x. (\<lambda>y. f(x, y)) integrable_on UNIV" and
	(IS THIS redundant? NO IT IS NOT)
	x_axis_integral_measurable: "(\<lambda>x. integral UNIV (\<lambda>y. f(x, y))) \<in> borel_measurable lborel" and
	f_is_g_indicator: "f = (\<lambda>x. if x \<in> s then g x else 0)" and
	s_is_bounded_by_g1_and_g2: "s = {(x,y). (\<forall>i\<in>Basis. a \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> b \<bullet> i) \<and>
	(\<forall>i\<in>Basis. (g1 x) \<bullet> i \<le> y \<bullet> i \<and> y \<bullet> i \<le> (g2 x) \<bullet> i)}"
	shows "integral s g = integral (cbox a b) (\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(x,y)))"
	proof -
	have two_D_integral_to_one_D: "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x,y)))"
	using gauge_integral_Fubini_universe_x and fun_lesbegue_integrable and x_axis_integral_measurable
	by auto
	have one_d_integral_integrable: "(\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) integrable_on UNIV"
	using gauge_integral_Fubini_universe_x(2) and assms
	by blast
	have case_x_in_range:
	"\<forall> x \<in> cbox a b. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(x,y)) = integral UNIV (\<lambda>y. f(x,y))"
	proof
	fix x:: 'a
	assume within_range: "x \<in> (cbox a b)"
	let ?f_one_D_spec = "(\<lambda>y. if y \<in> (cbox (g1 x) (g2 x)) then g(x,y) else 0)"
	have f_one_D_region: "(\<lambda>y. f(x,y)) = (\<lambda>y. if y \<in> cbox (g1 x) (g2 x) then g(x,y) else 0)"
	proof
	fix y::'b
	show "f (x, y) = (if y \<in> (cbox (g1 x) (g2 x)) then g (x, y) else 0)"
	apply (simp add: f_is_g_indicator s_is_bounded_by_g1_and_g2)
	using within_range
	apply (simp add: cbox_def)
	by smt
	qed
	have zero_out_of_bound: "\<forall> y. y \<notin> cbox (g1 x) (g2 x) \<longrightarrow> f (x,y) = 0"
	using f_is_g_indicator and s_is_bounded_by_g1_and_g2
	by (auto simp add: cbox_def)
	have "(\<lambda>y. f(x,y)) integrable_on cbox (g1 x) (g2 x)"
	proof -
	have "?f_one_D_spec integrable_on UNIV"
	using f_one_D_region and x_axis_gauge_integrable
	by metis
	then have "?f_one_D_spec integrable_on cbox(g1 x) (g2 x)"
	using integrable_on_subcbox
	by blast
	then show ?thesis using f_one_D_region by auto
	qed
	then have f_integrale_x: "((\<lambda>y. f(x,y)) has_integral (integral (cbox (g1 x) (g2 x)) (\<lambda>y. f(x,y)))) (cbox (g1 x) (g2 x))"
	using integrable_integral and within_range and x_axis_gauge_integrable
	by auto
	have "integral (cbox (g1 x) (g2 x)) (\<lambda>y. f (x, y)) = integral UNIV (\<lambda>y. f (x, y))"
	using has_integral_on_superset[OF f_integrale_x _ Set.subset_UNIV] zero_out_of_bound
	by (simp add: integral_unique)
	then have "((\<lambda>y. f(x, y)) has_integral integral UNIV (\<lambda>y. f (x, y))) (cbox (g1 x) (g2 x))"
	using f_integrale_x
	by simp
	then have "((\<lambda>y. g(x, y)) has_integral integral UNIV (\<lambda>y. f (x, y))) (cbox (g1 x)(g2 x))"
	using Henstock_Kurzweil_Integration.has_integral_restrict [OF subset_refl ] and
	f_one_D_region
	by (smt has_integral_eq)
	then show "integral (cbox (g1 x) (g2 x)) (\<lambda>y. g (x, y)) = integral UNIV (\<lambda>y. f (x, y))"
	by auto
	qed
	have case_x_not_in_range:
	"\<forall> x. x \<notin> cbox a b \<longrightarrow> integral UNIV (\<lambda>y. f(x,y)) = 0"
	proof
	fix x::'a
	have "x \<notin> (cbox a b) \<longrightarrow> (\<forall>y. f(x,y) = 0)"
	apply (simp add: s_is_bounded_by_g1_and_g2 f_is_g_indicator cbox_def)
	by auto
	then show "x \<notin> cbox a b \<longrightarrow> integral UNIV (\<lambda>y. f (x, y)) = 0"
	by (simp)
	qed
	have RHS: "integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) = integral (cbox a b) (\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(x,y)))"
	proof -
	let ?first_integral = "(\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(x,y)))"
	let ?x_integral_cases = "(\<lambda>x. if x \<in> cbox a b then ?first_integral x else 0)"
	have x_integral_cases_integral: "(\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) = ?x_integral_cases"
	using case_x_in_range and case_x_not_in_range
	by auto
	have "((\<lambda>x. integral UNIV (\<lambda>y. f(x,y))) has_integral (integral UNIV f)) UNIV"
	using two_D_integral_to_one_D
	one_d_integral_integrable
	by auto
	then have "(?x_integral_cases has_integral (integral UNIV f)) UNIV"
	using x_integral_cases_integral by auto
	then have "(?first_integral has_integral (integral UNIV f)) (cbox a b)"
	using has_integral_restrict_UNIV[of "cbox a b" "?first_integral" "integral UNIV f"]
	by auto
	then show ?thesis
	using two_D_integral_to_one_D
	by (simp add: integral_unique)
	qed
	have f_integrable:"f integrable_on UNIV"
	using fun_lesbegue_integrable and integrable_on_lborel
	by auto
	then have LHS: "integral UNIV f = integral s g"
	apply (simp add: f_is_g_indicator)
	using integrable_restrict_UNIV
	integral_restrict_UNIV
	by auto
	then show ?thesis
	using RHS and two_D_integral_to_one_D
	by auto
	qed

	lemma gauge_integral_Fubini_curve_bounded_region_y:
	fixes f g :: "('a::euclidean_space * 'b::euclidean_space) \<Rightarrow> 'c::euclidean_space" and
	g1 g2:: "'b \<Rightarrow> 'a" and
	s:: "('a * 'b) set"
	assumes fun_lesbegue_integrable: "integrable lborel f" and
	y_axis_gauge_integrable: "\<And>x. (\<lambda>y. f(y, x)) integrable_on UNIV" and
	(IS THIS redundant? NO IT IS NOT)
	y_axis_integral_measurable: "(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) \<in> borel_measurable lborel" and
	f_is_g_indicator: "f = (\<lambda>x. if x \<in> s then g x else 0)" and
	s_is_bounded_by_g1_and_g2: "s = {(y, x). (\<forall>i\<in>Basis. a \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> b \<bullet> i) \<and>
	(\<forall>i\<in>Basis. (g1 x) \<bullet> i \<le> y \<bullet> i \<and> y \<bullet> i \<le> (g2 x) \<bullet> i)}"
	shows "integral s g = integral (cbox a b) (\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(y, x)))"
	proof -
	have two_D_integral_to_one_D: "integral UNIV f = integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x)))"
	using gauge_integral_Fubini_universe_y and fun_lesbegue_integrable and y_axis_integral_measurable
	by auto
	have one_d_integral_integrable: "(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) integrable_on UNIV"
	using gauge_integral_Fubini_universe_y(2) and assms
	by blast
	have case_y_in_range:
	"\<forall> x \<in> cbox a b. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(y, x)) = integral UNIV (\<lambda>y. f(y, x))"
	proof
	fix x:: 'b
	assume within_range: "x \<in> (cbox a b)"
	let ?f_one_D_spec = "(\<lambda>y. if y \<in> (cbox (g1 x) (g2 x)) then g(y, x) else 0)"
	have f_one_D_region: "(\<lambda>y. f(y, x)) = (\<lambda>y. if y \<in> cbox (g1 x) (g2 x) then g(y, x) else 0)"
	proof
	fix y::'a
	show "f (y, x) = (if y \<in> (cbox (g1 x) (g2 x)) then g (y, x) else 0)"
	apply (simp add: f_is_g_indicator s_is_bounded_by_g1_and_g2)
	using within_range
	apply (simp add: cbox_def)
	by smt
	qed
	have zero_out_of_bound: "\<forall> y. y \<notin> cbox (g1 x) (g2 x) \<longrightarrow> f (y, x) = 0"
	using f_is_g_indicator and s_is_bounded_by_g1_and_g2
	by (auto simp add: cbox_def)
	have "(\<lambda>y. f(y, x)) integrable_on cbox (g1 x) (g2 x)"
	proof -
	have "?f_one_D_spec integrable_on UNIV"
	using f_one_D_region and y_axis_gauge_integrable
	by metis
	then have "?f_one_D_spec integrable_on cbox(g1 x) (g2 x)"
	using integrable_on_subcbox
	by blast
	then show ?thesis using f_one_D_region by auto
	qed
	then have f_integrale_y: "((\<lambda>y. f(y, x)) has_integral (integral (cbox (g1 x) (g2 x)) (\<lambda>y. f(y,x)))) (cbox (g1 x) (g2 x))"
	using integrable_integral and within_range and y_axis_gauge_integrable
	by auto
	have "integral (cbox (g1 x) (g2 x)) (\<lambda>y. f (y, x)) = integral UNIV (\<lambda>y. f (y, x))"
	using has_integral_on_superset[OF f_integrale_y _ Set.subset_UNIV] zero_out_of_bound
	by (simp add: integral_unique)
	then have "((\<lambda>y. f(y, x)) has_integral integral UNIV (\<lambda>y. f (y, x))) (cbox (g1 x) (g2 x))"
	using f_integrale_y
	by simp
	then have "((\<lambda>y. g(y, x)) has_integral integral UNIV (\<lambda>y. f (y, x))) (cbox (g1 x)(g2 x))"
	using Henstock_Kurzweil_Integration.has_integral_restrict [OF subset_refl ] and
	f_one_D_region
	by (smt has_integral_eq)
	then show "integral (cbox (g1 x) (g2 x)) (\<lambda>y. g (y, x)) = integral UNIV (\<lambda>y. f (y, x))"
	by auto
	qed
	have case_y_not_in_range:
	"\<forall> x. x \<notin> cbox a b \<longrightarrow> integral UNIV (\<lambda>y. f(y, x)) = 0"
	proof
	fix x::'b
	have "x \<notin> (cbox a b) \<longrightarrow> (\<forall>y. f(y, x) = 0)"
	apply (simp add: s_is_bounded_by_g1_and_g2 f_is_g_indicator cbox_def)
	by auto
	then show "x \<notin> cbox a b \<longrightarrow> integral UNIV (\<lambda>y. f (y, x)) = 0"
	by (simp)
	qed
	have RHS: "integral UNIV (\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) = integral (cbox a b) (\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(y, x)))"
	proof -
	let ?first_integral = "(\<lambda>x. integral (cbox (g1 x) (g2 x)) (\<lambda>y. g(y, x)))"
	let ?x_integral_cases = "(\<lambda>x. if x \<in> cbox a b then ?first_integral x else 0)"
	have y_integral_cases_integral: "(\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) = ?x_integral_cases"
	using case_y_in_range and case_y_not_in_range
	by auto
	have "((\<lambda>x. integral UNIV (\<lambda>y. f(y, x))) has_integral (integral UNIV f)) UNIV"
	using two_D_integral_to_one_D
	one_d_integral_integrable
	by auto
	then have "(?x_integral_cases has_integral (integral UNIV f)) UNIV"
	using y_integral_cases_integral by auto
	then have "(?first_integral has_integral (integral UNIV f)) (cbox a b)"
	using has_integral_restrict_UNIV[of "cbox a b" "?first_integral" "integral UNIV f"]
	by auto
	then show ?thesis
	using two_D_integral_to_one_D
	by (simp add: integral_unique)
	qed
	have f_integrable:"f integrable_on UNIV"
	using fun_lesbegue_integrable and integrable_on_lborel
	by auto
	then have LHS: "integral UNIV f = integral s g"
	apply (simp add: f_is_g_indicator)
	using integrable_restrict_UNIV
	integral_restrict_UNIV
	by auto
	then show ?thesis
	using RHS and two_D_integral_to_one_D
	by auto
	qed

	lemma gauge_integral_by_substitution:
	fixes f::"(real \<Rightarrow> real)" and
	g::"(real \<Rightarrow> real)" and
	g'::"real \<Rightarrow> real" and
	a::"real" and
	b::"real"
	assumes a_le_b: "a \<le> b" and
	ga_le_gb: "g a \<le> g b" and
	g'_derivative: "\<forall>x \<in> {a..b}. (g has_vector_derivative (g' x)) (at x within {a..b})" and
	g'_continuous: "continuous_on {a..b} g'" and
	f_continuous: "continuous_on (g ` {a..b}) f"
	shows "integral {g a..g b} (f) = integral {a..b} (\<lambda>x. f(g x) * (g' x))"
	proof -
	have "\<forall>x \<in> {a..b}. (g has_real_derivative (g' x)) (at x within {a..b})"
	using has_field_derivative_iff_has_vector_derivative[of "g"] and g'_derivative
	by auto
	then have 2: "interval_lebesgue_integral lborel (ereal (a)) (ereal (b)) (\<lambda>x. g' x *\<^sub>R f (g x))
	= interval_lebesgue_integral lborel (ereal (g a)) (ereal (g b)) f"
	using interval_integral_substitution_finite[of "a" "b" "g" "g'" "f"] and g'_continuous and a_le_b and f_continuous
	by auto
	have g_continuous: "continuous_on {a .. b} g"
	using Derivative.differentiable_imp_continuous_on
	apply (simp add: differentiable_on_def differentiable_def)
	by (metis continuous_on_vector_derivative g'_derivative)
	have "set_integrable lborel {a .. b} (\<lambda>x. g' x *\<^sub>R f (g x))"
	proof -
	have "continuous_on {a .. b} (\<lambda>x. g' x *\<^sub>R f (g x))"
	proof -
	have "continuous_on {a .. b} (\<lambda>x. f (g x))"
	proof -
	show ?thesis
	using Topological_Spaces.continuous_on_compose f_continuous g_continuous
	by auto
	qed
	then show ?thesis
	using Limits.continuous_on_mult g'_continuous
	by auto
	qed
	then show ?thesis
	using borel_integrable_atLeastAtMost' by blast
	qed
	then have 0: "interval_lebesgue_integral lborel (ereal (a)) (ereal (b)) (\<lambda>x. g' x *\<^sub>R f (g x))
	= integral {a .. b} (\<lambda>x. g' x *\<^sub>R f (g x))"
	using a_le_b and interval_integral_eq_integral
	by (metis (no_types))
	have "set_integrable lborel {g a .. g b} f"
	proof -
	have "continuous_on {g a .. g b} f"
	proof -
	have "{g a .. g b} \<subseteq> g ` {a .. b}"
	using g_continuous
	by (metis a_le_b atLeastAtMost_iff atLeastatMost_subset_iff continuous_image_closed_interval imageI order_refl)
	then show "continuous_on {g a .. g b} f"
	using f_continuous continuous_on_subset
	by blast
	qed
	then show ?thesis
	using borel_integrable_atLeastAtMost'
	by blast
	qed
	then have 1: "interval_lebesgue_integral lborel (ereal (g a)) (ereal (g b)) f
	= integral {g a .. g b} f"
	using ga_le_gb and interval_integral_eq_integral
	by (metis (no_types))
	then show ?thesis
	using 0 and 1 and 2
	by (metis (no_types, lifting) Henstock_Kurzweil_Integration.integral_cong mult.commute real_scaleR_def)
	qed

	lemma frontier_ic:
	assumes "a < (b::real)"
	shows "frontier {a<..b} = {a,b}"
	apply(simp add: frontier_def)
	using assms
	by auto

	lemma frontier_ci:
	assumes "a < (b::real)"
	shows "frontier {a<..<b} = {a,b}"
	apply(simp add: frontier_def)
	using assms
	by auto

	lemma ic_not_closed:
	assumes "a < (b::real)"
	shows "\<not> closed {a<..b}"
	using assms frontier_subset_eq frontier_ic greaterThanAtMost_iff by blast

	lemma closure_ic_union_ci:
	assumes "a < (b::real)" "b < c"
	shows "closure ({a..<b} \<union> {b<..c}) = {a .. c}"
	using frontier_ic[OF assms(1)] frontier_ci[OF assms(2)] closure_Un assms
	apply(simp add: frontier_def)
	by auto

	lemma interior_ic_ci_union:
	assumes "a < (b::real)" "b < c"
	shows "b \<notin> (interior ({a..<b} \<union> {b<..c}))"
	proof-
	have "b \<notin> ({a..<b} \<union> {b<..c})" by auto
	then show ?thesis
	using interior_subset by blast
	qed

	lemma frontier_ic_union_ci:
	assumes "a < (b::real)" "b < c"
	shows "b \<in> frontier ({a..<b} \<union> {b<..c})"
	using closure_ic_union_ci assms interior_ic_ci_union
	by(simp add: frontier_def)

	lemma ic_union_ci_not_closed:
	assumes "a < (b::real)" "b < c"
	shows "\<not> closed ({a..<b} \<union> {b<..c})"
	proof-
	have "b \<notin> ({a..<b} \<union> {b<..c})" by auto
	then show ?thesis
	using assms frontier_subset_eq frontier_ic_union_ci[OF assms]
	by (auto simp only: subset_iff)
	qed

	lemma integrable_continuous_:
	fixes f :: "'b::euclidean_space \<Rightarrow> 'a::banach"
	assumes "continuous_on (cbox a b) f"
	shows "f integrable_on cbox a b"
	by (simp add: assms integrable_continuous)

	lemma removing_singletons_from_div:
	assumes "\<forall>t\<in>S. \<exists>c d::real. c < d \<and> {c..d} = t"
	"{x} \<union> \<Union>S = {a..b}" "a < x" "x < b"
	"finite S"
	shows "\<exists>t\<in>S. x \<in> t"
	proof(rule ccontr)
	assume "\<not>(\<exists>t\<in>S. x \<in> t)"
	then have "\<forall>t\<in>S. x \<notin> t" by auto
	then have "x \<notin> \<Union>S" by auto
	then have i: "\<Union>S = {a..b} - {x}" using assms (2) by auto
	have "x \<in> {a..b}" using assms by auto
	then have "{a .. b} - {x} = {a..<x} \<union> {x<..b}" by auto
	then have 0: "\<Union>S = {a..<x} \<union> {x<..b}" using i by auto
	have 1:"closed (\<Union>S)"
	apply(rule closed_Union)
	proof-
	show "finite S"
	using assms by auto
	show "\<forall>T\<in>S. closed T" using assms by auto
	qed
	show False using 0 1 ic_union_ci_not_closed assms by auto
	qed

	lemma remove_singleton_from_division_of:(By Manuel Eberl)
	assumes "A division_of {a::real..b}" "a < b"
	assumes "x \<in> {a..b}"
	shows "\<exists>c d. c < d \<and> {c..d} \<in> A \<and> x \<in> {c..d}"
	proof -
	from assms have "x islimpt {a..b}"
	by (intro connected_imp_perfect) auto
	also have "{a..b} = {x. {x..x} \<in> A} \<union> ({a..b} - {x. {x..x} \<in> A})"
	using assms by auto
	also have "x islimpt \<dots> \<longleftrightarrow> x islimpt {a..b} - {x. {x..x} \<in> A}"
	proof (intro islimpt_Un_finite)
	have "{x. {x..x} \<in> A} \<subseteq> Inf ` A"
	proof safe
	fix x assume "{x..x} \<in> A"
	thus "x \<in> Inf ` A"
	by (auto intro!: bexI[of _ "{x}"] simp: image_iff)
	qed
	moreover from assms have "finite A" by (auto simp: division_of_def)
	hence "finite (Inf ` A)" by auto
	ultimately show "finite {x. {x..x} \<in> A}" by (rule finite_subset)
	qed
	also have "{a..b} = \<Union>A"
	using assms by (auto simp: division_of_def)
	finally have "x islimpt \<Union>(A - range (\<lambda>x. {x..x}))"
	by (rule islimpt_subset) auto
	moreover have "closed (\<Union>(A - range (\<lambda>x. {x..x})))"
	using assms by (intro closed_Union) auto
	ultimately have "x \<in> (\<Union>(A - range (\<lambda>x. {x..x})))"
	by (auto simp: closed_limpt)
	then obtain X where "x \<in> X" "X \<in> A" "X \<notin> range (\<lambda>x. {x..x})"
	by blast
	moreover from division_ofD(2)[OF assms(1) this(2)] division_ofD(3)[OF assms(1) this(2)]
	division_ofD(4)[OF assms(1) this(2)]
	obtain c d where "X = cbox c d" "X \<subseteq> {a..b}" "X \<noteq> {}" by blast
	ultimately have "c \<le> d" by auto
	have "c \<noteq> d"
	proof
	assume "c = d"
	with \<open>X = cbox c d\<close> have "X = {c..c}" by auto
	hence "X \<in> range (\<lambda>x. {x..x})" by blast
	with \<open>X \<notin> range (\<lambda>x. {x..x})\<close> show False by contradiction
	qed
	with \<open>c \<le> d\<close> have "c < d" by simp
	with \<open>X = cbox c d\<close> and \<open>x \<in> X\<close> and \<open>X \<in> A\<close> show ?thesis
	by auto
	qed

	lemma remove_singleton_from_tagged_division_of:
	assumes "A tagged_division_of {a::real..b}" "a < b"
	assumes "x \<in> {a..b}"
	shows "\<exists>k c d. c < d \<and> (k, {c..d}) \<in> A \<and> x \<in> {c..d}"
	using remove_singleton_from_division_of[OF division_of_tagged_division[OF assms(1)] assms(2)]
	(sledgehammer)
	using assms(3) by fastforce

	lemma tagged_div_wo_singlestons:
	assumes "p tagged_division_of {a::real..b}" "a < b"
	shows "(p - {xk. \<exists>x y. xk = (x,{y})}) tagged_division_of cbox a b"
	using remove_singleton_from_tagged_division_of[OF assms] assms
	apply(auto simp add: tagged_division_of_def tagged_partial_division_of_def)
	apply blast
	apply blast
	apply blast
	by fastforce

	lemma tagged_div_wo_empty:
	assumes "p tagged_division_of {a::real..b}" "a < b"
	shows "(p - {xk. \<exists>x. xk = (x,{})}) tagged_division_of cbox a b"
	using remove_singleton_from_tagged_division_of[OF assms] assms
	apply(auto simp add: tagged_division_of_def tagged_partial_division_of_def)
	apply blast
	apply blast
	apply blast
	by fastforce

	lemma fine_diff:
	assumes "\<gamma> fine p"
	shows "\<gamma> fine (p - s)"
	apply (auto simp add: fine_def)
	using assms by auto

	lemma tagged_div_tage_notin_set:
	assumes "finite (s::real set)"
	"p tagged_division_of {a..b}"
	"\<gamma> fine p" "(\<forall>(x, K)\<in>p. \<exists>c d::real. c < d \<and> K = {c..d})" "gauge \<gamma>"
	shows "\<exists>p' \<gamma>'. p' tagged_division_of {a..b} \<and>
	\<gamma>' fine p' \<and> (\<forall>(x, K)\<in>p'. x \<notin> s) \<and> gauge \<gamma>'"
	proof-
	have "(\<forall>(x::real, K)\<in>p. \<exists>x'. x' \<notin> s \<and> x'\<in> interior K)"
	proof-
	{fix x::real
	fix K
	assume ass: "(x::real,K) \<in> p"
	have "(\<forall>(x, K)\<in>p. infinite (interior K))"
	using assms(4) infinite_Ioo interior_atLeastAtMost_real
	by (smt split_beta)
	then have i: "infinite (interior K)" using ass by auto
	have "\<exists>x'. x' \<notin> s \<and> x'\<in> interior K"
	using infinite_imp_nonempty[OF Diff_infinite_finite[OF assms(1) i]] by auto}
	then show ?thesis by auto
	qed
	then obtain f where f: "(\<forall>(x::real, K)\<in>p. (f (x,K)) \<notin> s \<and> (f (x,K)) \<in> interior K)"
	using choice_iff[where ?Q = "\<lambda>(x,K) x'. (x::real, K)\<in>p \<longrightarrow> x' \<notin> s \<and> x' \<in> interior K"]
	apply (auto simp add: case_prod_beta)
	by metis
	have f': "(\<forall>(x::real, K)\<in>p. (f (x,K)) \<notin> s \<and> (f (x,K)) \<in> K)"
	using f interior_subset
	by (auto simp add: case_prod_beta subset_iff)
	let ?p' = "{m. (\<exists>xK. m = ((f xK), snd xK) \<and> xK \<in> p)}"
	have 0: "(\<forall>(x, K)\<in>?p'. x \<notin> s)"
	using f
	by (auto simp add: case_prod_beta)
	have i: "finite {(f (a, b), b) \|a b. (a, b) \<in> p}"
	proof-
	have a: "{(f (a, b), b) \|a b. (a, b) \<in> p} = (%(a,b). (f(a,b),b)) ` p" by auto
	have b: "finite p" using assms(2) by auto
	show ?thesis using a b by auto
	qed
	have 1: "?p' tagged_division_of {a..b}"
	using assms(2) f'
	apply(auto simp add: tagged_division_of_def tagged_partial_division_of_def case_prod_beta)
	apply(metis i)
	apply blast
	apply blast
	by fastforce
	(f is injective becuase interiors of different K's are disjoint and f is in interior)
	have f_inj: "inj_on f p"
	apply(simp add: inj_on_def)
	proof-
	{fix x y
	assume "x \<in> p" "y \<in> p"
	"f x = f y"
	then have "x = y"
	using f
	tagged_division_ofD(5)[OF assms(2)]
	(sledgehammer)
	by (smt case_prodE disjoint_insert(2) mk_disjoint_insert)}note * = this
	show "\<forall>x\<in>p. \<forall>y\<in>p. f x = f y \<longrightarrow> x = y" using * by auto
	qed
	let ?\<gamma>' = "\<lambda>x. if (\<exists>xK \<in> p. f xK = x) then (\<gamma> o fst o the_inv_into p f) x else \<gamma> x"
	have 2: "?\<gamma>' fine ?p'" using assms(3)
	apply(auto simp add: fine_def case_prod_beta the_inv_into_f_f[OF f_inj])
	by force
	have 3: "gauge ?\<gamma>'"
	using assms(5) assms(3) f'
	apply(auto simp add: fine_def gauge_def case_prod_beta the_inv_into_f_f[OF f_inj])
	by force
	have "?p' tagged_division_of {a..b} \<and> ?\<gamma>' fine ?p' \<and> (\<forall>(x, K)\<in>?p'. x \<notin> s) \<and> gauge ?\<gamma>'"
	using 0 1 2 3 by auto
	then show ?thesis by smt
	qed

	lemma has_integral_bound_spike_finite:
	fixes f :: "'a::euclidean_space \<Rightarrow> 'b::real_normed_vector"
	assumes "0 \<le> B" and "finite S"
	and f: "(f has_integral i) (cbox a b)"
	and leB: "\<And>x. x \<in> cbox a b - S \<Longrightarrow> norm (f x) \<le> B"
	shows "norm i \<le> B * content (cbox a b)"
	proof -
	define g where "g \<equiv> (\<lambda>x. if x \<in> S then 0 else f x)"
	then have "\<And>x. x \<in> cbox a b - S \<Longrightarrow> norm (g x) \<le> B"
	using leB by simp
	moreover have "(g has_integral i) (cbox a b)"
	using has_integral_spike_finite [OF \<open>finite S\<close> _ f]
	by (simp add: g_def)
	ultimately show ?thesis
	by (simp add: \<open>0 \<le> B\<close> g_def has_integral_bound)
	qed

	lemma has_integral_bound_:
	fixes f :: "real \<Rightarrow> 'a::real_normed_vector"
	assumes "a < b"
	and "0 \<le> B"
	and f: "(f has_integral i) (cbox a b)"
	and "finite s"
	and "\<forall>x\<in>(cbox a b)-s. norm (f x) \<le> B"
	shows "norm i \<le> B * content (cbox a b)"
	using has_integral_bound_spike_finite assms by blast

	corollary has_integral_bound_real':
	fixes f :: "real \<Rightarrow> 'b::real_normed_vector"
	assumes "0 \<le> B"
	and f: "(f has_integral i) (cbox a b)"
	and "finite s"
	and "\<forall>x\<in>(cbox a b)-s. norm (f x) \<le> B"
	shows "norm i \<le> B * content {a..b}"
	(sledgehammer)
	by (metis assms(1) assms(3) assms(4) box_real(2) f has_integral_bound_spike_finite)

	lemma integral_has_vector_derivative_continuous_at':
	fixes f :: "real \<Rightarrow> 'a::banach"
	assumes "finite s"
	and f: "f integrable_on {a..b}"
	and x: "x \<in> {a..b} - s"
	and fx: "continuous (at x within ({a..b} - s)) f"
	shows "((\<lambda>u. integral {a..u} f) has_vector_derivative f x) (at x within ({a..b} - s))"
	proof -
	let ?I = "\<lambda>a b. integral {a..b} f"
	{ fix e::real
	assume "e > 0"
	obtain d where "d>0" and d: "\<And>x'. \<lbrakk>x' \<in> {a..b} - s; \<bar>x' - x\<bar> < d\<rbrakk> \<Longrightarrow> norm(f x' - f x) \<le> e"
	using \<open>e>0\<close> fx by (auto simp: continuous_within_eps_delta dist_norm less_imp_le)
	have "norm (integral {a..y} f - integral {a..x} f - (y-x) \<^sub>R f x) \<le> e \<bar>y - x\<bar>"
	if y: "y \<in> {a..b} - s" and yx: "\<bar>y - x\<bar> < d" for y
	proof (cases "y < x")
	case False
	have "f integrable_on {a..y}"
	using f y by (simp add: integrable_subinterval_real)
	then have Idiff: "?I a y - ?I a x = ?I x y"
	using False x by (simp add: algebra_simps Henstock_Kurzweil_Integration.integral_combine)
	have fux_int: "((\<lambda>u. f u - f x) has_integral integral {x..y} f - (y-x) *\<^sub>R f x) {x..y}"
	apply (rule has_integral_diff)
	using x y apply (auto intro: integrable_integral [OF integrable_subinterval_real [OF f]])
	using has_integral_const_real [of "f x" x y] False
	- apply (simp add: )
	+ apply simp
	done
	show ?thesis
	using False
	apply (simp add: abs_eq_content del: content_real_if measure_lborel_Icc)
	apply (rule has_integral_bound_real'[where f="(\<lambda>u. f u - f x)"])
	using yx False d x y \<open>e>0\<close> apply (auto simp add: Idiff fux_int)
	proof-
	let ?M48= "mset_set s"
	show "\<And>z. y - x < d \<Longrightarrow> (\<And>x'. a \<le> x' \<and> x' \<le> b \<and> x' \<notin> s \<Longrightarrow> \<bar>x' - x\<bar> < d \<Longrightarrow> norm (f x' - f x) \<le> e) \<Longrightarrow> 0 < e \<Longrightarrow> z \<notin># ?M48 \<Longrightarrow> a \<le> x \<Longrightarrow> x \<notin> s \<Longrightarrow> y \<le> b \<Longrightarrow> y \<notin> s \<Longrightarrow> x \<le> z \<Longrightarrow> z \<le> y \<Longrightarrow> norm (f z - f x) \<le> e"
	using assms by auto
	qed
	next
	case True
	have "f integrable_on {a..x}"
	using f x by (simp add: integrable_subinterval_real)
	then have Idiff: "?I a x - ?I a y = ?I y x"
	using True x y by (simp add: algebra_simps Henstock_Kurzweil_Integration.integral_combine)
	have fux_int: "((\<lambda>u. f u - f x) has_integral integral {y..x} f - (x - y) *\<^sub>R f x) {y..x}"
	apply (rule has_integral_diff)
	using x y apply (auto intro: integrable_integral [OF integrable_subinterval_real [OF f]])
	using has_integral_const_real [of "f x" y x] True
	- apply (simp add: )
	+ apply simp
	done
	have "norm (integral {a..x} f - integral {a..y} f - (x - y) \<^sub>R f x) \<le> e \<bar>y - x\<bar>"
	using True
	apply (simp add: abs_eq_content del: content_real_if measure_lborel_Icc)
	apply (rule has_integral_bound_real'[where f="(\<lambda>u. f u - f x)"])
	using yx True d x y \<open>e>0\<close> apply (auto simp add: Idiff fux_int)
	proof-
	let ?M44= "mset_set s"
	show " \<And>xa. x - y < d \<Longrightarrow> y < x \<Longrightarrow> (\<And>x'. a \<le> x' \<and> x' \<le> b \<and> x' \<notin> s \<Longrightarrow> \<bar>x' - x\<bar> < d \<Longrightarrow> norm (f x' - f x) \<le> e) \<Longrightarrow> 0 < e \<Longrightarrow> xa \<notin># ?M44 \<Longrightarrow> x \<le> b \<Longrightarrow> x \<notin> s \<Longrightarrow> a \<le> y \<Longrightarrow> y \<notin> s \<Longrightarrow> y \<le> xa \<Longrightarrow> xa \<le> x \<Longrightarrow> norm (f xa - f x) \<le> e"
	using assms by auto
	qed
	then show ?thesis
	by (simp add: algebra_simps norm_minus_commute)
	qed
	then have "\<exists>d>0. \<forall>y\<in>{a..b} - s. \<bar>y - x\<bar> < d \<longrightarrow> norm (integral {a..y} f - integral {a..x} f - (y-x) \<^sub>R f x) \<le> e \<bar>y - x\<bar>"
	using \<open>d>0\<close> by blast
	}
	then show ?thesis
	by (simp add: has_vector_derivative_def has_derivative_within_alt bounded_linear_scaleR_left)
	qed

	lemma integral_has_vector_derivative':
	fixes f :: "real \<Rightarrow> 'a::banach"
	assumes "finite s"
	"f integrable_on {a..b}"
	"x \<in> {a..b} - s"
	"continuous (at x within {a..b} - s) f"
	shows "((\<lambda>u. integral {a .. u} f) has_vector_derivative f(x)) (at x within {a .. b} - s)"
	apply (rule integral_has_vector_derivative_continuous_at')
	using assms
	apply (auto simp: continuous_on_eq_continuous_within)
	done

	lemma fundamental_theorem_of_calculus_interior_stronger:
	fixes f :: "real \<Rightarrow> 'a::banach"
	assumes "finite S"
	and "a \<le> b" "\<And>x. x \<in> {a <..< b} - S \<Longrightarrow> (f has_vector_derivative f'(x)) (at x)"
	and "continuous_on {a .. b} f"
	shows "(f' has_integral (f b - f a)) {a .. b}"
	using assms
	proof (induction arbitrary: a b)
	case empty
	then show ?case
	using fundamental_theorem_of_calculus_interior by force
	next
	case (insert x S)
	show ?case
	proof (cases "x \<in> {a<..<b}")
	case False then show ?thesis
	using insert by blast
	next
	case True then have "a < x" "x < b"
	by auto
	have "(f' has_integral f x - f a) {a..x}"
	apply (rule insert)
	using \<open>a < x\<close> \<open>x < b\<close> insert.prems continuous_on_subset by force+
	moreover have "(f' has_integral f b - f x) {x..b}"
	apply (rule insert)
	using \<open>x < b\<close> \<open>a < x\<close> insert.prems continuous_on_subset by force+
	ultimately show ?thesis
	by (meson finite_insert fundamental_theorem_of_calculus_interior_strong insert.hyps(1) insert.prems(1) insert.prems(2) insert.prems(3))
	qed
	qed

	lemma at_within_closed_interval_finite:
	fixes x::real
	assumes "a < x" "x < b" "x \<notin> S" "finite S"
	shows "(at x within {a..b} - S) = at x"
	proof -
	have "interior ({a..b} - S) = {a<..<b} - S"
	using \<open>finite S\<close>
	by (simp add: interior_diff finite_imp_closed)
	then show ?thesis
	using at_within_interior assms by fastforce
	qed

	lemma at_within_cbox_finite:
	assumes "x \<in> box a b" "x \<notin> S" "finite S"
	shows "(at x within cbox a b - S) = at x"
	proof -
	have "interior (cbox a b - S) = box a b - S"
	using \<open>finite S\<close> by (simp add: interior_diff finite_imp_closed)
	then show ?thesis
	using at_within_interior assms by fastforce
	qed

	lemma fundamental_theorem_of_calculus_interior_stronger':
	fixes f :: "real \<Rightarrow> 'a::banach"
	assumes "finite S"
	and "a \<le> b" "\<And>x. x \<in> {a <..< b} - S \<Longrightarrow> (f has_vector_derivative f'(x)) (at x within {a..b} - S)"
	and "continuous_on {a .. b} f"
	shows "(f' has_integral (f b - f a)) {a .. b}"
	using assms fundamental_theorem_of_calculus_interior_strong at_within_cbox_finite
	(sledgehammer)
	by (metis DiffD1 DiffD2 interior_atLeastAtMost_real interior_cbox interval_cbox)

	lemma has_integral_substitution_general_:
	fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> real"
	assumes s: "finite s" and le: "a \<le> b"
	and subset: "g ` {a..b} \<subseteq> {c..d}"
	and f: "f integrable_on {c..d}" "continuous_on ({c..d} - (g ` s)) f"
	(and f [continuous_intros]: "continuous_on {c..d} f")
	and g : "continuous_on {a..b} g" "inj_on g ({a..b} \<union> s)"
	and deriv [derivative_intros]:
	"\<And>x. x \<in> {a..b} - s \<Longrightarrow> (g has_field_derivative g' x) (at x within {a..b})"
	shows "((\<lambda>x. g' x *\<^sub>R f (g x)) has_integral (integral {g a..g b} f - integral {g b..g a} f)) {a..b}"
	proof -
	let ?F = "\<lambda>x. integral {c..g x} f"
	have cont_int: "continuous_on {a..b} ?F"
	by (rule continuous_on_compose2[OF _ g(1) subset] indefinite_integral_continuous_1
	f)+
	have deriv: "\<And>x. x \<in> {a..b} - s \<Longrightarrow> (((\<lambda>x. integral {c..x} f) \<circ> g) has_vector_derivative g' x *\<^sub>R f (g x))
	(at x within ({a..b} - s))"
	apply (rule has_vector_derivative_eq_rhs)
	apply (rule vector_diff_chain_within)
	apply (subst has_field_derivative_iff_has_vector_derivative [symmetric])
	proof-
	fix x::real
	assume ass: "x \<in> {a..b} - s"
	let ?f'3 = "g' x"
	have i:"{a..b} - s \<subseteq> {a..b}" by auto
	have ii: " (g has_vector_derivative g' x) (at x within {a..b})" using deriv[OF ass]
	by (simp only: has_field_derivative_iff_has_vector_derivative)
	show "(g has_real_derivative ?f'3) (at x within {a..b} - s)"
	using has_vector_derivative_within_subset[OF ii i]
	by (simp only: has_field_derivative_iff_has_vector_derivative)
	next
	let ?g'3 = "f o g"
	show "\<And>x. x \<in> {a..b} - s \<Longrightarrow> ((\<lambda>x. integral {c..x} f) has_vector_derivative ?g'3 x) (at (g x) within g ` ({a..b} - s))"
	proof-
	fix x::real
	assume ass: "x \<in> {a..b} - s"
	have "finite (g ` s)" using s by auto
	then have i: "((\<lambda>x. integral {c..x} f) has_vector_derivative f(g x)) (at (g x) within ({c..d} - g ` s))"
	apply (rule integral_has_vector_derivative')
	proof-
	show " f integrable_on {c..d}" using f by auto
	show "g x \<in> {c..d} - g ` s" using ass subset
	(sledgehammer)
	by (smt Diff_iff Un_upper1 Un_upper2 g(2) imageE image_subset_iff inj_onD subsetCE)
	show "continuous (at (g x) within {c..d} - g ` s) f"
	(sledgehammer)
	using \<open>g x \<in> {c..d} - g ` s\<close> continuous_on_eq_continuous_within f(2) by blast
	qed
	have ii: "g ` ({a..b} - s) \<subseteq> ({c..d} - g ` s)"
	using subset g(2)
	(sledgehammer)
	by (smt Diff_subset Un_Diff Un_commute Un_upper2 inj_on_image_set_diff subset_trans sup.order_iff)
	then show "((\<lambda>x. integral {c..x} f) has_vector_derivative ?g'3 x) (at (g x) within g ` ({a..b} - s))"
	(sledgehammer)
	by (smt Diff_subset has_vector_derivative_weaken Un_upper1 Un_upper2 \<open>finite (g ` s)\<close> ass comp_def continuous_on_eq_continuous_within f(1) f(2) g(2) image_diff_subset image_subset_iff inj_on_image_set_diff integral_has_vector_derivative_continuous_at' subset_trans)
	qed
	show "\<And>x. x \<in> {a..b} - s \<Longrightarrow> g' x \<^sub>R ?g'3 x = g' x \<^sub>R f (g x)" by auto
	qed
	have deriv: "(?F has_vector_derivative g' x *\<^sub>R f (g x))
	(at x within {a..b} - s)" if "x \<in> {a<..<b} - (s)" for x
	using deriv[of x] that by (simp add: at_within_Icc_at o_def)
	have "((\<lambda>x. g' x *\<^sub>R f (g x)) has_integral (?F b - ?F a)) {a..b}"
	using cont_int
	using fundamental_theorem_of_calculus_interior_stronger'[OF s le deriv]
	by blast
	also
	from subset have "g x \<in> {c..d}" if "x \<in> {a..b}" for x using that by blast
	from this[of a] this[of b] le have cd: "c \<le> g a" "g b \<le> d" "c \<le> g b" "g a \<le> d" by auto
	have "integral {c..g b} f - integral {c..g a} f = integral {g a..g b} f - integral {g b..g a} f"
	proof cases
	assume "g a \<le> g b"
	note le = le this
	from cd have "integral {c..g a} f + integral {g a..g b} f = integral {c..g b} f"
	by (meson Henstock_Kurzweil_Integration.integral_combine atLeastatMost_subset_iff f(1) integrable_on_subinterval le(2) order_refl)
	with le show ?thesis
	by (cases "g a = g b") (simp_all add: algebra_simps)
	next
	assume less: "\<not>g a \<le> g b"
	then have "g a \<ge> g b" by simp
	note le = le this
	from cd have "integral {c..g b} f + integral {g b..g a} f = integral {c..g a} f"
	by (meson Henstock_Kurzweil_Integration.integral_combine atLeastatMost_subset_iff f(1) integrable_on_subinterval le(2) order_refl)
	with less show ?thesis
	by (simp_all add: algebra_simps)
	qed
	finally show ?thesis .
	qed

	lemma has_integral_substitution_general__:
	fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> real"
	assumes s: "finite s" and le: "a \<le> b" and s_subset: "s \<subseteq> {a..b}"
	and subset: "g ` {a..b} \<subseteq> {c..d}"
	and f: "f integrable_on {c..d}" "continuous_on ({c..d} - (g ` s)) f"
	(and f [continuous_intros]: "continuous_on {c..d} f")
	and g : "continuous_on {a..b} g" "inj_on g {a..b}"
	and deriv [derivative_intros]:
	"\<And>x. x \<in> {a..b} - s \<Longrightarrow> (g has_field_derivative g' x) (at x within {a..b})"
	shows "((\<lambda>x. g' x *\<^sub>R f (g x)) has_integral (integral {g a..g b} f - integral {g b..g a} f)) {a..b}"
	using s_subset has_integral_substitution_general_[OF s le subset f g(1) _ deriv]
	by (simp add: g(2) sup_absorb1)

	lemma has_integral_substitution_general_':
	fixes f :: "real \<Rightarrow> 'a::euclidean_space" and g :: "real \<Rightarrow> real"
	assumes s: "finite s" and le: "a \<le> b" and s': "finite s'"
	and subset: "g ` {a..b} \<subseteq> {c..d}"
	and f: "f integrable_on {c..d}" "continuous_on ({c..d} - s') f"
	and g : "continuous_on {a..b} g" "\<forall>x\<in>s'. finite (g -` {x})" "surj_on s' g" "inj_on g ({a..b} \<union> ((s \<union> g -` s')))"
	and deriv [derivative_intros]:
	"\<And>x. x \<in> {a..b} - s \<Longrightarrow> (g has_field_derivative g' x) (at x within {a..b})"
	shows "((\<lambda>x. g' x *\<^sub>R f (g x)) has_integral (integral {g a..g b} f - integral {g b..g a} f)) {a..b}"
	proof-
	have a: "g -` s' = \<Union>{t. \<exists>x. t = g -` {x} \<and> x \<in> s'}"
	using s s' by blast
	have "finite (\<Union>{t. \<exists>x. t = g -` {x} \<and> x \<in> s'})" using s'
	by (metis (no_types, lifting) \<open>g -` s' = \<Union>{g -` {x} \|x. x \<in> s'}\<close> finite_UN_I g(2) vimage_eq_UN)
	then have 0: "finite (s \<union> (g -` s'))"
	using a s
	by simp
	have 1: "continuous_on ({c..d} - g ` (s \<union> g -` s')) f"
	using f(2) surj_on_image_vimage_eq
	by (metis Diff_mono Un_upper2 continuous_on_subset equalityE g(3) image_Un)
	have 2: " (\<And>x. x \<in> {a..b} - (s \<union> g -` s') \<Longrightarrow> (g has_real_derivative g' x) (at x within {a..b}))"
	using deriv by auto
	show ?thesis using has_integral_substitution_general_[OF 0 assms(2) subset f(1) 1 g(1) g(4) 2]
	by auto
	qed

	end
	diff --git a/thys/Hoare_Time/Big_StepT_Partial.thy b/thys/Hoare_Time/Big_StepT_Partial.thy
	--- a/thys/Hoare_Time/Big_StepT_Partial.thy
	+++ b/thys/Hoare_Time/Big_StepT_Partial.thy
	@@ -1,500 +1,500 @@
	subsection "Big step Semantics on partial states"

	theory Big_StepT_Partial
	imports Partial_Evaluation Big_StepT "SepLogAdd/Sep_Algebra_Add"
	"HOL-Eisbach.Eisbach"
	begin


	type_synonym lvname = string
	type_synonym pstate_t = "partstate * nat"
	type_synonym assnp = "partstate \<Rightarrow> bool"
	type_synonym assn2 = "pstate_t \<Rightarrow> bool"

	subsubsection \<open>helper functions\<close>

	paragraph \<open>restrict\<close>

	definition restrict where "restrict S s = (%x. if x:S then Some (s x) else None)"

	lemma restrictI: "\<forall>x\<in>S. s1 x = s2 x \<Longrightarrow> restrict S s1 = restrict S s2"
	unfolding restrict_def by fastforce

	lemma restrictE: "restrict S s1 = restrict S s2 \<Longrightarrow> s1 = s2 on S"
	unfolding restrict_def by (meson option.inject)

	lemma dom_restrict[simp]: "dom (restrict S s) = S"
	unfolding restrict_def
	using domIff by fastforce

	lemma restrict_less_part: "restrict S t \<preceq> part t"
	unfolding restrict_def map_le_substate_conv[symmetric] map_le_def part_def apply auto
	by (metis option.simps(3))

	paragraph \<open>Heap helper functions\<close>

	fun lmaps_to_expr :: "aexp \<Rightarrow> val \<Rightarrow> assn2" where
	"lmaps_to_expr a v = (%(s,c). dom s = vars a \<and> paval a s = v \<and> c = 0)"

	fun lmaps_to_expr_x :: "vname \<Rightarrow> aexp \<Rightarrow> val \<Rightarrow> assn2" where
	"lmaps_to_expr_x x a v = (%(s,c). dom s = vars a \<union> {x} \<and> paval a s = v \<and> c = 0)"

	lemma subState: "x \<preceq> y \<Longrightarrow> v \<in> dom x \<Longrightarrow> x v = y v" unfolding map_le_substate_conv[symmetric] map_le_def
	by blast

	lemma fixes ps:: partstate
	and s::state
	assumes "vars a \<subseteq> dom ps" "ps \<preceq> part s"
	shows emb_update: "emb [x \<mapsto> paval a ps] s = (emb ps s) (x := aval a (emb ps s))"
	using assms
	unfolding emb_def apply auto apply (rule ext)
	apply(case_tac "v=x")
	apply(simp add: paval_aval)
	apply(simp) unfolding part_def apply(case_tac "v \<in> dom ps")
	using subState apply fastforce
	by (simp add: domIff)

	lemma paval_aval2: "vars a \<subseteq> dom ps \<Longrightarrow> ps \<preceq> part s \<Longrightarrow> paval a ps = aval a s"
	apply(induct a) using subState unfolding part_def apply auto
	by fastforce

	lemma fixes ps:: partstate
	and s::state
	assumes "vars a \<subseteq> dom ps" "ps \<preceq> part s"
	shows emb_update2: "emb (ps(x \<mapsto> paval a ps)) s = (emb ps s)(x := aval a (emb ps s))"
	using assms
	unfolding emb_def apply auto apply (rule ext)
	apply(case_tac "v=x")
	apply(simp add: paval_aval)
	by (simp)


	subsubsection "Big step Semantics on partial states"

	inductive
	big_step_t_part :: "com \<times> partstate \<Rightarrow> nat \<Rightarrow> partstate \<Rightarrow> bool" ("_ \<Rightarrow>\<^sub>A _ \<Down> _" 55)
	where
	Skip: "(SKIP,s) \<Rightarrow>\<^sub>A Suc 0 \<Down> s" \|
	Assign: "\<lbrakk> vars a \<union> {x} \<subseteq> dom ps; paval a ps = v ; ps' = ps(x \<mapsto> v) \<rbrakk> \<Longrightarrow> (x ::= a,ps) \<Rightarrow>\<^sub>A Suc 0 \<Down> ps'" \|

	Seq: "\<lbrakk> (c1,s1) \<Rightarrow>\<^sub>A x \<Down> s2; (c2,s2) \<Rightarrow>\<^sub>A y \<Down> s3 ; z=x+y \<rbrakk> \<Longrightarrow> (c1;;c2, s1) \<Rightarrow>\<^sub>A z \<Down> s3" \|

	IfTrue: "\<lbrakk> vars b \<subseteq> dom ps ; dom ps' = dom ps ; pbval b ps; (c1,ps) \<Rightarrow>\<^sub>A x \<Down> ps'; y=x+1 \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, ps) \<Rightarrow>\<^sub>A y \<Down> ps'" \|
	IfFalse: "\<lbrakk> vars b \<subseteq> dom ps ; dom ps' = dom ps ; \<not> pbval b ps; (c2,ps) \<Rightarrow>\<^sub>A x \<Down> ps'; y=x+1 \<rbrakk> \<Longrightarrow> (IF b THEN c1 ELSE c2, ps) \<Rightarrow>\<^sub>A y \<Down> ps'" \|
	WhileFalse: "\<lbrakk> vars b \<subseteq> dom s; \<not> pbval b s \<rbrakk> \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow>\<^sub>A Suc 0 \<Down> s" \|
	WhileTrue: "\<lbrakk> pbval b s1; vars b \<subseteq> dom s1; (c,s1) \<Rightarrow>\<^sub>A x \<Down> s2; (WHILE b DO c, s2) \<Rightarrow>\<^sub>A y \<Down> s3; 1+x+y=z \<rbrakk>
	\<Longrightarrow> (WHILE b DO c, s1) \<Rightarrow>\<^sub>A z \<Down> s3"


	declare big_step_t_part.intros [intro]


	inductive_cases Skip_tE3[elim!]: "(SKIP,s) \<Rightarrow>\<^sub>A x \<Down> t"
	thm Skip_tE3
	inductive_cases Assign_tE3[elim!]: "(x ::= a,s) \<Rightarrow>\<^sub>A p \<Down> t"
	thm Assign_tE3
	inductive_cases Seq_tE3[elim!]: "(c1;;c2,s1) \<Rightarrow>\<^sub>A p \<Down> s3"
	thm Seq_tE3
	inductive_cases If_tE3[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow>\<^sub>A x \<Down> t"
	thm If_tE3
	inductive_cases While_tE3[elim]: "(WHILE b DO c,s) \<Rightarrow>\<^sub>A x \<Down> t"
	thm While_tE3


	lemmas big_step_t_part_induct = big_step_t_part.induct[split_format(complete)]


	lemma big_step_t3_post_dom_conv: "(c,ps) \<Rightarrow>\<^sub>A t \<Down> ps' \<Longrightarrow> dom ps' = dom ps"
	apply(induct rule: big_step_t_part_induct) apply (auto simp: sep_disj_fun_def plus_fun_def)
	apply metis done

	lemma add_update_distrib: "ps1 x1 = Some y \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> vars x2 \<subseteq> dom ps1 \<Longrightarrow> ps1(x1 \<mapsto> paval x2 ps1) + ps2 = (ps1 + ps2)(x1 \<mapsto> paval x2 ps1)"
	apply (rule ext)
	apply (auto simp: sep_disj_fun_def plus_fun_def)
	by (metis disjoint_iff_not_equal domI domain_conv)

	lemma paval_extend: "ps1 ## ps2 \<Longrightarrow> vars a \<subseteq> dom ps1 \<Longrightarrow> paval a (ps1 + ps2) = paval a ps1"
	apply(induct a) apply (auto simp: sep_disj_fun_def domain_conv)
	by (metis domI map_add_comm map_add_dom_app_simps(1) option.sel plus_fun_conv)

	lemma pbval_extend: "ps1 ## ps2 \<Longrightarrow> vars b \<subseteq> dom ps1 \<Longrightarrow> pbval b (ps1 + ps2) = pbval b ps1"
	apply(induct b) by (auto simp: paval_extend)


	lemma Framer: "(C, ps1) \<Rightarrow>\<^sub>A m \<Down> ps1' \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> (C, ps1 + ps2) \<Rightarrow>\<^sub>A m \<Down> ps1'+ps2"
	proof (induct rule: big_step_t_part_induct)
	case (Skip s)
	then show ?case by (auto simp: big_step_t_part.Skip)
	next
	case (Assign a x ps v ps')
	show ?case apply(rule big_step_t_part.Assign)
	using Assign
	apply (auto simp: plus_fun_def)
	apply(rule ext)
	apply(case_tac "xa=x")
	- subgoal apply (auto simp: ) subgoal using paval_extend[unfolded plus_fun_def] by auto
	+ subgoal apply auto subgoal using paval_extend[unfolded plus_fun_def] by auto
	unfolding sep_disj_fun_def
	by (metis disjoint_iff_not_equal domI domain_conv)
	subgoal by auto
	done
	next
	case (IfTrue b ps ps' c1 x y c2)
	then show ?case apply (auto ) apply(subst big_step_t_part.IfTrue)
	apply (auto simp: pbval_extend)
	subgoal by (auto simp: plus_fun_def)
	subgoal by (auto simp: plus_fun_def)
	subgoal by (auto simp: plus_fun_def)
	done
	next
	case (IfFalse b ps ps' c2 x y c1)
	then show ?case apply (auto ) apply(subst big_step_t_part.IfFalse)
	apply (auto simp: pbval_extend)
	subgoal by (auto simp: plus_fun_def)
	subgoal by (auto simp: plus_fun_def)
	subgoal by (auto simp: plus_fun_def)
	done
	next
	case (WhileFalse b s c)
	then show ?case apply(subst big_step_t_part.WhileFalse)
	subgoal by (auto simp: plus_fun_def)
	subgoal by (auto simp: pbval_extend)
	by auto
	next
	case (WhileTrue b s1 c x s2 y s3 z)
	from big_step_t3_post_dom_conv[OF WhileTrue(3)] have "dom s2 = dom s1" by auto
	with WhileTrue(8) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
	with WhileTrue show ?case apply auto apply(subst big_step_t_part.WhileTrue)
	subgoal by (auto simp: pbval_extend)
	subgoal by (auto simp: plus_fun_def)
	apply (auto) done
	next
	case (Seq c1 s1 x s2 c2 y s3 z)
	from big_step_t3_post_dom_conv[OF Seq(1)] have "dom s2 = dom s1" by auto
	with Seq(6) have "s2 ## ps2" unfolding sep_disj_fun_def domain_conv by auto
	with Seq show ?case apply (subst big_step_t_part.Seq)
	by auto
	qed


	lemma Framer2: "(C, ps1) \<Rightarrow>\<^sub>A m \<Down> ps1' \<Longrightarrow> ps1 ## ps2 \<Longrightarrow> ps = ps1 + ps2 \<Longrightarrow> ps' = ps1'+ps2 \<Longrightarrow> (C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' "
	using Framer by auto

	(* connection to bigstep2 *)

	subsubsection \<open>Relation to BigStep Semantic on full states\<close>

	lemma paval_aval_part: "paval a (part s) = aval a s"
	apply(induct a) by (auto simp: part_def)
	lemma pbval_bval_part: "pbval b (part s) = bval b s"
	apply(induct b) by (auto simp: paval_aval_part)


	lemma part_paval_aval: "part (s(x := aval a s)) = part s(x \<mapsto> paval a (part s))"
	apply(rule ext)
	apply(case_tac "xa=x")
	unfolding part_def apply auto by (metis (full_types) domIff map_le_def map_le_substate_conv option.distinct(1) part_def paval_aval2 subsetI)


	lemma full_to_part: "(C, s) \<Rightarrow> m \<Down> s' \<Longrightarrow> (C, part s) \<Rightarrow>\<^sub>A m \<Down> part s' "
	apply(induct rule: big_step_t_induct)
	using Skip apply simp
	apply (subst Assign)
	using part_paval_aval apply(simp_all add: )
	apply(rule Seq) apply auto
	apply(rule IfTrue) apply (auto simp: pbval_bval_part)
	apply(rule IfFalse) apply (auto simp: pbval_bval_part)
	apply(rule WhileFalse) apply (auto simp: pbval_bval_part)
	apply(rule WhileTrue) apply (auto simp: pbval_bval_part)
	done

	lemma part_to_full': "(C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<Longrightarrow> (C, emb ps s) \<Rightarrow> m \<Down> emb ps' s"
	proof (induct rule: big_step_t_part_induct)
	case (Assign a x ps v ps')
	have z: "paval a ps = aval a (emb ps s)"
	apply(rule paval_aval_vars) using Assign(1) by auto
	have g :"emb ps' s = (emb ps s)(x:=aval a (emb ps s) )"
	apply(simp only: Assign z[symmetric])
	unfolding emb_def by auto
	show ?case apply(simp only: g) by(rule big_step_t.Assign)
	qed (auto simp: pbval_bval_vars[symmetric])


	lemma part_to_full: "(C, part s) \<Rightarrow>\<^sub>A m \<Down> part s' \<Longrightarrow> (C, s) \<Rightarrow> m \<Down> s'"
	proof -
	assume "(C, part s) \<Rightarrow>\<^sub>A m \<Down> part s'"
	then have "(C, emb (part s) s) \<Rightarrow> m \<Down> emb (part s') s" by (rule part_to_full')
	then show "(C, s) \<Rightarrow> m \<Down> s'" by auto
	qed


	lemma part_full_equiv: "(C, s) \<Rightarrow> m \<Down> s' \<longleftrightarrow> (C, part s) \<Rightarrow>\<^sub>A m \<Down> part s'"
	using part_to_full full_to_part by metis

	subsubsection \<open>more properties\<close>

	lemma big_step_t3_gt0: "(C, ps) \<Rightarrow>\<^sub>A x \<Down> ps' \<Longrightarrow> x > 0"
	apply(induct rule: big_step_t_part_induct) apply auto done

	lemma big_step_t3_same: "(C, ps) \<Rightarrow>\<^sub>A m \<Down> ps' ==> ps = ps' on UNIV - lvars C"
	apply(induct rule: big_step_t_part_induct) by (auto simp: sep_disj_fun_def plus_fun_def)

	lemma avalDirekt3_correct: " (x ::= N v, ps) \<Rightarrow>\<^sub>A m \<Down> ps' \<Longrightarrow> paval' a ps = Some v \<Longrightarrow> (x ::= a, ps) \<Rightarrow>\<^sub>A m \<Down> ps'"
	apply(auto) apply(subst Assign) by (auto simp: paval_paval' paval'dom)




	subsection \<open>Partial State\<close>



	(* partialstate and nat is a separation algebra ! *)
	lemma
	fixes h :: "(vname \<Rightarrow> val option) * nat"
	shows "(P Q H) h = (Q H P) h"
	by (simp add: sep_conj_ac)

	lemma separate_othogonal_commuted': assumes
	"\<And>ps n. P (ps,n) \<Longrightarrow> ps = 0"
	"\<And>ps n. Q (ps,n) \<Longrightarrow> n = 0"
	shows "(P ** Q) s \<longleftrightarrow> P (0,snd s) \<and> Q (fst s,0)"
	using assms unfolding sep_conj_def by force


	lemma separate_othogonal_commuted: assumes
	"\<And>ps n. P (ps,n) \<Longrightarrow> ps = 0"
	"\<And>ps n. Q (ps,n) \<Longrightarrow> n = 0"
	shows "(P ** Q) (ps,n) \<longleftrightarrow> P (0,n) \<and> Q (ps,0)"
	using assms unfolding sep_conj_def by force


	lemma separate_othogonal: assumes
	"\<And>ps n. P (ps,n) \<Longrightarrow> n = 0"
	"\<And>ps n. Q (ps,n) \<Longrightarrow> ps = 0"
	shows "(P ** Q) (ps,n) \<longleftrightarrow> P (ps,0) \<and> Q (0,n)"
	using assms unfolding sep_conj_def by force

	lemma assumes " ((\<lambda>(s, n). P (s, n) \<and> vars b \<subseteq> dom s) \<and>* (\<lambda>(s, c). s = 0 \<and> c = Suc 0)) (ps, n)"
	shows "\<exists> n'. P (ps, n') \<and> vars b \<subseteq> dom ps \<and> n = Suc n'"
	proof -
	from assms obtain x y where " x ## y" and "(ps, n) = x + y"
	and 2: "(case x of (s, n) \<Rightarrow> P (s, n) \<and> vars b \<subseteq> dom s)"
	and "(case y of (s, c) \<Rightarrow> s = 0 \<and> c = Suc 0)"
	unfolding sep_conj_def by blast
	then have "y = (0, Suc 0)" and f: "fst x = ps" and n: "n = snd x + Suc 0" by auto

	with 2 have "P (ps, snd x) \<and> vars b \<subseteq> dom ps \<and> n = Suc (snd x)"
	by auto
	then show ?thesis by simp
	qed




	subsection \<open>Dollar and Pointsto\<close>

	definition dollar :: "nat \<Rightarrow> assn2" ("$") where
	"dollar q = (%(s,c). s = 0 \<and> c=q)"


	lemma sep_reorder_dollar_aux:
	"NO_MATCH ($X) A \<Longrightarrow> ($B A) = (A $B)"
	"($X ** $Y) = $(X+Y)"
	apply (auto simp: sep_simplify)
	unfolding dollar_def sep_conj_def sep_disj_prod_def sep_disj_nat_def by auto

	lemmas sep_reorder_dollar = sep_conj_assoc sep_reorder_dollar_aux

	lemma stardiff: assumes "(P \<and>* $m) (ps, n)"
	shows P: "P (ps, n - m)" and "m\<le>n" using assms unfolding sep_conj_def dollar_def by auto

	lemma [simp]: "(Q ** $0) = Q" unfolding dollar_def sep_conj_def sep_disj_prod_def sep_disj_nat_def
	by auto

	definition embP :: "(partstate \<Rightarrow> bool) \<Rightarrow> partstate \<times> nat \<Rightarrow> bool" where "embP P = (%(s,n). P s \<and> n = 0)"


	lemma orthogonal_split: assumes "(embP Q \<and>* $ n) = (embP P \<and>* $ m)"
	shows "(Q = P \<and> n = m) \<or> Q = (\<lambda>s. False) \<and> P = (\<lambda>s. False)"
	using assms unfolding embP_def dollar_def apply (auto intro!: ext)
	unfolding sep_conj_def apply auto unfolding sep_disj_prod_def plus_prod_def
	apply (metis fst_conv snd_conv)+ done

	(* how to set up case rules *)

	lemma F: assumes "(embP Q \<and>* $ n) = (embP P \<and>* $ m)"
	obtains (blub) "Q = P" and "n = m" \|
	(da) "Q = (\<lambda>s. False)" and "P = (\<lambda>s. False)"
	using assms orthogonal_split by auto

	lemma T: assumes "(embP Q \<and>* $ n) = (embP P \<and>* $ m)"
	obtains (blub) x::nat where "Q = P" and "n = m" and "x=x" \|
	(da) "Q = (\<lambda>s. False)" and "P = (\<lambda>s. False)"
	using assms orthogonal_split by auto


	definition pointsto :: "vname \<Rightarrow> val \<Rightarrow> assn2" ("_ \<hookrightarrow> _" [56,51] 56) where
	"v \<hookrightarrow> n = (%(s,c). s = [v \<mapsto> n] \<and> c=0)"

	(* If you don't mind syntax ambiguity: *)
	notation pred_ex (binder "\<exists>" 10)

	definition maps_to_ex :: "vname \<Rightarrow> assn2" ("_ \<hookrightarrow> -" [56] 56)
	where "x \<hookrightarrow> - \<equiv> \<exists>y. x \<hookrightarrow> y"

	fun lmaps_to_ex :: "vname set \<Rightarrow> assn2" where
	"lmaps_to_ex xs = (%(s,c). dom s = xs \<and> c = 0)"


	lemma "(x \<hookrightarrow> -) (s,n) \<Longrightarrow> x \<in> dom s"
	unfolding maps_to_ex_def pointsto_def by auto

	fun lmaps_to_axpr :: "bexp \<Rightarrow> bool \<Rightarrow> assnp" where
	"lmaps_to_axpr b bv = (%ps. vars b \<subseteq> dom ps \<and> pbval b ps = bv )"

	definition lmaps_to_axpr' :: "bexp \<Rightarrow> bool \<Rightarrow> assnp" where
	"lmaps_to_axpr' b bv = lmaps_to_axpr b bv"




	subsection \<open>Frame Inference\<close>

	definition Frame where "Frame P Q F \<equiv> \<forall>s. (P imp (Q ** F)) s"
	definition Frame' where "Frame' P P' Q F \<equiv> \<forall>s. (( P' P) imp (Q F)) s"

	definition cnv where "cnv x y == x = y"

	lemma cnv_I: "cnv x x"
	unfolding cnv_def by simp

	lemma Frame'_conv: "Frame P Q F = Frame' (P \<box>) \<box> (Q \<box>) F"
	unfolding Frame_def Frame'_def apply auto done

	lemma Frame'I: "Frame' (P \<box>) \<box> (Q \<box>) F \<Longrightarrow> cnv F F' \<Longrightarrow> Frame P Q F'"
	unfolding Frame_def Frame'_def cnv_def apply auto done

	lemma FrameD: assumes "Frame P Q F" " P s "
	shows "(F ** Q) s"
	using assms unfolding Frame_def by (auto simp: sep_conj_commute)

	lemma Frame'_match: "Frame' (P P') \<box> Q F \<Longrightarrow> Frame' (x \<hookrightarrow> v P) P' (x \<hookrightarrow> v ** Q) F"
	unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)
	by (metis (no_types, opaque_lifting) prod.collapse sep.mult_assoc sep_conj_impl1)

	lemma R: assumes "\<And>s. (A imp B) s" shows "((A $n) imp (B $n)) s"
	proof (safe)
	assume "(A \<and>* $ n) s"
	then obtain h1 h2 where A: "A h1" and n: "$n h2" and disj: "h1 ## h2" "s = h1+h2" unfolding sep_conj_def by blast
	from assms A have B: "B h1" by auto
	show "(B ** $n) s" using B n disj unfolding sep_conj_def by blast
	qed

	lemma Frame'_matchdollar: assumes "Frame' (P P' $(n-m)) \<box> Q F" and nm: "n\<ge>m"
	shows "Frame' ($n P) P' ($m Q) F"
	using assms(1) unfolding Frame_def Frame'_def apply (auto simp: sep_conj_ac)
	proof (goal_cases)
	case (1 a b)
	have g: "((P \<and>* P' \<and>* $ n) imp (F \<and>* Q \<and>* $ m)) (a, b)
	\<longleftrightarrow> (((P \<and>* P' \<and>* $(n-m)) ** $m) imp ((F \<and>* Q) \<and>* $ m)) (a, b)"
	by(simp add: nm sep_reorder_dollar)
	have "((P \<and>* P' \<and>* $ n) imp (F \<and>* Q \<and>* $ m)) (a, b)"
	apply(subst g)
	apply(rule R) using 1(1) by auto
	then have "(P \<and>* P' \<and>* $ n) (a, b) \<longrightarrow> (F \<and>* Q \<and>* $ m) (a, b)"
	by blast
	then show ?case using 1(2) by auto
	qed

	lemma Frame'_nomatch: " Frame' P (p P') (x \<hookrightarrow> v Q) F\<Longrightarrow> Frame' (p P) P' (x \<hookrightarrow> v Q) F"
	unfolding Frame'_def by (auto simp: sep_conj_ac)

	lemma Frame'_nomatchempty: " Frame' P P' (x \<hookrightarrow> v Q) F\<Longrightarrow> Frame' (\<box> P) P' (x \<hookrightarrow> v ** Q) F"
	unfolding Frame'_def by (auto simp: sep_conj_ac)

	(* this will only be reached after a Frame'_match move, where P' is \<box> *)
	lemma Frame'_end: " Frame' P \<box> \<box> P"
	unfolding Frame'_def by (auto simp: sep_conj_ac)

	schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2) (x \<hookrightarrow> ?v) ?F"
	apply(rule Frame'I) apply(simp only: sep_conj_assoc)
	apply(rule Frame'_match)
	apply(rule Frame'_end) apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I) done

	schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2) (y \<hookrightarrow> ?v) ?F"
	apply(rule Frame'I) apply(simp only: sep_conj_assoc)
	apply(rule Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
	apply(simp only: sep_conj_ac sep_conj_empty' sep_conj_empty) apply(rule cnv_I)
	done

	method frame_inference_init = (rule Frame'I, (simp only: sep_conj_assoc)?)

	method frame_inference_solve = (rule Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+

	method frame_inference_cleanup = ( (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?; rule cnv_I)


	method frame_inference = (frame_inference_init, (frame_inference_solve; fail), (frame_inference_cleanup; fail))
	method frame_inference_debug = (frame_inference_init, frame_inference_solve)

	subsubsection \<open>tests\<close>

	schematic_goal "Frame (x \<hookrightarrow> v1 \<and>* y \<hookrightarrow> v2) (y \<hookrightarrow> ?v) ?F"
	by frame_inference

	schematic_goal "Frame (x \<hookrightarrow> v1 P \<box> ** y \<hookrightarrow> v2 \<and>* z \<hookrightarrow> v2 Q) (z \<hookrightarrow> ?v y \<hookrightarrow> ?v2) ?F"
	by frame_inference

	(* with dollar *)

	schematic_goal " 1 \<le> v \<Longrightarrow> Frame ($ (2 * v) \<and>* ''x'' \<hookrightarrow> int v) ($ 1 \<and>* ''x'' \<hookrightarrow> ?d) ?F"
	apply(rule Frame'I) apply(simp only: sep_conj_assoc)
	apply(rule Frame'_matchdollar Frame'_end Frame'_match Frame'_nomatchempty Frame'_nomatch; (simp only: sep_conj_assoc)?)+
	apply (simp only: sep_conj_ac sep_conj_empty' sep_conj_empty)?
	apply (rule cnv_I) done


	schematic_goal " 0 < v \<Longrightarrow> Frame ($ (2 * v) \<and>* ''x'' \<hookrightarrow> int v) ($ 1 \<and>* ''x'' \<hookrightarrow> ?d) ?F"
	apply frame_inference done

	subsection \<open>Expression evaluation\<close>

	definition symeval where "symeval P e v \<equiv> (\<forall>s n. P (s,n) \<longrightarrow> paval' e s = Some v)"
	definition symevalb where "symevalb P e v \<equiv> (\<forall>s n. P (s,n) \<longrightarrow> pbval' e s = Some v)"

	lemma symeval_c: "symeval P (N v) v"
	unfolding symeval_def apply auto done


	lemma symeval_v: assumes "Frame P (x \<hookrightarrow> v) F"
	shows "symeval P (V x) v"
	unfolding symeval_def apply auto
	apply (drule FrameD[OF assms]) unfolding sep_conj_def pointsto_def
	apply (auto simp: plus_fun_conv) done

	lemma symeval_plus: assumes "symeval P e1 v1" "symeval P e2 v2"
	shows "symeval P (Plus e1 e2) (v1+v2)"
	using assms unfolding symeval_def by auto


	lemma symevalb_c: "symevalb P (Bc v) v"
	unfolding symevalb_def apply auto done

	lemma symevalb_and: assumes "symevalb P e1 v1" "symevalb P e2 v2"
	shows "symevalb P (And e1 e2) (v1 \<and> v2)"
	using assms unfolding symevalb_def by auto

	lemma symevalb_not: assumes "symevalb P e v"
	shows "symevalb P (Not e) (\<not> v)"
	using assms unfolding symevalb_def by auto

	lemma symevalb_less: assumes "symeval P e1 v1" "symeval P e2 v2"
	shows "symevalb P (Less e1 e2) (v1 < v2)"
	using assms unfolding symevalb_def symeval_def by auto

	lemmas symeval = symeval_c symeval_v symeval_plus symevalb_c symevalb_and symevalb_not symevalb_less

	schematic_goal "symevalb ( (x \<hookrightarrow> v1) ** (y \<hookrightarrow> v2) ) (Less (Plus (V x) (V y)) (N 5)) ?g"
	apply(rule symeval \| frame_inference)+ done

	end
	\ No newline at end of file
	diff --git a/thys/IP_Addresses/WordInterval.thy b/thys/IP_Addresses/WordInterval.thy
	--- a/thys/IP_Addresses/WordInterval.thy
	+++ b/thys/IP_Addresses/WordInterval.thy
	@@ -1,777 +1,777 @@
	(* Title: WordInterval.thy
	Authors: Julius Michaelis, Cornelius Diekmann
	*)
	theory WordInterval
	imports
	Main
	"Word_Lib.Word_Lemmas"
	"Word_Lib.Next_and_Prev"
	begin

	section\<open>WordInterval: Executable datatype for Machine Word Sets\<close>
	text\<open>Stores ranges of machine words as interval. This has been proven quite efficient for
	IP Addresses.\<close>
	(*NOTE: All algorithms here use a straight-forward implementation. There is a lot of room for
	improving the computation complexity, for example by making the WordInterval a balanced,
	sorted tree.*)

	subsection\<open>Syntax\<close>
	context
	notes [[typedef_overloaded]]
	begin
	datatype ('a::len) wordinterval = WordInterval
	"('a::len) word" \<comment> \<open>start (inclusive)\<close>
	"('a::len) word" \<comment> \<open>end (inclusive)\<close>
	\| RangeUnion "'a wordinterval" "'a wordinterval"
	end

	subsection\<open>Semantics\<close>
	fun wordinterval_to_set :: "'a::len wordinterval \<Rightarrow> ('a::len word) set"
	where
	"wordinterval_to_set (WordInterval start end) =
	{start .. end}" \|
	"wordinterval_to_set (RangeUnion r1 r2) =
	wordinterval_to_set r1 \<union> wordinterval_to_set r2"

	(*Note: The runtime of all the operations could be improved, for example by keeping the tree sorted
	and balanced.*)

	subsection\<open>Basic operations\<close>
	text\<open>\<open>\<in>\<close>\<close>
	fun wordinterval_element :: "'a::len word \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
	"wordinterval_element el (WordInterval s e) \<longleftrightarrow> s \<le> el \<and> el \<le> e" \|
	"wordinterval_element el (RangeUnion r1 r2) \<longleftrightarrow>
	wordinterval_element el r1 \<or> wordinterval_element el r2"
	lemma wordinterval_element_set_eq[simp]:
	"wordinterval_element el rg = (el \<in> wordinterval_to_set rg)"
	by(induction rg rule: wordinterval_element.induct) simp_all

	definition wordinterval_union
	:: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
	"wordinterval_union r1 r2 = RangeUnion r1 r2"
	lemma wordinterval_union_set_eq[simp]:
	"wordinterval_to_set (wordinterval_union r1 r2) = wordinterval_to_set r1 \<union> wordinterval_to_set r2"
	unfolding wordinterval_union_def by simp

	fun wordinterval_empty :: "'a::len wordinterval \<Rightarrow> bool" where
	"wordinterval_empty (WordInterval s e) \<longleftrightarrow> e < s" \|
	"wordinterval_empty (RangeUnion r1 r2) \<longleftrightarrow> wordinterval_empty r1 \<and> wordinterval_empty r2"
	lemma wordinterval_empty_set_eq[simp]: "wordinterval_empty r \<longleftrightarrow> wordinterval_to_set r = {}"
	by(induction r) auto

	definition Empty_WordInterval :: "'a::len wordinterval" where
	"Empty_WordInterval \<equiv> WordInterval 1 0"
	lemma wordinterval_empty_Empty_WordInterval: "wordinterval_empty Empty_WordInterval"
	by(simp add: Empty_WordInterval_def)
	lemma Empty_WordInterval_set_eq[simp]: "wordinterval_to_set Empty_WordInterval = {}"
	by(simp add: Empty_WordInterval_def)



	subsection\<open>WordInterval and Lists\<close>
	text\<open>A list of \<open>(start, end)\<close> tuples.\<close>

	text\<open>wordinterval to list\<close>
	fun wi2l :: "'a::len wordinterval \<Rightarrow> ('a::len word \<times> 'a::len word) list" where
	"wi2l (RangeUnion r1 r2) = wi2l r1 @ wi2l r2" \|
	"wi2l (WordInterval s e) = (if e < s then [] else [(s,e)])"

	text\<open>list to wordinterval\<close>
	fun l2wi :: "('a::len word \<times> 'a word) list \<Rightarrow> 'a wordinterval" where
	"l2wi [] = Empty_WordInterval" \|
	"l2wi [(s,e)] = (WordInterval s e)" \|
	"l2wi ((s,e)#rs) = (RangeUnion (WordInterval s e) (l2wi rs))"


	lemma l2wi_append: "wordinterval_to_set (l2wi (l1@l2)) =
	wordinterval_to_set (l2wi l1) \<union> wordinterval_to_set (l2wi l2)"
	proof(induction l1 arbitrary: l2 rule:l2wi.induct)
	case 1 thus ?case by simp
	next
	case (2 s e l2) thus ?case by (cases l2) simp_all
	next
	case 3 thus ?case by force
	qed

	lemma l2wi_wi2l[simp]: "wordinterval_to_set (l2wi (wi2l r)) = wordinterval_to_set r"
	by(induction r) (simp_all add: l2wi_append)

	lemma l2wi: "wordinterval_to_set (l2wi l) = (\<Union> (i,j) \<in> set l. {i .. j})"
	by(induction l rule: l2wi.induct, simp_all)

	lemma wi2l: "(\<Union>(i,j)\<in>set (wi2l r). {i .. j}) = wordinterval_to_set r"
	by(induction r rule: wi2l.induct, simp_all)

	lemma l2wi_remdups[simp]: "wordinterval_to_set (l2wi (remdups ls)) = wordinterval_to_set (l2wi ls)"
	by(simp add: l2wi)

	lemma wi2l_empty[simp]: "wi2l Empty_WordInterval = []"
	unfolding Empty_WordInterval_def
	by simp


	subsection\<open>Optimizing and minimizing @{typ "('a::len) wordinterval"}s\<close>
	text\<open>Removing empty intervals\<close>
	context
	begin
	fun wordinterval_optimize_empty :: "'a::len wordinterval \<Rightarrow> 'a wordinterval" where
	"wordinterval_optimize_empty (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
	r2o = wordinterval_optimize_empty r2
	in if
	wordinterval_empty r1o
	then
	r2o
	else if
	wordinterval_empty r2o
	then
	r1o
	else
	RangeUnion r1o r2o)" \|
	"wordinterval_optimize_empty r = r"
	lemma wordinterval_optimize_empty_set_eq[simp]:
	"wordinterval_to_set (wordinterval_optimize_empty r) = wordinterval_to_set r"
	by(induction r) (simp_all add: Let_def)

	lemma wordinterval_optimize_empty_double:
	"wordinterval_optimize_empty (wordinterval_optimize_empty r) = wordinterval_optimize_empty r"
	by(induction r) (simp_all add: Let_def)

	private fun wordinterval_empty_shallow :: "'a::len wordinterval \<Rightarrow> bool" where
	"wordinterval_empty_shallow (WordInterval s e) \<longleftrightarrow> e < s" \|
	"wordinterval_empty_shallow (RangeUnion _ _) \<longleftrightarrow> False"
	private lemma helper_optimize_shallow:
	"wordinterval_empty_shallow (wordinterval_optimize_empty r) =
	wordinterval_empty (wordinterval_optimize_empty r)"
	by(induction r) fastforce+
	private fun wordinterval_optimize_empty2 where
	"wordinterval_optimize_empty2 (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
	r2o = wordinterval_optimize_empty r2
	in if
	wordinterval_empty_shallow r1o
	then
	r2o
	else if
	wordinterval_empty_shallow r2o
	then
	r1o
	else
	RangeUnion r1o r2o)" \|
	"wordinterval_optimize_empty2 r = r"
	lemma wordinterval_optimize_empty_code[code_unfold]:
	"wordinterval_optimize_empty = wordinterval_optimize_empty2"
	by (subst fun_eq_iff, clarify, rename_tac r, induct_tac r)
	(unfold wordinterval_optimize_empty.simps wordinterval_optimize_empty2.simps
	Let_def helper_optimize_shallow, simp_all)
	end



	text\<open>Merging overlapping intervals\<close>
	context
	begin

	private definition disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
	"disjoint A B \<equiv> A \<inter> B = {}"

	private primrec interval_of :: "('a::len) word \<times> 'a word \<Rightarrow> 'a word set" where
	"interval_of (s,e) = {s .. e}"
	declare interval_of.simps[simp del]

	private definition disjoint_intervals
	:: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
	where
	"disjoint_intervals A B \<equiv> disjoint (interval_of A) (interval_of B)"

	private definition not_disjoint_intervals
	:: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
	where
	"not_disjoint_intervals A B \<equiv> \<not> disjoint (interval_of A) (interval_of B)"

	private lemma [code]:
	"not_disjoint_intervals A B =
	(case A of (s,e) \<Rightarrow> case B of (s',e') \<Rightarrow> s \<le> e' \<and> s' \<le> e \<and> s \<le> e \<and> s' \<le> e')"
	apply(cases A, cases B)
	apply(simp add: not_disjoint_intervals_def interval_of.simps disjoint_def)
	done

	private lemma [code]:
	"disjoint_intervals A B =
	(case A of (s,e) \<Rightarrow> case B of (s',e') \<Rightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e')"
	apply(cases A, cases B)
	apply(simp add: disjoint_intervals_def interval_of.simps disjoint_def)
	by fastforce


	text\<open>BEGIN merging overlapping intervals\<close>
	(*result has no empty intervals and all are disjoint.
	merging things such as [1,7] [8,10] would still be possible*)
	private fun merge_overlap
	:: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
	where
	"merge_overlap s [] = [s]" \|
	"merge_overlap (s,e) ((s',e')#ss) = (
	if not_disjoint_intervals (s,e) (s',e')
	then (min s s', max e e')#ss
	else (s',e')#merge_overlap (s,e) ss)"

	private lemma not_disjoint_union:
	fixes s :: "('a::len) word"
	shows "\<not> disjoint {s..e} {s'..e'} \<Longrightarrow> {s..e} \<union> {s'..e'} = {min s s' .. max e e'}"
	by(auto simp add: disjoint_def min_def max_def)

	private lemma disjoint_subset: "disjoint A B \<Longrightarrow> A \<subseteq> B \<union> C \<Longrightarrow> A \<subseteq> C"
	unfolding disjoint_def
	by blast

	private lemma merge_overlap_helper1: "interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s) \<Longrightarrow>
	(\<Union>s \<in> set (merge_overlap A ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
	apply(induction ss)
	apply(simp; fail)
	apply(rename_tac x xs)
	apply(cases A, rename_tac a b)
	apply(case_tac x)
	apply(simp add: not_disjoint_intervals_def interval_of.simps)
	apply(intro impI conjI)
	apply(drule not_disjoint_union)
	apply blast
	apply(drule_tac C="(\<Union>x\<in>set xs. interval_of x)" in disjoint_subset)
	apply(simp_all)
	done

	private lemma merge_overlap_helper2: "\<exists>s'\<in>set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
	interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_overlap A ss). interval_of s)"
	apply(induction ss)
	apply(simp; fail)
	apply(rename_tac x xs)
	apply(cases A, rename_tac a b)
	apply(case_tac x)
	apply(simp add: not_disjoint_intervals_def interval_of.simps)
	apply(intro impI conjI)
	apply(drule not_disjoint_union)
	apply blast
	apply(simp)
	by blast

	private lemma merge_overlap_length:
	"\<exists>s' \<in> set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
	length (merge_overlap A ss) = length ss"
	apply(induction ss)
	apply(simp)
	apply(rename_tac x xs)
	apply(cases A, rename_tac a b)
	apply(case_tac x)
	apply(simp add: not_disjoint_intervals_def interval_of.simps)
	done

	lemma "merge_overlap (1:: 16 word,2) [(1, 7)] = [(1, 7)]" by eval
	lemma "merge_overlap (1:: 16 word,2) [(2, 7)] = [(1, 7)]" by eval
	lemma "merge_overlap (1:: 16 word,2) [(3, 7)] = [(3, 7), (1,2)]" by eval

	private function listwordinterval_compress
	:: "(('a::len) word \<times> ('a::len) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
	"listwordinterval_compress [] = []" \|
	"listwordinterval_compress (s#ss) = (
	if \<forall>s' \<in> set ss. disjoint_intervals s s'
	then s#listwordinterval_compress ss
	else listwordinterval_compress (merge_overlap s ss))"
	by(pat_completeness, auto)

	private termination listwordinterval_compress
	apply (relation "measure length")
	apply(rule wf_measure)
	apply(simp)
	using disjoint_intervals_def merge_overlap_length by fastforce

	private lemma listwordinterval_compress:
	"(\<Union>s \<in> set (listwordinterval_compress ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
	apply(induction ss rule: listwordinterval_compress.induct)
	apply(simp)
	apply(simp)
	apply(intro impI)
	apply(simp add: disjoint_intervals_def)
	apply(drule merge_overlap_helper2)
	apply(simp)
	done

	lemma "listwordinterval_compress [(1::32 word,3), (8,10), (2,5), (3,7)] = [(8, 10), (1, 7)]"
	by eval

	private lemma A_in_listwordinterval_compress: "A \<in> set (listwordinterval_compress ss) \<Longrightarrow>
	interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s)"
	using listwordinterval_compress by blast

	private lemma listwordinterval_compress_disjoint:
	"A \<in> set (listwordinterval_compress ss) \<Longrightarrow> B \<in> set (listwordinterval_compress ss) \<Longrightarrow>
	A \<noteq> B \<Longrightarrow> disjoint (interval_of A) (interval_of B)"
	apply(induction ss arbitrary: rule: listwordinterval_compress.induct)
	apply(simp)
	apply(simp split: if_split_asm)
	apply(elim disjE)
	apply(simp_all)
	apply(simp_all add: disjoint_intervals_def disjoint_def)
	apply(blast dest: A_in_listwordinterval_compress)+
	done
	text\<open>END merging overlapping intervals\<close>


	text\<open>BEGIN merging adjacent intervals\<close>
	private fun merge_adjacent
	:: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
	where
	"merge_adjacent s [] = [s]" \|
	"merge_adjacent (s,e) ((s',e')#ss) = (
	if s \<le>e \<and> s' \<le> e' \<and> word_next e = s'
	then (s, e')#ss
	else if s \<le>e \<and> s' \<le> e' \<and> word_next e' = s
	then (s', e)#ss
	else (s',e')#merge_adjacent (s,e) ss)"

	private lemma merge_adjacent_helper:
	"interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_adjacent A ss). interval_of s)"
	apply(induction ss)
	apply(simp; fail)
	apply(rename_tac x xs)
	apply(cases A, rename_tac a b)
	apply(case_tac x)
	apply(simp add: interval_of.simps)
	apply(intro impI conjI)
	apply (metis Un_assoc word_adjacent_union)
	apply(elim conjE)
	apply(drule(2) word_adjacent_union)
	subgoal by (blast)
	subgoal by (metis word_adjacent_union Un_assoc)
	by blast

	private lemma merge_adjacent_length:
	"\<exists>(s', e')\<in>set ss. s \<le> e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s)
	\<Longrightarrow> length (merge_adjacent (s,e) ss) = length ss"
	apply(induction ss)
	apply(simp)
	apply(rename_tac x xs)
	apply(case_tac x)
	- apply(simp add: )
	+ applysimp
	by blast

	private function listwordinterval_adjacent
	:: "(('a::len) word \<times> ('a::len) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
	"listwordinterval_adjacent [] = []" \|
	"listwordinterval_adjacent ((s,e)#ss) = (
	if \<forall>(s',e') \<in> set ss. \<not> (s \<le>e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s))
	then (s,e)#listwordinterval_adjacent ss
	else listwordinterval_adjacent (merge_adjacent (s,e) ss))"
	by(pat_completeness, auto)

	private termination listwordinterval_adjacent
	apply (relation "measure length")
	apply(rule wf_measure)
	apply(simp)
	apply(simp)
	using merge_adjacent_length by fastforce

	private lemma listwordinterval_adjacent:
	"(\<Union>s \<in> set (listwordinterval_adjacent ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
	apply(induction ss rule: listwordinterval_adjacent.induct)
	apply(simp)
	apply(simp add: merge_adjacent_helper)
	done

	lemma "listwordinterval_adjacent [(1::16 word, 3), (5, 10), (10,10), (4,4)] = [(10, 10), (1, 10)]"
	by eval
	text\<open>END merging adjacent intervals\<close>


	definition wordinterval_compress :: "('a::len) wordinterval \<Rightarrow> 'a wordinterval" where
	"wordinterval_compress r \<equiv>
	l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
	(wi2l (wordinterval_optimize_empty r)))))"

	text\<open>Correctness: Compression preserves semantics\<close>
	lemma wordinterval_compress:
	"wordinterval_to_set (wordinterval_compress r) = wordinterval_to_set r"
	unfolding wordinterval_compress_def
	proof -
	have interval_of': "interval_of s = (case s of (s,e) \<Rightarrow> {s .. e})" for s
	by (cases s) (simp add: interval_of.simps)

	have "wordinterval_to_set (l2wi (remdups (listwordinterval_adjacent
	(listwordinterval_compress (wi2l (wordinterval_optimize_empty r)))))) =
	(\<Union>x\<in>set (listwordinterval_adjacent (listwordinterval_compress
	(wi2l (wordinterval_optimize_empty r)))). interval_of x)"
	by (force simp: interval_of' l2wi)
	also have "\<dots> = (\<Union>s\<in>set (wi2l (wordinterval_optimize_empty r)). interval_of s)"
	by(simp add: listwordinterval_compress listwordinterval_adjacent)
	also have "\<dots> = (\<Union>(i, j)\<in>set (wi2l (wordinterval_optimize_empty r)). {i..j})"
	by(simp add: interval_of')
	also have "\<dots> = wordinterval_to_set r" by(simp add: wi2l)
	finally show "wordinterval_to_set
	(l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
	(wi2l (wordinterval_optimize_empty r))))))
	= wordinterval_to_set r" .
	qed

	end

	text\<open>Example\<close>
	lemma "(wi2l \<circ> (wordinterval_compress :: 32 wordinterval \<Rightarrow> 32 wordinterval) \<circ> l2wi)
	[(70, 80001), (0,0), (150, 8000), (1,3), (42,41), (3,7), (56, 200), (8,10)] =
	[(56, 80001), (0, 10)]" by eval

	lemma "wordinterval_compress (RangeUnion (RangeUnion (WordInterval (1::32 word) 5)
	(WordInterval 8 10)) (WordInterval 3 7)) =
	WordInterval 1 10" by eval



	subsection\<open>Further operations\<close>

	text\<open>\<open>\<Union>\<close>\<close>
	definition wordinterval_Union :: "('a::len) wordinterval list \<Rightarrow> 'a wordinterval" where
	"wordinterval_Union ws = wordinterval_compress (foldr wordinterval_union ws Empty_WordInterval)"

	lemma wordinterval_Union:
	"wordinterval_to_set (wordinterval_Union ws) = (\<Union> w \<in> (set ws). wordinterval_to_set w)"
	by(induction ws) (simp_all add: wordinterval_compress wordinterval_Union_def)


	context
	begin
	private fun wordinterval_setminus'
	:: "'a::len wordinterval \<Rightarrow> 'a wordinterval \<Rightarrow> 'a wordinterval" where
	"wordinterval_setminus' (WordInterval s e) (WordInterval ms me) = (
	if s > e \<or> ms > me then WordInterval s e else
	if me \<ge> e
	then
	WordInterval (if ms = 0 then 1 else s) (min e (word_prev ms))
	else if ms \<le> s
	then
	WordInterval (max s (word_next me)) (if me = - 1 then 0 else e)
	else
	RangeUnion (WordInterval (if ms = 0 then 1 else s) (word_prev ms))
	(WordInterval (word_next me) (if me = - 1 then 0 else e))
	)" \|
	"wordinterval_setminus' (RangeUnion r1 r2) t =
	RangeUnion (wordinterval_setminus' r1 t) (wordinterval_setminus' r2 t)"\|
	"wordinterval_setminus' t (RangeUnion r1 r2) =
	wordinterval_setminus' (wordinterval_setminus' t r1) r2"

	private lemma wordinterval_setminus'_rr_set_eq:
	"wordinterval_to_set(wordinterval_setminus' (WordInterval s e) (WordInterval ms me)) =
	wordinterval_to_set (WordInterval s e) - wordinterval_to_set (WordInterval ms me)"
	apply(simp only: wordinterval_setminus'.simps)
	apply(case_tac "e < s")
	apply simp
	apply(case_tac "me < ms")
	apply simp
	apply(case_tac [!] "e \<le> me")
	apply(case_tac [!] "ms = 0")
	apply(case_tac [!] "ms \<le> s")
	apply(case_tac [!] "me = - 1")
	apply(simp_all add: word_next_unfold word_prev_unfold min_def max_def)
	apply(safe)
	apply(auto)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	apply(uint_arith)
	done

	private lemma wordinterval_setminus'_set_eq:
	"wordinterval_to_set (wordinterval_setminus' r1 r2) =
	wordinterval_to_set r1 - wordinterval_to_set r2"
	apply(induction rule: wordinterval_setminus'.induct)
	using wordinterval_setminus'_rr_set_eq apply blast
	apply auto
	done
	lemma wordinterval_setminus'_empty_struct:
	"wordinterval_empty r2 \<Longrightarrow> wordinterval_setminus' r1 r2 = r1"
	by(induction r1 r2 rule: wordinterval_setminus'.induct) auto


	definition wordinterval_setminus
	:: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
	"wordinterval_setminus r1 r2 = wordinterval_compress (wordinterval_setminus' r1 r2)"

	lemma wordinterval_setminus_set_eq[simp]: "wordinterval_to_set (wordinterval_setminus r1 r2) =
	wordinterval_to_set r1 - wordinterval_to_set r2"
	by(simp add: wordinterval_setminus_def wordinterval_compress wordinterval_setminus'_set_eq)
	end

	definition wordinterval_UNIV :: "'a::len wordinterval" where
	"wordinterval_UNIV \<equiv> WordInterval 0 (- 1)"
	lemma wordinterval_UNIV_set_eq[simp]: "wordinterval_to_set wordinterval_UNIV = UNIV"
	unfolding wordinterval_UNIV_def
	using max_word_max by fastforce

	fun wordinterval_invert :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
	"wordinterval_invert r = wordinterval_setminus wordinterval_UNIV r"
	lemma wordinterval_invert_set_eq[simp]:
	"wordinterval_to_set (wordinterval_invert r) = UNIV - wordinterval_to_set r" by(auto)

	lemma wordinterval_invert_UNIV_empty:
	"wordinterval_empty (wordinterval_invert wordinterval_UNIV)" by simp

	lemma wi2l_univ[simp]: "wi2l wordinterval_UNIV = [(0, - 1)]"
	unfolding wordinterval_UNIV_def
	by simp

	text\<open>\<open>\<inter>\<close>\<close>
	context
	begin
	private lemma "{(s::nat) .. e} \<inter> {s' .. e'} = {} \<longleftrightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e'"
	by simp linarith
	private fun wordinterval_intersection'
	:: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
	"wordinterval_intersection' (WordInterval s e) (WordInterval s' e') = (
	if s > e \<or> s' > e' \<or> s > e' \<or> s' > e \<or> s > e \<or> s' > e'
	then
	Empty_WordInterval
	else
	WordInterval (max s s') (min e e')
	)" \|
	"wordinterval_intersection' (RangeUnion r1 r2) t =
	RangeUnion (wordinterval_intersection' r1 t) (wordinterval_intersection' r2 t)"\|
	"wordinterval_intersection' t (RangeUnion r1 r2) =
	RangeUnion (wordinterval_intersection' t r1) (wordinterval_intersection' t r2)"

	private lemma wordinterval_intersection'_set_eq:
	"wordinterval_to_set (wordinterval_intersection' r1 r2) =
	wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
	by(induction r1 r2 rule: wordinterval_intersection'.induct) (auto)

	lemma "wordinterval_intersection'
	(RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
	(WordInterval 1 3)) (WordInterval 1 3) =
	RangeUnion (RangeUnion (WordInterval 1 3) (WordInterval 1 0)) (WordInterval 1 3)" by eval

	definition wordinterval_intersection
	:: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
	"wordinterval_intersection r1 r2 \<equiv> wordinterval_compress (wordinterval_intersection' r1 r2)"

	lemma wordinterval_intersection_set_eq[simp]:
	"wordinterval_to_set (wordinterval_intersection r1 r2) =
	wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
	by(simp add: wordinterval_intersection_def
	wordinterval_compress wordinterval_intersection'_set_eq)

	lemma "wordinterval_intersection
	(RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
	(WordInterval 1 3)) (WordInterval 1 3) =
	WordInterval 1 3" by eval
	end


	definition wordinterval_subset :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
	"wordinterval_subset r1 r2 \<equiv> wordinterval_empty (wordinterval_setminus r1 r2)"
	lemma wordinterval_subset_set_eq[simp]:
	"wordinterval_subset r1 r2 = (wordinterval_to_set r1 \<subseteq> wordinterval_to_set r2)"
	unfolding wordinterval_subset_def by simp

	definition wordinterval_eq :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
	"wordinterval_eq r1 r2 = (wordinterval_subset r1 r2 \<and> wordinterval_subset r2 r1)"
	lemma wordinterval_eq_set_eq:
	"wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_to_set r1 = wordinterval_to_set r2"
	unfolding wordinterval_eq_def by auto

	thm iffD1[OF wordinterval_eq_set_eq]
	(declare iffD1[OF wordinterval_eq_set_eq, simp])

	lemma wordinterval_eq_comm: "wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_eq r2 r1"
	unfolding wordinterval_eq_def by fast
	lemma wordinterval_to_set_alt: "wordinterval_to_set r = {x. wordinterval_element x r}"
	unfolding wordinterval_element_set_eq by blast

	lemma wordinterval_un_empty:
	"wordinterval_empty r1 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r2"
	by(subst wordinterval_eq_set_eq, simp)
	lemma wordinterval_un_emty_b:
	"wordinterval_empty r2 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r1"
	by(subst wordinterval_eq_set_eq, simp)

	lemma wordinterval_Diff_triv:
	"wordinterval_empty (wordinterval_intersection a b) \<Longrightarrow> wordinterval_eq (wordinterval_setminus a b) a"
	unfolding wordinterval_eq_set_eq
	by simp blast



	text\<open>A size of the datatype, does not correspond to the cardinality of the corresponding set\<close>
	fun wordinterval_size :: "('a::len) wordinterval \<Rightarrow> nat" where
	"wordinterval_size (RangeUnion a b) = wordinterval_size a + wordinterval_size b" \|
	"wordinterval_size (WordInterval s e) = (if s \<le> e then 1 else 0)"

	lemma wordinterval_size_length: "wordinterval_size r = length (wi2l r)"
	by(induction r) (auto)

	lemma Ex_wordinterval_nonempty: "\<exists>x::('a::len wordinterval). y \<in> wordinterval_to_set x"
	proof show "y \<in> wordinterval_to_set wordinterval_UNIV" by simp qed

	lemma wordinterval_eq_reflp:
	"reflp wordinterval_eq"
	apply(rule reflpI)
	by(simp only: wordinterval_eq_set_eq)
	lemma wordintervalt_eq_symp:
	"symp wordinterval_eq"
	apply(rule sympI)
	by(simp add: wordinterval_eq_comm)
	lemma wordinterval_eq_transp:
	"transp wordinterval_eq"
	apply(rule transpI)
	by(simp only: wordinterval_eq_set_eq)

	lemma wordinterval_eq_equivp:
	"equivp wordinterval_eq"
	by (auto intro: equivpI wordinterval_eq_reflp wordintervalt_eq_symp wordinterval_eq_transp)


	text\<open>The smallest element in the interval\<close>
	definition is_lowest_element :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool" where
	"is_lowest_element x S = (x \<in> S \<and> (\<forall>y\<in>S. y \<le> x \<longrightarrow> y = x))"

	lemma
	fixes x :: "'a :: complete_lattice"
	assumes "x \<in> S"
	shows " x = Inf S \<Longrightarrow> is_lowest_element x S"
	using assms apply(simp add: is_lowest_element_def)
	by (simp add: Inf_lower eq_iff)

	lemma
	fixes x :: "'a :: linorder"
	assumes "finite S" and "x \<in> S"
	shows "is_lowest_element x S \<longleftrightarrow> x = Min S"
	apply(rule)
	subgoal
	apply(simp add: is_lowest_element_def)
	apply(subst Min_eqI[symmetric])
	using assms by(auto)
	by (metis Min.coboundedI assms(1) assms(2) dual_order.antisym is_lowest_element_def)

	text\<open>Smallest element in the interval\<close>
	fun wordinterval_lowest_element :: "'a::len wordinterval \<Rightarrow> 'a word option" where
	"wordinterval_lowest_element (WordInterval s e) = (if s \<le> e then Some s else None)" \|
	"wordinterval_lowest_element (RangeUnion A B) =
	(case (wordinterval_lowest_element A, wordinterval_lowest_element B) of
	(Some a, Some b) \<Rightarrow> Some (if a < b then a else b) \|
	(None, Some b) \<Rightarrow> Some b \|
	(Some a, None) \<Rightarrow> Some a \|
	(None, None) \<Rightarrow> None)"

	lemma wordinterval_lowest_none_empty: "wordinterval_lowest_element r = None \<longleftrightarrow> wordinterval_empty r"
	proof(induction r)
	case WordInterval thus ?case by simp
	next
	case RangeUnion thus ?case by fastforce
	qed


	lemma wordinterval_lowest_element_correct_A:
	"wordinterval_lowest_element r = Some x \<Longrightarrow> is_lowest_element x (wordinterval_to_set r)"
	unfolding is_lowest_element_def
	apply(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
	apply(rename_tac rs re x, case_tac "rs \<le> re", auto)[1]
	apply(subst(asm) wordinterval_lowest_element.simps(2))
	apply(rename_tac A B x)
	apply(case_tac "wordinterval_lowest_element B")
	apply(case_tac[!] "wordinterval_lowest_element A")
	apply(simp_all add: wordinterval_lowest_none_empty)[3]
	apply fastforce
	done


	lemma wordinterval_lowest_element_set_eq: assumes "\<not> wordinterval_empty r"
	shows "(wordinterval_lowest_element r = Some x) = (is_lowest_element x (wordinterval_to_set r))"
	(unfolding is_lowest_element_def)
	proof(rule iffI)
	assume "wordinterval_lowest_element r = Some x"
	thus "is_lowest_element x (wordinterval_to_set r)"
	using wordinterval_lowest_element_correct_A wordinterval_lowest_none_empty by simp
	next
	assume "is_lowest_element x (wordinterval_to_set r)"
	with assms show "(wordinterval_lowest_element r = Some x)"
	proof(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
	case 1 thus ?case by(simp add: is_lowest_element_def)
	next
	case (2 A B x)

	have is_lowest_RangeUnion: "is_lowest_element x (wordinterval_to_set A \<union> wordinterval_to_set B) \<Longrightarrow>
	is_lowest_element x (wordinterval_to_set A) \<or> is_lowest_element x (wordinterval_to_set B)"
	by(simp add: is_lowest_element_def)

	(why \<And> A B?)
	have wordinterval_lowest_element_RangeUnion:
	"\<And>a b A B. wordinterval_lowest_element A = Some a \<Longrightarrow>
	wordinterval_lowest_element B = Some b \<Longrightarrow>
	wordinterval_lowest_element (RangeUnion A B) = Some (min a b)"
	by(auto dest!: wordinterval_lowest_element_correct_A simp add: is_lowest_element_def min_def)

	from 2 show ?case
	apply(case_tac "wordinterval_lowest_element B")
	apply(case_tac[!] "wordinterval_lowest_element A")
	apply(auto simp add: is_lowest_element_def)[3]
	apply(subgoal_tac "\<not> wordinterval_empty A \<and> \<not> wordinterval_empty B")
	prefer 2
	using arg_cong[where f = Not, OF wordinterval_lowest_none_empty] apply blast
	apply(drule(1) wordinterval_lowest_element_RangeUnion)
	apply(simp split: option.split_asm add: min_def)
	apply(drule is_lowest_RangeUnion)
	apply(elim disjE)
	apply(simp add: is_lowest_element_def)
	apply(clarsimp simp add: wordinterval_lowest_none_empty)

	apply(simp add: is_lowest_element_def)
	apply(clarsimp simp add: wordinterval_lowest_none_empty)
	using wordinterval_lowest_element_correct_A[simplified is_lowest_element_def]
	by (metis Un_iff not_le)
	qed
	qed


	text\<open>Cardinality approximation for @{typ "('a::len) wordinterval"}s\<close>
	context
	begin
	lemma card_atLeastAtMost_word: fixes s::"('a::len) word" shows "card {s..e} = Suc (unat e) - (unat s)"
	apply(cases "s > e")
	apply(simp)
	apply(subst(asm) Word.word_less_nat_alt)
	apply simp
	apply(subst upto_enum_set_conv2[symmetric])
	apply(subst List.card_set)
	apply(simp add: remdups_enum_upto)
	done

	fun wordinterval_card :: "('a::len) wordinterval \<Rightarrow> nat" where
	"wordinterval_card (WordInterval s e) = Suc (unat e) - (unat s)" \|
	"wordinterval_card (RangeUnion a b) = wordinterval_card a + wordinterval_card b"

	lemma wordinterval_card: "wordinterval_card r \<ge> card (wordinterval_to_set r)"
	proof(induction r)
	case WordInterval thus ?case by (simp add: card_atLeastAtMost_word)
	next
	case (RangeUnion r1 r2)
	have "card (wordinterval_to_set r1 \<union> wordinterval_to_set r2) \<le>
	card (wordinterval_to_set r1) + card (wordinterval_to_set r2)"
	using Finite_Set.card_Un_le by blast
	with RangeUnion show ?case by(simp)
	qed

	text\<open>With @{thm wordinterval_compress} it should be possible to get the exact cardinality\<close>
	end

	end
	diff --git a/thys/Incompleteness/Sigma.thy b/thys/Incompleteness/Sigma.thy
	--- a/thys/Incompleteness/Sigma.thy
	+++ b/thys/Incompleteness/Sigma.thy
	@@ -1,597 +1,597 @@
	chapter \<open>Sigma-Formulas and Theorem 2.5\<close>

	theory Sigma
	imports Predicates
	begin

	section\<open>Ground Terms and Formulas\<close>

	definition ground_aux :: "tm \<Rightarrow> atom set \<Rightarrow> bool"
	where "ground_aux t S \<equiv> (supp t \<subseteq> S)"

	abbreviation ground :: "tm \<Rightarrow> bool"
	where "ground t \<equiv> ground_aux t {}"

	definition ground_fm_aux :: "fm \<Rightarrow> atom set \<Rightarrow> bool"
	where "ground_fm_aux A S \<equiv> (supp A \<subseteq> S)"

	abbreviation ground_fm :: "fm \<Rightarrow> bool"
	where "ground_fm A \<equiv> ground_fm_aux A {}"

	lemma ground_aux_simps[simp]:
	"ground_aux Zero S = True"
	"ground_aux (Var k) S = (if atom k \<in> S then True else False)"
	"ground_aux (Eats t u) S = (ground_aux t S \<and> ground_aux u S)"
	unfolding ground_aux_def
	by (simp_all add: supp_at_base)

	lemma ground_fm_aux_simps[simp]:
	"ground_fm_aux Fls S = True"
	"ground_fm_aux (t IN u) S = (ground_aux t S \<and> ground_aux u S)"
	"ground_fm_aux (t EQ u) S = (ground_aux t S \<and> ground_aux u S)"
	"ground_fm_aux (A OR B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (A AND B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (A IFF B) S = (ground_fm_aux A S \<and> ground_fm_aux B S)"
	"ground_fm_aux (Neg A) S = (ground_fm_aux A S)"
	"ground_fm_aux (Ex x A) S = (ground_fm_aux A (S \<union> {atom x}))"
	by (auto simp: ground_fm_aux_def ground_aux_def supp_conv_fresh)

	lemma ground_fresh[simp]:
	"ground t \<Longrightarrow> atom i \<sharp> t"
	"ground_fm A \<Longrightarrow> atom i \<sharp> A"
	unfolding ground_aux_def ground_fm_aux_def fresh_def
	by simp_all


	section\<open>Sigma Formulas\<close>

	text\<open>Section 2 material\<close>

	subsection \<open>Strict Sigma Formulas\<close>

	text\<open>Definition 2.1\<close>
	inductive ss_fm :: "fm \<Rightarrow> bool" where
	MemI: "ss_fm (Var i IN Var j)"
	\| DisjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A OR B)"
	\| ConjI: "ss_fm A \<Longrightarrow> ss_fm B \<Longrightarrow> ss_fm (A AND B)"
	\| ExI: "ss_fm A \<Longrightarrow> ss_fm (Ex i A)"
	\| All2I: "ss_fm A \<Longrightarrow> atom j \<sharp> (i,A) \<Longrightarrow> ss_fm (All2 i (Var j) A)"

	equivariance ss_fm

	nominal_inductive ss_fm
	avoids ExI: "i" \| All2I: "i"
	by (simp_all add: fresh_star_def)

	declare ss_fm.intros [intro]


	definition Sigma_fm :: "fm \<Rightarrow> bool"
	where "Sigma_fm A \<longleftrightarrow> (\<exists>B. ss_fm B \<and> supp B \<subseteq> supp A \<and> {} \<turnstile> A IFF B)"

	lemma Sigma_fm_Iff: "\<lbrakk>{} \<turnstile> B IFF A; supp A \<subseteq> supp B; Sigma_fm A\<rbrakk> \<Longrightarrow> Sigma_fm B"
	by (metis Sigma_fm_def Iff_trans order_trans)

	lemma ss_fm_imp_Sigma_fm [intro]: "ss_fm A \<Longrightarrow> Sigma_fm A"
	by (metis Iff_refl Sigma_fm_def order_refl)

	lemma Sigma_fm_Fls [iff]: "Sigma_fm Fls"
	by (rule Sigma_fm_Iff [of _ "Ex i (Var i IN Var i)"]) auto

	subsection\<open>Closure properties for Sigma-formulas\<close>

	lemma
	assumes "Sigma_fm A" "Sigma_fm B"
	shows Sigma_fm_AND [intro!]: "Sigma_fm (A AND B)"
	and Sigma_fm_OR [intro!]: "Sigma_fm (A OR B)"
	and Sigma_fm_Ex [intro!]: "Sigma_fm (Ex i A)"
	proof -
	obtain SA SB where "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
	and "ss_fm SB" "{} \<turnstile> B IFF SB" "supp SB \<subseteq> supp B"
	using assms by (auto simp add: Sigma_fm_def)
	then show "Sigma_fm (A AND B)" "Sigma_fm (A OR B)" "Sigma_fm (Ex i A)"
	apply (auto simp: Sigma_fm_def)
	apply (metis ss_fm.ConjI Conj_cong Un_mono supp_Conj)
	apply (metis ss_fm.DisjI Disj_cong Un_mono fm.supp(3))
	apply (rule exI [where x = "Ex i SA"])
	apply (auto intro!: Ex_cong)
	done
	qed

	lemma Sigma_fm_All2_Var:
	assumes H0: "Sigma_fm A" and ij: "atom j \<sharp> (i,A)"
	shows "Sigma_fm (All2 i (Var j) A)"
	proof -
	obtain SA where SA: "ss_fm SA" "{} \<turnstile> A IFF SA" "supp SA \<subseteq> supp A"
	using H0 by (auto simp add: Sigma_fm_def)
	show "Sigma_fm (All2 i (Var j) A)"
	apply (rule Sigma_fm_Iff [of _ "All2 i (Var j) SA"])
	apply (metis All2_cong Refl SA(2) emptyE)
	using SA ij
	apply (auto simp: supp_conv_fresh subset_iff)
	apply (metis ss_fm.All2I fresh_Pair ss_fm_imp_Sigma_fm)
	done
	qed


	section\<open>Lemma 2.2: Atomic formulas are Sigma-formulas\<close>

	lemma Eq_Eats_Iff:
	assumes [unfolded fresh_Pair, simp]: "atom i \<sharp> (z,x,y)"
	shows "{} \<turnstile> z EQ Eats x y IFF (All2 i z (Var i IN x OR Var i EQ y)) AND x SUBS z AND y IN z"
	proof (rule Iff_I, auto)
	have "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN Eats x y"
	by (metis Assume Iff_MP_left Iff_sym Mem_cong Refl)
	then show "{Var i IN z, z EQ Eats x y} \<turnstile> Var i IN x OR Var i EQ y"
	by (metis Iff_MP_same Mem_Eats_Iff)
	next
	show "{z EQ Eats x y} \<turnstile> x SUBS z"
	by (metis Iff_MP2_same Subset_cong [OF Refl Assume] Subset_Eats_I)
	next
	show "{z EQ Eats x y} \<turnstile> y IN z"
	by (metis Iff_MP2_same Mem_cong Assume Refl Mem_Eats_I2)
	next
	show "{x SUBS z, y IN z, All2 i z (Var i IN x OR Var i EQ y)} \<turnstile> z EQ Eats x y"
	(is "{_, _, ?allHyp} \<turnstile> _")
	apply (rule Eq_Eats_iff [OF assms, THEN Iff_MP2_same], auto)
	apply (rule Ex_I [where x="Var i"])
	apply (auto intro: Subset_D Mem_cong [OF Assume Refl, THEN Iff_MP2_same])
	done
	qed

	lemma Subset_Zero_sf: "Sigma_fm (Var i SUBS Zero)"
	proof -
	obtain j::name where j: "atom j \<sharp> i"
	by (rule obtain_fresh)
	hence Subset_Zero_Iff: "{} \<turnstile> Var i SUBS Zero IFF (All2 j (Var i) Fls)"
	by (auto intro!: Subset_I [of j] intro: Eq_Zero_D Subset_Zero_D All2_E [THEN rotate2])
	thus ?thesis using j
	by (auto simp: supp_conv_fresh
	intro!: Sigma_fm_Iff [OF Subset_Zero_Iff] Sigma_fm_All2_Var)
	qed

	lemma Eq_Zero_sf: "Sigma_fm (Var i EQ Zero)"
	proof -
	obtain j::name where "atom j \<sharp> i"
	by (rule obtain_fresh)
	thus ?thesis
	by (auto simp add: supp_conv_fresh
	intro!: Sigma_fm_Iff [OF _ _ Subset_Zero_sf] Subset_Zero_D EQ_imp_SUBS)
	qed

	lemma theorem_sf: assumes "{} \<turnstile> A" shows "Sigma_fm A"
	proof -
	obtain i::name and j::name
	where ij: "atom i \<sharp> (j,A)" "atom j \<sharp> A"
	by (metis obtain_fresh)
	show ?thesis
	apply (rule Sigma_fm_Iff [where A = "Ex i (Ex j (Var i IN Var j))"])
	using ij
	- apply (auto simp: )
	+ apply auto
	apply (rule Ex_I [where x=Zero], simp)
	apply (rule Ex_I [where x="Eats Zero Zero"])
	apply (auto intro: Mem_Eats_I2 assms thin0)
	done
	qed

	text \<open>The subset relation\<close>
	lemma Var_Subset_sf: "Sigma_fm (Var i SUBS Var j)"
	proof -
	obtain k::name where k: "atom (k::name) \<sharp> (i,j)"
	by (metis obtain_fresh)
	thus ?thesis
	proof (cases "i=j")
	case True thus ?thesis using k
	by (auto intro!: theorem_sf Subset_I [where i=k])
	next
	case False thus ?thesis using k
	by (auto simp: ss_fm_imp_Sigma_fm Subset.simps [of k] ss_fm.intros)
	qed
	qed

	lemma Zero_Mem_sf: "Sigma_fm (Zero IN Var i)"
	proof -
	obtain j::name where "atom j \<sharp> i"
	by (rule obtain_fresh)
	hence Zero_Mem_Iff: "{} \<turnstile> Zero IN Var i IFF (Ex j (Var j EQ Zero AND Var j IN Var i))"
	by (auto intro: Ex_I [where x = Zero] Mem_cong [OF Assume Refl, THEN Iff_MP_same])
	show ?thesis
	by (auto intro!: Sigma_fm_Iff [OF Zero_Mem_Iff] Eq_Zero_sf)
	qed

	lemma ijk: "i + k < Suc (i + j + k)"
	by arith

	lemma All2_term_Iff_fresh: "i\<noteq>j \<Longrightarrow> atom j' \<sharp> (i,j,A) \<Longrightarrow>
	{} \<turnstile> (All2 i (Var j) A) IFF Ex j' (Var j EQ Var j' AND All2 i (Var j') A)"
	apply auto
	apply (rule Ex_I [where x="Var j"], auto)
	apply (rule Ex_I [where x="Var i"], auto intro: ContraProve Mem_cong [THEN Iff_MP_same])
	done

	lemma Sigma_fm_All2_fresh:
	assumes "Sigma_fm A" "i\<noteq>j"
	shows "Sigma_fm (All2 i (Var j) A)"
	proof -
	obtain j'::name where j': "atom j' \<sharp> (i,j,A)"
	by (metis obtain_fresh)
	show "Sigma_fm (All2 i (Var j) A)"
	apply (rule Sigma_fm_Iff [OF All2_term_Iff_fresh [OF _ j']])
	using assms j'
	apply (auto simp: supp_conv_fresh Var_Subset_sf
	intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
	done
	qed

	lemma Subset_Eats_sf:
	assumes "\<And>j::name. Sigma_fm (Var j IN t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Var i SUBS Eats t u)"
	proof -
	obtain k::name where k: "atom k \<sharp> (t,u,Var i)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Var i SUBS Eats t u IFF All2 k (Var i) (Var k IN t OR Var k EQ u)"
	apply (auto simp: fresh_Pair intro: Set_MP Disj_I1 Disj_I2)
	apply (force intro!: Subset_I [where i=k] intro: All2_E' [OF Hyp] Mem_Eats_I1 Mem_Eats_I2)
	done
	thus ?thesis
	apply (rule Sigma_fm_Iff)
	using k
	apply (auto intro!: Sigma_fm_All2_fresh simp add: assms fresh_Pair supp_conv_fresh fresh_at_base)
	done
	qed

	lemma Eq_Eats_sf:
	assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Var i EQ Eats t u)"
	proof -
	obtain j::name and k::name and l::name
	where atoms: "atom j \<sharp> (t,u,i)" "atom k \<sharp> (t,u,i,j)" "atom l \<sharp> (t,u,i,j,k)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Var i EQ Eats t u IFF
	Ex j (Ex k (Var i EQ Eats (Var j) (Var k) AND Var j EQ t AND Var k EQ u))"
	apply auto
	apply (rule Ex_I [where x=t], simp)
	apply (rule Ex_I [where x=u], auto intro: Trans Eats_cong)
	done
	thus ?thesis
	apply (rule Sigma_fm_Iff)
	apply (auto simp: assms supp_at_base)
	apply (rule Sigma_fm_Iff [OF Eq_Eats_Iff [of l]])
	using atoms
	apply (auto simp: supp_conv_fresh fresh_at_base Var_Subset_sf
	intro!: Sigma_fm_All2_Var Sigma_fm_Iff [OF Extensionality _ _])
	done
	qed

	lemma Eats_Mem_sf:
	assumes "\<And>j::name. Sigma_fm (Var j EQ t)"
	and "\<And>k::name. Sigma_fm (Var k EQ u)"
	shows "Sigma_fm (Eats t u IN Var i)"
	proof -
	obtain j::name where j: "atom j \<sharp> (t,u,Var i)"
	by (metis obtain_fresh)
	hence "{} \<turnstile> Eats t u IN Var i IFF
	Ex j (Var j IN Var i AND Var j EQ Eats t u)"
	apply (auto simp: fresh_Pair intro: Ex_I [where x="Eats t u"])
	apply (metis Assume Mem_cong [OF _ Refl, THEN Iff_MP_same] rotate2)
	done
	thus ?thesis
	by (rule Sigma_fm_Iff) (auto simp: assms supp_conv_fresh Eq_Eats_sf)
	qed

	lemma Subset_Mem_sf_lemma:
	"size t + size u < n \<Longrightarrow> Sigma_fm (t SUBS u) \<and> Sigma_fm (t IN u)"
	proof (induction n arbitrary: t u rule: less_induct)
	case (less n t u)
	show ?case
	proof
	show "Sigma_fm (t SUBS u)"
	proof (cases t rule: tm.exhaust)
	case Zero thus ?thesis
	by (auto intro: theorem_sf)
	next
	case (Var i) thus ?thesis using less.prems
	apply (cases u rule: tm.exhaust)
	apply (auto simp: Subset_Zero_sf Var_Subset_sf)
	apply (force simp: supp_conv_fresh less.IH
	intro: Subset_Eats_sf Sigma_fm_Iff [OF Extensionality])
	done
	next
	case (Eats t1 t2) thus ?thesis using less.IH [OF _ ijk] less.prems
	by (auto intro!: Sigma_fm_Iff [OF Eats_Subset_Iff] simp: supp_conv_fresh)
	(metis add.commute)
	qed
	next
	show "Sigma_fm (t IN u)"
	proof (cases u rule: tm.exhaust)
	case Zero show ?thesis
	by (rule Sigma_fm_Iff [where A=Fls]) (auto simp: supp_conv_fresh Zero)
	next
	case (Var i) show ?thesis
	proof (cases t rule: tm.exhaust)
	case Zero thus ?thesis using \<open>u = Var i\<close>
	by (auto intro: Zero_Mem_sf)
	next
	case (Var j)
	thus ?thesis using \<open>u = Var i\<close>
	by auto
	next
	case (Eats t1 t2) thus ?thesis using \<open>u = Var i\<close> less.prems
	by (force intro: Eats_Mem_sf Sigma_fm_Iff [OF Extensionality _ _]
	simp: supp_conv_fresh less.IH [THEN conjunct1])
	qed
	next
	case (Eats t1 t2) thus ?thesis using less.prems
	by (force intro: Sigma_fm_Iff [OF Mem_Eats_Iff] Sigma_fm_Iff [OF Extensionality _ _]
	simp: supp_conv_fresh less.IH)
	qed
	qed
	qed

	lemma Subset_sf [iff]: "Sigma_fm (t SUBS u)"
	by (metis Subset_Mem_sf_lemma [OF lessI])

	lemma Mem_sf [iff]: "Sigma_fm (t IN u)"
	by (metis Subset_Mem_sf_lemma [OF lessI])

	text \<open>The equality relation is a Sigma-Formula\<close>
	lemma Equality_sf [iff]: "Sigma_fm (t EQ u)"
	by (auto intro: Sigma_fm_Iff [OF Extensionality] simp: supp_conv_fresh)


	section\<open>Universal Quantification Bounded by an Arbitrary Term\<close>

	lemma All2_term_Iff: "atom i \<sharp> t \<Longrightarrow> atom j \<sharp> (i,t,A) \<Longrightarrow>
	{} \<turnstile> (All2 i t A) IFF Ex j (Var j EQ t AND All2 i (Var j) A)"
	apply auto
	apply (rule Ex_I [where x=t], auto)
	apply (rule Ex_I [where x="Var i"])
	apply (auto intro: ContraProve Mem_cong [THEN Iff_MP2_same])
	done

	lemma Sigma_fm_All2 [intro!]:
	assumes "Sigma_fm A" "atom i \<sharp> t"
	shows "Sigma_fm (All2 i t A)"
	proof -
	obtain j::name where j: "atom j \<sharp> (i,t,A)"
	by (metis obtain_fresh)
	show "Sigma_fm (All2 i t A)"
	apply (rule Sigma_fm_Iff [OF All2_term_Iff [of i t j]])
	using assms j
	apply (auto simp: supp_conv_fresh Sigma_fm_All2_Var)
	done
	qed


	section \<open>Lemma 2.3: Sequence-related concepts are Sigma-formulas\<close>

	lemma OrdP_sf [iff]: "Sigma_fm (OrdP t)"
	proof -
	obtain z::name and y::name where "atom z \<sharp> t" "atom y \<sharp> (t, z)"
	by (metis obtain_fresh)
	thus ?thesis
	by (auto simp: OrdP.simps)
	qed

	lemma OrdNotEqP_sf [iff]: "Sigma_fm (OrdNotEqP t u)"
	by (auto simp: OrdNotEqP.simps)

	lemma HDomain_Incl_sf [iff]: "Sigma_fm (HDomain_Incl t u)"
	proof -
	obtain x::name and y::name and z::name
	where "atom x \<sharp> (t,u,y,z)" "atom y \<sharp> (t,u,z)" "atom z \<sharp> (t,u)"
	by (metis obtain_fresh)
	thus ?thesis
	by auto
	qed

	lemma HFun_Sigma_Iff:
	assumes "atom z \<sharp> (r,z',x,y,x',y')" "atom z' \<sharp> (r,x,y,x',y')"
	"atom x \<sharp> (r,y,x',y')" "atom y \<sharp> (r,x',y')"
	"atom x' \<sharp> (r,y')" "atom y' \<sharp> (r)"
	shows
	"{} \<turnstile>HFun_Sigma r IFF
	All2 z r (All2 z' r (Ex x (Ex y (Ex x' (Ex y'
	(Var z EQ HPair (Var x) (Var y) AND Var z' EQ HPair (Var x') (Var y')
	AND OrdP (Var x) AND OrdP (Var x') AND
	((Var x NEQ Var x') OR (Var y EQ Var y'))))))))"
	apply (simp add: HFun_Sigma.simps [OF assms])
	apply (rule Iff_refl All_cong Imp_cong Ex_cong)+
	apply (rule Conj_cong [OF Iff_refl])
	apply (rule Conj_cong [OF Iff_refl], auto)
	apply (blast intro: Disj_I1 Neg_D OrdNotEqP_I)
	apply (blast intro: Disj_I2)
	apply (blast intro: OrdNotEqP_E rotate2)
	done

	lemma HFun_Sigma_sf [iff]: "Sigma_fm (HFun_Sigma t)"
	proof -
	obtain x::name and y::name and z::name and x'::name and y'::name and z'::name
	where atoms: "atom z \<sharp> (t,z',x,y,x',y')" "atom z' \<sharp> (t,x,y,x',y')"
	"atom x \<sharp> (t,y,x',y')" "atom y \<sharp> (t,x',y')"
	"atom x' \<sharp> (t,y')" "atom y' \<sharp> (t)"
	by (metis obtain_fresh)
	show ?thesis
	by (auto intro!: Sigma_fm_Iff [OF HFun_Sigma_Iff [OF atoms]] simp: supp_conv_fresh atoms)
	qed

	lemma LstSeqP_sf [iff]: "Sigma_fm (LstSeqP t u v)"
	by (auto simp: LstSeqP.simps)


	section \<open>A Key Result: Theorem 2.5\<close>

	subsection \<open>Sigma-Eats Formulas\<close>

	inductive se_fm :: "fm \<Rightarrow> bool" where
	MemI: "se_fm (t IN u)"
	\| DisjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A OR B)"
	\| ConjI: "se_fm A \<Longrightarrow> se_fm B \<Longrightarrow> se_fm (A AND B)"
	\| ExI: "se_fm A \<Longrightarrow> se_fm (Ex i A)"
	\| All2I: "se_fm A \<Longrightarrow> atom i \<sharp> t \<Longrightarrow> se_fm (All2 i t A)"

	equivariance se_fm

	nominal_inductive se_fm
	avoids ExI: "i" \| All2I: "i"
	by (simp_all add: fresh_star_def)

	declare se_fm.intros [intro]

	lemma subst_fm_in_se_fm: "se_fm A \<Longrightarrow> se_fm (A(k::=x))"
	-by (nominal_induct avoiding: k x rule: se_fm.strong_induct) (auto)
	+ by (nominal_induct avoiding: k x rule: se_fm.strong_induct) (auto)

	subsection\<open>Preparation\<close>
	text\<open>To begin, we require some facts connecting quantification and ground terms.\<close>

	lemma obtain_const_tm: obtains t where "\<lbrakk>t\<rbrakk>e = x" "ground t"
	proof (induct x rule: hf_induct)
	case 0 thus ?case
	by (metis ground_aux_simps(1) eval_tm.simps(1))
	next
	case (hinsert y x) thus ?case
	by (metis ground_aux_simps(3) eval_tm.simps(3))
	qed

	lemma ex_eval_fm_iff_exists_tm:
	"eval_fm e (Ex k A) \<longleftrightarrow> (\<exists>t. eval_fm e (A(k::=t)) \<and> ground t)"
	by (auto simp: eval_subst_fm) (metis obtain_const_tm)

	text\<open>In a negative context, the formulation above is actually weaker than this one.\<close>
	lemma ex_eval_fm_iff_exists_tm':
	"eval_fm e (Ex k A) \<longleftrightarrow> (\<exists>t. eval_fm e (A(k::=t)))"
	by (auto simp: eval_subst_fm) (metis obtain_const_tm)

	text\<open>A ground term defines a finite set of ground terms, its elements.\<close>
	nominal_function elts :: "tm \<Rightarrow> tm set" where
	"elts Zero = {}"
	\| "elts (Var k) = {}"
	\| "elts (Eats t u) = insert u (elts t)"
	by (auto simp: eqvt_def elts_graph_aux_def) (metis tm.exhaust)

	nominal_termination (eqvt)
	by lexicographic_order

	lemma eval_fm_All2_Eats:
	"atom i \<sharp> (t,u) \<Longrightarrow>
	eval_fm e (All2 i (Eats t u) A) \<longleftrightarrow> eval_fm e (A(i::=u)) \<and> eval_fm e (All2 i t A)"
	by (simp only: ex_eval_fm_iff_exists_tm' eval_fm.simps) (auto simp: eval_subst_fm)

	text\<open>The term @{term t} must be ground, since @{term elts} doesn't handle variables.\<close>
	lemma eval_fm_All2_Iff_elts:
	"ground t \<Longrightarrow> eval_fm e (All2 i t A) \<longleftrightarrow> (\<forall>u \<in> elts t. eval_fm e (A(i::=u)))"
	apply (induct t rule: tm.induct)
	apply auto [2]
	apply (simp add: eval_fm_All2_Eats del: eval_fm.simps)
	done

	lemma prove_elts_imp_prove_All2:
	"ground t \<Longrightarrow> (\<And>u. u \<in> elts t \<Longrightarrow> {} \<turnstile> A(i::=u)) \<Longrightarrow> {} \<turnstile> All2 i t A"
	proof (induct t rule: tm.induct)
	case Zero thus ?case
	by auto
	next
	case (Var i) thus ?case \<comment> \<open>again: vacuously!\<close>
	by simp
	next
	case (Eats t u)
	hence pt: "{} \<turnstile> All2 i t A" and pu: "{} \<turnstile> A(i::=u)"
	by auto
	have "{} \<turnstile> ((Var i IN t) IMP A)(i ::= Var i)"
	by (rule All_D [OF pt])
	hence "{} \<turnstile> ((Var i IN t) IMP A)"
	by simp
	thus ?case using pu
	by (auto intro: anti_deduction) (metis Iff_MP_same Var_Eq_subst_Iff thin1)
	qed

	subsection\<open>The base cases: ground atomic formulas\<close>

	lemma ground_prove:
	"\<lbrakk>size t + size u < n; ground t; ground u\<rbrakk>
	\<Longrightarrow> (\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u) \<and> (\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u)"
	proof (induction n arbitrary: t u rule: less_induct)
	case (less n t u)
	show ?case
	proof
	show "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t SUBS u" using less
	by (cases t rule: tm.exhaust) auto
	next
	{ fix y t u
	have "\<lbrakk>y < n; size t + size u < y; ground t; ground u; \<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e\<rbrakk>
	\<Longrightarrow> {} \<turnstile> t EQ u"
	by (metis Equality_I less.IH add.commute order_refl)
	}
	thus "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<longrightarrow> {} \<turnstile> t IN u" using less.prems
	by (cases u rule: tm.exhaust) (auto simp: Mem_Eats_I1 Mem_Eats_I2 less.IH)
	qed
	qed

	lemma
	assumes "ground t" "ground u"
	shows ground_prove_SUBS: "\<lbrakk>t\<rbrakk>e \<le> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t SUBS u"
	and ground_prove_IN: "\<lbrakk>t\<rbrakk>e \<^bold>\<in> \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t IN u"
	and ground_prove_EQ: "\<lbrakk>t\<rbrakk>e = \<lbrakk>u\<rbrakk>e \<Longrightarrow> {} \<turnstile> t EQ u"
	by (metis Equality_I assms ground_prove [OF lessI] order_refl)+

	lemma ground_subst:
	"ground_aux tm (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_aux (subst i t tm) S"
	by (induct tm rule: tm.induct) (auto simp: ground_aux_def)

	lemma ground_subst_fm:
	"ground_fm_aux A (insert (atom i) S) \<Longrightarrow> ground t \<Longrightarrow> ground_fm_aux (A(i::=t)) S"
	apply (nominal_induct A avoiding: i arbitrary: S rule: fm.strong_induct)
	apply (auto simp: ground_subst Set.insert_commute)
	done

	lemma elts_imp_ground: "u \<in> elts t \<Longrightarrow> ground_aux t S \<Longrightarrow> ground_aux u S"
	by (induct t rule: tm.induct) auto

	lemma ground_se_fm_induction:
	"ground_fm \<alpha> \<Longrightarrow> size \<alpha> < n \<Longrightarrow> se_fm \<alpha> \<Longrightarrow> eval_fm e \<alpha> \<Longrightarrow> {} \<turnstile> \<alpha>"
	proof (induction n arbitrary: \<alpha> rule: less_induct)
	case (less n \<alpha>)
	show ?case using \<open>se_fm \<alpha>\<close>
	proof (cases rule: se_fm.cases)
	case (MemI t u) thus "{} \<turnstile> \<alpha>" using less
	by (auto intro: ground_prove_IN)
	next
	case (DisjI A B) thus "{} \<turnstile> \<alpha>" using less
	by (auto intro: Disj_I1 Disj_I2)
	next
	case (ConjI A B) thus "{} \<turnstile> \<alpha>" using less
	by auto
	next
	case (ExI A i)
	thus "{} \<turnstile> \<alpha>" using less.prems
	apply (auto simp: ex_eval_fm_iff_exists_tm simp del: better_ex_eval_fm)
	apply (auto intro!: Ex_I less.IH subst_fm_in_se_fm ground_subst_fm)
	done
	next
	case (All2I A i t)
	hence t: "ground t" using less.prems
	by (auto simp: ground_aux_def fresh_def)
	hence "(\<forall>u\<in>elts t. eval_fm e (A(i::=u)))"
	by (metis All2I(1) t eval_fm_All2_Iff_elts less(5))
	thus "{} \<turnstile> \<alpha>" using less.prems All2I t
	apply (auto del: Neg_I intro!: prove_elts_imp_prove_All2 less.IH)
	apply (auto intro: subst_fm_in_se_fm ground_subst_fm elts_imp_ground)
	done
	qed
	qed

	lemma ss_imp_se_fm: "ss_fm A \<Longrightarrow> se_fm A"
	by (erule ss_fm.induct) auto

	lemma se_fm_imp_thm: "\<lbrakk>se_fm A; ground_fm A; eval_fm e A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
	by (metis ground_se_fm_induction lessI)

	text\<open>Theorem 2.5\<close>
	theorem Sigma_fm_imp_thm: "\<lbrakk>Sigma_fm A; ground_fm A; eval_fm e0 A\<rbrakk> \<Longrightarrow> {} \<turnstile> A"
	by (metis Iff_MP2_same ss_imp_se_fm empty_iff Sigma_fm_def eval_fm_Iff ground_fm_aux_def
	hfthm_sound se_fm_imp_thm subset_empty)

	end

	diff --git a/thys/Iptables_Semantics/Primitive_Matchers/IpAddresses.thy b/thys/Iptables_Semantics/Primitive_Matchers/IpAddresses.thy
	--- a/thys/Iptables_Semantics/Primitive_Matchers/IpAddresses.thy
	+++ b/thys/Iptables_Semantics/Primitive_Matchers/IpAddresses.thy
	@@ -1,203 +1,203 @@
	theory IpAddresses
	imports IP_Addresses.IP_Address_toString
	IP_Addresses.CIDR_Split
	"../Common/WordInterval_Lists"
	begin




	\<comment> \<open>Misc\<close>
	(we dont't have an empty ip space, but a space which only contains the 0 address. We will use the option type to denote the empty space in some functions.)
	lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 33 = {0}"
	by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_large_pfxlen)


	(helper we use for spoofing protection specification)
	definition all_but_those_ips :: "('i::len word \<times> nat) list \<Rightarrow> ('i word \<times> nat) list" where
	"all_but_those_ips cidrips = cidr_split (wordinterval_invert (l2wi (map ipcidr_to_interval cidrips)))"

	lemma all_but_those_ips:
	"ipcidr_union_set (set (all_but_those_ips cidrips)) =
	UNIV - (\<Union> (ip,n) \<in> set cidrips. ipset_from_cidr ip n)"
	- apply(simp add: )
	+ applysimp
	unfolding ipcidr_union_set_uncurry all_but_those_ips_def
	apply(simp add: cidr_split_prefix)
	apply(simp add: l2wi)
	apply(simp add: ipcidr_to_interval_def)
	using ipset_from_cidr_ipcidr_to_interval by blast


	section\<open>IPv4 Addresses\<close>



	subsection\<open>IPv4 Addresses in IPTables Notation (how we parse it)\<close>
	context
	notes [[typedef_overloaded]]
	begin
	datatype 'i ipt_iprange =
	\<comment> \<open>Singleton IP Address\<close>
	IpAddr "'i::len word"

	\<comment> \<open>CIDR notation: addr/xx\<close>
	\| IpAddrNetmask "'i word" nat

	\<comment> \<open>-m iprange --src-range a.b.c.d-e.f.g.h\<close>
	\| IpAddrRange "'i word" "'i word"
	(the range is inclusive)
	end

	fun ipt_iprange_to_set :: "'i::len ipt_iprange \<Rightarrow> 'i word set" where
	"ipt_iprange_to_set (IpAddrNetmask base m) = ipset_from_cidr base m" \|
	"ipt_iprange_to_set (IpAddr ip) = { ip }" \|
	"ipt_iprange_to_set (IpAddrRange ip1 ip2) = { ip1 .. ip2 }"

	text\<open>@{term ipt_iprange_to_set} can only represent an empty set if it is an empty range.\<close>
	lemma ipt_iprange_to_set_nonempty: "ipt_iprange_to_set ip = {} \<longleftrightarrow>
	(\<exists>ip1 ip2. ip = IpAddrRange ip1 ip2 \<and> ip1 > ip2)"
	apply(cases ip)
	apply(simp; fail)
	apply(simp add: ipset_from_cidr_alt bitmagic_zeroLast_leq_or1Last; fail)
	apply(simp add:linorder_not_le; fail)
	done

	text\<open>maybe this is necessary as code equation?\<close>
	context
	includes bit_operations_syntax
	begin

	lemma element_ipt_iprange_to_set[code_unfold]: "(addr::'i::len word) \<in> ipt_iprange_to_set X = (
	case X of (IpAddrNetmask pre len) \<Rightarrow>
	(pre AND ((mask len) << (len_of (TYPE('i)) - len))) \<le> addr \<and>
	addr \<le> pre OR (mask (len_of (TYPE('i)) - len))
	\| IpAddr ip \<Rightarrow> (addr = ip)
	\| IpAddrRange ip1 ip2 \<Rightarrow> ip1 \<le> addr \<and> ip2 \<ge> addr)"
	apply(cases X)
	apply(simp; fail)
	apply(simp add: ipset_from_cidr_alt; fail)
	apply(simp; fail)
	done

	end

	lemma ipt_iprange_to_set_uncurry_IpAddrNetmask:
	"ipt_iprange_to_set (uncurry IpAddrNetmask a) = uncurry ipset_from_cidr a"
	by(simp split: uncurry_splits)


	text\<open>IP address ranges to \<open>(start, end)\<close> notation\<close>
	fun ipt_iprange_to_interval :: "'i::len ipt_iprange \<Rightarrow> ('i word \<times> 'i word)" where
	"ipt_iprange_to_interval (IpAddr addr) = (addr, addr)" \|
	"ipt_iprange_to_interval (IpAddrNetmask pre len) = ipcidr_to_interval (pre, len)" \|
	"ipt_iprange_to_interval (IpAddrRange ip1 ip2) = (ip1, ip2)"

	lemma ipt_iprange_to_interval: "ipt_iprange_to_interval ip = (s,e) \<Longrightarrow> {s .. e} = ipt_iprange_to_set ip"
	apply(cases ip)
	apply(auto simp add: ipcidr_to_interval)
	done


	text\<open>A list of IP address ranges to a @{typ "'i::len wordinterval"}.
	The nice thing is: the usual set operations are defined on this type.
	We can use the existing function @{const l2wi_intersect} if we want the intersection of the supplied list\<close>
	lemma "wordinterval_to_set (l2wi_intersect (map ipt_iprange_to_interval ips)) =
	(\<Inter> ip \<in> set ips. ipt_iprange_to_set ip)"
	apply(simp add: l2wi_intersect)
	using ipt_iprange_to_interval by blast

	text\<open>We can use @{const l2wi} if we want the union of the supplied list\<close>
	lemma "wordinterval_to_set (l2wi (map ipt_iprange_to_interval ips)) = (\<Union> ip \<in> set ips. ipt_iprange_to_set ip)"
	apply(simp add: l2wi)
	using ipt_iprange_to_interval by blast

	text\<open>A list of (negated) IP address to a @{typ "'i::len wordinterval"}.\<close>
	definition ipt_iprange_negation_type_to_br_intersect ::
	"'i::len ipt_iprange negation_type list \<Rightarrow> 'i wordinterval" where
	"ipt_iprange_negation_type_to_br_intersect l = l2wi_negation_type_intersect (NegPos_map ipt_iprange_to_interval l)"

	lemma ipt_iprange_negation_type_to_br_intersect: "wordinterval_to_set (ipt_iprange_negation_type_to_br_intersect l) =
	(\<Inter> ip \<in> set (getPos l). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg l). ipt_iprange_to_set ip)"
	apply(simp add: ipt_iprange_negation_type_to_br_intersect_def l2wi_negation_type_intersect NegPos_map_simps)
	using ipt_iprange_to_interval by blast

	text\<open>The @{typ "'i::len wordinterval"} can be translated back into a list of IP ranges.
	If a list of intervals is enough, we can use @{const wi2l}.
	If we need it in @{typ "'i::len ipt_iprange"}, we can use this function.\<close>
	definition wi_2_cidr_ipt_iprange_list :: "'i::len wordinterval \<Rightarrow> 'i ipt_iprange list" where
	"wi_2_cidr_ipt_iprange_list r = map (uncurry IpAddrNetmask) (cidr_split r)"

	lemma wi_2_cidr_ipt_iprange_list:
	"(\<Union> ip \<in> set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) = wordinterval_to_set r"
	proof -
	have "(\<Union> ip \<in> set (wi_2_cidr_ipt_iprange_list r). ipt_iprange_to_set ip) =
	(\<Union>x\<in>set (cidr_split r). uncurry ipset_from_cidr x)"
	unfolding wi_2_cidr_ipt_iprange_list_def by force
	thus ?thesis using cidr_split_prefix by metis
	qed

	text\<open>For example, this allows the following transformation\<close>
	definition ipt_iprange_compress :: "'i::len ipt_iprange negation_type list \<Rightarrow> 'i ipt_iprange list" where
	"ipt_iprange_compress = wi_2_cidr_ipt_iprange_list \<circ> ipt_iprange_negation_type_to_br_intersect"

	lemma ipt_iprange_compress: "(\<Union> ip \<in> set (ipt_iprange_compress l). ipt_iprange_to_set ip) =
	(\<Inter> ip \<in> set (getPos l). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg l). ipt_iprange_to_set ip)"
	by (metis wi_2_cidr_ipt_iprange_list comp_apply ipt_iprange_compress_def ipt_iprange_negation_type_to_br_intersect)

	definition normalized_cidr_ip :: "'i::len ipt_iprange \<Rightarrow> bool" where
	"normalized_cidr_ip ip \<equiv> case ip of IpAddrNetmask _ _ \<Rightarrow> True \| _ \<Rightarrow> False"

	lemma wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask:
	"\<forall>a'\<in>set (wi_2_cidr_ipt_iprange_list as). normalized_cidr_ip a'"
	apply(clarify)
	apply(simp add: wi_2_cidr_ipt_iprange_list_def normalized_cidr_ip_def)
	by force

	lemma ipt_iprange_compress_normalized_IpAddrNetmask:
	"\<forall>a'\<in>set (ipt_iprange_compress as). normalized_cidr_ip a'"
	by(simp add: ipt_iprange_compress_def wi_2_cidr_ipt_iprange_list_normalized_IpAddrNetmask)



	definition ipt_iprange_to_cidr :: "'i::len ipt_iprange \<Rightarrow> ('i word \<times> nat) list" where
	"ipt_iprange_to_cidr ips = cidr_split (iprange_interval (ipt_iprange_to_interval ips))"

	lemma ipt_ipvange_to_cidr: "ipcidr_union_set (set (ipt_iprange_to_cidr ips)) = (ipt_iprange_to_set ips)"
	apply(simp add: ipt_iprange_to_cidr_def)
	apply(simp add: ipcidr_union_set_uncurry)
	apply(case_tac "(ipt_iprange_to_interval ips)")
	apply(simp add: ipt_iprange_to_interval cidr_split_prefix_single)
	done




	(* actually, these are toString pretty printing helpers*)
	definition interval_to_wi_to_ipt_iprange :: "'i::len word \<Rightarrow> 'i word \<Rightarrow> 'i ipt_iprange" where
	"interval_to_wi_to_ipt_iprange s e \<equiv>
	if s = e
	then IpAddr s
	else case cidr_split (WordInterval s e) of [(ip,nmask)] \<Rightarrow> IpAddrNetmask ip nmask
	\| _ \<Rightarrow> IpAddrRange s e"

	lemma interval_to_wi_to_ipt_ipv4range: "ipt_iprange_to_set (interval_to_wi_to_ipt_iprange s e) = {s..e}"
	proof -
	from cidr_split_prefix_single[of s e] have
	"cidr_split (WordInterval s e) = [(a, b)] \<Longrightarrow> ipset_from_cidr a b = {s..e}" for a b
	by(simp add: iprange_interval.simps)
	thus ?thesis
	by(simp add: interval_to_wi_to_ipt_iprange_def split: list.split)
	qed

	fun wi_to_ipt_iprange :: "'i::len wordinterval \<Rightarrow> 'i ipt_iprange list" where
	"wi_to_ipt_iprange (WordInterval s e) = (if s > e then [] else
	[interval_to_wi_to_ipt_iprange s e])" \|
	"wi_to_ipt_iprange (RangeUnion a b) = wi_to_ipt_iprange a @ wi_to_ipt_iprange b"

	lemma wi_to_ipt_ipv4range: "\<Union>(set (map ipt_iprange_to_set (wi_to_ipt_iprange wi))) = wordinterval_to_set wi"
	apply(induction wi)
	apply(simp add: interval_to_wi_to_ipt_ipv4range)
	apply(simp)
	done

	end
	diff --git a/thys/Lambert_W/Lambert_W.thy b/thys/Lambert_W/Lambert_W.thy
	--- a/thys/Lambert_W/Lambert_W.thy
	+++ b/thys/Lambert_W/Lambert_W.thy
	@@ -1,1405 +1,1405 @@
	(*
	File: Lambert_W.thy
	Author: Manuel Eberl, TU München

	Definition and basic properties of the two real-valued branches of the Lambert W function,
	*)
	section \<open>The Lambert $W$ Function on the reals\<close>
	theory Lambert_W
	imports
	Complex_Main
	"HOL-Library.FuncSet"
	"HOL-Real_Asymp.Real_Asymp"
	begin

	(<)
	text \<open>Some lemmas about asymptotic equivalence:\<close>

	lemma asymp_equiv_sandwich':
	fixes f :: "'a \<Rightarrow> real"
	assumes "\<And>c'. c' \<in> {l<..<c} \<Longrightarrow> eventually (\<lambda>x. f x \<ge> c' * g x) F"
	assumes "\<And>c'. c' \<in> {c<..<u} \<Longrightarrow> eventually (\<lambda>x. f x \<le> c' * g x) F"
	assumes "l < c" "c < u" and [simp]: "c \<noteq> 0"
	shows "f \<sim>[F] (\<lambda>x. c * g x)"
	proof -
	have "(\<lambda>x. f x - c * g x) \<in> o[F](g)"
	proof (rule landau_o.smallI)
	fix e :: real assume e: "e > 0"
	define C1 where "C1 = min (c + e) ((c + u) / 2)"
	have C1: "C1 \<in> {c<..<u}" "C1 - c \<le> e"
	using e assms by (auto simp: C1_def min_def)
	define C2 where "C2 = max (c - e) ((c + l) / 2)"
	have C2: "C2 \<in> {l<..<c}" "c - C2 \<le> e"
	using e assms by (auto simp: C2_def max_def field_simps)

	show "eventually (\<lambda>x. norm (f x - c * g x) \<le> e * norm (g x)) F"
	using assms(2)[OF C1(1)] assms(1)[OF C2(1)]
	proof eventually_elim
	case (elim x)
	show ?case
	proof (cases "f x \<ge> c * g x")
	case True
	hence "norm (f x - c * g x) = f x - c * g x"
	by simp
	also have "\<dots> \<le> (C1 - c) * g x"
	using elim by (simp add: algebra_simps)
	also have "\<dots> \<le> (C1 - c) * norm (g x)"
	using C1 by (intro mult_left_mono) auto
	also have "\<dots> \<le> e * norm (g x)"
	using C1 elim by (intro mult_right_mono) auto
	finally show ?thesis using elim by simp
	next
	case False
	hence "norm (f x - c * g x) = c * g x - f x"
	by simp
	also have "\<dots> \<le> (c - C2) * g x"
	using elim by (simp add: algebra_simps)
	also have "\<dots> \<le> (c - C2) * norm (g x)"
	using C2 by (intro mult_left_mono) auto
	also have "\<dots> \<le> e * norm (g x)"
	using C2 elim by (intro mult_right_mono) auto
	finally show ?thesis using elim by simp
	qed
	qed
	qed
	also have "g \<in> O[F](\<lambda>x. c * g x)"
	by simp
	finally show ?thesis
	unfolding asymp_equiv_altdef by blast
	qed

	lemma asymp_equiv_sandwich'':
	fixes f :: "'a \<Rightarrow> real"
	assumes "\<And>c'. c' \<in> {l<..<1} \<Longrightarrow> eventually (\<lambda>x. f x \<ge> c' * g x) F"
	assumes "\<And>c'. c' \<in> {1<..<u} \<Longrightarrow> eventually (\<lambda>x. f x \<le> c' * g x) F"
	assumes "l < 1" "1 < u"
	shows "f \<sim>[F] (g)"
	using asymp_equiv_sandwich'[of l 1 g f F u] assms by simp
	(>)

	subsection \<open>Properties of the function $x\mapsto x e^{x}$\<close>

	lemma exp_times_self_gt:
	assumes "x \<noteq> -1"
	shows "x * exp x > -exp (-1::real)"
	proof -
	define f where "f = (\<lambda>x::real. x * exp x)"
	define f' where "f' = (\<lambda>x::real. (x + 1) * exp x)"
	have "(f has_field_derivative f' x) (at x)" for x
	by (auto simp: f_def f'_def intro!: derivative_eq_intros simp: algebra_simps)
	define l r where "l = min x (-1)" and "r = max x (-1)"

	have "\<exists>z. z > l \<and> z < r \<and> f r - f l = (r - l) * f' z"
	unfolding f_def f'_def l_def r_def using assms
	by (intro MVT2) (auto intro!: derivative_eq_intros simp: algebra_simps)
	then obtain z where z: "z \<in> {l<..<r}" "f r - f l = (r - l) * f' z"
	by auto
	from z have "f x = f (-1) + (x + 1) * f' z"
	using assms by (cases "x \<ge> -1") (auto simp: l_def r_def max_def min_def algebra_simps)
	moreover have "sgn ((x + 1) * f' z) = 1"
	using z assms
	by (cases x "(-1) :: real" rule: linorder_cases; cases z "(-1) :: real" rule: linorder_cases)
	(auto simp: f'_def sgn_mult l_def r_def)
	hence "(x + 1) * f' z > 0" using sgn_greater by fastforce
	ultimately show ?thesis by (simp add: f_def)
	qed

	lemma exp_times_self_ge: "x * exp x \<ge> -exp (-1::real)"
	using exp_times_self_gt[of x] by (cases "x = -1") auto

	lemma exp_times_self_strict_mono:
	assumes "x \<ge> -1" "x < (y :: real)"
	shows "x * exp x < y * exp y"
	using assms(2)
	proof (rule DERIV_pos_imp_increasing_open)
	fix t assume t: "x < t" "t < y"
	have "((\<lambda>x. x * exp x) has_real_derivative (t + 1) * exp t) (at t)"
	by (auto intro!: derivative_eq_intros simp: algebra_simps)
	moreover have "(t + 1) * exp t > 0"
	using t assms by (intro mult_pos_pos) auto
	ultimately show "\<exists>y. ((\<lambda>a. a * exp a) has_real_derivative y) (at t) \<and> 0 < y" by blast
	qed (auto intro!: continuous_intros)

	lemma exp_times_self_strict_antimono:
	assumes "y \<le> -1" "x < (y :: real)"
	shows "x * exp x > y * exp y"
	proof -
	have "-x * exp x < -y * exp y"
	using assms(2)
	proof (rule DERIV_pos_imp_increasing_open)
	fix t assume t: "x < t" "t < y"
	have "((\<lambda>x. -x * exp x) has_real_derivative (-(t + 1)) * exp t) (at t)"
	by (auto intro!: derivative_eq_intros simp: algebra_simps)
	moreover have "(-(t + 1)) * exp t > 0"
	using t assms by (intro mult_pos_pos) auto
	ultimately show "\<exists>y. ((\<lambda>a. -a * exp a) has_real_derivative y) (at t) \<and> 0 < y" by blast
	qed (auto intro!: continuous_intros)
	thus ?thesis by simp
	qed

	lemma exp_times_self_mono:
	assumes "x \<ge> -1" "x \<le> (y :: real)"
	shows "x * exp x \<le> y * exp y"
	using exp_times_self_strict_mono[of x y] assms by (cases "x = y") auto

	lemma exp_times_self_antimono:
	assumes "y \<le> -1" "x \<le> (y :: real)"
	shows "x * exp x \<ge> y * exp y"
	using exp_times_self_strict_antimono[of y x] assms by (cases "x = y") auto

	lemma exp_times_self_inj: "inj_on (\<lambda>x::real. x * exp x) {-1..}"
	proof
	fix x y :: real
	assume "x \<in> {-1..}" "y \<in> {-1..}" "x * exp x = y * exp y"
	thus "x = y"
	using exp_times_self_strict_mono[of x y] exp_times_self_strict_mono[of y x]
	by (cases x y rule: linorder_cases) auto
	qed

	lemma exp_times_self_inj': "inj_on (\<lambda>x::real. x * exp x) {..-1}"
	proof
	fix x y :: real
	assume "x \<in> {..-1}" "y \<in> {..-1}" "x * exp x = y * exp y"
	thus "x = y"
	using exp_times_self_strict_antimono[of x y] exp_times_self_strict_antimono[of y x]
	by (cases x y rule: linorder_cases) auto
	qed


	subsection \<open>Definition\<close>

	text \<open>
	The following are the two branches $W_0(x)$ and $W_{-1}(x)$ of the Lambert $W$ function on the
	real numbers. These are the inverse functions of the function $x\mapsto xe^x$, i.\,e.\
	we have $W(x)e^{W(x)} = x$ for both branches wherever they are defined. The two branches
	meet at the point $x = -\frac{1}{e}$.

	$W_0(x)$ is the principal branch, whose domain is $[-\frac{1}{e}; \infty)$ and whose
	range is $[-1; \infty)$.
	$W_{-1}(x)$ has the domain $[-\frac{1}{e}; 0)$ and the range $(-\infty;-1]$.
	Figure~\ref{fig:lambertw} shows plots of these two branches for illustration.
	\<close>

	text \<open>
	\definecolor{myblue}{HTML}{3869b1}
	\definecolor{myred}{HTML}{cc2428}
	\begin{figure}
	\begin{center}
	\begin{tikzpicture}
	\begin{axis}[
	xmin=-0.5, xmax=6.6, ymin=-3.8, ymax=1.5, axis lines=middle, ytick = {-3, -2, -1, 1}, xtick = {1,...,10}, yticklabel pos = right,
	yticklabel style={right,xshift=1mm},
	extra x tick style={tick label style={above,yshift=1mm}},
	extra x ticks={-0.367879441},
	extra x tick labels={$-\frac{1}{e}$},
	width=\textwidth, height=0.8\textwidth,
	xlabel={$x$}, tick style={thin,black}
	]
	\addplot [color=black, line width=0.5pt, densely dashed, mark=none,domain=-5:0,samples=200] ({-exp(-1)}, {x});
	\addplot [color=myblue, line width=1pt, mark=none,domain=-1:1.5,samples=200] ({x*exp(x)}, {x});
	\addplot [color=myred, line width=1pt, mark=none,domain=-5:-1,samples=200] ({x*exp(x)}, {x});
	\end{axis}
	\end{tikzpicture}
	\end{center}
	\caption{The two real branches of the Lambert $W$ function: $W_0$ (blue) and $W_{-1}$ (red).}
	\label{fig:lambertw}
	\end{figure}
	\<close>

	definition Lambert_W :: "real \<Rightarrow> real" where
	"Lambert_W x = (if x < -exp(-1) then -1 else (THE w. w \<ge> -1 \<and> w * exp w = x))"

	definition Lambert_W' :: "real \<Rightarrow> real" where
	"Lambert_W' x = (if x \<in> {-exp(-1)..<0} then (THE w. w \<le> -1 \<and> w * exp w = x) else -1)"

	lemma Lambert_W_ex1:
	assumes "(x::real) \<ge> -exp (-1)"
	shows "\<exists>!w. w \<ge> -1 \<and> w * exp w = x"
	proof (rule ex_ex1I)
	have "filterlim (\<lambda>w::real. w * exp w) at_top at_top"
	by real_asymp
	hence "eventually (\<lambda>w. w * exp w \<ge> x) at_top"
	by (auto simp: filterlim_at_top)
	hence "eventually (\<lambda>w. w \<ge> 0 \<and> w * exp w \<ge> x) at_top"
	by (intro eventually_conj eventually_ge_at_top)
	then obtain w' where w': "w' * exp w' \<ge> x" "w' \<ge> 0"
	by (auto simp: eventually_at_top_linorder)
	from w' assms have "\<exists>w. -1 \<le> w \<and> w \<le> w' \<and> w * exp w = x"
	by (intro IVT' continuous_intros) auto
	thus "\<exists>w. w \<ge> -1 \<and> w * exp w = x" by blast
	next
	fix w w' :: real
	assume ww': "w \<ge> -1 \<and> w * exp w = x" "w' \<ge> -1 \<and> w' * exp w' = x"
	hence "w * exp w = w' * exp w'" by simp
	thus "w = w'"
	using exp_times_self_strict_mono[of w w'] exp_times_self_strict_mono[of w' w] ww'
	by (cases w w' rule: linorder_cases) auto
	qed

	lemma Lambert_W'_ex1:
	assumes "(x::real) \<in> {-exp (-1)..<0}"
	shows "\<exists>!w. w \<le> -1 \<and> w * exp w = x"
	proof (rule ex_ex1I)
	have "eventually (\<lambda>w. x \<le> w * exp w) at_bot"
	using assms by real_asymp
	hence "eventually (\<lambda>w. w \<le> -1 \<and> w * exp w \<ge> x) at_bot"
	by (intro eventually_conj eventually_le_at_bot)
	then obtain w' where w': "w' * exp w' \<ge> x" "w' \<le> -1"
	by (auto simp: eventually_at_bot_linorder)

	from w' assms have "\<exists>w. w' \<le> w \<and> w \<le> -1 \<and> w * exp w = x"
	by (intro IVT2' continuous_intros) auto
	thus "\<exists>w. w \<le> -1 \<and> w * exp w = x" by blast
	next
	fix w w' :: real
	assume ww': "w \<le> -1 \<and> w * exp w = x" "w' \<le> -1 \<and> w' * exp w' = x"
	hence "w * exp w = w' * exp w'" by simp
	thus "w = w'"
	using exp_times_self_strict_antimono[of w w'] exp_times_self_strict_antimono[of w' w] ww'
	by (cases w w' rule: linorder_cases) auto
	qed

	lemma Lambert_W_times_exp_self:
	assumes "x \<ge> -exp (-1)"
	shows "Lambert_W x * exp (Lambert_W x) = x"
	using theI'[OF Lambert_W_ex1[OF assms]] assms by (auto simp: Lambert_W_def)

	lemma Lambert_W_times_exp_self':
	assumes "x \<ge> -exp (-1)"
	shows "exp (Lambert_W x) * Lambert_W x = x"
	using Lambert_W_times_exp_self[of x] assms by (simp add: mult_ac)

	lemma Lambert_W'_times_exp_self:
	assumes "x \<in> {-exp (-1)..<0}"
	shows "Lambert_W' x * exp (Lambert_W' x) = x"
	using theI'[OF Lambert_W'_ex1[OF assms]] assms by (auto simp: Lambert_W'_def)

	lemma Lambert_W'_times_exp_self':
	assumes "x \<in> {-exp (-1)..<0}"
	shows "exp (Lambert_W' x) * Lambert_W' x = x"
	using Lambert_W'_times_exp_self[of x] assms by (simp add: mult_ac)

	lemma Lambert_W_ge: "Lambert_W x \<ge> -1"
	using theI'[OF Lambert_W_ex1[of x]] by (auto simp: Lambert_W_def)

	lemma Lambert_W'_le: "Lambert_W' x \<le> -1"
	using theI'[OF Lambert_W'_ex1[of x]] by (auto simp: Lambert_W'_def)

	lemma Lambert_W_eqI:
	assumes "w \<ge> -1" "w * exp w = x"
	shows "Lambert_W x = w"
	proof -
	from assms exp_times_self_ge[of w] have "x \<ge> -exp (-1)"
	by (cases "x \<ge> -exp (-1)") auto
	from Lambert_W_ex1[OF this] Lambert_W_times_exp_self[OF this] Lambert_W_ge[of x] assms
	show ?thesis by metis
	qed

	lemma Lambert_W'_eqI:
	assumes "w \<le> -1" "w * exp w = x"
	shows "Lambert_W' x = w"
	proof -
	from assms exp_times_self_ge[of w] have "x \<ge> -exp (-1)"
	by (cases "x \<ge> -exp (-1)") auto
	moreover from assms have "w * exp w < 0"
	by (intro mult_neg_pos) auto
	ultimately have "x \<in> {-exp (-1)..<0}"
	using assms by auto

	from Lambert_W'_ex1[OF this(1)] Lambert_W'_times_exp_self[OF this(1)] Lambert_W'_le assms
	show ?thesis by metis
	qed

	text \<open>
	$W_0(x)$ and $W_{-1}(x)$ together fully cover all solutions of $we^w = x$:
	\<close>
	lemma exp_times_self_eqD:
	assumes "w * exp w = x"
	shows "x \<ge> -exp (-1)" and "w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x"
	proof -
	from assms show "x \<ge> -exp (-1)"
	using exp_times_self_ge[of w] by auto
	show "w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x"
	proof (cases "w \<ge> -1")
	case True
	hence "Lambert_W x = w"
	using assms by (intro Lambert_W_eqI) auto
	thus ?thesis by auto
	next
	case False
	from False have "w * exp w < 0"
	by (intro mult_neg_pos) auto
	from False have "Lambert_W' x = w"
	using assms by (intro Lambert_W'_eqI) auto
	thus ?thesis using assms \<open>w * exp w < 0\<close> by auto
	qed
	qed

	theorem exp_times_self_eq_iff:
	"w * exp w = x \<longleftrightarrow> x \<ge> -exp (-1) \<and> (w = Lambert_W x \<or> x < 0 \<and> w = Lambert_W' x)"
	using exp_times_self_eqD[of w x]
	by (auto simp: Lambert_W_times_exp_self Lambert_W'_times_exp_self)

	lemma Lambert_W_exp_times_self [simp]: "x \<ge> -1 \<Longrightarrow> Lambert_W (x * exp x) = x"
	by (rule Lambert_W_eqI) auto

	lemma Lambert_W_exp_times_self' [simp]: "x \<ge> -1 \<Longrightarrow> Lambert_W (exp x * x) = x"
	by (rule Lambert_W_eqI) auto

	lemma Lambert_W'_exp_times_self [simp]: "x \<le> -1 \<Longrightarrow> Lambert_W' (x * exp x) = x"
	by (rule Lambert_W'_eqI) auto

	lemma Lambert_W'_exp_times_self' [simp]: "x \<le> -1 \<Longrightarrow> Lambert_W' (exp x * x) = x"
	by (rule Lambert_W'_eqI) auto

	lemma Lambert_W_times_ln_self:
	assumes "x \<ge> exp (-1)"
	shows "Lambert_W (x * ln x) = ln x"
	proof -
	have "0 < exp (-1 :: real)"
	by simp
	also note \<open>\<dots> \<le> x\<close>
	finally have "x > 0" .
	from assms have "ln (exp (-1)) \<le> ln x"
	using \<open>x > 0\<close> by (subst ln_le_cancel_iff) auto
	hence "Lambert_W (exp (ln x) * ln x) = ln x"
	by (subst Lambert_W_exp_times_self') auto
	thus ?thesis using \<open>x > 0\<close> by simp
	qed

	lemma Lambert_W_times_ln_self':
	assumes "x \<ge> exp (-1)"
	shows "Lambert_W (ln x * x) = ln x"
	using Lambert_W_times_ln_self[OF assms] by (simp add: mult.commute)

	lemma Lambert_W_eq_minus_exp_minus1 [simp]: "Lambert_W (-exp (-1)) = -1"
	by (rule Lambert_W_eqI) auto

	lemma Lambert_W'_eq_minus_exp_minus1 [simp]: "Lambert_W' (-exp (-1)) = -1"
	by (rule Lambert_W'_eqI) auto

	lemma Lambert_W_0 [simp]: "Lambert_W 0 = 0"
	by (rule Lambert_W_eqI) auto


	subsection \<open>Monotonicity properties\<close>

	lemma Lambert_W_strict_mono:
	assumes "x \<ge> -exp(-1)" "x < y"
	shows "Lambert_W x < Lambert_W y"
	proof (rule ccontr)
	assume "\<not>(Lambert_W x < Lambert_W y)"
	hence "Lambert_W x * exp (Lambert_W x) \<ge> Lambert_W y * exp (Lambert_W y)"
	by (intro exp_times_self_mono) (auto simp: Lambert_W_ge)
	hence "x \<ge> y"
	using assms by (simp add: Lambert_W_times_exp_self)
	with assms show False by simp
	qed

	lemma Lambert_W_mono:
	assumes "x \<ge> -exp(-1)" "x \<le> y"
	shows "Lambert_W x \<le> Lambert_W y"
	using Lambert_W_strict_mono[of x y] assms by (cases "x = y") auto

	lemma Lambert_W_eq_iff [simp]:
	"x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x = Lambert_W y \<longleftrightarrow> x = y"
	using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W_le_iff [simp]:
	"x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x \<le> Lambert_W y \<longleftrightarrow> x \<le> y"
	using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W_less_iff [simp]:
	"x \<ge> -exp(-1) \<Longrightarrow> y \<ge> -exp(-1) \<Longrightarrow> Lambert_W x < Lambert_W y \<longleftrightarrow> x < y"
	using Lambert_W_strict_mono[of x y] Lambert_W_strict_mono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W_le_minus_one:
	assumes "x \<le> -exp(-1)"
	shows "Lambert_W x = -1"
	proof (cases "x = -exp(-1)")
	case False
	thus ?thesis using assms
	by (auto simp: Lambert_W_def)
	qed auto

	lemma Lambert_W_pos_iff [simp]: "Lambert_W x > 0 \<longleftrightarrow> x > 0"
	proof (cases "x \<ge> -exp (-1)")
	case True
	thus ?thesis
	using Lambert_W_less_iff[of 0 x] by (simp del: Lambert_W_less_iff)
	next
	case False
	hence "x < - exp(-1)" by auto
	also have "\<dots> \<le> 0" by simp
	finally show ?thesis using False
	by (auto simp: Lambert_W_le_minus_one)
	qed

	lemma Lambert_W_eq_0_iff [simp]: "Lambert_W x = 0 \<longleftrightarrow> x = 0"
	using Lambert_W_eq_iff[of x 0]
	by (cases "x \<ge> -exp (-1)") (auto simp: Lambert_W_le_minus_one simp del: Lambert_W_eq_iff)

	lemma Lambert_W_nonneg_iff [simp]: "Lambert_W x \<ge> 0 \<longleftrightarrow> x \<ge> 0"
	using Lambert_W_pos_iff[of x]
	by (cases "x = 0") (auto simp del: Lambert_W_pos_iff)

	lemma Lambert_W_neg_iff [simp]: "Lambert_W x < 0 \<longleftrightarrow> x < 0"
	using Lambert_W_nonneg_iff[of x] by (auto simp del: Lambert_W_nonneg_iff)

	lemma Lambert_W_nonpos_iff [simp]: "Lambert_W x \<le> 0 \<longleftrightarrow> x \<le> 0"
	using Lambert_W_pos_iff[of x] by (auto simp del: Lambert_W_pos_iff)

	lemma Lambert_W_geI:
	assumes "y * exp y \<le> x"
	shows "Lambert_W x \<ge> y"
	proof (cases "y \<ge> -1")
	case False
	hence "y \<le> -1" by simp
	also have "-1 \<le> Lambert_W x" by (rule Lambert_W_ge)
	finally show ?thesis .
	next
	case True
	have "Lambert_W x \<ge> Lambert_W (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W_mono) auto
	thus ?thesis using assms True by simp
	qed

	lemma Lambert_W_gtI:
	assumes "y * exp y < x"
	shows "Lambert_W x > y"
	proof (cases "y \<ge> -1")
	case False
	hence "y < -1" by simp
	also have "-1 \<le> Lambert_W x" by (rule Lambert_W_ge)
	finally show ?thesis .
	next
	case True
	have "Lambert_W x > Lambert_W (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W_strict_mono) auto
	thus ?thesis using assms True by simp
	qed

	lemma Lambert_W_leI:
	assumes "y * exp y \<ge> x" "y \<ge> -1" "x \<ge> -exp (-1)"
	shows "Lambert_W x \<le> y"
	proof -
	have "Lambert_W x \<le> Lambert_W (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W_mono) auto
	thus ?thesis using assms by simp
	qed

	lemma Lambert_W_lessI:
	assumes "y * exp y > x" "y \<ge> -1" "x \<ge> -exp (-1)"
	shows "Lambert_W x < y"
	proof -
	have "Lambert_W x < Lambert_W (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W_strict_mono) auto
	thus ?thesis using assms by simp
	qed



	lemma Lambert_W'_strict_antimono:
	assumes "-exp (-1) \<le> x" "x < y" "y < 0"
	shows "Lambert_W' x > Lambert_W' y"
	proof (rule ccontr)
	assume "\<not>(Lambert_W' x > Lambert_W' y)"
	hence "Lambert_W' x * exp (Lambert_W' x) \<ge> Lambert_W' y * exp (Lambert_W' y)"
	using assms by (intro exp_times_self_antimono Lambert_W'_le) auto
	hence "x \<ge> y"
	using assms by (simp add: Lambert_W'_times_exp_self)
	with assms show False by simp
	qed

	lemma Lambert_W'_antimono:
	assumes "x \<ge> -exp(-1)" "x \<le> y" "y < 0"
	shows "Lambert_W' x \<ge> Lambert_W' y"
	using Lambert_W'_strict_antimono[of x y] assms by (cases "x = y") auto

	lemma Lambert_W'_eq_iff [simp]:
	"x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x = Lambert_W' y \<longleftrightarrow> x = y"
	using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W'_le_iff [simp]:
	"x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x \<le> Lambert_W' y \<longleftrightarrow> x \<ge> y"
	using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W'_less_iff [simp]:
	"x \<in> {-exp(-1)..<0} \<Longrightarrow> y \<in> {-exp(-1)..<0} \<Longrightarrow> Lambert_W' x < Lambert_W' y \<longleftrightarrow> x > y"
	using Lambert_W'_strict_antimono[of x y] Lambert_W'_strict_antimono[of y x]
	by (cases x y rule: linorder_cases) auto

	lemma Lambert_W'_le_minus_one:
	assumes "x \<le> -exp(-1)"
	shows "Lambert_W' x = -1"
	proof (cases "x = -exp(-1)")
	case False
	thus ?thesis using assms
	by (auto simp: Lambert_W'_def)
	qed auto

	lemma Lambert_W'_ge_zero: "x \<ge> 0 \<Longrightarrow> Lambert_W' x = -1"
	by (simp add: Lambert_W'_def)

	lemma Lambert_W'_neg: "Lambert_W' x < 0"
	by (rule le_less_trans[OF Lambert_W'_le]) auto

	lemma Lambert_W'_nz [simp]: "Lambert_W' x \<noteq> 0"
	using Lambert_W'_neg[of x] by simp

	lemma Lambert_W'_geI:
	assumes "y * exp y \<ge> x" "y \<le> -1" "x \<ge> -exp(-1)"
	shows "Lambert_W' x \<ge> y"
	proof -
	from assms have "y * exp y < 0"
	by (intro mult_neg_pos) auto
	hence "Lambert_W' x \<ge> Lambert_W' (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W'_antimono) auto
	thus ?thesis using assms by simp
	qed

	lemma Lambert_W'_gtI:
	assumes "y * exp y > x" "y \<le> -1" "x \<ge> -exp(-1)"
	shows "Lambert_W' x \<ge> y"
	proof -
	from assms have "y * exp y < 0"
	by (intro mult_neg_pos) auto
	hence "Lambert_W' x > Lambert_W' (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W'_strict_antimono) auto
	thus ?thesis using assms by simp
	qed

	lemma Lambert_W'_leI:
	assumes "y * exp y \<le> x" "x < 0"
	shows "Lambert_W' x \<le> y"
	proof (cases "y \<le> -1")
	case True
	have "Lambert_W' x \<le> Lambert_W' (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W'_antimono) auto
	thus ?thesis using assms True by simp
	next
	case False
	have "Lambert_W' x \<le> -1"
	by (rule Lambert_W'_le)
	also have "\<dots> < y"
	using False by simp
	finally show ?thesis by simp
	qed

	lemma Lambert_W'_lessI:
	assumes "y * exp y < x" "x < 0"
	shows "Lambert_W' x < y"
	proof (cases "y \<le> -1")
	case True
	have "Lambert_W' x < Lambert_W' (y * exp y)"
	using assms exp_times_self_ge[of y] by (intro Lambert_W'_strict_antimono) auto
	thus ?thesis using assms True by simp
	next
	case False
	have "Lambert_W' x \<le> -1"
	by (rule Lambert_W'_le)
	also have "\<dots> < y"
	using False by simp
	finally show ?thesis by simp
	qed


	lemma bij_betw_exp_times_self_atLeastAtMost:
	fixes a b :: real
	assumes "a \<ge> -1" "a \<le> b"
	shows "bij_betw (\<lambda>x. x * exp x) {a..b} {a * exp a..b * exp b}"
	unfolding bij_betw_def
	proof
	show "inj_on (\<lambda>x. x * exp x) {a..b}"
	by (rule inj_on_subset[OF exp_times_self_inj]) (use assms in auto)
	next
	show "(\<lambda>x. x * exp x) ` {a..b} = {a * exp a..b * exp b}"
	proof safe
	fix x assume "x \<in> {a..b}"
	thus "x * exp x \<in> {a * exp a..b * exp b}"
	using assms by (auto intro!: exp_times_self_mono)
	next
	fix x assume x: "x \<in> {a * exp a..b * exp b}"
	have "(-1) * exp (-1) \<le> a * exp a"
	using assms by (intro exp_times_self_mono) auto
	also have "\<dots> \<le> x" using x by simp
	finally have "x \<ge> -exp (-1)" by simp

	have "Lambert_W x \<in> {a..b}"
	using x \<open>x \<ge> -exp (-1)\<close> assms by (auto intro!: Lambert_W_geI Lambert_W_leI)
	moreover have "Lambert_W x * exp (Lambert_W x) = x"
	using \<open>x \<ge> -exp (-1)\<close> by (simp add: Lambert_W_times_exp_self)
	ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..b}"
	unfolding image_iff by metis
	qed
	qed

	lemma bij_betw_exp_times_self_atLeastAtMost':
	fixes a b :: real
	assumes "a \<le> b" "b \<le> -1"
	shows "bij_betw (\<lambda>x. x * exp x) {a..b} {b * exp b..a * exp a}"
	unfolding bij_betw_def
	proof
	show "inj_on (\<lambda>x. x * exp x) {a..b}"
	by (rule inj_on_subset[OF exp_times_self_inj']) (use assms in auto)
	next
	show "(\<lambda>x. x * exp x) ` {a..b} = {b * exp b..a * exp a}"
	proof safe
	fix x assume "x \<in> {a..b}"
	thus "x * exp x \<in> {b * exp b..a * exp a}"
	using assms by (auto intro!: exp_times_self_antimono)
	next
	fix x assume x: "x \<in> {b * exp b..a * exp a}"
	from assms have "a * exp a < 0"
	by (intro mult_neg_pos) auto
	with x have "x < 0" by auto
	have "(-1) * exp (-1) \<le> b * exp b"
	using assms by (intro exp_times_self_antimono) auto
	also have "\<dots> \<le> x" using x by simp
	finally have "x \<ge> -exp (-1)" by simp

	have "Lambert_W' x \<in> {a..b}"
	using x \<open>x \<ge> -exp (-1)\<close> \<open>x < 0\<close> assms
	by (auto intro!: Lambert_W'_geI Lambert_W'_leI)
	moreover have "Lambert_W' x * exp (Lambert_W' x) = x"
	using \<open>x \<ge> -exp (-1)\<close> \<open>x < 0\<close> by (auto simp: Lambert_W'_times_exp_self)
	ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..b}"
	unfolding image_iff by metis
	qed
	qed

	lemma bij_betw_exp_times_self_atLeast:
	fixes a :: real
	assumes "a \<ge> -1"
	shows "bij_betw (\<lambda>x. x * exp x) {a..} {a * exp a..}"
	unfolding bij_betw_def
	proof
	show "inj_on (\<lambda>x. x * exp x) {a..}"
	by (rule inj_on_subset[OF exp_times_self_inj]) (use assms in auto)
	next
	show "(\<lambda>x. x * exp x) ` {a..} = {a * exp a..}"
	proof safe
	fix x assume "x \<ge> a"
	thus "x * exp x \<ge> a * exp a"
	using assms by (auto intro!: exp_times_self_mono)
	next
	fix x assume x: "x \<ge> a * exp a"
	have "(-1) * exp (-1) \<le> a * exp a"
	using assms by (intro exp_times_self_mono) auto
	also have "\<dots> \<le> x" using x by simp
	finally have "x \<ge> -exp (-1)" by simp

	have "Lambert_W x \<in> {a..}"
	using x \<open>x \<ge> -exp (-1)\<close> assms by (auto intro!: Lambert_W_geI Lambert_W_leI)
	moreover have "Lambert_W x * exp (Lambert_W x) = x"
	using \<open>x \<ge> -exp (-1)\<close> by (simp add: Lambert_W_times_exp_self)
	ultimately show "x \<in> (\<lambda>x. x * exp x) ` {a..}"
	unfolding image_iff by metis
	qed
	qed


	subsection \<open>Basic identities and bounds\<close>

	lemma Lambert_W_2_ln_2 [simp]: "Lambert_W (2 * ln 2) = ln 2"
	proof -
	have "-1 \<le> (0 :: real)"
	by simp
	also have "\<dots> \<le> ln 2"
	by simp
	finally have "-1 \<le> (ln 2 :: real)" .
	thus ?thesis
	by (intro Lambert_W_eqI) auto
	qed

	lemma Lambert_W_exp_1 [simp]: "Lambert_W (exp 1) = 1"
	by (rule Lambert_W_eqI) auto

	lemma Lambert_W_neg_ln_over_self:
	assumes "x \<in> {exp (-1)..exp 1}"
	shows "Lambert_W (-ln x / x) = -ln x"
	proof -
	have "0 < (exp (-1) :: real)"
	by simp
	also have "\<dots> \<le> x"
	using assms by simp
	finally have "x > 0" .
	from \<open>x > 0\<close> assms have "ln x \<le> ln (exp 1)"
	by (subst ln_le_cancel_iff) auto
	also have "ln (exp 1) = (1 :: real)"
	by simp
	finally have "ln x \<le> 1" .
	show ?thesis
	using assms \<open>x > 0\<close> \<open>ln x \<le> 1\<close>
	by (intro Lambert_W_eqI) (auto simp: exp_minus field_simps)
	qed

	lemma Lambert_W'_neg_ln_over_self:
	assumes "x \<ge> exp 1"
	shows "Lambert_W' (-ln x / x) = -ln x"
	proof (rule Lambert_W'_eqI)
	have "0 < (exp 1 :: real)"
	by simp
	also have "\<dots> \<le> x"
	by fact
	finally have "x > 0" .
	from assms \<open>x > 0\<close> have "ln x \<ge> ln (exp 1)"
	by (subst ln_le_cancel_iff) auto
	thus "-ln x \<le> -1" by simp
	show "-ln x * exp (-ln x) = -ln x / x"
	using \<open>x > 0\<close> by (simp add: field_simps exp_minus)
	qed

	lemma exp_Lambert_W: "x \<ge> -exp (-1) \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> exp (Lambert_W x) = x / Lambert_W x"
	using Lambert_W_times_exp_self[of x] by (auto simp add: divide_simps mult_ac)

	lemma exp_Lambert_W': "x \<in> {-exp (-1)..<0} \<Longrightarrow> exp (Lambert_W' x) = x / Lambert_W' x"
	using Lambert_W'_times_exp_self[of x] by (auto simp add: divide_simps mult_ac)

	lemma ln_Lambert_W:
	assumes "x > 0"
	shows "ln (Lambert_W x) = ln x - Lambert_W x"
	proof -
	have "-exp (-1) \<le> (0 :: real)"
	by simp
	also have "\<dots> < x" by fact
	finally have x: "x > -exp(-1)" .

	have "exp (ln (Lambert_W x)) = exp (ln x - Lambert_W x)"
	using assms x by (subst exp_diff) (auto simp: exp_Lambert_W)
	thus ?thesis by (subst (asm) exp_inj_iff)
	qed

	lemma ln_minus_Lambert_W':
	assumes "x \<in> {-exp (-1)..<0}"
	shows "ln (-Lambert_W' x) = ln (-x) - Lambert_W' x"
	proof -
	have "exp (ln (-x) - Lambert_W' x) = -Lambert_W' x"
	using assms by (simp add: exp_diff exp_Lambert_W')
	also have "\<dots> = exp (ln (-Lambert_W' x))"
	using Lambert_W'_neg[of x] by simp
	finally show ?thesis by simp
	qed

	lemma Lambert_W_plus_Lambert_W_eq:
	assumes "x > 0" "y > 0"
	shows "Lambert_W x + Lambert_W y = Lambert_W (x * y * (1 / Lambert_W x + 1 / Lambert_W y))"
	proof (rule sym, rule Lambert_W_eqI)
	have "x > -exp(-1)" "y > -exp (-1)"
	by (rule less_trans[OF _ assms(1)] less_trans[OF _ assms(2)], simp)+
	with assms show "(Lambert_W x + Lambert_W y) * exp (Lambert_W x + Lambert_W y) =
	x * y * (1 / Lambert_W x + 1 / Lambert_W y)"
	by (auto simp: field_simps exp_add exp_Lambert_W)
	have "-1 \<le> (0 :: real)"
	by simp
	also from assms have "\<dots> \<le> Lambert_W x + Lambert_W y"
	by (intro add_nonneg_nonneg) auto
	finally show "\<dots> \<ge> -1" .
	qed

	lemma Lambert_W'_plus_Lambert_W'_eq:
	assumes "x \<in> {-exp(-1)..<0}" "y \<in> {-exp(-1)..<0}"
	shows "Lambert_W' x + Lambert_W' y = Lambert_W' (x * y * (1 / Lambert_W' x + 1 / Lambert_W' y))"
	proof (rule sym, rule Lambert_W'_eqI)
	from assms show "(Lambert_W' x + Lambert_W' y) * exp (Lambert_W' x + Lambert_W' y) =
	x * y * (1 / Lambert_W' x + 1 / Lambert_W' y)"
	by (auto simp: field_simps exp_add exp_Lambert_W')
	have "Lambert_W' x + Lambert_W' y \<le> -1 + -1"
	by (intro add_mono Lambert_W'_le)
	also have "\<dots> \<le> -1" by simp
	finally show "Lambert_W' x + Lambert_W' y \<le> -1" .
	qed

	lemma Lambert_W_gt_ln_minus_ln_ln:
	assumes "x > exp 1"
	shows "Lambert_W x > ln x - ln (ln x)"
	proof (rule Lambert_W_gtI)
	have "x > 1"
	by (rule less_trans[OF _ assms]) auto
	have "ln x > ln (exp 1)"
	by (subst ln_less_cancel_iff) (use \<open>x > 1\<close> assms in auto)
	thus "(ln x - ln (ln x)) * exp (ln x - ln (ln x)) < x"
	using assms \<open>x > 1\<close> by (simp add: exp_diff field_simps)
	qed

	lemma Lambert_W_less_ln:
	assumes "x > exp 1"
	shows "Lambert_W x < ln x"
	proof (rule Lambert_W_lessI)
	have "x > 0"
	by (rule less_trans[OF _ assms]) auto
	have "ln x > ln (exp 1)"
	by (subst ln_less_cancel_iff) (use \<open>x > 0\<close> assms in auto)
	thus "x < ln x * exp (ln x)"
	using \<open>x > 0\<close> by simp
	show "ln x \<ge> -1"
	by (rule less_imp_le[OF le_less_trans[OF _ \<open>ln x > _\<close>]]) auto
	show "x \<ge> -exp (-1)"
	by (rule less_imp_le[OF le_less_trans[OF _ \<open>x > 0\<close>]]) auto
	qed


	subsection \<open>Limits, continuity, and differentiability\<close>

	lemma filterlim_Lambert_W_at_top [tendsto_intros]: "filterlim Lambert_W at_top at_top"
	unfolding filterlim_at_top
	proof
	fix C :: real
	have "eventually (\<lambda>x. x \<ge> C * exp C) at_top"
	by (rule eventually_ge_at_top)
	thus "eventually (\<lambda>x. Lambert_W x \<ge> C) at_top"
	proof eventually_elim
	case (elim x)
	thus ?case
	by (intro Lambert_W_geI) auto
	qed
	qed

	lemma filterlim_Lambert_W_at_left_0 [tendsto_intros]:
	"filterlim Lambert_W' at_bot (at_left 0)"
	unfolding filterlim_at_bot
	proof
	fix C :: real
	define C' where "C' = min C (-1)"
	have "C' < 0" "C' \<le> C"
	by (simp_all add: C'_def)
	have "C' * exp C' < 0"
	using \<open>C' < 0\<close> by (intro mult_neg_pos) auto
	hence "eventually (\<lambda>x. x \<ge> C' * exp C') (at_left 0)"
	by real_asymp
	moreover have "eventually (\<lambda>x::real. x < 0) (at_left 0)"
	by real_asymp
	ultimately show "eventually (\<lambda>x. Lambert_W' x \<le> C) (at_left 0)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W' x \<le> C'"
	by (intro Lambert_W'_leI) auto
	also have "\<dots> \<le> C" by fact
	finally show ?case .
	qed
	qed

	lemma continuous_on_Lambert_W [continuous_intros]: "continuous_on {-exp (-1)..} Lambert_W"
	proof -
	have : "continuous_on {-exp (-1)..b exp b} Lambert_W" if "b \<ge> 0" for b
	proof -
	have "continuous_on ((\<lambda>x. x * exp x) ` {-1..b}) Lambert_W"
	by (rule continuous_on_inv) (auto intro!: continuous_intros)
	also have "(\<lambda>x. x * exp x) ` {-1..b} = {-exp (-1)..b * exp b}"
	using bij_betw_exp_times_self_atLeastAtMost[of "-1" b] \<open>b \<ge> 0\<close>
	by (simp add: bij_betw_def)
	finally show ?thesis .
	qed

	have "continuous (at x) Lambert_W" if "x \<ge> 0" for x
	proof -
	have x: "-exp (-1) < x"
	by (rule less_le_trans[OF _ that]) auto

	define b where "b = Lambert_W x + 1"
	have "b \<ge> 0"
	using Lambert_W_ge[of x] by (simp add: b_def)
	have "x = Lambert_W x * exp (Lambert_W x)"
	using that x by (subst Lambert_W_times_exp_self) auto
	also have "\<dots> < b * exp b"
	by (intro exp_times_self_strict_mono) (auto simp: b_def Lambert_W_ge)
	finally have "b * exp b > x" .
	have "continuous_on {-exp(-1)<..<b * exp b} Lambert_W"
	by (rule continuous_on_subset[OF *[of b]]) (use \<open>b \<ge> 0\<close> in auto)
	moreover have "x \<in> {-exp(-1)<..<b * exp b}"
	- using \<open>b * exp b > x\<close> x by (auto simp: )
	+ using \<open>b * exp b > x\<close> x by auto
	ultimately show "continuous (at x) Lambert_W"
	by (subst (asm) continuous_on_eq_continuous_at) auto
	qed
	hence "continuous_on {0..} Lambert_W"
	by (intro continuous_at_imp_continuous_on) auto
	moreover have "continuous_on {-exp (-1)..0} Lambert_W"
	using *[of 0] by simp
	ultimately have "continuous_on ({-exp (-1)..0} \<union> {0..}) Lambert_W"
	by (intro continuous_on_closed_Un) auto
	also have "{-exp (-1)..0} \<union> {0..} = {-exp (-1::real)..}"
	using order.trans[of "-exp (-1)::real" 0] by auto
	finally show ?thesis .
	qed

	lemma continuous_on_Lambert_W_alt [continuous_intros]:
	assumes "continuous_on A f" "\<And>x. x \<in> A \<Longrightarrow> f x \<ge> -exp (-1)"
	shows "continuous_on A (\<lambda>x. Lambert_W (f x))"
	using continuous_on_compose2[OF continuous_on_Lambert_W assms(1)] assms by auto

	lemma continuous_on_Lambert_W' [continuous_intros]: "continuous_on {-exp (-1)..<0} Lambert_W'"
	proof -
	have : "continuous_on {-exp (-1)..-b exp (-b)} Lambert_W'" if "b \<ge> 1" for b
	proof -
	have "continuous_on ((\<lambda>x. x * exp x) ` {-b..-1}) Lambert_W'"
	by (intro continuous_on_inv ballI) (auto intro!: continuous_intros)
	also have "(\<lambda>x. x * exp x) ` {-b..-1} = {-exp (-1)..-b * exp (-b)}"
	using bij_betw_exp_times_self_atLeastAtMost'[of "-b" "-1"] that
	by (simp add: bij_betw_def)
	finally show ?thesis .
	qed

	have "continuous (at x) Lambert_W'" if "x > -exp (-1)" "x < 0" for x
	proof -
	define b where "b = Lambert_W x + 1"
	have "eventually (\<lambda>b. -b * exp (-b) > x) at_top"
	using that by real_asymp
	hence "eventually (\<lambda>b. b \<ge> 1 \<and> -b * exp (-b) > x) at_top"
	by (intro eventually_conj eventually_ge_at_top)
	then obtain b where b: "b \<ge> 1" "-b * exp (-b) > x"
	by (auto simp: eventually_at_top_linorder)

	have "continuous_on {-exp(-1)<..<-b * exp (-b)} Lambert_W'"
	by (rule continuous_on_subset[OF *[of b]]) (use \<open>b \<ge> 1\<close> in auto)
	moreover have "x \<in> {-exp(-1)<..<-b * exp (-b)}"
	using b that by auto
	ultimately show "continuous (at x) Lambert_W'"
	by (subst (asm) continuous_on_eq_continuous_at) auto
	qed
	hence **: "continuous_on {-exp (-1)<..<0} Lambert_W'"
	by (intro continuous_at_imp_continuous_on) auto

	show ?thesis
	unfolding continuous_on_def
	proof
	fix x :: real assume x: "x \<in> {-exp(-1)..<0}"
	show "(Lambert_W' \<longlongrightarrow> Lambert_W' x) (at x within {-exp(-1)..<0})"
	proof (cases "x = -exp(-1)")
	case False
	hence "isCont Lambert_W' x"
	using x ** by (auto simp: continuous_on_eq_continuous_at)
	thus ?thesis
	using continuous_at filterlim_within_subset by blast
	next
	case True
	define a :: real where "a = -2 * exp (-2)"
	have a: "a > -exp (-1)"
	using exp_times_self_strict_antimono[of "-1" "-2"] by (auto simp: a_def)
	from True have "x \<in> {-exp (-1)..<a}"
	using a by (auto simp: a_def)
	have "continuous_on {-exp (-1)..<a} Lambert_W'"
	unfolding a_def by (rule continuous_on_subset[OF *[of 2]]) auto
	hence "(Lambert_W' \<longlongrightarrow> Lambert_W' x) (at x within {-exp (-1)..<a})"
	using \<open>x \<in> {-exp (-1)..<a}\<close> by (auto simp: continuous_on_def)
	also have "at x within {-exp (-1)..<a} = at_right x"
	using a by (intro at_within_nhd[of _ "{..<a}"]) (auto simp: True)
	also have "\<dots> = at x within {-exp (-1)..<0}"
	using a by (intro at_within_nhd[of _ "{..<0}"]) (auto simp: True)
	finally show ?thesis .
	qed
	qed
	qed

	lemma continuous_on_Lambert_W'_alt [continuous_intros]:
	assumes "continuous_on A f" "\<And>x. x \<in> A \<Longrightarrow> f x \<in> {-exp (-1)..<0}"
	shows "continuous_on A (\<lambda>x. Lambert_W' (f x))"
	using continuous_on_compose2[OF continuous_on_Lambert_W' assms(1)] assms
	by (auto simp: subset_iff)


	lemma tendsto_Lambert_W_1:
	assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
	shows "((\<lambda>x. Lambert_W (f x)) \<longlongrightarrow> Lambert_W L) F"
	proof (cases "F = bot")
	case [simp]: False
	from tendsto_lowerbound[OF assms] have "L \<ge> -exp (-1)" by simp
	thus ?thesis
	using continuous_on_tendsto_compose[OF continuous_on_Lambert_W assms(1)] assms(2) by simp
	qed auto

	lemma tendsto_Lambert_W_2:
	assumes "(f \<longlongrightarrow> L) F" "L > -exp (-1)"
	shows "((\<lambda>x. Lambert_W (f x)) \<longlongrightarrow> Lambert_W L) F"
	using order_tendstoD(1)[OF assms] assms
	by (intro tendsto_Lambert_W_1) (auto elim: eventually_mono)

	lemma tendsto_Lambert_W [tendsto_intros]:
	assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F \<or> L > -exp (-1)"
	shows "((\<lambda>x. Lambert_W (f x)) \<longlongrightarrow> Lambert_W L) F"
	using assms(2)
	proof
	assume "L > -exp (-1)"
	from order_tendstoD(1)[OF assms(1) this] assms(1) show ?thesis
	by (intro tendsto_Lambert_W_1) (auto elim: eventually_mono)
	qed (use tendsto_Lambert_W_1[OF assms(1)] in auto)

	lemma tendsto_Lambert_W'_1:
	assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F" "L < 0"
	shows "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
	proof (cases "F = bot")
	case [simp]: False
	from tendsto_lowerbound[OF assms(1,2)] have L_ge: "L \<ge> -exp (-1)" by simp
	from order_tendstoD(2)[OF assms(1,3)] have ev: "eventually (\<lambda>x. f x < 0) F"
	by auto
	with assms(2) have "eventually (\<lambda>x. f x \<in> {-exp (-1)..<0}) F"
	by eventually_elim auto
	thus ?thesis using L_ge assms(3)
	by (intro continuous_on_tendsto_compose[OF continuous_on_Lambert_W' assms(1)]) auto
	qed auto

	lemma tendsto_Lambert_W'_2:
	assumes "(f \<longlongrightarrow> L) F" "L > -exp (-1)" "L < 0"
	shows "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
	using order_tendstoD(1)[OF assms(1,2)] assms
	by (intro tendsto_Lambert_W'_1) (auto elim: eventually_mono)

	lemma tendsto_Lambert_W' [tendsto_intros]:
	assumes "(f \<longlongrightarrow> L) F" "eventually (\<lambda>x. f x \<ge> -exp (-1)) F \<or> L > -exp (-1)" "L < 0"
	shows "((\<lambda>x. Lambert_W' (f x)) \<longlongrightarrow> Lambert_W' L) F"
	using assms(2)
	proof
	assume "L > -exp (-1)"
	from order_tendstoD(1)[OF assms(1) this] assms(1,3) show ?thesis
	by (intro tendsto_Lambert_W'_1) (auto elim: eventually_mono)
	qed (use tendsto_Lambert_W'_1[OF assms(1) _ assms(3)] in auto)


	lemma continuous_Lambert_W [continuous_intros]:
	assumes "continuous F f" "f (Lim F (\<lambda>x. x)) > -exp (-1) \<or> eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
	shows "continuous F (\<lambda>x. Lambert_W (f x))"
	using assms unfolding continuous_def by (intro tendsto_Lambert_W) auto

	lemma continuous_Lambert_W' [continuous_intros]:
	assumes "continuous F f" "f (Lim F (\<lambda>x. x)) > -exp (-1) \<or> eventually (\<lambda>x. f x \<ge> -exp (-1)) F"
	"f (Lim F (\<lambda>x. x)) < 0"
	shows "continuous F (\<lambda>x. Lambert_W' (f x))"
	using assms unfolding continuous_def by (intro tendsto_Lambert_W') auto


	lemma has_field_derivative_Lambert_W [derivative_intros]:
	assumes x: "x > -exp (-1)"
	shows "(Lambert_W has_real_derivative inverse (x + exp (Lambert_W x))) (at x within A)"
	proof -
	write Lambert_W ("W")
	from x have "W x > W (-exp (-1))"
	by (subst Lambert_W_less_iff) auto
	hence "W x > -1" by simp

	note [derivative_intros] = DERIV_inverse_function[where g = Lambert_W]
	have "((\<lambda>x. x * exp x) has_real_derivative (1 + W x) * exp (W x)) (at (W x))"
	by (auto intro!: derivative_eq_intros simp: algebra_simps)
	hence "(W has_real_derivative inverse ((1 + W x) * exp (W x))) (at x)"
	by (rule DERIV_inverse_function[where a = "-exp (-1)" and b = "x + 1"])
	(use x \<open>W x > -1\<close> in \<open>auto simp: Lambert_W_times_exp_self Lim_ident_at
	intro!: continuous_intros\<close>)
	also have "(1 + W x) * exp (W x) = x + exp (W x)"
	using x by (simp add: algebra_simps Lambert_W_times_exp_self)
	finally show ?thesis by (rule has_field_derivative_at_within)
	qed

	lemma has_field_derivative_Lambert_W_gen [derivative_intros]:
	assumes "(f has_real_derivative f') (at x within A)" "f x > -exp (-1)"
	shows "((\<lambda>x. Lambert_W (f x)) has_real_derivative
	(f' / (f x + exp (Lambert_W (f x))))) (at x within A)"
	using DERIV_chain2[OF has_field_derivative_Lambert_W[OF assms(2)] assms(1)]
	by (simp add: field_simps)

	lemma has_field_derivative_Lambert_W' [derivative_intros]:
	assumes x: "x \<in> {-exp (-1)<..<0}"
	shows "(Lambert_W' has_real_derivative inverse (x + exp (Lambert_W' x))) (at x within A)"
	proof -
	write Lambert_W' ("W")
	from x have "W x < W (-exp (-1))"
	by (subst Lambert_W'_less_iff) auto
	hence "W x < -1" by simp

	note [derivative_intros] = DERIV_inverse_function[where g = Lambert_W]
	have "((\<lambda>x. x * exp x) has_real_derivative (1 + W x) * exp (W x)) (at (W x))"
	by (auto intro!: derivative_eq_intros simp: algebra_simps)
	hence "(W has_real_derivative inverse ((1 + W x) * exp (W x))) (at x)"
	by (rule DERIV_inverse_function[where a = "-exp (-1)" and b = "0"])
	(use x \<open>W x < -1\<close> in \<open>auto simp: Lambert_W'_times_exp_self Lim_ident_at
	intro!: continuous_intros\<close>)
	also have "(1 + W x) * exp (W x) = x + exp (W x)"
	using x by (simp add: algebra_simps Lambert_W'_times_exp_self)
	finally show ?thesis by (rule has_field_derivative_at_within)
	qed

	lemma has_field_derivative_Lambert_W'_gen [derivative_intros]:
	assumes "(f has_real_derivative f') (at x within A)" "f x \<in> {-exp (-1)<..<0}"
	shows "((\<lambda>x. Lambert_W' (f x)) has_real_derivative
	(f' / (f x + exp (Lambert_W' (f x))))) (at x within A)"
	using DERIV_chain2[OF has_field_derivative_Lambert_W'[OF assms(2)] assms(1)]
	by (simp add: field_simps)


	subsection \<open>Asymptotic expansion\<close>

	text \<open>
	Lastly, we prove some more detailed asymptotic expansions of $W$ and $W'$ at their
	singularities. First, we show that:
	\begin{align*}
	W(x) &= \log x - \log\log x + o(\log\log x) &&\text{for}\ x\to\infty\\
	W'(x) &= \log (-x) - \log (-\log (-x)) + o(\log (-\log (-x))) &&\text{for}\ x\to 0^{-}
	\end{align*}
	\<close>
	theorem Lambert_W_asymp_equiv_at_top:
	"(\<lambda>x. Lambert_W x - ln x) \<sim>[at_top] (\<lambda>x. -ln (ln x))"
	proof -
	have "(\<lambda>x. Lambert_W x - ln x) \<sim>[at_top] (\<lambda>x. (-1) * ln (ln x))"
	proof (rule asymp_equiv_sandwich')
	fix c' :: real assume c': "c' \<in> {-2<..<-1}"
	have "eventually (\<lambda>x. (ln x + c' * ln (ln x)) * exp (ln x + c' * ln (ln x)) \<le> x) at_top"
	"eventually (\<lambda>x. ln x + c' * ln (ln x) \<ge> -1) at_top"
	using c' by real_asymp+
	thus "eventually (\<lambda>x. Lambert_W x - ln x \<ge> c' * ln (ln x)) at_top"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<ge> ln x + c' * ln (ln x)"
	by (intro Lambert_W_geI)
	thus ?case by simp
	qed
	next
	fix c' :: real assume c': "c' \<in> {-1<..<0}"
	have "eventually (\<lambda>x. (ln x + c' * ln (ln x)) * exp (ln x + c' * ln (ln x)) \<ge> x) at_top"
	"eventually (\<lambda>x. ln x + c' * ln (ln x) \<ge> -1) at_top"
	using c' by real_asymp+
	thus "eventually (\<lambda>x. Lambert_W x - ln x \<le> c' * ln (ln x)) at_top"
	using eventually_ge_at_top[of "-exp (-1)"]
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<le> ln x + c' * ln (ln x)"
	by (intro Lambert_W_leI)
	thus ?case by simp
	qed
	qed auto
	thus ?thesis by simp
	qed

	lemma Lambert_W_asymp_equiv_at_top' [asymp_equiv_intros]:
	"Lambert_W \<sim>[at_top] ln"
	proof -
	have "(\<lambda>x. Lambert_W x - ln x) \<in> \<Theta>(\<lambda>x. -ln (ln x))"
	by (intro asymp_equiv_imp_bigtheta Lambert_W_asymp_equiv_at_top)
	also have "(\<lambda>x::real. -ln (ln x)) \<in> o(ln)"
	by real_asymp
	finally show ?thesis by (simp add: asymp_equiv_altdef)
	qed

	theorem Lambert_W'_asymp_equiv_at_left_0:
	"(\<lambda>x. Lambert_W' x - ln (-x)) \<sim>[at_left 0] (\<lambda>x. -ln (-ln (-x)))"
	proof -
	have "(\<lambda>x. Lambert_W' x - ln (-x)) \<sim>[at_left 0] (\<lambda>x. (-1) * ln (-ln (-x)))"
	proof (rule asymp_equiv_sandwich')
	fix c' :: real assume c': "c' \<in> {-2<..<-1}"
	have "eventually (\<lambda>x. x \<le> (ln (-x) + c' * ln (-ln (-x))) * exp (ln (-x) + c' * ln (-ln (-x)))) (at_left 0)"
	"eventually (\<lambda>x::real. ln (-x) + c' * ln (-ln (-x)) \<le> -1) (at_left 0)"
	"eventually (\<lambda>x::real. -exp (-1) \<le> x) (at_left 0)"
	using c' by real_asymp+
	thus "eventually (\<lambda>x. Lambert_W' x - ln (-x) \<ge> c' * ln (-ln (-x))) (at_left 0)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W' x \<ge> ln (-x) + c' * ln (-ln (-x))"
	by (intro Lambert_W'_geI)
	thus ?case by simp
	qed
	next
	fix c' :: real assume c': "c' \<in> {-1<..<0}"
	have "eventually (\<lambda>x. x \<ge> (ln (-x) + c' * ln (-ln (-x))) * exp (ln (-x) + c' * ln (-ln (-x)))) (at_left 0)"
	using c' by real_asymp
	moreover have "eventually (\<lambda>x::real. x < 0) (at_left 0)"
	by (auto simp: eventually_at intro: exI[of _ 1])
	ultimately show "eventually (\<lambda>x. Lambert_W' x - ln (-x) \<le> c' * ln (-ln (-x))) (at_left 0)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W' x \<le> ln (-x) + c' * ln (-ln (-x))"
	by (intro Lambert_W'_leI)
	thus ?case by simp
	qed
	qed auto
	thus ?thesis by simp
	qed

	lemma Lambert_W'_asymp_equiv'_at_left_0 [asymp_equiv_intros]:
	"Lambert_W' \<sim>[at_left 0] (\<lambda>x. ln (-x))"
	proof -
	have "(\<lambda>x. Lambert_W' x - ln (-x)) \<in> \<Theta>[at_left 0](\<lambda>x. -ln (-ln (-x)))"
	by (intro asymp_equiv_imp_bigtheta Lambert_W'_asymp_equiv_at_left_0)
	also have "(\<lambda>x::real. -ln (-ln (-x))) \<in> o[at_left 0](\<lambda>x. ln (-x))"
	by real_asymp
	finally show ?thesis by (simp add: asymp_equiv_altdef)
	qed


	text \<open>
	Next, we look at the branching point $a := \tfrac{1}{e}$. Here, the asymptotic behaviour
	is as follows:
	\begin{align*}
	W(x) &= -1 + \sqrt{2e}(x - a)^{\frac{1}{2}} - \tfrac{2}{3}e(x-a) + o(x-a) &&\text{for} x\to a^+\\
	W'(x) &= -1 - \sqrt{2e}(x - a)^{\frac{1}{2}} - \tfrac{2}{3}e(x-a) + o(x-a) &&\text{for} x\to a^+
	\end{align*}
	\<close>
	lemma sqrt_sqrt_mult:
	assumes "x \<ge> (0 :: real)"
	shows "sqrt x * (sqrt x * y) = x * y"
	using assms by (subst mult.assoc [symmetric]) auto

	theorem Lambert_W_asymp_equiv_at_right_minus_exp_minus1:
	defines "e \<equiv> exp 1"
	defines "a \<equiv> -exp (-1)"
	defines "C1 \<equiv> sqrt (2 * exp 1)"
	defines "f \<equiv> (\<lambda>x. -1 + C1 * sqrt (x - a))"
	shows "(\<lambda>x. Lambert_W x - f x) \<sim>[at_right a] (\<lambda>x. -2/3 * e * (x - a))"
	proof -
	define C :: "real \<Rightarrow> real" where "C = (\<lambda>c. sqrt (2/e)/3 * (2e+3c))"
	have asymp_equiv: "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x)
	\<sim>[at_right a] (\<lambda>x. C c * (x - a) powr (3/2))" if "c \<noteq> -2/3 * e" for c
	proof -
	from that have "C c \<noteq> 0"
	by (auto simp: C_def e_def)
	have "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x - C c * (x - a) powr (3/2))
	\<in> o[at_right a](\<lambda>x. (x - a) powr (3/2))"
	unfolding f_def a_def C_def C1_def e_def
	by (real_asymp simp: field_simps real_sqrt_mult real_sqrt_divide sqrt_sqrt_mult
	exp_minus simp flip: sqrt_def)
	thus ?thesis
	using \<open>C c \<noteq> 0\<close> by (intro smallo_imp_asymp_equiv) auto
	qed

	show ?thesis
	proof (rule asymp_equiv_sandwich')
	fix c' :: real assume c': "c' \<in> {-e<..<-2/3*e}"
	hence neq: "c' \<noteq> -2/3 * e" by auto
	from c' have neg: "C c' < 0" unfolding C_def by (auto intro!: mult_pos_neg)
	hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) < 0) (at_right a)"
	by real_asymp
	hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x < 0) (at_right a)"
	using asymp_equiv_eventually_neg_iff[OF asymp_equiv[OF neq]]
	by eventually_elim (use neg in auto)
	thus "eventually (\<lambda>x. Lambert_W x - f x \<ge> c' * (x - a)) (at_right a)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<ge> f x + c' * (x - a)"
	by (intro Lambert_W_geI) auto
	thus ?case by simp
	qed
	next
	fix c' :: real assume c': "c' \<in> {-2/3*e<..<0}"
	hence neq: "c' \<noteq> -2/3 * e" by auto
	from c' have pos: "C c' > 0" unfolding C_def by auto
	hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) > 0) (at_right a)"
	by real_asymp
	hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x > 0) (at_right a)"
	using asymp_equiv_eventually_pos_iff[OF asymp_equiv[OF neq]]
	by eventually_elim (use pos in auto)
	moreover have "eventually (\<lambda>x. - 1 \<le> f x + c' * (x - a)) (at_right a)"
	"eventually (\<lambda>x. x > a) (at_right a)"
	unfolding a_def f_def C1_def c' by real_asymp+
	ultimately show "eventually (\<lambda>x. Lambert_W x - f x \<le> c' * (x - a)) (at_right a)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<le> f x + c' * (x - a)"
	by (intro Lambert_W_leI) (auto simp: a_def)
	thus ?case by simp
	qed
	qed (auto simp: e_def)
	qed

	theorem Lambert_W'_asymp_equiv_at_right_minus_exp_minus1:
	defines "e \<equiv> exp 1"
	defines "a \<equiv> -exp (-1)"
	defines "C1 \<equiv> sqrt (2 * exp 1)"
	defines "f \<equiv> (\<lambda>x. -1 - C1 * sqrt (x - a))"
	shows "(\<lambda>x. Lambert_W' x - f x) \<sim>[at_right a] (\<lambda>x. -2/3 * e * (x - a))"
	proof -
	define C :: "real \<Rightarrow> real" where "C = (\<lambda>c. -sqrt (2/e)/3 * (2e+3c))"

	have asymp_equiv: "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x)
	\<sim>[at_right a] (\<lambda>x. C c * (x - a) powr (3/2))" if "c \<noteq> -2/3 * e" for c
	proof -
	from that have "C c \<noteq> 0"
	by (auto simp: C_def e_def)
	have "(\<lambda>x. (f x + c * (x - a)) * exp (f x + c * (x - a)) - x - C c * (x - a) powr (3/2))
	\<in> o[at_right a](\<lambda>x. (x - a) powr (3/2))"
	unfolding f_def a_def C_def C1_def e_def
	by (real_asymp simp: field_simps real_sqrt_mult real_sqrt_divide sqrt_sqrt_mult
	exp_minus simp flip: sqrt_def)
	thus ?thesis
	using \<open>C c \<noteq> 0\<close> by (intro smallo_imp_asymp_equiv) auto
	qed

	show ?thesis
	proof (rule asymp_equiv_sandwich')
	fix c' :: real assume c': "c' \<in> {-e<..<-2/3*e}"
	hence neq: "c' \<noteq> -2/3 * e" by auto
	from c' have pos: "C c' > 0" unfolding C_def by (auto intro!: mult_pos_neg)
	hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) > 0) (at_right a)"
	by real_asymp
	hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x > 0) (at_right a)"
	using asymp_equiv_eventually_pos_iff[OF asymp_equiv[OF neq]]
	by eventually_elim (use pos in auto)
	moreover have "eventually (\<lambda>x. x > a) (at_right a)"
	"eventually (\<lambda>x. f x + c' * (x - a) \<le> -1) (at_right a)"
	unfolding a_def f_def C1_def c' by real_asymp+
	ultimately show "eventually (\<lambda>x. Lambert_W' x - f x \<ge> c' * (x - a)) (at_right a)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W' x \<ge> f x + c' * (x - a)"
	by (intro Lambert_W'_geI) (auto simp: a_def)
	thus ?case by simp
	qed
	next
	fix c' :: real assume c': "c' \<in> {-2/3*e<..<0}"
	hence neq: "c' \<noteq> -2/3 * e" by auto
	from c' have neg: "C c' < 0" unfolding C_def by auto
	hence "eventually (\<lambda>x. C c' * (x - a) powr (3 / 2) < 0) (at_right a)"
	by real_asymp
	hence "eventually (\<lambda>x. (f x + c' * (x - a)) * exp (f x + c' * (x - a)) - x < 0) (at_right a)"
	using asymp_equiv_eventually_neg_iff[OF asymp_equiv[OF neq]]
	by eventually_elim (use neg in auto)
	moreover have "eventually (\<lambda>x. x < 0) (at_right a)"
	unfolding a_def by real_asymp
	ultimately show "eventually (\<lambda>x. Lambert_W' x - f x \<le> c' * (x - a)) (at_right a)"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W' x \<le> f x + c' * (x - a)"
	by (intro Lambert_W'_leI) auto
	thus ?case by simp
	qed
	qed (auto simp: e_def)
	qed


	text \<open>
	Lastly, just for fun, we derive a slightly more accurate expansion of $W_0(x)$ for $x\to\infty$:
	\<close>
	theorem Lambert_W_asymp_equiv_at_top'':
	"(\<lambda>x. Lambert_W x - ln x + ln (ln x)) \<sim>[at_top] (\<lambda>x. ln (ln x) / ln x)"
	proof -
	have "(\<lambda>x. Lambert_W x - ln x + ln (ln x)) \<sim>[at_top] (\<lambda>x. 1 * (ln (ln x) / ln x))"
	proof (rule asymp_equiv_sandwich')
	fix c' :: real assume c': "c' \<in> {0<..<1}"
	define a where "a = (\<lambda>x::real. ln x - ln (ln x) + c' * (ln (ln x) / ln x))"
	have "eventually (\<lambda>x. a x * exp (a x) \<le> x) at_top"
	using c' unfolding a_def by real_asymp+
	thus "eventually (\<lambda>x. Lambert_W x - ln x + ln (ln x) \<ge> c' * (ln (ln x) / ln x)) at_top"
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<ge> a x"
	by (intro Lambert_W_geI)
	thus ?case by (simp add: a_def)
	qed
	next
	fix c' :: real assume c': "c' \<in> {1<..<2}"
	define a where "a = (\<lambda>x::real. ln x - ln (ln x) + c' * (ln (ln x) / ln x))"
	have "eventually (\<lambda>x. a x * exp (a x) \<ge> x) at_top"
	"eventually (\<lambda>x. a x \<ge> -1) at_top"
	using c' unfolding a_def by real_asymp+
	thus "eventually (\<lambda>x. Lambert_W x - ln x + ln (ln x) \<le> c' * (ln (ln x) / ln x)) at_top"
	using eventually_ge_at_top[of "-exp (-1)"]
	proof eventually_elim
	case (elim x)
	hence "Lambert_W x \<le> a x"
	by (intro Lambert_W_leI)
	thus ?case by (simp add: a_def)
	qed
	qed auto
	thus ?thesis by simp
	qed

	end
	\ No newline at end of file
	diff --git a/thys/Laplace_Transform/Existence.thy b/thys/Laplace_Transform/Existence.thy
	--- a/thys/Laplace_Transform/Existence.thy
	+++ b/thys/Laplace_Transform/Existence.thy
	@@ -1,1099 +1,1099 @@
	section \<open>Existence\<close>
	theory Existence imports
	Piecewise_Continuous
	begin

	subsection \<open>Definition\<close>

	definition has_laplace :: "(real \<Rightarrow> complex) \<Rightarrow> complex \<Rightarrow> complex \<Rightarrow> bool"
	(infixr "has'_laplace" 46)
	where "(f has_laplace L) s \<longleftrightarrow> ((\<lambda>t. exp (t \<^sub>R - s) f t) has_integral L) {0..}"

	lemma has_laplaceI:
	assumes "((\<lambda>t. exp (t \<^sub>R - s) f t) has_integral L) {0..}"
	shows "(f has_laplace L) s"
	using assms
	by (auto simp: has_laplace_def)

	lemma has_laplaceD:
	assumes "(f has_laplace L) s"
	shows "((\<lambda>t. exp (t \<^sub>R - s) f t) has_integral L) {0..}"
	using assms
	by (auto simp: has_laplace_def)

	lemma has_laplace_unique:
	"L = M" if
	"(f has_laplace L) s"
	"(f has_laplace M) s"
	using that
	by (auto simp: has_laplace_def has_integral_unique)


	subsection \<open>Condition for Existence: Exponential Order\<close>

	definition "exponential_order M c f \<longleftrightarrow> 0 < M \<and> (\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t))"

	lemma exponential_orderI:
	assumes "0 < M" and eo: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
	shows "exponential_order M c f"
	by (auto intro!: assms simp: exponential_order_def)

	lemma exponential_orderD:
	assumes "exponential_order M c f"
	shows "0 < M" "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
	using assms by (auto simp: exponential_order_def)

	context
	fixes f::"real \<Rightarrow> complex"
	begin

	definition laplace_integrand::"complex \<Rightarrow> real \<Rightarrow> complex"
	where "laplace_integrand s t = exp (t \<^sub>R - s) f t"

	lemma laplace_integrand_absolutely_integrable_on_Icc:
	"laplace_integrand s absolutely_integrable_on {a..b}"
	if "AE x\<in>{a..b} in lebesgue. cmod (f x) \<le> B" "f integrable_on {a..b}"
	apply (cases "b \<le> a")
	subgoal by (auto intro!: absolutely_integrable_onI integrable_negligible[OF negligible_real_ivlI])
	proof goal_cases
	case 1
	have "compact ((\<lambda>x. exp (- (x *\<^sub>R s))) ` {a .. b})"
	by (rule compact_continuous_image) (auto intro!: continuous_intros)
	then obtain C where C: "0 \<le> C" "a \<le> x \<Longrightarrow> x \<le> b \<Longrightarrow> cmod (exp (- (x *\<^sub>R s))) \<le> C" for x
	using 1
	apply (auto simp: bounded_iff dest!: compact_imp_bounded)
	by (metis atLeastAtMost_iff exp_ge_zero order_refl order_trans scaleR_complex.sel(1))

	have m: "(\<lambda>x. indicator {a..b} x *\<^sub>R f x) \<in> borel_measurable lebesgue"
	apply (rule has_integral_implies_lebesgue_measurable)
	apply (rule integrable_integral)
	apply (rule that)
	done
	have "complex_set_integrable lebesgue {a..b} (\<lambda>x. exp (- (x \<^sub>R s)) (indicator {a .. b} x *\<^sub>R f x))"
	unfolding set_integrable_def
	apply (rule integrableI_bounded_set_indicator[where B="C * B"])
	apply (simp; fail)
	apply (rule borel_measurable_times)
	apply measurable
	apply (simp add: measurable_completion)
	apply (simp add: measurable_completion)
	apply (rule m)
	apply (simp add: emeasure_lborel_Icc_eq)
	using that(1)
	apply eventually_elim
	apply (auto simp: norm_mult)
	apply (rule mult_mono)
	using C
	by auto
	then show ?case
	unfolding set_integrable_def
	by (simp add: laplace_integrand_def[abs_def] indicator_inter_arith[symmetric])
	qed

	lemma laplace_integrand_integrable_on_Icc:
	"laplace_integrand s integrable_on {a..b}"
	if "AE x\<in>{a..b} in lebesgue. cmod (f x) \<le> B" "f integrable_on {a..b}"
	using laplace_integrand_absolutely_integrable_on_Icc[OF that]
	using set_lebesgue_integral_eq_integral(1) by blast

	lemma eventually_laplace_integrand_le:
	"\<forall>\<^sub>F t in at_top. cmod (laplace_integrand s t) \<le> M * exp (- (Re s - c) * t)"
	if "exponential_order M c f"
	using exponential_orderD(2)[OF that]
	proof (eventually_elim)
	case (elim t)
	show ?case
	unfolding laplace_integrand_def
	apply (rule norm_mult_ineq[THEN order_trans])
	apply (auto intro!: mult_left_mono[THEN order_trans, OF elim])
	apply (auto simp: exp_minus divide_simps algebra_simps exp_add[symmetric])
	done
	qed

	lemma
	assumes eo: "exponential_order M c f"
	and cs: "c < Re s"
	shows laplace_integrand_integrable_on_Ici_iff:
	"laplace_integrand s integrable_on {a..} \<longleftrightarrow>
	(\<forall>k>a. laplace_integrand s integrable_on {a..k})"
	(is ?th1)
	and laplace_integrand_absolutely_integrable_on_Ici_iff:
	"laplace_integrand s absolutely_integrable_on {a..} \<longleftrightarrow>
	(\<forall>k>a. laplace_integrand s absolutely_integrable_on {a..k})"
	(is ?th2)
	proof -
	have "\<forall>\<^sub>F t in at_top. a < (t::real)"
	using eventually_gt_at_top by blast
	then have "\<forall>\<^sub>F t in at_top. t > a \<and> cmod (laplace_integrand s t) \<le> M * exp (- (Re s - c) * t)"
	using eventually_laplace_integrand_le[OF eo]
	by eventually_elim (auto)
	then obtain A where A: "A > a" and le: "t \<ge> A \<Longrightarrow> cmod (laplace_integrand s t) \<le> M * exp (- (Re s - c) * t)" for t
	unfolding eventually_at_top_linorder
	by blast

	let ?f = "\<lambda>(k::real) (t::real). indicat_real {A..k} t *\<^sub>R laplace_integrand s t"

	from exponential_orderD[OF eo] have "M \<noteq> 0" by simp
	have 2: "(\<lambda>t. M * exp (- (Re s - c) * t)) integrable_on {A..}"
	unfolding integrable_on_cmult_iff[OF \<open>M \<noteq> 0\<close>] norm_exp_eq_Re
	by (rule integrable_on_exp_minus_to_infinity) (simp add: cs)

	have 3: "t\<in>{A..} \<Longrightarrow> cmod (?f k t) \<le> M * exp (- (Re s - c) * t)"
	(is "t\<in>_\<Longrightarrow> ?lhs t \<le> ?rhs t")
	for t k
	proof safe
	fix t assume "A \<le> t"
	have "?lhs t \<le> cmod (laplace_integrand s t)"
	by (auto simp: indicator_def)
	also have "\<dots> \<le> ?rhs t" using \<open>A \<le> t\<close> le by (simp add: laplace_integrand_def)
	finally show "?lhs t \<le> ?rhs t" .
	qed

	have 4: "\<forall>t\<in>{A..}. ((\<lambda>k. ?f k t) \<longlongrightarrow> laplace_integrand s t) at_top"
	proof safe
	fix t assume t: "t \<ge> A"
	have "\<forall>\<^sub>F k in at_top. k \<ge> t"
	by (simp add: eventually_ge_at_top)
	then have "\<forall>\<^sub>F k in at_top. laplace_integrand s t = ?f k t"
	by eventually_elim (use t in \<open>auto simp: indicator_def\<close>)
	then show "((\<lambda>k. ?f k t) \<longlongrightarrow> laplace_integrand s t) at_top" using tendsto_const
	by (rule Lim_transform_eventually[rotated])
	qed

	show th1: ?th1
	proof safe
	assume "\<forall>k>a. laplace_integrand s integrable_on {a..k}"
	note li = this[rule_format]
	have liA: "laplace_integrand s integrable_on {A..k}" for k
	proof cases
	assume "k \<le> A"
	then have "{A..k} = (if A = k then {k} else {})" by auto
	then show ?thesis by (auto intro!: integrable_negligible)
	next
	assume n: "\<not> k \<le> A"
	show ?thesis
	by (rule integrable_on_subinterval[OF li[of k]]) (use A n in auto)
	qed
	have "?f k integrable_on {A..k}" for k
	using liA[of k] negligible_empty
	by (rule integrable_spike) auto
	then have 1: "?f k integrable_on {A..}" for k
	by (rule integrable_on_superset) auto
	note 1 2 3 4
	note * = this[unfolded set_integrable_def]
	from li[of A] dominated_convergence_at_top(1)[OF *]
	show "laplace_integrand s integrable_on {a..}"
	by (rule integrable_Un') (use \<open>a < A\<close> in \<open>auto simp: max_def li\<close>)
	qed (rule integrable_on_subinterval, assumption, auto)

	show ?th2
	proof safe
	assume ai: "\<forall>k>a. laplace_integrand s absolutely_integrable_on {a..k}"
	then have "laplace_integrand s absolutely_integrable_on {a..A}"
	using A by auto
	moreover
	from ai have "\<forall>k>a. laplace_integrand s integrable_on {a..k}"
	using set_lebesgue_integral_eq_integral(1) by blast
	with th1 have i: "laplace_integrand s integrable_on {a..}" by auto
	have 1: "?f k integrable_on {A..}" for k
	apply (rule integrable_on_superset[where S="{A..k}"])
	using _ negligible_empty
	apply (rule integrable_spike[where f="laplace_integrand s"])
	apply (rule integrable_on_subinterval)
	apply (rule i)
	by (use \<open>a < A\<close> in auto)
	have "laplace_integrand s absolutely_integrable_on {A..}"
	using _ dominated_convergence_at_top(1)[OF 1 2 3 4] 2
	by (rule absolutely_integrable_integrable_bound) (use le in auto)
	ultimately
	have "laplace_integrand s absolutely_integrable_on ({a..A} \<union> {A..})"
	by (rule set_integrable_Un) auto
	also have "{a..A} \<union> {A..} = {a..}" using \<open>a < A\<close> by auto
	finally show "local.laplace_integrand s absolutely_integrable_on {a..}" .
	qed (rule set_integrable_subset, assumption, auto)
	qed

	theorem laplace_exists_laplace_integrandI:
	assumes "laplace_integrand s integrable_on {0..}"
	obtains F where "(f has_laplace F) s"
	proof -
	from assms
	have "(f has_laplace integral {0..} (laplace_integrand s)) s"
	unfolding has_laplace_def laplace_integrand_def by blast
	thus ?thesis ..
	qed

	lemma
	assumes eo: "exponential_order M c f"
	and pc: "\<And>k. AE x\<in>{0..k} in lebesgue. cmod (f x) \<le> B k" "\<And>k. f integrable_on {0..k}"
	and s: "Re s > c"
	shows laplace_integrand_integrable: "laplace_integrand s integrable_on {0..}" (is ?th1)
	and laplace_integrand_absolutely_integrable:
	"laplace_integrand s absolutely_integrable_on {0..}" (is ?th2)
	using eo laplace_integrand_absolutely_integrable_on_Icc[OF pc] s
	by (auto simp: laplace_integrand_integrable_on_Ici_iff
	laplace_integrand_absolutely_integrable_on_Ici_iff
	set_lebesgue_integral_eq_integral)

	lemma piecewise_continuous_on_AE_boundedE:
	assumes pc: "\<And>k. piecewise_continuous_on a k (I k) f"
	obtains B where "\<And>k. AE x\<in>{a..k} in lebesgue. cmod (f x) \<le> B k"
	apply atomize_elim
	apply (rule choice)
	apply (rule allI)
	subgoal for k
	using bounded_piecewise_continuous_image[OF pc[of k]]
	by (force simp: bounded_iff)
	done

	theorem piecewise_continuous_on_has_laplace:
	assumes eo: "exponential_order M c f"
	and pc: "\<And>k. piecewise_continuous_on 0 k (I k) f"
	and s: "Re s > c"
	obtains F where "(f has_laplace F) s"
	proof -
	from piecewise_continuous_on_AE_boundedE[OF pc]
	obtain B where AE: "AE x\<in>{0..k} in lebesgue. cmod (f x) \<le> B k" for k by force
	have int: "f integrable_on {0..k}" for k
	using pc
	by (rule piecewise_continuous_on_integrable)
	show ?thesis
	using pc
	apply (rule piecewise_continuous_on_AE_boundedE)
	apply (rule laplace_exists_laplace_integrandI)
	apply (rule laplace_integrand_integrable)
	apply (rule eo)
	apply assumption
	apply (rule int)
	apply (rule s)
	by (rule that)
	qed

	end


	subsection \<open>Concrete Laplace Transforms\<close>

	lemma exp_scaleR_has_vector_derivative_left'[derivative_intros]:
	"((\<lambda>t. exp (t \<^sub>R A)) has_vector_derivative A exp (t *\<^sub>R A)) (at t within S)"
	by (metis exp_scaleR_has_vector_derivative_right exp_times_scaleR_commute)

	lemma
	fixes a::complex\<comment>\<open>TODO: generalize\<close>
	assumes a: "0 < Re a"
	shows integrable_on_cexp_minus_to_infinity: "(\<lambda>x. exp (x *\<^sub>R - a)) integrable_on {c..}"
	and integral_cexp_minus_to_infinity: "integral {c..} (\<lambda>x. exp (x \<^sub>R - a)) = exp (c \<^sub>R - a) / a"
	proof -
	from a have "a \<noteq> 0" by auto
	define f where "f = (\<lambda>k x. if x \<in> {c..real k} then exp (x *\<^sub>R -a) else 0)"
	{
	fix k :: nat assume k: "of_nat k \<ge> c"
	from \<open>a \<noteq> 0\<close> k
	have "((\<lambda>x. exp (x \<^sub>R -a)) has_integral (-exp (k \<^sub>R -a)/a - (-exp (c *\<^sub>R -a)/a))) {c..real k}"
	by (intro fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros exp_scaleR_has_vector_derivative_left
	simp: divide_inverse_commute
	simp del: scaleR_minus_left scaleR_minus_right)
	hence "(f k has_integral (exp (c \<^sub>R -a)/a - exp (k \<^sub>R -a)/a)) {c..}" unfolding f_def
	by (subst has_integral_restrict) simp_all
	} note has_integral_f = this

	have integrable_fk: "f k integrable_on {c..}" for k
	proof -
	have "(\<lambda>x. exp (x *\<^sub>R -a)) integrable_on {c..of_real k}" (is ?P)
	unfolding f_def by (auto intro!: continuous_intros integrable_continuous_real)
	then have int: "(f k) integrable_on {c..of_real k}"
	by (rule integrable_eq) (simp add: f_def)
	show ?thesis
	by (rule integrable_on_superset[OF int]) (auto simp: f_def)
	qed
	have limseq: "\<And>x. x \<in>{c..} \<Longrightarrow> (\<lambda>k. f k x) \<longlonglongrightarrow> exp (x *\<^sub>R - a)"
	apply (auto intro!: Lim_transform_eventually[OF tendsto_const] simp: f_def)
	by (meson eventually_sequentiallyI nat_ceiling_le_eq)
	have bnd: "\<And>x. x \<in> {c..} \<Longrightarrow> cmod (f k x) \<le> exp (- Re a * x)" for k
	by (auto simp: f_def)

	have [simp]: "f k = (\<lambda>_. 0)" if "of_nat k < c" for k using that by (auto simp: fun_eq_iff f_def)
	have integral_f: "integral {c..} (f k) =
	(if real k \<ge> c then exp (c \<^sub>R -a)/a - exp (k \<^sub>R -a)/a else 0)"
	for k using integral_unique[OF has_integral_f[of k]] by simp

	have "(\<lambda>k. exp (c \<^sub>R -a)/a - exp (k \<^sub>R -a)/a) \<longlonglongrightarrow> exp (c*\<^sub>R-a)/a - 0/a"
	apply (intro tendsto_intros filterlim_compose[OF exp_at_bot]
	filterlim_tendsto_neg_mult_at_bot[OF tendsto_const] filterlim_real_sequentially)+
	apply (rule tendsto_norm_zero_cancel)
	by (auto intro!: assms \<open>a \<noteq> 0\<close> filterlim_real_sequentially
	filterlim_compose[OF exp_at_bot] filterlim_compose[OF filterlim_uminus_at_bot_at_top]
	filterlim_at_top_mult_tendsto_pos[OF tendsto_const])
	moreover
	note A = dominated_convergence[where g="\<lambda>x. exp (x *\<^sub>R -a)",
	OF integrable_fk integrable_on_exp_minus_to_infinity[where a="Re a" and c=c, OF \<open>0 < Re a\<close>]
	bnd limseq]
	from A(1) show "(\<lambda>x. exp (x *\<^sub>R - a)) integrable_on {c..}" .
	from eventually_gt_at_top[of "nat \<lceil>c\<rceil>"] have "eventually (\<lambda>k. of_nat k > c) sequentially"
	by eventually_elim linarith
	hence "eventually (\<lambda>k. exp (c \<^sub>R -a)/a - exp (k \<^sub>R -a)/a = integral {c..} (f k)) sequentially"
	by eventually_elim (simp add: integral_f)
	ultimately have "(\<lambda>k. integral {c..} (f k)) \<longlonglongrightarrow> exp (c *\<^sub>R -a)/a - 0/a"
	by (rule Lim_transform_eventually)
	from LIMSEQ_unique[OF A(2) this]
	show "integral {c..} (\<lambda>x. exp (x \<^sub>R -a)) = exp (c \<^sub>R -a)/a" by simp
	qed

	lemma has_integral_cexp_minus_to_infinity:
	fixes a::complex\<comment>\<open>TODO: generalize\<close>
	assumes a: "0 < Re a"
	shows "((\<lambda>x. exp (x \<^sub>R - a)) has_integral exp (c \<^sub>R - a) / a) {c..}"
	using integral_cexp_minus_to_infinity[OF assms]
	integrable_on_cexp_minus_to_infinity[OF assms]
	using has_integral_integrable_integral by blast

	lemma has_laplace_one:
	"((\<lambda>_. 1) has_laplace inverse s) s" if "Re s > 0"
	proof (safe intro!: has_laplaceI)
	from that have "((\<lambda>t. exp (t *\<^sub>R - s)) has_integral inverse s) {0..}"
	by (rule has_integral_cexp_minus_to_infinity[THEN has_integral_eq_rhs])
	(auto simp: inverse_eq_divide)
	then show "((\<lambda>t. exp (t \<^sub>R - s) 1) has_integral inverse s) {0..}" by simp
	qed

	lemma has_laplace_add:
	assumes f: "(f has_laplace F) S"
	assumes g: "(g has_laplace G) S"
	shows "((\<lambda>x. f x + g x) has_laplace F + G) S"
	apply (rule has_laplaceI)
	using has_integral_add[OF has_laplaceD[OF f ] has_laplaceD[OF g]]
	by (auto simp: algebra_simps)

	lemma has_laplace_cmul:
	assumes "(f has_laplace F) S"
	shows "((\<lambda>x. r \<^sub>R f x) has_laplace r \<^sub>R F) S"
	apply (rule has_laplaceI)
	using has_laplaceD[OF assms, THEN has_integral_cmul[where c=r]]
	by auto

	lemma has_laplace_uminus:
	assumes "(f has_laplace F) S"
	shows "((\<lambda>x. - f x) has_laplace - F) S"
	using has_laplace_cmul[OF assms, of "-1"]
	by auto

	lemma has_laplace_minus:
	assumes f: "(f has_laplace F) S"
	assumes g: "(g has_laplace G) S"
	shows "((\<lambda>x. f x - g x) has_laplace F - G) S"
	using has_laplace_add[OF f has_laplace_uminus[OF g]]
	by simp

	lemma has_laplace_spike:
	"(f has_laplace L) s"
	if L: "(g has_laplace L) s"
	and "negligible T"
	and "\<And>t. t \<notin> T \<Longrightarrow> t \<ge> 0 \<Longrightarrow> f t = g t"
	by (auto intro!: has_laplaceI has_integral_spike[where S="T", OF _ _ has_laplaceD[OF L]] that)


	lemma has_laplace_frequency_shift:\<comment>\<open>First Translation Theorem in Schiff\<close>
	"((\<lambda>t. exp (t \<^sub>R b) f t) has_laplace L) s"
	if "(f has_laplace L) (s - b)"
	using that
	by (auto intro!: has_laplaceI dest!: has_laplaceD
	simp: mult_exp_exp algebra_simps)

	theorem has_laplace_derivative_time_domain:
	"(f' has_laplace s * L - f0) s"
	if L: "(f has_laplace L) s"
	and f': "\<And>t. t > 0 \<Longrightarrow> (f has_vector_derivative f' t) (at t)"
	and f0: "(f \<longlongrightarrow> f0) (at_right 0)"
	and eo: "exponential_order M c f"
	and cs: "c < Re s"
	\<comment>\<open>Proof and statement follow "The Laplace Transform: Theory and Applications" by Joel L. Schiff.\<close>
	proof (rule has_laplaceI)
	have ce: "continuous_on S (\<lambda>t. exp (t *\<^sub>R - s))" for S
	by (auto intro!: continuous_intros)
	have de: "((\<lambda>t. exp (t \<^sub>R - s)) has_vector_derivative (- s exp (- (t *\<^sub>R s)))) (at t)" for t
	by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros ext)
	have "((\<lambda>x. -s * (f x * exp (- (x \<^sub>R s)))) has_integral - s L) {0..}"
	apply (rule has_integral_mult_right)
	using has_laplaceD[OF L]
	by (auto simp: ac_simps)

	define g where "g x = (if x \<le> 0 then f0 else f x)" for x

	have eog: "exponential_order M c g"
	proof -
	from exponential_orderD[OF eo] have "0 < M"
	and ev: "\<forall>\<^sub>F t in at_top. cmod (f t) \<le> M * exp (c * t)" .
	have "\<forall>\<^sub>F t::real in at_top. t > 0" by simp
	with ev have "\<forall>\<^sub>F t in at_top. cmod (g t) \<le> M * exp (c * t)"
	by eventually_elim (auto simp: g_def)
	with \<open>0 < M\<close> show ?thesis
	by (rule exponential_orderI)
	qed
	have Lg: "(g has_laplace L) s"
	using L
	by (rule has_laplace_spike[where T="{0}"]) (auto simp: g_def)
	have g': "\<And>t. 0 < t \<Longrightarrow> (g has_vector_derivative f' t) (at t)"
	using f'
	by (rule has_vector_derivative_transform_within_open[where S="{0<..}"]) (auto simp: g_def)
	have cg: "continuous_on {0..k} g" for k
	apply (auto simp: g_def continuous_on_def)
	apply (rule filterlim_at_within_If)
	subgoal by (rule tendsto_intros)
	subgoal
	apply (rule tendsto_within_subset)
	apply (rule f0)
	by auto
	subgoal premises prems for x
	proof -
	from prems have "0 < x" by auto
	from order_tendstoD[OF tendsto_ident_at this]
	have "eventually ((<) 0) (at x within {0..k})" by auto
	then have "\<forall>\<^sub>F x in at x within {0..k}. f x = (if x \<le> 0 then f0 else f x)"
	by eventually_elim auto
	moreover
	note [simp] = at_within_open[where S="{0<..}"]
	have "continuous_on {0<..} f"
	by (rule continuous_on_vector_derivative)
	(auto simp add: intro!: f')
	then have "(f \<longlongrightarrow> f x) (at x within {0..k})"
	using \<open>0 < x\<close>
	by (auto simp: continuous_on_def intro: Lim_at_imp_Lim_at_within)
	ultimately show ?thesis
	by (rule Lim_transform_eventually[rotated])
	qed
	done
	then have pcg: "piecewise_continuous_on 0 k {} g" for k
	by (auto simp: piecewise_continuous_on_def)
	from piecewise_continuous_on_AE_boundedE[OF this]
	obtain B where B: "AE x\<in>{0..k} in lebesgue. cmod (g x) \<le> B k" for k by auto
	have 1: "laplace_integrand g s absolutely_integrable_on {0..}"
	apply (rule laplace_integrand_absolutely_integrable[OF eog])
	apply (rule B)
	apply (rule piecewise_continuous_on_integrable)
	apply (rule pcg)
	apply (rule cs)
	done
	then have csi: "complex_set_integrable lebesgue {0..} (\<lambda>x. exp (x \<^sub>R - s) g x)"
	by (auto simp: laplace_integrand_def[abs_def])
	from has_laplaceD[OF Lg, THEN has_integral_improperE, OF csi]
	obtain J where J: "\<And>k. ((\<lambda>t. exp (t \<^sub>R - s) g t) has_integral J k) {0..k}"
	and [tendsto_intros]: "(J \<longlongrightarrow> L) at_top"
	by auto
	have "((\<lambda>x. -s * (exp (x \<^sub>R - s) g x)) has_integral -s * J k) {0..k}" for k
	by (rule has_integral_mult_right) (rule J)
	then have : "((\<lambda>x. g x (- s * exp (- (x \<^sub>R s)))) has_integral -s J k) {0..k}" for k
	by (auto simp: algebra_simps)
	have "\<forall>\<^sub>F k::real in at_top. k \<ge> 0"
	using eventually_ge_at_top by blast
	then have evI: "\<forall>\<^sub>F k in at_top. ((\<lambda>t. exp (t \<^sub>R - s) f' t) has_integral
	g k * exp (k \<^sub>R - s) + s J k - g 0) {0..k}"
	proof eventually_elim
	case (elim k)
	show ?case
	apply (subst mult.commute)
	apply (rule integration_by_parts_interior[OF bounded_bilinear_mult], fact)
	apply (rule cg) apply (rule ce) apply (rule g') apply force apply (rule de)
	apply (rule has_integral_eq_rhs)
	apply (rule *)
	- by (auto simp: )
	+ by auto
	qed
	have t1: "((\<lambda>x. g x * exp (x *\<^sub>R - s)) \<longlongrightarrow> 0) at_top"
	apply (subst mult.commute)
	unfolding laplace_integrand_def[symmetric]
	apply (rule Lim_null_comparison)
	apply (rule eventually_laplace_integrand_le[OF eog])
	apply (rule tendsto_mult_right_zero)
	apply (rule filterlim_compose[OF exp_at_bot])
	apply (rule filterlim_tendsto_neg_mult_at_bot)
	apply (rule tendsto_intros)
	using cs apply simp
	apply (rule filterlim_ident)
	done
	show "((\<lambda>t. exp (t \<^sub>R - s) f' t) has_integral s * L - f0) {0..}"
	apply (rule has_integral_improper_at_topI[OF evI])
	subgoal
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule t1)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	by (simp add: g_def)
	done
	qed

	lemma exp_times_has_integral:
	"((\<lambda>t. exp (c * t)) has_integral (if c = 0 then t else exp (c * t) / c) - (if c = 0 then t0 else exp (c * t0) / c)) {t0 .. t}"
	if "t0 \<le> t"
	for c t::real
	apply (cases "c = 0")
	subgoal
	using that
	apply auto
	apply (rule has_integral_eq_rhs)
	apply (rule has_integral_const_real)
	by auto
	subgoal
	apply (rule fundamental_theorem_of_calculus)
	using that
	by (auto simp: has_vector_derivative_def intro!: derivative_eq_intros)
	done

	lemma integral_exp_times:
	"integral {t0 .. t} (\<lambda>t. exp (c * t)) = (if c = 0 then t - t0 else exp (c * t) / c - exp (c * t0) / c)"
	if "t0 \<le> t"
	for c t::real
	using exp_times_has_integral[OF that, of c] that
	by (auto split: if_splits)

	lemma filtermap_times_pos_at_top: "filtermap ((*) e) at_top = at_top"
	if "e > 0"
	for e::real
	apply (rule filtermap_fun_inverse[of "(*) (inverse e)"])
	apply (rule filterlim_tendsto_pos_mult_at_top)
	apply (rule tendsto_intros)
	subgoal using that by simp
	apply (rule filterlim_ident)
	apply (rule filterlim_tendsto_pos_mult_at_top)
	apply (rule tendsto_intros)
	subgoal using that by simp
	apply (rule filterlim_ident)
	using that by auto

	lemma exponential_order_additiveI:
	assumes "0 < M" and eo: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> K + M * exp (c * t)" and "c \<ge> 0"
	obtains M' where "exponential_order M' c f"
	proof -
	consider "c = 0" \| "c > 0" using \<open>c \<ge> 0\<close> by arith
	then show ?thesis
	proof cases
	assume "c = 0"
	have "exponential_order (max K 0 + M) c f"
	using eo
	apply (auto intro!: exponential_orderI add_nonneg_pos \<open>0 < M\<close> simp: \<open>c = 0\<close>)
	apply (auto simp: max_def)
	using eventually_elim2 by force
	then show ?thesis ..
	next
	assume "c > 0"
	have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> K + M * exp (c * t)"
	by fact
	moreover
	have "\<forall>\<^sub>F t in (filtermap exp (filtermap ((*) c) at_top)). K < t"
	by (simp add: filtermap_times_pos_at_top \<open>c > 0\<close> filtermap_exp_at_top)
	then have "\<forall>\<^sub>F t in at_top. K < exp (c * t)"
	by (simp add: eventually_filtermap)
	ultimately
	have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> (1 + M) * exp (c * t)"
	by eventually_elim (auto simp: algebra_simps)
	with add_nonneg_pos[OF zero_le_one \<open>0 < M\<close>]
	have "exponential_order (1 + M) c f"
	by (rule exponential_orderI)
	then show ?thesis ..
	qed
	qed

	lemma exponential_order_integral:
	fixes f::"real \<Rightarrow> 'a::banach"
	assumes I: "\<And>t. t \<ge> a \<Longrightarrow> (f has_integral I t) {a .. t}"
	and eo: "exponential_order M c f"
	and "c > 0"
	obtains M' where "exponential_order M' c I"
	proof -
	from exponential_orderD[OF eo] have "0 < M"
	and bound: "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t)"
	by auto
	have "\<forall>\<^sub>F t in at_top. t > a"
	by simp
	from bound this
	have "\<forall>\<^sub>F t in at_top. norm (f t) \<le> M * exp (c * t) \<and> t > a"
	by eventually_elim auto
	then obtain t0 where t0: "\<And>t. t \<ge> t0 \<Longrightarrow> norm (f t) \<le> M * exp (c * t)" "t0 > a"
	by (auto simp: eventually_at_top_linorder)
	have "\<forall>\<^sub>F t in at_top. t > t0" by simp
	then have "\<forall>\<^sub>F t in at_top. norm (I t) \<le> norm (integral {a..t0} f) - M * exp (c * t0) / c + (M / c) * exp (c * t)"
	proof eventually_elim
	case (elim t) then have that: "t \<ge> t0" by simp
	from t0 have "a \<le> t0" by simp
	have "f integrable_on {a .. t0}" "f integrable_on {t0 .. t}"
	subgoal by (rule has_integral_integrable[OF I[OF \<open>a \<le> t0\<close>]])
	subgoal
	apply (rule integrable_on_subinterval[OF has_integral_integrable[OF I[where t=t]]])
	using \<open>t0 > a\<close> that by auto
	done
	have "I t = integral {a .. t0} f + integral {t0 .. t} f"
	by (smt I \<open>a \<le> t0\<close> \<open>f integrable_on {t0..t}\<close> has_integral_combine has_integral_integrable_integral that)
	also have "norm \<dots> \<le> norm (integral {a .. t0} f) + norm (integral {t0 .. t} f)" by norm
	also
	have "norm (integral {t0 .. t} f) \<le> integral {t0 .. t} (\<lambda>t. M * exp (c * t))"
	apply (rule integral_norm_bound_integral)
	apply fact
	by (auto intro!: integrable_continuous_interval continuous_intros t0)
	also have "\<dots> = M * integral {t0 .. t} (\<lambda>t. exp (c * t))"
	by simp
	also have "integral {t0 .. t} (\<lambda>t. exp (c * t)) = exp (c * t) / c - exp (c * t0) / c"
	using \<open>c > 0\<close> \<open>t0 \<le> t\<close>
	by (subst integral_exp_times) auto
	finally show ?case
	using \<open>c > 0\<close>
	by (auto simp: algebra_simps)
	qed
	from exponential_order_additiveI[OF divide_pos_pos[OF \<open>0 < M\<close> \<open>0 < c\<close>] this less_imp_le[OF \<open>0 < c\<close>]]
	obtain M' where "exponential_order M' c I" .
	then show ?thesis ..
	qed

	lemma integral_has_vector_derivative_piecewise_continuous:
	fixes f :: "real \<Rightarrow> 'a::euclidean_space"\<comment>\<open>TODO: generalize?\<close>
	assumes "piecewise_continuous_on a b D f"
	shows "\<And>x. x \<in> {a .. b} - D \<Longrightarrow>
	((\<lambda>u. integral {a..u} f) has_vector_derivative f(x)) (at x within {a..b} - D)"
	using assms
	proof (induction a b D f rule: piecewise_continuous_on_induct)
	case (empty a b f)
	then show ?case
	by (auto intro: integral_has_vector_derivative)
	next
	case (combine a i b I f1 f2 f)
	then consider "x < i" \| "i < x" by auto arith

	then show ?case
	proof cases\<comment>\<open>TODO: this is very explicit...\<close>
	case 1
	have evless: "\<forall>\<^sub>F xa in nhds x. xa < i"
	apply (rule order_tendstoD[OF _ \<open>x < i\<close>])
	by (simp add: filterlim_ident)
	have eq: "at x within {a..b} - insert i I = at x within {a .. i} - I"
	unfolding filter_eq_iff
	proof safe
	fix P
	assume "eventually P (at x within {a..i} - I)"
	with evless show "eventually P (at x within {a..b} - insert i I)"
	unfolding eventually_at_filter
	by eventually_elim auto
	next
	fix P
	assume "eventually P (at x within {a..b} - insert i I)"
	with evless show "eventually P (at x within {a..i} - I)"
	unfolding eventually_at_filter
	apply eventually_elim
	using 1 combine
	by auto
	qed
	have "f x = f1 x" using combine 1 by auto
	have i_eq: "integral {a..y} f = integral {a..y} f1" if "y < i" for y
	using negligible_empty
	apply (rule integral_spike)
	using combine 1 that
	by auto
	from evless have ev_eq: "\<forall>\<^sub>F x in nhds x. x \<in> {a..i} - I \<longrightarrow> integral {a..x} f = integral {a..x} f1"
	by eventually_elim (auto simp: i_eq)
	show ?thesis unfolding eq \<open>f x = f1 x\<close>
	apply (subst has_vector_derivative_cong_ev[OF ev_eq])
	using combine.IH[of x]
	using combine.hyps combine.prems 1
	by (auto simp: i_eq)
	next
	case 2
	have evless: "\<forall>\<^sub>F xa in nhds x. xa > i"
	apply (rule order_tendstoD[OF _ \<open>x > i\<close>])
	by (simp add: filterlim_ident)
	have eq: "at x within {a..b} - insert i I = at x within {i .. b} - I"
	unfolding filter_eq_iff
	proof safe
	fix P
	assume "eventually P (at x within {i..b} - I)"
	with evless show "eventually P (at x within {a..b} - insert i I)"
	unfolding eventually_at_filter
	by eventually_elim auto
	next
	fix P
	assume "eventually P (at x within {a..b} - insert i I)"
	with evless show "eventually P (at x within {i..b} - I)"
	unfolding eventually_at_filter
	apply eventually_elim
	using 2 combine
	by auto
	qed
	have "f x = f2 x" using combine 2 by auto
	have i_eq: "integral {a..y} f = integral {a..i} f + integral {i..y} f2" if "i < y" "y \<le> b" for y
	proof -
	have "integral {a..y} f = integral {a..i} f + integral {i..y} f"
	apply (cases "i = y")
	subgoal by auto
	subgoal
	apply (rule Henstock_Kurzweil_Integration.integral_combine[symmetric])
	using combine that apply auto
	apply (rule integrable_Un'[where A="{a .. i}" and B="{i..y}"])
	subgoal
	by (rule integrable_spike[where S="{i}" and f="f1"])
	(auto intro: piecewise_continuous_on_integrable)
	subgoal
	apply (rule integrable_on_subinterval[where S="{i..b}"])
	by (rule integrable_spike[where S="{i}" and f="f2"])
	(auto intro: piecewise_continuous_on_integrable)
	subgoal by (auto simp: max_def min_def)
	subgoal by auto
	done
	done
	also have "integral {i..y} f = integral {i..y} f2"
	apply (rule integral_spike[where S="{i}"])
	using combine 2 that
	by auto
	finally show ?thesis .
	qed
	from evless have ev_eq: "\<forall>\<^sub>F y in nhds x. y \<in> {i..b} - I \<longrightarrow> integral {a..y} f = integral {a..i} f + integral {i..y} f2"
	by eventually_elim (auto simp: i_eq)
	show ?thesis unfolding eq
	apply (subst has_vector_derivative_cong_ev[OF ev_eq])
	using combine.IH[of x] combine.prems combine.hyps 2
	by (auto simp: i_eq intro!: derivative_eq_intros)
	qed
	qed (auto intro: has_vector_derivative_within_subset)

	lemma has_derivative_at_split:
	"(f has_derivative f') (at x) \<longleftrightarrow> (f has_derivative f') (at_left x) \<and> (f has_derivative f') (at_right x)"
	for x::"'a::{linorder_topology, real_normed_vector}"
	by (auto simp: has_derivative_at_within filterlim_at_split)

	lemma has_vector_derivative_at_split:
	"(f has_vector_derivative f') (at x) \<longleftrightarrow>
	(f has_vector_derivative f') (at_left x) \<and>
	(f has_vector_derivative f') (at_right x)"
	using has_derivative_at_split[of f "\<lambda>h. h *\<^sub>R f'" x]
	by (simp add: has_vector_derivative_def)

	lemmas differentiableI_vector[intro]

	lemma differentiable_at_splitD:
	"f differentiable at_left x"
	"f differentiable at_right x"
	if "f differentiable (at x)"
	for x::real
	using that[unfolded vector_derivative_works has_vector_derivative_at_split]
	by auto

	lemma integral_differentiable:
	fixes f :: "real \<Rightarrow> 'a::banach"
	assumes "continuous_on {a..b} f"
	and "x \<in> {a..b}"
	shows "(\<lambda>u. integral {a..u} f) differentiable at x within {a..b}"
	using integral_has_vector_derivative[OF assms]
	by blast

	theorem integral_has_vector_derivative_piecewise_continuous':
	fixes f :: "real \<Rightarrow> 'a::euclidean_space"\<comment>\<open>TODO: generalize?\<close>
	assumes "piecewise_continuous_on a b D f" "a < b"
	shows
	"(\<forall>x. a < x \<longrightarrow> x < b \<longrightarrow> x \<notin> D \<longrightarrow> (\<lambda>u. integral {a..u} f) differentiable at x) \<and>
	(\<forall>x. a \<le> x \<longrightarrow> x < b \<longrightarrow> (\<lambda>t. integral {a..t} f) differentiable at_right x) \<and>
	(\<forall>x. a < x \<longrightarrow> x \<le> b \<longrightarrow> (\<lambda>t. integral {a..t} f) differentiable at_left x)"
	using assms
	proof (induction a b D f rule: piecewise_continuous_on_induct)
	case (empty a b f)
	have "a < x \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>u. integral {a..u} f) differentiable (at x)" for x
	using integral_differentiable[OF empty(1), of x]
	by (auto simp: at_within_interior)
	then show ?case
	using integral_differentiable[OF empty(1), of a]
	integral_differentiable[OF empty(1), of b]
	\<open>a < b\<close>
	by (auto simp: at_within_Icc_at_right at_within_Icc_at_left le_less
	intro: differentiable_at_withinI)
	next
	case (combine a i b I f1 f2 f)
	from \<open>piecewise_continuous_on a i I f1\<close> have "finite I"
	by (auto elim!: piecewise_continuous_onE)

	from combine(4) have "piecewise_continuous_on a i (insert i I) f1"
	by (rule piecewise_continuous_on_insert_rightI)
	then have "piecewise_continuous_on a i (insert i I) f"
	by (rule piecewise_continuous_on_congI) (auto simp: combine)
	moreover
	from combine(5) have "piecewise_continuous_on i b (insert i I) f2"
	by (rule piecewise_continuous_on_insert_leftI)
	then have "piecewise_continuous_on i b (insert i I) f"
	by (rule piecewise_continuous_on_congI) (auto simp: combine)
	ultimately have "piecewise_continuous_on a b (insert i I) f"
	by (rule piecewise_continuous_on_combine)
	then have f_int: "f integrable_on {a .. b}"
	by (rule piecewise_continuous_on_integrable)

	from combine.IH
	have f1: "x>a \<Longrightarrow> x < i \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {a..u} f1) differentiable (at x)"
	"x\<ge>a \<Longrightarrow> x < i \<Longrightarrow> (\<lambda>t. integral {a..t} f1) differentiable (at_right x)"
	"x>a \<Longrightarrow> x \<le> i \<Longrightarrow> (\<lambda>t. integral {a..t} f1) differentiable (at_left x)"
	and f2: "x>i \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {i..u} f2) differentiable (at x)"
	"x\<ge>i \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>t. integral {i..t} f2) differentiable (at_right x)"
	"x>i \<Longrightarrow> x \<le> b \<Longrightarrow> (\<lambda>t. integral {i..t} f2) differentiable (at_left x)"
	for x
	by auto

	have "(\<lambda>u. integral {a..u} f) differentiable at x" if "a < x" "x < b" "x \<noteq> i" "x \<notin> I" for x
	proof -
	from that consider "x < i" \|"i < x" by arith
	then show ?thesis
	proof cases
	case 1
	have at: "at x within {a<..<i} - I = at x"
	using that 1
	by (intro at_within_open) (auto intro!: open_Diff finite_imp_closed \<open>finite I\<close>)
	then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {a<..<i} - I"
	using that 1 f1 by auto
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {a<..<i} - I"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 1 by (auto intro!: integral_cong)
	then show ?thesis by (simp add: at)
	next
	case 2
	have at: "at x within {i<..<b} - I = at x"
	using that 2
	by (intro at_within_open) (auto intro!: open_Diff finite_imp_closed \<open>finite I\<close>)
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {i<..<b} - I"
	using that 2 f2 by auto
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {i<..<b} - I"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {i<..<b} - I"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	subgoal using that 2 by auto
	- apply (auto simp: )
	+ apply auto
	apply (subst Henstock_Kurzweil_Integration.integral_combine)
	using that 2 \<open>a \<le> i\<close>
	apply auto
	by (auto intro: integrable_on_subinterval f_int)
	then show ?thesis by (simp add: at)
	qed
	qed
	moreover
	have "(\<lambda>t. integral {a..t} f) differentiable at_right x" if "a \<le> x" "x < b" for x
	proof -
	from that consider "x < i" \|"i \<le> x" by arith
	then show ?thesis
	proof cases
	case 1
	have at: "at x within {x..i} = at_right x"
	using \<open>x < i\<close> by (rule at_within_Icc_at_right)
	then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {x..i}"
	using that 1 f1 by auto
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {x..i}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 1 by (auto intro!: integral_spike[where S="{i,x}"])
	then show ?thesis by (simp add: at)
	next
	case 2
	have at: "at x within {x..b} = at_right x"
	using \<open>x < b\<close> by (rule at_within_Icc_at_right)
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {x..b}"
	using that 2 f2 by auto
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {x..b}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {x..b}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	subgoal using that 2 by auto
	- apply (auto simp: )
	+ apply auto
	apply (subst Henstock_Kurzweil_Integration.integral_combine)
	using that 2 \<open>a \<le> i\<close>
	apply auto
	by (auto intro: integrable_on_subinterval f_int)
	then show ?thesis by (simp add: at)
	qed
	qed
	moreover
	have "(\<lambda>t. integral {a..t} f) differentiable at_left x" if "a < x" "x \<le> b" for x
	proof -
	from that consider "x \<le> i" \|"i < x" by arith
	then show ?thesis
	proof cases
	case 1
	have at: "at x within {a..x} = at_left x"
	using \<open>a < x\<close> by (rule at_within_Icc_at_left)
	then have "(\<lambda>u. integral {a..u} f1) differentiable at x within {a..x}"
	using that 1 f1 by auto
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {a..x}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 1 by (auto intro!: integral_spike[where S="{i,x}"])
	then show ?thesis by (simp add: at)
	next
	case 2
	have at: "at x within {i..x} = at_left x"
	using \<open>i < x\<close> by (rule at_within_Icc_at_left)
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f2) differentiable at x within {i..x}"
	using that 2 f2 by auto
	then have "(\<lambda>u. integral {a..i} f + integral {i..u} f) differentiable at x within {i..x}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	using that combine.hyps 2 by (auto intro!: integral_spike[where S="{i,x}"])
	then have "(\<lambda>u. integral {a..u} f) differentiable at x within {i..x}"
	apply (rule differentiable_transform_within[OF _ zero_less_one])
	subgoal using that 2 by auto
	- apply (auto simp: )
	+ apply auto
	apply (subst Henstock_Kurzweil_Integration.integral_combine)
	using that 2 \<open>a \<le> i\<close>
	apply auto
	by (auto intro: integrable_on_subinterval f_int)
	then show ?thesis by (simp add: at)
	qed
	qed
	ultimately
	show ?case
	by auto
	next
	case (weaken a b i I f)
	from weaken.IH[OF \<open>a < b\<close>]
	obtain l u where IH:
	"\<And>x. a < x \<Longrightarrow> x < b \<Longrightarrow> x \<notin> I \<Longrightarrow> (\<lambda>u. integral {a..u} f) differentiable (at x)"
	"\<And>x. a \<le> x \<Longrightarrow> x < b \<Longrightarrow> (\<lambda>t. integral {a..t} f) differentiable (at_right x)"
	"\<And>x. a < x \<Longrightarrow> x \<le> b \<Longrightarrow> (\<lambda>t. integral {a..t} f) differentiable (at_left x)"
	by metis
	then show ?case by auto
	qed

	lemma "closure (-S) \<inter> closure S = frontier S"
	by (auto simp add: frontier_def closure_complement)

	theorem integral_time_domain_has_laplace:
	"((\<lambda>t. integral {0 .. t} f) has_laplace L / s) s"
	if pc: "\<And>k. piecewise_continuous_on 0 k D f"
	and eo: "exponential_order M c f"
	and L: "(f has_laplace L) s"
	and s: "Re s > c"
	and c: "c > 0"
	and TODO: "D = {}" \<comment> \<open>TODO: generalize to actual \<open>piecewise_continuous_on\<close>\<close>
	for f::"real \<Rightarrow> complex"
	proof -
	define I where "I = (\<lambda>t. integral {0 .. t} f)"
	have I': "(I has_vector_derivative f t) (at t within {0..x} - D)"
	if "t \<in> {0 .. x} - D"
	for x t
	unfolding I_def
	by (rule integral_has_vector_derivative_piecewise_continuous; fact)
	have fi: "f integrable_on {0..t}" for t
	by (rule piecewise_continuous_on_integrable) fact
	have Ic: "continuous_on {0 .. t} I" for t
	unfolding I_def using fi
	by (rule indefinite_integral_continuous_1)
	have Ipc: "piecewise_continuous_on 0 t {} I" for t
	by (rule piecewise_continuous_onI) (auto intro!: Ic)
	have I: "(f has_integral I t) {0 .. t}" for t
	unfolding I_def
	using fi
	by (rule integrable_integral)
	from exponential_order_integral[OF I eo \<open>0 < c\<close>] obtain M'
	where Ieo: "exponential_order M' c I" .
	have Ili: "laplace_integrand I s integrable_on {0..}"
	using Ipc
	apply (rule piecewise_continuous_on_AE_boundedE)
	apply (rule laplace_integrand_integrable)
	apply (rule Ieo)
	apply assumption
	apply (rule integrable_continuous_interval)
	apply (rule Ic)
	apply (rule s)
	done
	then obtain LI where LI: "(I has_laplace LI) s"
	by (rule laplace_exists_laplace_integrandI)

	from piecewise_continuous_onE[OF pc] have \<open>finite D\<close> by auto
	have I'2: "(I has_vector_derivative f t) (at t)" if "t > 0" "t \<notin> D" for t
	apply (subst at_within_open[symmetric, where S="{0<..<t+1} - D"])
	subgoal using that by auto
	subgoal by (auto intro!:open_Diff finite_imp_closed \<open>finite D\<close>)
	subgoal using I'[where x="t + 1"]
	apply (rule has_vector_derivative_within_subset)
	using that
	by auto
	done
	have I_tndsto: "(I \<longlongrightarrow> 0) (at_right 0)"
	apply (rule tendsto_eq_rhs)
	apply (rule continuous_on_Icc_at_rightD)
	apply (rule Ic)
	apply (rule zero_less_one)
	by (auto simp: I_def)
	have "(f has_laplace s * LI - 0) s"
	by (rule has_laplace_derivative_time_domain[OF LI I'2 I_tndsto Ieo s])
	(auto simp: TODO)
	from has_laplace_unique[OF this L] have "LI = L / s"
	using s c by auto
	with LI show "(I has_laplace L / s) s" by simp
	qed

	subsection \<open>higher derivatives\<close>

	definition "nderiv i f X = ((\<lambda>f. (\<lambda>x. vector_derivative f (at x within X)))^^i) f"

	definition "ndiff n f X \<longleftrightarrow> (\<forall>i<n. \<forall>x \<in> X. nderiv i f X differentiable at x within X)"

	lemma nderiv_zero[simp]: "nderiv 0 f X = f"
	by (auto simp: nderiv_def)

	lemma nderiv_Suc[simp]:
	"nderiv (Suc i) f X x = vector_derivative (nderiv i f X) (at x within X)"
	by (auto simp: nderiv_def)

	lemma ndiff_zero[simp]: "ndiff 0 f X"
	by (auto simp: ndiff_def)

	lemma ndiff_Sucs[simp]:
	"ndiff (Suc i) f X \<longleftrightarrow>
	(ndiff i f X) \<and>
	(\<forall>x \<in> X. (nderiv i f X) differentiable (at x within X))"
	apply (auto simp: ndiff_def )
	using less_antisym by blast

	theorem has_laplace_vector_derivative:
	"((\<lambda>t. vector_derivative f (at t)) has_laplace s * L - f0) s"
	if L: "(f has_laplace L) s"
	and f': "\<And>t. t > 0 \<Longrightarrow> f differentiable (at t)"
	and f0: "(f \<longlongrightarrow> f0) (at_right 0)"
	and eo: "exponential_order M c f"
	and cs: "c < Re s"
	proof -
	have f': "(\<And>t. 0 < t \<Longrightarrow> (f has_vector_derivative vector_derivative f (at t)) (at t))"
	using f'
	by (subst vector_derivative_works[symmetric])
	show ?thesis
	by (rule has_laplace_derivative_time_domain[OF L f' f0 eo cs])
	qed

	lemma has_laplace_nderiv:
	"(nderiv n f {0<..} has_laplace s^n * L - (\<Sum>i<n. s^(n - Suc i) * f0 i)) s"
	if L: "(f has_laplace L) s"
	and f': "ndiff n f {0<..}"
	and f0: "\<And>i. i < n \<Longrightarrow> (nderiv i f {0<..} \<longlongrightarrow> f0 i) (at_right 0)"
	and eo: "\<And>i. i < n \<Longrightarrow> exponential_order M c (nderiv i f {0<..})"
	and cs: "c < Re s"
	using f' f0 eo
	proof (induction n)
	case 0
	then show ?case
	by (auto simp: L)
	next
	case (Suc n)
	have awo: "at t within {0<..} = at t" if "t > 0" for t::real
	using that
	by (subst at_within_open) auto
	have "((\<lambda>a. vector_derivative (nderiv n f {0<..}) (at a)) has_laplace
	s * ( s ^ n * L - (\<Sum>i<n. s^(n - Suc i) * f0 i)) - f0 n) s"
	(is "(_ has_laplace ?L) _")
	apply (rule has_laplace_vector_derivative)
	apply (rule Suc.IH)
	subgoal using Suc.prems by auto
	subgoal using Suc.prems by auto
	subgoal using Suc.prems by auto
	subgoal using Suc.prems by (auto simp: awo)
	subgoal using Suc.prems by auto
	apply (rule Suc.prems; force)
	apply (rule cs)
	done
	also have "?L = s ^ Suc n * L - (\<Sum>i<Suc n. s ^ (Suc n - Suc i) * f0 i)"
	by (auto simp: algebra_simps sum_distrib_left diff_Suc Suc_diff_le
	split: nat.splits
	intro!: sum.cong)
	finally show ?case
	by (rule has_laplace_spike[where T="{0}"]) (auto simp: awo)
	qed

	end
	\ No newline at end of file
	diff --git a/thys/List_Update/BIT.thy b/thys/List_Update/BIT.thy
	--- a/thys/List_Update/BIT.thy
	+++ b/thys/List_Update/BIT.thy
	@@ -1,2158 +1,2158 @@
	(* Title: Competitive Analysis of BIT
	Author: Max Haslbeck
	*)

	section "BIT: an Online Algorithm for the List Update Problem"

	theory BIT
	imports
	Bit_Strings
	MTF2_Effects
	begin


	abbreviation "config'' A qs init n == config_rand A init (take n qs)"


	lemma sum_my: fixes f g::"'b \<Rightarrow> 'a::ab_group_add"
	assumes "finite A" "finite B"
	shows "(\<Sum>x\<in>A. f x) - (\<Sum>x\<in>B. g x)
	= (\<Sum>x\<in>(A \<inter> B). f x - g x) + (\<Sum>x\<in>A-B. f x) - (\<Sum>x\<in>B-A. g x)"
	proof -
	have "finite (A-B)" and "finite (A\<inter>B)" and "finite (B-A)" and "finite (B\<inter>A)" using assms by auto
	note finites=this
	have "(A-B) \<inter> ( (A\<inter>B) ) = {}" and "(B-A) \<inter> ( (B\<inter>A) ) = {}" by auto
	note inters=this
	have commute: "A\<inter>B=B\<inter>A" by auto
	have "A = (A-B) \<union> (A\<inter>B)" and "B = (B-A) \<union> ( (B\<inter>A))" by auto
	then have "(\<Sum>x\<in>A. f x) - (\<Sum>x\<in>B. g x) = (\<Sum>x\<in>(A-B) \<union> (A\<inter>B). f x) - (\<Sum>x\<in>(B-A) \<union> (B\<inter>A). g x)" by auto
	also have "\<dots> = ( (\<Sum>x\<in>(A-B). f x) + (\<Sum>x\<in>(A\<inter>B). f x) - (\<Sum>x\<in>(A-B)\<inter>(A\<inter>B). f x) )
	-( (\<Sum>x\<in>(B-A). g x) + (\<Sum>x\<in>(B\<inter>A). g x) - (\<Sum>x\<in>(B-A)\<inter>(B\<inter>A). g x))"
	using sum_Un[where ?f="f",OF finites(1) finites(2)]
	sum_Un[where ?f="g",OF finites(3) finites(4)] by(simp)
	also have "\<dots> = ( (\<Sum>x\<in>(A-B). f x) + (\<Sum>x\<in>(A\<inter>B). f x) )
	- (\<Sum>x\<in>(B-A). g x) - (\<Sum>x\<in>(B\<inter>A). g x) " using inters by auto
	also have "\<dots> = (\<Sum>x\<in>(A-B). f x) - (\<Sum>x\<in>(A\<inter>B). g x) + (\<Sum>x\<in>(A\<inter>B). f x)
	- (\<Sum>x\<in>(B-A). g x) " using commute by auto
	also have "\<dots> = (\<Sum>x\<in>(A\<inter>B). f x - g x) +(\<Sum>x\<in>(A-B). f x)
	- (\<Sum>x\<in>(B-A). g x)" using sum_subtractf[of f g "(A\<inter>B)"] by auto
	finally show ?thesis .
	qed

	lemma sum_my2: "(\<forall>x\<in>A. f x = g x) \<Longrightarrow> (\<Sum>x\<in>A. f x) = (\<Sum>x\<in>A. g x)" by auto


	subsection "Definition of BIT"


	definition BIT_init :: "('a state,bool list * 'a list)alg_on_init" where
	"BIT_init init = map_pmf (\<lambda>l. (l,init)) (bv (length init))"



	lemma "~ deterministic_init BIT_init"
	unfolding deterministic_init_def BIT_init_def apply(auto)
	apply(intro exI[where x="[a]"])
	\<comment> \<open>comment in a proof\<close>
	by(auto simp: UNIV_bool set_pmf_bernoulli)

	definition BIT_step :: "('a state, bool list * 'a list, 'a, answer)alg_on_step" where
	"BIT_step s q = ( let a=((if (fst (snd s))!(index (snd (snd s)) q) then 0 else (length (fst s))),[]) in
	return_pmf (a , (flip (index (snd (snd s)) q) (fst (snd s)), snd (snd s))))"

	lemma "deterministic_step BIT_step"
	unfolding deterministic_step_def BIT_step_def
	by simp



	abbreviation BIT :: "('a state, bool list*'a list, 'a, answer)alg_on_rand" where
	"BIT == (BIT_init, BIT_step)"


	subsection "Properties of BIT's state distribution"

	lemma BIT_no_paid: "\<forall>((free,paid),_) \<in> (BIT_step s q). paid=[]"
	unfolding BIT_step_def
	by(auto)

	subsubsection "About the Internal State"
	term "(config'_rand (BIT_init, BIT_step) s0 qs) "
	lemma config'_n_init: fixes qs init n
	shows "map_pmf (snd \<circ> snd) (config'_rand (BIT_init, BIT_step) init qs) = map_pmf (snd \<circ> snd) init"
	apply (induct qs arbitrary: init)
	by (simp_all add: map_pmf_def bind_assoc_pmf BIT_step_def bind_return_pmf )


	lemma config_n_init: "map_pmf (snd \<circ> snd) (config_rand (BIT_init, BIT_step) s0 qs) = return_pmf s0"
	using config'_n_init[of "((fst (BIT_init, BIT_step) s0) \<bind> (\<lambda>is. return_pmf (s0, is)))"]
	by (simp_all add: map_pmf_def bind_assoc_pmf bind_return_pmf BIT_init_def )

	lemma config_n_init2: "\<forall>(_,(_,x)) \<in> set_pmf (config_rand (BIT_init, BIT_step) init qs). x = init"
	proof (rule, goal_cases)
	case (1 z)
	then have 1: "snd(snd z) \<in> (snd \<circ> snd) ` set_pmf (config_rand (BIT_init, BIT_step) init qs)"
	by force
	have "(snd \<circ> snd) ` set_pmf (config_rand (BIT_init, BIT_step) init qs)
	= set_pmf (map_pmf (snd \<circ> snd) (config_rand (BIT_init, BIT_step) init qs))" by(simp)
	also have "\<dots> = {init}" apply(simp only: config_n_init) by simp
	finally have "snd(snd z) = init" using 1 by auto
	then show ?case by auto
	qed
	lemma config_n_init3: "\<forall>x \<in> set_pmf (config_rand (BIT_init, BIT_step) init qs). snd (snd x) = init"
	using config_n_init2 by(simp add: split_def)



	lemma config'_n_bv: fixes qs init n
	shows " map_pmf (snd \<circ> snd) init = return_pmf s0
	\<Longrightarrow> map_pmf (fst \<circ> snd) init = bv (length s0)
	\<Longrightarrow> map_pmf (snd \<circ> snd) (config'_rand (BIT_init, BIT_step) init qs) = return_pmf s0
	\<and> map_pmf (fst \<circ> snd) (config'_rand (BIT_init, BIT_step) init qs) = bv (length s0)"
	proof (induct qs arbitrary: init)
	case (Cons r rs)
	from Cons(2) have a: "map_pmf (snd \<circ> snd) (init \<bind> (\<lambda>s. snd (BIT_init, BIT_step) s r \<bind>
	(\<lambda>(a, is'). return_pmf (step (fst s) r a, is'))))
	= return_pmf s0" apply(simp add: BIT_step_def)
	by (simp_all add: map_pmf_def bind_assoc_pmf BIT_step_def bind_return_pmf )
	then have b: "\<forall>z\<in>set_pmf (init \<bind> (\<lambda>s. snd (BIT_init, BIT_step) s r \<bind>
	(\<lambda>(a, is'). return_pmf (step (fst s) r a, is')))). snd (snd z) = s0"
	by (metis (mono_tags, lifting) comp_eq_dest_lhs map_pmf_eq_return_pmf_iff)

	show ?case
	apply(simp only: config'_rand.simps)
	proof (rule Cons(1), goal_cases)
	case 2
	have "map_pmf (fst \<circ> snd)
	(init \<bind>
	(\<lambda>s. snd (BIT_init, BIT_step) s r \<bind>
	(\<lambda>(a, is').
	return_pmf (step (fst s) r a, is')))) = map_pmf (flip (index s0 r)) (bv (length s0))"
	using b
	apply(simp add: BIT_step_def Cons(3)[symmetric] bind_return_pmf map_pmf_def bind_assoc_pmf )
	apply(rule bind_pmf_cong)
	apply(simp)
	by(simp add: inv_flip_bv)
	also have "\<dots> = bv (length s0)" using inv_flip_bv by auto
	finally show ?case .
	qed (fact)
	qed simp


	lemma config_n_bv_2: "map_pmf (snd \<circ> snd) (config_rand (BIT_init, BIT_step) s0 qs) = return_pmf s0
	\<and> map_pmf (fst \<circ> snd) (config_rand (BIT_init, BIT_step) s0 qs) = bv (length s0)"
	apply(rule config'_n_bv)
	by(simp_all add: bind_return_pmf map_pmf_def bind_assoc_pmf bind_return_pmf' BIT_init_def)



	lemma config_n_bv: "map_pmf (fst \<circ> snd) (config_rand (BIT_init, BIT_step) s0 qs) = bv (length s0)"
	using config_n_bv_2 by auto

	lemma config_n_fst_init_length: "\<forall>(_,(x,_)) \<in> set_pmf (config_rand (BIT_init, BIT_step) s0 qs). length x = length s0"
	proof
	fix x::"('a list \<times> (bool list \<times> 'a list))"
	assume ass:"x \<in> set_pmf (config_rand (BIT_init, BIT_step) s0 qs)"
	let ?a="fst (snd x)"
	from ass have "(fst x,(?a,snd (snd x))) \<in> set_pmf (config_rand (BIT_init, BIT_step) s0 qs)" by auto
	with ass have "?a \<in> (fst \<circ> snd) ` set_pmf (config_rand (BIT_init, BIT_step) s0 qs)" by force
	then have "?a \<in> set_pmf (map_pmf (fst \<circ> snd) (config_rand (BIT_init, BIT_step) s0 qs))" by auto
	then have "?a \<in> bv (length s0)" by(simp only: config_n_bv)
	then have "length ?a = length s0" by (auto simp: len_bv_n)
	then show "case x of (uu_, xa, uua_) \<Rightarrow> length xa = length s0" by(simp add: split_def)
	qed

	lemma config_n_fst_init_length2: "\<forall>x \<in> set_pmf (config_rand (BIT_init, BIT_step) s0 qs). length (fst (snd x)) = length s0"
	using config_n_fst_init_length by(simp add: split_def)



	lemma fperms: "finite {x::'a list. length x = length init \<and> distinct x \<and> set x = set init}"
	apply(rule finite_subset[where B="{xs. set xs \<subseteq> set init \<and> length xs \<le> length init}"])
	apply(force) apply(rule finite_lists_length_le) by auto


	lemma finite_config_BIT: assumes [simp]: "distinct init"
	shows "finite (set_pmf (config_rand (BIT_init, BIT_step) init qs))" (is "finite ?D")
	proof -
	have a: "(fst \<circ> snd) ` ?D \<subseteq> {x. length x = length init}" using config_n_fst_init_length2 by force
	have c: "(snd \<circ> snd) ` ?D = {init}"
	proof -
	have "(snd \<circ> snd) ` set_pmf (config_rand (BIT_init, BIT_step) init qs)
	= set_pmf (map_pmf (snd \<circ> snd) (config_rand (BIT_init, BIT_step) init qs))" by(simp)
	also have "\<dots> = {init}" apply(subst config_n_init) by simp
	finally show ?thesis .
	qed
	from a c have d: "snd ` ?D \<subseteq> {x. length x = length init} \<times> {init}" by force
	have b: "fst ` ?D \<subseteq> {x. length x = length init \<and> distinct x \<and> set x = set init}"
	using config_rand by fastforce

	from b d have "?D \<subseteq> {x. length x = length init \<and> distinct x \<and> set x = set init} \<times> ({x. length x = length init} \<times> {init})"
	by auto
	then show ?thesis
	apply (rule finite_subset)
	apply(rule finite_cartesian_product)
	apply(rule fperms)
	apply(rule finite_cartesian_product)
	apply (rule bitstrings_finite)
	by(simp)
	qed


	subsection "BIT is $1.75$-competitive (a combinatorial proof)"







	subsubsection "Definition of the Locale and Helper Functions"
	locale BIT_Off =
	fixes acts :: "answer list"
	fixes qs :: "'a list"
	fixes init :: "'a list"
	assumes dist_init[simp]: "distinct init"
	assumes len_acts: "length acts = length qs"
	begin


	lemma setinit: "(index init) ` set init = {0..<length init}"
	using dist_init
	proof(induct init)
	case (Cons a as)
	with Cons have iH: "index as ` set as = {0..<length as}" by auto
	from Cons have 1:"(set as \<inter> {x. (a \<noteq> x)}) = set as" by fastforce
	have 2: "(\<lambda>a. Suc (index as a)) ` set as =
	(\<lambda>a. Suc a) ` ((index as) ` set as )" by auto
	show ?case
	apply(simp add: 1 2 iH) by auto
	qed simp

	definition free_A :: "nat list" where (* free exchanges of A *)
	"free_A = map fst acts"

	definition paid_A' :: "nat list list" where (* paid exchanges of A' *)
	"paid_A' = map snd acts"

	definition paid_A :: "nat list list" where (* paid exchanges of A *)
	"paid_A = map (filter (\<lambda>x. Suc x < length init)) paid_A'"

	lemma len_paid_A[simp]: "length paid_A = length qs"
	unfolding paid_A_def paid_A'_def using len_acts by auto
	lemma len_paid_A'[simp]: "length paid_A' = length qs"
	unfolding paid_A'_def using len_acts by auto


	lemma paidAnm_inbound: "n < length paid_A \<Longrightarrow> m < length(paid_A!n) \<Longrightarrow> (Suc ((paid_A!n)!(length (paid_A ! n) - Suc m))) < length init"
	proof -
	assume "n < length paid_A"
	then have "n < length paid_A'" by auto
	then have a: "(paid_A!n)
	= filter (\<lambda>x. Suc x < length init) (paid_A' ! n)" unfolding paid_A_def by auto

	let ?filtered="(filter (\<lambda>x. Suc x < length init) (paid_A' ! n))"
	assume mtt: "m < length (paid_A!n)"
	with a have "(length (paid_A ! n) - Suc m) < length ?filtered" by auto
	with nth_mem have b: "Suc(?filtered ! (length (paid_A ! n) - Suc m)) < length init" by force

	show "Suc (paid_A ! n ! (length (paid_A ! n) - Suc m)) < length init" using a b by auto
	qed

	fun s_A' :: "nat \<Rightarrow> 'a list" where
	"s_A' 0 = init" \|
	"s_A'(Suc n) = step (s_A' n) (qs!n) (free_A!n, paid_A'!n)"

	lemma length_s_A'[simp]: "length(s_A' n) = length init"
	by (induction n) simp_all

	lemma dist_s_A'[simp]: "distinct(s_A' n)"
	by(induction n) (simp_all add: step_def)

	lemma set_s_A'[simp]: "set(s_A' n) = set init"
	by(induction n) (simp_all add: step_def)

	fun s_A :: "nat \<Rightarrow> 'a list" where
	"s_A 0 = init" \|
	"s_A(Suc n) = step (s_A n) (qs!n) (free_A!n, paid_A!n)"

	lemma length_s_A[simp]: "length(s_A n) = length init"
	by (induction n) simp_all

	lemma dist_s_A[simp]: "distinct(s_A n)"
	by(induction n) (simp_all add: step_def)

	lemma set_s_A[simp]: "set(s_A n) = set init"
	by(induction n) (simp_all add: step_def)

	lemma cost_paidAA': "n < length paid_A' \<Longrightarrow> length (paid_A!n) \<le> length (paid_A'!n)"
	unfolding paid_A_def by simp

	lemma swaps_filtered: "swaps (filter (\<lambda>x. Suc x < length xs) ys) xs = swaps (ys) xs"
	apply (induct ys) by auto

	lemma sAsA': "n < length paid_A' \<Longrightarrow> s_A' n = s_A n"
	proof (induct n)
	case (Suc m)
	have " s_A' (Suc m)
	= mtf2 (free_A!m) (qs!m) (swaps (paid_A'!m) (s_A' m))" by (simp add: step_def)
	also from Suc(2) have "\<dots> = mtf2 (free_A!m) (qs!m) (swaps (paid_A!m) (s_A' m))"
	unfolding paid_A_def
	by (simp only: nth_map swaps_filtered[where xs="s_A' m", simplified])
	also have "\<dots> = mtf2 (free_A!m) (qs!m) (swaps (paid_A!m) (s_A m))" using Suc by auto
	also have "\<dots> = s_A (Suc m)" by (simp add: step_def)
	finally show ?case .
	qed simp


	lemma sAsA'': "n < length qs \<Longrightarrow> s_A n = s_A' n"
	using sAsA' by auto


	definition t_BIT :: "nat \<Rightarrow> real" where (* BIT's cost in nth step *)
	"t_BIT n = T_on_rand_n BIT init qs n"

	definition T_BIT :: "nat \<Rightarrow> real" where (* BIT's cost in first n steps *)
	"T_BIT n = (\<Sum>i<n. t_BIT i)"


	definition c_A :: "nat \<Rightarrow> int" where
	"c_A n = index (swaps (paid_A!n) (s_A n)) (qs!n) + 1"

	definition f_A :: "nat \<Rightarrow> int" where
	"f_A n = min (free_A!n) (index (swaps (paid_A!n) (s_A n)) (qs!n))"

	definition p_A :: "nat \<Rightarrow> int" where
	"p_A n = size(paid_A!n)"

	definition t_A :: "nat \<Rightarrow> int" where
	"t_A n = c_A n + p_A n"



	definition c_A' :: "nat \<Rightarrow> int" where
	"c_A' n = index (swaps (paid_A'!n) (s_A' n)) (qs!n) + 1"

	definition p_A' :: "nat \<Rightarrow> int" where
	"p_A' n = size(paid_A'!n)"
	definition t_A' :: "nat \<Rightarrow> int" where
	"t_A' n = c_A' n + p_A' n"

	lemma t_A_A'_leq: "n < length paid_A' \<Longrightarrow> t_A n \<le> t_A' n"
	unfolding t_A_def t_A'_def c_A_def c_A'_def p_A_def p_A'_def
	apply(simp add: sAsA')
	unfolding paid_A_def
	by (simp add: swaps_filtered[where xs="(s_A n)", simplified])

	definition T_A' :: "nat \<Rightarrow> int" where
	"T_A' n = (\<Sum>i<n. t_A' i)"

	definition T_A :: "nat \<Rightarrow> int" where
	"T_A n = (\<Sum>i<n. t_A i)"

	lemma T_A_A'_leq: "n \<le> length paid_A' \<Longrightarrow> T_A n \<le> T_A' n"
	unfolding T_A'_def T_A_def apply(rule sum_mono)
	by (simp add: t_A_A'_leq)

	lemma T_A_A'_leq': "n \<le> length qs \<Longrightarrow> T_A n \<le> T_A' n"
	using T_A_A'_leq by auto


	fun s'_A :: "nat \<Rightarrow> nat \<Rightarrow> 'a list" where
	"s'_A n 0 = s_A n"
	\| "(s'_A n (Suc m)) = swap ((paid_A ! n)!(length (paid_A ! n) -(Suc m)) ) (s'_A n m)"

	lemma set_s'_A[simp]: "set (s'_A n m) = set init"
	apply(induct m) by(auto)

	lemma len_s'_A[simp]: "length (s'_A n m) = length init"
	apply(induct m) by(auto)

	lemma distperm_s'_A[simp]: "dist_perm (s'_A n m) init"
	apply(induct m) by auto

	lemma s'A_m_le: "m \<le> (length (paid_A ! n)) \<Longrightarrow> swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m"
	apply(induct m)
	apply(simp)
	proof -
	fix m
	assume iH: "(m \<le> length (paid_A ! n) \<Longrightarrow> swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m)"
	assume Suc: "Suc m \<le> length (paid_A ! n)"
	then have "m \<le> length (paid_A ! n)" by auto
	with iH have x: "swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n) = s'_A n m" by auto

	from Suc have mlen: "(length (paid_A ! n) - Suc m) < length (paid_A ! n)" by auto

	let ?l="length (paid_A ! n) - Suc m"
	let ?Sucl="length (paid_A ! n) - m"
	have Sucl: "Suc ?l = ?Sucl" using Suc by auto

	from mlen have yu: "((paid_A ! n)! ?l ) # (drop (Suc ?l) (paid_A ! n))
	= (drop ?l (paid_A ! n))"
	by (rule Cons_nth_drop_Suc)

	from Suc have "s'_A n (Suc m)
	= swap ((paid_A ! n)!(length (paid_A ! n) - (Suc m)) ) (s'_A n m)" by auto
	also have "\<dots> = swap ((paid_A ! n)!(length (paid_A ! n) - (Suc m)) )
	(swaps (drop (length (paid_A ! n) - m) (paid_A ! n)) (s_A n))"
	by(simp only: x)
	also have "\<dots> = (swaps (((paid_A ! n)!(length (paid_A ! n) - (Suc m)) ) # (drop (length (paid_A ! n) - m) (paid_A ! n))) (s_A n))"
	by auto
	also have "\<dots> = (swaps (((paid_A ! n)! ?l ) # (drop (Suc ?l) (paid_A ! n))) (s_A n))"
	using Sucl by auto
	also from mlen have "\<dots> = (swaps ((drop ?l (paid_A ! n))) (s_A n))"
	by (simp only: yu)
	finally have " s'_A n (Suc m) = swaps (drop (length (paid_A ! n) - Suc m) (paid_A ! n)) (s_A n)" .
	then show " swaps (drop (length (paid_A ! n) - Suc m) (paid_A ! n)) (s_A n) = s'_A n (Suc m)" by auto
	qed

	lemma s'A_m: "swaps (paid_A ! n) (s_A n) = s'_A n (length (paid_A ! n))"
	using s'A_m_le[of "(length (paid_A ! n))" "n", simplified] by auto


	definition gebub :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
	"gebub n m = index init ((s'_A n m)!(Suc ((paid_A!n)!(length (paid_A ! n) - Suc m))))"

	lemma gebub_inBound: assumes 1: " n < length paid_A " and 2: "m < length (paid_A ! n)"
	shows "gebub n m < length init"
	proof -
	have "Suc (paid_A ! n ! (length (paid_A ! n) - Suc m)) < length (s'_A n m)" using paidAnm_inbound[OF 1 2] by auto
	then have "s'_A n m ! Suc (paid_A ! n ! (length (paid_A ! n) - Suc m)) \<in> set (s'_A n m)" by (rule nth_mem)
	then show ?thesis
	unfolding gebub_def using setinit by auto
	qed


	subsubsection "The Potential Function"

	fun phi :: "nat \<Rightarrow>'a list\<times> (bool list \<times> 'a list) \<Rightarrow> real" ("\<phi>") where
	"phi n (c,(b,_)) = (\<Sum>(x,y)\<in>(Inv c (s_A n)). (if b!(index init y) then 2 else 1))"

	lemma phi': "phi n z = (\<Sum>(x,y)\<in>(Inv (fst z) (s_A n)). (if (fst (snd z))!(index init y) then 2 else 1))"
	proof -
	have "phi n z = phi n (fst z, (fst(snd z),snd(snd z)))" by (metis prod.collapse)
	also have "\<dots> = (\<Sum>(x,y)\<in>(Inv (fst z) (s_A n)). (if (fst (snd z))!(index init y) then 2 else 1))" by(simp del: prod.collapse)
	finally show ?thesis .
	qed

	lemma Inv_empty2: "length d = 0 \<Longrightarrow> Inv c d = {}"
	unfolding Inv_def before_in_def by(auto)

	corollary Inv_empty3: "length init = 0 \<Longrightarrow> Inv c (s_A n) = {}"
	apply(rule Inv_empty2) by (metis length_s_A)

	lemma phi_empty2: "length init = 0 \<Longrightarrow> phi n (c,(b,i)) = 0"
	apply(simp only: phi.simps Inv_empty3) by auto

	lemma phi_nonzero: "phi n (c,(b,i)) \<ge> 0"
	by (simp add: sum_nonneg split_def)

	(* definition of the potential function! *)
	definition Phi :: "nat \<Rightarrow> real" ("\<Phi>") where
	"Phi n = E( map_pmf (\<phi> n) (config'' BIT qs init n))"

	definition PhiPlus :: "nat \<Rightarrow> real" ("\<Phi>\<^sup>+") where
	"PhiPlus n = (let
	nextconfig = bind_pmf (config'' BIT qs init n)
	(\<lambda>(s,is). bind_pmf (BIT_step (s,is) (qs!n)) (\<lambda>(a,nis). return_pmf (step s (qs!n) a,nis)) )
	in
	E( map_pmf (phi (Suc n)) nextconfig) )"

	lemma PhiPlus_is_Phi_Suc: "n<length qs \<Longrightarrow> PhiPlus n = Phi (Suc n)"
	unfolding PhiPlus_def Phi_def
	apply (simp add: bind_return_pmf map_pmf_def bind_assoc_pmf split_def take_Suc_conv_app_nth )
	apply(simp add: config'_rand_snoc)
	by(simp add: bind_assoc_pmf split_def bind_return_pmf)

	lemma phi0: "Phi 0 = 0" unfolding Phi_def
	by (simp add: bind_return_pmf map_pmf_def bind_assoc_pmf BIT_init_def)

	lemma phi_pos: "Phi n \<ge> 0"
	unfolding Phi_def
	apply(rule E_nonneg_fun)
	using phi_nonzero by auto

	subsubsection "Helper lemmas"
	lemma swap_subs: "dist_perm X Y \<Longrightarrow> Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}"
	proof -
	assume "dist_perm X Y"
	note aj = Inv_swap[OF this, of z]
	show "Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}"
	proof cases
	assume c1: "Suc z < length X"
	show "Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}"
	proof cases
	assume "Y ! z < Y ! Suc z in X"
	with c1 have "Inv X (swap z Y) = Inv X Y \<union> {(Y ! z, Y ! Suc z)}" using aj by auto
	then show "Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}" by auto
	next
	assume "~ Y ! z < Y ! Suc z in X"
	with c1 have "Inv X (swap z Y) = Inv X Y - {(Y ! Suc z, Y ! z)}" using aj by auto
	then show "Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}" by auto
	qed
	next
	assume "~ (Suc z < length X)"
	then have "Inv X (swap z Y) = Inv X Y" using aj by auto
	then show "Inv X (swap z Y) \<subseteq> Inv X Y \<union> {(Y ! z, Y ! Suc z)}" by auto
	qed
	qed


	subsubsection "InvOf"

	term "Inv" (* BIT A *)
	abbreviation "InvOf y bits as \<equiv> {(x,y)\|x. x < y in bits \<and> y < x in as}"

	lemma "InvOf y xs ys = {(x,y)\|x. (x,y)\<in>Inv xs ys}"
	unfolding Inv_def by auto

	lemma "InvOf y xs ys \<subseteq> Inv xs ys" unfolding Inv_def by auto

	lemma numberofIsbeschr: assumes
	distxsys: "dist_perm xs ys" and
	yinxs: "y \<in> set xs"
	shows "index xs y \<le> index ys y + card (InvOf y xs ys)"
	(is "?iBit \<le> ?iA + card ?I")
	proof -
	from assms have distinctxs: "distinct xs"
	and distinctys: "distinct ys"
	and yinys: "y \<in> set ys" by auto

	let ?A="fst ` ?I"
	have aha: "card ?A = card ?I" apply(rule card_image)
	unfolding inj_on_def by(auto)

	have "?A \<subseteq> (before y xs)" by(auto)
	have "?A \<subseteq> (after y ys)" by auto



	have "finite (before y ys)" by auto

	have bef: "(before y xs) - ?A \<subseteq> before y ys" apply(auto)
	proof -
	fix x
	assume a: "x < y in xs"
	assume " x \<notin> fst ` {(x, y) \|x. x < y in xs \<and> y < x in ys}"
	then have "~ (x < y in xs \<and> y < x in ys)" by force
	with a have d: "~ y < x in ys" by auto
	from a have "x \<in> set xs" by (rule before_in_setD1)
	with distxsys have b: "x \<in> set ys" by auto
	from a have "y \<in> set xs" by (rule before_in_setD2)
	with distxsys have c: "y \<in> set ys" by auto
	from a have e: "~ x = y" unfolding before_in_def by auto
	have "(\<not> y < x in ys) = (x < y in ys \<or> y = x)" apply(rule not_before_in)
	using b c by auto
	with d e show "x < y in ys" by auto
	qed

	have "(index xs y) - card (InvOf y xs ys) = card (before y xs) - card ?A"
	by(simp only: aha card_before[OF distinctxs yinxs])
	also have "\<dots> = card ((before y xs) - ?A)"
	apply(rule card_Diff_subset[symmetric]) by auto
	also have "\<dots> \<le> card (before y ys)"
	apply(rule card_mono)
	apply(simp)
	apply(rule bef)
	done
	also have "\<dots> = (index ys y)" by(simp only: card_before[OF distinctys yinys])
	finally have "index xs y - card ?I \<le> index ys y" .
	then show "index xs y \<le> index ys y + card ?I" by auto
	qed


	lemma "length init = 0 \<Longrightarrow> length xs = length init \<Longrightarrow> t xs q (mf, sws) = 1 + length sws"
	unfolding t_def by(auto)


	lemma integr_index: "integrable (measure_pmf (config'' (BIT_init, BIT_step) qs init n))
	(\<lambda>(s, is). real (Suc (index s (qs ! n))))"
	apply(rule measure_pmf.integrable_const_bound[where B="Suc (length init)"])
	apply(simp add: split_def) apply (metis (mono_tags) index_le_size AE_measure_pmf_iff config_rand_length)
	by (auto)


	subsubsection "Upper Bound on the Cost of BIT"


	lemma t_BIT_ub2: "(qs!n) \<notin> set init \<Longrightarrow> t_BIT n \<le> Suc(size init)"
	apply(simp add: t_BIT_def t_def BIT_step_def)
	apply(simp add: bind_return_pmf)
	proof (goal_cases)
	case 1
	note qs=this
	let ?D = "(config'' (BIT_init, BIT_step) qs init n)"

	have absch: "(\<forall>x\<in> set_pmf ?D. ((\<lambda>(s,is). real (Suc (index s (qs ! n)))) x) \<le> ((\<lambda>(is,s). Suc (length init)) x))"
	proof (rule ballI, goal_cases)
	case (1 x)
	from 1 config_rand_length have f1: "length (fst x) = length init" by fastforce
	from 1 config_rand_set have 2: "set (fst x) = set init" by fastforce

	from qs 2 have "(qs!n) \<notin> set (fst x)" by auto
	then show ?case using f1 by (simp add: split_def)
	qed

	have "integrable (measure_pmf (config'' (BIT_init, BIT_step) qs init n))
	(\<lambda>(s, is). Suc (length init))" by(simp)

	have "E(bind_pmf ?D (\<lambda>(s, is). return_pmf (real (Suc (index s (qs ! n))))))
	= E(map_pmf (\<lambda>(s, is). real (Suc (index s (qs ! n)))) ?D)"
	by(simp add: split_def map_pmf_def)
	also have "\<dots> \<le> E(map_pmf (\<lambda>(s, is). Suc (length init)) ?D)"
	apply (rule E_mono3)
	apply(fact integr_index)
	apply(simp)
	using absch by auto
	also have "\<dots> = Suc (length init)"
	by(simp add: split_def)
	finally show ?case by(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf split_def)
	qed

	lemma t_BIT_ub: "(qs!n) \<in> set init \<Longrightarrow> t_BIT n \<le> size init"
	apply(simp add: t_BIT_def t_def BIT_step_def)
	apply(simp add: bind_return_pmf)
	proof (goal_cases)
	case 1
	note qs=this
	let ?D = "(config'' (BIT_init, BIT_step) qs init n)"

	have absch: "(\<forall>x\<in> set_pmf ?D. ((\<lambda>(s, is). real (Suc (index s (qs ! n)))) x) \<le> ((\<lambda>(s, is). length init) x))"
	proof (rule ballI, goal_cases)
	case (1 x)
	from 1 config_rand_length have f1: "length (fst x) = length init" by fastforce
	from 1 config_rand_set have 2: "set (fst x) = set init" by fastforce

	from qs 2 have "(qs!n) \<in> set (fst x)" by auto
	then have "(index (fst x) (qs ! n)) < length init" apply(rule index_less) using f1 by auto
	then show ?case by (simp add: split_def)
	qed

	have "E(bind_pmf ?D (\<lambda>(s, is). return_pmf (real (Suc (index s (qs ! n))))))
	= E(map_pmf (\<lambda>(s, is). real (Suc (index s (qs ! n)))) ?D)"
	by(simp add: split_def map_pmf_def)
	also have "\<dots> \<le> E(map_pmf (\<lambda>(s, is). length init) ?D)"
	apply(rule E_mono3)
	apply(fact integr_index)
	apply(simp)
	using absch by auto
	also have "\<dots> = length init"
	by(simp add: split_def)
	finally show ?case by(simp add: map_pmf_def bind_assoc_pmf bind_return_pmf split_def)
	qed

	lemma T_BIT_ub: "\<forall>i<n. qs!i \<in> set init \<Longrightarrow> T_BIT n \<le> n * size init"
	proof(induction n)
	case 0 show ?case by(simp add: T_BIT_def)
	next
	case (Suc n) thus ?case
	using t_BIT_ub[where n="n"] by (simp add: T_BIT_def)
	qed



	subsubsection "Main Lemma"



	lemma myub: "n < length qs \<Longrightarrow> t_BIT n + Phi(n + 1) - Phi n \<le> (7 / 4) * t_A n - 3/4"
	proof -
	assume nqs: "n < length qs"
	have "t_BIT n + Phi (n+1) - Phi n \<le> (7 / 4) * t_A n - 3/4"
	proof (cases "length init > 0")
	case False
	show ?thesis
	proof -
	from False have qsn: "(qs!n) \<notin> set init" by auto
	from False have l0: "length init = 0" by auto
	then have "length (swaps (paid_A ! n) (s_A n)) = 0" using length_s_A by auto

	with l0 have 4: "t_A n = 1 + length (paid_A ! n)" unfolding t_A_def c_A_def p_A_def by(simp)

	have 1: "t_BIT n \<le> 1" using t_BIT_ub2[OF qsn] l0 by auto

	{ fix m
	have "phi m = (\<lambda>(b,(a,i)). phi m (b,(a,i)))" by auto
	also have "\<dots> = (\<lambda>(b,(a,i)). 0)" by(simp only: phi_empty2[OF l0])
	finally have "phi m= (\<lambda>(b,(a,i)). 0)".
	} note phinull=this

	have 2: "PhiPlus n = 0" unfolding PhiPlus_def apply(simp) apply(simp only: phinull)
	by (auto simp: split_def)
	have 3:"Phi n = 0" unfolding Phi_def apply(simp only: phinull)
	by (auto simp: split_def)

	have "t_A n \<ge> 1 \<Longrightarrow> 1 \<le> 7 / 4 * (t_A n) - 3 / 4" by(simp)
	with 4 have 5: "1 \<le> 7 / 4 * (t_A n) - 3 / 4" by auto

	from 1 2 3 have "t_BIT n + PhiPlus n - Phi n \<le> 1" by auto
	also from 5 have "\<dots> \<le> 7 / 4 * (t_A n) - 3 / 4" by auto

	finally show ?thesis using PhiPlus_is_Phi_Suc nqs by auto
	qed
	next
	case True
	let ?l = "length init"
	from True obtain l' where lSuc: "?l = Suc l'" by (metis Suc_pred)

	have 31: "n < length paid_A" using nqs by auto


	define q where "q = qs!n"
	define D where [simp]: "D = (config'' (BIT_init, BIT_step) qs init n)"
	define cost where [simp]: "cost = (\<lambda>(s, is).(t s q (if (fst is) ! (index (snd is) q) then 0 else length s, [])))"
	define \<Phi>\<^sub>2 where [simp]: "\<Phi>\<^sub>2 = (\<lambda>(s, is). ((phi (Suc n)) (step s q (if (fst is) ! (index (snd is) q) then 0 else length s, []),(flip (index (snd is) q) (fst is), snd is))))"
	define \<Phi>\<^sub>0 where [simp]: "\<Phi>\<^sub>0 = phi n"

	have inEreinziehn: "t_BIT n + Phi (n+1) - Phi n = E (map_pmf (\<lambda>x. (cost x) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x)) D)"
	proof -
	have "bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a,nis). return_pmf (real(t s (q) a))))
	= bind_pmf D
	(\<lambda>(s, is). return_pmf (t s q (if (fst is) ! (index (snd is) q) then 0 else length s, [])))"
	unfolding BIT_step_def apply (auto simp: bind_return_pmf split_def)
	by (metis prod.collapse)
	also have "\<dots> = map_pmf cost D"
	by (auto simp: map_pmf_def split_def)
	finally have rightform1: "bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a,nis). return_pmf (real(t s (q) a))))
	= map_pmf cost D" .

	have rightform2: "map_pmf (phi (Suc n)) (bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a, nis). return_pmf (step s (q) a, nis))))
	= map_pmf \<Phi>\<^sub>2 D" apply(simp add: bind_return_pmf bind_assoc_pmf map_pmf_def split_def BIT_step_def)
	by (metis prod.collapse)
	have "t_BIT n + Phi (n+1) - Phi n =
	t_BIT n + PhiPlus n - Phi n" using PhiPlus_is_Phi_Suc nqs by auto
	also have "\<dots> =
	T_on_rand_n BIT init qs n
	+ E (map_pmf (phi (Suc n)) (bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a, nis). return_pmf (step s (q) a, nis)))))
	- E (map_pmf (phi n) D)
	" unfolding PhiPlus_def Phi_def t_BIT_def q_def by auto
	also have "\<dots> =
	E (bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a,nis). return_pmf (t s (q) a))))
	+ E (map_pmf (phi (Suc n)) (bind_pmf D
	(\<lambda>(s, is). bind_pmf (BIT_step (s, is) (q)) (\<lambda>(a, nis). return_pmf (step s (q) a, nis)))))
	- E (map_pmf \<Phi>\<^sub>0 D)" by (auto simp: q_def split_def)
	also have "\<dots> = E (map_pmf cost D)
	+ E (map_pmf \<Phi>\<^sub>2 D)
	- E (map_pmf \<Phi>\<^sub>0 D)" using rightform1 rightform2 split_def by auto
	also have "\<dots> = E (map_pmf (\<lambda>x. (cost x) + (\<Phi>\<^sub>2 x)) D) - E (map_pmf (\<lambda>x. (\<Phi>\<^sub>0 x)) D)"
	unfolding D_def using E_linear_plus2[OF finite_config_BIT[OF dist_init]] by auto
	also have "\<dots> = E (map_pmf (\<lambda>x. (cost x) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x)) D)"
	unfolding D_def by(simp only: E_linear_diff2[OF finite_config_BIT[OF dist_init]] split_def)
	finally show "t_BIT n + Phi (n+1) - Phi n
	= E (map_pmf (\<lambda>x. (cost x) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x)) D)" by auto
	qed

	define xs where [simp]: "xs = s_A n"
	define xs' where [simp]: "xs' = swaps (paid_A!n) xs"
	define xs'' where [simp]: "xs'' = mtf2 (free_A!n) (q) xs'"
	define k where [simp]: "k = index xs' q" (* position of the requested element in A's list *)
	define k' where [simp]: "k' = max 0 (k-free_A!n)" (* position where A moves the requested element to *)

	have [simp]: "length xs = length init" by auto

	have dp_xs_init[simp]: "dist_perm xs init" by auto


	text "The Transformation"

	have ub_cost: "\<forall>x\<in>set_pmf D. (real (cost x)) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x) \<le> k + 1 +
	(if (q) \<in> set init
	then (if (fst (snd x))!(index init q) then k-k'
	else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))
	else 0)
	+ (\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2 else 1))"
	proof (rule, goal_cases)
	case (1 x)
	note xinD=1
	then have [simp]: "snd (snd x) = init" using D_def config_n_init3 by fast

	define b where "b = fst (snd x)"
	define ys where "ys = fst x"
	define aBIT where [simp]: "aBIT = (if b ! (index (snd (snd x)) q) then 0 else length ys, ([]::nat list))"
	define ys' where "ys' = step ys (q) aBIT"
	define b' where "b' = flip (index init q) b"
	define \<Phi>\<^sub>1 where "\<Phi>\<^sub>1 = (\<lambda>z:: 'a list\<times> (bool list \<times> 'a list) . (\<Sum>(x,y)\<in>(Inv ys xs'). (if fst (snd z)!(index init y) then 2::real else 1)))"

	have xs''_step: "xs'' = step xs (q) (free_A!n,paid_A!n)"
	unfolding xs'_def xs''_def xs_def step_def free_A_def paid_A_def
	by(auto simp: split_def)

	have gis2: "(\<Phi>\<^sub>2 (ys,(b,init))) = (\<Sum>(x,y)\<in>(Inv ys' xs''). (if b'!(index init y) then 2 else 1))"
	apply(simp only: split_def)
	apply(simp only: xs''_step)
	apply(simp only: \<Phi>\<^sub>2_def phi.simps)
	unfolding b'_def b_def ys'_def aBIT_def q_def
	unfolding s_A.simps apply(simp only: split_def) by auto
	then have gis: "\<Phi>\<^sub>2 x = (\<Sum>(x,y)\<in>(Inv ys' xs''). (if b'!(index init y) then 2 else 1))"
	unfolding ys_def b_def by (auto simp: split_def)

	have his2: "(\<Phi>\<^sub>0 (ys,(b,init))) = (\<Sum>(x,y)\<in>(Inv ys xs). (if b!(index init y) then 2 else 1))"
	apply(simp only: split_def)
	apply(simp only: \<Phi>\<^sub>0_def phi.simps) by(simp add: split_def)
	then have his: "(\<Phi>\<^sub>0 x) = (\<Sum>(x,y)\<in>(Inv ys xs). (if b!(index init y) then 2 else 1))"
	by(auto simp: ys_def b_def split_def phi')

	have dis: "\<Phi>\<^sub>1 x = (\<Sum>(x,y)\<in>(Inv ys xs'). (if b!(index init y) then 2 else 1))"
	unfolding \<Phi>\<^sub>1_def b_def by auto

	have "ys' = mtf2 (fst aBIT) (q) ys" by (simp add: step_def ys'_def)

	from config_rand_distinct[of BIT] config_rand_set[of BIT] xinD
	have dp_ys_init[simp]: "dist_perm ys init" unfolding D_def ys_def by force
	have dp_ys'_init[simp]: "dist_perm ys' init" unfolding ys'_def step_def by (auto)
	then have lenys'[simp]: "length ys' = length init" by (metis distinct_card)
	have dp_xs'_init[simp]: "dist_perm xs' init" by auto
	have gra: "dist_perm ys xs'" by auto

	have leninitb[simp]: "length b = length init" using b_def config_n_fst_init_length2 xinD[unfolded] by auto
	have leninitys[simp]: "length ys = length init" using dp_ys_init by (metis distinct_card)

	{fix m
	have "dist_perm ys (s'_A n m)" using dp_ys_init by auto
	} note dist=this

	text "Upper bound of the inversions created by paid exchanges of A"

	(* ============================================

	first we adress the paid exchanges

	paid cost of A: p_A *)


	let ?paidUB="(\<Sum>i<(length (paid_A!n)). (if b!(gebub n i) then 2::real else 1))"

	have paid_ub: "\<Phi>\<^sub>1 x \<le> \<Phi>\<^sub>0 x + ?paidUB"
	proof -

	have a: "length (paid_A ! n) \<le> length (paid_A ! n)" by auto
	have b: "xs' = (s'_A n (length (paid_A ! n)))" using s'A_m by auto

	{
	fix m
	have "m\<le>length (paid_A!n) \<Longrightarrow> (\<Sum>(x,y)\<in>(Inv ys (s'_A n m)). (if b!(index init y) then 2::real else 1)) \<le> (\<Sum>(x,y)\<in>(Inv ys xs). (if b!(index init y) then 2 else 1))
	+ (\<Sum>i<m. (if b!(gebub n i) then 2 else 1))"
	proof (induct m)
	case (Suc m)
	then have m_bd2: "m \<le> length (paid_A ! n)"
	and m_bd: "m < length (paid_A ! n)" by auto
	note yeah = Suc(1)[OF m_bd2]

	let ?revm="(length (paid_A ! n) - Suc m)"
	note ah=Inv_swap[of "ys" "(s'_A n m)" "(paid_A ! n ! ?revm)", OF dist]
	have "(\<Sum>(xa, y)\<in>Inv ys (s'_A n (Suc m)). if b ! (index init y) then 2::real else 1)
	= (\<Sum>(xa, y)\<in>Inv ys (swap (paid_A ! n ! ?revm) (s'_A n m)). if b ! (index init y) then 2 else 1)" using s'_A.simps(2) by auto
	also
	have "\<dots> = (\<Sum>(xa, y)\<in>(if Suc (paid_A ! n ! ?revm) < length ys
	then if s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys
	then Inv ys (s'_A n m) \<union> {(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))}
	else Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
	else Inv ys (s'_A n m)). if b ! (index init y) then 2::real else 1)" by (simp only: ah)
	also
	have "\<dots> \<le> (\<Sum>(xa, y)\<in>Inv ys (s'_A n m). if b ! (index init y) then 2::real else 1)
	+ (if (b) ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" (is "?A \<le> ?B")
	proof(cases "Suc (paid_A ! n ! ?revm) < length ys")
	case False (* FIXME! can't occur! because it has already been filtered out! see:
	then have "False" using paidAnm_inbound apply(auto) using m_bd nqs by blast *)
	then have "?A = (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> \<le> (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1) +
	(if b ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" by auto
	finally show "?A \<le> ?B" .
	next
	case True
	then have "?A = (\<Sum>(xa, y)\<in>(if s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys
	then Inv ys (s'_A n m) \<union> {(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))}
	else Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
	). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> \<le> ?B" (is "?A' \<le> ?B")
	proof (cases "s'_A n m ! (paid_A ! n ! ?revm) < s'_A n m ! Suc (paid_A ! n ! ?revm) in ys")
	case True
	let ?neurein="(s'_A n m ! (paid_A ! n ! ?revm), s'_A n m ! Suc (paid_A ! n ! ?revm))"
	from True have "?A' = (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m) \<union> {?neurein}
	). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> = (\<Sum>(xa, y)\<in>insert ?neurein (Inv ys (s'_A n m)
	). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> \<le> (if b ! (index init (snd ?neurein)) then 2 else 1)
	+ (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)"
	proof (cases "?neurein \<in> Inv ys (s'_A n m)")
	case True
	then have "insert ?neurein (Inv ys (s'_A n m)) = (Inv ys (s'_A n m))" by auto
	then have "(\<Sum>(xa, y)\<in>insert ?neurein (Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)
	= (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> \<le> (if b ! (index init (snd ?neurein)) then 2::real else 1)
	+ (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by auto
	finally show ?thesis .
	next
	case False
	have "(\<Sum>(xa, y)\<in>insert ?neurein (Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)
	= (\<Sum>y\<in>insert ?neurein (Inv ys (s'_A n m)). (\<lambda>i. if b ! (index init (snd i)) then 2 else 1) y)" by(auto simp: split_def)
	also have "\<dots> = (\<lambda>i. if b ! (index init (snd i)) then 2 else 1) ?neurein
	+ (\<Sum>y\<in>(Inv ys (s'_A n m)) - {?neurein}. (\<lambda>i. if b ! (index init (snd i)) then 2 else 1) y)"
	apply(rule sum.insert_remove) by(auto)
	also have "\<dots> = (if b ! (index init (snd ?neurein)) then 2 else 1)
	+ (\<Sum>y\<in>(Inv ys (s'_A n m)). (\<lambda>i. if b ! (index init (snd i)) then 2::real else 1) y)" using False by auto
	also have "\<dots> \<le> (if b ! (index init (snd ?neurein)) then 2 else 1)
	+ (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" by(simp only: split_def)
	finally show ?thesis .
	qed
	also have "\<dots> = (\<Sum>(xa, y)\<in>Inv ys (s'_A n m). if b ! (index init y) then 2 else 1) +
	(if b ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2 else 1)" by auto
	finally show ?thesis .
	next
	case False
	then have "?A' = (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m) - {(s'_A n m ! Suc (paid_A ! n ! ?revm), s'_A n m ! (paid_A ! n ! ?revm))}
	). if b ! (index init y) then 2 else 1)" by auto
	also have "\<dots> \<le> (\<Sum>(xa, y)\<in>(Inv ys (s'_A n m)). if b ! (index init y) then 2 else 1)" (is "(\<Sum>(xa, y)\<in>?X-{?x}. ?g y) \<le> (\<Sum>(xa, y)\<in>?X. ?g y) ")
	proof (cases "?x \<in> ?X")
	case True
	have "(\<Sum>(xa, y)\<in>?X-{?x}. ?g y) \<le> (%(xa,y). ?g y) ?x + (\<Sum>(xa, y)\<in>?X-{?x}. ?g y)"
	by simp
	also have "\<dots> = (\<Sum>(xa, y)\<in>?X. ?g y)"
	apply(rule sum.remove[symmetric])
	apply simp apply(fact) done
	finally show ?thesis .
	qed simp
	also have "\<dots> \<le> ?B" by auto
	finally show ?thesis .
	qed
	finally show "?A \<le> ?B" .
	qed

	also have "\<dots>
	\<le> (\<Sum>(xa, y)\<in>Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (\<Sum>i<m. if b ! gebub n i then 2::real else 1)
	+ (if (b) ! (index init (s'_A n m ! Suc (paid_A ! n ! ?revm))) then 2::real else 1)" using yeah by simp
	also have "\<dots> = (\<Sum>(xa, y)\<in>Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (\<Sum>i<m. if b ! gebub n i then 2 else 1)
	+ (if (b) ! gebub n m then 2 else 1)" unfolding gebub_def by simp
	also have "\<dots> = (\<Sum>(xa, y)\<in>Inv ys (s_A n). if b ! (index init y) then 2::real else 1) + (\<Sum>i<(Suc m). if b ! gebub n i then 2 else 1)"
	by auto
	finally show ?case by simp
	qed (simp add: split_def)
	} note x = this[OF a]

	show ?thesis
	unfolding \<Phi>\<^sub>1_def his apply(simp only: b) using x b_def by auto
	qed

	text "Upper bound for the costs of BIT"

	define inI where [simp]: "inI = InvOf (q) ys xs'"
	define I where [simp]: "I = card(InvOf (q) ys xs')"
	(* ys is BITs list, xs' is A's list after paid exchanges *)

	have ub_cost_BIT: "(cost x) \<le> k + 1 + I"
	proof (cases "(q) \<in> set init")
	case False (* cannot occur! ! ! OBSOLETE *)
	from False have 4: "I = 0" by(auto simp: before_in_def)
	have "(cost x) = 1 + index ys (q)" by (auto simp: ys_def t_def split_def)
	also have "\<dots> = 1 + length init" using False by auto
	also have "\<dots> = 1 + k" using False by auto
	finally show ?thesis using 4 by auto
	next
	case True
	then have gra2: "(q) \<in> set ys" using dp_ys_init by auto
	have "(cost x) = 1 + index ys (q)" by(auto simp: ys_def t_def split_def)
	also have "\<dots> \<le> k + 1 + I" using numberofIsbeschr[OF gra gra2] by auto
	finally show"(cost x) \<le> k + 1 + I" .
	qed

	text "Upper bound for inversions generated by free exchanges"

	(* ================================================ *)
	(* ================================================ *)

	(* second part: FREE EXCHANGES *)

	define ub_free
	where "ub_free =
	(if (q \<in> set init)
	then (if b!(index init q) then k-k' else (\<Sum>j<k'. (if (b)!(index init (xs'!j)) then 2::real else 1) ))
	else 0)"
	let ?ub2 = "- I + ub_free"
	have free_ub: "(\<Sum>(x,y)\<in>(Inv ys' xs''). (if b' !(index init y) then 2 else 1 ) )
	- (\<Sum>(x,y)\<in>(Inv ys xs'). (if b!(index init y) then 2 else 1) ) \<le> ?ub2"
	proof (cases "(q) \<in> set init")
	case False

	from False have 1: "ys' = ys" unfolding ys'_def step_def mtf2_def by(simp)
	from False have 2: "xs' = xs''" unfolding xs''_def mtf2_def by(simp)
	from False have "(index init q) \<ge> length b" using setinit by auto
	then have 3: "b' = b" unfolding b'_def using flip_out_of_bounds by auto

	from False have 4: "I = 0" unfolding I_def before_in_def by(auto)

	note ubnn=False

	have nn: "k-k'\<ge>0" unfolding k_def k'_def by auto

	from 1 2 3 4 have "(\<Sum>(x,y)\<in>(Inv ys' xs''). (if b'!(index init y) then 2::real else 1))
	- (\<Sum>(x,y)\<in>(Inv ys xs'). (if b!(index init y) then 2 else 1)) = -I" by auto
	with ubnn show ?thesis unfolding ub_free_def by auto
	next
	case True
	note queryinlist=this


	then have gra2: "q \<in> set ys" using dp_ys_init by auto

	have k_inbounds: "k < length init"
	using index_less_size_conv queryinlist
	by (simp)
	{
	fix y e
	fix X::"bool list"
	assume rd: "e < length X"
	have "y < length X \<Longrightarrow> (if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
	= (if e=y then (if X ! y then -1 else 1) else 0)"
	proof cases
	assume "y < length X" and ey: "e=y"
	then have "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
	= (if X ! y then 1::real else 2) - (if X ! y then 2 else 1)" using flip_itself by auto
	also have "\<dots> = (if X ! y then -1::real else 1)" by auto
	finally
	show "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
	= (if e=y then (if X ! y then -1 else 1) else 0)" using ey by auto
	next
	assume len: "y < length X" and eny: "e\<noteq>y"
	then have "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
	= (if X ! y then 2::real else 1) - (if X ! y then 2 else 1)" using flip_other[OF len rd eny] by auto
	also have "\<dots> = 0" by auto
	finally
	show "(if flip e X ! y then 2::real else 1) - (if X ! y then 2 else 1)
	= (if e=y then (if X ! y then -1 else 1) else 0)" using eny by auto
	qed
	} note flipstyle=this

	from queryinlist setinit have qsfst: "(index init q) < length b" by simp

	have fA: "finite (Inv ys' xs'')" by auto
	have fB: "finite (Inv ys xs')" by auto


	define \<Delta> where [simp]: "\<Delta> = (\<Sum>(x,y)\<in>(Inv ys' xs''). (if b'!(index init y) then 2::real else 1))
	- (\<Sum>(x,y)\<in>(Inv ys xs'). (if b!(index init y) then 2 else 1))"
	define C where [simp]: "C = (\<Sum>(x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys xs'). (if b'!(index init y) then 2::real else 1)
	- (if b!(index init y) then 2 else 1))"
	define A where [simp]: "A = (\<Sum>(x,y)\<in>(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))"
	define B where [simp]: "B = (\<Sum>(x,y)\<in>(Inv ys xs')-(Inv ys' xs''). (if b!(index init y) then 2::real else 1))"
	have teilen: "\<Delta> = C + A - B" (* C A B *)
	unfolding \<Delta>_def A_def B_def C_def
	using sum_my[OF fA fB] by (auto simp: split_def)
	then have "\<Delta> = A - B + C" by auto
	then have teilen2: "\<Phi>\<^sub>2 x - \<Phi>\<^sub>1 x = A - B + C" unfolding \<Delta>_def using dis gis by auto


	have setys': "(index init) ` (set ys') = {0..<length ys'}"
	proof -
	have "(index init) ` (set ys') = (index init) ` (set init)" by auto
	also have "\<dots> = {0..<length init}" using setinit by auto
	also have "\<dots> = {0..<length ys'}" using lenys' by auto
	finally show ?thesis .
	qed

	have BC_absch: "C - B \<le> -I"

	proof (cases "b!(index init q)") (* case distinction on whether the bit of the requested element is set *)
	case True
	then have samesame: "ys' = ys" unfolding ys'_def step_def by auto
	then have puh: "(Inv ys' xs') = (Inv ys xs')" by auto

	{
	fix \<alpha> \<beta>
	assume "(\<alpha>,\<beta>)\<in>(Inv ys' xs'') \<inter> (Inv ys' xs')"
	then have "(\<alpha>,\<beta>)\<in>(Inv ys' xs'')" by auto
	then have "(\<alpha>< \<beta> in ys')" unfolding Inv_def by auto
	then have 1: "\<beta> \<in> set ys'" by (simp only: before_in_setD2)
	then have "index init \<beta> < length ys'" using setys' by auto
	then have "index init \<beta> < length init" using lenys' by auto
	then have puzzel: "index init \<beta> < length b" using leninitb by auto


	have betainit: "\<beta> \<in> set init" using 1 by auto
	have aha: "(q=\<beta>) = (index init q = index init \<beta>)"
	using betainit by simp

	have "(if b'!(index init \<beta>) then 2::real else 1) - (if b!(index init \<beta>) then 2 else 1)
	= (if (index init q) = (index init \<beta>) then if b !(index init \<beta>) then - 1 else 1 else 0)"
	unfolding b'_def apply(rule flipstyle) by(fact)+
	also have "\<dots> = (if (index init q) = (index init \<beta>) then if b ! (index init q) then - 1 else 1 else 0)" by auto
	also have "\<dots> = (if q = \<beta> then - 1 else 0)" using aha True by auto
	finally have "(if b'!(index init \<beta>) then 2::real else 1) - (if b!(index init \<beta>) then 2 else 1)
	= (if (q) = \<beta> then -1::real else 0)" by auto
	}
	then have grreeeaa: "\<forall>x\<in>(Inv ys' xs'') \<inter> (Inv ys' xs').
	(\<lambda>x. (if b'! (index init (snd x)) then 2::real else 1) - (if b! (index init (snd x)) then 2 else 1)) x
	= (\<lambda>x. (if (q) = snd x then -1::real else 0)) x" by force

	let ?fin="(Inv ys' xs'') \<inter> (Inv ys' xs')"

	have ttt: "{(x,y). (x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys' xs')
	\<and> y = (q)} \<union> {(x,y). (x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys' xs')
	\<and> y \<noteq> (q)} = (Inv ys' xs'') \<inter> (Inv ys' xs')" (is "?split1 \<union> ?split2 = ?easy") by auto
	have interem: "?split1 \<inter> ?split2 = {}" by auto
	have split1subs: "?split1 \<subseteq> ?fin" by auto
	have split2subs: "?split2 \<subseteq> ?fin" by auto
	have fs1: "finite ?split1" apply(rule finite_subset[where B="?fin"])
	apply(rule split1subs) by(auto)
	have fs2: "finite ?split2" apply(rule finite_subset[where B="?fin"])
	apply(rule split2subs) by(auto)

	have "k - k' \<le> (free_A!n)" by auto

	have g: "InvOf (q) ys' xs'' \<supseteq> InvOf (q) ys' xs'"
	using True apply(auto) apply(rule mtf2_mono[of "swaps (paid_A ! n) (s_A n)"])
	by (auto simp: queryinlist)
	have h: "?split1 = (InvOf (q) ys' xs'') \<inter> (InvOf (q) ys' xs')"
	unfolding Inv_def by auto
	also from g have "\<dots> = InvOf (q) ys' xs'" by force
	also from samesame have "\<dots> = InvOf (q) ys xs'" by simp
	finally have "?split1 = inI" unfolding inI_def .
	then have cardsp1isI: "card ?split1 = I" by auto

	{
	fix a b
	assume "(a,b)\<in>?split1"
	then have "b = (q)" by auto
	then have "(if (q) = b then (-1::real) else 0) = (-1::real)" by auto
	}
	then have split1easy: "\<forall>x\<in>?split1.
	(\<lambda>x. (if (q) = snd x then (-1::real) else 0)) x = (\<lambda>x. (-1::real)) x" by force
	{
	fix a b
	assume "(a,b)\<in>?split2"
	then have "~ b = (q)" by auto
	then have "(if (q) = b then (-1::real) else 0) = 0" by auto
	}
	then have split2easy: "\<forall>x\<in>?split2.
	(\<lambda>x. (if (q) = snd x then (-1::real) else 0)) x = (\<lambda>x. 0::real) x" by force


	have E0: "C =
	(\<Sum>(x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys xs').
	(if b'!(index init y) then 2::real else 1) - (if b!(index init y) then 2 else 1))" by auto
	also from puh have E1: "... =
	(\<Sum>(x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys' xs').
	(if b'!(index init y) then 2::real else 1) - (if b!(index init y) then 2 else 1))" by auto
	also have E2: "\<dots> = (\<Sum>(x,y)\<in>?easy.
	(if (q) = y then (-1::real) else 0))" using sum_my2[OF grreeeaa] by (auto simp: split_def)
	also have E3: "\<dots> = (\<Sum>(x,y)\<in>?split1 \<union> ?split2.
	(if (q) = y then (-1::real) else 0))" by(simp only: ttt)
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if (q) = y then (-1::real) else 0))
	+ (\<Sum>(x,y)\<in>?split2. (if (q) = y then (-1::real) else 0))
	- (\<Sum>(x,y)\<in>?split1 \<inter> ?split2. (if (q) = y then (-1::real) else 0))"
	by(rule sum_Un[OF fs1 fs2])
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if (q) = y then (-1::real) else 0))
	+ (\<Sum>(x,y)\<in>?split2. (if (q) = y then (-1::real) else 0))"
	apply(simp only: interem) by auto
	also have E4: "\<dots> = (\<Sum>(x,y)\<in>?split1. (-1::real) )
	+ (\<Sum>(x,y)\<in>?split2. 0)"
	using sum_my2[OF split1easy]sum_my2[OF split2easy] by(simp only: split_def)
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (-1::real) )" by auto
	also have E5: "\<dots> = - card ?split1 " by auto
	also have E6: "\<dots> = - I " using cardsp1isI by auto
	finally have abschC: "C = -I".

	have abschB: "B \<ge> (0::real)" unfolding B_def apply(rule sum_nonneg) by auto

	from abschB abschC show "C - B \<le> -I" by simp

	next
	case False
	from leninitys False have ya: "ys' = mtf2 (length ys) q ys"
	unfolding step_def ys'_def by(auto)
	have "index ys' q = 0"
	unfolding ya apply(rule mtf2_moves_to_front)
	using gra2 by simp_all
	then have nixbefore: "before q ys' = {}" unfolding before_in_def by auto

	{
	fix \<alpha> \<beta>
	assume "(\<alpha>,\<beta>)\<in>(Inv ys' xs'') \<inter> (Inv ys xs')"
	then have "(\<alpha>,\<beta>)\<in>(Inv ys' xs'')" by auto
	then have "(\<alpha>< \<beta> in ys')" unfolding Inv_def by auto
	then have 1: "\<beta> \<in> set ys'" by (simp only: before_in_setD2)
	then have "(index init \<beta>) < length ys'" using setys' by auto
	then have "(index init \<beta>) < length init" using lenys' by auto
	then have puzzel: "(index init \<beta>) < length b" using leninitb by auto


	have betainit: "\<beta> \<in> set init" using 1 by auto
	have aha: "(q=\<beta>) = (index init q = index init \<beta>)"
	using betainit by simp

	have "(if b'!(index init \<beta>) then 2::real else 1) - (if b!(index init \<beta>) then 2 else 1)
	= (if (index init q) = (index init \<beta>) then if b ! (index init \<beta>) then - 1 else 1 else 0)"
	unfolding b'_def apply(rule flipstyle) by(fact)+
	also have "\<dots> = (if (index init q) = (index init \<beta>) then if b ! (index init q) then - 1 else 1 else 0)" by auto
	also have "\<dots> = (if (q) = \<beta> then 1 else 0)" using False aha by auto
	finally have "(if b'!(index init \<beta>) then 2::real else 1) - (if b!(index init \<beta>) then 2 else 1)
	= (if (q) = \<beta> then 1::real else 0)" by auto
	}
	then have grreeeaa2: "\<forall>x\<in>(Inv ys' xs'') \<inter> (Inv ys xs').
	(\<lambda>x. (if b'! (index init (snd x)) then 2::real else 1) - (if b! (index init (snd x)) then 2 else 1)) x
	= (\<lambda>x. (if (q) = snd x then 1::real else 0)) x" by force

	let ?fin="(Inv ys' xs'') \<inter> (Inv ys xs')"

	have ttt: "{(x,y). (x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys xs')
	\<and> y = (q)} \<union> {(x,y). (x,y)\<in>(Inv ys' xs'') \<inter> (Inv ys xs')
	\<and> y \<noteq> (q)} = (Inv ys' xs'') \<inter> (Inv ys xs')" (is "?split1 \<union> ?split2 = ?easy") by auto
	have interem: "?split1 \<inter> ?split2 = {}" by auto
	have split1subs: "?split1 \<subseteq> ?fin" by auto
	have split2subs: "?split2 \<subseteq> ?fin" by auto
	have fs1: "finite ?split1" apply(rule finite_subset[where B="?fin"])
	apply(rule split1subs) by(auto)
	have fs2: "finite ?split2" apply(rule finite_subset[where B="?fin"])
	apply(rule split2subs) by(auto)

	have split1easy : "\<forall>x\<in>?split1.
	(\<lambda>x. (if (q) = snd x then (1::real) else 0)) x = (\<lambda>x. (1::real)) x" by force

	have split2easy : "\<forall>x\<in>?split2.
	(\<lambda>x. (if (q) = snd x then (1::real) else 0)) x = (\<lambda>x. (0::real)) x" by force



	from nixbefore have InvOfempty: "InvOf q ys' xs'' = {}" unfolding Inv_def by auto

	have "?split1 = InvOf q ys' xs'' \<inter> InvOf q ys xs'"
	unfolding Inv_def by auto
	also from InvOfempty have "\<dots> = {}" by auto
	finally have split1empty: "?split1 = {}" .

	have "C = (\<Sum>(x,y)\<in>?easy.
	(if (q) = y then (1::real) else 0))" unfolding C_def by(simp only: split_def sum_my2[OF grreeeaa2])
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1 \<union> ?split2.
	(if (q) = y then (1::real) else 0))" by(simp only: ttt)
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if (q) = y then (1::real) else 0))
	+ (\<Sum>(x,y)\<in>?split2. (if (q) = y then (1::real) else 0))
	- (\<Sum>(x,y)\<in>?split1 \<inter> ?split2. (if (q) = y then (1::real) else 0))"
	by(rule sum_Un[OF fs1 fs2])
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if (q) = y then (1::real) else 0))
	+ (\<Sum>(x,y)\<in>?split2. (if (q) = y then (1::real) else 0))"
	apply(simp only: interem) by auto
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (1::real) )
	+ (\<Sum>(x,y)\<in>?split2. 0)" using sum_my2[OF split1easy] sum_my2[OF split2easy] by (simp only: split_def)
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (1::real) )" by auto
	also have "\<dots> = card ?split1" by auto
	also have "\<dots> = (0::real)" apply(simp only: split1empty) by auto
	finally have abschC: "C = (0::real)" .

	(* approx for B *)

	have ttt2: "{(x,y). (x,y)\<in>(Inv ys xs') - (Inv ys' xs'')
	\<and> y = (q)} \<union> {(x,y). (x,y)\<in>(Inv ys xs') - (Inv ys' xs'')
	\<and> y \<noteq> (q)} = (Inv ys xs') - (Inv ys' xs'')" (is "?split1 \<union> ?split2 = ?easy2") by auto
	have interem: "?split1 \<inter> ?split2 = {}" by auto
	have split1subs: "?split1 \<subseteq> ?easy2" by auto
	have split2subs: "?split2 \<subseteq> ?easy2" by auto
	have fs1: "finite ?split1" apply(rule finite_subset[where B="?easy2"])
	apply(rule split1subs) by(auto)
	have fs2: "finite ?split2" apply(rule finite_subset[where B="?easy2"])
	apply(rule split2subs) by(auto)

	from False have split1easy2: "\<forall>x\<in>?split1.
	(\<lambda>x. (if b! (index init (snd x)) then 2::real else 1)) x = (\<lambda>x. (1::real)) x" by force

	have "?split1 = (InvOf q ys xs') - (InvOf q ys' xs'')"
	unfolding Inv_def by auto
	also have "\<dots> = inI" unfolding InvOfempty by auto
	finally have splI: "?split1 = inI" .

	have abschaway: "(\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1)) \<ge> 0"
	apply(rule sum_nonneg) by auto

	have "B = (\<Sum>(x,y)\<in>?split1 \<union> ?split2.
	(if b!(index init y) then 2::real else 1) )" unfolding B_def by(simp only: ttt2)
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if b!(index init y) then 2::real else 1))
	+ (\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1))
	- (\<Sum>(x,y)\<in>?split1 \<inter> ?split2. (if b!(index init y) then 2::real else 1))"
	by(rule sum_Un[OF fs1 fs2])
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. (if b!(index init y) then 2::real else 1))
	+ (\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1))"
	apply(simp only: interem) by auto
	also have "\<dots> = (\<Sum>(x,y)\<in>?split1. 1)
	+ (\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1))"
	using sum_my2[OF split1easy2] by (simp only: split_def)
	also have "\<dots> = card ?split1
	+ (\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1))" by auto
	also have "\<dots> = I
	+ (\<Sum>(x,y)\<in>?split2. (if b!(index init y) then 2::real else 1))" using splI by auto
	also have "\<dots> \<ge> I" using abschaway by auto
	finally have abschB: "B \<ge> I" .

	from abschB abschC show "C - B \<le> -I" by auto
	qed


	(* ==========================================
	central! calculations for A
	========================================== *)

	have A_absch: "A
	\<le> (if b!(index init q) then k-k' else (\<Sum>j<k'. (if b!(index init (xs'!j)) then 2::real else 1)))"
	proof (cases "b!(index init q)") (* case distinction on whether the requested element's bit is set *)
	case False

	from leninitys False have ya: "ys' = mtf2 (length ys) q ys" (* BIT moves q to front *)
	unfolding step_def ys'_def by(auto)
	have "index ys' q = 0" unfolding ya apply(rule mtf2_moves_to_front)
	using gra2 by(simp_all)
	then have nixbefore: "before q ys' = {}" unfolding before_in_def by auto

	have "A = (\<Sum>(x,y)\<in>(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto


	have "index (mtf2 (free_A ! n) (q) (swaps (paid_A ! n) (s_A n))) (q)
	= (index (swaps (paid_A ! n) (s_A n)) (q) - free_A ! n)"
	apply(rule mtf2_q_after) using queryinlist by auto
	then have whatisk': "k' = index xs'' q" by auto


	have ss: "set ys' = set ys" by auto
	have ss2: "set xs' = set xs''" by auto

	have di: "distinct init" by auto
	have dys: "distinct ys" by auto

	have "(Inv ys' xs'')-(Inv ys xs')
	= {(x,y). x < y in ys' \<and> y < x in xs'' \<and> (~x < y in ys \<or> ~ y < x in xs')}"
	unfolding Inv_def by auto
	also have "\<dots> =
	{(x,y). y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> (~x < y in ys \<or> ~ y < x in xs') }"
	using nixbefore by blast
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> (~x < y in ys \<or> ~ y < x in xs') }"
	unfolding before_in_def by auto
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> ~x < y in ys }
	\<union> {(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> ~ y < x in xs' }"
	by force
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> y < x in ys }
	\<union> {(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> ~ y < x in xs' }"
	using before_in_setD1[where xs="ys'"] before_in_setD2[where xs="ys'"] not_before_in ss by metis
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> y < x in ys }
	\<union> {(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> x < y in xs' }" (is "?S1 \<union> ?S2 = ?S1 \<union> ?S2'")
	proof -
	have "?S2 = ?S2'" apply(safe)
	proof (goal_cases)
	case (2 a b)
	from 2(5) have "~ b < a in xs'" by auto
	with 2(6) show "False" by auto
	next
	case (1 a b)
	from 1(4) have "a \<in> set xs'" "b \<in> set xs'"
	using before_in_setD1[where xs="xs''"]
	before_in_setD2[where xs="xs''"] ss2 by auto
	with not_before_in 1(5) have "(a < b in xs' \<or> a = b)" by metis
	with 1(1) show "a < b in xs'" by auto
	qed
	then show ?thesis by auto
	qed
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> y < x in ys }
	\<union> {(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> ~ x < y in xs'' \<and> x < y in xs' }" (is "?S1 \<union> ?S2 = ?S1 \<union> ?S2'")
	proof -
	have "?S2 = ?S2'" apply(safe)
	proof (goal_cases)
	case (1 a b)
	from 1(4) have "~ a < b in xs''" by auto
	with 1(6) show "False" by auto
	next
	case (2 a b)
	from 2(5) have "a \<in> set xs''" "b \<in> set xs''"
	using before_in_setD1[where xs="xs'"]
	before_in_setD2[where xs="xs'"] ss2 by auto
	with not_before_in 2(4) have "(b < a in xs'' \<or> a = b)" by metis
	with 2(1) show "b < a in xs''" by auto
	qed
	then show ?thesis by auto
	qed
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> y < x in ys }
	\<union> {}"
	using x_stays_before_y_if_y_not_moved_to_front[where xs="xs'" and q="q"]
	before_in_setD1[where xs="xs'"] before_in_setD2[where xs="xs'"] by (auto simp: queryinlist)
	also have "\<dots> =
	{(x,y). x\<noteq>y \<and> x=q \<and> y\<noteq>q \<and> x < y in ys' \<and> y < x in xs'' \<and> y < x in ys }"
	apply(simp only: ya) using swapped_by_mtf2[where xs="ys" and q="q" and n="(length ys)"] dys
	before_in_setD1[where xs="ys"] before_in_setD2[where xs="ys"] by (auto simp: queryinlist)
	also have "\<dots> \<subseteq>
	{(x,y). x=q \<and> y\<noteq>q \<and> q < y in ys' \<and> y < q in xs''}" by force
	also have "\<dots> =
	{(x,y). x=q \<and> y\<noteq>q \<and> q < y in ys' \<and> y < q in xs'' \<and> y \<in> set xs''}"
	using before_in_setD1 by metis
	also have "\<dots> =
	{(x,y). x=q \<and> y\<noteq>q \<and> q < y in ys' \<and> index xs'' y < index xs'' q \<and> q \<in> set xs'' \<and> y \<in> set xs''}" unfolding before_in_def by auto
	also have "\<dots> =
	{(x,y). x=q \<and> y\<noteq>q \<and> q < y in ys' \<and> index xs'' y < index xs' q - (free_A ! n) \<and> q \<in> set xs'' \<and> y \<in> set xs''}"
	using mtf2_q_after[where A="xs'" and q="q"] by force
	also have "\<dots> \<subseteq>
	{(x,y). x=q \<and> y\<noteq>q \<and> index xs' y < index xs' q - (free_A ! n) \<and> y \<in> set xs''}"
	using mtf2_backwards_effect4'[where xs="xs'" and q="q" and n="(free_A ! n)", simplified ]
	by auto
	also have "\<dots> \<subseteq>
	{(x,y). x=q \<and> y\<noteq>q \<and> index xs' y < k'}"
	using mtf2_q_after[where A="xs'" and q="q"] by auto

	finally have subsa: "(Inv ys' xs'')-(Inv ys xs')
	\<subseteq> {(x,y). x=q \<and> y\<noteq>q \<and> index xs' y < k'}" .

	have k'xs': "k' < length xs''" unfolding whatisk'
	apply(rule index_less) by (auto simp: queryinlist)
	then have k'xs': "k' < length xs'" by auto

	have "{(x,y). x=q \<and> index xs' y < k'}
	\<subseteq> {(x,y). x=q \<and> index xs' y < length xs'}" using k'xs' by auto
	also have "\<dots> = {(x,y). x=q \<and> y \<in> set xs'}"
	using index_less_size_conv by fast
	finally have "{(x,y). x=q \<and> index xs' y < k'} \<subseteq> {(x,y). x=q \<and> y \<in> set xs'}" .
	then have finia2: "finite {(x,y). x=q \<and> index xs' y < k'}"
	apply(rule finite_subset) by(simp)

	have lulae: "{(a,b). a=q \<and> index xs' b < k'}
	= {(q,b)\|b. index xs' b < k'}" by auto

	have k'b: "k' < length b" using whatisk' by (auto simp: queryinlist)
	have asdasd: "{(\<alpha>,\<beta>). \<alpha>=q \<and> \<beta>\<noteq>q \<and> index xs' \<beta> < k'}
	= {(\<alpha>,\<beta>). \<alpha>=q \<and> \<beta>\<noteq>q \<and> index xs' \<beta> < k' \<and> (index init \<beta>) < length b }"
	proof (auto, goal_cases)
	case (1 b)
	from 1(2) have "index xs' b < index xs' (q)" by auto
	also have "\<dots> < length xs'" by (auto simp: queryinlist)
	finally have "b \<in> set xs'" using index_less_size_conv by metis
	then show ?case using setinit by auto
	qed

	{ fix \<beta>
	have "\<beta>\<noteq>q \<Longrightarrow> (index init \<beta>)\<noteq>(index init q)"
	using queryinlist by auto
	} note ij=this
	have subsa2: "{(\<alpha>,\<beta>). \<alpha>=q \<and> \<beta>\<noteq>q \<and> index xs' \<beta> < k'} \<subseteq>
	{(\<alpha>,\<beta>). \<alpha>=q \<and> index xs' \<beta> < k'}" by auto
	then have finia: "finite {(x,y). x=q \<and> y\<noteq>q \<and> index xs' y < k'}"
	apply(rule finite_subset) using finia2 by auto

	have E0: "A = (\<Sum>(x,y)\<in>(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto
	also have E1: "\<dots> \<le> (\<Sum>(x,y)\<in>{(a,b). a=q \<and> b\<noteq>q \<and> index xs' b < k'}. (if b'!(index init y) then 2::real else 1))"
	unfolding A_def apply(rule sum_mono2[OF finia subsa]) by auto
	also have "\<dots> = (\<Sum>(x,y)\<in>{(\<alpha>,\<beta>). \<alpha>=q \<and> \<beta>\<noteq>q \<and> index xs' \<beta> < k'
	\<and> (index init \<beta>) < length b }. (if b'!(index init y) then 2::real else 1))"
	using asdasd by auto
	also have "\<dots> = (\<Sum>(x,y)\<in>{(\<alpha>,\<beta>). \<alpha>=q \<and> \<beta>\<noteq>q \<and> index xs' \<beta> < k'
	\<and> (index init \<beta>) < length b }. (if b!(index init y) then 2::real else 1))"
	proof (rule sum.cong, goal_cases)
	case (2 z)
	then obtain \<alpha> \<beta> where zab: "z=(\<alpha>, \<beta>)" and "\<alpha> = q" and diff: "\<beta> \<noteq> q" and "index xs' \<beta> < k'" and i: "index init \<beta> < length b" by auto
	from diff ij have "index init \<beta> \<noteq> index init q" by auto
	with flip_other qsfst i have "b' ! index init \<beta> = b ! index init \<beta>" unfolding b'_def by auto
	with zab show ?case by(auto simp add: split_def)
	qed simp
	also have E1a: "\<dots> = (\<Sum>(x,y)\<in>{(a,b). a=q \<and> b\<noteq>q \<and> index xs' b < k'}. (if b!(index init y) then 2::real else 1))"
	using asdasd by auto
	also have "\<dots> \<le> (\<Sum>(x,y)\<in>{(a,b). a=q \<and> index xs' b < k'}. (if b!(index init y) then 2::real else 1))"
	apply(rule sum_mono2[OF finia2 subsa2]) by auto
	also have E2: "\<dots> = (\<Sum>(x,y)\<in>{(q,b)\|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))"
	by (simp only: lulae[symmetric])
	finally have aa: "A \<le> (\<Sum>(x,y)\<in>{(q,b)\|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))" .

	have sameset: "{y. index xs' y < k'} = {xs'!i \| i. i < k'}"
	proof (safe, goal_cases)
	case (1 z)
	show ?case
	proof
	from 1(1) have "index xs' z < index (swaps (paid_A ! n) (s_A n)) (q)"
	by auto
	also have "\<dots> < length xs'" using index_less_size_conv by (auto simp: queryinlist)
	finally have "index xs' z < length xs'" .
	then have zset: "z \<in> set xs'" using index_less_size_conv by metis
	have f1: "xs' ! (index xs' z) = z"
	apply(rule nth_index) using zset by auto
	show "z = xs' ! (index xs' z) \<and> (index xs' z) < k'"
	using f1 1(1) by auto
	qed
	next
	case (2 k i)
	from 2(1) have "i < index (swaps (paid_A ! n) (s_A n)) (q)"
	by auto
	also have "\<dots> < length xs'" using index_less_size_conv by (auto simp: queryinlist)
	finally have iset: "i < length xs'" .
	have "index xs' (xs' ! i) = i" apply(rule index_nth_id)
	using iset by(auto)
	with 2 show ?case by auto
	qed

	have aaa23: "inj_on (\<lambda>i. xs'!i) {i. i < k'}"
	apply(rule inj_on_nth)
	apply(simp)
	apply(simp) proof (safe, goal_cases)
	case (1 i)
	then have "i < index xs' (q)" by auto
	also have "\<dots> < length xs'" using index_less_size_conv by (auto simp: queryinlist)
	also have "\<dots> = length init" by auto
	finally show " i < length init" .
	qed


	have aa3: "{xs'!i \| i. i < k'} = (\<lambda>i. xs'!i) ` {i. i < k'}" by auto
	have aa4: "{(q,b)\|b. index xs' b < k'} = (\<lambda>b. (q,b)) ` {b. index xs' b < k'}" by auto


	have unbelievable: "{i::nat. i < k'} = {..<k'}" by auto

	have aadad: "inj_on (\<lambda>b. (q,b)) {b. index xs' b < k'}"
	unfolding inj_on_def by(simp)

	have "(\<Sum>(x,y)\<in>{(q,b)\|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
	= (\<Sum>y\<in>{y. index xs' y < k'}. (if b!(index init y) then 2::real else 1))"
	proof -
	have "(\<Sum>(x,y)\<in>{(q,b)\|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
	= (\<Sum>(x,y)\<in> (\<lambda>b. (q,b)) ` {b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))" using aa4 by simp
	also have "\<dots> = (\<Sum>z\<in> (\<lambda>b. (q,b)) ` {b. index xs' b < k'}. (if b!(index init (snd z)) then 2::real else 1))" by (simp add: split_def)
	also have "\<dots> = (\<Sum>z\<in>{b. index xs' b < k'}. (if b!(index init (snd ((\<lambda>b. (q,b)) z))) then 2::real else 1))"
	apply(simp only: sum.reindex[OF aadad]) by auto
	also have "\<dots> = (\<Sum>y\<in>{y. index xs' y < k'}. (if b!(index init y) then 2::real else 1))" by auto
	finally show ?thesis .
	qed
	also have "\<dots> = (\<Sum>y\<in>{xs'!i \| i. i < k'}. (if b!(index init y) then 2::real else 1))" using sameset by auto
	also have "\<dots> = (\<Sum>y\<in>(\<lambda>i. xs'!i) ` {i. i < k'}. (if b!(index init y) then 2::real else 1))" using aa3 by simp
	also have "\<dots> = (\<Sum>y\<in>{i::nat. i < k'}. (if b!(index init (xs'!y)) then 2::real else 1))"
	using sum.reindex[OF aaa23] by simp
	also have E3: "\<dots> = (\<Sum>j::nat<k'. (if b!(index init (xs'!j)) then 2::real else 1))"
	using unbelievable by auto
	finally have bb: "(\<Sum>(x,y)\<in>{(q,b)\|b. index xs' b < k'}. (if b!(index init y) then 2::real else 1))
	= (\<Sum>j<k'. (if b!(index init (xs'!j)) then 2::real else 1))" .

	have "A \<le> (\<Sum>j<k'. (if b!(index init (xs'!j)) then 2::real else 1))"
	using aa bb by linarith


	then show "A
	\<le> (if b!(index init q) then k-k' else (\<Sum>j<k'. (if b!(index init (xs'!j)) then 2::real else 1)))"
	using False by auto

	next
	case True

	then have samesame: "ys' = ys" unfolding ys'_def step_def by auto (* BIT does nothing *)

	have setxsbleibt: "set xs'' = set init" by auto

	have whatisk': "k' = index xs'' q" apply(simp)
	apply(rule mtf2_q_after[symmetric]) using queryinlist by auto

	have "(Inv ys' xs'')-(Inv ys xs')
	= {(x,y). x < y in ys \<and> y < x in xs'' \<and> ~ y < x in xs'}"
	unfolding Inv_def using samesame by auto
	also have
	"\<dots> \<subseteq> {(xs'!i,q)\|i. i\<in>{k'..<k}}"
	apply(clarify)
	proof
	fix a b
	assume 1: "a < b in ys"
	and 2: "b < a in xs''"
	and 3: "\<not> b < a in xs'"
	then have anb: "a \<noteq> b"
	using no_before_inI by(force)
	have a: "a \<in> set init"
	and b: "b \<in> set init"
	using before_in_setD1[OF 1] before_in_setD2[OF 1] by auto
	with anb 3 have 3: "a < b in xs'"
	by (simp add: not_before_in)
	note all= anb 1 2 3 a b
	have bq: "b=q" apply(rule swapped_by_mtf2[where xs="xs'" and x=a])
	using queryinlist apply(simp_all add: all)
	using all(4) apply(simp)
	using all(3) apply(simp) done

	note mine=mtf2_backwards_effect3[THEN conjunct1]

	from bq have "q < a in xs''" using 2 by auto
	then have "(k' < index xs'' a \<and> a \<in> set xs'')"
	unfolding before_in_def
	using whatisk' by auto
	then have low : "k' \<le> index xs' a"
	unfolding whatisk'
	unfolding xs''_def
	apply(subst mtf2_q_after)
	apply(simp)
	using queryinlist apply(simp)
	apply(rule mine)
	apply (simp add: queryinlist)
	using bq b apply(simp)
	apply(simp)
	apply(simp del: xs'_def)
	apply (metis "3" a before_in_def bq dp_xs'_init k'_def k_def max_0L mtf2_forward_beforeq nth_index whatisk' xs''_def)
	using a by(simp)(*

	unfolding xs'_def xs_def
	sledgehammer TODO: make this step readable
	by (metis "3" mtf2_q_after a before_in_def bq dp_xs'_init index_less_size_conv mtf2_forward_beforeq nth_index whatisk' xs''_def xs'_def xs_def)
	*)
	from bq have "a < q in xs'" using 3 by auto
	then have up: "(index xs' a < k )"
	unfolding before_in_def by auto

	from a have "a \<in> set xs'" by simp
	then have aa: "a = xs'!index xs' a" using nth_index by simp

	have inset: "index xs' a \<in> {k'..<k}"
	using low up by fastforce

	from bq aa show "(a, b) = (xs' ! index xs' a, q) \<and> index xs' a \<in> {k'..<k}"
	using inset by simp
	qed
	finally have a: "(Inv ys' xs'')-(Inv ys xs') \<subseteq> {(xs'!i,q)\|i. i\<in>{k'..<k}}" (is "?M \<subseteq> ?UB") .

	have card_of_UB: "card {(xs'!i,q)\|i. i\<in>{k'..<k}} = k-k'"
	proof -
	have e: "fst ` ?UB = (%i. xs' ! i) ` {k'..<k}" by force
	have "card ?UB = card (fst ` ?UB)"
	apply(rule card_image[symmetric])
	using inj_on_def by fastforce
	also
	have "\<dots> = card ((%i. xs' ! i) ` {k'..<k})"
	by (simp only: e)
	also
	have "\<dots> = card {k'..<k}"
	apply(rule card_image)
	apply(rule inj_on_nth)
	using k_inbounds by simp_all
	also
	have "\<dots> = k-k'" by auto
	finally
	show ?thesis .
	qed

	have flipit: "flip (index init q) b ! (index init q) = (~ (b) ! (index init q))" apply(rule flip_itself)
	using queryinlist setinit by auto


	have q: "{x\<in>?UB. snd x=q} = ?UB" by auto

	have E0: "A = (\<Sum>(x,y)\<in>(Inv ys' xs'')-(Inv ys xs'). (if b'!(index init y) then 2::real else 1))" by auto
	also have E1: "\<dots> \<le> (\<Sum>(z,y)\<in>?UB. if flip (index init q) (b) ! (index init y) then 2::real else 1)"
	unfolding b'_def apply(rule sum_mono2[OF _ a])
	by(simp_all add: split_def)
	also have "\<dots> = (\<Sum>(z,y)\<in>{x\<in>?UB. snd x=q}. if flip (index init q) (b) ! (index init y) then 2::real else 1)" by(simp only: q)
	also have "\<dots> = (\<Sum>z\<in>{x\<in>?UB. snd x=q}. if flip (index init q) (b) ! (index init (snd z)) then 2::real else 1)" by(simp add: split_def)
	also have "\<dots> = (\<Sum>z\<in>{x\<in>?UB. snd x=q}. if flip (index init q) (b) ! (index init q) then 2::real else 1)" by simp
	also have E2: "\<dots> = (\<Sum>z\<in>?UB. if flip (index init q) (b) ! (index init q) then 2::real else 1)" by(simp only: q)
	also have E3: "\<dots> = (\<Sum>y\<in>?UB. 1)" using flipit True by simp
	also have E4: "\<dots> = k-k'"
	by(simp only: real_of_card[symmetric] card_of_UB)
	finally have result: "A \<le> k-k'" .
	with True show ?thesis by auto
	qed


	show "(\<Sum>(x,y)\<in>(Inv ys' xs''). (if b'!(index init y) then 2::real else 1)) - (\<Sum>(x,y)\<in>(Inv ys xs'). (if b!(index init y) then 2::real else 1)) \<le> ?ub2"
	unfolding ub_free_def teilen[unfolded \<Delta>_def A_def B_def C_def] using BC_absch A_absch using True
	by auto
	qed
	from paid_ub have kl: "\<Phi>\<^sub>1 x \<le> \<Phi>\<^sub>0 x + ?paidUB" by auto
	from free_ub have kl2: "\<Phi>\<^sub>2 x - ?ub2 \<le> \<Phi>\<^sub>1 x" using gis dis by auto


	have iub_free: "I + ?ub2 = ub_free" by auto

	from kl kl2 have "\<Phi>\<^sub>2 x - \<Phi>\<^sub>0 x \<le> ?ub2 + ?paidUB" by auto

	then have "(cost x) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x) \<le> k + 1 + I + ?ub2 + ?paidUB" using ub_cost_BIT by auto

	then show ?case unfolding ub_free_def b_def by auto
	qed

	text "Approximation of the Term for Free exchanges"


	have free_absch: "E(map_pmf (\<lambda>x. (if (q) \<in> set init then (if (fst (snd x))!(index init q) then k-k'
	else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1))) else 0)) D)
	\<le> 3/4 * k" (is "?EA \<le> ?absche")
	proof (cases "(q) \<in> set init")
	case False

	then have "?EA = 0" by auto
	then show ?thesis by auto
	next
	case True


	note queryinlist=this

	have "k-k' \<le> k" by auto
	have "k' \<le> k" by auto


	text "Transformation of the first term"



	have qsn: "{index init q} \<union> {} \<subseteq> {0..<?l}" using setinit queryinlist by auto

	have "{l::bool list. length l = ?l \<and> l!(index init q)}
	= {xs. Ball {(index init q)} ((!) xs) \<and> (\<forall>i\<in>{}. \<not> xs ! i) \<and> length xs = ?l}" by auto
	then have "card {l::bool list. length l = ?l \<and> l!(index init q)}
	= card {xs. Ball {index init q} ((!) xs) \<and> (\<forall>i\<in>{}. \<not> xs ! i) \<and> length xs = length init} " by auto
	also have "\<dots> = 2^(length init - card {index init q} - card {})"
	apply(subst card2[of "{(index init q)}" "{}" "?l"]) using qsn by auto
	finally have lulu: "card {l::bool list. length l = ?l \<and> l!(index init q)} = 2^(?l-1)" by auto

	have "(\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. real(k-k'))
	= (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. k-k')" by auto
	also have "\<dots> = (k-k')*2^(?l-1)" using lulu by simp

	finally have absch1stterm: "(\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. real(k-k'))
	= real((k-k')*2^(?l-1))" .

	text "Transformation of the second term"


	let ?S="{(xs'!j)\|j. j<k'}"

	from queryinlist have "q \<in> set (swaps (paid_A ! n) (s_A n))" by auto
	then have "index (swaps (paid_A ! n) (s_A n)) q < length xs'" by auto
	then have k'inbound: "k' < length xs'" by auto

	{ fix x
	have a: "{..<k'} = {j. j<k'}" by auto
	have b: "?S = ((%j. xs'!j) ` {j. j<k'})" by auto

	have "(\<Sum>j<k'. (\<lambda>t. (if x!(index init t) then 2::real else 1)) (xs'!j))
	= sum ((\<lambda>t. (if x!(index init t) then 2::real else 1)) o (%j. xs'!j)) {..<k'}"
	by(auto)
	also have "\<dots> = sum ((\<lambda>t. (if x!(index init t) then 2::real else 1)) o (%j. xs'!j)) {j. j<k'}"
	by (simp only: a)
	also have "\<dots> = sum (\<lambda>t. (if x!(index init t) then 2::real else 1)) ((%j. xs'!j) ` {j. j<k'})"
	apply(rule sum.reindex[symmetric])
	apply(rule inj_on_nth)
	using k'inbound by(simp_all)
	finally have "(\<Sum>j<k'. (\<lambda>t. (if x!(index init t) then 2::real else 1)) (xs'!j))
	= (\<Sum>j\<in>?S. (\<lambda>t. (if x!(index init t) then 2 else 1)) j)" using b by simp
	} note reindex=this

	have identS: "?S = set (take k' xs')"
	proof -
	have "index (swaps (paid_A ! n) (s_A n)) (q) \<le> length (swaps (paid_A ! n) (s_A n))"
	by (rule index_le_size)
	then have kxs': "k' \<le> length xs'" by simp
	have "?S = (!) xs' ` {0..<k'}" by force
	also have "\<dots> = set (take k' xs')" apply(rule nth_image) by(rule kxs')
	finally show "?S = set (take k' xs')" .
	qed
	have distinctS: "distinct (take k' xs')" using distinct_take identS by simp
	have lengthS: "length (take k' xs') = k'" using length_take k'inbound by simp
	from distinct_card[OF distinctS] lengthS have "card (set (take k' xs')) = k'" by simp
	then have cardS: "card ?S = k'" using identS by simp

	have a: "?S \<subseteq> set xs'" using set_take_subset identS by metis
	then have Ssubso: "(index init) ` ?S \<subseteq> {0..<?l}" using setinit by auto
	from a have s_subst_init: "?S \<subseteq> set init" by auto

	note index_inj_on_S=subset_inj_on[OF inj_on_index[of "init"] s_subst_init]

	have l: "xs'!k = q" unfolding k_def apply(rule nth_index) using queryinlist by(auto)
	have "xs'!k \<notin> set (take k' xs')"
	apply(rule index_take) using l by simp
	then have requestnotinS: "(q) \<notin> ?S" using l identS by simp
	then have indexnotin: "index init q \<notin> (index init) ` ?S"
	using index_inj_on_S s_subst_init by auto


	have lua: "{l. length l = ?l \<and> ~l!(index init q)}
	= {xs. (\<forall>i\<in>{}. xs ! i) \<and> (\<forall>i\<in>{index init q}. \<not> xs ! i) \<and> length xs = ?l}" by auto


	from k'inbound have k'inbound2: "Suc k' \<le> length init" using Suc_le_eq by auto

	(* rewrite from sum over indices of the list
	to sum over elements (thus indices of the bit vector) *)
	have "(\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. (\<Sum>j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))

	= (\<Sum>x\<in>{l. length l = ?l \<and> ~l!(index init q)}. (\<Sum>j\<in>?S. (\<lambda>t. (if x!(index init t) then 2 else 1)) j))"
	using reindex by auto

	(* rewrite to conform the syntax of Expactation2or1 *)
	also
	have "\<dots> = (\<Sum>x\<in>{xs. (\<forall>i\<in>{}. xs ! i) \<and> (\<forall>i\<in>{index init q}. \<not> xs ! i) \<and> length xs = ?l}. (\<Sum>j\<in>?S. (\<lambda>t. (if x!(index init t) then 2 else 1)) j))"
	using lua by auto
	also
	have "\<dots> = (\<Sum>x\<in>{xs. (\<forall>i\<in>{}. xs ! i) \<and> (\<forall>i\<in>{index init q}. \<not> xs ! i) \<and> length xs = ?l}. (\<Sum>j\<in>(index init) ` ?S. (\<lambda>t. (if x!t then 2 else 1)) j))"
	proof -
	{ fix x
	have "(\<Sum>j\<in>?S. (\<lambda>t. (if x!(index init t) then 2 else 1)) j)
	= (\<Sum>j\<in>(index init) ` ?S. (\<lambda>t. (if x!t then 2 else 1)) j)"
	apply(simp only: sum.reindex[OF index_inj_on_S, where g="(%j. if x ! j then 2 else 1)"])
	by(simp)
	} note a=this
	show ?thesis by(simp only: a)
	qed

	(* use Expactation2or1, and solve all the conditions *)
	also
	have "\<dots> = 3 / 2 * real (card ?S) * 2 ^ (?l - card {} - card {q})"
	apply(subst Expactation2or1)
	apply(simp)
	apply(simp)
	apply(simp)
	apply(simp only: card_image index_inj_on_S cardS ) apply(simp add: k'inbound2 del: k'_def)
	- using indexnotin apply(simp add: )
	+ using indexnotin applysimp
	apply(simp)
	using Ssubso queryinlist apply(simp)
	apply(simp only: card_image[OF index_inj_on_S]) by simp
	finally have "(\<Sum>x\<in>{l. length l = ?l \<and> \<not> l ! (index init q)}. \<Sum>j<k'. if x ! (index init (xs' ! j)) then 2 else 1)
	= 3 / 2 * real (card ?S) * 2 ^ (?l - card {} - card {q}) " .

	(* insert the cardinality of S*)
	also
	have "3 / 2 * real (card ?S) * 2 ^ (?l - card {} - card {q}) = (3/2) * (real (k')) * 2 ^ (?l - 1)" using cardS by auto

	finally have absch2ndterm: " (\<Sum>x\<in>{l. length l = ?l \<and> \<not> l ! (index init q)}.
	\<Sum>j<k'. if x !(index init (xs' ! j)) then 2 else 1) =
	3 / 2 * real (k') * 2 ^ (?l - 1) " .


	text "Equational transformations to the goal"

	have cardonebitset: "card {l::bool list. length l = ?l \<and> l!(index init q)} = 2^(?l-1)" using lulu by auto

	have splitie: "{l::bool list. length l = ?l}
	= {l::bool list. length l = ?l \<and> l!(index init q)} \<union> {l::bool list. length l = ?l \<and> ~l!(index init q)}"
	by auto
	have interempty: "{l::bool list. length l = ?l \<and> l!(index init q)} \<inter> {l::bool list. length l = ?l \<and> ~l!(index init q)}
	= {}" by auto
	have fa: "finite {l::bool list. length l = ?l \<and> l!(index init q)}" using bitstrings_finite by auto
	have fb: "finite {l::bool list. length l = ?l \<and> ~l!(index init q)}" using bitstrings_finite by auto

	{ fix f :: "bool list \<Rightarrow> real"
	have "(\<Sum>x\<in>{l::bool list. length l = ?l}. f x)
	= (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)} \<union> {l::bool list. length l = ?l \<and> ~l!(index init q)}. f x)" by(simp only: splitie)
	also have "\<dots>
	= (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. f x)
	+ (\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. f x)
	- (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)} \<inter> {l::bool list. length l = ?l \<and> ~l!(index init q)}. f x)"
	using sum_Un[OF fa fb, of "f"] by simp
	also have "\<dots> = (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. f x)
	+ (\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. f x)" by(simp add: interempty)
	finally have "sum f {l. length l = length init} =
	sum f {l. length l = length init \<and> l ! (index init q)} + sum f {l. length l = length init \<and> \<not> l ! (index init q)}" .
	} note darfstsplitten=this



	have E1: "E(map_pmf (\<lambda>x. (if (fst (snd x))!(index init q) then real(k-k') else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))) D)
	= E(map_pmf (\<lambda>x. (if x!(index init q) then real(k-k') else (\<Sum>j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) (map_pmf (fst \<circ> snd) D))"
	proof -
	have triv: "\<And>x. (fst \<circ> snd) x = fst (snd x)" by simp
	have "E((map_pmf (\<lambda>x. (if (fst (snd x))!(index init q) then real(k-k') else (\<Sum>j<k'. (if (fst (snd x))!index init (xs'!j) then 2::real else 1))))) D)
	= E(map_pmf (\<lambda>x. ((\<lambda>y. (if y!(index init q) then real(k-k') else (\<Sum>j<k'. (if y!index init (xs'!j) then 2::real else 1)))) \<circ> (fst \<circ> snd)) x) D)"
	apply(auto simp: comp_assoc) by (simp only: triv)
	also have "\<dots> = E((map_pmf (\<lambda>x. (if x!(index init q) then real(k-k') else (\<Sum>j<k'. (if x!index init (xs'!j) then 2::real else 1)))) \<circ> (map_pmf (fst \<circ> snd))) D)"
	using map_pmf_compose by metis
	also have "\<dots> = E(map_pmf (\<lambda>x. (if x!(index init q) then real(k-k') else (\<Sum>j<k'. (if x!index init (xs'!j) then 2::real else 1)))) (map_pmf (fst \<circ> snd) D))" by auto
	finally show ?thesis .
	qed
	also
	have E2: "\<dots> = E(map_pmf (\<lambda>x. (if x!(index init q) then real(k-k') else (\<Sum>j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) (bv ?l))"
	using config_n_bv[of init _] by auto
	also
	let ?insf="(\<lambda>x. (if x!(index init q) then k-k' else (\<Sum>j<k'. (if x!(index init (xs'!j)) then 2::real else 1))))"
	have E3: "\<dots> = (\<Sum>x\<in>(set_pmf (bv ?l)). (?insf x) * pmf (bv ?l) x)"
	by (subst E_finite_sum_fun) (auto simp: bv_finite mult_ac)
	also
	have "\<dots> = (\<Sum>x\<in>{l::bool list. length l = ?l}. (?insf x) * pmf (bv ?l) x)"
	using bv_set by auto
	also
	have E4: "\<dots> = (\<Sum>x\<in>{l::bool list. length l = ?l}. (?insf x) * (1/2)^?l)"
	by (simp add: list_pmf)
	also
	have "\<dots> = (\<Sum>x\<in>{l::bool list. length l = ?l}. (?insf x)) * ((1/2)^?l)"
	by(simp only: sum_distrib_right[where r="(1/2)^?l"])
	also
	have E5: "\<dots> = ((1/2)^?l) *(\<Sum>x\<in>{l::bool list. length l = ?l}. (?insf x))"
	by(auto)
	also
	have E6: "\<dots> = ((1/2)^?l) * ( (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. ?insf x)
	+ (\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. ?insf x)
	)" using darfstsplitten by auto
	also
	have E7: "\<dots> = ((1/2)^?l) * ( (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. ((\<lambda>x. real(k-k'))) x)
	+ (\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. ((\<lambda>x. (\<Sum>j<k'. (if x!index init (xs'!j) then 2::real else 1)))) x)
	)" by auto
	finally have "E(map_pmf (\<lambda>x. (if (fst (snd x))!(index init q) then real(k-k') else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))) D)
	= ((1/2)^?l) * ( (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. ((\<lambda>x. real(k-k'))) x)
	+ (\<Sum>x\<in>{l::bool list. length l = ?l \<and> ~l!(index init q)}. ((\<lambda>x. (\<Sum>j<k'. (if x!(index init (xs'!j)) then 2::real else 1)))) x)
	)" .
	also
	have "\<dots> = ((1/2)^?l) * ( (\<Sum>x\<in>{l::bool list. length l = ?l \<and> l!(index init q)}. real(k-k'))
	+ (3/2)(real (k'))2^(?l-1)
	)" by(simp only: absch2ndterm)
	also
	have E8: "\<dots> = ((1/2)^?l) * ( real((k-k')2^(?l-1)) + (3/2)(real (k'))*2^(?l-1))"
	by(simp only: absch1stterm)
	(* from here it is only arithmetic ... *)
	also have "\<dots> = ((1/2)^?l) * ( ( (k-k') + (k')(3/2) ) 2^(?l-1) )" apply(simp only: distrib_right) by simp
	also have "\<dots> = ((1/2)^?l) * 2^(?l-1) * ( (k-k') + (k')*(3/2) )" by simp
	also have "\<dots> = (((1::real)/2)^(Suc l')) * 2^(l') * ( real(k-k') + (k')*(3/2) )"
	using lSuc by auto (* REFACTOR: the only place where I use lSuc , can I avoid it?
	yes, if ?l=0 then k=k'<?l impossible, perhaps I can insert that
	somehow ?
	*)
	also have E9: "\<dots> = (1/2) * ( real(k-k') + (k')*(3/2) )"
	proof -
	have "((1::real)/2)^l' * 2^l' = ((1::real)/2 * 2)^l' " by(rule power_mult_distrib[symmetric])
	also have "... = 1" by auto
	finally have "(((1::real)/2)^(Suc l'))* 2^l'=(1/2)" by auto
	then show ?thesis by auto
	qed
	also have E10: "\<dots> \<le> (1/2) * ( (3/2)(k-k') + (k')(3/2) )" by auto (* and one inequality *)
	also have "\<dots> = (1/2) * ( (3/2)*(k-k'+(k')) )" by auto
	also have "\<dots> = (1/2) * ( (3/2)*(k) )" by auto
	also have E11: "\<dots> = (3/4)*(k )" by auto
	finally show "E(map_pmf (\<lambda>x. (if q \<in> set init then (if (fst (snd x))!(index init q) then real( k-k' ) else (\<Sum>j<k'. (if (fst (snd x))!index init (xs'!j) then 2::real else 1))) else 0 )) D)
	\<le> 3/4 * k " using True by simp

	qed (* free_absch *)



	text "Transformation of the Term for Paid Exchanges"

	have paid_absch: "E(map_pmf (\<lambda>x. (\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1) )) D) = 3/2 * (length (paid_A!n))"
	proof -

	{
	fix i
	assume inbound: "(index init i) < length init"
	have "map_pmf (\<lambda>xx. if fst (snd xx) ! (index init i) then 2::real else 1) D =
	bind_pmf (map_pmf (fst \<circ> snd) D) (\<lambda>b. return_pmf (if b! index init i then 2::real else 1))"
	unfolding map_pmf_def by(simp add: bind_assoc_pmf bind_return_pmf)
	also have "\<dots> = bind_pmf (bv (length init)) (\<lambda>b. return_pmf (if b! index init i then 2::real else 1))"
	using config_n_bv[of init "take n qs"] by simp
	also have "\<dots> = map_pmf (\<lambda>yy. (if yy then 2 else 1)) ( map_pmf (\<lambda>y. y!(index init i)) (bv (length init)))"
	by (simp add: map_pmf_def bind_return_pmf bind_assoc_pmf)
	also have "\<dots> = map_pmf (\<lambda>yy. (if yy then 2 else 1)) (bernoulli_pmf (5 / 10))"
	by (auto simp add: bv_comp_bernoulli[OF inbound])
	finally have "map_pmf (\<lambda>xx. if fst (snd xx) ! (index init i) then 2::real else 1) D =
	map_pmf (\<lambda>yy. if yy then 2::real else 1) (bernoulli_pmf (5 / 10)) " .
	} note umform = this


	have "E(map_pmf (\<lambda>x. (\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D) =
	(\<Sum>i<(length (paid_A!n)). E(map_pmf ((\<lambda>xx. (if (fst (snd xx))!(gebub n i) then 2::real else 1))) D))"
	apply(subst E_linear_sum2)
	using finite_config_BIT[OF dist_init] by(simp_all)
	also have "\<dots> = (\<Sum>i<(length (paid_A!n)). E(map_pmf (\<lambda>y. if y then 2::real else 1) (bernoulli_pmf (5 / 10))))" using umform gebub_def gebub_inBound[OF 31] by simp
	also have "\<dots> = 3/2 * (length (paid_A!n))" by(simp add: E_bernoulli)
	finally show "E(map_pmf (\<lambda>x. (\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D) = 3/2 * (length (paid_A!n))" .
	qed

	text "Combine the Results"

	(* cost of A *)
	have costA_absch: "k+(length (paid_A!n)) + 1 = t_A n" unfolding k_def q_def c_A_def p_A_def t_A_def by (auto)

	(* combine *)
	let ?yo= "(\<lambda>x. (cost x) + (\<Phi>\<^sub>2 x) - (\<Phi>\<^sub>0 x))"
	let ?yo2=" (\<lambda>x. (k + 1) + (if (q)\<in>set init then (if (fst (snd x))!(index init q) then k-k'
	else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)) ) else 0)
	+(\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2 else 1)))"

	have E0: "t_BIT n + Phi(n+1) - Phi n = E (map_pmf ?yo D) "
	using inEreinziehn by auto
	also have "\<dots> \<le> E(map_pmf ?yo2 D)"
	apply(rule E_mono2) unfolding D_def
	apply(fact finite_config_BIT[OF dist_init])
	apply(fact ub_cost[unfolded D_def])
	done

	also have E2: "\<dots> = E(map_pmf (\<lambda>x. k + 1::real) D)
	+ (E(map_pmf (\<lambda>x. (if (q)\<in>set init then (if (fst (snd x))!(index init q) then real(k-k') else (\<Sum>j<k'. (if (fst (snd x))!(index init (xs'!j)) then 2::real else 1)))else 0)) D)
	+ E(map_pmf (\<lambda>x. (\<Sum>i<(length (paid_A!n)). (if (fst (snd x))!(gebub n i) then 2::real else 1))) D))"
	unfolding D_def apply(simp only: E_linear_plus2[OF finite_config_BIT[OF dist_init]]) by(auto simp: add.assoc)

	also have E3: "\<dots> \<le> k + 1 + (3/4 * (real (k)) + (3/2 * real (length (paid_A!n))))" using paid_absch free_absch by auto

	also have "\<dots> = k + (3/4 * (real k)) + 1 + 3/2 (length (paid_A!n)) " by auto ( arithmetic! *)
	also have "\<dots> = (1+3/4) * (real k) + 1 + 3/2 (length (paid_A!n)) " by auto ( arithmetic! *)
	also have E4: "\<dots> = 7/4(real k) + 3/2 (length (paid_A!n)) + 1 " by auto (* arithmetic! *)
	also have "\<dots> \<le> 7/4(real k) + 7/4 (length (paid_A!n)) + 1" by auto (* arithmetic! *)
	also have E5:"\<dots> = 7/4*(k+(length (paid_A!n))) + 1 " by auto
	also have E6:"\<dots> = 7/4*(t_A n - (1::real)) + 1" using costA_absch by auto
	also have "\<dots> = 7/4*(t_A n) - 7/4 + 1" by algebra
	also have E7: "\<dots> = 7/4*(t_A n)- 3/4" by auto
	finally show "t_BIT n + Phi(n+1) - Phi n \<le> (7 / 4) * t_A n - 3/4" .
	qed
	then show "t_BIT n + Phi(n + 1) - Phi n \<le> (7 / 4) * t_A n - 3/4" .
	qed

	subsubsection "Lift the Result to the Whole Request List"


	lemma T_BIT_absch_le: assumes nqs: "n \<le> length qs"
	shows "T_BIT n \<le> (7 / 4) * T_A n - 3/4*n"
	unfolding T_BIT_def T_A_def
	proof -
	from potential2[of "Phi", OF phi0 phi_pos myub] nqs have
	"sum t_BIT {..<n} \<le> (\<Sum>i<n. 7 / 4 * (t_A i) - 3 / 4)" by auto
	also have "\<dots> = (\<Sum>i<n. 7 / 4 * real_of_int (t_A i)) - (\<Sum>i<n. (3/4))" by (rule sum_subtractf)
	also have "\<dots> = (\<Sum>i<n. 7 / 4 * real_of_int (t_A i)) - (3/4)*(\<Sum>i<n. 1)" by simp
	also have "\<dots> = (\<Sum>i<n. (7 / 4) * real_of_int (t_A i)) - (3/4)*n" by simp
	also have "\<dots> = (7 / 4) * (\<Sum>i<n. real_of_int (t_A i)) - (3/4)*n" by (simp add: sum_distrib_left)
	also have "\<dots> = (7 / 4) * real_of_int (\<Sum>i<n.(t_A i)) - (3/4)*n" by auto
	finally show "sum t_BIT {..<n} \<le> 7 / 4 * real_of_int (sum t_A {..<n}) - (3/4)*n" by auto
	qed



	lemma T_BIT_absch: assumes nqs: "n \<le> length qs"
	shows "T_BIT n \<le> (7 / 4) * T_A' n - 3/4*n"
	using nqs T_BIT_absch_le[of n] T_A_A'_leq[of n] by auto

	lemma T_A_nneg: "0 \<le> T_A n"
	by(auto simp add: sum_nonneg T_A_def t_A_def c_A_def p_A_def)



	lemma T_BIT_eq: "T_BIT (length qs) = T_on_rand BIT init qs"
	unfolding T_BIT_def T_on_rand_as_sum using t_BIT_def by auto


	corollary T_BIT_competitive: assumes "n \<le> length qs" and "init \<noteq> []" and "\<forall>i<n. qs!i \<in> set init"
	shows "T_BIT n \<le> ((7 / 4) - 3/(4 * size init)) * T_A' n"
	proof cases
	assume 0: "real_of_int(T_A' n) \<le> n * (size init)"
	then have 1: "3/4real_of_int(T_A' n) \<le> 3/4(n * (size init))" by auto
	have "T_BIT n \<le> (7 / 4) * T_A' n - 3/4*n" using T_BIT_absch[OF assms(1)] by auto
	also have "\<dots> = ((7 / 4) * real_of_int(T_A' n)) - (3/4(n size init)) / size init"
	using assms(2) by simp
	also have "\<dots> \<le> ((7 / 4) * real_of_int(T_A' n)) - 3/4*T_A' n / size init"
	by(rule diff_left_mono[OF divide_right_mono[OF 1]]) simp
	also have "\<dots> = ((7 / 4) - 3/4 / size init) * T_A' n" by algebra
	also have "\<dots> = ((7 / 4) - 3/(4 * size init)) * T_A' n" by simp
	finally show ?thesis .
	next
	assume 0: "\<not> real_of_int(T_A' n) \<le> n * (size init)"

	have T_A'_nneg: "0 \<le> T_A' n" using T_A_nneg[of n] T_A_A'_leq[of n] assms(1) by auto

	have "2 - 1 / size init \<ge> 1" using assms(2)
	by (auto simp add: field_simps neq_Nil_conv)
	have " T_BIT n \<le> n * size init" using T_BIT_ub[OF assms(3)] by linarith
	also have "\<dots> < real_of_int(T_A' n)" using 0 by linarith
	also have "\<dots> \<le> ((7 / 4) - 3/4 / size init) * T_A' n" using assms(2) T_A'_nneg
	by(auto simp add: mult_le_cancel_right1 field_simps neq_Nil_conv)
	finally show ?thesis by simp
	qed


	lemma t_A'_t: "n < length qs \<Longrightarrow> t_A' n = int (t (s_A' n) (qs!n) (acts ! n))"
	by (simp add: t_A'_def t_def c_A'_def p_A'_def paid_A'_def len_acts split: prod.split)

	lemma T_A'_eq_lem: "(\<Sum>i=0..<length qs. t_A' i) =
	T (s_A' 0) (drop 0 qs) (drop 0 acts)"
	proof(induction rule: zero_induct[of _ "size qs"])
	case 1 thus ?case by (simp add: len_acts)
	next
	case (2 n)
	show ?case
	proof cases
	assume "n < length qs"
	thus ?case using 2
	by(simp add: Cons_nth_drop_Suc[symmetric,where i=n] len_acts sum.atLeast_Suc_lessThan
	t_A'_t free_A_def paid_A'_def)
	next
	assume "\<not> n < length qs" thus ?case by (simp add: len_acts)
	qed
	qed

	lemma T_A'_eq: "T_A' (length qs) = T init qs acts"
	using T_A'_eq_lem by(simp add: T_A'_def atLeast0LessThan)

	corollary BIT_competitive3: "init \<noteq> [] \<Longrightarrow> \<forall>i<length qs. qs!i \<in> set init \<Longrightarrow>
	T_BIT (length qs) \<le> ( (7/4) - 3 / (4 * length init)) * T init qs acts"
	using order.refl T_BIT_competitive[of "length qs"] T_A'_eq by (simp add: of_int_of_nat_eq)

	corollary BIT_competitive2: "init \<noteq> [] \<Longrightarrow> \<forall>i<length qs. qs!i \<in> set init \<Longrightarrow>
	T_on_rand BIT init qs \<le> ( (7/4) - 3 / (4 * length init)) * T init qs acts"
	using BIT_competitive3 T_BIT_eq by auto

	corollary BIT_absch_le: "init \<noteq> [] \<Longrightarrow>
	T_on_rand BIT init qs \<le> (7 / 4) * (T init qs acts) - 3/4 * length qs"
	using T_BIT_absch[of "length qs", unfolded T_A'_eq T_BIT_eq] by auto

	end


	subsubsection "Generalize Competitivness of BIT"


	lemma setdi: "set xs = {0..<length xs} \<Longrightarrow> distinct xs"
	apply(rule card_distinct) by auto


	theorem compet_BIT: assumes "init \<noteq> []" "distinct init" "set qs \<subseteq> set init"
	shows "T_on_rand BIT init qs \<le> ( (7/4) - 3 / (4 * length init)) * T_opt init qs"
	proof-
	from assms(3) have 1: "\<forall>i < length qs. qs!i \<in> set init" by auto
	{ fix acts :: "answer list"
	assume len: "length acts = length qs"
	interpret BIT_Off acts qs init proof qed (auto simp: assms(2) len)
	from BIT_competitive2[OF assms(1) 1] assms(1)
	have "T_on_rand BIT init qs / ( (7/4) - 3 / (4 * length init)) \<le> real(T init qs acts)"
	by(simp add: field_simps length_greater_0_conv[symmetric]
	del: length_greater_0_conv) }
	hence "T_on_rand BIT init qs / ( (7/4) - 3 / (4 * length init)) \<le> T_opt init qs"
	apply(simp add: T_opt_def Inf_nat_def)
	apply(rule LeastI2_wellorder)
	using length_replicate[of "length qs" undefined] apply fastforce
	apply auto
	done
	thus ?thesis using assms by(simp add: field_simps
	length_greater_0_conv[symmetric] del: length_greater_0_conv)
	qed

	theorem compet_BIT4: assumes "init \<noteq> []" "distinct init"
	shows "T_on_rand BIT init qs \<le> 7/4 * T_opt init qs"
	proof-
	{ fix acts :: "answer list"
	assume len: "length acts = length qs"
	interpret BIT_Off acts qs init proof qed (auto simp: assms(2) len)
	from BIT_absch_le[OF assms(1)] assms(1)
	have "(T_on_rand BIT init qs + 3 / 4 * length qs)/ (7/4) \<le> real(T init qs acts)"
	by(simp add: field_simps length_greater_0_conv[symmetric]
	del: length_greater_0_conv) }
	hence "(T_on_rand BIT init qs + 3 / 4 * length qs)/ (7/4) \<le> T_opt init qs"
	apply(simp add: T_opt_def Inf_nat_def)
	apply(rule LeastI2_wellorder)
	using length_replicate[of "length qs" undefined] apply fastforce
	apply auto
	done
	thus ?thesis by(simp add: field_simps
	length_greater_0_conv[symmetric] del: length_greater_0_conv)
	qed

	theorem compet_BIT_2:
	"compet_rand BIT (7/4) {init. init \<noteq> [] \<and> distinct init}"
	unfolding compet_rand_def
	proof
	fix init
	assume "init \<in> {init. init \<noteq> [] \<and> distinct init }"
	then have ne: "init \<noteq> []" and a: "distinct init" by auto
	{
	fix qs
	assume "init \<noteq> []" and a: "distinct init"
	then have "T_on_rand BIT init qs \<le> 7/4 * T_opt init qs"
	using compet_BIT4[of init qs] by simp
	}
	with a ne show "\<exists>b\<ge>0. \<forall>qs. static init qs \<longrightarrow> T_on_rand BIT init qs \<le> (7 / 4) * (T_opt init qs) + b"
	by auto
	qed

	end
	diff --git a/thys/List_Update/List_Factoring.thy b/thys/List_Update/List_Factoring.thy
	--- a/thys/List_Update/List_Factoring.thy
	+++ b/thys/List_Update/List_Factoring.thy
	@@ -1,2389 +1,2389 @@
	(* Title: List Factoring
	Author: Max Haslbeck
	*)

	section "List factoring technique"

	theory List_Factoring
	imports
	Partial_Cost_Model
	MTF2_Effects
	begin

	hide_const config compet

	subsection "Helper functions"

	subsubsection "Helper lemmas"

	lemma befaf: assumes "q\<in>set s" "distinct s"
	shows "before q s \<union> {q} \<union> after q s = set s"
	proof -
	have "before q s \<union> {y. index s y = index s q \<and> q \<in> set s}
	= {y. index s y \<le> index s q \<and> q \<in> set s}"
	unfolding before_in_def apply(auto) by (simp add: le_neq_implies_less)
	also have "\<dots> = {y. index s y \<le> index s q \<and> y\<in> set s \<and> q \<in> set s}"
	apply(auto) by (metis index_conv_size_if_notin index_less_size_conv not_less)
	also with \<open>q \<in> set s\<close> have "\<dots> = {y. index s y \<le> index s q \<and> y\<in> set s}" by auto
	finally have "before q s \<union> {y. index s y = index s q \<and> q \<in> set s} \<union> after q s
	= {y. index s y \<le> index s q \<and> y\<in> set s} \<union> {y. index s y > index s q \<and> y \<in> set s}"
	unfolding before_in_def by simp
	also have "\<dots> = set s" by auto
	finally show ?thesis using assms by simp
	qed

	lemma index_sum: assumes "distinct s" "q\<in>set s"
	shows "index s q = (\<Sum>e\<in>set s. if e < q in s then 1 else 0)"
	proof -
	from assms have bia_empty: "before q s \<inter> ({q} \<union> after q s) = {}"
	by(auto simp: before_in_def)
	from befaf[OF assms(2) assms(1)] have "(\<Sum>e\<in>set s. if e < q in s then 1::nat else 0)
	= (\<Sum>e\<in>(before q s \<union> {q} \<union> after q s). if e < q in s then 1 else 0)" by auto
	also have "\<dots> = (\<Sum>e\<in>before q s. if e < q in s then 1 else 0)
	+ (\<Sum>e\<in>{q}. if e < q in s then 1 else 0) + (\<Sum>e\<in>after q s. if e < q in s then 1 else 0)"
	proof -
	have "(\<Sum>e\<in>(before q s \<union> {q} \<union> after q s). if e < q in s then 1::nat else 0)
	= (\<Sum>e\<in>(before q s \<union> ({q} \<union> after q s)). if e < q in s then 1::nat else 0)"
	by simp
	also have "\<dots> = (\<Sum>e\<in>before q s. if e < q in s then 1 else 0)
	+ (\<Sum>e\<in>({q} \<union> after q s). if e < q in s then 1 else 0)
	- (\<Sum>e\<in>(before q s \<inter> ({q} \<union> after q s)). if e < q in s then 1 else 0)"
	apply(rule sum_Un_nat) by(simp_all)
	also have "\<dots> = (\<Sum>e\<in>before q s. if e < q in s then 1 else 0)
	+ (\<Sum>e\<in>({q} \<union> after q s). if e < q in s then 1 else 0)" using bia_empty by auto
	also have "\<dots> = (\<Sum>e\<in>before q s. if e < q in s then 1 else 0)
	+ (\<Sum>e\<in>{q}. if e < q in s then 1 else 0) + (\<Sum>e\<in>after q s. if e < q in s then 1 else 0)"
	by (simp add: before_in_def)
	finally show ?thesis .
	qed
	also have "\<dots> = (\<Sum>e\<in>before q s. 1) + (\<Sum>e\<in>({q} \<union> after q s). 0)" apply(auto)
	unfolding before_in_def by auto
	also have "\<dots> = card (before q s)" by auto
	also have "\<dots> = card (set (take (index s q) s))" using before_conv_take[OF assms(2)] by simp
	also have "\<dots> = length (take (index s q) s)" using distinct_card assms(1) distinct_take by metis
	also have "\<dots> = min (length s) (index s q)" by simp
	also have "\<dots> = index s q" using index_le_size[of s q] by(auto)
	finally show ?thesis by simp
	qed


	subsubsection "ALG"

	fun ALG :: "'a \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> ('a list * 'is) \<Rightarrow> nat" where
	"ALG x qs i s = (if x < (qs!i) in fst s then 1::nat else 0)"

	(* no paid exchanges, requested items in state (nice, quickcheck is awesome!) *)
	lemma t\<^sub>p_sumofALG: "distinct (fst s) \<Longrightarrow> snd a = [] \<Longrightarrow> (qs!i)\<in>set (fst s)
	\<Longrightarrow> t\<^sub>p (fst s) (qs!i) a = (\<Sum>e\<in>set (fst s). ALG e qs i s)"
	unfolding t\<^sub>p_def apply(simp add: split_def )
	using index_sum by metis

	lemma t\<^sub>p_sumofALGreal: assumes "distinct (fst s)" "snd a = []" "qs!i \<in> set(fst s)"
	shows "real(t\<^sub>p (fst s) (qs!i) a) = (\<Sum>e\<in>set (fst s). real(ALG e qs i s))"
	proof -
	from assms have "real(t\<^sub>p (fst s) (qs!i) a) = real(\<Sum>e\<in>set (fst s). ALG e qs i s)"
	using t\<^sub>p_sumofALG by metis
	also have "\<dots> = (\<Sum>e\<in>set (fst s). real (ALG e qs i s))"
	by auto
	finally show ?thesis .
	qed


	subsubsection "The function steps'"

	fun steps' where
	"steps' s _ _ 0 = s"
	\| "steps' s [] [] (Suc n) = s"
	\| "steps' s (q#qs) (a#as) (Suc n) = steps' (step s q a) qs as n"

	lemma steps'_steps: "length as = length qs \<Longrightarrow> steps' s as qs (length as) = steps s as qs"
	by(induct arbitrary: s rule: list_induct2, simp_all)


	lemma steps'_length: "length qs = length as \<Longrightarrow> n \<le> length as
	\<Longrightarrow> length (steps' s qs as n) = length s"
	apply(induct qs as arbitrary: s n rule: list_induct2)
	apply(simp)
	apply(case_tac n)
	by (auto)

	lemma steps'_set: "length qs = length as \<Longrightarrow> n \<le> length as
	\<Longrightarrow> set (steps' s qs as n) = set s"
	apply(induct qs as arbitrary: s n rule: list_induct2)
	apply(simp)
	apply(case_tac n)
	by(auto simp: set_step)

	lemma steps'_distinct2: "length qs = length as \<Longrightarrow> n \<le> length as
	\<Longrightarrow> distinct s \<Longrightarrow> distinct (steps' s qs as n)"
	apply(induct qs as arbitrary: s n rule: list_induct2)
	apply(simp)
	apply(case_tac n)
	by(auto simp: distinct_step)


	lemma steps'_distinct: "length qs = length as \<Longrightarrow> length as = n
	\<Longrightarrow> distinct (steps' s qs as n) = distinct s"
	by (induct qs as arbitrary: s n rule: list_induct2) (fastforce simp add: distinct_step)+

	lemma steps'_dist_perm: "length qs = length as \<Longrightarrow> length as = n
	\<Longrightarrow> dist_perm s s \<Longrightarrow> dist_perm (steps' s qs as n) (steps' s qs as n)"
	using steps'_set steps'_distinct by blast

	lemma steps'_rests: "length qs = length as \<Longrightarrow> n \<le> length as \<Longrightarrow> steps' s qs as n = steps' s (qs@r1) (as@r2) n"
	apply(induct qs as arbitrary: s n rule: list_induct2)
	apply(simp) apply(case_tac n) by auto

	lemma steps'_append: "length qs = length as \<Longrightarrow> length qs = n \<Longrightarrow> steps' s (qs@[q]) (as@[a]) (Suc n) = step (steps' s qs as n) q a"
	apply(induct qs as arbitrary: s n rule: list_induct2) by auto

	subsubsection "\<open>ALG'_det\<close>"

	definition "ALG'_det Strat qs init i x = ALG x qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),())"

	lemma ALG'_det_append: "n < length Strat \<Longrightarrow> n < length qs \<Longrightarrow> ALG'_det Strat (qs@a) init n x
	= ALG'_det Strat qs init n x"
	proof -
	assume qs: "n < length qs"
	assume S: "n < length Strat"

	have tt: "(qs @ a) ! n = qs ! n"
	using qs by (simp add: nth_append)

	have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ drop n qs) ((take n Strat) @ (drop n Strat)) n"
	apply(rule steps'_rests)
	using S qs by auto
	then have A: "steps' init (take n qs) (take n Strat) n = steps' init qs Strat n" by auto
	have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ ((drop n qs)@a)) ((take n Strat) @((drop n Strat)@[])) n"
	apply(rule steps'_rests)
	using S qs by auto
	then have B: "steps' init (take n qs) (take n Strat) n = steps' init (qs@a) (Strat@[]) n"
	by (metis append_assoc List.append_take_drop_id)
	from A B have "steps' init qs Strat n = steps' init (qs@a) (Strat@[]) n" by auto
	then have C: "steps' init qs Strat n = steps' init (qs@a) Strat n" by auto

	show ?thesis unfolding ALG'_det_def C
	unfolding ALG.simps tt by auto
	qed

	subsubsection "ALG'"

	abbreviation "config'' A qs init n == config_rand A init (take n qs)"

	definition "ALG' A qs init i x = E( map_pmf (ALG x qs i) (config'' A qs init i))"

	lemma ALG'_refl: "qs!i = x \<Longrightarrow> ALG' A qs init i x = 0"
	unfolding ALG'_def by(simp add: split_def before_in_def)

	subsubsection "\<open>ALGxy_det\<close>"

	definition ALGxy_det where
	"ALGxy_det A qs init x y = (\<Sum>i\<in>{..<length qs}. (if (qs!i \<in> {y,x}) then ALG'_det A qs init i y + ALG'_det A qs init i x
	else 0::nat))"

	lemma ALGxy_det_alternativ: "ALGxy_det A qs init x y
	= (\<Sum>i\<in>{i. i<length qs \<and> (qs!i \<in> {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)"
	proof -
	have f: "{i. i<length qs} = {..<length qs}" by(auto)

	have e: "{i. i<length qs \<and> (qs!i \<in> {y,x})} = {i. i<length qs} \<inter> {i. (qs!i \<in> {y,x})}"
	by auto
	have "(\<Sum>i\<in>{i. i<length qs \<and> (qs!i \<in> {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)
	= (\<Sum>i\<in>{i. i<length qs} \<inter> {i. (qs!i \<in> {y,x})}. ALG'_det A qs init i y + ALG'_det A qs init i x)"
	unfolding e by simp
	also have "\<dots> = (\<Sum>i\<in>{i. i<length qs}. (if i \<in> {i. (qs!i \<in> {y,x})} then ALG'_det A qs init i y + ALG'_det A qs init i x
	else 0))"
	apply(rule sum.inter_restrict) by auto
	also have "\<dots> = (\<Sum>i\<in>{..<length qs}. (if i \<in> {i. (qs!i \<in> {y,x})} then ALG'_det A qs init i y + ALG'_det A qs init i x
	else 0))"
	unfolding f by auto
	also have "\<dots> = ALGxy_det A qs init x y"
	unfolding ALGxy_det_def by auto
	finally show ?thesis by simp
	qed

	subsubsection "ALGxy"

	definition ALGxy where
	"ALGxy A qs init x y = (\<Sum>i\<in>{..<length qs} \<inter> {i. (qs!i \<in> {y,x})}. ALG' A qs init i y + ALG' A qs init i x)"

	lemma ALGxy_def2:
	"ALGxy A qs init x y = (\<Sum>i\<in>{i. i<length qs \<and> (qs!i \<in> {y,x})}. ALG' A qs init i y + ALG' A qs init i x)"
	proof -
	have a: "{i. i<length qs \<and> (qs!i \<in> {y,x})} = {..<length qs} \<inter> {i. (qs!i \<in> {y,x})}" by auto
	show ?thesis unfolding ALGxy_def a by simp
	qed
	lemma ALGxy_append: "ALGxy A (rs@[r]) init x y =
	ALGxy A rs init x y + (if (r \<in> {y,x}) then ALG' A (rs@[r]) init (length rs) y + ALG' A (rs@[r]) init (length rs) x else 0 )"
	proof -
	have "ALGxy A (rs@[r]) init x y = (\<Sum>i\<in>{..<(Suc (length rs))} \<inter> {i. (rs @ [r]) ! i \<in> {y, x}}.
	ALG' A (rs @ [r]) init i y +
	ALG' A (rs @ [r]) init i x)" unfolding ALGxy_def by(simp)
	also have "\<dots> = (\<Sum>i\<in>{..<(Suc (length rs))}. (if i\<in>{i. (rs @ [r]) ! i \<in> {y, x}} then
	ALG' A (rs @ [r]) init i y +
	ALG' A (rs @ [r]) init i x else 0) )"
	apply(rule sum.inter_restrict) by simp
	also have "\<dots> = (\<Sum>i\<in>{..<length rs}. (if i\<in>{i. (rs @ [r]) ! i \<in> {y, x}} then
	ALG' A (rs @ [r]) init i y +
	ALG' A (rs @ [r]) init i x else 0) ) + (if length rs\<in>{i. (rs @ [r]) ! i \<in> {y, x}} then
	ALG' A (rs @ [r]) init (length rs) y +
	ALG' A (rs @ [r]) init(length rs) x else 0) " by simp
	also have "\<dots> = ALGxy A rs init x y + (if r \<in> {y, x} then
	ALG' A (rs @ [r]) init (length rs) y +
	ALG' A (rs @ [r]) init(length rs) x else 0)"
	apply(simp add: ALGxy_def sum.inter_restrict nth_append)
	unfolding ALG'_def
	apply(rule sum.cong)
	apply(simp) by(auto simp: nth_append)
	finally show ?thesis .
	qed

	lemma ALGxy_wholerange: "ALGxy A qs init x y
	= (\<Sum>i<(length qs). (if qs ! i \<in> {y, x}
	then ALG' A qs init i y + ALG' A qs init i x
	else 0 ))"
	proof -
	have "ALGxy A qs init x y
	= (\<Sum>i\<in> {i. i < length qs} \<inter> {i. qs ! i \<in> {y, x}}.
	ALG' A qs init i y + ALG' A qs init i x)"
	unfolding ALGxy_def
	apply(rule sum.cong)
	apply(simp) apply(blast)
	by simp
	also have "\<dots> = (\<Sum>i\<in>{i. i < length qs}. if i \<in> {i. qs ! i \<in> {y, x}}
	then ALG' A qs init i y + ALG' A qs init i x
	else 0)"
	by(rule sum.inter_restrict) simp
	also have "\<dots> = (\<Sum>i<(length qs). (if qs ! i \<in> {y, x}
	then ALG' A qs init i y + ALG' A qs init i x
	else 0 ))" apply(rule sum.cong) by(auto)
	finally show ?thesis .
	qed

	subsection "Transformation to Blocking Cost"

	lemma umformung:
	fixes A :: "(('a::linorder) list,'is,'a,(nat * nat list)) alg_on_rand"
	assumes no_paid: "\<And>is s q. \<forall>((free,paid),_) \<in> (snd A (s,is) q). paid=[]"
	assumes inlist: "set qs \<subseteq> set init"
	assumes dist: "distinct init"
	assumes "\<And>x. x < length qs \<Longrightarrow> finite (set_pmf (config'' A qs init x))"
	shows "T\<^sub>p_on_rand A init qs =
	(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALGxy A qs init x y)"
	proof -
	have config_dist: "\<forall>n. \<forall>xa \<in> set_pmf (config'' A qs init n). distinct (fst xa)"
	using dist config_rand_distinct by metis

	have E0: "T\<^sub>p_on_rand A init qs =
	(\<Sum>i\<in>{..<length qs}. T\<^sub>p_on_rand_n A init qs i)" unfolding T_on_rand_as_sum by auto
	also have "\<dots> =
	(\<Sum>i<length qs. E (bind_pmf (config'' A qs init i)
	(\<lambda>s. bind_pmf (snd A s (qs ! i))
	(\<lambda>(a, nis). return_pmf (real (\<Sum>x\<in>set init. ALG x qs i s))))))"
	apply(rule sum.cong)
	apply(simp)
	apply(simp add: bind_return_pmf bind_assoc_pmf)
	apply(rule arg_cong[where f=E])
	apply(rule bind_pmf_cong)
	apply(simp)
	apply(rule bind_pmf_cong)
	apply(simp)
	apply(simp add: split_def)
	apply(subst t\<^sub>p_sumofALGreal)
	proof (goal_cases)
	case 1
	then show ?case using config_dist by(metis)
	next
	case (2 a b c)
	then show ?case using no_paid[of "fst b" "snd b"] by(auto simp add: split_def)
	next
	case (3 a b c)
	with config_rand_set have a: "set (fst b) = set init" by metis
	with inlist have " set qs \<subseteq> set (fst b)" by auto
	with 3 show ?case by auto
	next
	case (4 a b c)
	with config_rand_set have a: "set (fst b) = set init" by metis
	then show ?case by(simp)
	qed


	(* hier erst s, dann init *)
	also have "\<dots> = (\<Sum>i<length qs.
	E (map_pmf (\<lambda>(is, s). (real (\<Sum>x\<in>set init. ALG x qs i (is,s))))
	(config'' A qs init i)))"
	apply(simp only: map_pmf_def split_def) by simp
	also have E1: "\<dots> = (\<Sum>i<length qs. (\<Sum>x\<in>set init. ALG' A qs init i x))"
	apply(rule sum.cong)
	apply(simp)
	apply(simp add: split_def ALG'_def)
	apply(rule E_linear_sum_allg)
	by(rule assms(4))
	also have E2: "\<dots> = (\<Sum>x\<in>set init.
	(\<Sum>i<length qs. ALG' A qs init i x))"
	by(rule sum.swap) (* die summen tauschen *)
	also have E3: "\<dots> = (\<Sum>x\<in>set init.
	(\<Sum>y\<in>set init.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG' A qs init i x)))"
	proof (rule sum.cong, goal_cases)
	case (2 x)
	have "(\<Sum>i<length qs. ALG' A qs init i x)
	= sum (%i. ALG' A qs init i x) {i. i<length qs}"
	by (metis lessThan_def)
	also have "\<dots> = sum (%i. ALG' A qs init i x)
	(\<Union>y\<in>{y. y \<in> set init}. {i. i < length qs \<and> qs ! i = y})"
	apply(rule sum.cong)
	apply(auto)
	using inlist by auto
	also have "\<dots> = sum (%t. sum (%i. ALG' A qs init i x) {i. i<length qs \<and> qs ! i = t}) {y. y\<in> set init}"
	apply(rule sum.UNION_disjoint)
	apply(simp_all) by force
	also have "\<dots> = (\<Sum>y\<in>set init. \<Sum>i \| i < length qs \<and> qs ! i = y.
	ALG' A qs init i x)" by auto
	finally show ?case .
	qed (simp)

	also have "\<dots> = (\<Sum>(x,y)\<in> (set init \<times> set init).
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG' A qs init i x))"
	by (rule sum.cartesian_product)
	also have "\<dots> = (\<Sum>(x,y)\<in> {(x,y). x\<in>set init \<and> y\<in> set init}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG' A qs init i x))"
	by simp
	also have E4: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x\<in>set init \<and> y\<in> set init \<and> x\<noteq>y}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG' A qs init i x))" (is "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f x y)")
	proof -
	let ?M = "{(x,y). x\<in>set init \<and> y\<in> set init \<and> x=y}"
	have A: "?L = ?R \<union> ?M" by auto
	have B: "{} = ?R \<inter> ?M" by auto

	have "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R \<union> ?M. ?f x y)"
	by(simp only: A)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?M. ?f x y)"
	apply(rule sum.union_disjoint)
	apply(rule finite_subset[where B="set init \<times> set init"])
	apply(auto)
	apply(rule finite_subset[where B="set init \<times> set init"])
	by(auto)
	also have "(\<Sum>(x,y)\<in> ?M. ?f x y) = 0"
	apply(rule sum.neutral)
	by (auto simp add: ALG'_refl)
	finally show ?thesis by simp
	qed

	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG' A qs init i x)
	+ (\<Sum>i\<in>{i. i<length qs \<and> qs!i=x}. ALG' A qs init i y) )"
	(is "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f x y + ?f y x)")
	proof -
	let ?R' = "{(x,y). x \<in> set init \<and> y\<in>set init \<and> y<x}"
	have A: "?L = ?R \<union> ?R'" by auto
	have "{} = ?R \<inter> ?R'" by auto
	have C: "?R' = (%(x,y). (y, x)) ` ?R" by auto

	have D: "(\<Sum>(x,y)\<in> ?R'. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f y x)"
	proof -
	have "(\<Sum>(x,y)\<in> ?R'. ?f x y) = (\<Sum>(x,y)\<in> (%(x,y). (y, x)) ` ?R. ?f x y)"
	by(simp only: C)
	also have "(\<Sum>z\<in> (%(x,y). (y, x)) ` ?R. (%(x,y). ?f x y) z) = (\<Sum>z\<in>?R. ((%(x,y). ?f x y) \<circ> (%(x,y). (y, x))) z)"
	apply(rule sum.reindex)
	by(fact swap_inj_on)
	also have "\<dots> = (\<Sum>z\<in>?R. (%(x,y). ?f y x) z)"
	apply(rule sum.cong)
	by(auto)
	finally show ?thesis .
	qed

	have "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R \<union> ?R'. ?f x y)"
	by(simp only: A)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?R'. ?f x y)"
	apply(rule sum.union_disjoint)
	apply(rule finite_subset[where B="set init \<times> set init"])
	apply(auto)
	apply(rule finite_subset[where B="set init \<times> set init"])
	by(auto)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?R. ?f y x)"
	by(simp only: D)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y + ?f y x)"
	by(simp add: split_def sum.distrib[symmetric])
	finally show ?thesis .
	qed

	also have E5: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{i. i<length qs \<and> (qs!i=y \<or> qs!i=x)}. ALG' A qs init i y + ALG' A qs init i x))"
	apply(rule sum.cong)
	apply(simp)
	proof goal_cases
	case (1 x)
	then obtain a b where x: "x=(a,b)" and a: "a \<in> set init" "b \<in> set init" "a < b" by auto
	then have "a\<noteq>b" by simp
	then have disj: "{i. i < length qs \<and> qs ! i = b} \<inter> {i. i < length qs \<and> qs ! i = a} = {}" by auto
	have unio: "{i. i < length qs \<and> (qs ! i = b \<or> qs ! i = a)}
	= {i. i < length qs \<and> qs ! i = b} \<union> {i. i < length qs \<and> qs ! i = a}" by auto
	have "(\<Sum>i\<in>{i. i < length qs \<and> qs ! i = b} \<union>
	{i. i < length qs \<and> qs ! i = a}. ALG' A qs init i b +
	ALG' A qs init i a)
	= (\<Sum>i\<in>{i. i < length qs \<and> qs ! i = b}. ALG' A qs init i b +
	ALG' A qs init i a) + (\<Sum>i\<in>
	{i. i < length qs \<and> qs ! i = a}. ALG' A qs init i b +
	ALG' A qs init i a) - (\<Sum>i\<in>{i. i < length qs \<and> qs ! i = b} \<inter>
	{i. i < length qs \<and> qs ! i = a}. ALG' A qs init i b +
	ALG' A qs init i a) "
	apply(rule sum_Un)
	by(auto)
	also have "\<dots> = (\<Sum>i\<in>{i. i < length qs \<and> qs ! i = b}. ALG' A qs init i b +
	ALG' A qs init i a) + (\<Sum>i\<in>
	{i. i < length qs \<and> qs ! i = a}. ALG' A qs init i b +
	ALG' A qs init i a)" using disj by auto
	also have "\<dots> = (\<Sum>i\<in>{i. i < length qs \<and> qs ! i = b}. ALG' A qs init i a)
	+ (\<Sum>i\<in>{i. i < length qs \<and> qs ! i = a}. ALG' A qs init i b)"
	by (auto simp: ALG'_refl)
	finally
	show ?case unfolding x apply(simp add: split_def)
	unfolding unio by simp
	qed
	also have E6: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy A qs init x y)"
	unfolding ALGxy_def2 by simp
	finally show ?thesis .
	qed (* this is lemma 1.4 *)


	lemma before_in_index1:
	fixes l
	assumes "set l = {x,y}" and "length l = 2" and "x\<noteq>y"
	shows "(if (x < y in l) then 0 else 1) = index l x"
	unfolding before_in_def
	proof (auto, goal_cases) (* bad style! *)
	case 1
	from assms(1) have "index l y < length l" by simp
	with assms(2) 1(1) show "index l x = 0" by auto
	next
	case 2
	from assms(1) have a: "index l x < length l" by simp
	from assms(1,3) have "index l y \<noteq> index l x" by simp
	with assms(2) 2(1) a show "Suc 0 = index l x" by simp
	qed (simp add: assms)


	lemma before_in_index2:
	fixes l
	assumes "set l = {x,y}" and "length l = 2" and "x\<noteq>y"
	shows "(if (x < y in l) then 1 else 0) = index l y"
	unfolding before_in_def
	proof (auto, goal_cases) (* bad style! *)
	case 2
	from assms(1,3) have a: "index l y \<noteq> index l x" by simp
	from assms(1) have "index l x < length l" by simp
	with assms(2) a 2(1) show "index l y = 0" by auto
	next
	case 1
	from assms(1) have a: "index l y < length l" by simp
	from assms(1,3) have "index l y \<noteq> index l x" by simp
	with assms(2) 1(1) a show "Suc 0 = index l y" by simp
	qed (simp add: assms)


	lemma before_in_index:
	fixes l
	assumes "set l = {x,y}" and "length l = 2" and "x\<noteq>y"
	shows "(x < y in l) = (index l x = 0)"
	unfolding before_in_def
	proof (safe, goal_cases)
	case 1
	from assms(1) have "index l y < length l" by simp
	with assms(2) 1(1) show "index l x = 0" by auto
	next
	case 2
	from assms(1,3) have "index l y \<noteq> index l x" by simp
	with 2(1) show "index l x < index l y" by simp
	qed (simp add: assms)


	subsection "The pairwise property"


	definition pairwise where
	"pairwise A = (\<forall>init. distinct init \<longrightarrow> (\<forall>qs\<in>{xs. set xs \<subseteq> set init}. \<forall>(x::('a::linorder),y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. T\<^sub>p_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}) = ALGxy A qs init x y))"

	definition "Pbefore_in x y A qs init = map_pmf (\<lambda>p. x < y in fst p) (config_rand A init qs)"


	lemma T_on_n_no_paid:
	assumes
	nopaid: "\<And>s n. map_pmf (\<lambda>x. snd (fst x)) (snd A s n) = return_pmf []"
	shows "T_on_rand_n A init qs i = E (config'' A qs init i \<bind> (\<lambda>p. return_pmf (real(index (fst p) (qs ! i)))))"
	proof -

	have "(\<lambda>s. snd A s (qs ! i) \<bind>
	(\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) (qs ! i) a))))
	=
	(\<lambda>s. (snd A s (qs ! i) \<bind> (\<lambda>x. return_pmf (snd (fst x))))
	\<bind> (\<lambda>p. return_pmf
	(real (index (swaps p (fst s)) (qs ! i)) +
	real (length p))))"
	by(simp add: t\<^sub>p_def split_def bind_return_pmf bind_assoc_pmf)
	also
	have "\<dots> = (\<lambda>p. return_pmf (real (index (fst p) (qs ! i))))"
	using nopaid[unfolded map_pmf_def]
	by(simp add: split_def bind_return_pmf)
	finally
	show ?thesis by simp
	qed

	lemma pairwise_property_lemma:
	assumes
	relativeorder: "(\<And>init qs. distinct init \<Longrightarrow> qs \<in> {xs. set xs \<subseteq> set init}
	\<Longrightarrow> (\<And>x y. (x,y)\<in> {(x,y). x \<in> set init \<and> y\<in>set init \<and> x\<noteq>y}
	\<Longrightarrow> x \<noteq> y
	\<Longrightarrow> Pbefore_in x y A qs init = Pbefore_in x y A (Lxy qs {x,y}) (Lxy init {x,y})
	))"
	and nopaid: "\<And>xa r. \<forall>z\<in> set_pmf(snd A xa r). snd(fst z) = []"
	shows "pairwise A"
	unfolding pairwise_def
	proof (clarify, goal_cases)
	case (1 init rs x y)
	then have xny: "x\<noteq>y" by auto

	note dinit=1(1)
	then have dLyx: "distinct (Lxy init {y,x})" by(rule Lxy_distinct)
	from dinit have dLxy: "distinct (Lxy init {x,y})" by(rule Lxy_distinct)
	have setLxy: "set (Lxy init {x, y}) = {x,y}" apply(subst Lxy_set_filter) using 1 by auto
	have setLyx: "set (Lxy init {y, x}) = {x,y}" apply(subst Lxy_set_filter) using 1 by auto
	have lengthLyx:" length (Lxy init {y, x}) = 2" using setLyx distinct_card[OF dLyx] xny by simp
	have lengthLxy:" length (Lxy init {x, y}) = 2" using setLxy distinct_card[OF dLxy] xny by simp
	have aee: "{x,y} = {y,x}" by auto


	from 1(2) show ?case
	proof(induct rs rule: rev_induct)
	case (snoc r rs)

	have b: "Pbefore_in x y A rs init = Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y})"
	apply(rule relativeorder)
	using snoc 1 xny by(simp_all)

	show ?case (is "?L (rs @ [r]) = ?R (rs @ [r])")
	proof(cases "r\<in>{x,y}")
	case True
	note xyrequest=this
	let ?expr = "E (Partial_Cost_Model.config'_rand A
	(fst A (Lxy init {x, y}) \<bind>
	(\<lambda>is. return_pmf (Lxy init {x, y}, is)))
	(Lxy rs {x, y}) \<bind>
	(\<lambda>s. snd A s r \<bind>
	(\<lambda>(a, is').
	return_pmf
	(real (t\<^sub>p (fst s) r a)))))"
	let ?expr2 = "ALG' A (rs @ [r]) init (length rs) y + ALG' A (rs @ [r]) init (length rs) x"

	from xyrequest have "?L (rs @ [r]) = ?L rs + ?expr"
	by(simp add: Lxy_snoc T_on_rand'_append)
	also have "\<dots> = ?L rs + ?expr2"
	proof(cases "r=x")
	case True
	let ?projS ="config'_rand A (fst A (Lxy init {x, y}) \<bind> (\<lambda>is. return_pmf (Lxy init {x, y}, is))) (Lxy rs {x, y})"
	let ?S = "(config'_rand A (fst A init \<bind> (\<lambda>is. return_pmf (init, is))) rs)"


	have "?projS \<bind> (\<lambda>s. snd A s r
	\<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) r a))))
	= ?projS \<bind> (\<lambda>s. return_pmf (real (index (fst s) r)))"
	proof (rule bind_pmf_cong, goal_cases)
	case (2 z)
	have "snd A z r \<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst z) r a))) = snd A z r \<bind> (\<lambda>x. return_pmf (real (index (fst z) r)))"
	apply(rule bind_pmf_cong)
	apply(simp)
	using nopaid[of z r] by(simp add: split_def t\<^sub>p_def)
	then show ?case by(simp add: bind_return_pmf)
	qed simp
	also have "\<dots> = map_pmf (%b. (if b then 0::real else 1)) (Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y}))"
	unfolding Pbefore_in_def map_pmf_def
	apply(simp add: bind_return_pmf bind_assoc_pmf)
	apply(rule bind_pmf_cong)
	apply(simp add: aee)
	proof goal_cases
	case (1 z)
	have " (if x < y in fst z then 0 else 1) = (index (fst z) x)"
	apply(rule before_in_index1)
	using 1 config_rand_set setLxy apply fast
	using 1 config_rand_length lengthLxy apply metis
	using xny by simp
	with True show ?case
	by(auto)
	qed
	also have "\<dots> = map_pmf (%b. (if b then 0::real else 1)) (Pbefore_in x y A rs init)" by(simp add: b)

	also have "\<dots> = map_pmf (\<lambda>xa. real (if y < x in fst xa then 1 else 0)) ?S"
	apply(simp add: Pbefore_in_def map_pmf_comp)
	proof (rule map_pmf_cong, goal_cases)
	case (2 z)
	then have set_z: "set (fst z) = set init"
	using config_rand_set by fast
	have "(\<not> x < y in fst z) = y < x in fst z"
	apply(subst not_before_in)
	using set_z 1(3,4) xny by(simp_all)
	- then show ?case by(simp add: )
	+ then show ?case bysimp
	qed simp
	finally have a: "?projS \<bind> (\<lambda>s. snd A s x
	\<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) x a))))
	= map_pmf (\<lambda>xa. real (if y < x in fst xa then 1 else 0)) ?S" using True by simp
	from True show ?thesis
	apply(simp add: ALG'_refl nth_append)
	unfolding ALG'_def
	by(simp add: a)
	next
	case False
	with xyrequest have request: "r=y" by blast

	let ?projS ="config'_rand A (fst A (Lxy init {x, y}) \<bind> (\<lambda>is. return_pmf (Lxy init {x, y}, is))) (Lxy rs {x, y})"
	let ?S = "(config'_rand A (fst A init \<bind> (\<lambda>is. return_pmf (init, is))) rs)"


	have "?projS \<bind> (\<lambda>s. snd A s r
	\<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) r a))))
	= ?projS \<bind> (\<lambda>s. return_pmf (real (index (fst s) r)))"
	proof (rule bind_pmf_cong, goal_cases)
	case (2 z)
	have "snd A z r \<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst z) r a))) = snd A z r \<bind> (\<lambda>x. return_pmf (real (index (fst z) r)))"
	apply(rule bind_pmf_cong)
	apply(simp)
	using nopaid[of z r] by(simp add: split_def t\<^sub>p_def)
	then show ?case by(simp add: bind_return_pmf)
	qed simp
	also have "\<dots> = map_pmf (%b. (if b then 1::real else 0)) (Pbefore_in x y A (Lxy rs {x,y}) (Lxy init {x,y}))"
	unfolding Pbefore_in_def map_pmf_def
	apply(simp add: bind_return_pmf bind_assoc_pmf)
	apply(rule bind_pmf_cong)
	apply(simp add: aee)
	proof goal_cases
	case (1 z)
	have " (if x < y in fst z then 1 else 0) = (index (fst z) y)"
	apply(rule before_in_index2)
	using 1 config_rand_set setLxy apply fast
	using 1 config_rand_length lengthLxy apply metis
	using xny by simp
	with request show ?case
	by(auto)
	qed
	also have "\<dots> = map_pmf (%b. (if b then 1::real else 0)) (Pbefore_in x y A rs init)" by(simp add: b)

	also have "\<dots> = map_pmf (\<lambda>xa. real (if x < y in fst xa then 1 else 0)) ?S"
	apply(simp add: Pbefore_in_def map_pmf_comp)
	apply (rule map_pmf_cong) by simp_all
	finally have a: "?projS \<bind> (\<lambda>s. snd A s y
	\<bind> (\<lambda>(a, is'). return_pmf (real (t\<^sub>p (fst s) y a))))
	= map_pmf (\<lambda>xa. real (if x < y in fst xa then 1 else 0)) ?S" using request by simp
	from request show ?thesis
	apply(simp add: ALG'_refl nth_append)
	unfolding ALG'_def
	by(simp add: a)
	qed
	also have "\<dots> = ?R rs + ?expr2" using snoc by simp
	also from True have "\<dots> = ?R (rs@[r])"
	apply(subst ALGxy_append) by(auto)
	finally show ?thesis .
	next
	case False
	then have "?L (rs @ [r]) = ?L rs" apply(subst Lxy_snoc) by simp
	also have "\<dots> = ?R rs" using snoc by(simp)
	also have "\<dots> = ?R (rs @ [r])"
	apply(subst ALGxy_append) using False by(simp)
	finally show ?thesis .
	qed
	qed (simp add: ALGxy_def)
	qed


	lemma umf_pair: assumes
	0: "pairwise A"
	assumes 1: "\<And>is s q. \<forall>((free,paid),_) \<in> (snd A (s, is) q). paid=[]"
	assumes 2: "set qs \<subseteq> set init"
	assumes 3: "distinct init"
	assumes 4: "\<And>x. x<length qs \<Longrightarrow> finite (set_pmf (config'' A qs init x))"
	shows "T\<^sub>p_on_rand A init qs
	= (\<Sum>(x,y)\<in>{(x, y). x \<in> set init \<and> y \<in> set init \<and> x < y}. T\<^sub>p_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}))"
	proof -
	have " T\<^sub>p_on_rand A init qs = (\<Sum>(x,y)\<in>{(x, y). x \<in> set init \<and> y \<in> set init \<and> x < y}. ALGxy A qs init x y)"
	by(simp only: umformung[OF 1 2 3 4])
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x, y). x \<in> set init \<and> y \<in> set init \<and> x < y}. T\<^sub>p_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}))"
	apply(rule sum.cong)
	apply(simp)
	using 0[unfolded pairwise_def] 2 3 by auto
	finally show ?thesis .
	qed

	subsection "List Factoring for OPT"

	(* calculates given a list of swaps, elements x and y and a current state
	how many swaps between x and y there are *)
	fun ALG_P :: "nat list \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> nat" where
	"ALG_P [] x y xs = (0::nat)"
	\| "ALG_P (s#ss) x y xs = (if Suc s < length (swaps ss xs)
	then (if ((swaps ss xs)!s=x \<and> (swaps ss xs)!(Suc s)=y) \<or> ((swaps ss xs)!s=y \<and> (swaps ss xs)!(Suc s)=x)
	then 1
	else 0)
	else 0) + ALG_P ss x y xs"

	(* nat list ersetzen durch (a::ordered) list *)
	lemma ALG_P_erwischt_alle:
	assumes dinit: "distinct init"
	shows
	"\<forall>l< length sws. Suc (sws!l) < length init \<Longrightarrow> length sws
	= (\<Sum>(x,y)\<in>{(x,y). x \<in> set (init::('a::linorder) list) \<and> y\<in>set init \<and> x<y}. ALG_P sws x y init)"
	proof (induct sws)
	case (Cons s ss)
	then have isininit: "Suc s < length init" by auto
	from Cons have "\<forall>l<length ss. Suc (ss ! l) < length init" by auto
	note iH=Cons(1)[OF this]

	let ?expr = "(\<lambda>x y. (if Suc s < length (swaps ss init)
	then (if ((swaps ss init)!s=x \<and> (swaps ss init)!(Suc s)=y) \<or> ((swaps ss init)!s=y \<and> (swaps ss init)!(Suc s)=x)
	then 1::nat
	else 0)
	else 0))"

	let ?expr2 = "(\<lambda>x y. (if ((swaps ss init)!s=x \<and> (swaps ss init)!(Suc s)=y) \<or> ((swaps ss init)!s=y \<and> (swaps ss init)!(Suc s)=x)
	then 1
	else 0))"

	let ?expr3 = "(%x y. ((swaps ss init)!s=x \<and> (swaps ss init)!(Suc s)=y)
	\<or> ((swaps ss init)!s=y \<and> (swaps ss init)!(Suc s)=x))"
	let ?co' = "swaps ss init"

	from dinit have dco: "distinct ?co'" by auto

	let ?expr4 = "(\<lambda>z. (if z\<in>{(x,y). ?expr3 x y}
	then 1
	else 0))"

	have scoinit: "set ?co' = set init" by auto
	from isininit have isT: "Suc s < length ?co'" by auto
	then have isT2: "Suc s < length init" by auto
	then have isT3: "s < length init" by auto
	then have isT6: "s < length ?co'" by auto
	from isT2 have isT7: "Suc s < length ?co'" by auto
	from isT6 have a: "?co'!s \<in> set ?co'" by (rule nth_mem)
	then have a: "?co'!s \<in> set init" by auto
	from isT7 have "?co'! (Suc s) \<in> set ?co'" by (rule nth_mem)
	then have b: "?co'!(Suc s) \<in> set init" by auto

	have "{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}
	\<inter> {(x,y). ?expr3 x y}
	= {(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y
	\<and> (?co'!s=x \<and> ?co'!(Suc s)=y
	\<or> ?co'!s=y \<and> ?co'!(Suc s)=x)}" by auto
	also have "\<dots> = {(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y
	\<and> ?co'!s=x \<and> ?co'!(Suc s)=y }
	\<union>
	{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y
	\<and> ?co'!s=y \<and> ?co'!(Suc s)=x}" by auto
	also have "\<dots> = {(x,y). x<y \<and> ?co'!s=x \<and> ?co'!(Suc s)=y}
	\<union>
	{(x,y). x<y \<and> ?co'!s=y \<and> ?co'!(Suc s)=x}"
	using a b by(auto)
	finally have c1: "{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y} \<inter> {(x,y). ?expr3 x y}
	= {(x,y). x<y \<and> ?co'!s=x \<and> ?co'!(Suc s)=y}
	\<union>
	{(x,y). x<y \<and> ?co'!s=y \<and> ?co'!(Suc s)=x}" .

	have c2: "card ({(x,y). x<y \<and> ?co'!s=x \<and> ?co'!(Suc s)=y}
	\<union>
	{(x,y). x<y \<and> ?co'!s=y \<and> ?co'!(Suc s)=x}) = 1" (is "card (?A \<union> ?B) = 1")
	proof (cases "?co'!s<?co'!(Suc s)")
	case True
	then have a: "?A = { (?co'!s, ?co'!(Suc s)) }"
	and b: "?B = {} " by auto
	have c: "?A \<union> ?B = { (?co'!s, ?co'!(Suc s)) }" apply(simp only: a b) by simp
	have "card (?A \<union> ?B) = 1" unfolding c by auto
	then show ?thesis .
	next
	case False
	then have a: "?A = {}" by auto
	have b: "?B = { (?co'!(Suc s), ?co'!s) } "
	proof -
	from dco distinct_conv_nth[of "?co'"]
	have "swaps ss init ! s \<noteq> swaps ss init ! (Suc s)"
	using isT2 isT3 by simp
	with False show ?thesis by auto
	qed

	have c: "?A \<union> ?B = { (?co'!(Suc s), ?co'!s) }" apply(simp only: a b) by simp
	have "card (?A \<union> ?B) = 1" unfolding c by auto
	then show ?thesis .
	qed



	have yeah: "(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr x y) = (1::nat)"
	proof -
	have "(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr x y)
	= (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr2 x y)"
	using isT by auto
	also have "\<dots> = (\<Sum>z\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr2 (fst z) (snd z))"
	by(simp add: split_def)
	also have "\<dots> = (\<Sum>z\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr4 z)"
	by(simp add: split_def)
	also have "\<dots> = (\<Sum>z\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}
	\<inter>{(x,y). ?expr3 x y} . 1)"
	apply(rule sum.inter_restrict[symmetric])
	apply(rule finite_subset[where B="set init \<times> set init"])
	by(auto)
	also have "\<dots> = card ({(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}
	\<inter> {(x,y). ?expr3 x y})" by auto
	also have "\<dots> = card ({(x,y). x<y \<and> ?co'!s=x \<and> ?co'!(Suc s)=y}
	\<union>
	{(x,y). x<y \<and> ?co'!s=y \<and> ?co'!(Suc s)=x})" by(simp only: c1)
	also have "\<dots> = (1::nat)" using c2 by auto
	finally show ?thesis .
	qed

	have "length (s # ss) = 1 + length ss"
	by auto
	also have "\<dots> = 1 + (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P ss x y init)"
	using iH by auto
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr x y)
	+ (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P ss x y init)"
	by(simp only: yeah)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ?expr x y + ALG_P ss x y init)"
	(is "?A + ?B = ?C")
	by (simp add: sum.distrib split_def)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (s#ss) x y init)"
	by auto
	finally show ?case .
	qed (simp)




	(* thesame with paid exchanges *)
	lemma t\<^sub>p_sumofALGALGP:
	assumes "distinct s" "(qs!i)\<in>set s"
	and "\<forall>l< length (snd a). Suc ((snd a)!l) < length s"
	shows "t\<^sub>p s (qs!i) a = (\<Sum>e\<in>set s. ALG e qs i (swaps (snd a) s,()))
	+ (\<Sum>(x,y)\<in>{(x::('a::linorder),y). x \<in> set s \<and> y\<in>set s \<and> x<y}. ALG_P (snd a) x y s)"
	proof -
	(* paid exchanges *)
	have pe: "length (snd a)
	= (\<Sum>(x,y)\<in>{(x,y). x \<in> set s \<and> y\<in>set s \<and> x<y}. ALG_P (snd a) x y s)"
	apply(rule ALG_P_erwischt_alle)
	by(fact)+

	(* access cost *)
	have ac: "index (swaps (snd a) s) (qs ! i) = (\<Sum>e\<in>set s. ALG e qs i (swaps (snd a) s,()))"
	proof -
	have "index (swaps (snd a) s) (qs ! i)
	= (\<Sum>e\<in>set (swaps (snd a) s). if e < (qs ! i) in (swaps (snd a) s) then 1 else 0)"
	apply(rule index_sum)
	using assms by(simp_all)
	also have "\<dots> = (\<Sum>e\<in>set s. ALG e qs i (swaps (snd a) s,()))" by auto
	finally show ?thesis .
	qed

	show ?thesis
	unfolding t\<^sub>p_def apply (simp add: split_def)
	unfolding ac pe by (simp add: split_def)
	qed


	(* given a Strategy Strat to serve request sequence qs on initial list init how many
	swaps between elements x and y occur during the ith step *)
	definition "ALG_P' Strat qs init i x y = ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)"

	(* if n is in bound, Strat may be too long, that does not matter *)
	lemma ALG_P'_rest: "n < length qs \<Longrightarrow> n < length Strat \<Longrightarrow>
	ALG_P' Strat (take n qs @ [qs ! n]) init n x y =
	ALG_P' (take n Strat @ [Strat ! n]) (take n qs @ [qs ! n]) init n x y"
	proof -
	assume qs: "n < length qs"
	assume S: "n < length Strat"

	then have lS: "length (take n Strat) = n" by auto
	have "(take n Strat @ [Strat ! n]) ! n =
	(take n Strat @ (Strat ! n) # []) ! length (take n Strat)" using lS by auto
	also have "\<dots> = Strat ! n" by(rule nth_append_length)
	finally have tt: "(take n Strat @ [Strat ! n]) ! n = Strat ! n" .

	obtain rest where rest: "Strat = (take n Strat @ [Strat ! n] @ rest)"
	using S apply(auto) using id_take_nth_drop by blast

	have "steps' init (take n qs @ [qs ! n])
	(take n Strat @ [Strat ! n]) n
	= steps' init (take n qs)
	(take n Strat) n"
	apply(rule steps'_rests[symmetric])
	using S qs by auto
	also have "\<dots> =
	steps' init (take n qs @ [qs ! n])
	(take n Strat @ ([Strat ! n] @ rest)) n"
	apply(rule steps'_rests)
	using S qs by auto
	finally show ?thesis unfolding ALG_P'_def tt using rest by auto
	qed

	(* verallgemeinert ALG_P'_rest, sollte mergen! *)
	lemma ALG_P'_rest2: "n < length qs \<Longrightarrow> n < length Strat \<Longrightarrow>
	ALG_P' Strat qs init n x y =
	ALG_P' (Strat@r1) (qs@r2) init n x y"
	proof -
	assume qs: "n < length qs"
	assume S: "n < length Strat"

	have tt: "Strat ! n = (Strat @ r1) ! n"
	using S by (simp add: nth_append)

	have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ drop n qs) ((take n Strat) @ (drop n Strat)) n"
	apply(rule steps'_rests)
	using S qs by auto
	then have A: "steps' init (take n qs) (take n Strat) n = steps' init qs Strat n" by auto
	have "steps' init (take n qs) (take n Strat) n = steps' init ((take n qs) @ ((drop n qs)@r2)) ((take n Strat) @((drop n Strat)@r1)) n"
	apply(rule steps'_rests)
	using S qs by auto
	then have B: "steps' init (take n qs) (take n Strat) n = steps' init (qs@r2) (Strat@r1) n"
	by (metis append_assoc List.append_take_drop_id)
	from A B have C: "steps' init qs Strat n = steps' init (qs@r2) (Strat@r1) n" by auto
	show ?thesis unfolding ALG_P'_def tt using C by auto

	qed



	(* total number of swaps of elements x and y during execution of Strategy Strat *)
	definition ALG_Pxy where
	"ALG_Pxy Strat qs init x y = (\<Sum>i<length qs. ALG_P' Strat qs init i x y)"

	lemma wegdamit: "length A < length Strat \<Longrightarrow> b \<notin> {x,y} \<Longrightarrow> ALGxy_det Strat (A @ [b]) init x y
	= ALGxy_det Strat A init x y"
	proof -
	assume bn: "b \<notin> {x,y}"
	have "(A @ [b]) ! (length A) = b" by auto
	assume l: "length A < length Strat"

	term "%i. ALG'_det Strat (A @ [b]) init i y"

	have e: "\<And>i. i<length A \<Longrightarrow> (A @ [b]) ! i = A ! i" by(auto simp: nth_append)
	have "(\<Sum>i\<in> {..< length (A @ [b])}.
	if (A @ [b]) ! i \<in> {y, x}
	then ALG'_det Strat (A @ [b]) init i y +
	ALG'_det Strat (A @ [b]) init i x
	else 0) = (\<Sum>i\<in> {..< Suc(length (A))}.
	if (A @ [b]) ! i \<in> {y, x}
	then ALG'_det Strat (A @ [b]) init i y +
	ALG'_det Strat (A @ [b]) init i x
	else 0)" by auto
	also have "\<dots> = (\<Sum>i\<in> {..< (length (A))}.
	if (A @ [b]) ! i \<in> {y, x}
	then ALG'_det Strat (A @ [b]) init i y +
	ALG'_det Strat (A @ [b]) init i x
	else 0) + ( if (A @ [b]) ! (length A) \<in> {y, x}
	then ALG'_det Strat (A @ [b]) init (length A) y +
	ALG'_det Strat (A @ [b]) init (length A) x
	else 0) " by simp (* abspalten des letzten glieds *)
	also have "\<dots> = (\<Sum>i\<in> {..< (length (A))}.
	if (A @ [b]) ! i \<in> {y, x}
	then ALG'_det Strat (A @ [b]) init i y +
	ALG'_det Strat (A @ [b]) init i x
	else 0)" using bn by auto
	also have "\<dots> = (\<Sum>i\<in> {..< (length (A))}.
	if A ! i \<in> {y, x}
	then ALG'_det Strat A init i y +
	ALG'_det Strat A init i x
	else 0)"
	apply(rule sum.cong)
	apply(simp)
	using l ALG'_det_append[where qs=A] e by(simp)
	finally show ?thesis unfolding ALGxy_det_def by simp
	qed

	lemma ALG_P_split: "length qs < length Strat \<Longrightarrow> ALG_Pxy Strat (qs@[q]) init x y = ALG_Pxy Strat qs init x y
	+ ALG_P' Strat (qs@[q]) init (length qs) x y "
	unfolding ALG_Pxy_def apply(auto)
	apply(rule sum.cong)
	apply(simp)
	using ALG_P'_rest2[symmetric, of _ qs Strat "[]" "[q]"] by(simp)


	lemma swap0in2: assumes "set l = {x,y}" "x\<noteq>y" "length l = 2" "dist_perm l l"
	shows
	"x < y in (swap 0) l = (~ x < y in l)"
	proof (cases "x < y in l")
	case True
	then have a: "index l x < index l y" unfolding before_in_def by simp
	from assms(1) have drin: "x\<in>set l" "y\<in>set l" by auto
	from assms(1,3) have b: "index l y < 2" by simp
	from a b have k: "index l x = 0" "index l y = 1" by auto

	have g: "x = l ! 0" "y = l ! 1"
	using k nth_index assms(1) by force+

	have "x < y in swap 0 l
	= (x < y in l \<and> \<not> (x = l ! 0 \<and> y = l ! Suc 0)
	\<or> x = l ! Suc 0 \<and> y = l ! 0)"
	apply(rule before_in_swap)
	apply(fact assms(4))
	using assms(3) by simp
	also have "\<dots> = (\<not> (x = l ! 0 \<and> y = l ! Suc 0)
	\<or> x = l ! Suc 0 \<and> y = l ! 0)" using True by simp
	also have "\<dots> = False" using g assms(2) by auto
	finally have "~ x < y in (swap 0) l" by simp
	then show ?thesis using True by auto
	next
	case False
	from assms(1,2) have "index l y \<noteq> index l x" by simp
	with False assms(1,2) have a: "index l y < index l x"
	by (metis before_in_def insert_iff linorder_neqE_nat)
	from assms(1) have drin: "x\<in>set l" "y\<in>set l" by auto
	from assms(1,3) have b: "index l x < 2" by simp
	from a b have k: "index l x = 1" "index l y = 0" by auto
	then have g: "x = l ! 1" "y = l ! 0"
	using k nth_index assms(1) by force+
	have "x < y in swap 0 l
	= (x < y in l \<and> \<not> (x = l ! 0 \<and> y = l ! Suc 0)
	\<or> x = l ! Suc 0 \<and> y = l ! 0)"
	apply(rule before_in_swap)
	apply(fact assms(4))
	using assms(3) by simp
	also have "\<dots> = (x = l ! Suc 0 \<and> y = l ! 0)" using False by simp
	also have "\<dots> = True" using g by auto
	finally have "x < y in (swap 0) l" by simp
	then show ?thesis using False by auto
	qed



	lemma before_in_swap2:
	"dist_perm xs ys \<Longrightarrow> Suc n < size xs \<Longrightarrow> x\<noteq>y \<Longrightarrow>
	x < y in (swap n xs) \<longleftrightarrow>
	(~ x < y in xs \<and> (y = xs!n \<and> x = xs!Suc n)
	\<or> x < y in xs \<and> ~(y = xs!Suc n \<and> x = xs!n))"
	apply(simp add:before_in_def index_swap_distinct)
	by (metis Suc_lessD Suc_lessI index_nth_id less_Suc_eq nth_mem yes)

	lemma projected_paid_same_effect:
	assumes
	d: "dist_perm s1 s1"
	and ee: "x\<noteq>y"
	and f: "set s2 = {x, y}"
	and g: "length s2 = 2"
	and h: "dist_perm s2 s2"
	shows "x < y in s1 = x < y in s2 \<Longrightarrow>
	x < y in swaps acs s1 = x < y in (swap 0 ^^ ALG_P acs x y s1) s2"
	proof (induct acs)
	case Nil
	then show ?case by auto
	next
	case (Cons s ss)
	from d have dd: "dist_perm (swaps ss s1) (swaps ss s1)" by simp
	from f have ff: "set ((swap 0 ^^ ALG_P ss x y s1) s2) = {x, y}" by (metis foldr_replicate swaps_inv)
	from g have gg: "length ((swap 0 ^^ ALG_P ss x y s1) s2) = 2" by (metis foldr_replicate swaps_inv)
	from h have hh: "dist_perm ((swap 0 ^^ ALG_P ss x y s1) s2) ((swap 0 ^^ ALG_P ss x y s1) s2)" by (metis foldr_replicate swaps_inv)
	show ?case (is "?LHS = ?RHS")
	proof (cases "Suc s < length (swaps ss s1) \<and> (((swaps ss s1)!s=x \<and> (swaps ss s1)!(Suc s)=y) \<or> ((swaps ss s1)!s=y \<and> (swaps ss s1)!(Suc s)=x))")
	case True
	from True have 1:" Suc s < length (swaps ss s1)"
	and 2: "(swaps ss s1 ! s = x \<and> swaps ss s1 ! Suc s = y
	\<or> swaps ss s1 ! s = y \<and> swaps ss s1 ! Suc s = x)" by auto
	from True have "ALG_P (s # ss) x y s1 = 1 + ALG_P ss x y s1" by auto
	then have "?RHS = x < y in (swap 0) ((swap 0 ^^ ALG_P ss x y s1) s2)"
	by auto
	also have "\<dots> = (~ x < y in ((swap 0 ^^ ALG_P ss x y s1) s2))"
	apply(rule swap0in2)
	by(fact)+
	also have "\<dots> = (~ x < y in swaps ss s1)"
	using Cons by auto
	also have "\<dots> = x < y in (swap s) (swaps ss s1)"
	using 1 2 before_in_swap
	by (metis Suc_lessD before_id dd lessI no_before_inI) (* bad *)
	also have "\<dots> = ?LHS" by auto
	finally show ?thesis by simp
	next
	case False
	note F=this
	then have "ALG_P (s # ss) x y s1 = ALG_P ss x y s1" by auto
	then have "?RHS = x < y in ((swap 0 ^^ ALG_P ss x y s1) s2)"
	by auto
	also have "\<dots> = x < y in swaps ss s1"
	using Cons by auto
	also have "\<dots> = x < y in (swap s) (swaps ss s1)"
	proof (cases "Suc s < length (swaps ss s1)")
	case True
	with F have g: "swaps ss s1 ! s \<noteq> x \<or>
	swaps ss s1 ! Suc s \<noteq> y" and
	h: "swaps ss s1 ! s \<noteq> y \<or>
	swaps ss s1 ! Suc s \<noteq> x" by auto
	show ?thesis
	unfolding before_in_swap[OF dd True, of x y] apply(simp)
	using g h by auto
	next
	case False
	then show ?thesis unfolding swap_def by(simp)
	qed
	also have "\<dots> = ?LHS" by auto
	finally show ?thesis by simp
	qed
	qed


	lemma steps_steps':
	"length qs = length as \<Longrightarrow> steps s qs as = steps' s qs as (length as)"
	by (induct qs as arbitrary: s rule: list_induct2) (auto)


	lemma T1_7': "T\<^sub>p init qs Strat = T\<^sub>p_opt init qs \<Longrightarrow> length Strat = length qs
	\<Longrightarrow> n\<le>length qs \<Longrightarrow>
	x\<noteq>(y::('a::linorder)) \<Longrightarrow>
	x\<in> set init \<Longrightarrow> y \<in> set init \<Longrightarrow> distinct init \<Longrightarrow>
	set qs \<subseteq> set init \<Longrightarrow>
	(\<exists>Strat2 sws.
	\<^cancel>\<open>T\<^sub>p_opt (Lxy init {x,y}) (Lxy (take n qs) {x,y}) \<le> T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2
	\<and>\<close> length Strat2 = length (Lxy (take n qs) {x,y})
	\<and> (x < y in (steps' init (take n qs) (take n Strat) n))
	= (x < y in (swaps sws (steps' (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2 (length Strat2))))
	\<and> T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x,y}) Strat2 + length sws =
	ALGxy_det Strat (take n qs) init x y + ALG_Pxy Strat (take n qs) init x y)"
	proof(induct n)
	case (Suc n)
	from Suc(3,4) have ns: "n < length qs" by simp
	then have n: "n \<le> length qs" by simp
	from Suc(1)[OF Suc(2) Suc(3) n Suc(5) Suc(6) Suc(7) Suc(8) Suc(9) ] obtain Strat2 sws where
	(*S2: "T\<^sub>p_opt (Lxy init {x,y}) (Lxy (take n qs) {x, y})
	\<le> T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2"
	and *) len: "length Strat2 = length (Lxy (take n qs) {x, y})"
	and iff:
	"x < y in steps' init (take n qs) (take n Strat) n
	=
	x < y in swaps sws (steps' (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2))"

	and T_Strat2: "T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 + length sws =
	ALGxy_det Strat (take n qs) init x y +
	ALG_Pxy Strat (take n qs) init x y " by (auto)

	from Suc(3-4) have nStrat: "n < length Strat" by auto
	from take_Suc_conv_app_nth[OF this] have tak2: "take (Suc n) Strat = take n Strat @ [Strat ! n]" by auto


	from take_Suc_conv_app_nth[OF ns] have tak: "take (Suc n) qs = take n qs @ [qs ! n]" by auto

	have aS: "length (take n Strat) = n" using Suc(3,4) by auto
	have aQ: "length (take n qs) = n" using Suc(4) by auto
	from aS aQ have qQS: "length (take n qs) = length (take n Strat)" by auto

	have xyininit: "x\<in> set init" "y : set init" by fact+
	then have xysubs: "{x,y} \<subseteq> set init" by auto
	have dI: "distinct init" by fact
	have "set qs \<subseteq> set init" by fact
	then have qsnset: "qs ! n \<in> set init" using ns by auto

	from xyininit have ahjer: "set (Lxy init {x, y}) = {x,y}"
	using xysubs by (simp add: Lxy_set_filter)
	with Suc(5) have ah: "card (set (Lxy init {x, y})) = 2" by simp
	have ahjer3: "distinct (Lxy init {x,y})"
	apply(rule Lxy_distinct) by fact
	from ah have ahjer2: "length (Lxy init {x,y}) = 2"
	using distinct_card[OF ahjer3] by simp

	show ?case
	proof (cases "qs ! n \<in> {x,y}")
	case False
	with tak have nixzutun: "Lxy (take (Suc n) qs) {x,y} = Lxy (take n qs) {x,y}"
	unfolding Lxy_def by simp
	let ?m="ALG_P' (take n Strat @ [Strat ! n]) (take n qs @ [qs ! n]) init n x y"
	let ?L="replicate ?m 0 @ sws"

	{
	fix xs::"('a::linorder) list"
	fix m::nat
	fix q::'a
	assume "q \<notin> {x,y}"
	then have 5: "y \<noteq> q" by auto
	assume 1: "q \<in> set xs"
	assume 2: "distinct xs"
	assume 3: "x \<in> set xs"
	assume 4: "y \<in> set xs"
	have "(x < y in xs) = (x < y in (mtf2 m q xs))"
	by (metis "1" "2" "3" "4" \<open>q \<notin> {x, y}\<close> insertCI not_before_in set_mtf2 swapped_by_mtf2)
	} note f=this

	(* taktik, erstmal das mtf weg bekommen,
	dann induct über snd (Strat!n) *)
	have "(x < y in steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n))
	= (x < y in mtf2 (fst (Strat ! n)) (qs ! n)
	(swaps (snd (Strat ! n)) (steps' init (take n qs) (take n Strat) n)))"
	unfolding tak2 tak apply(simp only: steps'_append[OF qQS aQ] )
	by (simp add: step_def split_def)
	also have "\<dots> = (x < y in (swaps (snd (Strat ! n)) (steps' init (take n qs) (take n Strat) n)))"
	apply(rule f[symmetric])
	apply(fact)
	using qsnset steps'_set[OF qQS] aS apply(simp)
	using steps'_distinct[OF qQS] aS dI apply(simp)
	using steps'_set[OF qQS] aS xyininit by simp_all
	also have "\<dots> = x < y in (swap 0 ^^ ALG_P (snd (Strat ! n)) x y (steps' init (take n qs) (take n Strat) n))
	(swaps sws (steps' (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2)))"
	apply(rule projected_paid_same_effect)
	apply(rule steps'_dist_perm)
	apply(fact qQS)
	apply(fact aS)
	using dI apply(simp)
	apply(fact Suc(5))
	apply(simp)
	apply(rule steps'_set[where s="Lxy init {x,y}", unfolded ahjer])
	using len apply(simp)
	apply(simp)
	apply(simp)
	apply(rule steps'_length[where s="Lxy init {x,y}", unfolded ahjer2])
	using len apply(simp)
	apply(simp)
	apply(simp)
	apply(rule steps'_distinct2[where s="Lxy init {x,y}"])
	using len apply(simp)
	apply(simp)
	apply(fact)
	using iff by auto

	finally have umfa: "x < y in steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n) =
	x < y
	in (swap 0 ^^ ALG_P (snd (Strat ! n)) x y (steps' init (take n qs) (take n Strat) n))
	(swaps sws (steps' (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2 (length Strat2)))" .

	from Suc(3,4) have lS: "length (take n Strat) = n" by auto
	have "(take n Strat @ [Strat ! n]) ! n =
	(take n Strat @ (Strat ! n) # []) ! length (take n Strat)" using lS by auto
	also have "\<dots> = Strat ! n" by(rule nth_append_length)
	finally have tt: "(take n Strat @ [Strat ! n]) ! n = Strat ! n" .

	show ?thesis
	apply(rule exI[where x="Strat2"])
	apply(rule exI[where x="?L"])
	unfolding nixzutun
	apply(safe)
	apply(fact)
	proof goal_cases
	case 1
	show ?case
	unfolding tak2 tak
	apply(simp add: step_def split_def)
	unfolding ALG_P'_def
	unfolding tt
	using aS apply(simp only: steps'_rests[OF qQS, symmetric])
	using 1(1) umfa by auto
	next
	case 2
	then show ?case
	apply(simp add: step_def split_def)
	unfolding ALG_P'_def
	unfolding tt
	using aS apply(simp only: steps'_rests[OF qQS, symmetric])
	using umfa[symmetric] by auto
	next
	case 3
	have ns2: "n < length (take n qs @ [qs ! n])"
	using ns by auto

	have er: "length (take n qs) < length Strat"
	using Suc.prems(2) aQ ns by linarith

	have "T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
	+ length (replicate (ALG_P' Strat (take n qs @ [qs ! n]) init n x y) 0 @ sws)
	= ( T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2 + length sws)
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y" by simp

	also have "\<dots> = ALGxy_det Strat (take n qs) init x y +
	ALG_Pxy Strat (take n qs) init x y +
	ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	unfolding T_Strat2 by simp
	also
	have "\<dots> = ALGxy_det Strat (take (Suc n) qs) init x y
	+ ALG_Pxy Strat (take (Suc n) qs) init x y"
	unfolding tak unfolding wegdamit[OF er False] apply(simp)
	unfolding ALG_P_split[of "take n qs" Strat "qs ! n" init x y, unfolded aQ, OF nStrat]
	by(simp)
	finally show ?case unfolding tak using ALG_P'_rest[OF ns nStrat] by auto
	qed
	next
	case True
	note qsinxy=this
	then have yeh: "Lxy (take (Suc n) qs) {x, y} = Lxy (take n qs) {x,y} @ [qs!n]"
	unfolding tak Lxy_def by auto

	from True have garar: "(take n qs @ [qs ! n]) ! n \<in> {y, x}"
	using tak[symmetric] by(auto)
	have aer: "\<forall>i<n.
	((take n qs @ [qs ! n]) ! i \<in> {y, x})
	= (take n qs ! i \<in> {y, x})" using ns by (metis less_SucI nth_take tak)

	(* erst definiere ich die zwischenzeitlichen Configurationen
	?xs \<rightarrow> ?xs' \<rightarrow> ?xs''
	und
	?ys \<rightarrow> ?ys' \<rightarrow> ?ys'' \<rightarrow> ?ys'''

	und einige Eigenschaften über sie
	*)

	(* what is the mtf action taken by Strat? *)
	let ?Strat_mft = "fst (Strat ! n)"
	let ?Strat_sws = "snd (Strat ! n)"
	(* what is the configuration before the step? *)
	let ?xs = "steps' init (take n qs) (take n Strat) n"
	(* what is the configuration before the mtf *)
	let ?xs' = "(swaps (snd (Strat!n)) ?xs)"
	let ?xs'' = "steps' init (take (Suc n) qs) (take (Suc n) Strat) (Suc n)"
	let ?xs''2 = "mtf2 ?Strat_mft (qs!n) ?xs'"
	(* position of requested element *)
	let ?no_swap_occurs = "(x < y in ?xs') = (x < y in ?xs''2)"

	let ?mtf="(if ?no_swap_occurs then 0 else 1::nat)"
	let ?m="ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	let ?L="replicate ?m 0 @ sws"

	let ?newStrat="Strat2@[(?mtf,?L)]"

	have "?xs'' = step ?xs (qs!n) (Strat!n)"
	unfolding tak tak2
	apply(rule steps'_append) by fact+
	also have "\<dots> = mtf2 (fst (Strat!n)) (qs!n) (swaps (snd (Strat!n)) ?xs)" unfolding step_def
	by (auto simp: split_def)
	finally have A: "?xs'' = mtf2 (fst (Strat!n)) (qs!n) ?xs'" .

	let ?ys = "(steps' (Lxy init {x, y})
	(Lxy (take n qs) {x, y}) Strat2 (length Strat2))"
	let ?ys' = "( swaps sws (steps' (Lxy init {x, y})
	(Lxy (take n qs) {x, y}) Strat2 (length Strat2)))"
	let ?ys'' = " (swap 0 ^^ ALG_P (snd (Strat!n)) x y ?xs) ?ys'"
	let ?ys''' = "(steps' (Lxy init {x, y}) (Lxy (take (Suc n) qs) {x, y}) ?newStrat (length ?newStrat))"

	have gr: "Lxy (take n qs @ [qs ! n]) {x, y} =
	Lxy (take n qs) {x, y} @ [qs ! n]" unfolding Lxy_def using True by(simp)

	have "steps' init (take n qs @ [qs ! n]) Strat n
	= steps' init (take n qs @ [qs ! n]) (take n Strat @ drop n Strat) n" by simp
	also have "\<dots> = steps' init (take n qs) (take n Strat) n"
	apply(subst steps'_rests[symmetric]) using aS qQS by(simp_all)
	finally have t: "steps' init (take n qs @ [qs ! n]) Strat n
	= steps' init (take n qs) (take n Strat) n" .
	have gge: "swaps (replicate ?m 0) ?ys'
	= (swap 0 ^^ ALG_P (snd (Strat!n)) x y ?xs) ?ys'"
	unfolding ALG_P'_def t by simp

	have gg: "length ?newStrat = Suc (length Strat2)" by auto
	have "?ys''' = step ?ys (qs!n) (?mtf,?L)"
	unfolding tak gr unfolding gg
	apply(rule steps'_append)
	using len by auto
	also have "\<dots> = mtf2 ?mtf (qs!n) (swaps ?L ?ys)"
	unfolding step_def by (simp add: split_def)
	also have "\<dots> = mtf2 ?mtf (qs!n) (swaps (replicate ?m 0) ?ys')"
	by (simp)
	also have "\<dots> = mtf2 ?mtf (qs!n) ?ys''"
	using gge by (simp)
	finally have B: "?ys''' = mtf2 ?mtf (qs!n) ?ys''" .

	have 3: "set ?ys' = {x,y}"
	apply(simp add: swaps_inv) apply(subst steps'_set) using ahjer len by(simp_all)
	have k: "?ys'' = swaps (replicate (ALG_P (snd (Strat!n)) x y ?xs) 0) ?ys'"
	by (auto)
	have 6: "set ?ys'' = {x,y}" unfolding k using 3 swaps_inv by metis
	have 7: "set ?ys''' = {x,y}" unfolding B using set_mtf2 6 by metis
	have 22: "x \<in> set ?ys''" "y \<in> set ?ys''" using 6 by auto
	have 23: "x \<in> set ?ys'''" "y \<in> set ?ys'''" using 7 by auto

	have 26: "(qs!n) \<in> set ?ys''" using 6 True by auto

	have "distinct ?ys" apply(rule steps'_distinct2)
	using len ahjer3 by(simp)+
	then have 9: "distinct ?ys'" using swaps_inv by metis
	then have 27: "distinct ?ys''" unfolding k using swaps_inv by metis

	from 3 Suc(5) have "card (set ?ys') = 2" by auto
	then have 4: "length ?ys' = 2" using distinct_card[OF 9] by simp
	have "length ?ys'' = 2" unfolding k using 4 swaps_inv by metis
	have 5: "dist_perm ?ys' ?ys'" using 9 by auto

	have sxs: "set ?xs = set init" apply(rule steps'_set) using qQS n Suc(3) by(auto)
	have sxs': "set ?xs' = set ?xs" using swaps_inv by metis
	have sxs'': "set ?xs'' = set ?xs'" unfolding A using set_mtf2 by metis
	have 24: "x \<in> set ?xs'" "y\<in>set ?xs'" "(qs!n) \<in> set ?xs'"
	using xysubs True sxs sxs' by auto
	have 28: "x \<in> set ?xs''" "y\<in>set ?xs''" "(qs!n) \<in> set ?xs''"
	using xysubs True sxs sxs' sxs'' by auto

	have 0: "dist_perm init init" using dI by auto
	have 1: "dist_perm ?xs ?xs" apply(rule steps'_dist_perm)
	by fact+
	then have 25: "distinct ?xs'" using swaps_inv by metis


	(* aus der Induktionsvorraussetzung (iff) weiß ich bereits
	dass die Ordnung erhalten wird bis zum nten Schritt,
	mit Theorem "projected_paid_same_effect" kann ich auch die paid exchanges abarbeiten ...*)

	from projected_paid_same_effect[OF 1 Suc(5) 3 4 5, OF iff, where acs="snd (Strat ! n)"]
	have aaa: "x < y in ?xs' = x < y in ?ys''" .

	(* ... was nun noch fehlt ist, dass die moveToFront anweisungen von Strat
	und Strat2 sich in gleicher Art auf die Ordnung von x und y auswirken
	*)

	have t: "?mtf = (if (x<y in ?xs') = (x<y in ?xs'') then 0 else 1)"
	by (simp add: A)

	have central: "x < y in ?xs'' = x < y in ?ys'''"
	proof (cases "(x<y in ?xs') = (x<y in ?xs'')")
	case True
	then have "?mtf = 0" using t by auto
	with B have "?ys''' = ?ys''" by auto
	with aaa True show ?thesis by auto
	next
	case False
	then have k: "?mtf = 1" using t by auto
	from False have i: "(x<y in ?xs') = (~x<y in ?xs'')" by auto

	have gn: "\<And>a b. a\<in>{x,y} \<Longrightarrow> b\<in>{x,y} \<Longrightarrow> set ?ys'' = {x,y} \<Longrightarrow>
	a\<noteq>b \<Longrightarrow> distinct ?ys'' \<Longrightarrow>
	a<b in ?ys'' \<Longrightarrow> ~a<b in mtf2 1 b ?ys''"
	proof goal_cases
	case (1 a b)
	from 1 have f: "set ?ys'' = {a,b}" by auto
	with 1 have i: "card (set ?ys'') = 2" by auto
	from 1(5) have "dist_perm ?ys'' ?ys''" by auto
	from i distinct_card 1(5) have g: "length ?ys'' = 2" by metis
	with 1(6) have d: "index ?ys'' b = 1"
	using before_in_index2 f 1(4) by fastforce
	from 1(2,3) have e: "b \<in> set ?ys''" by auto

	from d e have p: "mtf2 1 b ?ys'' = swap 0 ?ys''"
	unfolding mtf2_def by auto
	have q: "a < b in swap 0 ?ys'' = (\<not> a < b in ?ys'')"
	apply(rule swap0in2) by(fact)+
	from 1(6) p q show ?case by metis
	qed

	show ?thesis
	proof (cases "x<y in ?xs'")
	case True
	with aaa have st: "x < y in ?ys''" by auto
	from True False have "~ x<y in ?xs''" by auto
	with Suc(5) 28 not_before_in A have "y < x in ?xs''" by metis
	with A have "y < x in mtf2 (fst (Strat!n)) (qs!n) ?xs'" by auto
	(from True swapped_by_mtf2)
	have itisy: "y = (qs!n)"
	apply(rule swapped_by_mtf2[where xs= ?xs'])
	apply(fact)
	apply(fact)
	apply(fact 24)
	apply(fact 24)
	by(fact)+
	have "~x<y in mtf2 1 y ?ys''"
	apply(rule gn)
	apply(simp)
	apply(simp)
	apply(simp add: 6)
	by(fact)+
	then have ts: "~x<y in ?ys'''" using B itisy k by auto
	have ii: "(x<y in ?ys'') = (~x<y in ?ys''')" using st ts by auto
	from i ii aaa show ?thesis by metis
	next
	case False
	with aaa have st: "~ x < y in ?ys''" by auto
	with Suc(5) 22 not_before_in have st: "y < x in ?ys''" by metis
	from i False have kl: "x<y in ?xs''" by auto
	with A have "x < y in mtf2 (fst (Strat!n)) (qs!n) ?xs'" by auto
	from False Suc(5) 24 not_before_in have "y < x in ?xs'" by metis
	have itisx: "x = (qs!n)"
	apply(rule swapped_by_mtf2[where xs= ?xs'])
	apply(fact)
	apply(fact)
	apply(fact 24(2))
	apply(fact 24)
	by(fact)+
	have "~y<x in mtf2 1 x ?ys''"
	apply(rule gn)
	apply(simp)
	apply(simp)
	apply(simp add: 6)
	apply(metis Suc(5))
	by(fact)+
	then have "~y<x in ?ys'''" using itisx k B by auto
	with Suc(5) not_before_in 23 have "x<y in ?ys'''" by metis
	with st have "(x<y in ?ys'') = (~x<y in ?ys''')" using B k by auto
	with i aaa show ?thesis by metis
	qed
	qed

	show ?thesis
	apply(rule exI[where x="?newStrat"])
	apply(rule exI[where x="[]"])
	proof (standard, goal_cases)
	case 1
	show ?case unfolding yeh using len by(simp)
	next
	case 2
	show ?case
	proof (standard, goal_cases)
	case 1
	(* hier beweise ich also, dass die ordnung von x und y in der projezierten
	Ausführung (von Strat2) der Ordnung von x und y in der Ausführung
	von Strat entspricht *)
	from central show ?case by auto
	next
	case 2
	(* nun muss noch bewiesen werden, dass die Kosten sich richtig aufspalten:
	Kosten für Strat2 + \|sws\|
	= blocking kosten von x,y + paid exchange kosten von x,y
	*)
	have j: "ALGxy_det Strat (take (Suc n) qs) init x y =
	ALGxy_det Strat (take n qs) init x y
	+ (ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)"
	proof -
	have "ALGxy_det Strat (take (Suc n) qs) init x y =
	(\<Sum>i\<in>{..<length (take n qs @ [qs ! n])}.
	if (take n qs @ [qs ! n]) ! i \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init i y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init i x
	else 0)" unfolding ALGxy_det_def tak by auto
	also have "\<dots>
	= (\<Sum>i\<in>{..<Suc n}.
	if (take n qs @ [qs ! n]) ! i \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init i y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init i x
	else 0)" using ns by simp
	also have "\<dots> = (\<Sum>i\<in>{..<n}.
	if (take n qs @ [qs ! n]) ! i \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init i y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init i x
	else 0)
	+ (if (take n qs @ [qs ! n]) ! n \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init n y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init n x
	else 0)" by simp
	also have "\<dots> = (\<Sum>i\<in>{..< n}.
	if take n qs ! i \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init i y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init i x
	else 0)
	+ ALG'_det Strat (take n qs @ [qs ! n]) init n y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init n x "
	using aer using garar by simp
	also have "\<dots> = (\<Sum>i\<in>{..< n}.
	if take n qs ! i \<in> {y, x}
	then ALG'_det Strat (take n qs @ [qs ! n]) init i y
	+ ALG'_det Strat (take n qs @ [qs ! n]) init i x
	else 0)
	+ ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
	proof -
	have "ALG'_det Strat qs init n y
	= ALG'_det Strat ((take n qs @ [qs ! n]) @ drop (Suc n) qs) init n y"
	unfolding tak[symmetric] by auto
	also have "\<dots> = ALG'_det Strat (take n qs @ [qs ! n]) init n y "
	apply(rule ALG'_det_append) using nStrat ns by(auto)
	finally have 1: "ALG'_det Strat qs init n y = ALG'_det Strat (take n qs @ [qs ! n]) init n y" .
	have "ALG'_det Strat qs init n x
	= ALG'_det Strat ((take n qs @ [qs ! n]) @ drop (Suc n) qs) init n x"
	unfolding tak[symmetric] by auto
	also have "\<dots> = ALG'_det Strat (take n qs @ [qs ! n]) init n x "
	apply(rule ALG'_det_append) using nStrat ns by(auto)
	finally have 2: "ALG'_det Strat qs init n x = ALG'_det Strat (take n qs @ [qs ! n]) init n x" .
	from 1 2 show ?thesis by auto
	qed
	also have "\<dots> = (\<Sum>i\<in>{..< n}.
	if take n qs ! i \<in> {y, x}
	then ALG'_det Strat (take n qs) init i y
	+ ALG'_det Strat (take n qs) init i x
	else 0)
	+ ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
	apply(simp)
	apply(rule sum.cong)
	apply(simp)
	apply(simp)
	using ALG'_det_append[where qs="take n qs"] Suc.prems(2) ns by auto
	also have "\<dots> = (\<Sum>i\<in>{..< length(take n qs)}.
	if take n qs ! i \<in> {y, x}
	then ALG'_det Strat (take n qs) init i y
	+ ALG'_det Strat (take n qs) init i x
	else 0)
	+ ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
	using aQ by auto
	also have "\<dots> = ALGxy_det Strat (take n qs) init x y
	+ (ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)"
	unfolding ALGxy_det_def by(simp)
	finally show ?thesis .
	qed

	(*
	aaa: x < y in ?xs' = x < y in ?ys''
	central: x < y in ?xs'' = x < y in ?ys'''
	*)

	have list: "?ys' = swaps sws (steps (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2)"
	unfolding steps_steps'[OF len[symmetric], of "(Lxy init {x, y})"] by simp

	have j2: "steps' init (take n qs @ [qs ! n]) Strat n
	= steps' init (take n qs) (take n Strat) n"
	proof -
	have "steps' init (take n qs @ [qs ! n]) Strat n
	= steps' init (take n qs @ [qs ! n]) (take n Strat @ drop n Strat) n"
	by auto
	also have "\<dots> = steps' init (take n qs) (take n Strat) n"
	apply(rule steps'_rests[symmetric]) apply fact using aS by simp
	finally show ?thesis .
	qed

	have arghschonwieder: "steps' init (take n qs) (take n Strat) n
	= steps' init qs Strat n"
	proof -
	have "steps' init qs Strat n
	= steps' init (take n qs @ drop n qs) (take n Strat @ drop n Strat) n"
	by auto
	also have "\<dots> = steps' init (take n qs) (take n Strat) n"
	apply(rule steps'_rests[symmetric]) apply fact using aS by simp
	finally show ?thesis by simp
	qed

	have indexe: "((swap 0 ^^ ?m) (swaps sws
	(steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2)))
	= ?ys''" unfolding ALG_P'_def unfolding list using j2 by auto

	have blocky: "ALG'_det Strat qs init n y
	= (if y < qs ! n in ?xs' then 1 else 0)"
	unfolding ALG'_det_def ALG.simps by(auto simp: arghschonwieder split_def)
	have blockx: "ALG'_det Strat qs init n x
	= (if x < qs ! n in ?xs' then 1 else 0)"
	unfolding ALG'_det_def ALG.simps by(auto simp: arghschonwieder split_def)

	have index_is_blocking_cost: "index ((swap 0 ^^ ?m) (swaps sws
	(steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n)
	= ALG'_det Strat qs init n y + ALG'_det Strat qs init n x"
	proof (cases "x= qs!n")
	case True
	then have "ALG'_det Strat qs init n x = 0"
	unfolding blockx apply(simp) using before_in_irefl by metis
	then have "ALG'_det Strat qs init n y + ALG'_det Strat qs init n x
	= (if y < x in ?xs' then 1 else 0)" unfolding blocky using True by simp
	also have "\<dots> = (if ~y < x in ?xs' then 0 else 1)" by auto
	also have "\<dots> = (if x < y in ?xs' then 0 else 1)"
	apply(simp) by (meson 24 Suc.prems(4) not_before_in)
	also have "\<dots> = (if x < y in ?ys'' then 0 else 1)" using aaa by simp
	also have "\<dots> = index ?ys'' x"
	apply(rule before_in_index1) by(fact)+
	finally show ?thesis unfolding indexe using True by auto
	next
	case False
	then have q: "y = qs!n" using qsinxy by auto
	then have "ALG'_det Strat qs init n y = 0"
	unfolding blocky apply(simp) using before_in_irefl by metis
	then have "ALG'_det Strat qs init n y + ALG'_det Strat qs init n x
	= (if x < y in ?xs' then 1 else 0)" unfolding blockx using q by simp
	also have "\<dots> = (if x < y in ?ys'' then 1 else 0)" using aaa by simp
	also have "\<dots> = index ?ys'' y"
	apply(rule before_in_index2) by(fact)+
	finally show ?thesis unfolding indexe using q by auto
	qed

	have jj: "ALG_Pxy Strat (take (Suc n) qs) init x y =
	ALG_Pxy Strat (take n qs) init x y
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	proof -
	have "ALG_Pxy Strat (take (Suc n) qs) init x y
	= (\<Sum>i<length (take (Suc n) qs). ALG_P' Strat (take (Suc n) qs) init i x y)"
	unfolding ALG_Pxy_def by simp
	also have "\<dots> = (\<Sum>i< Suc n. ALG_P' Strat (take (Suc n) qs) init i x y)"
	unfolding tak using ns by simp
	also have "\<dots> = (\<Sum>i<n. ALG_P' Strat (take (Suc n) qs) init i x y)
	+ ALG_P' Strat (take (Suc n) qs) init n x y"
	by simp
	also have "\<dots> = (\<Sum>i<length (take n qs). ALG_P' Strat (take n qs @ [qs ! n]) init i x y)
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	unfolding tak using ns by auto
	also have "\<dots> = (\<Sum>i<length (take n qs). ALG_P' Strat (take n qs) init i x y)
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y" (is "?A + ?B = ?A' + ?B")
	proof -
	have "?A = ?A'"
	apply(rule sum.cong)
	apply(simp)
	proof goal_cases
	case 1
	show ?case
	apply(rule ALG_P'_rest2[symmetric, where ?r1.0="[]", simplified])
	using 1 apply(simp)
	using 1 nStrat by(simp)
	qed
	then show ?thesis by auto
	qed
	also have "\<dots> = ALG_Pxy Strat (take n qs) init x y
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	unfolding ALG_Pxy_def by auto
	finally show ?thesis .
	qed

	have tw: "length (Lxy (take n qs) {x, y}) = length Strat2"
	using len by auto
	have "T\<^sub>p (Lxy init {x,y}) (Lxy (take (Suc n) qs) {x, y}) ?newStrat + length []
	= T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
	+ t\<^sub>p (steps (Lxy init {x, y}) (Lxy (take n qs) {x, y}) Strat2) (qs ! n) (?mtf,?L)"
	unfolding yeh
	by(simp add: T_append[OF tw, of "(Lxy init) {x,y}"])
	also have "\<dots> =
	T\<^sub>p (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2
	+ length sws
	+ index ((swap 0 ^^ ?m) (swaps sws
	(steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n)
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y"
	by(simp add: t\<^sub>p_def)
	(* now use iH *)
	also have "\<dots> = (ALGxy_det Strat (take n qs) init x y
	+ index ((swap 0 ^^ ?m) (swaps sws
	(steps (Lxy init {x,y}) (Lxy (take n qs) {x, y}) Strat2))) (qs ! n))
	+ (ALG_Pxy Strat (take n qs) init x y
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y)"
	by (simp only: T_Strat2)
	(* the current cost are equal to the blocking costs: *)
	also from index_is_blocking_cost have "\<dots> = (ALGxy_det Strat (take n qs) init x y
	+ ALG'_det Strat qs init n y + ALG'_det Strat qs init n x)
	+ (ALG_Pxy Strat (take n qs) init x y
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y)" by auto
	also have "\<dots> = ALGxy_det Strat (take (Suc n) qs) init x y
	+ (ALG_Pxy Strat (take n qs) init x y
	+ ALG_P' Strat (take n qs @ [qs ! n]) init n x y)" using j by auto
	also have "\<dots> = ALGxy_det Strat (take (Suc n) qs) init x y
	+ ALG_Pxy Strat (take (Suc n) qs) init x y" using jj by auto
	finally show ?case .
	qed
	qed
	qed
	next
	case 0
	then show ?case
	apply (simp add: Lxy_def ALGxy_det_def ALG_Pxy_def T_opt_def)
	proof goal_cases
	case 1
	show ?case apply(rule Lxy_mono[unfolded Lxy_def, simplified])
	using 1 by auto
	qed
	qed


	lemma T1_7:
	assumes "T\<^sub>p init qs Strat = T\<^sub>p_opt init qs" "length Strat = length qs"
	"x \<noteq> (y::('a::linorder))" "x\<in> set init" "y \<in> set init" "distinct init"
	"set qs \<subseteq> set init"
	shows "T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y})
	\<le> ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y"
	proof -
	have A:"length qs \<le> length qs" by auto
	have B:" x \<noteq> y " using assms by auto

	from T1_7'[OF assms(1,2), of "length qs" x y, OF A B assms(4-7)]
	obtain Strat2 sws where
	len: "length Strat2 = length (Lxy qs {x, y})"
	and "x < y in steps' init qs (take (length qs) Strat)
	(length qs) = x < y in swaps sws (steps' (Lxy init {x,y})
	(Lxy qs {x, y}) Strat2 (length Strat2))"
	and Tp: "T\<^sub>p (Lxy init {x,y}) (Lxy qs {x, y}) Strat2 + length sws
	= ALGxy_det Strat qs init x y
	+ ALG_Pxy Strat qs init x y" by auto

	have "T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y}) \<le> T\<^sub>p (Lxy init {x,y}) (Lxy qs {x, y}) Strat2"
	unfolding T_opt_def
	apply(rule cInf_lower)
	using len by auto
	also have "\<dots> \<le> ALGxy_det Strat qs init x y
	+ ALG_Pxy Strat qs init x y" using Tp by auto
	finally show ?thesis .
	qed

	lemma T_snoc: "length rs = length as
	\<Longrightarrow> T init (rs@[r]) (as@[a])
	= T init rs as + t\<^sub>p (steps' init rs as (length rs)) r a"
	apply(induct rs as arbitrary: init rule: list_induct2) by simp_all

	lemma steps'_snoc: "length rs = length as \<Longrightarrow> n = (length as)
	\<Longrightarrow> steps' init (rs@[r]) (as@[a]) (Suc n) = step (steps' init rs as n) r a"
	apply(induct rs as arbitrary: init n r a rule: list_induct2)
	by (simp_all)

	lemma steps'_take:
	assumes "n<length qs" "length qs = length Strat"
	shows "steps' init (take n qs) (take n Strat) n
	= steps' init qs Strat n"
	proof -
	have "steps' init qs Strat n =
	steps' init (take n qs @ drop n qs) (take n Strat @ drop n Strat) n" by simp
	also have "\<dots> = steps' init (take n qs) (take n Strat) n"
	apply(subst steps'_rests[symmetric]) using assms by auto
	finally show ?thesis by simp
	qed

	lemma Tp_darstellung: "length qs = length Strat
	\<Longrightarrow> T\<^sub>p init qs Strat =
	(\<Sum>i\<in>{..<length qs}. t\<^sub>p (steps' init qs Strat i) (qs!i) (Strat!i))"
	proof -
	assume a[simp]: "length qs = length Strat"
	{fix n
	have "n\<le>length qs
	\<Longrightarrow> T\<^sub>p init (take n qs) (take n Strat) =
	(\<Sum>i\<in>{..<n}. t\<^sub>p (steps' init qs Strat i) (qs!i) (Strat!i))"
	apply(induct n)
	apply(simp)
	apply(simp add: take_Suc_conv_app_nth)
	apply(subst T_snoc)
	apply(simp)
	by(simp add: min_def steps'_take)
	}
	from a this[of "length qs"] show ?thesis by auto
	qed


	(* Gleichung 1.8 in Borodin *)
	lemma umformung_OPT':
	assumes inlist: "set qs \<subseteq> set init"
	assumes dist: "distinct init"
	assumes qsStrat: "length qs = length Strat"
	assumes noStupid: "\<And>x l. x<length Strat \<Longrightarrow> l< length (snd (Strat ! x)) \<Longrightarrow> Suc ((snd (Strat ! x))!l) < length init"
	shows "T\<^sub>p init qs Strat =
	(\<Sum>(x,y)\<in>{(x,y::('a::linorder)). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
	proof -
	(* have config_dist: "\<forall>n. \<forall>xa \<in> set_pmf (config\<^sub>p (I, S) qs init n). distinct (snd xa)"
	using dist config_rand_distinct by metis
	*)

	(* ersten Teil umformen: *)
	have "(\<Sum>i\<in>{..<length qs}.
	(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )
	= (\<Sum>i\<in>{..<length qs}.
	(\<Sum>z\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) (fst z) (snd z) (steps' init qs Strat i)) )"
	by(auto simp: split_def)
	also have "\<dots>
	= (\<Sum>z\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{..<length qs}. ALG_P (snd (Strat!i)) (fst z) (snd z) (steps' init qs Strat i)) )"
	by(rule sum.swap)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{..<length qs}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
	by(auto simp: split_def)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALG_Pxy Strat qs init x y)"
	unfolding ALG_P'_def ALG_Pxy_def by auto
	finally have paid_part: "(\<Sum>i\<in>{..<length qs}.
	(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )
	= (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALG_Pxy Strat qs init x y)" .

	(* zweiten Teil umformen: *)

	let ?config = "(%i. swaps (snd (Strat!i)) (steps' init qs Strat i))"

	have "(\<Sum>i\<in>{..<length qs}.
	(\<Sum>e\<in>set init. ALG e qs i (?config i, ())))
	= (\<Sum>e\<in>set init.
	(\<Sum>i\<in>{..<length qs}. ALG e qs i (?config i, ())))"
	by(rule sum.swap)
	also have "\<dots> = (\<Sum>e\<in>set init.
	(\<Sum>y\<in>set init.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG e qs i (?config i,()))))"
	proof (rule sum.cong, goal_cases)
	case (2 x)
	have "(\<Sum>i<length qs. ALG x qs i (?config i, ()))
	= sum (%i. ALG x qs i (?config i, ())) {i. i<length qs}"
	by (simp add: lessThan_def)
	also have "\<dots> = sum (%i. ALG x qs i (?config i, ()))
	(\<Union>y\<in>{y. y \<in> set init}. {i. i < length qs \<and> qs ! i = y})"
	apply(rule sum.cong)
	proof goal_cases
	case 1
	show ?case apply(auto) using inlist by auto
	qed simp
	also have "\<dots> = sum (%t. sum (%i. ALG x qs i (?config i, ())) {i. i<length qs \<and> qs ! i = t}) {y. y\<in> set init}"
	apply(rule sum.UNION_disjoint)
	apply(simp_all) by force
	also have "\<dots> = (\<Sum>y\<in>set init. \<Sum>i \| i < length qs \<and> qs ! i = y.
	ALG x qs i (?config i, ()))" by auto
	finally show ?case .
	qed (simp)
	also have "\<dots> = (\<Sum>(x,y)\<in> (set init \<times> set init).
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG x qs i (?config i, ())))"
	by (rule sum.cartesian_product)
	also have "\<dots> = (\<Sum>(x,y)\<in> {(x,y). x\<in>set init \<and> y\<in> set init}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG x qs i (?config i, ())))"
	by simp
	also have E4: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x\<in>set init \<and> y\<in> set init \<and> x\<noteq>y}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG x qs i (?config i, ())))" (is "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f x y)")
	proof goal_cases
	case 1
	let ?M = "{(x,y). x\<in>set init \<and> y\<in> set init \<and> x=y}"
	have A: "?L = ?R \<union> ?M" by auto
	have B: "{} = ?R \<inter> ?M" by auto
	have "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R \<union> ?M. ?f x y)"
	by(simp only: A)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?M. ?f x y)"
	apply(rule sum.union_disjoint)
	apply(rule finite_subset[where B="set init \<times> set init"])
	apply(auto)
	apply(rule finite_subset[where B="set init \<times> set init"])
	by(auto)
	also have "(\<Sum>(x,y)\<in> ?M. ?f x y) = 0"
	apply(rule sum.neutral)
	by (auto simp add: split_def before_in_def)
	finally show ?case by simp
	qed

	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{i. i<length qs \<and> qs!i=y}. ALG x qs i (?config i, ()))
	+ (\<Sum>i\<in>{i. i<length qs \<and> qs!i=x}. ALG y qs i (?config i, ())) )"
	(is "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f x y + ?f y x)")
	proof -
	let ?R' = "{(x,y). x \<in> set init \<and> y\<in>set init \<and> y<x}"
	have A: "?L = ?R \<union> ?R'" by auto
	have "{} = ?R \<inter> ?R'" by auto
	have C: "?R' = (%(x,y). (y, x)) ` ?R" by auto

	have D: "(\<Sum>(x,y)\<in> ?R'. ?f x y) = (\<Sum>(x,y)\<in> ?R. ?f y x)"
	proof -
	have "(\<Sum>(x,y)\<in> ?R'. ?f x y) = (\<Sum>(x,y)\<in> (%(x,y). (y, x)) ` ?R. ?f x y)"
	by(simp only: C)
	also have "(\<Sum>z\<in> (%(x,y). (y, x)) ` ?R. (%(x,y). ?f x y) z) = (\<Sum>z\<in>?R. ((%(x,y). ?f x y) \<circ> (%(x,y). (y, x))) z)"
	apply(rule sum.reindex)
	by(fact swap_inj_on)
	also have "\<dots> = (\<Sum>z\<in>?R. (%(x,y). ?f y x) z)"
	apply(rule sum.cong)
	by(auto)
	finally show ?thesis .
	qed

	have "(\<Sum>(x,y)\<in> ?L. ?f x y) = (\<Sum>(x,y)\<in> ?R \<union> ?R'. ?f x y)"
	by(simp only: A)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?R'. ?f x y)"
	apply(rule sum.union_disjoint)
	apply(rule finite_subset[where B="set init \<times> set init"])
	apply(auto)
	apply(rule finite_subset[where B="set init \<times> set init"])
	by(auto)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y) + (\<Sum>(x,y)\<in> ?R. ?f y x)"
	by(simp only: D)
	also have "\<dots> = (\<Sum>(x,y)\<in> ?R. ?f x y + ?f y x)"
	by(simp add: split_def sum.distrib[symmetric])
	finally show ?thesis .
	qed

	also have E5: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	(\<Sum>i\<in>{i. i<length qs \<and> (qs!i=y \<or> qs!i=x)}. ALG y qs i (?config i, ()) + ALG x qs i (?config i, ())))"
	apply(rule sum.cong)
	apply(simp)
	proof goal_cases
	case (1 x)
	then obtain a b where x: "x=(a,b)" and a: "a \<in> set init" "b \<in> set init" "a < b" by auto
	then have "a\<noteq>b" by simp
	then have disj: "{i. i < length qs \<and> qs ! i = b} \<inter> {i. i < length qs \<and> qs ! i = a} = {}" by auto
	have unio: "{i. i < length qs \<and> (qs ! i = b \<or> qs ! i = a)}
	= {i. i < length qs \<and> qs ! i = b} \<union> {i. i < length qs \<and> qs ! i = a}" by auto
	let ?f="%i. ALG b qs i (?config i, ()) +
	ALG a qs i (?config i, ())"
	let ?B="{i. i < length qs \<and> qs ! i = b}"
	let ?A="{i. i < length qs \<and> qs ! i = a}"
	have "(\<Sum>i\<in>?B \<union> ?A. ?f i)
	= (\<Sum>i\<in>?B. ?f i) + (\<Sum>i\<in>?A. ?f i) - (\<Sum>i\<in>?B \<inter> ?A. ?f i) "
	apply(rule sum_Un_nat) by auto
	also have "\<dots> = (\<Sum>i\<in>?B. ALG b qs i (?config i, ()) + ALG a qs i (?config i, ()))
	+ (\<Sum>i\<in>?A. ALG b qs i (?config i, ()) + ALG a qs i (?config i, ()))"
	using disj by auto
	also have "\<dots> = (\<Sum>i\<in>?B. ALG a qs i (?config i, ()))
	+ (\<Sum>i\<in>?A. ALG b qs i (?config i, ()))"
	by (auto simp: split_def before_in_def)
	finally
	show ?case unfolding x apply(simp add: split_def)
	unfolding unio by simp
	qed
	also have E6: "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y)"
	apply(rule sum.cong)
	unfolding ALGxy_det_alternativ unfolding ALG'_det_def by auto
	finally have blockingpart: "(\<Sum>i<length qs.
	\<Sum>e\<in>set init.
	ALG e qs i (?config i, ()))
	= (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y) " .
	from Tp_darstellung[OF qsStrat] have E0: "T\<^sub>p init qs Strat =
	(\<Sum>i\<in>{..<length qs}. t\<^sub>p (steps' init qs Strat i) (qs!i) (Strat!i))"
	by auto
	also have "\<dots> = (\<Sum>i\<in>{..<length qs}.
	(\<Sum>e\<in>set (steps' init qs Strat i). ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),()))
	+ (\<Sum>(x,y)\<in>{(x,(y::('a::linorder))). x \<in> set (steps' init qs Strat i) \<and> y\<in>set (steps' init qs Strat i) \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
	apply(rule sum.cong)
	apply(simp)
	apply (rule t\<^sub>p_sumofALGALGP)
	apply(rule steps'_distinct2)
	using dist qsStrat apply(simp_all)
	apply(subst steps'_set)
	using dist qsStrat inlist apply(simp_all)
	apply fastforce
	apply(subst steps'_length)
	apply(simp_all)
	using noStupid by auto
	also have "\<dots> = (\<Sum>i\<in>{..<length qs}.
	(\<Sum>e\<in>set init. ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i),()))
	+ (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
	apply(rule sum.cong)
	apply(simp)
	proof goal_cases
	case (1 x)
	then have "set (steps' init qs Strat x) = set init"
	apply(subst steps'_set)
	using dist qsStrat 1 by(simp_all)
	then show ?case by simp
	qed
	also have "\<dots> = (\<Sum>i\<in>{..<length qs}.
	(\<Sum>e\<in>set init. ALG e qs i (swaps (snd (Strat!i)) (steps' init qs Strat i), ())))
	+ (\<Sum>i\<in>{..<length qs}.
	(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
	by (simp add: sum.distrib split_def)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y)
	+ (\<Sum>i\<in>{..<length qs}.
	(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. ALG_P (snd (Strat!i)) x y (steps' init qs Strat i)) )"
	by(simp only: blockingpart)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y)
	+ (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALG_Pxy Strat qs init x y)"
	by(simp only: paid_part)
	also have "\<dots> = (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y
	+ ALG_Pxy Strat qs init x y)"
	by (simp add: sum.distrib split_def)
	finally show ?thesis by auto
	qed




	lemma nn_contains_Inf:
	fixes S :: "nat set"
	assumes nn: "S \<noteq> {}"
	shows "Inf S \<in> S"
	using assms Inf_nat_def LeastI by force


	lemma steps_length: "length qs = length as \<Longrightarrow> length (steps s qs as) = length s"
	apply(induct qs as arbitrary: s rule: list_induct2)
	by simp_all

	(* shows that OPT does not use paid exchanges that do not have an effect *)
	lemma OPT_noStupid:
	fixes Strat
	assumes [simp]: "length Strat = length qs"
	assumes opt: "T\<^sub>p init qs Strat = T\<^sub>p_opt init qs"
	assumes init_nempty: "init\<noteq>[]"
	shows "\<And>x l. x < length Strat \<Longrightarrow>
	l < length (snd (Strat ! x)) \<Longrightarrow>
	Suc ((snd (Strat ! x))!l) < length init"
	proof (rule ccontr, goal_cases)
	case (1 x l)

	(* construct a Stratgy that leaves out that paid exchange *)
	let ?sws' = "take l (snd (Strat!x)) @ drop (Suc l) (snd (Strat!x))"
	let ?Strat' = "take x Strat @ (fst (Strat!x),?sws') # drop (Suc x) Strat"

	from 1(1) have valid: "length ?Strat' = length qs" by simp
	from valid have isin: "T\<^sub>p init qs ?Strat' \<in> {T\<^sub>p init qs as \|as. length as = length qs}" by blast

	from 1(1,2) have lsws': "length (snd (Strat!x)) = length ?sws' + 1"
	by (simp)

	have a: "(take x ?Strat') = (take x Strat)"
	using 1(1) by(auto simp add: min_def take_Suc_conv_app_nth)
	have b: "(drop (Suc x) Strat) = (drop (Suc x) ?Strat')"
	using 1(1) by(auto simp add: min_def take_Suc_conv_app_nth)

	have aa: "(take l (snd (Strat!x))) = (take l (snd (?Strat'!x)))"
	using 1(1,2) by(auto simp add: min_def take_Suc_conv_app_nth nth_append)
	have bb: "(drop (Suc l) (snd (Strat!x))) = (drop l (snd (?Strat'!x)))"
	using 1(1,2) by(auto simp add: min_def take_Suc_conv_app_nth nth_append )

	have "(swaps (snd (Strat ! x)) (steps init (take x qs) (take x Strat)))
	= (swaps (take l (snd (Strat ! x)) @ (snd (Strat ! x))!l # drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
	unfolding id_take_nth_drop[OF 1(2), symmetric] by simp
	also have "...
	= (swaps (take l (snd (Strat ! x)) @ drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
	using 1(3) by(simp add: swap_def steps_length)
	finally have noeffect: "(swaps (snd (Strat ! x)) (steps init (take x qs) (take x Strat)))
	= (swaps (take l (snd (Strat ! x)) @ drop (Suc l) (snd (Strat ! x))) (steps init (take x qs) (take x Strat)))"
	.


	have c: "t\<^sub>p (steps init (take x qs) (take x Strat)) (qs ! x) (Strat ! x) =
	t\<^sub>p (steps init (take x qs) (take x ?Strat')) (qs ! x) (?Strat' ! x) + 1"
	unfolding a t\<^sub>p_def using 1(1,2)
	apply(simp add: min_def split_def nth_append) unfolding noeffect
	by(simp)

	have "T\<^sub>p init (take (Suc x) qs) (take (Suc x) Strat)
	= T\<^sub>p init (take x qs) (take x ?Strat') +
	t\<^sub>p (steps init (take x qs) (take x Strat)) (qs ! x) (Strat ! x)"
	using 1(1) a by(simp add: take_Suc_conv_app_nth T_append)
	also have "\<dots> = T\<^sub>p init (take x qs) (take x ?Strat') +
	t\<^sub>p (steps init (take x qs) (take x ?Strat')) (qs ! x) (?Strat' ! x) + 1"
	unfolding c by(simp)
	also have "\<dots> = T\<^sub>p init (take (Suc x) qs) (take (Suc x) ?Strat') + 1"
	using 1(1) a by(simp add: min_def take_Suc_conv_app_nth T_append nth_append)
	finally have bef: "T\<^sub>p init (take (Suc x) qs) (take (Suc x) Strat)
	= T\<^sub>p init (take (Suc x) qs) (take (Suc x) ?Strat') + 1" .

	let ?interstate = "(steps init (take (Suc x) qs) (take (Suc x) Strat))"
	let ?interstate' = "(steps init (take (Suc x) qs) (take (Suc x) ?Strat'))"

	have state: "?interstate' = ?interstate"
	using 1(1) apply(simp add: take_Suc_conv_app_nth min_def)
	apply(simp add: steps_append step_def split_def) using noeffect by simp


	have "T\<^sub>p init qs Strat
	= T\<^sub>p init (take (Suc x) qs @ drop (Suc x) qs) (take (Suc x) Strat @ drop (Suc x) Strat)"
	by simp
	also have "\<dots> = T\<^sub>p init (take (Suc x) qs) (take (Suc x) Strat)
	+ T\<^sub>p ?interstate (drop (Suc x) qs) (drop (Suc x) Strat)"
	apply(subst T_append2) by(simp_all)
	also have "\<dots> = T\<^sub>p init (take (Suc x) qs) (take (Suc x) ?Strat')
	+ T\<^sub>p ?interstate' (drop (Suc x) qs) (drop (Suc x) ?Strat') + 1"
	unfolding bef state using 1(1) by(simp add: min_def nth_append)
	also have "\<dots> = T\<^sub>p init (take (Suc x) qs @ drop (Suc x) qs) (take (Suc x) ?Strat' @ drop (Suc x) ?Strat') + 1"
	apply(subst T_append2) using 1(1) by(simp_all add: min_def)
	also have "\<dots> = T\<^sub>p init qs ?Strat' + 1" by simp
	finally have better: "T\<^sub>p init qs ?Strat' + 1 = T\<^sub>p init qs Strat" by simp

	have "T\<^sub>p init qs ?Strat' + 1 = T\<^sub>p init qs Strat" by (fact better)
	also have "\<dots> = T\<^sub>p_opt init qs" by (fact opt)
	also from cInf_lower[OF isin] have "\<dots> \<le> T\<^sub>p init qs ?Strat'" unfolding T_opt_def by simp
	finally show "False" using init_nempty by auto
	qed


	(* Gleichung 1.8 in Borodin *)
	lemma umformung_OPT:
	assumes inlist: "set qs \<subseteq> set init"
	assumes dist: "distinct init"
	assumes a: "T\<^sub>p_opt init qs = T\<^sub>p init qs Strat"
	assumes b: " length qs = length Strat"
	assumes c: "init\<noteq>[]"
	shows "T\<^sub>p_opt init qs =
	(\<Sum>(x,y)\<in>{(x,y::('a::linorder)). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
	proof -
	have "T\<^sub>p_opt init qs = T\<^sub>p init qs Strat" by(fact a)
	also have "\<dots> =
	(\<Sum>(x,y)\<in>{(x,y::('a::linorder)). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
	apply(rule umformung_OPT')
	apply(fact)+
	using OPT_noStupid[OF b[symmetric] a[symmetric] c] apply(simp) done
	finally show ?thesis .
	qed


	corollary OPT_zerlegen:
	assumes
	dist: "distinct init"
	and c: "init\<noteq>[]"
	and setqsinit: "set qs \<subseteq> set init"
	shows "(\<Sum>(x,y)\<in>{(x,y::('a::linorder)). x \<in> set init \<and> y\<in>set init \<and> x<y}. (T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y})))
	\<le> T\<^sub>p_opt init qs"
	proof -

	have "T\<^sub>p_opt init qs \<in> {T\<^sub>p init qs as \|as. length as = length qs}"
	unfolding T_opt_def
	apply(rule nn_contains_Inf)
	apply(auto) by (rule Ex_list_of_length)

	then obtain Strat where a: "T\<^sub>p init qs Strat = T\<^sub>p_opt init qs"
	and b: "length Strat = length qs"
	unfolding T_opt_def by auto

	have "(\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x, y})) \<le> (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}.
	ALGxy_det Strat qs init x y + ALG_Pxy Strat qs init x y)"
	apply (rule sum_mono)
	apply(auto)
	proof goal_cases
	case (1 a b)
	then have "a\<noteq>b" by auto
	show ?case apply(rule T1_7[OF a b]) by(fact)+
	qed
	also from umformung_OPT[OF setqsinit dist] a b c have "\<dots> = T\<^sub>p init qs Strat" by auto
	also from a have "\<dots> = T\<^sub>p_opt init qs" by simp
	finally show ?thesis .
	qed


	subsection "Factoring Lemma"


	lemma cardofpairs: "S \<noteq> [] \<Longrightarrow> sorted S \<Longrightarrow> distinct S \<Longrightarrow> card {(x,y). x \<in> set S \<and> y\<in>set S \<and> x<y} = ((length S)*(length S-1)) / 2"
	proof (induct S rule: list_nonempty_induct)
	case (cons s ss)
	then have "sorted ss" "distinct ss" by auto
	from cons(2)[OF this(1) this(2)] have iH: "card {(x, y) . x \<in> set ss \<and> y \<in> set ss \<and> x < y}
	= (length ss * (length ss-1)) / 2"
	by auto

	from cons have sss: "s \<notin> set ss" by auto

	from cons have tt: "(\<forall>y\<in>set (s#ss). s \<le> y)" by auto
	with cons have tt': "(\<forall>y\<in>set ss. s < y)"
	proof -
	from sss have "(\<forall>y\<in>set ss. s \<noteq> y)" by auto
	with tt show ?thesis by fastforce
	qed

	then have "{(x, y) . x = s \<and> y \<in> set ss \<and> x < y}
	= {(x, y) . x = s \<and> y \<in> set ss}" by auto
	also have "\<dots> = {s}\<times>(set ss)" by auto
	finally have "{(x, y) . x = s \<and> y \<in> set ss \<and> x < y} = {s}\<times>(set ss)" .
	then have "card {(x, y) . x = s \<and> y \<in> set ss \<and> x < y}
	= card (set ss)" by(auto)
	also from cons distinct_card have "\<dots> = length ss" by auto
	finally have step: "card {(x, y) . x = s \<and> y \<in> set ss \<and> x < y} =
	length ss" .

	have uni: "{(x, y) . x \<in> set (s # ss) \<and> y \<in> set (s # ss) \<and> x < y}
	= {(x, y) . x \<in> set ss \<and> y \<in> set ss \<and> x < y}
	\<union> {(x, y) . x = s \<and> y \<in> set ss \<and> x < y}"
	using tt by auto

	have disj: "{(x, y) . x \<in> set ss \<and> y \<in> set ss \<and> x < y}
	\<inter> {(x, y) . x = s \<and> y \<in> set ss \<and> x < y} = {}"
	using sss by(auto)
	have "card {(x, y) . x \<in> set (s # ss) \<and> y \<in> set (s # ss) \<and> x < y}
	= card ({(x, y) . x \<in> set ss \<and> y \<in> set ss \<and> x < y}
	\<union> {(x, y) . x = s \<and> y \<in> set ss \<and> x < y})" using uni by auto
	also have "\<dots> = card {(x, y) . x \<in> set ss \<and> y \<in> set ss \<and> x < y}
	+ card {(x, y) . x = s \<and> y \<in> set ss \<and> x < y}"
	apply(rule card_Un_disjoint)
	apply(rule finite_subset[where B="(set ss) \<times> (set ss)"])
	apply(force)
	apply(simp)
	apply(rule finite_subset[where B="{s} \<times> (set ss)"])
	apply(force)
	apply(simp)
	using disj apply(simp) done
	also have "\<dots> = (length ss * (length ss-1)) / 2
	+ length ss" using iH step by auto
	also have "\<dots> = (length ss * (length ss-1) + 2*length ss) / 2" by auto
	also have "\<dots> = (length ss * (length ss-1) + length ss * 2) / 2" by auto
	also have "\<dots> = (length ss * (length ss-1+2)) / 2"
	by simp
	also have "\<dots> = (length ss * (length ss+1)) / 2"
	using cons(1) by simp
	also have "\<dots> = ((length ss+1) * length ss) / 2" by auto
	also have "\<dots> = (length (s#ss) * (length (s#ss)-1)) / 2" by auto
	finally show ?case by auto
	next
	case single thus ?case by(simp cong: conj_cong)
	qed


	(* factoring lemma *)
	lemma factoringlemma_withconstant:
	fixes A
	and b::real
	and c::real
	assumes c: "c \<ge> 1"
	assumes dist: "\<forall>e\<in>S0. distinct e"
	assumes notempty: "\<forall>e\<in>S0. length e > 0"
	(* A has pairwise property *)
	assumes pw: "pairwise A"
	(* A is c-competitive on list of length 2 *)
	assumes on2: "\<forall>s0\<in>S0. \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}. \<forall>(x,y)\<in>{(x,y). x \<in> set s0 \<and> y\<in>set s0 \<and> x<y}. T\<^sub>p_on_rand A (Lxy s0 {x,y}) (Lxy qs {x,y}) \<le> c * (T\<^sub>p_opt (Lxy s0 {x,y}) (Lxy qs {x,y})) + b"
	assumes nopaid: "\<And>is s q. \<forall>((free,paid),_) \<in> (snd A (s, is) q). paid=[]"
	assumes 4: "\<And>init qs. distinct init \<Longrightarrow> set qs \<subseteq> set init \<Longrightarrow> (\<And>x. x<length qs \<Longrightarrow> finite (set_pmf (config'' A qs init x)))"
	(* then A is c-competitive on arbitrary list lengths *)
	shows "\<forall>s0\<in>S0. \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}.
	T\<^sub>p_on_rand A s0 qs \<le> c * real (T\<^sub>p_opt s0 qs) + b"
	proof (standard, goal_cases)
	case (1 init)
	have d: "distinct init" using dist 1 by auto
	have d2: "init \<noteq> []" using notempty 1 by auto


	obtain b where on3: "\<forall>qs\<in>{x. set x \<subseteq> set init}. \<forall>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. T\<^sub>p_on_rand A (Lxy init {x,y}) (Lxy qs {x,y}) \<le> c * (T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b"
	and b: "b\<ge>0"
	using on2 1 by auto

	{

	fix qs
	assume drin: "set qs \<subseteq> set init"

	have "T\<^sub>p_on_rand A init qs =
	(\<Sum>(x,y)\<in>{(x, y) . x \<in> set init \<and> y \<in> set init \<and> x < y}.
	T\<^sub>p_on_rand A (Lxy init {x,y}) (Lxy qs {x, y})) "
	apply(rule umf_pair)
	apply(fact)+
	using 4[of init qs] drin d by(simp add: split_def)
	(* 1.4 *)
	also have "\<dots> \<le> (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. c * (T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b)"
	apply(rule sum_mono)
	using on3 drin by(simp add: split_def)
	also have "\<dots> = c * (\<Sum>(x,y)\<in>{(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y}. T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x,y})) + b(((length init)(length init-1)) / 2)"
	proof -

	{
	fix S::"'a list"
	assume dis: "distinct S"
	assume d2: "S \<noteq> []"
	then have d3: "sort S \<noteq> []" by (metis length_0_conv length_sort)
	have "card {(x,y). x \<in> set S \<and> y\<in>set S \<and> x<y}
	= card {(x,y). x \<in> set (sort S) \<and> y\<in>set (sort S) \<and> x<y}"
	by auto
	also have "\<dots> = (length (sort S) * (length (sort S) - 1)) / 2"
	apply(rule cardofpairs) using dis d2 d3 by (simp_all)
	finally have "card {(x, y) . x \<in> set S \<and> y \<in> set S \<and> x < y} =
	(length (sort S) * (length (sort S) - 1)) / 2 " .
	}
	with d d2 have e: "card {(x,y). x \<in> set init \<and> y\<in>set init \<and> x<y} = ((length init)*(length init-1)) / 2" by auto
	show ?thesis (is "(\<Sum>(x,y)\<in>?S. c * (?T x y) + b) = c * ?R + b*?T2")
	proof -
	have "(\<Sum>(x,y)\<in>?S. c * (?T x y) + b) =
	c * (\<Sum>(x,y)\<in>?S. (?T x y)) + (\<Sum>(x,y)\<in>?S. b)"
	by(simp add: split_def sum.distrib sum_distrib_left)
	also have "\<dots> = c * (\<Sum>(x,y)\<in>?S. (?T x y)) + b*?T2"
	using e by(simp add: split_def)
	finally show ?thesis by(simp add: split_def)
	qed
	qed
	also have "\<dots> \<le> c * T\<^sub>p_opt init qs + (b((length init)(length init-1)) / 2)"
	proof -
	have "(\<Sum>(x, y)\<in>{(x, y) . x \<in> set init \<and>
	y \<in> set init \<and> x < y}. T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x, y}))
	\<le> T\<^sub>p_opt init qs"
	using OPT_zerlegen drin d d2 by auto
	then have " real (\<Sum>(x, y)\<in>{(x, y) . x \<in> set init \<and>
	y \<in> set init \<and> x < y}. T\<^sub>p_opt (Lxy init {x,y}) (Lxy qs {x, y}))
	\<le> (T\<^sub>p_opt init qs)"
	by linarith
	with c show ?thesis by(auto simp: split_def)
	qed
	finally have f: "T\<^sub>p_on_rand A init qs \<le> c * real (T\<^sub>p_opt init qs) + (b((length init)(length init-1)) / 2)" .
	} note all=this
	show ?case unfolding compet_def
	apply(auto)
	apply(rule exI[where x="(b((length init)(length init-1)) / 2)"])
	apply(safe)
	using notempty 1 b apply simp
	using all b by simp
	qed

	lemma factoringlemma_withconstant':
	fixes A
	and b::real
	and c::real
	assumes c: "c \<ge> 1"
	assumes dist: "\<forall>e\<in>S0. distinct e"
	assumes notempty: "\<forall>e\<in>S0. length e > 0"
	(* A has pairwise property *)
	assumes pw: "pairwise A"
	(* A is c-competitive on list of length 2 *)
	assumes on2: "\<forall>s0\<in>S0. \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}. \<forall>(x,y)\<in>{(x,y). x \<in> set s0 \<and> y\<in>set s0 \<and> x<y}. T\<^sub>p_on_rand A (Lxy s0 {x,y}) (Lxy qs {x,y}) \<le> c * (T\<^sub>p_opt (Lxy s0 {x,y}) (Lxy qs {x,y})) + b"
	assumes nopaid: "\<And>is s q. \<forall>((free,paid),_) \<in> (snd A (s, is) q). paid=[]"
	assumes 4: "\<And>init qs. distinct init \<Longrightarrow> set qs \<subseteq> set init \<Longrightarrow> (\<And>x. x<length qs \<Longrightarrow> finite (set_pmf (config'' A qs init x)))"
	(* then A is c-competitive on arbitrary list lengths *)
	shows "compet_rand A c S0"
	unfolding compet_rand_def static_def using factoringlemma_withconstant[OF assms] by simp


	end
	diff --git a/thys/List_Update/Prob_Theory.thy b/thys/List_Update/Prob_Theory.thy
	--- a/thys/List_Update/Prob_Theory.thy
	+++ b/thys/List_Update/Prob_Theory.thy
	@@ -1,573 +1,573 @@
	(* Title: Definition of Expectation and Distribution of uniformly distributed bit vectors
	Author: Max Haslbeck
	*)

	section "Probability Theory"

	theory Prob_Theory
	imports "HOL-Probability.Probability"
	begin

	lemma integral_map_pmf[simp]:
	fixes f::"real \<Rightarrow> real"
	shows "(\<integral>x. f x \<partial>(map_pmf g M)) = (\<integral>x. f (g x) \<partial>M)"
	unfolding map_pmf_rep_eq
	using integral_distr[of g "(measure_pmf M)" "(count_space UNIV)" f] by auto


	subsection "function \<open>E\<close>"

	definition E :: "real pmf \<Rightarrow> real" where
	"E M = (\<integral>x. x \<partial> measure_pmf M)"

	translations
	"\<integral> x. f \<partial>M" <= "CONST lebesgue_integral M (\<lambda>x. f)"

	notation (latex output) E ("E[_]" [1] 100)

	lemma E_const[simp]: "E (return_pmf a) = a"
	unfolding E_def
	unfolding return_pmf.rep_eq
	by (simp add: integral_return)

	lemma E_null[simp]: "E (return_pmf 0) = 0"
	by auto

	lemma E_finite_sum: "finite (set_pmf X) \<Longrightarrow> E X = (\<Sum>x\<in>(set_pmf X). pmf X x * x)"
	unfolding E_def by (subst integral_measure_pmf) simp_all

	lemma E_of_const: "E(map_pmf (\<lambda>x. y) (X::real pmf)) = y" by auto

	lemma E_nonneg:
	shows "(\<forall>x\<in>set_pmf X. 0\<le> x) \<Longrightarrow> 0 \<le> E X"
	unfolding E_def
	using integral_nonneg by (simp add: AE_measure_pmf_iff integral_nonneg_AE)

	lemma E_nonneg_fun: fixes f::"'a\<Rightarrow>real"
	shows "(\<forall>x\<in>set_pmf X. 0\<le>f x) \<Longrightarrow> 0 \<le> E (map_pmf f X)"
	using E_nonneg by auto

	lemma E_cong:
	fixes f::"'a \<Rightarrow> real"
	shows "finite (set_pmf X) \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) = (u x)) \<Longrightarrow> E (map_pmf f X) = E (map_pmf u X)"
	unfolding E_def integral_map_pmf apply(rule integral_cong_AE)
	apply(simp add: integrable_measure_pmf_finite)+
	by (simp add: AE_measure_pmf_iff)

	lemma E_mono3:
	fixes f::"'a \<Rightarrow> real"
	shows " integrable (measure_pmf X) f \<Longrightarrow> integrable (measure_pmf X) u \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) \<le> (u x)) \<Longrightarrow> E (map_pmf f X) \<le> E (map_pmf u X)"
	unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
	by (auto simp add: AE_measure_pmf_iff)

	lemma E_mono2:
	fixes f::"'a \<Rightarrow> real"
	shows "finite (set_pmf X) \<Longrightarrow> (\<forall>x\<in> set_pmf X. (f x) \<le> (u x)) \<Longrightarrow> E (map_pmf f X) \<le> E (map_pmf u X)"
	unfolding E_def integral_map_pmf apply(rule integral_mono_AE)
	apply(simp add: integrable_measure_pmf_finite)+
	by (simp add: AE_measure_pmf_iff)

	lemma E_linear_diff2: "finite (set_pmf A) \<Longrightarrow> E (map_pmf f A) - E (map_pmf g A) = E (map_pmf (\<lambda>x. (f x) - (g x)) A)"
	unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_diff[of "measure_pmf A" f g, symmetric])
	by (simp_all add: integrable_measure_pmf_finite)

	lemma E_linear_plus2: "finite (set_pmf A) \<Longrightarrow> E (map_pmf f A) + E (map_pmf g A) = E (map_pmf (\<lambda>x. (f x) + (g x)) A)"
	unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_add[of "measure_pmf A" f g, symmetric])
	by (simp_all add: integrable_measure_pmf_finite)

	lemma E_linear_sum2: "finite (set_pmf D) \<Longrightarrow> E(map_pmf (\<lambda>x. (\<Sum>i<up. f i x)) D)
	= (\<Sum>i<(up::nat). E(map_pmf (f i) D))"
	unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

	lemma E_linear_sum_allg: "finite (set_pmf D) \<Longrightarrow> E(map_pmf (\<lambda>x. (\<Sum>i\<in> A. f i x)) D)
	= (\<Sum>i\<in> (A::'a set). E(map_pmf (f i) D))"
	unfolding E_def integral_map_pmf apply(rule Bochner_Integration.integral_sum) by (simp add: integrable_measure_pmf_finite)

	lemma E_finite_sum_fun: "finite (set_pmf X) \<Longrightarrow>
	E (map_pmf f X) = (\<Sum>x\<in>set_pmf X. pmf X x * f x)"
	proof -
	assume finite: "finite (set_pmf X)"
	have "E (map_pmf f X) = (\<integral>x. f x \<partial>measure_pmf X)"
	unfolding E_def by auto
	also have "\<dots> = (\<Sum>x\<in>set_pmf X. pmf X x * f x)"
	by (subst integral_measure_pmf) (auto simp add: finite)
	finally show ?thesis .
	qed

	lemma E_bernoulli: "0\<le>p \<Longrightarrow> p\<le>1 \<Longrightarrow>
	E (map_pmf f (bernoulli_pmf p)) = p(f True) + (1-p)(f False)"
	unfolding E_def by (auto)


	subsection "function \<open>bv\<close>"

	fun bv:: "nat \<Rightarrow> bool list pmf" where
	"bv 0 = return_pmf []"
	\| "bv (Suc n) = do {
	(xs::bool list) \<leftarrow> bv n;
	(x::bool) \<leftarrow> (bernoulli_pmf 0.5);
	return_pmf (x#xs)
	}"

	lemma bv_finite: "finite (bv n)"
	by (induct n) auto

	lemma len_bv_n: "\<forall>xs \<in> set_pmf (bv n). length xs = n"
	apply(induct n) by auto

	lemma bv_set: "set_pmf (bv n) = {x::bool list. length x = n}"
	proof (induct n)
	case (Suc n)
	then have "set_pmf (bv (Suc n)) = (\<Union>x\<in>{x. length x = n}. {True # x, False # x})"
	by(simp add: set_pmf_bernoulli UNIV_bool)
	also have "\<dots> = {x#xs\| x xs. length xs = n}" by auto
	also have "\<dots> = {x. length x = Suc n} " using Suc_length_conv by fastforce
	finally show ?case .
	qed (simp)

	lemma len_not_in_bv: "length xs \<noteq> n \<Longrightarrow> xs \<notin> set_pmf (bv n)"
	by(auto simp: len_bv_n)

	lemma not_n_bv_0: "length xs \<noteq> n \<Longrightarrow> pmf (bv n) xs = 0"
	by (simp add: len_not_in_bv pmf_eq_0_set_pmf)

	lemma bv_comp_bernoulli: "n < l
	\<Longrightarrow> map_pmf (\<lambda>y. y!n) (bv l) = bernoulli_pmf (5 / 10)"
	proof (induct n arbitrary: l)
	case 0
	then obtain m where "l = Suc m" by (metis Suc_pred)
	then show "map_pmf (\<lambda>y. y!0) (bv l) = bernoulli_pmf (5 / 10)" by (auto simp: map_pmf_def bind_return_pmf bind_assoc_pmf bind_return_pmf')
	next
	case (Suc n)
	then have "0 < l" by auto
	then obtain m where lsm: "l = Suc m" by (metis Suc_pred)
	with Suc(2) have nltm: "n < m" by auto

	from lsm have "map_pmf (\<lambda>y. y ! Suc n) (bv l)
	= map_pmf (\<lambda>x. x!n) (bind_pmf (bv m) (\<lambda>t. (return_pmf t)))" by (auto simp: map_bind_pmf)
	also
	have "\<dots> = map_pmf (\<lambda>x. x!n) (bv m)" by (auto simp: bind_return_pmf')
	also
	have "\<dots> = bernoulli_pmf (5 / 10)" by (auto simp add: Suc(1)[of m, OF nltm])
	finally
	show ?case .
	qed

	lemma pmf_2elemlist: "pmf (bv (Suc 0)) ([x]) = pmf (bv 0) [] * pmf (bernoulli_pmf (5 / 10)) x"
	unfolding bv.simps(2)[where n=0] pmf_bind pmf_return
	apply (subst integral_measure_pmf[where A="{[]}"])
	apply (auto) by (cases x) auto

	lemma pmf_moreelemlist: "pmf (bv (Suc n)) (x#xs) = pmf (bv n) xs * pmf (bernoulli_pmf (5 / 10)) x"
	unfolding bv.simps(2) pmf_bind pmf_return
	apply (subst integral_measure_pmf[where A="{xs}"])
	apply auto apply (cases x) apply(auto)
	apply (meson indicator_simps(2) list.inject singletonD)
	apply (meson indicator_simps(2) list.inject singletonD)
	apply (cases x) by(auto)

	lemma list_pmf: "length xs = n \<Longrightarrow> pmf (bv n) xs = (1 / 2)^n"
	proof(induct n arbitrary: xs)
	case 0
	then have "xs = []" by auto
	then show "pmf (bv 0) xs = (1 / 2) ^ 0" by(auto)
	next
	case (Suc n xs)
	then obtain a as where split: "xs = a#as" by (metis Suc_length_conv)
	have "length as = n" using Suc(2) split by auto
	with Suc(1) have 1: "pmf (bv n) as = (1 / 2) ^ n" by auto

	from split pmf_moreelemlist[where n=n and x=a and xs=as] have
	"pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
	then have "pmf (bv (Suc n)) xs = (1 / 2) ^ n * 1 / 2" using 1 by auto
	then show "pmf (bv (Suc n)) xs = (1 / 2) ^ Suc n" by auto
	qed

	lemma bv_0_notlen: "pmf (bv n) xs = 0 \<Longrightarrow> length xs \<noteq> n "
	by(auto simp: list_pmf)

	lemma "length xs > n \<Longrightarrow> pmf (bv n) xs = 0"
	proof (induct n arbitrary: xs)
	case (Suc n xs)
	then obtain a as where split: "xs = a#as" by (metis Suc_length_conv Suc_lessE)
	have "length as > n" using Suc(2) split by auto
	with Suc(1) have 1: "pmf (bv n) as = 0" by auto
	from split pmf_moreelemlist[where n=n and x=a and xs=as] have
	"pmf (bv (Suc n)) xs = pmf (bv n) as * pmf (bernoulli_pmf (5 / 10)) a" by auto
	then have "pmf (bv (Suc n)) xs = 0 * 1 / 2" using 1 by auto
	then show "pmf (bv (Suc n)) xs = 0" by auto
	qed simp

	lemma map_hd_list_pmf: "map_pmf hd (bv (Suc n)) = bernoulli_pmf (5 / 10)"
	by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf')

	lemma map_tl_list_pmf: "map_pmf tl (bv (Suc n)) = bv n"
	by (simp add: map_pmf_def bind_assoc_pmf bind_return_pmf bind_return_pmf' )


	subsection "function \<open>flip\<close>"

	fun flip :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
	"flip _ [] = []"
	\| "flip 0 (x#xs) = (\<not>x)#xs"
	\| "flip (Suc n) (x#xs) = x#(flip n xs)"

	lemma flip_length[simp]: "length (flip i xs) = length xs"
	apply(induct xs arbitrary: i) apply(simp) apply(case_tac i) by(simp_all)

	lemma flip_out_of_bounds: "y \<ge> length X \<Longrightarrow> flip y X = X"
	apply(induct X arbitrary: y)
	proof -
	case (Cons X Xs)
	hence "y > 0" by auto
	with Cons obtain y' where y1: "y = Suc y'" and y2: "y' \<ge> length Xs" by (metis Suc_pred' length_Cons not_less_eq_eq)
	then have "flip y (X # Xs) = X#(flip y' Xs)" by auto
	moreover from Cons y2 have "flip y' Xs = Xs" by auto
	ultimately show ?case by auto
	qed simp

	lemma flip_other: "y < length X \<Longrightarrow> z < length X \<Longrightarrow> z \<noteq> y \<Longrightarrow> flip z X ! y = X ! y"
	apply(induct y arbitrary: X z)
	apply(simp) apply (metis flip.elims neq0_conv nth_Cons_0)
	proof (case_tac z, goal_cases)
	case (1 y X z)
	then obtain a as where "X=a#as" using length_greater_0_conv by (metis (full_types) flip.elims)
	with 1(5) show ?case by(simp)
	next
	case (2 y X z z')
	from 2 have 3: "z' \<noteq> y" by auto
	from 2(2) have "length X > 0" by auto
	then obtain a as where aas: "X = a#as" by (metis (full_types) flip.elims length_greater_0_conv)
	then have a: "flip (Suc z') X ! Suc y = flip z' as ! y"
	and b : "(X ! Suc y) = (as ! y)" by auto
	from 2(2) aas have 1: "y < length as" by auto
	from 2(3,5) aas have f2: "z' < length as" by auto
	note c=2(1)[OF 1 f2 3]

	have "flip z X ! Suc y = flip (Suc z') X ! Suc y" using 2 by auto
	also have "\<dots> = flip z' as ! y" by (rule a)
	also have "\<dots> = as ! y" by (rule c)
	also have "\<dots> = (X ! Suc y)" by (rule b[symmetric])
	finally show "flip z X ! Suc y = (X ! Suc y)" .
	qed

	lemma flip_itself: "y < length X \<Longrightarrow> flip y X ! y = (\<not> X ! y)"
	apply(induct y arbitrary: X)
	apply(simp) apply (metis flip.elims nth_Cons_0 old.nat.distinct(2))
	proof -
	fix y
	fix X::"bool list"
	assume iH: "(\<And>X. y < length X \<Longrightarrow> flip y X ! y = (\<not> X ! y))"
	assume len: "Suc y < length X"
	from len have "y < length X" by auto
	from len have "length X > 0" by auto
	then obtain z zs where zzs: "X = z#zs" by (metis (full_types) flip.elims length_greater_0_conv)
	then have a: "flip (Suc y) X ! Suc y = flip y zs ! y"
	and b : "(\<not> X ! Suc y) = (\<not> zs ! y)" by auto
	from len zzs have "y < length zs" by auto
	note c=iH[OF this]
	from a b c show "flip (Suc y) X ! Suc y = (\<not> X ! Suc y)" by auto
	qed

	lemma flip_twice: "flip i (flip i b) = b"
	proof (cases "i < length b")
	case True
	then have A: "i < length (flip i b)" by simp
	show ?thesis apply(simp add: list_eq_iff_nth_eq) apply(clarify)
	proof (goal_cases)
	case (1 j)
	then show ?case
	apply(cases "i=j")
	using flip_itself[OF A] flip_itself[OF True] apply(simp)
	using flip_other True 1 by auto
	qed
	qed (simp add: flip_out_of_bounds)

	lemma flipidiflip: "y < length X \<Longrightarrow> e < length X \<Longrightarrow> flip e X ! y = (if e=y then ~ (X ! y) else X ! y)"
	apply(cases "e=y")
	apply(simp add: flip_itself)
	by(simp add: flip_other)

	lemma bernoulli_Not: "map_pmf Not (bernoulli_pmf (1 / 2)) = (bernoulli_pmf (1 / 2))"
	apply(rule pmf_eqI)
	proof (case_tac i, goal_cases)
	case (1 i)
	then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
	pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not False)" by auto
	also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) False" apply (rule pmf_map_inj') apply(rule injI) by auto
	also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) i" by auto
	finally show ?case .
	next
	case (2 i)
	then have "pmf (map_pmf Not (bernoulli_pmf (1 / 2))) i =
	pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (Not True)" by auto
	also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) True" apply (rule pmf_map_inj') apply(rule injI) by auto
	also have "\<dots> = pmf (bernoulli_pmf (1 / 2)) i" by auto
	finally show ?case .
	qed

	lemma inv_flip_bv: "map_pmf (flip i) (bv n) = (bv n)"
	proof(induct n arbitrary: i)
	case (Suc n i)
	note iH=this
	have "bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. map_pmf (flip i) (return_pmf (xa # x))))
	= bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa .bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))"
	by(rule bind_commute_pmf)
	also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa . bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
	proof (cases i)
	case 0
	then have "bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))
	= bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf ((\<not> xa) # x)))" by auto
	also have "\<dots> = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf ((\<not> xa) # x)))"
	by(rule bind_commute_pmf)
	also have "\<dots>
	= bind_pmf (bv n) (\<lambda>x. bind_pmf (map_pmf Not (bernoulli_pmf (1 / 2))) (\<lambda>xa. return_pmf (xa # x)))"
	by(auto simp add: bind_map_pmf)
	also have "\<dots> = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf (xa # x)))" by (simp only: bernoulli_Not)
	also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
	by(rule bind_commute_pmf)
	finally show ?thesis .
	next
	case (Suc i')
	have "bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. map_pmf (flip i) (return_pmf (xa # x))))
	= bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # flip i' x)))" unfolding Suc by(simp)
	also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (map_pmf (flip i') (bv n)) (\<lambda>x. return_pmf (xa # x)))"
	by(auto simp add: bind_map_pmf)
	also have "\<dots> = bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. bind_pmf (bv n) (\<lambda>x. return_pmf (xa # x)))"
	using iH[of "i'"] by simp
	finally show ?thesis .
	qed
	also have "\<dots> = bind_pmf (bv n) (\<lambda>x. bind_pmf (bernoulli_pmf (1 / 2)) (\<lambda>xa. return_pmf (xa # x)))"
	by(rule bind_commute_pmf)
	finally show ?case by(simp add: map_pmf_def bind_assoc_pmf)
	qed simp


	subsection "Example for pmf"

	definition "twocoins =
	do {
	x \<leftarrow> (bernoulli_pmf 0.4);
	y \<leftarrow> (bernoulli_pmf 0.5);
	return_pmf (x \<or> y)
	}"

	lemma experiment0_7: "pmf twocoins True = 0.7"
	unfolding twocoins_def
	unfolding pmf_bind pmf_return
	apply (subst integral_measure_pmf[where A="{True, False}"])
	by auto

	subsection "Sum Distribution"

	definition "Sum_pmf p Da Db = (bernoulli_pmf p) \<bind> (%b. if b then map_pmf Inl Da else map_pmf Inr Db )"

	lemma b0: "bernoulli_pmf 0 = return_pmf False"
	apply(rule pmf_eqI) apply(case_tac i)
	by(simp_all)
	lemma b1: "bernoulli_pmf 1 = return_pmf True"
	apply(rule pmf_eqI) apply(case_tac i)
	by(simp_all)


	lemma Sum_pmf_0: "Sum_pmf 0 Da Db = map_pmf Inr Db"
	unfolding Sum_pmf_def
	apply(rule pmf_eqI)
	by(simp add: b0 bind_return_pmf)

	lemma Sum_pmf_1: "Sum_pmf 1 Da Db = map_pmf Inl Da"
	unfolding Sum_pmf_def
	apply(rule pmf_eqI)
	by(simp add: b1 bind_return_pmf)


	definition "Proj1_pmf D = map_pmf (%a. case a of Inl e \<Rightarrow> e) (cond_pmf D {f. (\<exists>e. Inl e = f)})"


	lemma A: "(case_sum (\<lambda>e. e) (\<lambda>a. undefined)) (Inl e) = e"
	by(simp)

	lemma B: "inj (case_sum (\<lambda>e. e) (\<lambda>a. undefined))"
	oops

	lemma none: "p >0 \<Longrightarrow> p < 1 \<Longrightarrow> (set_pmf (bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	\<inter> {f. (\<exists>e. Inl e = f)}) \<noteq> {}"
	apply(simp add: UNIV_bool)
	using set_pmf_not_empty by fast
	lemma none2: "p >0 \<Longrightarrow> p < 1 \<Longrightarrow> (set_pmf (bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	\<inter> {f. (\<exists>e. Inr e = f)}) \<noteq> {}"
	apply(simp add: UNIV_bool)
	using set_pmf_not_empty by fast

	lemma C: "set_pmf (Proj1_pmf (Sum_pmf 0.5 Da Db)) = set_pmf Da"
	proof -
	show ?thesis
	unfolding Sum_pmf_def Proj1_pmf_def
	- apply(simp add: )
	+ applysimp
	using none[of "0.5" Da Db] apply(simp add: set_cond_pmf UNIV_bool)
	by force
	qed

	thm integral_measure_pmf

	thm pmf_cond pmf_cond[OF none]

	lemma proj1_pmf: assumes "p>0" "p<1" shows "Proj1_pmf (Sum_pmf p Da Db) = Da"
	proof -

	have kl: "\<And>e. pmf (map_pmf Inr Db) (Inl e) = 0"
	apply(simp only: pmf_eq_0_set_pmf)
	apply(simp) by blast

	have ll: "measure_pmf.prob
	(bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	{f. \<exists>e. Inl e = f} = p"
	using assms
	apply(simp add: integral_pmf[symmetric] pmf_bind)
	apply(subst Bochner_Integration.integral_add)
	using integrable_pmf apply fast
	using integrable_pmf apply fast
	by(simp add: integral_pmf)

	have E: "(cond_pmf
	(bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	{f. \<exists>e. Inl e = f}) =
	map_pmf Inl Da"
	apply(rule pmf_eqI)
	apply(subst pmf_cond)
	using none[of p Da Db] assms apply (simp)
	using assms apply(auto)
	apply(subst pmf_bind)
	apply(simp add: kl ll )
	apply(simp only: pmf_eq_0_set_pmf) by auto

	have ID: "case_sum (\<lambda>e. e) (\<lambda>a. undefined) \<circ> Inl = id"
	by fastforce
	show ?thesis
	unfolding Sum_pmf_def Proj1_pmf_def
	apply(simp only: E)
	apply(simp add: pmf.map_comp ID)
	done

	qed


	definition "Proj2_pmf D = map_pmf (%a. case a of Inr e \<Rightarrow> e) (cond_pmf D {f. (\<exists>e. Inr e = f)})"

	lemma proj2_pmf: assumes "p>0" "p<1" shows "Proj2_pmf (Sum_pmf p Da Db) = Db"
	proof -

	have kl: "\<And>e. pmf (map_pmf Inl Da) (Inr e) = 0"
	apply(simp only: pmf_eq_0_set_pmf)
	apply(simp) by blast

	have ll: "measure_pmf.prob
	(bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	{f. \<exists>e. Inr e = f} = 1-p"
	using assms
	apply(simp add: integral_pmf[symmetric] pmf_bind)
	apply(subst Bochner_Integration.integral_add)
	using integrable_pmf apply fast
	using integrable_pmf apply fast
	by(simp add: integral_pmf)

	have E: "(cond_pmf
	(bernoulli_pmf p \<bind>
	(\<lambda>b. if b then map_pmf Inl Da else map_pmf Inr Db))
	{f. \<exists>e. Inr e = f}) =
	map_pmf Inr Db"
	apply(rule pmf_eqI)
	apply(subst pmf_cond)
	using none2[of p Da Db] assms apply (simp)
	using assms apply(auto)
	apply(subst pmf_bind)
	apply(simp add: kl ll )
	apply(simp only: pmf_eq_0_set_pmf) by auto

	have ID: "case_sum (\<lambda>e. undefined) (\<lambda>a. a) \<circ> Inr = id"
	by fastforce
	show ?thesis
	unfolding Sum_pmf_def Proj2_pmf_def
	apply(simp only: E)
	apply(simp add: pmf.map_comp ID)
	done

	qed




	definition "invSum invA invB D x i == invA (Proj1_pmf D) x i \<and> invB (Proj2_pmf D) x i"


	lemma invSum_split: "p>0 \<Longrightarrow> p<1 \<Longrightarrow> invA Da x i \<Longrightarrow> invB Db x i \<Longrightarrow> invSum invA invB (Sum_pmf p Da Db) x i"
	by(simp add: invSum_def proj1_pmf proj2_pmf)

	term "(%a. case a of Inl e \<Rightarrow> Inl (fa e) \| Inr e \<Rightarrow> Inr (fb e))"
	definition "f_on2 fa fb = (%a. case a of Inl e \<Rightarrow> map_pmf Inl (fa e) \| Inr e \<Rightarrow> map_pmf Inr (fb e))"

	term "bind_pmf"


	lemma Sum_bind_pmf: assumes a: "bind_pmf Da fa = Da'" and b: "bind_pmf Db fb = Db'"
	shows "bind_pmf (Sum_pmf p Da Db) (f_on2 fa fb)
	= Sum_pmf p Da' Db'"
	proof -
	{ fix x
	have "(if x then map_pmf Inl Da else map_pmf Inr Db) \<bind>
	case_sum (\<lambda>e. map_pmf Inl (fa e))
	(\<lambda>e. map_pmf Inr (fb e))
	=
	(if x then map_pmf Inl Da \<bind> case_sum (\<lambda>e. map_pmf Inl (fa e))
	(\<lambda>e. map_pmf Inr (fb e))
	else map_pmf Inr Db \<bind> case_sum (\<lambda>e. map_pmf Inl (fa e))
	(\<lambda>e. map_pmf Inr (fb e)))"
	apply(simp) done
	also
	have "\<dots> = (if x then map_pmf Inl (bind_pmf Da fa) else map_pmf Inr (bind_pmf Db fb))"
	by(auto simp add: map_pmf_def bind_assoc_pmf bind_return_pmf)
	also
	have "\<dots> = (if x then map_pmf Inl Da' else map_pmf Inr Db')"
	using a b by simp
	finally
	have "(if x then map_pmf Inl Da else map_pmf Inr Db) \<bind>
	case_sum (\<lambda>e. map_pmf Inl (fa e))
	(\<lambda>e. map_pmf Inr (fb e)) = (if x then map_pmf Inl Da' else map_pmf Inr Db')" .
	} note gr=this



	show ?thesis
	unfolding Sum_pmf_def f_on2_def
	apply(rule pmf_eqI)
	apply(case_tac i)
	by(simp_all add: bind_return_pmf bind_assoc_pmf gr)
	qed

	definition "sum_map_pmf fa fb = (%a. case a of Inl e \<Rightarrow> Inl (fa e) \| Inr e \<Rightarrow> Inr (fb e))"

	lemma Sum_map_pmf: assumes a: "map_pmf fa Da = Da'" and b: "map_pmf fb Db = Db'"
	shows "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
	= Sum_pmf p Da' Db'"
	proof -
	have "map_pmf (sum_map_pmf fa fb) (Sum_pmf p Da Db)
	= bind_pmf (Sum_pmf p Da Db) (f_on2 (\<lambda>x. return_pmf (fa x)) (\<lambda>x. return_pmf (fb x)))"
	using a b
	unfolding map_pmf_def sum_map_pmf_def f_on2_def
	by(auto simp add: bind_return_pmf sum.case_distrib)
	also
	have "\<dots> = Sum_pmf p Da' Db'"
	using assms[unfolded map_pmf_def]
	by(rule Sum_bind_pmf )
	finally
	show ?thesis .
	qed



	end
	diff --git a/thys/List_Update/TS.thy b/thys/List_Update/TS.thy
	--- a/thys/List_Update/TS.thy
	+++ b/thys/List_Update/TS.thy
	@@ -1,2682 +1,2682 @@
	(* Title: Competitive Analysis of TS
	Author: Max Haslbeck
	*)

	section "TS: another 2-competitive Algorithm"

	theory TS
	imports
	OPT2
	Phase_Partitioning
	Move_to_Front
	List_Factoring
	RExp_Var
	begin



	subsection "Definition of TS"



	definition TS_step_d where
	"TS_step_d s q = ((
	(
	let li = index (snd s) q in
	(if li = length (snd s) then 0 \<comment> \<open>requested for first time\<close>
	else (let sincelast = take li (snd s)
	in (let S={x. x < q in (fst s) \<and> count_list sincelast x \<le> 1}
	in
	(if S={} then 0
	else
	(index (fst s) q) - Min ( (index (fst s)) ` S)))
	)
	)
	)
	,[]), q#(snd s))"


	(* FIXME: generalizing regular expressions equivalence checking
	enables relaxing the type here to 'a::linord *)
	definition rTS :: "nat list \<Rightarrow> (nat,nat list) alg_on" where "rTS h = ((\<lambda>s. h), TS_step_d)"

	fun TSstep where
	"TSstep qs n (is,s)
	= ((qs!n)#is,
	step s (qs!n) ((
	let li = index is (qs!n) in
	(if li = length is then 0 \<comment> \<open>requested for first time\<close>
	else (let sincelast = take li is
	in (let S={x. x < (qs!n) in s \<and> count_list sincelast x \<le> 1}
	in
	(if S={} then 0
	else
	(index s (qs!n)) - Min ( (index s) ` S)))
	)
	)
	),[]))"

	lemma TSnopaid: "(snd (fst (snd (rTS initH) is q))) = []"
	unfolding rTS_def by(simp add: TS_step_d_def)


	abbreviation TSdet where
	"TSdet init initH qs n == config (rTS initH) init (take n qs)"

	lemma TSdet_Suc: "Suc n \<le> length qs \<Longrightarrow> TSdet init initH qs (Suc n) = Step (rTS initH) (TSdet init initH qs n) (qs!n)"
	by(simp add: take_Suc_conv_app_nth config_snoc)

	(* now do the proof with TSdet *)

	definition s_TS where "s_TS init initH qs n = fst (TSdet init initH qs n)"

	lemma sndTSdet: "n\<le>length xs \<Longrightarrow> snd (TSdet init initH xs n) = rev (take n xs) @ initH"
	apply(induct n)
	apply(simp add: rTS_def)
	by(simp add: split_def TS_step_d_def take_Suc_conv_app_nth config'_snoc Step_def rTS_def)


	subsection "Behaviour of TS on lists of length 2"

	lemma
	fixes hs x y
	assumes "x\<noteq>y"
	shows oneTS_step : "TS_step_d ([x, y], x#y#hs) y = ((1, []), y # x # y # hs)"
	and oneTS_stepyyy: "TS_step_d ([x, y], y#x#hs) y = ((Suc 0, []), y#y#x#hs)"
	and oneTS_stepx: "TS_step_d ([x, y], x#x#hs) y = ((0, []), y # x # x # hs)"
	and oneTS_stepy: "TS_step_d ([x, y], []) y = ((0, []), [y])"
	and oneTS_stepxy: "TS_step_d ([x, y], [x]) y = ((0, []), [y, x])"
	and oneTS_stepyy: "TS_step_d ([x, y], [y]) y = ((Suc 0, []), [y, y])"
	and oneTS_stepyx: "TS_step_d ([x, y], hs) x = ((0, []), x # hs)"
	using assms by(auto simp add: step_def mtf2_def swap_def TS_step_d_def before_in_def)

	lemmas oneTS_steps = oneTS_stepx oneTS_stepxy oneTS_stepyx oneTS_stepy oneTS_stepyy oneTS_stepyyy oneTS_step

	subsection "Analysis of the Phases"

	definition "TS_inv c x i \<equiv> (\<exists>hs. c = return_pmf ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> c = return_pmf ((if x=hd i then i else rev i),[])"

	lemma TS_inv_sym: "a\<noteq>b \<Longrightarrow> {a,b}={x,y} \<Longrightarrow> z\<in>{x,y} \<Longrightarrow> TS_inv c z [a,b] = TS_inv c z [x,y]"
	unfolding TS_inv_def by auto

	abbreviation "TS_inv' s x i == TS_inv (return_pmf s) x i"

	lemma TS_inv'_det: "TS_inv' s x i = ((\<exists>hs. s = ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> s = ((if x=hd i then i else rev i),[]))"
	unfolding TS_inv_def by auto

	lemma TS_inv'_det2: "TS_inv' (s,h) x i = (\<exists>hs. (s,h) = ((if x=hd i then i else rev i),[x,x]@hs) )
	\<or> (s,h) = ((if x=hd i then i else rev i),[])"
	unfolding TS_inv_def by auto

	(*
	TS_A (x+1)yy \<rightarrow> Plus(Atom (x::nat)) One,(Atom y), (Atom y)]
	TS_B (x+1)yx(yx)*yy \<rightarrow> Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]
	TS_C (x+1)yx(yx)*x \<rightarrow> Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]
	TD_D xx \<rightarrow> seq[(Atom x),(Atom x)]
	*)

	subsubsection "(yx)*?"

	lemma TS_yx': assumes "x \<noteq> y" "qs \<in> lang (Star(Times (Atom y) (Atom x)))"
	"\<exists>hs. h=[x,y]@hs"
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs + T_on' (rTS h0) ([x,y],((rev qs) @h)) r
	\<and> (\<exists>hs. ((rev qs) @h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],h) qs = ([x,y],rev qs @ h)"
	proof -
	from assms have "qs \<in> star ({[y]} @@ {[x]})" by (simp)
	from this assms(3) show ?thesis
	proof (induct qs arbitrary: h rule: star_induct)
	case Nil
	then show ?case by(simp add: rTS_def)
	next
	case (append u v)
	then have uyx: "u = [y,x]" by auto
	from append obtain hs where a: "h = [x,y]@hs" by blast

	have "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r
	\<and> (\<exists>hs. rev v @ (rev u @ h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))"
	apply(simp only: uyx) apply(rule append(3)) by simp
	then have yy: "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r"
	and history: "(\<exists>hs. rev v @ (rev u @ h) = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))" by auto

	have s0: "s_TS [x, y] h [y, x] 0 = [x,y]" unfolding s_TS_def by(simp)

	from assms(1) have hahah: " {xa. xa < y in [x, y] \<and> count_list [x] xa \<le> 1} = {x}"
	unfolding before_in_def by auto



	have "config' (rTS h0) ([x, y],h) u = ([x, y], x # y # x # y # hs)"
	apply(simp add: split_def rTS_def uyx a )
	using assms(1) by(auto simp add: Step_def oneTS_steps step_def mtf2_def swap_def)

	then have s2: "config' (rTS h0) ([x, y],h) u = ([x, y], ((rev u) @ h))"
	unfolding a uyx by simp

	have "config' (rTS h0) ([x, y], h) (u @ v) =
	config' (rTS h0) (Partial_Cost_Model.config' (rTS h0) ([x, y], h) u) v" by (rule config'_append2)
	also
	have "\<dots> = config' (rTS h0) ([x, y], ((rev u) @ h)) v" by(simp only: s2)
	also
	have "\<dots> = ([x, y], rev (u @ v) @ h)" by (simp add: state)
	finally
	have alles: "config' (rTS h0) ([x, y], h) (u @ v) = ([x, y], rev (u @ v) @ h)" .


	have ta: "T_on' (rTS h0) ([x,y],h) u = 2"
	unfolding rTS_def uyx a apply(simp only: T_on'.simps(2))
	using assms(1) apply(auto simp add: Step_def step_def mtf2_def swap_def oneTS_steps)
	by(simp add: t\<^sub>p_def)



	have "T_on' (rTS h0) ([x,y],h) ((u @ v) @ r)
	= T_on' (rTS h0) ([x,y],h) (u @ (v @ r))" by auto
	also have "\<dots>
	= T_on' (rTS h0) ([x,y],h) u
	+ T_on' (rTS h0) (config' (rTS h0) ([x, y],h) u) (v @ r)"
	by(rule T_on'_append)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u
	+ T_on' (rTS h0) ([x, y],(rev u @ h)) (v @ r)" by(simp only: s2)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: yy)
	also have "\<dots> = 2 + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: ta)
	also have "\<dots> = length (u @ v) + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" using uyx by auto
	also have "\<dots> = length (u @ v) + T_on' (rTS h0) ([x, y], (rev (u @ v) @ h)) r" by auto
	finally show ?case using history alles by simp
	qed
	qed

	subsubsection "?x"


	lemma TS_x': "T_on' (rTS h0) ([x,y],h) [x] = 0 \<and> config' (rTS h0) ([x, y],h) [x] = ([x,y], rev [x] @ h)"
	by(auto simp add: t\<^sub>p_def rTS_def TS_step_d_def Step_def step_def)

	subsubsection "?yy"

	lemma TS_yy': assumes "x \<noteq> y" "\<exists>hs. h = [x, y] @ hs"
	shows "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
	proof -
	from assms obtain hs where a: "h = [x,y]@hs" by blast

	from a show "T_on' (rTS h0) ([x,y],h) [y, y] = 1"
	unfolding rTS_def
	using assms(1) apply(auto simp add: oneTS_steps Step_def step_def mtf2_def swap_def)
	by(simp add: t\<^sub>p_def)

	show "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
	unfolding rTS_def a using assms(1)
	by(simp add: Step_def oneTS_steps step_def mtf2_def swap_def)
	qed

	subsubsection "yx(yx)*?"

	lemma TS_yxyx': assumes [simp]: "x \<noteq> y" and "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	"(\<exists>hs. h=[x,x]@hs) \<or> index h y = length h"
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r
	\<and> (\<exists>hs. (rev qs @ h) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],h) qs = ([x,y], rev qs @ h)"
	proof -
	obtain u v where uu: "u \<in> lang (Times (Atom y) (Atom x))"
	and vv: "v \<in> lang (seq[ Star(Times (Atom y) (Atom x))])"
	and qsuv: "qs = u @ v"
	using assms(2)
	by (auto simp: conc_def)
	from uu have uyx: "u = [y,x]" by(auto)

	from qsuv uyx have vqs: "length v = length qs - 2" by auto
	from qsuv uyx have vqs2: "length v + 1 = length qs - 1" by auto

	have firststep: "TS_step_d ([x, y], h) y = ((0, []), y # h)"
	proof (cases "index h y = length h")
	case True
	then show ?thesis unfolding TS_step_d_def by(simp)
	next
	case False
	with assms(3) obtain hs where a: "h = [x,x]@hs" by auto
	then show ?thesis by(simp add: oneTS_steps)
	qed

	have s2: "config' (rTS h0) ([x,y],h) u = ([x, y], x # y # h)"
	- unfolding rTS_def uyx apply(simp add: )
	+ unfolding rTS_def uyx applysimp
	unfolding Step_def by(simp add: firststep step_def oneTS_steps)

	have ta: "T_on' (rTS h0) ([x,y],h) u = 1"
	unfolding rTS_def uyx
	apply(simp)
	apply(simp add: firststep)
	unfolding Step_def
	using assms(1) by (simp add: firststep step_def oneTS_steps t\<^sub>p_def)

	have ttt:
	"T_on' (rTS h0) ([x,y],rev u @ h) (v@r) = length v + T_on' (rTS h0) ([x,y],((rev v) @(rev u @ h))) r
	\<and> (\<exists>hs. ((rev v) @(rev u @ h)) = [x, y] @ hs)
	\<and> config' (rTS h0) ([x, y],(rev u @ h)) v = ([x,y],rev v @ (rev u @ h))"
	apply(rule TS_yx')
	apply(fact)
	using vv apply(simp)
	using uyx by(simp)
	then have tat: "T_on' (rTS h0) ([x,y], x # y # h) (v@r) =
	length v + T_on' (rTS h0) ([x,y],rev qs @ h) r"
	and history: "(\<exists>hs. (rev qs @ h) = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], x # y # h) v = ([x,y],rev qs @ h)" using qsuv uyx
	by auto

	have "config' (rTS h0) ([x, y], h) qs = config' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
	unfolding qsuv by (rule config'_append2)
	also
	have "\<dots> = ([x, y], rev qs @ h)" by(simp add: s2 state)
	finally
	have his: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)" .


	have "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],h) (u @ v @ r)" using qsuv by auto
	also have "\<dots>
	= T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) (config' (rTS h0) ([x,y],h) u) (v @ r)"
	by(rule T_on'_append)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) ([x, y], x # y # h) (v @ r)" by(simp only: s2)
	also have "\<dots> = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by (simp only: tat)
	also have "\<dots> = 1 + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by(simp only: ta)
	also have "\<dots> = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r" using vqs2 by auto
	finally show ?thesis
	apply(safe)
	using history apply(simp)
	using his by auto
	qed




	lemma TS_xr': assumes "x \<noteq> y" "qs \<in> lang (Plus (Atom x) One)"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs) "
	shows "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],rev qs@h) r"
	"((\<exists>hs. (rev qs @ h) = [x, x] @ hs) \<or> (rev qs @ h) = [x] \<or> (rev qs @ h)=[]) "
	"config' (rTS h0) ([x,y],h) (qs@r) = config' (rTS h0) ([x,y],rev qs @ h) r"
	using assms
	by (auto simp add: T_on'_append Step_def rTS_def TS_step_d_def step_def t\<^sub>p_def)

	subsubsection "(x+1)yx(yx)*yy"

	lemma ts_b': assumes "x \<noteq> y"
	"v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
	\<and> (\<exists>hs. (rev v @ h) = [y,y]@hs) \<and> config' (rTS h0) ([x,y], h) v = ([y,x], rev v @ h)"
	proof -
	from assms have lenvmod: "length v mod 2 = 0" apply(simp)
	proof -
	assume "v \<in> ({[y]} @@ {[x]}) @@ star ({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}"
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in> {[y]} @@ {[y]}" by (metis concE)
	then have "p = [y,x]" "r=[y,y]" by auto
	with pqr have a: "length v = 4+length q" by auto

	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show ?thesis by auto
	qed

	with assms(1,3) have fall: "(\<exists>hs. h = [x, x] @ hs) \<or> index h y = length h"
	by(auto)

	from assms(2) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
	@@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
	then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	and "b \<in> lang (seq[Atom y, Atom y])"
	and vab: "v = a @ b"
	by(erule concE)
	then have bb: "b=[y,y]" by auto
	from aa have lena: "length a > 0" by auto

	from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
	length a - 1 + T_on' (rTS h0) ([x, y], rev a @ h) b"
	and history: "(\<exists>hs. rev a @ h = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], h) a = ([x,y],rev a @ h)" by auto
	(* "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)" *)
	have suffix: "T_on' (rTS h0) ([x, y], rev a @ h) b = 1"
	and jajajaj: "config' (rTS h0) ([x, y],rev a @ h) b = ([y,x],rev b @ rev a @ h)" unfolding bb
	using TS_yy' history assms(1) by auto

	from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a" using lena by auto
	then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto


	have grgr:"config' (rTS h0) ([x, y], h) v = ([y, x], rev v @ h)"
	unfolding vab
	apply(simp only: config'_append2 state jajajaj) by simp

	from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
	then obtain hs2 where reva: "rev a @ h = x # hs2" by auto

	show ?thesis using whatineed grgr
	by(auto simp add: reva vab bb)
	qed

	lemma TS_b'1: assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	have f: "qs \<in> lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	using assms(3) by(simp add: conc_assoc)

	from ts_b'[OF assms(1) f] assms(2) have
	T_star: "T_on' (rTS h0) ([x, y], h) qs = length qs - 2"
	and inv1: "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
	and inv2: "(\<exists>hs. rev qs @ h = [y, y] @ hs)" by auto

	from T_star have TS: "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)" by metis

	have lqs: "last qs = y" using assms(3) by force


	from inv1 have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
	apply(simp add: lqs)
	apply(subst TS_inv'_det)
	using assms(2) inv2 by(simp)


	show ?thesis unfolding TS
	apply(safe)
	by(fact inv)
	qed



	lemma TS_b1'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	then have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []" by blast
	from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_b'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note b1=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed


	lemma ts_b2': assumes "x \<noteq> y"
	"qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
	\<and> config' (rTS h0) ([x,y], h) qs = ([y,x],rev qs@h) \<and> (\<exists>hs. (rev qs @ h) = [y,y]@hs)"
	proof -
	from assms(2) obtain v where qs: "qs = [x]@v"
	and V: "v\<in>lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	by(auto simp add: conc_assoc)

	from assms(3) have 3: "(\<exists>hs. x#h = [x, x] @ hs) \<or> x#h = [x] \<or> x#h = []" by auto

	from ts_b'[OF assms(1) V 3]
	have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
	and C: "config' (rTS h0) ([x, y], x#h) v = ([y, x], rev v @ x#h)"
	and H: "(\<exists>hs. rev v @ x#h = [y, y] @ hs)" by auto

	have t: "t\<^sub>p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
	by (simp add: step_def rTS_def TS_step_d_def t\<^sub>p_def)
	have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
	= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

	show ?thesis
	unfolding qs apply(safe)
	apply(simp add: T_on'_append T c t)
	apply(simp add: config'_rand_append C c)
	using H by simp
	qed


	lemma TS_b2'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

	from C have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = []" by blast

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_b2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note b2=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed



	lemma TS_b': assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs
	\<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
	and qsuv: "qs = u @ v"
	using assms(3)
	by (auto simp: conc_def)

	from TS_xr'[OF assms(1) uu assms(2)] have
	T_pre: "T_on' (rTS h0) ([x, y], h) (u @ v) =
	T_on' (rTS h0) ([x, y], rev u @ h) v"
	and fall': "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> (rev u @ h) = [x] \<or> (rev u @ h)=[]"
	and conf: "config' (rTS h0) ([x,y],h) (u@v) = config' (rTS h0) ([x,y],rev u @ h) v"
	by auto

	with assms uu have fall: "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> index (rev u @ h) y = length (rev u @ h)"
	by(auto)

	from ts_b'[OF assms(1) vv fall'] have
	T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = length v - 2"
	and inv1: "config' (rTS h0) ([x, y], rev u @ h) v = ([y, x], rev v @ rev u @ h)"
	and inv2: "(\<exists>hs. rev v @ rev u @ h = [y, y] @ hs)" by auto

	from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

	(* OPT *)

	from uu have uuu: "u=[] \<or> u=[x]" by auto
	from vv have vvv: "v \<in> lang (seq
	[Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto simp: conc_def)
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+

	have lqs: "last qs = y" using assms(3) by force

	have "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
	unfolding qsuv conf inv1 by simp

	then have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
	apply(simp add: lqs)
	apply(subst TS_inv'_det)
	using assms(2) inv2 qsuv by(simp)


	show ?thesis unfolding TS OPT
	apply(safe)
	apply(simp)
	by(fact inv)
	qed


	subsubsection "(x+1)yy"


	lemma ts_a': assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	shows "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]
	\<and> T_on' (rTS h0) ([x, y], h) qs = 2"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Atom y, Atom y])"
	and qsuv: "qs = u @ v"
	using assms(2)
	by (auto simp: conc_def)

	from vv have vv2: "v = [y,y]" by auto

	from uu have TS_prefix: " T_on' (rTS h0) ([x, y], h) u = 0"
	using assms(1) by(auto simp add: rTS_def oneTS_steps t\<^sub>p_def)

	have h_split: "rev u @ h = [] \<or> rev u @ h = [x] \<or> (\<exists> hs. rev u @ h = [x,x]@hs)"
	using assms(3) uu by(auto)

	then have e: "T_on' (rTS h0) ([x,y],rev u @ h) [y,y] = 2"
	using assms(1)
	apply(auto simp add: rTS_def
	oneTS_steps
	Step_def step_def t\<^sub>p_def) done

	have conf: "config' (rTS h0) ([x, y], h) u = ([x,y], rev u @ h)"
	using uu by(auto simp add: Step_def rTS_def TS_step_d_def step_def)

	have "T_on' (rTS h0) ([x, y], h) qs = T_on' (rTS h0) ([x, y], h) (u @ v)" using qsuv by auto
	also have "\<dots>
	=T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
	by(rule T_on'_append)
	also have "\<dots>
	= T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) ([x,y],rev u @ h) [y,y]"
	by(simp add: conf vv2)
	also have "\<dots> = T_on' (rTS h0) ([x, y], h) u + 2" by (simp only: e)
	also have "\<dots> = 2" by (simp add: TS_prefix)
	finally have TS: "T_on' (rTS h0) ([x, y], h) qs= 2" .

	(* dannach *)

	have lqs: "last qs = y" using assms(2) by force

	from assms(1) have "config' (rTS h0) ([x, y], h) qs = ([y,x], rev qs @ h)"
	unfolding qsuv
	apply(simp only: config'_append2 conf vv2)
	using h_split
	apply(auto simp add: Step_def rTS_def
	oneTS_steps
	step_def)
	by(simp_all add: mtf2_def swap_def)

	with assms(1) have "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	apply(subst TS_inv'_det)
	by(simp add: qsuv vv2 lqs)

	show ?thesis unfolding TS apply(auto) by fact
	qed

	lemma TS_a': assumes "x \<noteq> y"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	and "qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])"
	shows "T_on' (rTS h0) ([x, y], h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]
	\<and> T_on' (rTS h0) ([x, y], h) qs = 2"
	proof -
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = 1" using OPT2_A[OF assms(1,3)] by auto
	show ?thesis using OPT ts_a'[OF assms(1,3,2)] by auto
	qed

	lemma TS_a'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
	shows
	"TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T\<^sub>p_on_rand' (embed (rTS h0)) s qs = 2"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto

	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	"qs \<in> lang (seq [question (Atom x), Atom y, Atom y])"
	"h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_a'[OF A] by auto
	} note b=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule b)
	using assms apply(simp)
	using assms apply(simp)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule b)
	using assms apply(simp)
	using assms apply(simp)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed

	subsubsection "x+yx(yx)*x"

	lemma ts_c': assumes "x \<noteq> y"
	"v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
	\<and> config' (rTS h0) ([x,y], h) v = ([x,y],rev v@h) \<and> (\<exists>hs. (rev v @ h) = [x,x]@hs)"
	proof -
	from assms have lenvmod: "length v mod 2 = 1" apply(simp)
	proof -
	assume "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}"
	then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
	and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in> {[x]}" by (metis concE)
	then have "p = [y,x]" "r=[x]" by auto
	with pqr have a: "length v = 3+length q" by auto

	from q have b: "length q mod 2 = 0"
	apply(induct q rule: star_induct) by (auto)
	from a b show "length v mod 2 = Suc 0" by auto
	qed

	with assms(1,3) have fall: "(\<exists>hs. h = [x, x] @ hs) \<or> index h y = length h"
	by(auto)



	from assms(2) have "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
	@@ lang (seq[Atom x])" by (auto simp: conc_def)
	then obtain a b where aa: "a \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
	and "b \<in> lang (seq[Atom x])"
	and vab: "v = a @ b"
	by(erule concE)
	then have bb: "b=[x]" by auto
	from aa have lena: "length a > 0" by auto

	from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
	length a - 1 + T_on' (rTS h0) ([x, y],rev a @ h) b"
	and history: "(\<exists>hs. rev a @ h = [x, y] @ hs)"
	and state: "config' (rTS h0) ([x, y], h) a = ([x, y], rev a @ h)" by auto


	have suffix: "T_on' (rTS h0) ( [x, y],rev a @ h) b = 0"
	and suState: "config' (rTS h0) ([x, y], rev a @ h) b = ([x,y], rev b @ (rev a @ h))"
	unfolding bb using TS_x' by auto

	from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a - 1" by auto
	then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto

	have conf: "config' (rTS h0) ([x, y], h) v = ([x, y], rev v @ h)"
	by(simp add: vab config'_append2 state suState)


	from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
	then obtain hs2 where reva: "rev a @ h = x # hs2" by auto


	show ?thesis using whatineed
	apply(auto)
	using conf apply(simp)
	by(simp add: reva vab bb)
	qed


	lemma TS_c1'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	then have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = [x] \<or> h = []" by blast
	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_c'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note c1=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule c1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule c1)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed

	lemma ts_c2': assumes "x \<noteq> y"
	"qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	"(\<exists>hs. h = [x, x] @ hs) \<or> h = []"
	shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
	\<and> config' (rTS h0) ([x,y], h) qs = ([x,y],rev qs@h) \<and> (\<exists>hs. (rev qs @ h) = [x,x]@hs)"
	proof -
	from assms(2) obtain v where qs: "qs = [x]@v"
	and V: "v\<in>lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	by(auto simp add: conc_assoc)

	from assms(3) have 3: "(\<exists>hs. x#h = [x, x] @ hs) \<or> x#h = [x] \<or> x#h = []" by auto

	from ts_c'[OF assms(1) V 3]
	have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
	and C: "config' (rTS h0) ([x, y], x#h) v = ([x, y], rev v @ x#h)"
	and H: "(\<exists>hs. rev v @ x#h = [x, x] @ hs)" by auto

	have t: "t\<^sub>p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
	by (simp add: step_def rTS_def TS_step_d_def t\<^sub>p_def)
	have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
	= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

	show ?thesis
	unfolding qs apply(safe)
	apply(simp add: T_on'_append T c t)
	apply(simp add: config'_rand_append C c)
	using H by simp
	qed


	lemma TS_c2'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

	from C have C': "(\<exists>hs. h = [x, x] @ hs) \<or> h = []" by blast

	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using ts_c2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
	} note c2=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule c2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule c2)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed


	lemma TS_c': assumes "x \<noteq> y" "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	"qs \<in> lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
	shows "T_on' (rTS h0) ([x, y], h) qs
	\<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<and> TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	proof -
	obtain u v where uu: "u \<in> lang (Plus (Atom x) One)"
	and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
	and qsuv: "qs = u @ v"
	using assms(3)
	by (auto simp: conc_def)

	from TS_xr'[OF assms(1) uu assms(2)] have
	T_pre: "T_on' (rTS h0) ([x, y], h) (u@v) = T_on' (rTS h0) ([x, y], rev u @ h) v"
	and fall': "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> (rev u @ h) = [x] \<or> (rev u @ h)=[]"
	and conf': "config' (rTS h0) ([x, y], h) (u @ v) =
	config' (rTS h0) ([x, y], rev u @ h) v" by auto

	with assms uu have fall: "(\<exists>hs. (rev u @ h) = [x, x] @ hs) \<or> index (rev u @ h) y = length (rev u @ h)"
	by(auto)

	from ts_c'[OF assms(1) vv fall'] have
	T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = (length v - 2)"
	and inv1: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ rev u @ h)"
	and inv2: "(\<exists>hs. rev v @ rev u @ h = [x, x] @ hs)" by auto

	from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

	(* OPT *)

	from uu have uuu: "u=[] \<or> u=[x]" by auto
	from vv have vvv: "v \<in> lang (seq
	[Atom y, Atom x,
	Star (Times (Atom y) (Atom x)),
	Atom x])" by(auto simp: conc_def)
	have OPT: "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+

	have lqs: "last qs = x" using assms(3) by force

	have conf: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)"
	by(simp add: qsuv conf' inv1)
	then have conf: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
	apply(simp add: lqs)
	apply( subst TS_inv'_det)
	using inv2 qsuv by(simp)

	show ?thesis unfolding TS OPT
	by (auto simp add: conf)
	qed



	subsubsection "xx"

	lemma request_first: "x\<noteq>y \<Longrightarrow> Step (rTS h) ([x, y], is) x = ([x,y],x#is)"
	unfolding rTS_def Step_def by(simp add: split_def TS_step_d_def step_def)

	lemma ts_d': "qs \<in> Lxx x y \<Longrightarrow>
	x \<noteq> y \<Longrightarrow>
	h = [] \<or> (\<exists>hs. h = [x, x] @ hs) \<Longrightarrow>
	qs \<in> lang (seq [Atom x, Atom x]) \<Longrightarrow>
	T_on' (rTS h0) ([x, y], h) qs = 0 \<and>
	TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x,y]"
	proof -
	assume xny: "x \<noteq> y"
	assume "qs \<in> lang (seq [Atom x, Atom x])"
	then have xx: "qs = [x,x]" by auto

	from xny have TS: "T_on' (rTS h0) ([x, y], h) qs = 0" unfolding xx
	by(auto simp add: Step_def step_def oneTS_steps rTS_def t\<^sub>p_def)

	from xny have "config' (rTS h0) ([x, y], h) qs = ([x, y], x # x # h) "
	by(auto simp add: xx Step_def rTS_def oneTS_steps step_def)

	then have " TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x, y]"
	by(simp add: TS_inv'_det)

	with TS show ?thesis by simp
	qed



	lemma TS_d': assumes xny: "x \<noteq> y" and "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	and qsis: "qs \<in> lang (seq [Atom x, Atom x])"
	shows "T_on' (rTS h0) ([x,y],h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y]) "
	and "TS_inv' (config' (rTS h0) ([x,y],h) qs) (last qs) [x, y]"
	and "T_on' (rTS h0) ([x,y],h) qs = 0"
	proof -
	from qsis have xx: "qs = [x,x]" by auto

	show TS: "T_on' (rTS h0) ([x,y],h) qs = 0"
	using assms(1) by (auto simp add: xx t\<^sub>p_def rTS_def Step_def oneTS_steps step_def)
	then show "T_on' (rTS h0) ([x,y],h) qs \<le> 2 * T\<^sub>p [x, y] qs (OPT2 qs [x, y])" by simp

	show "TS_inv' (config' (rTS h0) ([x,y],h) qs) (last qs) [x, y]"
	unfolding TS_inv_def
	by(simp add: xx request_first[OF xny])
	qed


	lemma TS_d'': assumes
	"x \<noteq> y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
	"set qs \<subseteq> {x, y}"
	"qs \<in> lang (seq [Atom x, Atom x])"
	shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
	\<and> T_on_rand' (embed (rTS h0)) s qs = 0"
	proof -
	from assms(1,2) have kas: "(x0=x \<and> y0=y) \<or> (y0=x \<and> x0=y)" by(auto)
	then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

	have l: "qs \<noteq> []" using assms by auto
	{
	fix x y qs h0
	fix h:: "nat list"
	assume A: "x \<noteq> y"
	and B: "qs \<in> lang (seq [Atom x, Atom x])"
	and C: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"

	from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)


	have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] \<and>
	T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 0"
	apply(simp only: T_on'_embed[symmetric] config'_embed)
	using TS_d'[OF A C B ] A lqs unfolding TS_inv'_det by auto
	} note d=this


	show ?thesis unfolding S
	using kas apply(rule disjE)
	apply(simp only:)
	apply(rule d)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	apply(simp only:)

	apply(subst TS_inv_sym[of y x x y])
	using assms(1) apply(simp)
	apply(blast)
	defer
	apply(rule d)
	using assms apply(simp)
	using assms apply(simp add: conc_assoc)
	using h apply(simp)
	using last_in_set l assms(4) by blast
	qed



	subsection "Phase Partitioning"

	lemma D': assumes "\<sigma>' \<in> Lxx x y" and "x \<noteq> y" and "TS_inv' ([x, y], h) x [x, y]"
	shows "T_on' (rTS h0) ([x, y], h) \<sigma>' \<le> 2 * T\<^sub>p [x, y] \<sigma>' (OPT2 \<sigma>' [x, y])
	\<and> TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>') (last \<sigma>') [x, y]"
	proof -

	from config'_embed have " config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>'
	= return_pmf (Partial_Cost_Model.config' (rTS h0) ([x, y], h) \<sigma>')" by blast

	then have L: "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) \<sigma>') (last \<sigma>') [x, y]
	= TS_inv' (config' (rTS h0) ([x, y], h) \<sigma>') (last \<sigma>') [x, y]" by auto

	from assms(3) have
	h: "h = [] \<or> (\<exists>hs. h = [x, x] @ hs)"
	by(auto simp add: TS_inv'_det)

	have "T_on' (rTS h0) ([x, y], h) \<sigma>' \<le> 2 * T\<^sub>p [x, y] \<sigma>' (OPT2 \<sigma>' [x, y])
	\<and> TS_inv' (config' (rTS h0) ([x, y], h) \<sigma>') (last \<sigma>') [x, y]"
	apply(rule LxxE[OF assms(1)])
	using TS_d'[OF assms(2) h, of "\<sigma>'"] apply(simp)
	using TS_b'[OF assms(2) h] apply(simp)
	using TS_c'[OF assms(2) h] apply(simp)
	using TS_a'[OF assms(2) h] apply fast
	done

	then show ?thesis using L by auto
	qed

	theorem TS_OPT2': "(x::nat) \<noteq> y \<Longrightarrow> set \<sigma> \<subseteq> {x,y}
	\<Longrightarrow> T\<^sub>p_on (rTS []) [x,y] \<sigma> \<le> 2 * real (T\<^sub>p_opt [x,y] \<sigma>) + 2"
	apply(subst T_on_embed)
	apply(rule Phase_partitioning_general[where P=TS_inv])
	apply(simp)
	apply(simp)
	apply(simp)
	apply(simp add: TS_inv_def rTS_def)
	proof (goal_cases)
	case (1 a b \<sigma>' s)
	from 1(6) obtain h hist' where s: "s = return_pmf ([a, b], h)"
	and "h = [] \<or> h = [a,a]@hist'"
	unfolding TS_inv_def apply(cases "a=hd [x,y]")
	apply(simp) using 1 apply fast
	apply(simp) using 1 by blast

	from 1 have xyab: "TS_inv' ([a, b], h) a [x, y]
	= TS_inv' ([a, b], h) a [a, b]"
	by(auto simp add: TS_inv'_det)

	with 1(6) s have inv: "TS_inv' ([a, b], h) a [a, b]" by simp

	from \<open>\<sigma>' \<in> Lxx a b\<close> have "\<sigma>' \<noteq> []" using Lxx1 by fastforce
	then have l: "last \<sigma>' \<in> {x,y}" using 1(5,7) last_in_set by blast

	show ?case unfolding s T_on'_embed[symmetric]
	using D'[OF 1(3,4) inv, of "[]"]
	apply(safe)
	apply linarith
	using TS_inv_sym[OF 1(4,5)] l apply blast
	done
	qed

	subsection "TS is pairwise"



	lemma config'_distinct[simp]:
	shows "distinct (fst (config' A S qs)) = distinct (fst S)"
	apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def distinct_step)

	lemma config'_set[simp]:
	shows "set (fst (config' A S qs)) = set (fst S)"
	apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def set_step)

	lemma s_TS_append: "i\<le>length as \<Longrightarrow>s_TS init h (as@bs) i = s_TS init h as i"
	by (simp add: s_TS_def)

	lemma s_TS_distinct: "distinct init \<Longrightarrow> i<length qs \<Longrightarrow> distinct (fst (TSdet init h qs i))"
	by(simp_all add: config_config_distinct)

	lemma othersdontinterfere: "distinct init \<Longrightarrow> i < length qs \<Longrightarrow> a\<in>set init \<Longrightarrow> b\<in>set init
	\<Longrightarrow> set qs \<subseteq> set init \<Longrightarrow> qs!i\<notin>{a,b} \<Longrightarrow> a < b in s_TS init h qs i \<Longrightarrow> a < b in s_TS init h qs (Suc i)"
	apply(simp add: s_TS_def split_def take_Suc_conv_app_nth config_append Step_def step_def)
	apply(subst x_stays_before_y_if_y_not_moved_to_front)
	apply(simp_all add: config_config_distinct config_config_set)
	by(auto simp: rTS_def TS_step_d_def)

	lemma TS_mono:
	fixes l::nat
	assumes 1: "x < y in s_TS init h xs (length xs)"
	and l_in_cs: "l \<le> length cs"
	and firstocc: "\<forall>j<l. cs ! j \<noteq> y"
	and "x \<notin> set cs"
	and di: "distinct init"
	and inin: "set (xs @ cs) \<subseteq> set init"
	shows "x < y in s_TS init h (xs@cs) (length (xs)+l)"
	proof -
	from before_in_setD2[OF 1] have y: "y : set init" unfolding s_TS_def by(simp add: config_config_set)
	from before_in_setD1[OF 1] have x: "x : set init" unfolding s_TS_def by(simp add: config_config_set)

	{
	fix n
	assume "n\<le>l"
	then have "x < y in s_TS init h ((xs)@cs) (length (xs)+n)"
	proof(induct n)
	case 0
	show ?case apply (simp only: s_TS_append ) using 1 by(simp)
	next
	case (Suc n)
	then have n_lt_l: "n<l" by auto
	show ?case apply(simp)
	apply(rule othersdontinterfere)
	apply(rule di)
	using n_lt_l l_in_cs apply(simp)
	apply(fact x)
	apply(fact y)
	apply(fact inin)
	apply(simp add: nth_append) apply(safe)
	using assms(4) n_lt_l l_in_cs apply fastforce
	using firstocc n_lt_l apply blast
	using Suc(1) n_lt_l by(simp)
	qed
	}
	\<comment> \<open>before the request to y, x is in front of y\<close>
	then show "x < y in s_TS init h (xs@cs) (length (xs)+l)"
	by blast
	qed

	lemma step_no_action: "step s q (0,[]) = s"
	unfolding step_def mtf2_def by simp

	lemma s_TS_set: "i \<le> length qs \<Longrightarrow> set (s_TS init h qs i) = set init"
	apply(induct i)
	apply(simp add: s_TS_def )
	apply(simp add: s_TS_def TSdet_Suc)
	by(simp add: split_def rTS_def Step_def step_def)

	lemma count_notin2: "count_list xs x = 0 \<Longrightarrow> x \<notin> set xs"
	by (simp add: count_list_0_iff)

	lemma mtf2_q_passes: assumes "q \<in> set xs" "distinct xs"
	and "index xs q - n \<le> index xs x" "index xs x < index xs q"
	shows "q < x in (mtf2 n q xs)"
	proof -
	from assms have "index xs q < length xs" by auto
	with assms(4) have ind_x: "index xs x < length xs" by auto
	then have xinxs: "x\<in>set xs" using index_less_size_conv by metis

	have B: "index (mtf2 n q xs) q = index xs q - n"
	apply(rule mtf2_q_after)
	by(fact)+
	also from ind_x mtf2_forward_effect3'[OF assms]
	have A: "\<dots> < index (mtf2 n q xs) x" by auto
	finally show ?thesis unfolding before_in_def using xinxs by force
	qed

	lemma twotox:
	assumes "count_list bs y \<le> 1"
	and "distinct init"
	and "x \<in> set init"
	and "y : set init"
	and "x \<notin> set bs"
	and "x\<noteq>y"
	shows "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
	proof -
	have aa: "snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))
	= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h"
	apply(rule sndTSdet) by(simp)
	then have aa': "snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))
	= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h" by auto
	have lasocc_x: "index (snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))) x = length bs"
	unfolding aa
	apply(simp add: del: config'.simps)
	using assms(5) by(simp add: index_append)
	then have lasocc_x': "(index (snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x) = length bs" by auto

	let ?sincelast = "take (length bs)
	(snd (TSdet init h ((as @ x # bs) @ [x])
	(Suc (length as + length bs))))"
	have sl: "?sincelast = rev bs" unfolding aa by(simp)
	let ?S = "{xa. xa < x in fst (TSdet init h (as @ x # bs @ [x])
	(Suc (length as + length bs))) \<and>
	count_list ?sincelast xa \<le> 1}"

	have y: "y \<in> ?S \<or> ~ y < x in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
	unfolding sl unfolding s_TS_def using assms(1) by(simp del: config'.simps)

	have eklr: "length (as@[x]@bs@[x]) = Suc (length (as@[x]@bs))" by simp
	have 1: "s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))
	= fst (Partial_Cost_Model.Step (rTS h)
	(TSdet init h (as @ [x] @ bs @ [x])
	(length (as @ [x] @ bs)))
	((as @ [x] @ bs @ [x]) ! length (as @ [x] @ bs)))" unfolding s_TS_def unfolding eklr apply(subst TSdet_Suc)
	by(simp_all add: split_def)

	have brrr: "x\<in> set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_set[unfolded s_TS_def])
	apply(simp) by fact
	have ydrin: "y\<in>set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact
	have dbrrr: "distinct (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
	apply(subst s_TS_distinct[unfolded s_TS_def]) using assms(2) by(simp_all)

	show ?thesis
	proof (cases "y < x in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))")
	case True
	with y have yS: "y\<in>?S" by auto
	then have minsteps: "Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
	by auto
	let ?entf = "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x -
	Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)"
	from minsteps have br: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
	by presburger
	have brr: "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x"
	using True unfolding before_in_def s_TS_def by auto

	from br brr have klo: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
	\<le> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	\<and> index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
	< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x" by metis


	let ?result ="(mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"

	have whatsthat: "s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))
	= ?result"
	unfolding 1 apply(simp add: split_def step_def rTS_def Step_def TS_step_d_def del: config'.simps)
	apply(simp add: nth_append del: config'.simps)
	using lasocc_x'[unfolded rTS_def] aa'[unfolded rTS_def]
	apply(simp add: del: config'.simps)
	using yS[unfolded sl rTS_def] by auto


	have ydrinee: " y \<in> set (mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"
	apply(subst set_mtf2)
	apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact

	show ?thesis unfolding whatsthat apply(rule mtf2_q_passes) by(fact)+
	next
	case False
	then have 2: "x < y in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
	using brrr ydrin not_before_in assms(6) unfolding s_TS_def by metis
	{
	fix e
	have "x < y in mtf2 e x (s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs)))"
	apply(rule x_stays_before_y_if_y_not_moved_to_front)
	unfolding s_TS_def
	apply(fact)+
	using assms(6) apply(simp)
	using 2 unfolding s_TS_def by simp
	} note bratz=this
	show ?thesis unfolding 1 apply(simp add: TSnopaid split_def Step_def s_TS_def TS_step_d_def step_def nth_append del: config'.simps)
	using bratz[unfolded s_TS_def] by simp
	qed

	qed

	lemma count_drop: "count_list (drop n cs) x \<le> count_list cs x"
	proof -
	have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
	also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_list_append)
	also have "\<dots> \<ge> count_list (drop n cs) x" by auto
	finally show ?thesis .
	qed

	lemma count_take_less: assumes "n\<le>m"
	shows "count_list (take n cs) x \<le> count_list (take m cs) x"
	proof -
	from assms have "count_list (take n cs) x = count_list (take n (take m cs)) x" by auto
	also have "\<dots> \<le> count_list (take n (take m cs) @ drop n (take m cs)) x" by (simp)
	also have "\<dots> = count_list (take m cs) x"
	by(simp only: append_take_drop_id)
	finally show ?thesis .
	qed

	lemma count_take: "count_list (take n cs) x \<le> count_list cs x"
	proof -
	have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
	also have "\<dots> = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_list_append)
	also have "\<dots> \<ge> count_list (take n cs) x" by auto
	finally show ?thesis .
	qed

	lemma casexxy: assumes "\<sigma>=as@[x]@bs@[x]@cs"
	and "x \<notin> set cs"
	and "set cs \<subseteq> set init"
	and "x \<in> set init"
	and "distinct init"
	and "x \<notin> set bs"
	and "set as \<subseteq> set init"
	and "set bs \<subseteq> set init"
	shows "(%i. i<length cs \<longrightarrow> (\<forall>j<i. cs!j\<noteq>cs!i) \<longrightarrow> cs!i\<noteq>x
	\<longrightarrow> (cs!i) \<notin> set bs
	\<longrightarrow> x < (cs!i) in (s_TS init h \<sigma> (length (as@[x]@bs@[x]) + i+1))) i"
	proof (rule infinite_descent[where P="(%i. i<length cs \<longrightarrow> (\<forall>j<i. cs!j\<noteq>cs!i) \<longrightarrow> cs!i\<noteq>x
	\<longrightarrow> (cs!i) \<notin> set bs
	\<longrightarrow> x < (cs!i) in (s_TS init h \<sigma> (length (as@[x]@bs@[x]) + i+1)))"], goal_cases)
	case (1 i)
	let ?y = "cs!i"
	from 1 have i_in_cs: "i < length cs" and
	firstocc: "(\<forall>j<i. cs ! j \<noteq> cs ! i)"
	and ynx: "cs ! i \<noteq> x"
	and ynotinbs: "cs ! i \<notin> set bs"
	and y_before_x': "~x < cs ! i in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)" by auto

	have ss: "set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)) = set init" using assms(1) i_in_cs by(simp add: s_TS_set)
	then have "cs ! i \<in> set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1))"
	unfolding ss using assms(3) i_in_cs by fastforce
	moreover have "x : set (s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1))"
	unfolding ss using assms(4) by fastforce

	\<comment> \<open>after the request to y, y is in front of x\<close>
	ultimately have y_before_x_Suct3: "?y < x in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)"
	using y_before_x' ynx not_before_in by metis

	from ynotinbs have yatmostonceinbs: "count_list bs (cs!i) \<le> 1" by simp


	let ?y = "cs!i"
	have yininit: "?y \<in> set init" using assms(3) i_in_cs by fastforce
	{
	fix y
	assume "y \<in> set init"
	assume "x\<noteq>y"
	assume "count_list bs y \<le> 1"
	then have "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
	apply(rule twotox) by(fact)+
	} note xgoestofront=this
	with yatmostonceinbs ynx yininit have zeitpunktt2: "x < ?y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))" by blast

	have "i \<le> length cs" using i_in_cs by auto
	have x_before_y_t3: "x < ?y in s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+i)"
	apply(rule TS_mono)
	apply(fact)+
	using assms by simp
	\<comment> \<open>so x and y swap positions when y is requested, that means that y was inserted infront of
	some elment z (which cannot be x, has only been requested at most once since last request of y
	but is in front of x)\<close>

	\<comment> \<open>first show that y must have been requested in as\<close>

	have "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
	rev (take (length (as @ [x] @ bs @ [x]) + i) (as @ [x] @ bs @ [x] @ cs)) @ h"
	apply(rule sndTSdet) using i_in_cs by simp
	also have "\<dots> = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by simp
	finally have fstTS_t3: "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
	(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" .
	then have fstTS_t3': "(snd (TSdet init h \<sigma> (Suc (Suc (length as + length bs + i))))) =
	(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" using assms(1) by auto

	let ?is = "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	let ?is' = "snd (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
	let ?s = "fst (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	let ?s' = "fst (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
	let ?s_Suct3="s_TS init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i+1)"

	let ?S = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s \<and>
	count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) xa \<le> 1) }"
	let ?S' = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s' \<and>
	count_list (take (index ?is' ((cs!i))) ?is') xa \<le> 1) }"

	have isis': "?is = ?is'" by(simp)
	have ss': "?s = ?s'" by(simp)
	then have SS': "?S = ?S'" using i_in_cs by(simp add: nth_append)


	(* unfold TSdet once *)
	have once: "TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i))))
	= Step (rTS h) (config\<^sub>p (rTS h) init (as @ x # bs @ x # take i cs)) (cs ! i)"
	apply(subst TSdet_Suc)
	using i_in_cs apply(simp)
	by(simp add: nth_append)

	have aha: "(index ?is (cs ! i) \<noteq> length ?is)
	\<and> ?S \<noteq> {}"
	proof (rule ccontr, goal_cases)
	case 1
	then have "(index ?is (cs ! i) = length ?is) \<or> ?S = {}" by(simp)
	then have alters: "(index ?is' (cs ! i) = length ?is') \<or> ?S' = {}"
	apply(simp only: SS') by(simp only: isis')
	\<comment> \<open>wenn (cs ! i) noch nie requested wurde, dann kann es gar nicht nach vorne gebracht werden!
	also widerspruch mit @{text y_before_x'}\<close>
	have "?s_Suct3 = fst (config (rTS h) init ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)))"
	unfolding s_TS_def
	apply(simp only: length_append)
	apply(subst take_append)
	apply(subst take_append)
	apply(subst take_append)
	apply(subst take_append)
	by(simp)
	also have "\<dots> = fst (config (rTS h) init (((as @ [x] @ bs @ [x]) @ (take i cs)) @ [cs!i]))"
	using i_in_cs by(simp add: take_Suc_conv_app_nth)
	also have "\<dots> = step ?s' ?y (0, [])"
	proof (cases "index ?is' (cs ! i) = length ?is'")
	case True
	show ?thesis
	apply(subst config_append)
	using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
	apply(subst TS_step_d_def)
	apply(simp only: True[unfolded rTS_def,simplified])
	by(simp)
	next
	case False
	with alters have S': "?S' = {}" by simp

	have 1 : "{xa. xa < cs ! i
	in fst (Partial_Cost_Model.config' (\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)) \<and>
	count_list (take (index
	(snd
	(Partial_Cost_Model.config'
	(\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)))
	(cs ! i))
	(snd
	(Partial_Cost_Model.config'
	(\<lambda>s. h, TS_step_d) (init, h)
	(as @ x # bs @ x # take i cs)))) xa \<le> 1} = {}" using S' by(simp add: rTS_def nth_append)

	show ?thesis
	apply(subst config_append)
	using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
	apply(subst TS_step_d_def)
	apply(simp only: 1 Let_def)
	by(simp)
	qed
	finally have "?s_Suct3 = step ?s ?y (0, [])" using ss' by simp
	then have e: "?s_Suct3 = ?s" by(simp only: step_no_action)
	from x_before_y_t3 have "x < cs ! i in ?s_Suct3" unfolding e unfolding s_TS_def by simp
	with y_before_x' show "False" unfolding assms(1) by auto
	qed
	then have aha': "index (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))
	(cs ! i) \<noteq>
	length (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
	and
	aha2: "?S \<noteq> {}" by auto


	from fstTS_t3' assms(1) have is_: "?is = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by auto

	have minlencsi: " min (length cs) i = i" using i_in_cs by linarith

	let ?lastoccy="(index (rev (take i cs) @ x # rev bs @ x # rev as @ h) (cs ! i))"
	have "?y \<notin> set (rev (take i cs))" using firstocc by (simp add: in_set_conv_nth)
	then have lastoccy: "?lastoccy \<ge>
	i + 1 + length bs + 1" using ynx ynotinbs minlencsi by(simp add: index_append)

	(* x is not in S, because it is requested at least twice since the last request to y*)
	have x_nin_S: "x\<notin>?S"
	using is_ apply(simp add: split_def nth_append del: config'.simps)
	proof (goal_cases)
	case 1
	have " count_list (take ?lastoccy (rev (take i cs))) x \<le>
	count_list (drop (length cs - i) (rev cs)) x" by (simp add: count_take rev_take)
	also have "\<dots> \<le> count_list (rev cs) x" by (meson count_drop)
	also have "\<dots> = 0" using assms(2) by(simp)
	finally have " count_list (take ?lastoccy (rev (take i cs))) x = 0" by auto
	have"
	2 \<le>
	count_list ([x] @ rev bs @ [x]) x " by(simp)
	also have "\<dots> = count_list (take (1 + length bs + 1) (x # rev bs @ x # rev as @ h)) x" by auto
	also have "\<dots> \<le> count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x"
	apply(rule count_take_less)
	using lastoccy by linarith
	also have "\<dots> \<le> count_list (take ?lastoccy (rev (take i cs))) x
	+ count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x" by auto
	finally show ?case by(simp add: minlencsi)
	qed

	have "Min (index ?s ` ?S) \<in> (index ?s ` ?S)" apply(rule Min_in) using aha2 by (simp_all)
	then obtain z where zminimal: "index ?s z = Min (index ?s ` ?S)"and z_in_S: "z \<in> ?S" by auto
	then have bef: "z < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s"
	and "count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) z \<le> 1" by(blast)+

	with zminimal have zbeforey: "z < cs ! i in ?s"
	and zatmostonce: "count_list (take (index ?is (cs ! i)) ?is) z \<le> 1"
	and isminimal: "index ?s z = Min (index ?s ` ?S)" by(simp_all add: nth_append)
	have elemins: "z \<in> set ?s" unfolding before_in_def by (meson zbeforey before_in_setD1)
	then have zininit: "z \<in> set init"
	using i_in_cs by(simp add: s_TS_set[unfolded s_TS_def] del: config'.simps)

	from zbeforey have zbeforey_ind: "index ?s z < index ?s ?y" unfolding before_in_def by auto
	then have el_n_y: "z \<noteq> ?y" by auto

	have el_n_x: "z \<noteq> x" using x_nin_S z_in_S by blast

	(* and because it is JUST before that element, z must be before x *)
	{ fix s q
	have TS_step_d2: "TS_step_d s q =
	(let V\<^sub>r={x. x < q in fst s \<and> count_list (take (index (snd s) q) (snd s)) x \<le> 1}
	in ((if index (snd s) q \<noteq> length (snd s) \<and> V\<^sub>r \<noteq> {}
	then index (fst s) q - Min ( (index (fst s)) ` V\<^sub>r)
	else 0,[]),q#(snd s)))"
	unfolding TS_step_d_def
	apply(cases "index (snd s) q < length (snd s)")
	using index_le_size apply(simp split: prod.split) apply blast
	by(auto simp add: index_less_size_conv split: prod.split)
	} note alt_chara=this

	have iF: "(index (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i)
	\<noteq> length (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) \<and>
	{xa. xa < cs ! i in fst (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs)) \<and>
	count_list
	(take (index (snd (config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i))
	(snd (Partial_Cost_Model.config' (\<lambda>s. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))))
	xa
	\<le> 1} \<noteq>
	{}) = True" using aha[unfolded rTS_def] ss' SS' by(simp add: nth_append)

	have "?s_Suct3 = fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i)))))"
	by(auto simp add: s_TS_def)
	also have "\<dots> = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])"
	apply(simp only: once[unfolded assms(1)])
	apply(simp add: Step_def split_def rTS_def del: config'.simps)
	apply(subst alt_chara)
	apply(simp only: Let_def )
	apply(simp only: iF)
	by(simp add: nth_append)
	finally have "?s_Suct3 = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])" .
	with isminimal have state_dannach: "?s_Suct3 = step ?s ?y (index ?s ?y - index ?s z, [])" by presburger


	\<comment> \<open>so y is moved in front of z, that means:\<close>
	have yinfrontofz: "?y < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + i+1)"
	unfolding assms(1) state_dannach apply(simp add: step_def del: config'.simps)
	apply(rule mtf2_q_passes)
	using i_in_cs assms(5) apply(simp_all add: s_TS_distinct[unfolded s_TS_def] s_TS_set[unfolded s_TS_def])
	using yininit apply(simp)
	using zbeforey_ind by simp




	have yins: "?y \<in> set ?s"
	using i_in_cs assms(3,5) apply(simp_all add: s_TS_set[unfolded s_TS_def] del: config'.simps)
	by fastforce

	have "index ?s_Suct3 ?y = index ?s z"
	and "index ?s_Suct3 z = Suc (index ?s z)"
	proof -
	let ?xs = "(fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
	have setxs: "set ?xs = set init"
	apply(rule s_TS_set[unfolded s_TS_def])
	using i_in_cs by auto
	then have yinxs: "cs ! i \<in> set ?xs"
	apply(simp add: setxs del: config'.simps)
	using assms(3) i_in_cs by fastforce

	have distinctxs: "distinct ?xs"
	apply(rule s_TS_distinct[unfolded s_TS_def])
	using i_in_cs assms(5) by auto


	let ?n = "(index
	(fst (TSdet init h (as @ x # bs @ x # cs)
	(Suc (Suc (length as + length bs + i)))))
	(cs ! i) -
	index
	(fst (TSdet init h (as @ x # bs @ x # cs)
	(Suc (Suc (length as + length bs + i)))))
	z)"

	have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n\<and>
	index ?xs ?y - ?n = index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y )"
	apply(rule mtf2_forward_effect2)
	apply(fact)
	apply(fact)
	by simp

	then have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n" by metis
	also have "\<dots> = index ?s z" using zbeforey_ind by force
	finally have A: "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?s z" .

	have aa: "index ?xs ?y - ?n \<le> index ?xs z" "index ?xs z < index ?xs ?y"
	apply(simp)
	using zbeforey_ind by fastforce

	from mtf2_forward_effect3'[OF yinxs distinctxs aa]
	have B: "index (mtf2 ?n ?y ?xs) z = Suc (index ?xs z)"
	using elemins yins by(simp add: nth_append split_def del: config'.simps)

	show "index ?s_Suct3 ?y = index ?s z"
	unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
	using A yins by(simp add: nth_append del: config'.simps)

	show "index ?s_Suct3 z = Suc (index ?s z)"
	unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
	using B yins by(simp add: nth_append del: config'.simps)
	qed

	then have are: "Suc (index ?s_Suct3 ?y) = index ?s_Suct3 z" by presburger





	from are before_in_def y_before_x_Suct3 el_n_x assms(1) have z_before_x: "z < x in ?s_Suct3"
	by (metis Suc_lessI not_before_in yinfrontofz)


	have xSuct3: "x\<in>set ?s_Suct3" using assms(4) i_in_cs by(simp add: s_TS_set)
	have elSuct3: "z\<in>set ?s_Suct3" using zininit i_in_cs by(simp add: s_TS_set)

	have xt3: "x\<in>set ?s " apply(subst config_config_set) by fact

	note elt3=elemins

	have z_s: "z < x in ?s"
	proof(rule ccontr, goal_cases)
	case 1
	then have "x < z in ?s" using not_before_in[OF xt3 elt3] el_n_x unfolding s_TS_def by blast
	then have "x < z in ?s_Suct3"
	apply (simp only: state_dannach)
	apply (simp only: step_def)
	apply(simp add: nth_append del: config'.simps)
	apply(rule x_stays_before_y_if_y_not_moved_to_front)
	apply(subst config_config_set) using i_in_cs assms(3) apply fastforce
	apply(subst config_config_distinct) using assms(5) apply fastforce
	apply(subst config_config_set) using assms(4) apply fastforce
	apply(subst config_config_set) using zininit apply fastforce
	using el_n_y apply(simp)
	by(simp)

	then show "False" using z_before_x not_before_in[OF xSuct3 elSuct3] by blast
	qed


	have mind: "(index ?is (cs ! i)) \<ge> i + 1 + length bs + 1 " using lastoccy
	using i_in_cs fstTS_t3'[unfolded assms(1)] by(simp add: split_def nth_append del: config'.simps)

	have "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z=
	count_list (take (i + 1 + length bs + 1) ?is) z" unfolding is_
	using el_n_x by(simp add: minlencsi)
	also from mind have "\<dots>
	\<le> count_list (take (index ?is (cs ! i)) ?is) z"
	by(rule count_take_less)
	also have "\<dots> \<le> 1" using zatmostonce by metis
	finally have aaa: "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z \<le> 1" .
	with el_n_x have "count_list bs z + count_list (take i cs) z \<le> 1"
	by(simp)
	moreover have "count_list (take (Suc i) cs) z = count_list (take i cs) z"
	using i_in_cs el_n_y by(simp add: take_Suc_conv_app_nth)
	ultimately have aaaa: "count_list bs z + count_list (take (Suc i) cs) z \<le> 1" by simp

	have z_occurs_once_in_cs: "count_list (take (Suc i) cs) z = 1"
	proof (rule ccontr, goal_cases)
	case 1
	with aaaa have atmost1: "count_list bs z \<le> 1" and "count_list (take (Suc i) cs) z = 0" by force+
	have yeah: "z \<notin> set (take (Suc i) cs)" apply(rule count_notin2) by fact

	\<comment> \<open>now we know that x is in front of z after 2nd request to x, and that z is not requested any more,
	that means it stays behind x, which leads to a contradiction with @{text z_before_x}\<close>

	have xin123: "x \<in> set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
	using i_in_cs assms(4) by(simp add: s_TS_set)
	have zin123: "z \<in> set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
	using i_in_cs elemins by(simp add: s_TS_set del: config'.simps)

	have "x < z in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i + 1))"
	apply(rule TS_mono)
	apply(rule xgoestofront)
	apply(fact) using el_n_x apply(simp) apply(fact)
	using i_in_cs apply(simp)
	using yeah i_in_cs length_take nth_mem
	apply (metis Suc_eq_plus1 Suc_leI min_absorb2)
	using set_take_subset assms(2) apply fast
	using assms i_in_cs apply(simp_all ) using set_take_subset by fast
	then have ge: "\<not> z < x in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
	using not_before_in[OF zin123 xin123] el_n_x by blast

	have " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
	= s_TS init h ((as @ [x] @ bs @ [x] @ (take (i+1) cs)) @ (drop (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" by auto
	also have "\<dots>
	= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
	apply(rule s_TS_append)
	using i_in_cs by(simp)
	finally have aaa: " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
	= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" .

	from ge z_before_x show "False" unfolding assms(1) using aaa by auto
	qed
	from z_occurs_once_in_cs have kinSuci: "z \<in> set (take (Suc i) cs)" by (metis One_nat_def count_notin n_not_Suc_n)
	then have zincs: "z\<in>set cs" using set_take_subset by fast
	from z_occurs_once_in_cs obtain k where k_def: "k=index (take (Suc i) cs) z" by blast


	then have "k=index cs z" using kinSuci by (simp add: index_take_if_set)
	then have zcsk: "z = cs!k" using zincs by simp




	have era: " cs ! index (take (Suc i) cs) z = z" using kinSuci in_set_takeD index_take_if_set by fastforce
	have ki: "k<i" unfolding k_def using kinSuci el_n_y
	by (metis i_in_cs index_take index_take_if_set le_neq_implies_less not_less_eq_eq yes)
	have zmustbebeforex: "cs!k < x in ?s"
	unfolding k_def era by (fact z_s)

	\<comment> \<open>before the request to z, x is in front of z, analog zu oben, vllt generell machen?\<close>


	\<comment> \<open>element z does not occur between t1 and position k\<close>
	have z_notinbs: "cs ! k \<notin> set bs"
	proof -
	from z_occurs_once_in_cs aaaa have "count_list bs z = 0" by auto
	then show ?thesis using zcsk count_notin2 by metis
	qed


	have "count_list bs z \<le> 1" using aaaa by linarith
	with xgoestofront[OF zininit el_n_x[symmetric]] have xbeforez: "x < z in s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))" by auto

	obtain cs1 cs2 where v: "cs1 @ cs2 = cs" and cs1: "cs1 = take (Suc k) cs" and cs2: "cs2 = drop (Suc k) cs" by auto

	have z_firstocc: "\<forall>j<k. cs ! j \<noteq> cs ! k"
	and z_lastocc: "\<forall>j<i-k-1. cs2 ! j \<noteq> cs ! k"
	proof (safe, goal_cases)
	case (1 j)
	with ki i_in_cs have 2: "j < length (take k cs)" by auto
	have un1: "(take (Suc i) cs)!k = cs!k" apply(rule nth_take) using ki by auto
	have un2: "(take k cs)!j = cs!j" apply(rule nth_take) using 1(1) ki by auto

	from i_in_cs ki have f1: "k < length (take (Suc i) cs)" by auto
	then have "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
	by(rule id_take_nth_drop)
	also have "(take k (take (Suc i) cs)) = take k cs" using i_in_cs ki by (simp add: min_def)
	also have "... = (take j (take k cs)) @ (take k cs)!j # (drop (Suc j) (take k cs))"
	using 2 by(rule id_take_nth_drop)
	finally have "take (Suc i) cs
	= (take j (take k cs)) @ [(take k cs)!j] @ (drop (Suc j) (take k cs))
	@ [(take (Suc i) cs)!k] @ (drop (Suc k) (take (Suc i) cs))"
	by(simp)
	then have A: "take (Suc i) cs
	= (take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
	@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))"
	unfolding un1 un2 by simp
	have "count_list ((take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
	@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))) z \<ge> 2"
	using zcsk 1(2) by(simp)
	with A have "count_list (take (Suc i) cs) z \<ge> 2" by auto
	with z_occurs_once_in_cs show "False" by auto
	next
	case (2 j)
	then have 1: "Suc k+j < i" by auto
	then have f2: "j < length (drop (Suc k) (take (Suc i) cs))" using i_in_cs by simp
	have 3: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ (drop (Suc k) (take (Suc i) cs))! j
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
	using f2 by(rule id_take_nth_drop)
	have "(drop (Suc k) (take (Suc i) cs))! j = (take (Suc i) cs) ! (Suc k+j)"
	apply(rule nth_drop) using i_in_cs 1 by auto
	also have "\<dots> = cs ! (Suc k+j)" apply(rule nth_take) using 1 by auto
	finally have 4: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ cs! (Suc k +j)
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
	using 3 by auto
	have 5: "cs2 ! j = cs! (Suc k +j)" unfolding cs2
	apply(rule nth_drop) using i_in_cs 1 by auto

	from 4 5 2(2) have 6: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
	@ cs! k
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" by auto

	from i_in_cs ki have 1: "k < length (take (Suc i) cs)" by auto
	then have 7: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
	by(rule id_take_nth_drop)
	have 9: "(take (Suc i) cs)!k = z" unfolding zcsk apply(rule nth_take) using ki by auto
	from 6 7 have A: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
	@ z
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" using ki 9 by auto

	have "count_list ((take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
	@ z
	# drop (Suc j) (drop (Suc k) (take (Suc i) cs))) z
	\<ge> 2"
	by(simp)
	with A have "count_list (take (Suc i) cs) z \<ge> 2" by auto
	with z_occurs_once_in_cs show "False" by auto
	qed


	have k_in_cs: "k < length cs" using ki i_in_cs by auto
	with cs1 have lenkk: "length cs1 = k+1" by auto
	from k_in_cs have mincsk: "min (length cs) (Suc k) = Suc k" by auto

	have "s_TS init h (((as@[x]@bs@[x])@cs1) @ cs2) (length (as@[x]@bs@[x])+k+1)
	= s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x])+k+1)"
	apply(rule s_TS_append)
	using cs1 cs2 k_in_cs by(simp)
	then have spliter: "s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))
	= s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+k+1) "
	using lenkk v cs1 apply(auto) by (simp add: add.commute add.left_commute)

	from cs2 have "length cs2 = length cs - (Suc k)" by auto

	have notxbeforez: "~ x < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + k + 1)"
	proof (rule ccontr, goal_cases)
	case 1
	then have a: "x < z in s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))"
	unfolding spliter assms(1) by auto

	have 41: "x \<in> set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	using i_in_cs assms(4) by(simp add: s_TS_set)
	have 42: "z \<in> set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
	using i_in_cs zininit by(simp add: s_TS_set)

	have rewr: "s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1)) =
	s_TS init h (as@[x]@bs@[x]@cs) (length (as@[x]@bs@[x])+i)"
	using cs1 v ki apply(simp add: mincsk) by (simp add: add.commute add.left_commute)

	have "x < z in s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1))"
	apply(rule TS_mono)
	using a apply(simp)
	using cs2 i_in_cs ki v cs1 apply(simp)
	using z_lastocc zcsk apply(simp)
	using v assms(2) apply force
	using assms by(simp_all add: cs1 cs2)

	(* "contradiction to zmustbebeforex" *)
	from zmustbebeforex this[unfolded rewr ] el_n_x zcsk 41 42 not_before_in show "False"
	unfolding s_TS_def by fastforce
	qed

	have 1: "k < length cs"
	"(\<forall>j<k. cs ! j \<noteq> cs ! k)"
	"cs ! k \<noteq> x" "cs ! k \<notin> set bs"
	"~ x < z in s_TS init h \<sigma> (length (as @ [x] @ bs @ [x]) + k + 1)"
	apply(safe)
	using ki i_in_cs apply(simp)
	using z_firstocc apply(simp)
	using assms(2) ki i_in_cs apply(fastforce)
	using z_notinbs apply(simp)
	using notxbeforez by auto



	show ?case apply(simp only: ex_nat_less_eq)
	apply(rule bexI[where x=k])
	using 1 zcsk apply(simp)
	using ki by simp
	qed

	lemma nopaid: "snd (fst (TS_step_d s q)) = []" unfolding TS_step_d_def by simp

	lemma staysuntouched:
	assumes d[simp]: "distinct (fst S)"
	and x: "x \<in> set (fst S)"
	and y: "y \<in> set (fst S)"
	shows "set qs \<subseteq> set (fst S) \<Longrightarrow> x \<notin> set qs \<Longrightarrow> y \<notin> set qs
	\<Longrightarrow> x < y in fst (config' (rTS []) S qs) = x < y in fst S"
	proof(induct qs rule: rev_induct)
	case (snoc q qs)
	have "x < y in fst (config' (rTS []) S (qs @ [q])) =
	x < y in fst (config' (rTS []) S qs)"
	apply(simp add: config'_snoc Step_def split_def step_def rTS_def nopaid)
	apply(rule xy_relativorder_mtf2)
	using snoc by(simp_all add: x y )
	also have "\<dots> = x < y in fst S"
	apply(rule snoc)
	using snoc by simp_all
	finally show ?case .
	qed simp

	lemma staysuntouched':
	assumes d[simp]: "distinct init"
	and x: "x \<in> set init"
	and y: "y \<in> set init"
	and "set qs \<subseteq> set init"
	and "x \<notin> set qs" and "y \<notin> set qs"
	shows "x < y in fst (config (rTS []) init qs) = x < y in init"
	proof -
	let ?S="(init, fst (rTS []) init)"
	have "x < y in fst (config' (rTS []) ?S qs) = x < y in fst ?S"
	apply(rule staysuntouched)
	using assms by(simp_all)
	then show ?thesis by simp
	qed

	lemma projEmpty: "Lxy qs S = [] \<Longrightarrow> x \<in> S \<Longrightarrow> x \<notin> set qs"
	unfolding Lxy_def by (metis filter_empty_conv)

	lemma Lxy_index_mono:
	assumes "x\<in>S" "y\<in>S"
	and "index xs x < index xs y"
	and "index xs y < length xs"
	and "x\<noteq>y"
	shows "index (Lxy xs S) x < index (Lxy xs S) y"
	proof -
	from assms have ij: "index xs x < index xs y"
	and xinxs: "index xs x < length xs"
	and yinxs: "index xs y < length xs" by auto
	then have inset: "x\<in>set xs" "y\<in>set xs" using index_less_size_conv by fast+
	from xinxs obtain a as where dec1: "a @ [xs!index xs x] @ as = xs"
	and a: "a = take (index xs x) xs" and "as = drop (Suc (index xs x)) xs"
	and length_a: "length a = index xs x" and length_as: "length as = length xs - index xs x- 1"
	using id_take_nth_drop by fastforce
	have "index xs y\<ge>length (a @ [xs!index xs x])" using length_a ij by auto
	then have "((a @ [xs!index xs x]) @ as) ! index xs y = as ! (index xs y-length (a @ [xs ! index xs x]))" using nth_append[where xs="a @ [xs!index xs x]" and ys="as"]
	by(simp)
	then have xsj: "xs ! index xs y = as ! (index xs y-index xs x-1)" using dec1 length_a by auto
	have las: "(index xs y-index xs x-1) < length as" using length_as yinxs ij by simp
	obtain b c where dec2: "b @ [xs!index xs y] @ c = as"
	and "b = take (index xs y-index xs x-1) as" "c=drop (Suc (index xs y-index xs x-1)) as"
	and length_b: "length b = index xs y-index xs x-1" using id_take_nth_drop[OF las] xsj by force

	have xs_dec: "a @ [xs!index xs x] @ b @ [xs!index xs y] @ c = xs" using dec1 dec2 by auto


	then have "Lxy xs S = Lxy (a @ [xs!index xs x] @ b @ [xs!index xs y] @ c) S"
	by(simp add: xs_dec)
	also have "\<dots> = Lxy a S @ Lxy [x] S @ Lxy b S @ Lxy [y] S @ Lxy c S"
	by(simp add: Lxy_append Lxy_def assms inset)
	finally have gr: "Lxy xs S = Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S"
	using assms by(simp add: Lxy_def)

	have "y \<notin> set (take (index xs x) xs)"
	apply(rule index_take) using assms by simp
	then have "y \<notin> set (Lxy (take (index xs x) xs) S )"
	apply(subst Lxy_set_filter) by blast
	with a have ynot: "y \<notin> set (Lxy a S)" by simp
	have "index (Lxy xs S) y =
	index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) y"
	by(simp add: gr)
	also have "\<dots> \<ge> length (Lxy a S) + 1"
	using assms(5) ynot by(simp add: index_append)
	finally have 1: "index (Lxy xs S) y \<ge> length (Lxy a S) + 1" .

	have "index (Lxy xs S) x = index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) x"
	by (simp add: gr)
	also have "\<dots> \<le> length (Lxy a S)"
	apply(simp add: index_append)
	apply(subst index_less_size_conv[symmetric]) by simp
	finally have 2: "index (Lxy xs S) x \<le> length (Lxy a S)" .

	from 1 2 show ?thesis by linarith
	qed

	lemma proj_Cons:
	assumes filterd_cons: "Lxy qs S = a#as"
	and a_filter: "a\<in>S"
	obtains pre suf where "qs = pre @ [a] @ suf" and "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set pre"
	and "Lxy suf S = as"
	proof -
	have "set (Lxy qs S) \<subseteq> set qs" using Lxy_set_filter by fast
	with filterd_cons have a_inq: "a \<in> set qs" by simp
	then have "index qs a < length qs" by(simp)
	{ fix e
	assume eS:"e\<in>S"
	assume "e\<noteq>a"
	have "index qs a \<le> index qs e"
	proof (rule ccontr)
	assume "\<not> index qs a \<le> index qs e"
	then have 1: "index qs e < index qs a" by simp
	have 0: "index (Lxy qs S) a = 0" unfolding filterd_cons by simp
	have 2: "index (Lxy qs S) e < index (Lxy qs S) a"
	apply(rule Lxy_index_mono)
	by(fact)+
	from 0 2 show "False" by linarith
	qed
	} note atfront=this


	let ?lastInd="index qs a"
	have "qs = take ?lastInd qs @ qs!?lastInd # drop (Suc ?lastInd) qs"
	apply(rule id_take_nth_drop)
	using a_inq by simp
	also have "\<dots> = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs"
	using a_inq by simp
	finally have split: "qs = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs" .

	have nothingin: "\<And>s. s\<in>S \<Longrightarrow> s \<notin> set (take ?lastInd qs)"
	apply(rule index_take)
	apply(case_tac "a=s")
	apply(simp)
	by (rule atfront) simp_all
	then have "set (Lxy (take ?lastInd qs) S) = {}"
	apply(subst Lxy_set_filter) by blast
	then have emptyPre: "Lxy (take ?lastInd qs) S = []" by blast


	have "a#as = Lxy qs S"
	using filterd_cons by simp
	also have "\<dots> = Lxy (take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs) S"
	using split by simp
	also have "\<dots> = Lxy (take ?lastInd qs) S @ (Lxy [a] S) @ Lxy (drop (Suc ?lastInd) qs) S"
	by(simp add: Lxy_append Lxy_def)
	also have "\<dots> = a#Lxy (drop (Suc ?lastInd) qs) S"
	unfolding emptyPre by(simp add: Lxy_def a_filter)
	finally have suf: "Lxy (drop (Suc ?lastInd) qs) S = as" by simp

	from split nothingin suf show ?thesis ..
	qed

	lemma Lxy_rev: "rev (Lxy qs S) = Lxy (rev qs) S"
	apply(induct qs)
	by(simp_all add: Lxy_def)

	lemma proj_Snoc:
	assumes filterd_cons: "Lxy qs S = as@[a]"
	and a_filter: "a\<in>S"
	obtains pre suf where "qs = pre @ [a] @ suf" and "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set suf"
	and "Lxy pre S = as"
	proof -
	have "Lxy (rev qs) S = rev (Lxy qs S)" by(simp add: Lxy_rev)
	also have "\<dots> = a#(rev as)" unfolding filterd_cons by simp
	finally have "Lxy (rev qs) S = a # (rev as)" .
	with a_filter
	obtain pre' suf' where 1: "rev qs = pre' @[a] @ suf'"
	and 2: "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set pre'"
	and 3: "Lxy suf' S = rev as"
	using proj_Cons by metis
	have "qs = rev (rev qs)" by simp
	also have "\<dots> = rev suf' @ [a] @ rev pre'" using 1 by simp
	finally have a1: "qs = rev suf' @ [a] @ rev pre'" .

	have "Lxy (rev suf') S = rev (Lxy suf' S)" by(simp add: Lxy_rev)
	also have "\<dots> = as" using 3 by simp
	finally have a3: "Lxy (rev suf') S = as" .

	have a2: "\<And>x. x \<in> S \<Longrightarrow> x \<notin> set (rev pre')" using 2 by simp

	from a1 a2 a3 show ?thesis ..
	qed

	lemma sndTSconfig': "snd (config' (rTS initH) (init,[]) qs) = rev qs @ []"
	apply(induct qs rule: rev_induct)
	apply(simp add: rTS_def)
	by(simp add: split_def TS_step_d_def config'_snoc Step_def rTS_def)

	lemma projxx:
	fixes e a bs
	assumes axy: "a\<in>{x,y}"
	assumes ane: "a\<noteq>e"
	assumes exy: "e\<in>{x,y}"
	assumes add: "f\<in>{[],[e]}"
	assumes bsaxy: "set (bs @ [a] @ f) \<subseteq> {x,y}"
	assumes Lxyinitxy: "Lxy init {x, y} \<in> {[x,y],[y,x]}"
	shows "a < e in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
	proof -
	have aexy: "{a,e}={x,y}" using exy axy ane by blast

	let ?h="snd (Partial_Cost_Model.config' (\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, []) (bs @ a # f))"
	have history: "?h = (rev f)@a#(rev bs)"
	using sndTSdet[of "length (bs@a#f)" "bs@a#f", unfolded rTS_def] by(simp)

	{ fix xs s
	assume sinit: "s:{[a,e],[e,a]}"
	assume "set xs \<subseteq> {a,e}"
	then have "fst (config' (\<lambda>s. [], TS_step_d) (s, []) xs) \<in> {[a,e], [e,a]}"
	apply (induct xs rule: rev_induct)
	using sinit apply(simp)
	apply(subst config'_append2)
	apply(simp only: Step_def config'.simps Let_def split_def fst_conv)
	apply(rule stepxy) by simp_all
	} note staysae=this

	have opt: "fst (config' (\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, []) (bs @ [a] @ f)) \<in> {[a,e], [e,a]}"
	apply(rule staysae)
	using Lxyinitxy exy axy ane apply fast
	unfolding aexy by(fact bsaxy)

	have contr: " (\<forall>x. 0 < (if e = x then 0 else index [a] x + 1)) = False"
	proof (rule ccontr, goal_cases)
	case 1
	then have "\<And>x. 0 < (if e = x then 0 else index [a] x + 1)" by simp
	then have "0 < (if e = e then 0 else index [a] e + 1)" by blast
	then have "0<0" by simp
	then show "False" by auto
	qed


	show "a < e in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(subst TS_step_d_def)
	apply(simp only: history)
	using opt ane add
	apply(auto simp: step_def)
	apply(simp add: before_in_def)
	apply(simp add: before_in_def)
	apply(simp add: before_in_def contr)
	apply(simp add: mtf2_def swap_def before_in_def)
	apply(auto simp add: before_in_def contr)
	apply (metis One_nat_def add_is_1 count_list.simps(1) le_Suc_eq)
	by(simp add: mtf2_def swap_def)
	qed

	lemma oneposs:
	assumes "set xs = {x,y}"
	assumes "x\<noteq>y"
	assumes "distinct xs"
	assumes True: "x<y in xs"
	shows "xs = [x,y]"
	proof -
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs x = 0 \<and> index xs y = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs x), xs!index xs y]" using f by simp
	also have "\<dots> = [x,y]" using assms by(simp)
	finally show "xs = [x,y]" .
	qed

	lemma twoposs:
	assumes "set xs = {x,y}"
	assumes "x\<noteq>y"
	assumes "distinct xs"
	shows "xs \<in> {[x,y], [y,x]}"
	proof (cases "x<y in xs")
	case True
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs x = 0 \<and> index xs y = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs x), xs!index xs y]" using f by simp
	also have "\<dots> = [x,y]" using assms by(simp)
	finally have "xs = [x,y]" .
	then show ?thesis by simp
	next
	case False
	from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
	from False have "y<x in xs" using not_before_in assms(1,2) by fastforce
	then have "index xs y < index xs x" "index xs x < length xs" unfolding before_in_def using assms
	by simp_all
	then have f: "index xs y = 0 \<and> index xs x = 1" using len2 by linarith
	have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = take 1 xs @ [xs!1]" using len2 by simp
	also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
	apply(rule id_take_nth_drop) using len2 by simp
	also have "\<dots> = [xs!0]" by(simp)
	finally have "xs = [xs!0, xs!1]" by simp
	also have "\<dots> = [xs!(index xs y), xs!index xs x]" using f by simp
	also have "\<dots> = [y,x]" using assms by(simp)
	finally have "xs = [y,x]" .
	then show ?thesis by simp
	qed

	lemma TS_pairwise': assumes "qs \<in> {xs. set xs \<subseteq> set init}"
	"(x, y) \<in> {(x, y). x \<in> set init \<and> y \<in> set init \<and> x \<noteq> y}"
	"x \<noteq> y" "distinct init"
	shows "Pbefore_in x y (embed (rTS [])) qs init =
	Pbefore_in x y (embed (rTS [])) (Lxy qs {x, y}) (Lxy init {x, y})"
	proof -
	from assms have xyininit: "{x, y} \<subseteq> set init"
	and qsininit: "set qs \<subseteq> set init" by auto
	note dinit=assms(4)
	from assms have xny: "x\<noteq>y" by simp
	have Lxyinitxy: "Lxy init {x, y} \<in> {[x, y], [y, x]}"
	apply(rule twoposs)
	apply(subst Lxy_set_filter) using xyininit apply fast
	using xny Lxy_distinct[OF dinit] by simp_all

	have lq_s: "set (Lxy qs {x, y}) \<subseteq> {x,y}" by (simp add: Lxy_set_filter)

	(* projected history *)
	let ?pH = "snd (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	have "?pH =snd (TSdet (Lxy init {x, y}) [] (Lxy qs {x, y}) (length (Lxy qs {x, y})))"
	by(simp)
	also have "\<dots> = rev (take (length (Lxy qs {x, y})) (Lxy qs {x, y})) @ []"
	apply(rule sndTSdet) by simp
	finally have pH: "?pH = rev (Lxy qs {x, y})" by simp

	let ?pQs = "(Lxy qs {x, y})"

	have A: " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	proof(cases "?pQs" rule: rev_cases)
	case Nil
	then have xqs: "x \<notin> set qs" and yqs: "y \<notin> set qs" by(simp_all add: projEmpty)
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in init" apply(rule staysuntouched') using assms xqs yqs by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding Nil apply(simp) apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc as a)
	then have "a\<in>set (Lxy qs {x, y})" by (simp)
	then have axy: "a\<in>{x,y}" by(simp add: Lxy_set_filter)
	with xyininit have ainit: "a\<in>set init" by auto
	note a=snoc
	from a axy obtain pre suf where qs: "qs = pre @ [a] @ suf"
	and nosuf: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf"
	and pre: "Lxy pre {x,y} = as"
	using proj_Snoc by metis
	show ?thesis
	proof (cases "as" rule: rev_cases)
	case Nil
	from pre Nil have xqs: "x \<notin> set pre" and yqs: "y \<notin> set pre" by(simp_all add: projEmpty)
	from xqs yqs axy have "a \<notin> set pre" by blast
	then have noocc: "index (rev pre) a = length (rev pre)" by simp
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) init ((pre @ [a]) @ suf))" by(simp add: qs)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init pre)"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	by(simp add: noocc step_def)
	also have "\<dots> = x < y in init"
	apply(rule staysuntouched') using assms xqs yqs qs by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding a Nil apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
	apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc bs b)
	note b=this
	with a have "b\<in>set (Lxy qs {x, y})" by (simp)
	then have bxy: "b\<in>{x,y}" by(simp add: Lxy_set_filter)
	with xyininit have binit: "b\<in>set init" by auto
	from b pre have "Lxy pre {x,y} = bs @ [b]" by simp
	with bxy obtain pre2 suf2 where bs: "pre = pre2 @ [b] @ suf2"
	and nosuf2: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf2"
	and pre2: "Lxy pre2 {x,y} = bs"
	using proj_Snoc by metis

	from bs qs have qs2: "qs = pre2 @ [b] @ suf2 @ [a] @ suf" by simp

	show ?thesis
	proof (cases "a=b")
	case True
	note ab=this

	let ?qs ="(pre2 @ [a] @ suf2 @ [a]) @ suf"
	{
	fix e
	assume ane: "a\<noteq>e"
	assume exy: "e\<in>{x,y}"
	have "a < e in fst (config\<^sub>p (rTS []) init qs)
	= a < e in fst (config\<^sub>p (rTS []) init ?qs)" using True qs2 by(simp)
	also have "\<dots> = a < e in fst (config\<^sub>p (rTS []) init (pre2 @ [a] @ suf2 @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
	using exy xyininit apply fast
	using nosuf axy apply(simp)
	using nosuf exy by simp
	also have "\<dots>"
	apply(simp)
	apply(rule twotox[unfolded s_TS_def, simplified])
	using nosuf2 exy apply(simp)
	using assms apply(simp_all)
	using axy xyininit apply fast
	using exy xyininit apply fast
	using nosuf2 axy apply(simp)
	using ane by simp
	finally have "a < e in fst (config\<^sub>p (rTS []) init qs)" by simp
	} note full=this

	have "set (bs @ [a]) \<subseteq> set (Lxy qs {x, y})" using a b by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have bsaxy: "set (bs @ [a]) \<subseteq> {x,y}" .

	with xny show ?thesis
	proof(cases "x=a")
	case True
	have 1: "a < y in fst (config\<^sub>p (rTS []) init qs)"
	apply(rule full)
	using True xny apply blast
	by simp


	have "a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
	using a b ab by simp
	also have "\<dots>"
	apply(rule projxx[where bs=bs and f="[]"])
	using True apply blast
	using a b True ab xny Lxyinitxy bsaxy by(simp_all)
	finally show ?thesis using True 1 by simp
	next
	case False
	with axy have ay: "a=y" by blast
	have 1: "a < x in fst (config\<^sub>p (rTS []) init qs)"
	apply(rule full)
	using False xny apply blast
	by simp
	have "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
	using a b ab by simp
	also have "\<dots>"
	apply(rule projxx[where bs=bs and f="[]"])
	using True axy apply blast
	using a b True ab xny Lxyinitxy ay bsaxy by(simp_all)
	finally have 2: "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

	have "x < y in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> y < x in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using assms by(simp_all)
	also have "\<dots> = False" using 1 ay by simp
	also have "\<dots> = (\<not> y < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using 2 ay by simp
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using assms by(simp_all add: Lxy_set_filter)
	finally show ?thesis .
	qed
	next
	case False
	note ab=this

	show ?thesis
	proof (cases "bs" rule: rev_cases)
	case Nil
	with a b have "Lxy qs {x, y} = [b,a]" by simp
	from pre2 Nil have xqs: "x \<notin> set pre2" and yqs: "y \<notin> set pre2" by(simp_all add: projEmpty)
	from xqs yqs bxy have "b \<notin> set pre2" by blast
	then have noocc2: "index (rev pre2) b = length (rev pre2)" by simp
	from axy nosuf2 have "a \<notin> set suf2" by blast
	with xqs yqs axy False have "a \<notin> set ((pre2 @ b # suf2))" by(auto)
	then have noocc: "index (rev (pre2 @ b # suf2) @ []) a = length (rev (pre2 @ b # suf2))" by simp
	have " x < y in fst (config\<^sub>p (rTS []) init qs)
	= x < y in fst (config\<^sub>p (rTS []) init ((((pre2 @ [b]) @ suf2) @ [a]) @ suf))" by(simp add: qs2)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (((pre2 @ [b]) @ suf2) @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init ((pre2 @ [b]) @ suf2))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	apply(simp only: noocc) by (simp add: step_def)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre2 @ [b]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms xqs yqs qs2 nosuf2 by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) init (pre2))"
	apply(subst config_append)
	apply(simp add: rTS_def Step_def split_def)
	apply(simp only: TS_step_d_def)
	apply(simp only: sndTSconfig'[unfolded rTS_def])
	by(simp add: noocc2 step_def)
	also have "\<dots> = x < y in init"
	apply(rule staysuntouched') using assms xqs yqs qs2 by(simp_all)
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	unfolding a b Nil
	using False
	apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
	apply(rule Lxy_mono) using xyininit dinit by(simp_all)
	finally show ?thesis .
	next
	case (snoc cs c)
	note c=this
	with a b have "c\<in>set (Lxy qs {x, y})" by (simp)
	then have cxy: "c\<in>{x,y}" by(simp add: Lxy_set_filter)
	from c pre2 have "Lxy pre2 {x,y} = cs @ [c]" by simp
	with cxy obtain pre3 suf3 where cs: "pre2 = pre3 @ [c] @ suf3"
	and nosuf3: "\<And>e. e \<in> {x,y} \<Longrightarrow> e \<notin> set suf3"
	and pre3: "Lxy pre3 {x,y} = cs"
	using proj_Snoc by metis

	let ?qs=" pre3 @ [c] @ suf3 @ [b] @ suf2 @ [a] @ suf"
	from bs cs qs have qs2: "qs = ?qs" by simp

	show ?thesis
	proof(cases "c=a")
	case True (* aba *)
	note ca=this

	have "a < b in fst (config\<^sub>p (rTS []) init qs)
	= a < b in fst (config\<^sub>p (rTS []) init ((pre3 @ a # (suf3 @ [b] @ suf2) @ [a]) @ suf))"
	using qs2 True by simp
	also have "\<dots> = a < b in fst (config\<^sub>p (rTS []) init (pre3 @ a # (suf3 @ [b] @ suf2) @ [a]))"
	apply(subst config_append)
	apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
	using bxy xyininit apply(fast)
	using nosuf axy bxy by(simp_all)
	also have "..."
	apply(rule twotox[unfolded s_TS_def, simplified])
	using nosuf2 nosuf3 bxy apply(simp)
	using assms apply(simp_all)
	using axy xyininit apply(fast)
	using bxy xyininit apply(fast)
	using ab nosuf2 nosuf3 axy apply(simp)
	using ab by simp
	finally have full: "a < b in fst (config\<^sub>p (rTS []) init qs)" by simp


	have "set (cs @ [a] @ [b]) \<subseteq> set (Lxy qs {x, y})" using a b c by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have csabxy: "set (cs @ [a] @ [b]) \<subseteq> {x,y}" .

	with xny show ?thesis
	proof(cases "x=a")
	case True
	with xny ab bxy have bisy: "b=y" by blast
	have 1: "x < y in fst (config\<^sub>p (rTS []) init qs)"
	using full True bisy by simp

	have "a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
	using a b c ca ab by simp
	also have "\<dots>"
	apply(rule projxx)
	using True apply blast
	using a b True ab xny Lxyinitxy csabxy by(simp_all)
	finally show ?thesis using 1 True by simp
	next
	case False
	with axy have ay: "a=y" by blast
	with xny ab bxy have bisx: "b=x" by blast
	have 1: "y < x in fst (config\<^sub>p (rTS []) init qs)"
	using full ay bisx by simp

	have "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
	using a b c ca ab by simp
	also have "\<dots>"
	apply(rule projxx)
	using a b True ab xny Lxyinitxy csabxy False by(simp_all)
	finally have 2: "a < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

	have "x < y in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> y < x in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using assms by(simp_all)
	also have "\<dots> = False" using 1 ay by simp
	also have "\<dots> = (\<not> y < x in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using 2 ay by simp
	also have "\<dots> = x < y in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using assms by(simp_all add: Lxy_set_filter)
	finally show ?thesis .
	qed
	next
	case False (* bba *)
	then have cb: "c=b" using bxy cxy axy ab by blast

	let ?cs = "suf2 @ [a] @ suf"
	let ?i = "index ?cs a"


	have aed: "(\<forall>j<index (suf2 @ a # suf) a. (suf2 @ a # suf) ! j \<noteq> a)"
	by (metis add.right_neutral axy index_Cons index_append nosuf2 nth_append nth_mem)

	have "?i < length ?cs
	\<longrightarrow> (\<forall>j<?i. ?cs ! j \<noteq> ?cs ! ?i) \<longrightarrow> ?cs ! ?i \<noteq> b
	\<longrightarrow> ?cs ! ?i \<notin> set suf3
	\<longrightarrow> b < ?cs ! ?i in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	apply(rule casexxy)
	using cb qs2 apply(simp)
	using bxy ab nosuf2 nosuf apply(simp)
	using bs qs qsininit apply(simp)
	using bxy xyininit apply(blast)
	apply(fact)
	using nosuf3 bxy apply(simp)
	using cs bs qs qsininit by(simp_all)

	then have inner: "b < a in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	using ab nosuf3 axy bxy aed
	by(simp)
	let ?n = "(length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
	let ?inner="(config\<^sub>p (rTS []) init (take (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1) ?qs))"

	have "b < a in fst (config\<^sub>p (rTS []) init qs)
	= b < a in fst (config\<^sub>p (rTS []) init (take ?n ?qs @ drop ?n ?qs))" using qs2 by simp
	also have "\<dots> = b < a in fst (config' (rTS []) ?inner suf)" apply(simp only: config_append drop_append)
	using nosuf2 axy by(simp add: index_append config_append)
	also have "\<dots> = b < a in fst ?inner"
	apply(rule staysuntouched) using assms bxy xyininit qs nosuf apply(simp_all)
	using bxy xyininit apply(blast)
	using axy xyininit by (blast)
	also have "\<dots> = True" using inner by(simp add: s_TS_def qs2)
	finally have full: "b < a in fst (config\<^sub>p (rTS []) init qs)" by simp

	have "set (cs @ [b] @ []) \<subseteq> set (Lxy qs {x, y})" using a b c by auto
	also have "\<dots> = {x,y} \<inter> set qs" by (rule Lxy_set_filter)
	also have "\<dots> \<subseteq> {x,y}" by simp
	finally have csbxy: "set (cs @ [b] @ []) \<subseteq> {x,y}" .

	have "set (Lxy init {x, y}) = {x,y} \<inter> set init"
	by(rule Lxy_set_filter)
	also have "\<dots> = {x,y}" using xyininit by fast
	also have "\<dots> = {b,a}" using axy bxy ab by fast
	finally have r: "set (Lxy init {x, y}) = {b, a}" .

	let ?confbef="(config\<^sub>p (rTS []) (Lxy init {x, y}) ((cs @ [b] @ []) @ [b]))"
	have f1: "b < a in fst ?confbef"
	apply(rule projxx)
	using bxy ab axy a b c csbxy Lxyinitxy by(simp_all)
	have 1: "fst ?confbef = [b,a]"
	apply(rule oneposs)
	using ab axy bxy xyininit Lxy_distinct[OF dinit] f1 r by(simp_all)
	have 2: "snd (Partial_Cost_Model.config'
	(\<lambda>s. [], TS_step_d)
	(Lxy init {x, y}, [])
	(cs @ [b, b])) = [b,b]@(rev cs)"
	using sndTSdet[of "length (cs @ [b, b])" "(cs @ [b, b])", unfolded rTS_def] by(simp)
	have "b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
	= b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (((cs @ [b] @ []) @ [b])@[a]))"
	using a b c cb by(simp)
	also have "\<dots>"
	apply(subst config_append)
	using 1 2 ab apply(simp add: step_def Step_def split_def rTS_def TS_step_d_def)
	by(simp add: before_in_def)
	finally have projected: "b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .


	have 1: "{x,y} = {a,b}" using ab axy bxy by fast
	with xny show ?thesis
	proof(cases "x=a")
	case True
	with 1 xny have y: "y=b" by fast
	have "a < b in fst (config\<^sub>p (rTS []) init qs) =
	(\<not> b < a in fst (config\<^sub>p (rTS []) init qs))"
	apply(subst not_before_in)
	using binit ainit ab by(simp_all)
	also have "\<dots> = False" using full by simp
	also have "\<dots> = (\<not> b < a in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
	using projected by simp
	also have "\<dots> = a < b in fst (config\<^sub>p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
	apply(subst not_before_in)
	using binit ainit ab axy bxy by(simp_all add: Lxy_set_filter)
	finally show ?thesis using True y by simp
	next
	case False
	with 1 xny have y: "y=a" "x=b" by fast+
	with full projected show ?thesis by fast
	qed
	qed (* end of (c=a) *)
	qed (* end of snoc cs c *)
	qed (* end of (a=b) *)
	qed (* end snoc bs b *)
	qed (* end snoc as a *)




	show ?thesis unfolding Pbefore_in_def
	apply(subst config_embed)
	apply(subst config_embed)
	apply(simp) by (rule A)
	qed

	theorem TS_pairwise: "pairwise (embed (rTS []))"
	apply(rule pairwise_property_lemma)
	apply(rule TS_pairwise') by (simp_all add: rTS_def TS_step_d_def)


	subsection "TS is 2-compet"


	lemma TS_compet': "pairwise (embed (rTS [])) \<Longrightarrow>
	\<forall>s0\<in>{init::(nat list). distinct init \<and> init\<noteq>[]}. \<exists>b\<ge>0. \<forall>qs\<in>{x. set x \<subseteq> set s0}. T\<^sub>p_on_rand (embed (rTS [])) s0 qs \<le> (2::real) * T\<^sub>p_opt s0 qs + b"
	unfolding rTS_def
	proof (rule factoringlemma_withconstant, goal_cases)
	case 5
	show ?case
	proof (safe, goal_cases)
	case (1 init)
	note out=this
	show ?case
	apply(rule exI[where x=2])
	apply(simp)
	proof (safe, goal_cases)
	case (1 qs a b)
	then have a: "a\<noteq>b" by simp
	have twist: "{a,b}={b, a}" by auto
	have b1: "set (Lxy qs {a, b}) \<subseteq> {a, b}" unfolding Lxy_def by auto
	with this[unfolded twist] have b2: "set (Lxy qs {b, a}) \<subseteq> {b, a}" by(auto)

	have "set (Lxy init {a, b}) = {a,b} \<inter> (set init)" apply(induct init)
	unfolding Lxy_def by(auto)
	with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
	have "finite {a,b}" by auto
	from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
	have C: "length (Lxy init {a, b}) = 2"
	using distinct_card[OF B, unfolded A] using a by auto

	have "{xs. set xs = {a,b} \<and> distinct xs \<and> length xs =(2::nat)}
	= { [a,b], [b,a] }"
	apply(auto simp: a a[symmetric])
	proof (goal_cases)
	case (1 xs)
	from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
	with 1(4) have "length xs' = 1" by auto
	then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
	from r s have t: "[x,y] = xs" by auto
	moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
	moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
	ultimately show ?case by auto
	qed

	with A B C have pos: "(Lxy init {a, b}) = [a,b]
	\<or> (Lxy init {a, b}) = [b,a]" by auto

	{ fix a::nat
	fix b::nat
	fix qs
	assume as: "a \<noteq> b" "set qs \<subseteq> {a, b}"
	have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] \<bind> (\<lambda>is. return_pmf ([a,b], is))) qs
	= T\<^sub>p_on (rTS []) [a, b] qs" by (rule T_on_embed[symmetric])
	also from as have "\<dots> \<le> 2 * T\<^sub>p_opt [a, b] qs + 2" using TS_OPT2' by fastforce
	finally have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] \<bind> (\<lambda>is. return_pmf ([a,b], is))) qs
	\<le> 2 * T\<^sub>p_opt [a, b] qs + 2" .
	} note ye=this

	show ?case
	apply(cases "(Lxy init {a, b}) = [a,b]")
	using ye[OF a b1, unfolded rTS_def] apply(simp)
	using pos ye[OF a[symmetric] b2, unfolded rTS_def] by(simp add: twist)
	qed
	qed
	next
	case 6
	show ?case unfolding TS_step_d_def by (simp add: split_def TS_step_d_def)
	next
	case (7 init qs x)
	then show ?case
	apply(induct x)
	by (simp_all add: rTS_def split_def take_Suc_conv_app_nth config'_rand_snoc )
	next
	case 4 then show ?case by simp
	qed (simp_all)


	lemma TS_compet: "compet_rand (embed (rTS [])) 2 {init. distinct init \<and> init \<noteq> []}"
	unfolding compet_rand_def static_def
	using TS_compet'[OF TS_pairwise] by simp

	end
	diff --git a/thys/MFMC_Countable/MFMC_Flow_Attainability.thy b/thys/MFMC_Countable/MFMC_Flow_Attainability.thy
	--- a/thys/MFMC_Countable/MFMC_Flow_Attainability.thy
	+++ b/thys/MFMC_Countable/MFMC_Flow_Attainability.thy
	@@ -1,2166 +1,2166 @@
	theory MFMC_Flow_Attainability imports
	MFMC_Network
	begin

	section \<open>Attainability of flows in networks\<close>

	subsection \<open>Cleaning up flows\<close>

	text \<open>If there is a flow along antiparallel edges, it suffices to consider the difference.\<close>

	definition cleanup :: "'a flow \<Rightarrow> 'a flow"
	where "cleanup f = (\<lambda>(a, b). if f (a, b) > f (b, a) then f (a, b) - f (b, a) else 0)"

	lemma cleanup_simps [simp]:
	"cleanup f (a, b) = (if f (a, b) > f (b, a) then f (a, b) - f (b, a) else 0)"
	by(simp add: cleanup_def)

	lemma value_flow_cleanup:
	assumes [simp]: "\<And>x. f (x, source \<Delta>) = 0"
	shows "value_flow \<Delta> (cleanup f) = value_flow \<Delta> f"
	unfolding d_OUT_def
	by (auto simp add: not_less intro!: nn_integral_cong intro: antisym)

	lemma KIR_cleanup:
	assumes KIR: "KIR f x"
	and finite_IN: "d_IN f x \<noteq> \<top>"
	shows "KIR (cleanup f) x"
	proof -
	from finite_IN KIR have finite_OUT: "d_OUT f x \<noteq> \<top>" by simp

	have finite_IN: "(\<Sum>\<^sup>+ y\<in>A. f (y, x)) \<noteq> \<top>" for A
	using finite_IN by(rule neq_top_trans)(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
	have finite_OUT: "(\<Sum>\<^sup>+ y\<in>A. f (x, y)) \<noteq> \<top>" for A
	using finite_OUT by(rule neq_top_trans)(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
	have finite_in: "f (x, y) \<noteq> \<top>" for y using \<open>d_OUT f x \<noteq> \<top>\<close>
	by(rule neq_top_trans) (rule d_OUT_ge_point)

	let ?M = "{y. f (x, y) > f (y, x)}"

	have "d_OUT (cleanup f) x = (\<Sum>\<^sup>+ y\<in>?M. f (x, y) - f (y, x))"
	by(auto simp add: d_OUT_def nn_integral_count_space_indicator intro!: nn_integral_cong)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>?M. f (x, y)) - (\<Sum>\<^sup>+ y\<in>?M. f (y, x))" using finite_IN
	by(subst nn_integral_diff)(auto simp add: AE_count_space)
	also have "\<dots> = (d_OUT f x - (\<Sum>\<^sup>+ y\<in>{y. f (x, y) \<le> f (y, x)}. f (x, y))) - (\<Sum>\<^sup>+ y\<in>?M. f (y, x))"
	unfolding d_OUT_def d_IN_def using finite_IN finite_OUT
	apply(simp add: nn_integral_count_space_indicator)
	apply(subst (2) nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space finite_in split: split_indicator intro!: arg_cong2[where f="(-)"] intro!: nn_integral_cong)
	done
	also have "\<dots> = (d_IN f x - (\<Sum>\<^sup>+ y\<in>?M. f (y, x))) - (\<Sum>\<^sup>+ y\<in>{y. f (x, y) \<le> f (y, x)}. f (x, y))"
	using KIR by(simp add: diff_diff_commute_ennreal)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>{y. f (x, y) \<le> f (y, x)}. f (y, x)) - (\<Sum>\<^sup>+ y\<in>{y. f (x, y) \<le> f (y, x)}. f (x, y))"
	using finite_IN finite_IN[of "{ _ }"]
	apply(simp add: d_IN_def nn_integral_count_space_indicator)
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: d_IN_def AE_count_space split: split_indicator intro!: arg_cong2[where f="(-)"] intro!: nn_integral_cong)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>{y. f (x, y) \<le> f (y, x)}. f (y, x) - f (x, y))" using finite_OUT
	by(subst nn_integral_diff)(auto simp add: AE_count_space)
	also have "\<dots> = d_IN (cleanup f) x" using finite_in
	by(auto simp add: d_IN_def nn_integral_count_space_indicator intro!: ennreal_diff_self nn_integral_cong split: split_indicator)
	finally show "KIR (cleanup f) x" .
	qed

	locale flow_attainability = countable_network \<Delta>
	for \<Delta> :: "('v, 'more) network_scheme" (structure)
	+
	assumes finite_capacity: "\<And>x. x \<noteq> sink \<Delta> \<Longrightarrow> d_IN (capacity \<Delta>) x \<noteq> \<top> \<or> d_OUT (capacity \<Delta>) x \<noteq> \<top>"
	and no_loop: "\<And>x. \<not> edge \<Delta> x x"
	and source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
	begin

	lemma source_in_not_cycle:
	assumes "cycle \<Delta> p"
	shows "(x, source \<Delta>) \<notin> set (cycle_edges p)"
	using cycle_edges_edges[OF assms] source_in[of x] by(auto)

	lemma source_out_not_cycle:
	"cycle \<Delta> p \<Longrightarrow> (source \<Delta>, x) \<notin> set (cycle_edges p)"
	by(auto dest: cycle_leave_ex_enter source_in_not_cycle)

	lemma flowD_source_IN:
	assumes "flow \<Delta> f"
	shows "d_IN f (source \<Delta>) = 0"
	proof -
	have "d_IN f (source \<Delta>) = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N (source \<Delta>). f (y, source \<Delta>))"
	by(rule d_IN_alt_def)(simp add: flowD_outside[OF assms])
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N (source \<Delta>). 0)"
	by(rule nn_integral_cong)(simp add: source_in incoming_def)
	finally show ?thesis by simp
	qed

	lemma flowD_finite_IN:
	assumes f: "flow \<Delta> f" and x: "x \<noteq> sink \<Delta>"
	shows "d_IN f x \<noteq> top"
	proof(cases "x = source \<Delta>")
	case True thus ?thesis by(simp add: flowD_source_IN[OF f])
	next
	case False
	from finite_capacity[OF x] show ?thesis
	proof
	assume *: "d_IN (capacity \<Delta>) x \<noteq> \<top>"
	from flowD_capacity[OF f] have "d_IN f x \<le> d_IN (capacity \<Delta>) x" by(rule d_IN_mono)
	also have "\<dots> < \<top>" using * by (simp add: less_top)
	finally show ?thesis by simp
	next
	assume *: "d_OUT (capacity \<Delta>) x \<noteq> \<top>"
	have "d_IN f x = d_OUT f x" using flowD_KIR[OF f False x] by simp
	also have "\<dots> \<le> d_OUT (capacity \<Delta>) x" using flowD_capacity[OF f] by(rule d_OUT_mono)
	also have "\<dots> < \<top>" using * by (simp add: less_top)
	finally show ?thesis by simp
	qed
	qed

	lemma flowD_finite_OUT:
	assumes "flow \<Delta> f" "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	shows "d_OUT f x \<noteq> \<top>"
	using flowD_KIR[OF assms] assms by(simp add: flowD_finite_IN)

	end

	locale flow_network = flow_attainability
	+
	fixes g :: "'v flow"
	assumes g: "flow \<Delta> g"
	and g_finite: "value_flow \<Delta> g \<noteq> \<top>"
	and nontrivial: "\<^bold>V - {source \<Delta>, sink \<Delta>} \<noteq> {}"
	begin

	lemma g_outside: "e \<notin> \<^bold>E \<Longrightarrow> g e = 0"
	by(rule flowD_outside)(rule g)

	lemma g_loop [simp]: "g (x, x) = 0"
	by(rule g_outside)(simp add: no_loop)

	lemma finite_IN_g: "x \<noteq> sink \<Delta> \<Longrightarrow> d_IN g x \<noteq> top"
	by(rule flowD_finite_IN[OF g])

	lemma finite_OUT_g:
	assumes "x \<noteq> sink \<Delta>"
	shows "d_OUT g x \<noteq> top"
	proof(cases "x = source \<Delta>")
	case True
	with g_finite show ?thesis by simp
	next
	case False
	with g have "KIR g x" using assms by(auto dest: flowD_KIR)
	with finite_IN_g[of x] False assms show ?thesis by(simp)
	qed

	lemma g_source_in [simp]: "g (x, source \<Delta>) = 0"
	by(rule g_outside)(simp add: source_in)

	lemma finite_g [simp]: "g e \<noteq> top"
	by(rule flowD_finite[OF g])


	definition enum_v :: "nat \<Rightarrow> 'v"
	where "enum_v n = from_nat_into (\<^bold>V - {source \<Delta>, sink \<Delta>}) (fst (prod_decode n))"

	lemma range_enum_v: "range enum_v \<subseteq> \<^bold>V - {source \<Delta>, sink \<Delta>}"
	using from_nat_into[OF nontrivial] by(auto simp add: enum_v_def)

	lemma enum_v_repeat:
	assumes x: "x \<in> \<^bold>V" "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	shows "\<exists>i'>i. enum_v i' = x"
	proof -
	let ?V = "\<^bold>V - {source \<Delta>, sink \<Delta>}"
	let ?n = "to_nat_on ?V x"
	let ?A = "{?n} \<times> (UNIV :: nat set)"
	from x have x': "x \<in> \<^bold>V - {source \<Delta>, sink \<Delta>}" by simp
	have "infinite ?A" by(auto dest: finite_cartesian_productD2)
	hence "infinite (prod_encode ` ?A)" by(auto dest: finite_imageD simp add: inj_prod_encode)
	then obtain i' where "i' > i" "i' \<in> prod_encode ` ?A"
	unfolding infinite_nat_iff_unbounded by blast
	from this(2) have "enum_v i' = x" using x by(clarsimp simp add: enum_v_def)
	with \<open>i' > i\<close> show ?thesis by blast
	qed

	fun h_plus :: "nat \<Rightarrow> 'v edge \<Rightarrow> ennreal"
	where
	"h_plus 0 (x, y) = (if x = source \<Delta> then g (x, y) else 0)"
	\| "h_plus (Suc i) (x, y) =
	(if enum_v (Suc i) = x \<and> d_OUT (h_plus i) x < d_IN (h_plus i) x then
	let total = d_IN (h_plus i) x - d_OUT (h_plus i) x;
	share = g (x, y) - h_plus i (x, y);
	shares = d_OUT g x - d_OUT (h_plus i) x
	in h_plus i (x, y) + share * total / shares
	else h_plus i (x, y))"


	lemma h_plus_le_g: "h_plus i e \<le> g e"
	proof(induction i arbitrary: e and e)
	case 0 thus ?case by(cases e) simp
	next
	case (Suc i)
	{ fix x y
	assume enum: "x = enum_v (Suc i)"
	assume less: "d_OUT (h_plus i) x < d_IN (h_plus i) x"
	from enum have x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" using range_enum_v
	by(auto dest: sym intro: rev_image_eqI)

	define share where "share = g (x, y) - h_plus i (x, y)"
	define shares where "shares = d_OUT g x - d_OUT (h_plus i) x"
	define total where "total = d_IN (h_plus i) x - d_OUT (h_plus i) x"
	let ?h = "h_plus i (x, y) + share * total / shares"

	have "d_OUT (h_plus i) x \<le> d_OUT g x" by(rule d_OUT_mono)(rule Suc.IH)
	also have "\<dots> < top" using finite_OUT_g[of x] x by (simp add: less_top)
	finally have "d_OUT (h_plus i) x \<noteq> \<top>" by simp
	then have shares_eq: "shares = (\<Sum>\<^sup>+ y. g (x, y) - h_plus i (x, y))" unfolding shares_def d_OUT_def
	by(subst nn_integral_diff)(simp_all add: AE_count_space Suc.IH)

	have *: "share / shares \<le> 1"
	proof (cases "share = 0")
	case True thus ?thesis by(simp)
	next
	case False
	hence "share > 0" using \<open>h_plus i (x, y) \<le> g _\<close>
	by(simp add: share_def dual_order.strict_iff_order)
	moreover have "share \<le> shares" unfolding share_def shares_eq by(rule nn_integral_ge_point)simp
	ultimately show ?thesis by(simp add: divide_le_posI_ennreal)
	qed

	note shares_def
	also have "d_OUT g x = d_IN g x" by(rule flowD_KIR[OF g x])
	also have "d_IN (h_plus i) x \<le> d_IN g x" by(rule d_IN_mono)(rule Suc.IH)
	ultimately have *: "total \<le> shares" unfolding total_def by(simp add: ennreal_minus_mono)
	moreover have "total > 0" unfolding total_def using less by (clarsimp simp add: diff_gr0_ennreal)
	ultimately have "total / shares \<le> 1" by(intro divide_le_posI_ennreal)(simp_all)
	hence "share * (total / shares) \<le> share * 1"
	by(rule mult_left_mono) simp
	hence "?h \<le> h_plus i (x, y) + share" by(simp add: ennreal_times_divide add_mono)
	also have "\<dots> = g (x, y)" unfolding share_def using \<open>h_plus i (x, y) \<le> g _\<close> finite_g[of "(x, y)"]
	by simp
	moreover
	note calculation }
	note * = this
	show ?case using Suc.IH * by(cases e) clarsimp
	qed

	lemma h_plus_outside: "e \<notin> \<^bold>E \<Longrightarrow> h_plus i e = 0"
	by (metis g_outside h_plus_le_g le_zero_eq)

	lemma h_plus_not_infty [simp]: "h_plus i e \<noteq> top"
	using h_plus_le_g[of i e] by (auto simp: top_unique)

	lemma h_plus_mono: "h_plus i e \<le> h_plus (Suc i) e"
	proof(cases e)
	case [simp]: (Pair x y)
	{ assume "d_OUT (h_plus i) x < d_IN (h_plus i) x"
	hence "h_plus i (x, y) + 0 \<le> h_plus i (x, y) + (g (x, y) - h_plus i (x, y)) * (d_IN (h_plus i) x - d_OUT (h_plus i) x) / (d_OUT g x - d_OUT (h_plus i) x)"
	by(intro add_left_mono d_OUT_mono le_funI) (simp_all add: h_plus_le_g) }
	then show ?thesis by clarsimp
	qed

	lemma h_plus_mono': "i \<le> j \<Longrightarrow> h_plus i e \<le> h_plus j e"
	by(induction rule: dec_induct)(auto intro: h_plus_mono order_trans)

	lemma d_OUT_h_plus_not_infty': "x \<noteq> sink \<Delta> \<Longrightarrow> d_OUT (h_plus i) x \<noteq> top"
	using d_OUT_mono[of "h_plus i" x g, OF h_plus_le_g] finite_OUT_g[of x] by (auto simp: top_unique)

	lemma h_plus_OUT_le_IN:
	assumes "x \<noteq> source \<Delta>"
	shows "d_OUT (h_plus i) x \<le> d_IN (h_plus i) x"
	proof(induction i)
	case 0
	thus ?case using assms by(simp add: d_OUT_def)
	next
	case (Suc i)
	have "d_OUT (h_plus (Suc i)) x \<le> d_IN (h_plus i) x"
	proof(cases "enum_v (Suc i) = x \<and> d_OUT (h_plus i) x < d_IN (h_plus i) x")
	case False
	thus ?thesis using Suc.IH by(simp add: d_OUT_def cong: conj_cong)
	next
	case True
	hence x: "x \<noteq> sink \<Delta>" and le: "d_OUT (h_plus i) x < d_IN (h_plus i) x" using range_enum_v by auto
	let ?r = "\<lambda>y. (g (x, y) - h_plus i (x, y)) * (d_IN (h_plus i) x - d_OUT (h_plus i) x) / (d_OUT g x - d_OUT (h_plus i) x)"
	have "d_OUT (h_plus (Suc i)) x = d_OUT (h_plus i) x + (\<Sum>\<^sup>+ y. ?r y)"
	using True unfolding d_OUT_def h_plus.simps by(simp add: AE_count_space nn_integral_add)
	also from True have "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" using range_enum_v by auto
	from flowD_KIR[OF g this] le d_IN_mono[of "h_plus i" x g, OF h_plus_le_g]
	have le': "d_OUT (h_plus i) x < d_OUT g x" by(simp)
	then have "(\<Sum>\<^sup>+ y. ?r y) =
	(d_IN (h_plus i) x - d_OUT (h_plus i) x) * ((\<Sum>\<^sup>+ y. g (x, y) - h_plus i (x, y)) / (d_OUT g x - d_OUT (h_plus i) x))"
	by(subst mult.commute, subst ennreal_times_divide[symmetric])
	(simp add: nn_integral_cmult nn_integral_divide Suc.IH diff_gr0_ennreal)
	also have "(\<Sum>\<^sup>+ y. g (x, y) - h_plus i (x, y)) = d_OUT g x - d_OUT (h_plus i) x" using x
	by(subst nn_integral_diff)(simp_all add: d_OUT_def[symmetric] h_plus_le_g d_OUT_h_plus_not_infty')
	also have "\<dots> / \<dots> = 1" using le' finite_OUT_g[of x] x
	by(auto intro!: ennreal_divide_self dest: diff_gr0_ennreal simp: less_top[symmetric])
	also have "d_OUT (h_plus i) x + (d_IN (h_plus i) x - d_OUT (h_plus i) x) * 1 = d_IN (h_plus i) x" using x
	by (simp add: Suc)
	finally show ?thesis by simp
	qed
	also have "\<dots> \<le> d_IN (h_plus (Suc i)) x" by(rule d_IN_mono)(rule h_plus_mono)
	finally show ?case .
	qed

	lemma h_plus_OUT_eq_IN:
	assumes enum: "enum_v (Suc i) = x"
	shows "d_OUT (h_plus (Suc i)) x = d_IN (h_plus i) x"
	proof(cases "d_OUT (h_plus i) x < d_IN (h_plus i) x")
	case False
	from enum have "x \<noteq> source \<Delta>" using range_enum_v by auto
	from h_plus_OUT_le_IN[OF this, of i] False have "d_OUT (h_plus i) x = d_IN (h_plus i) x" by auto
	with False enum show ?thesis by(simp add: d_OUT_def)
	next
	case True
	from enum have x: "x \<noteq> source \<Delta>" and sink: "x \<noteq> sink \<Delta>" using range_enum_v by auto
	let ?r = "\<lambda>y. (g (x, y) - h_plus i (x, y)) * (d_IN (h_plus i) x - d_OUT (h_plus i) x) / (d_OUT g x - d_OUT (h_plus i) x)"
	have "d_OUT (h_plus (Suc i)) x = d_OUT (h_plus i) x + (\<Sum>\<^sup>+ y. ?r y)"
	using True enum unfolding d_OUT_def h_plus.simps by(simp add: AE_count_space nn_integral_add)
	also from True enum have "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" using range_enum_v by auto
	from flowD_KIR[OF g this] True d_IN_mono[of "h_plus i" x g, OF h_plus_le_g]
	have le': "d_OUT (h_plus i) x < d_OUT g x" by(simp)
	then have "(\<Sum>\<^sup>+ y. ?r y ) =
	(d_IN (h_plus i) x - d_OUT (h_plus i) x) * ((\<Sum>\<^sup>+ y. g (x, y) - h_plus i (x, y)) / (d_OUT g x - d_OUT (h_plus i) x))"
	by(subst mult.commute, subst ennreal_times_divide[symmetric])
	(simp add: nn_integral_cmult nn_integral_divide h_plus_OUT_le_IN[OF x] diff_gr0_ennreal)
	also have "(\<Sum>\<^sup>+ y. g (x, y) - h_plus i (x, y)) = d_OUT g x - d_OUT (h_plus i) x" using sink
	by(subst nn_integral_diff)(simp_all add: d_OUT_def[symmetric] h_plus_le_g d_OUT_h_plus_not_infty')
	also have "\<dots> / \<dots> = 1" using le' finite_OUT_g[of x] sink
	by(auto intro!: ennreal_divide_self dest: diff_gr0_ennreal simp: less_top[symmetric])
	also have "d_OUT (h_plus i) x + (d_IN (h_plus i) x - d_OUT (h_plus i) x) * 1 = d_IN (h_plus i) x" using sink
	by (simp add: h_plus_OUT_le_IN x)
	finally show ?thesis .
	qed

	lemma h_plus_source_in [simp]: "h_plus i (x, source \<Delta>) = 0"
	by(induction i)simp_all

	lemma h_plus_sum_finite: "(\<Sum>\<^sup>+ e. h_plus i e) \<noteq> top"
	proof(induction i)
	case 0
	have "(\<Sum>\<^sup>+ e\<in>UNIV. h_plus 0 e) = (\<Sum>\<^sup>+ (x, y). h_plus 0 (x, y))"
	by(simp del: h_plus.simps)
	also have "\<dots> = (\<Sum>\<^sup>+ (x, y)\<in>range (Pair (source \<Delta>)). h_plus 0 (x, y))"
	by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_cong)
	also have "\<dots> = value_flow \<Delta> g" by(simp add: d_OUT_def nn_integral_count_space_reindex)
	also have "\<dots> < \<top>" using g_finite by (simp add: less_top)
	finally show ?case by simp
	next
	case (Suc i)
	define xi where "xi = enum_v (Suc i)"
	then have xi: "xi \<noteq> source \<Delta>" "xi \<noteq> sink \<Delta>" using range_enum_v by auto
	show ?case
	proof(cases "d_OUT (h_plus i) xi < d_IN (h_plus i) xi")
	case False
	hence "(\<Sum>\<^sup>+ e\<in>UNIV. h_plus (Suc i) e) = (\<Sum>\<^sup>+ e. h_plus i e)"
	by(auto intro!: nn_integral_cong simp add: xi_def)
	with Suc.IH show ?thesis by simp
	next
	case True
	have less: "d_OUT (h_plus i) xi < d_OUT g xi"
	using True flowD_KIR[OF g xi] d_IN_mono[of "h_plus i" xi, OF h_plus_le_g]
	by simp

	have "(\<Sum>\<^sup>+ e. h_plus (Suc i) e) =
	(\<Sum>\<^sup>+ e\<in>UNIV. h_plus i e) + (\<Sum>\<^sup>+ (x, y). ((g (x, y) - h_plus i (x, y)) * (d_IN (h_plus i) x - d_OUT (h_plus i) x) / (d_OUT g x - d_OUT (h_plus i) x)) * indicator (range (Pair xi)) (x, y))"
	(is "_ = ?IH + ?rest" is "_ = _ + \<integral>\<^sup>+ (x, y). ?f x y * _ \<partial>_") using xi True
	by(subst nn_integral_add[symmetric])(auto simp add: xi_def split_beta AE_count_space intro!: nn_integral_cong split: split_indicator intro!: h_plus_le_g h_plus_OUT_le_IN d_OUT_mono le_funI)
	also have "?rest = (\<Sum>\<^sup>+ (x, y)\<in>range (Pair xi). ?f x y)"
	by(simp add: nn_integral_count_space_indicator split_def)
	also have "\<dots> = (\<Sum>\<^sup>+ y. ?f xi y)" by(simp add: nn_integral_count_space_reindex)
	also have "\<dots> = (\<Sum>\<^sup>+ y. g (xi, y) - h_plus i (xi, y)) * ((d_IN (h_plus i) xi - d_OUT (h_plus i) xi) / (d_OUT g xi - d_OUT (h_plus i) xi))"
	(is "_ = ?integral * ?factor") using True less
	by(simp add: nn_integral_multc nn_integral_divide diff_gr0_ennreal ennreal_times_divide)
	also have "?integral = d_OUT g xi - d_OUT (h_plus i) xi" unfolding d_OUT_def using xi
	by(subst nn_integral_diff)(simp_all add: h_plus_le_g d_OUT_def[symmetric] d_OUT_h_plus_not_infty')
	also have "\<dots> * ?factor = (d_IN (h_plus i) xi - d_OUT (h_plus i) xi)" using xi
	apply (subst ennreal_times_divide)
	apply (subst mult.commute)
	apply (subst ennreal_mult_divide_eq)
	apply (simp_all add: diff_gr0_ennreal finite_OUT_g less zero_less_iff_neq_zero[symmetric])
	done
	also have "\<dots> \<noteq> \<top>" using h_plus_OUT_eq_IN[OF refl, of i, folded xi_def, symmetric] xi
	by(simp add: d_OUT_h_plus_not_infty')
	ultimately show ?thesis using Suc.IH by simp
	qed
	qed

	lemma d_OUT_h_plus_not_infty [simp]: "d_OUT (h_plus i) x \<noteq> top"
	proof -
	have "d_OUT (h_plus i) x \<le> (\<Sum>\<^sup>+ y\<in>UNIV. \<Sum>\<^sup>+ x. h_plus i (x, y))"
	unfolding d_OUT_def by(rule nn_integral_mono nn_integral_ge_point)+ simp
	also have "\<dots> < \<top>" using h_plus_sum_finite by(simp add: nn_integral_snd_count_space less_top)
	finally show ?thesis by simp
	qed

	definition enum_cycle :: "nat \<Rightarrow> 'v path"
	where "enum_cycle = from_nat_into (cycles \<Delta>)"

	lemma cycle_enum_cycle [simp]: "cycles \<Delta> \<noteq> {} \<Longrightarrow> cycle \<Delta> (enum_cycle n)"
	unfolding enum_cycle_def using from_nat_into[of "cycles \<Delta>" n] by simp

	context
	fixes h' :: "'v flow"
	assumes finite_h': "h' e \<noteq> top"
	begin

	fun h_minus_aux :: "nat \<Rightarrow> 'v edge \<Rightarrow> ennreal"
	where
	"h_minus_aux 0 e = 0"
	\| "h_minus_aux (Suc j) e =
	(if e \<in> set (cycle_edges (enum_cycle j)) then
	h_minus_aux j e + Min {h' e' - h_minus_aux j e'\|e'. e'\<in>set (cycle_edges (enum_cycle j))}
	else h_minus_aux j e)"

	lemma h_minus_aux_le_h': "h_minus_aux j e \<le> h' e"
	proof(induction j e rule: h_minus_aux.induct)
	case 0: (1 e) show ?case by simp
	next
	case Suc: (2 j e)
	{ assume e: "e \<in> set (cycle_edges (enum_cycle j))"
	then have "h_minus_aux j e + Min {h' e' - h_minus_aux j e' \|e'. e' \<in> set (cycle_edges (enum_cycle j))} \<le>
	h_minus_aux j e + (h' e - h_minus_aux j e)"
	using [[simproc add: finite_Collect]] by(cases e rule: prod.exhaust)(auto intro!: add_mono Min_le)
	also have "\<dots> = h' e" using e finite_h'[of e] Suc.IH(2)[of e]
	by(cases e rule: prod.exhaust)
	(auto simp add: add_diff_eq_ennreal top_unique intro!: ennreal_add_diff_cancel_left)
	also note calculation }
	then show ?case using Suc by clarsimp
	qed

	lemma h_minus_aux_finite [simp]: "h_minus_aux j e \<noteq> top"
	using h_minus_aux_le_h'[of j e] finite_h'[of e] by (auto simp: top_unique)

	lemma h_minus_aux_mono: "h_minus_aux j e \<le> h_minus_aux (Suc j) e"
	proof(cases "e \<in> set (cycle_edges (enum_cycle j)) = True")
	case True
	have "h_minus_aux j e + 0 \<le> h_minus_aux (Suc j) e" unfolding h_minus_aux.simps True if_True
	using True [[simproc add: finite_Collect]]
	by(cases e)(rule add_mono, auto intro!: Min.boundedI simp add: h_minus_aux_le_h')
	thus ?thesis by simp
	qed simp

	lemma d_OUT_h_minus_aux:
	assumes "cycles \<Delta> \<noteq> {}"
	shows "d_OUT (h_minus_aux j) x = d_IN (h_minus_aux j) x"
	proof(induction j)
	case 0 show ?case by simp
	next
	case (Suc j)
	define C where "C = enum_cycle j"
	define \<delta> where "\<delta> = Min {h' e' - h_minus_aux j e' \|e'. e' \<in> set (cycle_edges C)}"

	have "d_OUT (h_minus_aux (Suc j)) x =
	(\<Sum>\<^sup>+ y. h_minus_aux j (x, y) + (if (x, y) \<in> set (cycle_edges C) then \<delta> else 0))"
	unfolding d_OUT_def by(simp add: if_distrib C_def \<delta>_def cong del: if_weak_cong)
	also have "\<dots> = d_OUT (h_minus_aux j) x + (\<Sum>\<^sup>+ y. \<delta> * indicator (set (cycle_edges C)) (x, y))"
	(is "_ = _ + ?add")
	by(subst nn_integral_add)(auto simp add: AE_count_space d_OUT_def intro!: arg_cong2[where f="(+)"] nn_integral_cong)
	also have "?add = (\<Sum>\<^sup>+ e\<in>range (Pair x). \<delta> * indicator {(x', y). (x', y) \<in> set (cycle_edges C) \<and> x' = x} e)"
	by(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = \<delta> * card (set (filter (\<lambda>(x', y). x' = x) (cycle_edges C)))"
	using [[simproc add: finite_Collect]]
	apply(subst nn_integral_cmult_indicator; auto)
	apply(subst emeasure_count_space; auto simp add: split_def)
	done
	also have "card (set (filter (\<lambda>(x', y). x' = x) (cycle_edges C))) = card (set (filter (\<lambda>(x', y). y = x) (cycle_edges C)))"
	unfolding C_def by(rule cycle_enter_leave_same)(rule cycle_enum_cycle[OF assms])
	also have "\<delta> * \<dots> = (\<Sum>\<^sup>+ e\<in>range (\<lambda>x'. (x', x)). \<delta> * indicator {(x', y). (x', y) \<in> set (cycle_edges C) \<and> y = x} e)"
	using [[simproc add: finite_Collect]]
	apply(subst nn_integral_cmult_indicator; auto)
	apply(subst emeasure_count_space; auto simp add: split_def)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ x'. \<delta> * indicator (set (cycle_edges C)) (x', x))"
	by(auto simp add: nn_integral_count_space_reindex intro!: nn_integral_cong split: split_indicator)
	also have "d_OUT (h_minus_aux j) x + \<dots> = (\<Sum>\<^sup>+ x'. h_minus_aux j (x', x) + \<delta> * indicator (set (cycle_edges C)) (x', x))"
	unfolding Suc.IH d_IN_def by(simp add: nn_integral_add[symmetric])
	also have "\<dots> = d_IN (h_minus_aux (Suc j)) x" unfolding d_IN_def
	by(auto intro!: nn_integral_cong simp add: \<delta>_def C_def split: split_indicator)
	finally show ?case .
	qed

	lemma h_minus_aux_source:
	assumes "cycles \<Delta> \<noteq> {}"
	shows "h_minus_aux j (source \<Delta>, y) = 0"
	proof(induction j)
	case 0 thus ?case by simp
	next
	case (Suc j)
	have "(source \<Delta>, y) \<notin> set (cycle_edges (enum_cycle j))"
	proof
	assume *: "(source \<Delta>, y) \<in> set (cycle_edges (enum_cycle j))"
	have cycle: "cycle \<Delta> (enum_cycle j)" using assms by(rule cycle_enum_cycle)
	from cycle_leave_ex_enter[OF this *]
	obtain z where "(z, source \<Delta>) \<in> set (cycle_edges (enum_cycle j))" ..
	with cycle_edges_edges[OF cycle] have "(z, source \<Delta>) \<in> \<^bold>E" ..
	thus False using source_in[of z] by simp
	qed
	then show ?case using Suc.IH by simp
	qed

	lemma h_minus_aux_cycle:
	fixes j defines "C \<equiv> enum_cycle j"
	assumes "cycles \<Delta> \<noteq> {}"
	shows "\<exists>e\<in>set (cycle_edges C). h_minus_aux (Suc j) e = h' e"
	proof -
	let ?A = "{h' e' - h_minus_aux j e'\|e'. e' \<in> set (cycle_edges C)}"
	from assms have "cycle \<Delta> C" by auto
	from cycle_edges_not_Nil[OF this] have "Min ?A \<in> ?A" using [[simproc add: finite_Collect]]
	by(intro Min_in)(fastforce simp add: neq_Nil_conv)+
	then obtain e' where e: "e' \<in> set (cycle_edges C)"
	and "Min ?A = h' e' - h_minus_aux j e'" by auto
	hence "h_minus_aux (Suc j) e' = h' e'"
	by(simp add: C_def h_minus_aux_le_h')
	with e show ?thesis by blast
	qed

	end

	fun h_minus :: "nat \<Rightarrow> 'v edge \<Rightarrow> ennreal"
	where
	"h_minus 0 e = 0"
	\| "h_minus (Suc i) e = h_minus i e + (SUP j. h_minus_aux (\<lambda>e'. h_plus (Suc i) e' - h_minus i e') j e)"

	lemma h_minus_le_h_plus: "h_minus i e \<le> h_plus i e"
	proof(induction i e rule: h_minus.induct)
	case 0: (1 e) show ?case by simp
	next
	case Suc: (2 i e)
	note IH = Suc.IH(2)[OF UNIV_I]
	let ?h' = "\<lambda>e'. h_plus (Suc i) e' - h_minus i e'"
	- have h': "?h' e' \<noteq> top" for e' using IH(1)[of e'] by(simp add: )
	+ have h': "?h' e' \<noteq> top" for e' using IH(1)[of e'] bysimp

	have "(\<Squnion>j. h_minus_aux ?h' j e) \<le> ?h' e" by(rule SUP_least)(rule h_minus_aux_le_h'[OF h'])
	hence "h_minus (Suc i) e \<le> h_minus i e + \<dots>" by(simp add: add_mono)
	also have "\<dots> = h_plus (Suc i) e" using IH[of e] h_plus_mono[of i e]
	by auto
	finally show ?case .
	qed

	lemma finite_h': "h_plus (Suc i) e - h_minus i e \<noteq> top"
	by simp

	lemma h_minus_mono: "h_minus i e \<le> h_minus (Suc i) e"
	proof -
	have "h_minus i e + 0 \<le> h_minus (Suc i) e" unfolding h_minus.simps
	by(rule add_mono; simp add: SUP_upper2)
	thus ?thesis by simp
	qed

	lemma h_minus_finite [simp]: "h_minus i e \<noteq> \<top>"
	proof -
	have "h_minus i e \<le> h_plus i e" by(rule h_minus_le_h_plus)
	also have "\<dots> < \<top>" by (simp add: less_top[symmetric])
	finally show ?thesis by simp
	qed

	lemma d_OUT_h_minus:
	assumes cycles: "cycles \<Delta> \<noteq> {}"
	shows "d_OUT (h_minus i) x = d_IN (h_minus i) x"
	proof(induction i)
	case (Suc i)
	let ?h' = "\<lambda>e. h_plus (Suc i) e - h_minus i e"
	have "d_OUT (\<lambda>e. h_minus (Suc i) e) x = d_OUT (h_minus i) x + d_OUT (\<lambda>e. SUP j. h_minus_aux ?h' j e) x"
	by(simp add: d_OUT_add SUP_upper2)
	also have "d_OUT (\<lambda>e. SUP j. h_minus_aux ?h' j e) x = (SUP j. d_OUT (h_minus_aux ?h' j) x)"
	by(rule d_OUT_monotone_convergence_SUP incseq_SucI le_funI h_minus_aux_mono finite_h')+
	also have "\<dots> = (SUP j. d_IN (h_minus_aux ?h' j) x)"
	by(rule SUP_cong[OF refl])(rule d_OUT_h_minus_aux[OF finite_h' cycles])
	also have "\<dots> = d_IN (\<lambda>e. SUP j. h_minus_aux ?h' j e) x"
	by(rule d_IN_monotone_convergence_SUP[symmetric] incseq_SucI le_funI h_minus_aux_mono finite_h')+
	also have "d_OUT (h_minus i) x + \<dots> = d_IN (\<lambda>e. h_minus (Suc i) e) x" using Suc.IH
	by(simp add: d_IN_add SUP_upper2)
	finally show ?case .
	qed simp

	lemma h_minus_source:
	assumes "cycles \<Delta> \<noteq> {}"
	shows "h_minus n (source \<Delta>, y) = 0"
	by(induction n)(simp_all add: h_minus_aux_source[OF finite_h' assms])

	lemma h_minus_source_in [simp]: "h_minus i (x, source \<Delta>) = 0"
	using h_minus_le_h_plus[of i "(x, source \<Delta>)"] by simp

	lemma h_minus_OUT_finite [simp]: "d_OUT (h_minus i) x \<noteq> top"
	proof -
	have "d_OUT (h_minus i) x \<le> d_OUT (h_plus i) x" by(rule d_OUT_mono)(rule h_minus_le_h_plus)
	also have "\<dots> < \<top>" by (simp add: less_top[symmetric])
	finally show ?thesis by simp
	qed

	lemma h_minus_cycle:
	assumes "cycle \<Delta> C"
	shows "\<exists>e\<in>set (cycle_edges C). h_minus i e = h_plus i e"
	proof(cases i)
	case (Suc i)
	let ?h' = "\<lambda>e. h_plus (Suc i) e - h_minus i e"
	from assms have cycles: "cycles \<Delta> \<noteq> {}" by auto
	with assms from_nat_into_surj[of "cycles \<Delta>" C] obtain j where j: "C = enum_cycle j"
	by(auto simp add: enum_cycle_def)
	from h_minus_aux_cycle[of "?h'" j, OF finite_h' cycles] j
	obtain e where e: "e \<in> set (cycle_edges C)" and "h_minus_aux ?h' (Suc j) e = ?h' e" by(auto)
	then have "h_plus (Suc i) e = h_minus i e + h_minus_aux ?h' (Suc j) e"
	using order_trans[OF h_minus_le_h_plus h_plus_mono]
	by (subst eq_commute) simp
	also have "\<dots> \<le> h_minus (Suc i) e" unfolding h_minus.simps
	by(intro add_mono SUP_upper; simp)
	finally show ?thesis using e h_minus_le_h_plus[of "Suc i" e] Suc by auto
	next
	case 0
	from cycle_edges_not_Nil[OF assms] obtain x y where e: "(x, y) \<in> set (cycle_edges C)"
	by(fastforce simp add: neq_Nil_conv)
	then have "x \<noteq> source \<Delta>" using assms by(auto dest: source_out_not_cycle)
	hence "h_plus 0 (x, y) = 0" by simp
	with e 0 show ?thesis by(auto simp del: h_plus.simps)
	qed

	abbreviation lim_h_plus :: "'v edge \<Rightarrow> ennreal"
	where "lim_h_plus e \<equiv> SUP n. h_plus n e"

	abbreviation lim_h_minus :: "'v edge \<Rightarrow> ennreal"
	where "lim_h_minus e \<equiv> SUP n. h_minus n e"

	lemma lim_h_plus_le_g: "lim_h_plus e \<le> g e"
	by(rule SUP_least)(rule h_plus_le_g)

	lemma lim_h_plus_finite [simp]: "lim_h_plus e \<noteq> top"
	proof -
	have "lim_h_plus e \<le> g e" by(rule lim_h_plus_le_g)
	also have "\<dots> < top" by (simp add: less_top[symmetric])
	finally show ?thesis unfolding less_top .
	qed

	lemma lim_h_minus_le_lim_h_plus: "lim_h_minus e \<le> lim_h_plus e"
	by(rule SUP_mono)(blast intro: h_minus_le_h_plus)

	lemma lim_h_minus_finite [simp]: "lim_h_minus e \<noteq> top"
	proof -
	have "lim_h_minus e \<le> lim_h_plus e" by(rule lim_h_minus_le_lim_h_plus)
	also have "\<dots> < top" unfolding less_top[symmetric] by (rule lim_h_plus_finite)
	finally show ?thesis unfolding less_top[symmetric] by simp
	qed

	lemma lim_h_minus_IN_finite [simp]:
	assumes "x \<noteq> sink \<Delta>"
	shows "d_IN lim_h_minus x \<noteq> top"
	proof -
	have "d_IN lim_h_minus x \<le> d_IN lim_h_plus x"
	by(intro d_IN_mono le_funI lim_h_minus_le_lim_h_plus)
	also have "\<dots> \<le> d_IN g x" by(intro d_IN_mono le_funI lim_h_plus_le_g)
	also have "\<dots> < \<top>" using assms by(simp add: finite_IN_g less_top[symmetric])
	finally show ?thesis by simp
	qed

	lemma lim_h_plus_OUT_IN:
	assumes "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	shows "d_OUT lim_h_plus x = d_IN lim_h_plus x"
	proof(cases "x \<in> \<^bold>V")
	case True
	have "d_OUT lim_h_plus x = (SUP n. d_OUT (h_plus n) x)"
	by(rule d_OUT_monotone_convergence_SUP incseq_SucI le_funI h_plus_mono)+
	also have "\<dots> = (SUP n. d_IN (h_plus n) x)" (is "?lhs = ?rhs")
	proof(rule antisym)
	show "?lhs \<le> ?rhs" by(rule SUP_mono)(auto intro: h_plus_OUT_le_IN[OF assms(1)])
	show "?rhs \<le> ?lhs"
	proof(rule SUP_mono)
	fix i
	from enum_v_repeat[OF True assms, of i]
	obtain i' where "i' > i" "enum_v i' = x" by auto
	moreover then obtain i'' where i': "i' = Suc i''" by(cases i') auto
	ultimately have "d_OUT (h_plus i') x = d_IN (h_plus i'') x" using \<open>x \<noteq> source \<Delta>\<close>
	by(simp add: h_plus_OUT_eq_IN)
	moreover have "i \<le> i''" using \<open>i < i'\<close> i' by simp
	then have "d_IN (h_plus i) x \<le> d_IN (h_plus i'') x" by(intro d_IN_mono h_plus_mono')
	ultimately have "d_IN (h_plus i) x \<le> d_OUT (h_plus i') x" by simp
	thus "\<exists>i'\<in>UNIV. d_IN (h_plus i) x \<le> d_OUT (h_plus i') x" by blast
	qed
	qed
	also have "\<dots> = d_IN lim_h_plus x"
	by(rule d_IN_monotone_convergence_SUP[symmetric] incseq_SucI le_funI h_plus_mono)+
	finally show ?thesis .
	next
	case False
	have "(x, y) \<notin> support_flow lim_h_plus" for y using False h_plus_outside[of "(x, y)"]
	by(fastforce elim!: support_flow.cases simp add: less_SUP_iff vertex_def)
	moreover have "(y, x) \<notin> support_flow lim_h_plus" for y using False h_plus_outside[of "(y, x)"]
	by(fastforce elim!: support_flow.cases simp add: less_SUP_iff vertex_def)
	ultimately show ?thesis
	by(auto simp add: d_OUT_alt_def2 d_IN_alt_def2 AE_count_space intro!: nn_integral_cong_AE)
	qed

	lemma lim_h_minus_OUT_IN:
	assumes cycles: "cycles \<Delta> \<noteq> {}"
	shows "d_OUT lim_h_minus x = d_IN lim_h_minus x"
	proof -
	have "d_OUT lim_h_minus x = (SUP n. d_OUT (h_minus n) x)"
	by(rule d_OUT_monotone_convergence_SUP incseq_SucI le_funI h_minus_mono)+
	also have "\<dots> = (SUP n. d_IN (h_minus n) x)" using cycles by(simp add: d_OUT_h_minus)
	also have "\<dots> = d_IN lim_h_minus x"
	by(rule d_IN_monotone_convergence_SUP[symmetric] incseq_SucI le_funI h_minus_mono)+
	finally show ?thesis .
	qed

	definition h :: "'v edge \<Rightarrow> ennreal"
	where "h e = lim_h_plus e - (if cycles \<Delta> \<noteq> {} then lim_h_minus e else 0)"

	lemma h_le_lim_h_plus: "h e \<le> lim_h_plus e"
	by (simp add: h_def)

	lemma h_le_g: "h e \<le> g e"
	using h_le_lim_h_plus[of e] lim_h_plus_le_g[of e] by simp

	lemma flow_h: "flow \<Delta> h"
	proof
	fix e
	have "h e \<le> lim_h_plus e" by(rule h_le_lim_h_plus)
	also have "\<dots> \<le> g e" by(rule lim_h_plus_le_g)
	also have "\<dots> \<le> capacity \<Delta> e" using g by(rule flowD_capacity)
	finally show "h e \<le> \<dots>" .
	next
	fix x
	assume "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	then show "KIR h x"
	by (cases "cycles \<Delta> = {}")
	(auto simp add: h_def[abs_def] lim_h_plus_OUT_IN d_OUT_diff d_IN_diff lim_h_minus_le_lim_h_plus lim_h_minus_OUT_IN)
	qed

	lemma value_h_plus: "value_flow \<Delta> (h_plus i) = value_flow \<Delta> g" (is "?lhs = ?rhs")
	proof(rule antisym)
	show "?lhs \<le> ?rhs" by(rule d_OUT_mono)(rule h_plus_le_g)

	have "?rhs \<le> value_flow \<Delta> (h_plus 0)"
	by(auto simp add: d_OUT_def cong: if_cong intro!: nn_integral_mono)
	also have "\<dots> \<le> value_flow \<Delta> (h_plus i)"
	by(rule d_OUT_mono)(rule h_plus_mono'; simp)
	finally show "?rhs \<le> ?lhs" .
	qed

	lemma value_h: "value_flow \<Delta> h = value_flow \<Delta> g" (is "?lhs = ?rhs")
	proof(rule antisym)
	have "?lhs \<le> value_flow \<Delta> lim_h_plus" using ennreal_minus_mono
	by(fastforce simp add: h_def intro!: d_OUT_mono)
	also have "\<dots> \<le> ?rhs" by(rule d_OUT_mono)(rule lim_h_plus_le_g)
	finally show "?lhs \<le> ?rhs" .

	show "?rhs \<le> ?lhs"
	by(auto simp add: d_OUT_def h_def h_minus_source cong: if_cong intro!: nn_integral_mono SUP_upper2[where i=0])
	qed


	definition h_diff :: "nat \<Rightarrow> 'v edge \<Rightarrow> ennreal"
	where "h_diff i e = h_plus i e - (if cycles \<Delta> \<noteq> {} then h_minus i e else 0)"

	lemma d_IN_h_source [simp]: "d_IN (h_diff i) (source \<Delta>) = 0"
	by(simp add: d_IN_def h_diff_def cong del: if_weak_cong)

	lemma h_diff_le_h_plus: "h_diff i e \<le> h_plus i e"
	by(simp add: h_diff_def)

	lemma h_diff_le_g: "h_diff i e \<le> g e"
	using h_diff_le_h_plus[of i e] h_plus_le_g[of i e] by simp

	lemma h_diff_loop [simp]: "h_diff i (x, x) = 0"
	using h_diff_le_g[of i "(x, x)"] by simp

	lemma supp_h_diff_edges: "support_flow (h_diff i) \<subseteq> \<^bold>E"
	proof
	fix e
	assume "e \<in> support_flow (h_diff i)"
	then have "0 < h_diff i e" by(auto elim: support_flow.cases)
	also have "h_diff i e \<le> h_plus i e" by(rule h_diff_le_h_plus)
	finally show "e \<in> \<^bold>E" using h_plus_outside[of e i] by(cases "e \<in> \<^bold>E") auto
	qed

	lemma h_diff_OUT_le_IN:
	assumes "x \<noteq> source \<Delta>"
	shows "d_OUT (h_diff i) x \<le> d_IN (h_diff i) x"
	proof(cases "cycles \<Delta> \<noteq> {}")
	case False
	thus ?thesis using assms by(simp add: h_diff_def[abs_def] h_plus_OUT_le_IN)
	next
	case cycles: True
	then have "d_OUT (h_diff i) x = d_OUT (h_plus i) x - d_OUT (h_minus i) x"
	unfolding h_diff_def[abs_def] using assms
	by (simp add: h_minus_le_h_plus d_OUT_diff)
	also have "\<dots> \<le> d_IN (h_plus i) x - d_IN (h_minus i) x" using cycles assms
	by(intro ennreal_minus_mono h_plus_OUT_le_IN)(simp_all add: d_OUT_h_minus)
	also have "\<dots> = d_IN (h_diff i) x" using cycles
	unfolding h_diff_def[abs_def] by(subst d_IN_diff)(simp_all add: h_minus_le_h_plus d_OUT_h_minus[symmetric])
	finally show ?thesis .
	qed

	lemma h_diff_cycle:
	assumes "cycle \<Delta> p"
	shows "\<exists>e\<in>set (cycle_edges p). h_diff i e = 0"
	proof -
	from h_minus_cycle[OF assms, of i] obtain e
	where e: "e \<in> set (cycle_edges p)" and "h_minus i e = h_plus i e" by auto
	hence "h_diff i e = 0" using assms by(auto simp add: h_diff_def)
	with e show ?thesis by blast
	qed

	lemma d_IN_h_le_value': "d_IN (h_diff i) x \<le> value_flow \<Delta> (h_plus i)"
	proof -
	let ?supp = "support_flow (h_diff i)"
	define X where "X = {y. (y, x) \<in> ?supp^*} - {x}"

	{ fix x y
	assume x: "x \<notin> X" and y: "y \<in> X"
	{ assume yx: "(y, x) \<in> ?supp\<^sup>*" and neq: "y \<noteq> x" and xy: "(x, y) \<in> ?supp"
	from yx obtain p' where "rtrancl_path (\<lambda>x y. (x, y) \<in> ?supp) y p' x"
	unfolding rtrancl_def rtranclp_eq_rtrancl_path by auto
	then obtain p where p: "rtrancl_path (\<lambda>x y. (x, y) \<in> ?supp) y p x"
	and distinct: "distinct (y # p)" by(rule rtrancl_path_distinct)
	with neq have "p \<noteq> []" by(auto elim: rtrancl_path.cases)

	from xy have "(x, y) \<in> \<^bold>E" using supp_h_diff_edges[of i] by(auto)
	moreover from p have "path \<Delta> y p x"
	by(rule rtrancl_path_mono)(auto dest: supp_h_diff_edges[THEN subsetD])
	ultimately have "path \<Delta> x (y # p) x" by(auto intro: rtrancl_path.intros)
	hence cycle: "cycle \<Delta> (y # p)" using _ distinct by(rule cycle) simp
	from h_diff_cycle[OF this, of i] obtain e
	where e: "e \<in> set (cycle_edges (y # p))" and 0: "h_diff i e = 0" by blast
	from e obtain n where e': "e = ((y # p) ! n, (p @ [y]) ! n)" and n: "n < Suc (length p)"
	by(auto simp add: cycle_edges_def set_zip)
	have "e \<in> ?supp"
	proof(cases "n = length p")
	case True
	with rtrancl_path_last[OF p] \<open>p \<noteq> []\<close> have "(y # p) ! n = x"
	by(cases p)(simp_all add: last_conv_nth del: last.simps)
	with e' True have "e = (x, y)" by simp
	with xy show ?thesis by simp
	next
	case False
	with n have "n < length p" by simp
	with rtrancl_path_nth[OF p this] e' show ?thesis by(simp add: nth_append)
	qed
	with 0 have False by(simp add: support_flow.simps) }
	hence "(x, y) \<notin> ?supp" using x y
	by(auto simp add: X_def intro: converse_rtrancl_into_rtrancl)
	then have "h_diff i (x, y) = 0"
	by(simp add: support_flow.simps) }
	note acyclic = this

	{ fix y
	assume "y \<notin> X"
	hence "(y, x) \<notin> ?supp" by(auto simp add: X_def support_flow.simps intro: not_in_support_flowD)
	hence "h_diff i (y, x) = 0" by(simp add: support_flow.simps) }
	note in_X = this

	let ?diff = "\<lambda>x. (\<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x * indicator X y)"
	have finite2: "(\<Sum>\<^sup>+ x. ?diff x) \<noteq> top" (is "?lhs \<noteq> _")
	proof -
	have "?lhs \<le> (\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_plus i (x, y))"
	by(intro nn_integral_mono)(auto simp add: h_diff_def split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ e. h_plus i e)" by(rule nn_integral_fst_count_space)
	also have "\<dots> < \<top>" by(simp add: h_plus_sum_finite less_top[symmetric])
	finally show ?thesis by simp
	qed
	have finite1: "?diff x \<noteq> top" for x
	using finite2 by(rule neq_top_trans)(rule nn_integral_ge_point, simp)
	have finite3: "(\<Sum>\<^sup>+ x. d_OUT (h_diff i) x * indicator (X - {source \<Delta>}) x) \<noteq> \<top>" (is "?lhs \<noteq> _")
	proof -
	have "?lhs \<le> (\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_plus i (x, y))" unfolding d_OUT_def
	apply(simp add: nn_integral_multc[symmetric])
	apply(intro nn_integral_mono)
	apply(auto simp add: h_diff_def split: split_indicator)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ e. h_plus i e)" by(rule nn_integral_fst_count_space)
	also have "\<dots> < \<top>" by(simp add: h_plus_sum_finite less_top[symmetric])
	finally show ?thesis by simp
	qed

	have "d_IN (h_diff i) x = (\<Sum>\<^sup>+ y. h_diff i (y, x) * indicator X y)" unfolding d_IN_def
	by(rule nn_integral_cong)(simp add: in_X split: split_indicator)
	also have "\<dots> \<le> (\<Sum>\<^sup>+ x\<in>- X. \<Sum>\<^sup>+ y. h_diff i (y, x) * indicator X y)"
	by(rule nn_integral_ge_point)(simp add: X_def)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_diff i (y, x) * indicator X y * indicator (- X) x)"
	by(simp add: nn_integral_multc nn_integral_count_space_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x * indicator (- X) y)"
	by(subst nn_integral_snd_count_space[where f="case_prod _", simplified])(simp add: nn_integral_fst_count_space[where f="case_prod _", simplified])
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. (\<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x * indicator (- X) y) + (?diff x - ?diff x))"
	by(simp add: finite1)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. (\<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x * indicator (- X) y + h_diff i (x, y) * indicator X x * indicator X y) - ?diff x)"
	apply (subst add_diff_eq_ennreal)
	apply simp
	by(subst nn_integral_add[symmetric])(simp_all add:)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. (\<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x) - ?diff x)"
	by(auto intro!: nn_integral_cong arg_cong2[where f="(-)"] split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y\<in>UNIV. h_diff i (x, y) * indicator X x) - (\<Sum>\<^sup>+ x. ?diff x)"
	by(subst nn_integral_diff)(auto simp add: AE_count_space finite2 intro!: nn_integral_mono split: split_indicator)
	also have "(\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y\<in>UNIV. h_diff i (x, y) * indicator X x) = (\<Sum>\<^sup>+ x. d_OUT (h_diff i) x * indicator X x)"
	unfolding d_OUT_def by(simp add: nn_integral_multc)
	also have "\<dots> = (\<Sum>\<^sup>+ x. d_OUT (h_diff i) x * indicator (X - {source \<Delta>}) x + value_flow \<Delta> (h_diff i) * indicator X (source \<Delta>) * indicator {source \<Delta>} x)"
	by(rule nn_integral_cong)(simp split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ x. d_OUT (h_diff i) x * indicator (X - {source \<Delta>}) x) + value_flow \<Delta> (h_diff i) * indicator X (source \<Delta>)"
	(is "_ = ?out" is "_ = _ + ?value")
	by(subst nn_integral_add) simp_all
	also have "(\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X x * indicator X y) =
	(\<Sum>\<^sup>+ x\<in>UNIV. \<Sum>\<^sup>+ y. h_diff i (x, y) * indicator X y)"
	using acyclic by(intro nn_integral_cong)(simp split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>UNIV. \<Sum>\<^sup>+ x. h_diff i (x, y) * indicator X y)"
	by(subst nn_integral_snd_count_space[where f="case_prod _", simplified])(simp add: nn_integral_fst_count_space[where f="case_prod _", simplified])
	also have "\<dots> = (\<Sum>\<^sup>+ y. d_IN (h_diff i) y * indicator X y)" unfolding d_IN_def
	by(simp add: nn_integral_multc)
	also have "\<dots> = (\<Sum>\<^sup>+ y. d_IN (h_diff i) y * indicator (X - {source \<Delta>}) y)"
	by(rule nn_integral_cong)(simp split: split_indicator)
	also have "?out - \<dots> \<le> (\<Sum>\<^sup>+ x. d_OUT (h_diff i) x * indicator (X - {source \<Delta>}) x) - \<dots> + ?value"
	by (auto simp add: add_ac intro!: add_diff_le_ennreal)
	also have "\<dots> \<le> 0 + ?value" using h_diff_OUT_le_IN finite3
	by(intro nn_integral_mono add_right_mono)(auto split: split_indicator intro!: diff_eq_0_ennreal nn_integral_mono simp add: less_top)
	also have "\<dots> \<le> value_flow \<Delta> (h_diff i)" by(simp split: split_indicator)
	also have "\<dots> \<le> value_flow \<Delta> (h_plus i)" by(rule d_OUT_mono le_funI h_diff_le_h_plus)+
	finally show ?thesis .
	qed

	lemma d_IN_h_le_value: "d_IN h x \<le> value_flow \<Delta> h" (is "?lhs \<le> ?rhs")
	proof -
	have [tendsto_intros]: "(\<lambda>i. h_plus i e) \<longlonglongrightarrow> lim_h_plus e" for e
	by(rule LIMSEQ_SUP incseq_SucI h_plus_mono)+
	have [tendsto_intros]: "(\<lambda>i. h_minus i e) \<longlonglongrightarrow> lim_h_minus e" for e
	by(rule LIMSEQ_SUP incseq_SucI h_minus_mono)+
	have "(\<lambda>i. h_diff i e) \<longlonglongrightarrow> lim_h_plus e - (if cycles \<Delta> \<noteq> {} then lim_h_minus e else 0)" for e
	by(auto intro!: tendsto_intros tendsto_diff_ennreal simp add: h_diff_def simp del: Sup_eq_top_iff SUP_eq_top_iff)
	then have "d_IN h x = (\<Sum>\<^sup>+ y. liminf (\<lambda>i. h_diff i (y, x)))"
	by(simp add: d_IN_def h_def tendsto_iff_Liminf_eq_Limsup)
	also have "\<dots> \<le> liminf (\<lambda>i. d_IN (h_diff i) x)" unfolding d_IN_def
	by(rule nn_integral_liminf) simp_all
	also have "\<dots> \<le> liminf (\<lambda>i. value_flow \<Delta> h)" using d_IN_h_le_value'[of _ x]
	by(intro Liminf_mono eventually_sequentiallyI)(auto simp add: value_h_plus value_h)
	also have "\<dots> = value_flow \<Delta> h" by(simp add: Liminf_const)
	finally show ?thesis .
	qed

	lemma flow_cleanup: \<comment> \<open>Lemma 5.4\<close>
	"\<exists>h \<le> g. flow \<Delta> h \<and> value_flow \<Delta> h = value_flow \<Delta> g \<and> (\<forall>x. d_IN h x \<le> value_flow \<Delta> h)"
	by(intro exI[where x=h] conjI strip le_funI d_IN_h_le_value flow_h value_h h_le_g)

	end

	subsection \<open>Residual network\<close>

	context countable_network begin

	definition residual_network :: "'v flow \<Rightarrow> ('v, 'more) network_scheme"
	where "residual_network f =
	\<lparr>edge = \<lambda>x y. edge \<Delta> x y \<or> edge \<Delta> y x \<and> y \<noteq> source \<Delta>,
	capacity = \<lambda>(x, y). if edge \<Delta> x y then capacity \<Delta> (x, y) - f (x, y) else if y = source \<Delta> then 0 else f (y, x),
	source = source \<Delta>, sink = sink \<Delta>, \<dots> = network.more \<Delta> \<rparr>"

	lemma residual_network_sel [simp]:
	"edge (residual_network f) x y \<longleftrightarrow> edge \<Delta> x y \<or> edge \<Delta> y x \<and> y \<noteq> source \<Delta>"
	"capacity (residual_network f) (x, y) = (if edge \<Delta> x y then capacity \<Delta> (x, y) - f (x, y) else if y = source \<Delta> then 0 else f (y, x))"
	"source (residual_network f) = source \<Delta>"
	"sink (residual_network f) = sink \<Delta>"
	"network.more (residual_network f) = network.more \<Delta>"
	by(simp_all add: residual_network_def)

	lemma "\<^bold>E_residual_network": "\<^bold>E\<^bsub>residual_network f\<^esub> = \<^bold>E \<union> {(x, y). (y, x) \<in> \<^bold>E \<and> y \<noteq> source \<Delta>}"
	by auto

	lemma vertices_residual_network [simp]: "vertex (residual_network f) = vertex \<Delta>"
	by(auto simp add: vertex_def fun_eq_iff)

	inductive wf_residual_network :: "bool"
	where "\<lbrakk> \<And>x y. (x, y) \<in> \<^bold>E \<Longrightarrow> (y, x) \<notin> \<^bold>E; (source \<Delta>, sink \<Delta>) \<notin> \<^bold>E \<rbrakk> \<Longrightarrow> wf_residual_network"

	lemma wf_residual_networkD:
	"\<lbrakk> wf_residual_network; edge \<Delta> x y \<rbrakk> \<Longrightarrow> \<not> edge \<Delta> y x"
	"\<lbrakk> wf_residual_network; e \<in> \<^bold>E \<rbrakk> \<Longrightarrow> prod.swap e \<notin> \<^bold>E"
	"\<lbrakk> wf_residual_network; edge \<Delta> (source \<Delta>) (sink \<Delta>) \<rbrakk> \<Longrightarrow> False"
	by(auto simp add: wf_residual_network.simps)

	lemma residual_countable_network:
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	shows "countable_network (residual_network f)" (is "countable_network ?\<Delta>")
	proof
	have "countable (converse \<^bold>E)" by simp
	then have "countable {(x, y). (y, x) \<in> \<^bold>E \<and> y \<noteq> source \<Delta>}"
	by(rule countable_subset[rotated]) auto
	then show "countable \<^bold>E\<^bsub>?\<Delta>\<^esub>" unfolding "\<^bold>E_residual_network" by simp

	show "source ?\<Delta> \<noteq> sink ?\<Delta>" by simp
	show "capacity ?\<Delta> e = 0" if "e \<notin> \<^bold>E\<^bsub>?\<Delta>\<^esub>" for e using that by(cases e)(auto intro: flowD_outside[OF f])
	show "capacity ?\<Delta> e \<noteq> top" for e
	using flowD_finite[OF f] by(cases e) auto
	qed

	end

	context antiparallel_edges begin

	interpretation \<Delta>'': countable_network \<Delta>'' by(rule \<Delta>''_countable_network)

	lemma \<Delta>''_flow_attainability:
	assumes "flow_attainability_axioms \<Delta>"
	shows "flow_attainability \<Delta>''"
	proof -
	interpret flow_attainability \<Delta> using _ assms by(rule flow_attainability.intro) unfold_locales
	show ?thesis
	proof
	show "d_IN (capacity \<Delta>'') v \<noteq> \<top> \<or> d_OUT (capacity \<Delta>'') v \<noteq> \<top>" if "v \<noteq> sink \<Delta>''" for v
	using that finite_capacity by(cases v)(simp_all add: max_def)
	show "\<not> edge \<Delta>'' v v" for v by(auto elim: edg.cases)
	show "\<not> edge \<Delta>'' v (source \<Delta>'')" for v by(simp add: source_in)
	qed
	qed

	lemma \<Delta>''_wf_residual_network:
	assumes no_loop: "\<And>x. \<not> edge \<Delta> x x"
	shows "\<Delta>''.wf_residual_network"
	by(auto simp add: \<Delta>''.wf_residual_network.simps assms elim!: edg.cases)

	end

	subsection \<open>The attainability theorem\<close>

	context flow_attainability begin

	lemma residual_flow_attainability:
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	shows "flow_attainability (residual_network f)" (is "flow_attainability ?\<Delta>")
	proof -
	interpret res: countable_network "residual_network f" by(rule residual_countable_network[OF assms])
	show ?thesis
	proof
	fix x
	assume sink: "x \<noteq> sink ?\<Delta>"
	then consider (source) "x = source \<Delta>" \| (IN) "d_IN (capacity \<Delta>) x \<noteq> \<top>" \| (OUT) "x \<noteq> source \<Delta>" "d_OUT (capacity \<Delta>) x \<noteq> \<top>"
	using finite_capacity[of x] by auto
	then show "d_IN (capacity ?\<Delta>) x \<noteq> \<top> \<or> d_OUT (capacity ?\<Delta>) x \<noteq> \<top>"
	proof(cases)
	case source
	hence "d_IN (capacity ?\<Delta>) x = 0" by(simp add: d_IN_def source_in)
	thus ?thesis by simp
	next
	case IN
	have "d_IN (capacity ?\<Delta>) x =
	(\<Sum>\<^sup>+ y. (capacity \<Delta> (y, x) - f (y, x)) * indicator \<^bold>E (y, x) +
	(if x = source \<Delta> then 0 else f (x, y) * indicator \<^bold>E (x, y)))"
	using flowD_outside[OF f] unfolding d_IN_def
	by(auto intro!: nn_integral_cong split: split_indicator dest: wf_residual_networkD[OF wf])
	also have "\<dots> = (\<Sum>\<^sup>+ y. (capacity \<Delta> (y, x) - f (y, x)) * indicator \<^bold>E (y, x)) +
	(\<Sum>\<^sup>+ y. (if x = source \<Delta> then 0 else f (x, y) * indicator \<^bold>E (x, y)))"
	(is "_ = ?in + ?out")
	by(subst nn_integral_add)(auto simp add: AE_count_space split: split_indicator intro!: flowD_capacity[OF f])
	also have "\<dots> \<le> d_IN (capacity \<Delta>) x + (if x = source \<Delta> then 0 else d_OUT f x)" (is "_ \<le> ?in + ?rest")
	unfolding d_IN_def d_OUT_def
	by(rule add_mono)(auto intro!: nn_integral_mono split: split_indicator simp add: nn_integral_0_iff_AE AE_count_space intro!: diff_le_self_ennreal)
	also consider (source) "x = source \<Delta>" \| (inner) "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" using sink by auto
	then have "?rest < \<top>"
	proof cases
	case inner
	show ?thesis using inner flowD_finite_OUT[OF f inner] by (simp add: less_top)
	qed simp
	ultimately show ?thesis using IN sink by (auto simp: less_top[symmetric] top_unique)
	next
	case OUT
	have "d_OUT (capacity ?\<Delta>) x =
	(\<Sum>\<^sup>+ y. (capacity \<Delta> (x, y) - f (x, y)) * indicator \<^bold>E (x, y) +
	(if y = source \<Delta> then 0 else f (y, x) * indicator \<^bold>E (y, x)))"
	using flowD_outside[OF f] unfolding d_OUT_def
	by(auto intro!: nn_integral_cong split: split_indicator dest: wf_residual_networkD[OF wf] simp add: source_in)
	also have "\<dots> = (\<Sum>\<^sup>+ y. (capacity \<Delta> (x, y) - f (x, y)) * indicator \<^bold>E (x, y)) +
	(\<Sum>\<^sup>+ y. (if y = source \<Delta> then 0 else f (y, x) * indicator \<^bold>E (y, x)))"
	(is "_ = ?in + ?out")
	by(subst nn_integral_add)(auto simp add: AE_count_space split: split_indicator intro!: flowD_capacity[OF f])
	also have "\<dots> \<le> d_OUT (capacity \<Delta>) x + d_IN f x" (is "_ \<le> ?out + ?rest")
	unfolding d_IN_def d_OUT_def
	by(rule add_mono)(auto intro!: nn_integral_mono split: split_indicator simp add: nn_integral_0_iff_AE AE_count_space intro!: diff_le_self_ennreal)
	also have "?rest = d_OUT f x" using flowD_KIR[OF f OUT(1)] sink by simp
	also have "?out + \<dots> \<le> ?out + ?out" by(intro add_left_mono d_OUT_mono flowD_capacity[OF f])
	finally show ?thesis using OUT by (auto simp: top_unique)
	qed
	next
	show "\<not> edge ?\<Delta> x x" for x by(simp add: no_loop)
	show "\<not> edge ?\<Delta> x (source ?\<Delta>)" for x by(simp add: source_in)
	qed
	qed

	end

	definition plus_flow :: "('v, 'more) graph_scheme \<Rightarrow> 'v flow \<Rightarrow> 'v flow \<Rightarrow> 'v flow" (infixr "\<oplus>\<index>" 65)
	where "plus_flow G f g = (\<lambda>(x, y). if edge G x y then f (x, y) + g (x, y) - g (y, x) else 0)"

	lemma plus_flow_simps [simp]: fixes G (structure) shows
	"(f \<oplus> g) (x, y) = (if edge G x y then f (x, y) + g (x, y) - g (y, x) else 0)"
	by(simp add: plus_flow_def)

	lemma plus_flow_outside: fixes G (structure) shows "e \<notin> \<^bold>E \<Longrightarrow> (f \<oplus> g) e = 0"
	by(cases e) simp

	lemma
	fixes \<Delta> (structure)
	assumes f_outside: "\<And>e. e \<notin> \<^bold>E \<Longrightarrow> f e = 0"
	and g_le_f: "\<And>x y. edge \<Delta> x y \<Longrightarrow> g (y, x) \<le> f (x, y)"
	shows OUT_plus_flow: "d_IN g x \<noteq> top \<Longrightarrow> d_OUT (f \<oplus> g) x = d_OUT f x + (\<Sum>\<^sup>+ y\<in>UNIV. g (x, y) * indicator \<^bold>E (x, y)) - (\<Sum>\<^sup>+ y. g (y, x) * indicator \<^bold>E (x, y))"
	(is "_ \<Longrightarrow> ?OUT" is "_ \<Longrightarrow> _ = _ + ?g_out - ?g_out'")
	and IN_plus_flow: "d_OUT g x \<noteq> top \<Longrightarrow> d_IN (f \<oplus> g) x = d_IN f x + (\<Sum>\<^sup>+ y\<in>UNIV. g (y, x) * indicator \<^bold>E (y, x)) - (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (y, x))"
	(is "_ \<Longrightarrow> ?IN" is "_ \<Longrightarrow> _ = _ + ?g_in - ?g_in'")
	proof -
	assume "d_IN g x \<noteq> top"
	then have finite1: "(\<Sum>\<^sup>+ y. g (y, x) * indicator A (f y)) \<noteq> top" for A f
	by(rule neq_top_trans)(auto split: split_indicator simp add: d_IN_def intro!: nn_integral_mono)

	have "d_OUT (f \<oplus> g) x = (\<Sum>\<^sup>+ y. (g (x, y) + (f (x, y) - g (y, x))) * indicator \<^bold>E (x, y))"
	unfolding d_OUT_def by(rule nn_integral_cong)(simp split: split_indicator add: add_diff_eq_ennreal add.commute ennreal_diff_add_assoc g_le_f)
	also have "\<dots> = ?g_out + (\<Sum>\<^sup>+ y. (f (x, y) - g (y, x)) * indicator \<^bold>E (x, y))"
	(is "_ = _ + ?rest")
	by(subst nn_integral_add[symmetric])(auto simp add: AE_count_space g_le_f split: split_indicator intro!: nn_integral_cong)
	also have "?rest = (\<Sum>\<^sup>+ y. f (x, y) * indicator \<^bold>E (x, y)) - ?g_out'" (is "_ = ?f - _")
	apply(subst nn_integral_diff[symmetric])
	apply(auto intro!: nn_integral_cong split: split_indicator simp add: AE_count_space g_le_f finite1)
	done
	also have "?f = d_OUT f x" unfolding d_OUT_def using f_outside
	by(auto intro!: nn_integral_cong split: split_indicator)
	also have "(\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (x, y)) + (d_OUT f x - (\<Sum>\<^sup>+ y. g (y, x) * indicator \<^bold>E (x, y))) =
	d_OUT f x + ?g_out - ?g_out'"
	by (subst ennreal_diff_add_assoc[symmetric])
	(auto simp: ac_simps d_OUT_def intro!: nn_integral_mono g_le_f split: split_indicator)
	finally show ?OUT .
	next
	assume "d_OUT g x \<noteq> top"
	then have finite2: "(\<Sum>\<^sup>+ y. g (x, y) * indicator A (f y)) \<noteq> top" for A f
	by(rule neq_top_trans)(auto split: split_indicator simp add: d_OUT_def intro!: nn_integral_mono)

	have "d_IN (f \<oplus> g) x = (\<Sum>\<^sup>+ y. (g (y, x) + (f (y, x) - g (x, y))) * indicator \<^bold>E (y, x))"
	unfolding d_IN_def by(rule nn_integral_cong)(simp split: split_indicator add: add_diff_eq_ennreal add.commute ennreal_diff_add_assoc g_le_f)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>UNIV. g (y, x) * indicator \<^bold>E (y, x)) + (\<Sum>\<^sup>+ y. (f (y, x) - g (x, y)) * indicator \<^bold>E (y, x))"
	(is "_ = _ + ?rest")
	by(subst nn_integral_add[symmetric])(auto simp add: AE_count_space g_le_f split: split_indicator intro!: nn_integral_cong)
	also have "?rest = (\<Sum>\<^sup>+ y. f (y, x) * indicator \<^bold>E (y, x))- ?g_in'"
	by(subst nn_integral_diff[symmetric])(auto intro!: nn_integral_cong split: split_indicator simp add: add_ac add_diff_eq_ennreal AE_count_space g_le_f finite2)
	also have "(\<Sum>\<^sup>+ y. f (y, x) * indicator \<^bold>E (y, x)) = d_IN f x"
	unfolding d_IN_def using f_outside by(auto intro!: nn_integral_cong split: split_indicator)
	also have "(\<Sum>\<^sup>+ y. g (y, x) * indicator \<^bold>E (y, x)) + (d_IN f x - (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (y, x))) =
	d_IN f x + ?g_in - ?g_in'"
	by (subst ennreal_diff_add_assoc[symmetric])
	(auto simp: ac_simps d_IN_def intro!: nn_integral_mono g_le_f split: split_indicator)
	finally show ?IN .
	qed

	context countable_network begin

	lemma d_IN_plus_flow:
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	and g: "flow (residual_network f) g"
	shows "d_IN (f \<oplus> g) x \<le> d_IN f x + d_IN g x"
	proof -
	have "d_IN (f \<oplus> g) x \<le> (\<Sum>\<^sup>+ y. f (y, x) + g (y, x))" unfolding d_IN_def
	by(rule nn_integral_mono)(auto intro: diff_le_self_ennreal)
	also have "\<dots> = d_IN f x + d_IN g x"
	by(subst nn_integral_add)(simp_all add: d_IN_def)
	finally show ?thesis .
	qed

	lemma scale_flow:
	assumes f: "flow \<Delta> f"
	and c: "c \<le> 1"
	shows "flow \<Delta> (\<lambda>e. c * f e)"
	proof(intro flow.intros)
	fix e
	from c have "c * f e \<le> 1 * f e" by(rule mult_right_mono) simp
	also have "\<dots> \<le> capacity \<Delta> e" using flowD_capacity[OF f, of e] by simp
	finally show "c * f e \<le> \<dots>" .
	next
	fix x
	assume x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	have "d_OUT (\<lambda>e. c * f e) x = c * d_OUT f x" by(simp add: d_OUT_cmult)
	also have "d_OUT f x = d_IN f x" using f x by(rule flowD_KIR)
	also have "c * \<dots> = d_IN (\<lambda>e. c * f e) x" by(simp add: d_IN_cmult)
	finally show "KIR (\<lambda>e. c * f e) x" .
	qed

	lemma value_scale_flow:
	"value_flow \<Delta> (\<lambda>e. c * f e) = c * value_flow \<Delta> f"
	by(rule d_OUT_cmult)

	lemma value_flow:
	assumes f: "flow \<Delta> f"
	and source_out: "\<And>y. edge \<Delta> (source \<Delta>) y \<longleftrightarrow> y = x"
	shows "value_flow \<Delta> f = f (source \<Delta>, x)"
	proof -
	have "value_flow \<Delta> f = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T (source \<Delta>). f (source \<Delta>, y))"
	by(rule d_OUT_alt_def)(simp add: flowD_outside[OF f])
	also have "\<dots> = (\<Sum>\<^sup>+ y. f (source \<Delta>, y) * indicator {x} y)"
	by(subst nn_integral_count_space_indicator)(auto intro!: nn_integral_cong split: split_indicator simp add: outgoing_def source_out)
	also have "\<dots> = f (source \<Delta>, x)" by(simp add: one_ennreal_def[symmetric] max_def)
	finally show ?thesis .
	qed

	end

	context flow_attainability begin

	lemma value_plus_flow:
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	and g: "flow (residual_network f) g"
	shows "value_flow \<Delta> (f \<oplus> g) = value_flow \<Delta> f + value_flow \<Delta> g"
	proof -
	interpret RES: countable_network "residual_network f" using wf f by(rule residual_countable_network)
	have "value_flow \<Delta> (f \<oplus> g) = (\<Sum>\<^sup>+ y. f (source \<Delta>, y) + g (source \<Delta>, y))"
	unfolding d_OUT_def by(rule nn_integral_cong)(simp add: flowD_outside[OF f] RES.flowD_outside[OF g] source_in)
	also have "\<dots> = value_flow \<Delta> f + value_flow \<Delta> g" unfolding d_OUT_def
	by(rule nn_integral_add) simp_all
	finally show ?thesis .
	qed

	lemma flow_residual_add: \<comment> \<open>Lemma 5.3\<close>
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	and g: "flow (residual_network f) g"
	shows "flow \<Delta> (f \<oplus> g)"
	proof
	fix e
	{ assume e: "e \<in> \<^bold>E"
	hence "(f \<oplus> g) e = f e + g e - g (prod.swap e)" by(cases e) simp
	also have "\<dots> \<le> f e + g e - 0" by(rule ennreal_minus_mono) simp_all
	also have "\<dots> \<le> f e + (capacity \<Delta> e - f e)"
	using e flowD_capacity[OF g, of e] by(simp split: prod.split_asm add: add_mono)
	also have "\<dots> = capacity \<Delta> e" using flowD_capacity[OF f, of e]
	by simp
	also note calculation }
	thus "(f \<oplus> g) e \<le> capacity \<Delta> e" by(cases e) auto
	next
	fix x
	assume x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	have g_le_f: "g (y, x) \<le> f (x, y)" if "edge \<Delta> x y" for x y
	using that flowD_capacity[OF g, of "(y, x)"]
	by(auto split: if_split_asm dest: wf_residual_networkD[OF wf] elim: order_trans)

	interpret RES: flow_attainability "residual_network f" using wf f by(rule residual_flow_attainability)

	have finite1: "(\<Sum>\<^sup>+ y. g (y, x) * indicator A (f y)) \<noteq> \<top>" for A f
	using RES.flowD_finite_IN[OF g, of x]
	by(rule neq_top_trans)(auto simp add: x d_IN_def split: split_indicator intro: nn_integral_mono)
	have finite2: "(\<Sum>\<^sup>+ y. g (x, y) * indicator A (f y)) \<noteq> \<top>" for A f
	using RES.flowD_finite_OUT[OF g, of x]
	by(rule neq_top_trans)(auto simp add: x d_OUT_def split: split_indicator intro: nn_integral_mono)

	have "d_OUT (f \<oplus> g) x = d_OUT f x + (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (x, y)) - (\<Sum>\<^sup>+ y. g (y, x) * indicator \<^bold>E (x, y))"
	(is "_ = ?f + ?g_out - ?g_in")
	using flowD_outside[OF f] g_le_f RES.flowD_finite_IN[OF g, of x]
	by(rule OUT_plus_flow)(simp_all add: x)
	also have "?f = d_IN f x" using f x by(auto dest: flowD_KIR)
	also have "?g_out = (\<Sum>\<^sup>+ y. g (x, y) * indicator (- \<^bold>E) (y, x))"
	proof -
	have "(\<Sum>\<^sup>+ y. g (x, y) * indicator (- \<^bold>E) (y, x)) =
	(\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (x, y)) + (\<Sum>\<^sup>+ y. g (x, y) * indicator (- \<^bold>E) (x, y) * indicator (- \<^bold>E) (y, x))"
	by(subst nn_integral_add[symmetric])(auto simp add: AE_count_space dest: wf_residual_networkD[OF wf] split: split_indicator intro!: nn_integral_cong)
	also have "(\<Sum>\<^sup>+ y. g (x, y) * indicator (- \<^bold>E) (x, y) * indicator (- \<^bold>E) (y, x)) = 0"
	using RES.flowD_outside[OF g]
	by(auto simp add: nn_integral_0_iff_AE AE_count_space split: split_indicator)
	finally show ?thesis by simp
	qed
	also have "\<dots> = (\<Sum>\<^sup>+ y. g (x, y) - g (x, y) * indicator \<^bold>E (y, x))"
	by(rule nn_integral_cong)(simp split: split_indicator add: RES.flowD_finite[OF g])
	also have "\<dots> = d_OUT g x - (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (y, x))"
	(is "_ = _ - ?g_in_E") unfolding d_OUT_def
	by(subst nn_integral_diff)(simp_all add: AE_count_space finite2 split: split_indicator)
	also have "d_IN f x + (d_OUT g x - (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (y, x))) - ?g_in =
	((d_IN f x + d_OUT g x) - (\<Sum>\<^sup>+ y. g (x, y) * indicator \<^bold>E (y, x))) - ?g_in"
	by (subst add_diff_eq_ennreal) (auto simp: d_OUT_def intro!: nn_integral_mono split: split_indicator)
	also have "d_OUT g x = d_IN g x" using x g by(auto dest: flowD_KIR)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>UNIV. g (y, x) * indicator (- \<^bold>E) (y, x)) + (\<Sum>\<^sup>+ y. g (y, x) * indicator \<^bold>E (y, x))"
	(is "_ = ?x + ?g_in_E'")
	by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong simp add: d_IN_def AE_count_space split: split_indicator)
	also have "?x = ?g_in"
	proof -
	have "?x = (\<Sum>\<^sup>+ y. g (y, x) * indicator (- \<^bold>E) (x, y) * indicator (- \<^bold>E) (y, x)) + ?g_in"
	by(subst nn_integral_add[symmetric])(auto simp add: AE_count_space dest: wf_residual_networkD[OF wf] split: split_indicator intro!: nn_integral_cong)
	also have "(\<Sum>\<^sup>+ y. g (y, x) * indicator (- \<^bold>E) (x, y) * indicator (- \<^bold>E) (y, x)) = 0"
	using RES.flowD_outside[OF g]
	by(auto simp add: nn_integral_0_iff_AE AE_count_space split: split_indicator)
	finally show ?thesis by simp
	qed
	also have "(d_IN f x + (?g_in + ?g_in_E') - ?g_in_E) - ?g_in =
	d_IN f x + ?g_in_E' + ?g_in - ?g_in - ?g_in_E"
	by (subst diff_diff_commute_ennreal) (simp add: ac_simps)
	also have "\<dots> = d_IN f x + ?g_in_E' - ?g_in_E"
	by (subst ennreal_add_diff_cancel_right) (simp_all add: finite1)
	also have "\<dots> = d_IN (f \<oplus> g) x"
	using flowD_outside[OF f] g_le_f RES.flowD_finite_OUT[OF g, of x]
	by(rule IN_plus_flow[symmetric])(simp_all add: x)
	finally show "KIR (f \<oplus> g) x" by simp
	qed

	definition minus_flow :: "'v flow \<Rightarrow> 'v flow \<Rightarrow> 'v flow" (infixl "\<ominus>" 65)
	where
	"f \<ominus> g = (\<lambda>(x, y). if edge \<Delta> x y then f (x, y) - g (x, y) else if edge \<Delta> y x then g (y, x) - f (y, x) else 0)"

	lemma minus_flow_simps [simp]:
	"(f \<ominus> g) (x, y) = (if edge \<Delta> x y then f (x, y) - g (x, y) else if edge \<Delta> y x then g (y, x) - f (y, x) else 0)"
	by(simp add: minus_flow_def)

	lemma minus_flow:
	assumes wf: "wf_residual_network"
	and f: "flow \<Delta> f"
	and g: "flow \<Delta> g"
	and value_le: "value_flow \<Delta> g \<le> value_flow \<Delta> f"
	and f_finite: "f (source \<Delta>, x) \<noteq> \<top>"
	and source_out: "\<And>y. edge \<Delta> (source \<Delta>) y \<longleftrightarrow> y = x"
	shows "flow (residual_network g) (f \<ominus> g)" (is "flow ?\<Delta> ?f")
	proof
	show "?f e \<le> capacity ?\<Delta> e" for e
	using value_le f_finite flowD_capacity[OF g] flowD_capacity[OF f]
	by(cases e)(auto simp add: source_in source_out value_flow[OF f source_out] value_flow[OF g source_out] less_top
	intro!: diff_le_self_ennreal diff_eq_0_ennreal ennreal_minus_mono)

	fix x
	assume "x \<noteq> source ?\<Delta>" "x \<noteq> sink ?\<Delta>"
	hence x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>" by simp_all

	have finite_f_in: "(\<Sum>\<^sup>+ y. f (y, x) * indicator A y) \<noteq> top" for A
	using flowD_finite_IN[OF f, of x]
	by(rule neq_top_trans)(auto simp add: x d_IN_def split: split_indicator intro!: nn_integral_mono)
	have finite_f_out: "(\<Sum>\<^sup>+ y. f (x, y) * indicator A y) \<noteq> top" for A
	using flowD_finite_OUT[OF f, of x]
	by(rule neq_top_trans)(auto simp add: x d_OUT_def split: split_indicator intro!: nn_integral_mono)
	have finite_f[simp]: "f (x, y) \<noteq> top" "f (y, x) \<noteq> top" for y
	using finite_f_in[of "{y}"] finite_f_out[of "{y}"] by auto

	have finite_g_in: "(\<Sum>\<^sup>+ y. g (y, x) * indicator A y) \<noteq> top" for A
	using flowD_finite_IN[OF g, of x]
	by(rule neq_top_trans)(auto simp add: x d_IN_def split: split_indicator intro!: nn_integral_mono)
	have finite_g_out: "(\<Sum>\<^sup>+ y. g (x, y) * indicator A y) \<noteq> top" for A
	using flowD_finite_OUT[OF g x]
	by(rule neq_top_trans)(auto simp add: x d_OUT_def split: split_indicator intro!: nn_integral_mono)
	have finite_g[simp]: "g (x, y) \<noteq> top" "g (y, x) \<noteq> top" for y
	using finite_g_in[of "{y}"] finite_g_out[of "{y}"] by auto

	have "d_OUT (f \<ominus> g) x = (\<Sum>\<^sup>+ y. (f (x, y) - g (x, y)) * indicator \<^bold>E (x, y) * indicator {y. g (x, y) \<le> f (x, y)} y) +
	(\<Sum>\<^sup>+ y. (g (y, x) - f (y, x)) * indicator \<^bold>E (y, x) * indicator {y. f (y, x) < g (y, x)} y)"
	(is "_ = ?out + ?in" is "_ = (\<Sum>\<^sup>+ y\<in>_. _ * ?f_ge_g y) + (\<Sum>\<^sup>+ y\<in>_. _ * ?g_gt_f y)")
	using flowD_finite[OF g]
	apply(subst nn_integral_add[symmetric])
	apply(auto 4 4 simp add: d_OUT_def not_le less_top[symmetric] intro!: nn_integral_cong
	dest!: wf_residual_networkD[OF wf] split: split_indicator intro!: diff_eq_0_ennreal)
	done
	also have "?in = (\<Sum>\<^sup>+ y. (g (y, x) - f (y, x)) * ?g_gt_f y)"
	using flowD_outside[OF f] flowD_outside[OF g] by(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>UNIV. g (y, x) * ?g_gt_f y) - (\<Sum>\<^sup>+ y. f (y, x) * ?g_gt_f y)" (is "_ = ?g_in - ?f_in")
	using finite_f_in
	by(subst nn_integral_diff[symmetric])(auto simp add: AE_count_space split: split_indicator intro!: nn_integral_cong)
	also have "?out = (\<Sum>\<^sup>+ y. (f (x, y) - g (x, y)) * ?f_ge_g y)"
	using flowD_outside[OF f] flowD_outside[OF g] by(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ y. f (x, y) * ?f_ge_g y) - (\<Sum>\<^sup>+ y. g (x, y) * ?f_ge_g y)" (is "_ = ?f_out - ?g_out")
	using finite_g_out
	by(subst nn_integral_diff[symmetric])(auto simp add: AE_count_space split: split_indicator intro!: nn_integral_cong)
	also have "?f_out = d_OUT f x - (\<Sum>\<^sup>+ y. f (x, y) * indicator {y. f (x, y) < g (x, y)} y)" (is "_ = _ - ?f_out_less")
	unfolding d_OUT_def using flowD_finite[OF f] using finite_f_out
	by(subst nn_integral_diff[symmetric])(auto split: split_indicator intro!: nn_integral_cong)
	also have "?g_out = d_OUT g x - (\<Sum>\<^sup>+ y. g (x, y) * indicator {y. f (x, y) < g (x, y)} y)" (is "_ = _ - ?g_less_f")
	unfolding d_OUT_def using flowD_finite[OF g] finite_g_out
	by(subst nn_integral_diff[symmetric])(auto split: split_indicator intro!: nn_integral_cong)
	also have "d_OUT f x - ?f_out_less - (d_OUT g x - ?g_less_f) + (?g_in - ?f_in) =
	(?g_less_f + (d_OUT f x - ?f_out_less)) - d_OUT g x + (?g_in - ?f_in)"
	by (subst diff_diff_ennreal')
	(auto simp: ac_simps d_OUT_def nn_integral_diff[symmetric] finite_g_out finite_f_out intro!: nn_integral_mono split: split_indicator )
	also have "\<dots> = ?g_less_f + d_OUT f x - ?f_out_less - d_OUT g x + (?g_in - ?f_in)"
	by (subst add_diff_eq_ennreal)
	(auto simp: d_OUT_def intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> = d_OUT f x + ?g_less_f - ?f_out_less - d_OUT g x + (?g_in - ?f_in)"
	by (simp add: ac_simps)
	also have "\<dots> = d_OUT f x + (?g_less_f - ?f_out_less) - d_OUT g x + (?g_in - ?f_in)"
	by (subst add_diff_eq_ennreal[symmetric])
	(auto intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> = (?g_in - ?f_in) + ((?g_less_f - ?f_out_less) + d_OUT f x - d_OUT g x)"
	by (simp add: ac_simps)
	also have "\<dots> = ((?g_in - ?f_in) + ((?g_less_f - ?f_out_less) + d_OUT f x)) - d_OUT g x"
	apply (subst add_diff_eq_ennreal)
	apply (simp_all add: d_OUT_def)
	apply (subst nn_integral_diff[symmetric])
	apply (auto simp: AE_count_space finite_f_out nn_integral_add[symmetric] not_less diff_add_cancel_ennreal intro!: nn_integral_mono split: split_indicator)
	done
	also have "\<dots> = ((?g_less_f - ?f_out_less) + (d_OUT f x + (?g_in - ?f_in))) - d_OUT g x"
	by (simp add: ac_simps)
	also have "\<dots> = ((?g_less_f - ?f_out_less) + (d_IN f x + (?g_in - ?f_in))) - d_IN g x"
	unfolding flowD_KIR[OF f x] flowD_KIR[OF g x] ..
	also have "\<dots> = (?g_less_f - ?f_out_less) + ((d_IN f x + (?g_in - ?f_in)) - d_IN g x)"
	apply (subst (2) add_diff_eq_ennreal)
	apply (simp_all add: d_IN_def)
	apply (subst nn_integral_diff[symmetric])
	apply (auto simp: AE_count_space finite_f_in finite_f_out nn_integral_add[symmetric] not_less ennreal_ineq_diff_add[symmetric]
	intro!: nn_integral_mono split: split_indicator)
	done
	also have "\<dots> = (?g_less_f - ?f_out_less) + (d_IN f x + ?g_in - d_IN g x - ?f_in)"
	by (subst (2) add_diff_eq_ennreal) (auto intro!: nn_integral_mono split: split_indicator simp: diff_diff_commute_ennreal)
	also have "\<dots> = (?g_less_f - ?f_out_less) + (d_IN f x - (d_IN g x - ?g_in) - ?f_in)"
	apply (subst diff_diff_ennreal')
	apply (auto simp: d_IN_def intro!: nn_integral_mono split: split_indicator)
	apply (subst nn_integral_diff[symmetric])
	apply (auto simp: AE_count_space finite_g_in intro!: nn_integral_mono split: split_indicator)
	done
	also have "\<dots> =(d_IN f x - ?f_in) - (d_IN g x - ?g_in) + (?g_less_f - ?f_out_less)"
	by (simp add: ac_simps diff_diff_commute_ennreal)
	also have "?g_less_f - ?f_out_less = (\<Sum>\<^sup>+ y. (g (x, y) - f (x, y)) * indicator {y. f (x, y) < g (x, y)} y)" using finite_f_out
	by(subst nn_integral_diff[symmetric])(auto simp add: AE_count_space split: split_indicator intro!: nn_integral_cong)
	also have "\<dots> = (\<Sum>\<^sup>+ y. (g (x, y) - f (x, y)) * indicator \<^bold>E (x, y) * indicator {y. f (x, y) < g (x, y)} y)" (is "_ = ?diff_out")
	using flowD_outside[OF f] flowD_outside[OF g] by(auto intro!: nn_integral_cong split: split_indicator)
	also have "d_IN f x - ?f_in = (\<Sum>\<^sup>+ y. f (y, x) * indicator {y. g (y, x) \<le> f (y, x)} y)"
	unfolding d_IN_def using finite_f_in
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space split: split_indicator intro!: nn_integral_cong)
	done
	also have "d_IN g x - ?g_in = (\<Sum>\<^sup>+ y. g (y, x) * indicator {y. g (y, x) \<le> f (y, x)} y)"
	unfolding d_IN_def using finite_g_in
	by(subst nn_integral_diff[symmetric])(auto simp add: flowD_finite[OF g] AE_count_space split: split_indicator intro!: nn_integral_cong)
	also have "(\<Sum>\<^sup>+ y\<in>UNIV. f (y, x) * indicator {y. g (y, x) \<le> f (y, x)} y) - \<dots> = (\<Sum>\<^sup>+ y. (f (y, x) - g (y, x)) * indicator {y. g (y, x) \<le> f (y, x)} y)"
	using finite_g_in
	by(subst nn_integral_diff[symmetric])(auto simp add: flowD_finite[OF g] AE_count_space split: split_indicator intro!: nn_integral_cong)
	also have "\<dots> = (\<Sum>\<^sup>+ y. (f (y, x) - g (y, x)) * indicator \<^bold>E (y, x) * indicator {y. g (y, x) \<le> f (y, x)} y)"
	using flowD_outside[OF f] flowD_outside[OF g] by(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> + ?diff_out = d_IN ?f x"
	using flowD_finite[OF g]
	apply(subst nn_integral_add[symmetric])
	apply(auto 4 4 simp add: d_IN_def not_le less_top[symmetric] intro!: nn_integral_cong
	dest!: wf_residual_networkD[OF wf] split: split_indicator intro: diff_eq_0_ennreal)
	done
	finally show "KIR ?f x" .
	qed

	lemma value_minus_flow:
	assumes f: "flow \<Delta> f"
	and g: "flow \<Delta> g"
	and value_le: "value_flow \<Delta> g \<le> value_flow \<Delta> f"
	and source_out: "\<And>y. edge \<Delta> (source \<Delta>) y \<longleftrightarrow> y = x"
	shows "value_flow \<Delta> (f \<ominus> g) = value_flow \<Delta> f - value_flow \<Delta> g" (is "?value")
	proof -
	have "value_flow \<Delta> (f \<ominus> g) = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T (source \<Delta>). (f \<ominus> g) (source \<Delta>, y))"
	by(subst d_OUT_alt_def)(auto simp add: flowD_outside[OF f] flowD_outside[OF g] source_in)
	also have "\<dots> = (\<Sum>\<^sup>+ y. (f (source \<Delta>, y) - g (source \<Delta>, y)) * indicator {x} y)"
	by(subst nn_integral_count_space_indicator)(auto intro!: nn_integral_cong split: split_indicator simp add: outgoing_def source_out)
	also have "\<dots> = f (source \<Delta>, x) - g (source \<Delta>, x)"
	using value_le value_flow[OF f source_out] value_flow[OF g source_out]
	by(auto simp add: one_ennreal_def[symmetric] max_def not_le intro: antisym)
	also have "\<dots> = value_flow \<Delta> f - value_flow \<Delta> g" using f g source_out by(simp add: value_flow)
	finally show ?value .
	qed

	context
	fixes \<alpha>
	defines "\<alpha> \<equiv> (SUP g\<in>{g. flow \<Delta> g}. value_flow \<Delta> g)"
	begin

	lemma flow_by_value:
	assumes "v < \<alpha>"
	and real[rule_format]: "\<forall>f. \<alpha> = \<top> \<longrightarrow> flow \<Delta> f \<longrightarrow> value_flow \<Delta> f < \<alpha>"
	obtains f where "flow \<Delta> f" "value_flow \<Delta> f = v"
	proof -
	have \<alpha>_pos: "\<alpha> > 0" using assms by (auto simp add: zero_less_iff_neq_zero)
	from \<open>v < \<alpha>\<close> obtain f where f: "flow \<Delta> f" and v: "v < value_flow \<Delta> f"
	unfolding \<alpha>_def less_SUP_iff by blast
	have [simp]: "value_flow \<Delta> f \<noteq> \<top>"
	proof
	assume val: "value_flow \<Delta> f = \<top>"
	from f have "value_flow \<Delta> f \<le> \<alpha>" unfolding \<alpha>_def by(blast intro: SUP_upper2)
	with val have "\<alpha> = \<top>" by (simp add: top_unique)
	from real[OF this f] val show False by simp
	qed
	let ?f = "\<lambda>e. (v / value_flow \<Delta> f) * f e"
	note f
	moreover
	have *: "0 < value_flow \<Delta> f"
	using \<open>v < value_flow \<Delta> f\<close> by (auto simp add: zero_less_iff_neq_zero)
	then have "v / value_flow \<Delta> f \<le> 1" using v
	by (auto intro!: divide_le_posI_ennreal)
	ultimately have "flow \<Delta> ?f" by (rule scale_flow)
	moreover {
	have "value_flow \<Delta> ?f = v * (value_flow \<Delta> f / value_flow \<Delta> f)"
	by(subst value_scale_flow)(simp add: divide_ennreal_def ac_simps)
	also have "\<dots> = v" using * by(subst ennreal_divide_self) (auto simp: less_top[symmetric])
	also note calculation }
	ultimately show ?thesis by(rule that)
	qed

	theorem ex_max_flow':
	assumes wf: "wf_residual_network"
	assumes source_out: "\<And>y. edge \<Delta> (source \<Delta>) y \<longleftrightarrow> y = x"
	and nontrivial: "\<^bold>V - {source \<Delta>, sink \<Delta>} \<noteq> {}"
	and real: "\<alpha> = ennreal \<alpha>'" and \<alpha>'_nonneg[simp]: "0 \<le> \<alpha>'"
	shows "\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = \<alpha> \<and> (\<forall>x. d_IN f x \<le> value_flow \<Delta> f)"
	proof -
	have \<alpha>'_not_neg[simp]: "\<not> \<alpha>' < 0"
	using \<alpha>'_nonneg by linarith

	let ?v = "\<lambda>i. (1 - (1 / 2) ^ i) * \<alpha>"
	let ?v_r = "\<lambda>i. ennreal ((1 - (1 / 2) ^ i) * \<alpha>')"
	have v_eq: "?v i = ?v_r i" for i
	by (auto simp: real ennreal_mult power_le_one ennreal_lessI ennreal_minus[symmetric]
	ennreal_power[symmetric] divide_ennreal_def)
	have "\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = ?v i" for i :: nat
	proof(cases "\<alpha> = 0")
	case True thus ?thesis by(auto intro!: exI[where x="\<lambda>_. 0"])
	next
	case False
	then have "?v i < \<alpha>"
	unfolding v_eq by (auto simp: real field_simps intro!: ennreal_lessI) (simp_all add: less_le)
	then obtain f where "flow \<Delta> f" and "value_flow \<Delta> f = ?v i"
	by(rule flow_by_value)(simp add: real)
	thus ?thesis by blast
	qed
	then obtain f_aux where f_aux: "\<And>i. flow \<Delta> (f_aux i)"
	and value_aux: "\<And>i. value_flow \<Delta> (f_aux i) = ?v_r i"
	unfolding v_eq by moura

	define f_i where "f_i = rec_nat (\<lambda>_. 0) (\<lambda>i f_i.
	let g = f_aux (Suc i) \<ominus> f_i;
	k_i = SOME k. k \<le> g \<and> flow (residual_network f_i) k \<and> value_flow (residual_network f_i) k = value_flow (residual_network f_i) g \<and> (\<forall>x. d_IN k x \<le> value_flow (residual_network f_i) k)
	in f_i \<oplus> k_i)"
	let ?P = "\<lambda>i k. k \<le> f_aux (Suc i) \<ominus> f_i i \<and> flow (residual_network (f_i i)) k \<and> value_flow (residual_network (f_i i)) k = value_flow (residual_network (f_i i)) (f_aux (Suc i) \<ominus> f_i i) \<and> (\<forall>x. d_IN k x \<le> value_flow (residual_network (f_i i)) k)"
	define k_i where "k_i i = Eps (?P i)" for i

	have f_i_simps [simp]: "f_i 0 = (\<lambda>_. 0)" "f_i (Suc i) = f_i i \<oplus> k_i i" for i
	by(simp_all add: f_i_def Let_def k_i_def)

	have k_i: "flow (residual_network (f_i i)) (k_i i)" (is ?k_i)
	and value_k_i: "value_flow (residual_network (f_i i)) (k_i i) = value_flow (residual_network (f_i i)) (f_aux (Suc i) \<ominus> f_i i)" (is "?value_k_i")
	and IN_k_i: "d_IN (k_i i) x \<le> value_flow (residual_network (f_i i)) (k_i i)" (is "?IN_k_i")
	and value_diff: "value_flow (residual_network (f_i i)) (f_aux (Suc i) \<ominus> f_i i) = value_flow \<Delta> (f_aux (Suc i)) - value_flow \<Delta> (f_i i)" (is "?value_diff")
	if "flow_network \<Delta> (f_i i)" and value_f_i: "value_flow \<Delta> (f_i i) = value_flow \<Delta> (f_aux i)" for i x
	proof -
	let ?RES = "residual_network (f_i i)"
	interpret fn: flow_network \<Delta> "f_i i" by(rule that)
	interpret RES: flow_attainability "?RES" using wf fn.g by(rule residual_flow_attainability)
	have le: "value_flow \<Delta> (f_i i) \<le> value_flow \<Delta> (f_aux (Suc i))"
	unfolding value_aux value_f_i
	unfolding v_eq by (rule ennreal_leI) (auto simp: field_simps)
	with wf f_aux fn.g have res_flow: "flow ?RES (f_aux (Suc i) \<ominus> f_i i)"
	using flowD_finite[OF f_aux] source_out
	by(rule minus_flow)
	show value': ?value_diff by(simp add: value_minus_flow[OF f_aux fn.g le source_out])
	also have "\<dots> < \<top>"
	unfolding value_aux v_eq by (auto simp: less_top[symmetric])
	finally have "value_flow ?RES (f_aux (Suc i) \<ominus> f_i i) \<noteq> \<top>" by simp
	then have fn': "flow_network ?RES (f_aux (Suc i) \<ominus> f_i i)"
	using nontrivial res_flow by(unfold_locales) simp_all
	then interpret fn': flow_network "?RES" "f_aux (Suc i) \<ominus> f_i i" .
	from fn'.flow_cleanup show ?k_i ?value_k_i ?IN_k_i unfolding k_i_def by(rule someI2_ex; blast)+
	qed

	have fn_i: "flow_network \<Delta> (f_i i)"
	and value_f_i: "value_flow \<Delta> (f_i i) = value_flow \<Delta> (f_aux i)"
	and d_IN_i: "d_IN (f_i i) x \<le> value_flow \<Delta> (f_i i)" for i x
	proof(induction i)
	case 0
	{ case 1 show ?case using nontrivial by(unfold_locales)(simp_all add: f_aux value_aux) }
	{ case 2 show ?case by(simp add: value_aux) }
	{ case 3 show ?case by(simp) }
	next
	case (Suc i)
	interpret fn: flow_network \<Delta> "f_i i" using Suc.IH(1) .
	let ?RES = "residual_network (f_i i)"

	have k_i: "flow ?RES (k_i i)"
	and value_k_i: "value_flow ?RES (k_i i) = value_flow ?RES (f_aux (Suc i) \<ominus> f_i i)"
	and d_IN_k_i: "d_IN (k_i i) x \<le> value_flow ?RES (k_i i)" for x
	using Suc.IH(1-2) by(rule k_i value_k_i IN_k_i)+

	interpret RES: flow_attainability "?RES" using wf fn.g by(rule residual_flow_attainability)
	have le: "value_flow \<Delta> (f_i i) \<le> value_flow \<Delta> (f_aux (Suc i))"
	unfolding value_aux Suc.IH(2) v_eq using \<alpha>'_nonneg by(intro ennreal_leI)(simp add: real field_simps)
	{ case 1 show ?case unfolding f_i_simps
	proof
	show "flow \<Delta> (f_i i \<oplus> k_i i)" using wf fn.g k_i by(rule flow_residual_add)
	with RES.flowD_finite[OF k_i] show "value_flow \<Delta> (f_i i \<oplus> k_i i) \<noteq> \<top>"
	by(simp add: value_flow[OF _ source_out])
	qed(rule nontrivial) }
	from value_k_i have value_k: "value_flow ?RES (k_i i) = value_flow \<Delta> (f_aux (Suc i)) - value_flow \<Delta> (f_aux i)"
	by(simp add: value_minus_flow[OF f_aux fn.g le source_out] Suc.IH)
	{ case 2 show ?case using value_k
	by(auto simp add: source_out value_plus_flow[OF wf fn.g k_i] Suc.IH value_aux field_simps intro!: ennreal_leI) }
	note value_f = this
	{ case 3
	have "d_IN (f_i i \<oplus> k_i i) x \<le> d_IN (f_i i) x + d_IN (k_i i) x"
	using fn.g k_i by(rule d_IN_plus_flow[OF wf])
	also have "\<dots> \<le> value_flow \<Delta> (f_i i) + d_IN (k_i i) x" using Suc.IH(3) by(rule add_right_mono)
	also have "\<dots> \<le> value_flow \<Delta> (f_i i) + value_flow ?RES (k_i i)" using d_IN_k_i by(rule add_left_mono)
	also have "\<dots> = value_flow \<Delta> (f_i (Suc i))" unfolding value_f Suc.IH(2) value_k
	by(auto simp add: value_aux field_simps intro!: ennreal_leI)
	finally show ?case by simp }
	qed
	interpret fn: flow_network \<Delta> "f_i i" for i by(rule fn_i)
	note k_i = k_i[OF fn_i value_f_i] and value_k_i = value_k_i[OF fn_i value_f_i]
	and IN_k_i = IN_k_i[OF fn_i value_f_i] and value_diff = value_diff[OF fn_i value_f_i]

	have "\<exists>x\<ge>0. f_i i e = ennreal x" for i e
	using fn.finite_g[of i e] by (cases "f_i i e") auto
	then obtain f_i' where f_i': "\<And>i e. f_i i e = ennreal (f_i' i e)" and [simp]: "\<And>i e. 0 \<le> f_i' i e"
	by metis

	{ fix i e
	obtain x y :: 'v where e: "e = (x, y)" by(cases e)
	have "k_i i (x, y) \<le> d_IN (k_i i) y" by (rule d_IN_ge_point)
	also have "\<dots> \<le> value_flow (residual_network (f_i i)) (k_i i)" by(rule IN_k_i)
	also have "\<dots> < \<top>" using value_k_i[of i] value_diff[of i]
	by(simp add: value_k_i value_f_i value_aux real less_top[symmetric])
	finally have "\<exists>x\<ge>0. k_i i e = ennreal x"
	by(cases "k_i i e")(auto simp add: e) }
	then obtain k_i' where k_i': "\<And>i e. k_i i e = ennreal (k_i' i e)" and k_i'_nonneg[simp]: "\<And>i e. 0 \<le> k_i' i e"
	by metis

	have wf_k: "(x, y) \<in> \<^bold>E \<Longrightarrow> k_i i (y, x) \<le> f_i i (x, y) + k_i i (x, y)" for i x y
	using flowD_capacity[OF k_i, of i "(y, x)"]
	by (auto split: if_split_asm dest: wf_residual_networkD[OF wf] elim: order_trans)

	have f_i'_0[simp]: "f_i' 0 = (\<lambda>_. 0)" using f_i_simps(1) by (simp del: f_i_simps add: fun_eq_iff f_i')

	have f_i'_Suc[simp]: "f_i' (Suc i) e = (if e \<in> \<^bold>E then f_i' i e + (k_i' i e - k_i' i (prod.swap e)) else 0)" for i e
	using f_i_simps(2)[of i, unfolded fun_eq_iff, THEN spec, of e] wf_k[of "fst e" "snd e" i]
	by (auto simp del: f_i_simps ennreal_plus
	simp add: fun_eq_iff f_i' k_i' ennreal_plus[symmetric] ennreal_minus split: if_split_asm)

	have k_i'_le: "k_i' i e \<le> \<alpha>' / 2 ^ (Suc i)" for i e
	proof -
	obtain x y where e: "e = (x, y)" by(cases e)
	have "k_i' i (x, y) \<le> d_IN (k_i' i) y" by (rule d_IN_ge_point)
	also have "\<dots> \<le> value_flow (residual_network (f_i i)) (k_i' i)"
	using IN_k_i[of i y] by(simp add: k_i'[abs_def])
	also have "\<dots> = \<alpha>' / 2 ^ (Suc i)" using value_k_i[of i] value_diff[of i]
	by(simp add: value_f_i value_aux real k_i'[abs_def] field_simps ennreal_minus mult_le_cancel_left1)
	finally show ?thesis using e by simp
	qed

	have convergent: "convergent (\<lambda>i. f_i' i e)" for e
	proof(cases "\<alpha>' > 0")
	case False
	obtain x y where [simp]: "e = (x, y)" by(cases e)

	{ fix i
	from False \<alpha>'_nonneg have "\<alpha>' = 0" by simp
	moreover have "f_i i (x, y) \<le> d_IN (f_i i) y" by (rule d_IN_ge_point)
	ultimately have "f_i i (x, y) = 0" using d_IN_i[of i y]
	by(simp add: value_f_i value_aux real) }
	thus ?thesis by(simp add: f_i' convergent_const)
	next
	case \<alpha>'_pos: True
	show ?thesis
	proof(rule real_Cauchy_convergent Cauchy_real_Suc_diff)+
	fix n
	have "\<bar>k_i' n e - k_i' n (prod.swap e)\<bar> \<le> \<bar>k_i' n e\<bar> + \<bar>k_i' n (prod.swap e)\<bar>"
	by (rule abs_triangle_ineq4)
	then have "\<bar>k_i' n e - k_i' n (prod.swap e)\<bar> \<le> \<alpha>' / 2 ^ n"
	using k_i'_le[of n e] k_i'_le[of n "prod.swap e"] by simp
	then have "\<bar>f_i' (Suc n) e - f_i' n e\<bar> \<le> \<alpha>' / 2 ^ n"
	using flowD_outside[OF fn.g] by (cases e) (auto simp: f_i')
	thus "\<bar>f_i' (Suc n) e - f_i' n e\<bar> \<le> \<alpha>' / 2 ^ n" by simp
	qed simp
	qed
	then obtain f' where f': "\<And>e. (\<lambda>i. f_i' i e) \<longlonglongrightarrow> f' e" unfolding convergent_def by metis
	hence f: "\<And>e. (\<lambda>i. f_i i e) \<longlonglongrightarrow> ennreal (f' e)" unfolding f_i' by simp

	have f'_nonneg: "0 \<le> f' e" for e
	by (rule LIMSEQ_le_const[OF f']) auto

	let ?k = "\<lambda>i x y. (k_i' i (x, y) - k_i' i (y, x)) * indicator \<^bold>E (x, y)"
	have sum_i': "f_i' i (x, y) = (\<Sum>j<i. ?k j x y)" for x y i
	by (induction i) auto

	have summable_nk: "summable (\<lambda>i. \<bar>?k i x y\<bar>)" for x y
	proof(rule summable_rabs_comparison_test)
	show "\<exists>N. \<forall>i\<ge>N. \<bar>?k i x y\<bar> \<le> \<alpha>' * (1 / 2) ^ i"
	proof (intro exI allI impI)
	fix i have "\<bar>?k i x y\<bar> \<le> k_i' i (x, y) + k_i' i (y, x)"
	by (auto intro!: abs_triangle_ineq4[THEN order_trans] split: split_indicator)
	also have "\<dots> \<le> \<alpha>' * (1 / 2) ^ i"
	using k_i'_le[of i "(x, y)"] k_i'_le[of i "(y, x)"] \<alpha>'_nonneg k_i'_nonneg[of i "(x, y)"] k_i'_nonneg[of i "(y, x)"]
	by(auto simp add: abs_real_def power_divide split: split_indicator)
	finally show "\<bar>?k i x y\<bar> \<le> \<alpha>' * (1 / 2) ^ i"
	by simp
	qed
	show "summable (\<lambda>i. \<alpha>' * (1 / 2) ^ i)"
	by(rule summable_mult complete_algebra_summable_geometric)+ simp
	qed
	hence summable_k: "summable (\<lambda>i. ?k i x y)" for x y by(auto intro: summable_norm_cancel)

	have suminf: "(\<Sum>i. (k_i' i (x, y) - k_i' i (y, x)) * indicator \<^bold>E (x, y)) = f' (x, y)" for x y
	by(rule LIMSEQ_unique[OF summable_LIMSEQ])(simp_all add: sum_i'[symmetric] f' summable_k)

	have flow: "flow \<Delta> f'"
	proof
	fix e
	have "f' e \<le> Sup {..capacity \<Delta> e}" using _ f
	by(rule Sup_lim)(simp add: flowD_capacity[OF fn.g])
	then show "f' e \<le> capacity \<Delta> e" by simp
	next
	fix x
	assume x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"

	have integrable_f_i: "integrable (count_space UNIV) (\<lambda>y. f_i' i (x, y))" for i
	using flowD_finite_OUT[OF fn.g x, of i] by(auto intro!: integrableI_bounded simp add: f_i' d_OUT_def less_top)
	have integrable_f_i': "integrable (count_space UNIV) (\<lambda>y. f_i' i (y, x))" for i
	using flowD_finite_IN[OF fn.g, of x i] x by(auto intro!: integrableI_bounded simp add: f_i' d_IN_def less_top)

	have integral_k_bounded: "(\<Sum>\<^sup>+ y. norm (?k i x y)) \<le> \<alpha>' / 2 ^ i" (is ?thesis1)
	and integral_k'_bounded: "(\<Sum>\<^sup>+ y. norm (?k i y x)) \<le> \<alpha>' / 2 ^ i" (is ?thesis2) for i
	proof -
	define b where "b = (\<Sum>\<^sup>+ y. k_i i (x, y) + k_i i (y, x))"
	have "b = d_OUT (k_i i) x + d_IN (k_i i) x" unfolding b_def
	by(subst nn_integral_add)(simp_all add: d_OUT_def d_IN_def)
	also have "d_OUT (k_i i) x = d_IN (k_i i) x" using k_i by(rule flowD_KIR)(simp_all add: x)
	also have "\<dots> + \<dots> \<le> value_flow \<Delta> (k_i i) + value_flow \<Delta> (k_i i)"
	using IN_k_i[of i x, simplified] by-(rule add_mono)
	also have "\<dots> \<le> \<alpha>' / 2 ^ i" using value_k_i[of i] value_diff[of i]
	by(simp add: value_aux value_f_i field_simps ennreal_minus_if ennreal_plus_if mult_le_cancel_left1
	del: ennreal_plus)
	also have "(\<Sum>\<^sup>+ y\<in>UNIV. norm (?k i x y)) \<le> b" and "(\<Sum>\<^sup>+ y. norm (?k i y x)) \<le> b" unfolding b_def
	by(rule nn_integral_mono; simp add: abs_real_def k_i' ennreal_plus_if del: ennreal_plus split: split_indicator)+
	ultimately show ?thesis1 ?thesis2 by(auto)
	qed

	have integrable_k: "integrable (count_space UNIV) (\<lambda>y. ?k i x y)"
	and integrable_k': "integrable (count_space UNIV) (\<lambda>y. ?k i y x)" for i
	using integral_k_bounded[of i] integral_k'_bounded[of i] real
	by(auto intro!: integrableI_bounded simp: less_top[symmetric] top_unique ennreal_divide_eq_top_iff)

	have summable'_k: "summable (\<lambda>i. \<integral> y. \<bar>?k i x y\<bar> \<partial>count_space UNIV)"
	proof(rule summable_comparison_test)
	have "\<bar>\<integral> y. \<bar>?k i x y\<bar> \<partial>count_space UNIV\<bar> \<le> \<alpha>' * (1 / 2) ^ i" for i
	using integral_norm_bound_ennreal[OF integrable_norm, OF integrable_k, of i] integral_k_bounded[of i]
	by(bestsimp simp add: real power_divide dest: order_trans)
	thus "\<exists>N. \<forall>i\<ge>N. norm (\<integral> y. \<bar>?k i x y\<bar> \<partial>count_space UNIV) \<le> \<alpha>' * (1 / 2) ^ i"
	by auto
	show "summable (\<lambda>i. \<alpha>' * (1 / 2) ^ i)"
	by(rule summable_mult complete_algebra_summable_geometric)+ simp
	qed
	have summable'_k': "summable (\<lambda>i. \<integral> y. \<bar>?k i y x\<bar> \<partial>count_space UNIV)"
	proof(rule summable_comparison_test)
	have "\<bar>\<integral> y. \<bar>?k i y x\<bar> \<partial>count_space UNIV\<bar> \<le> \<alpha>' * (1 / 2) ^ i" for i
	using integral_norm_bound_ennreal[OF integrable_norm, OF integrable_k', of i] integral_k'_bounded[of i]
	by(bestsimp simp add: real power_divide dest: order_trans)
	thus "\<exists>N. \<forall>i\<ge>N. norm (\<integral> y. \<bar>?k i y x\<bar> \<partial>count_space UNIV) \<le> \<alpha>' * (1 / 2) ^ i" by auto
	show "summable (\<lambda>i. \<alpha>' * (1 / 2) ^ i)"
	by(rule summable_mult complete_algebra_summable_geometric)+ simp
	qed

	have "(\<lambda>i. \<integral> y. ?k i x y \<partial>count_space UNIV) sums \<integral> y. (\<Sum>i. ?k i x y) \<partial>count_space UNIV"
	using integrable_k by(rule sums_integral)(simp_all add: summable_nk summable'_k)
	also have "\<dots> = \<integral> y. f' (x, y) \<partial>count_space UNIV" by(rule Bochner_Integration.integral_cong[OF refl])(rule suminf)
	finally have "(\<lambda>i. \<Sum>j<i. \<integral> y. ?k j x y \<partial>count_space UNIV) \<longlonglongrightarrow> \<dots>" unfolding sums_def .
	also have "(\<lambda>i. \<Sum>j<i. \<integral> y. ?k j x y \<partial>count_space UNIV) = (\<lambda>i. \<integral> y. f_i' i (x, y) \<partial>count_space UNIV)"
	unfolding sum_i' by(rule ext Bochner_Integration.integral_sum[symmetric] integrable_k)+
	finally have "(\<lambda>i. ennreal (\<integral> y. f_i' i (x, y) \<partial>count_space UNIV)) \<longlonglongrightarrow> ennreal (\<integral> y. f' (x, y) \<partial>count_space UNIV)" by simp
	also have "(\<lambda>i. ennreal (\<integral> y. f_i' i (x, y) \<partial>count_space UNIV)) = (\<lambda>i. d_OUT (f_i i) x)"
	unfolding d_OUT_def f_i' by(rule ext nn_integral_eq_integral[symmetric] integrable_f_i)+ simp
	also have "ennreal (\<integral> y. f' (x, y) \<partial>count_space UNIV) = d_OUT f' x"
	unfolding d_OUT_def by(rule nn_integral_eq_integral[symmetric])(simp_all add: f'_nonneg, simp add: suminf[symmetric] integrable_suminf integrable_k summable_nk summable'_k)
	also have "(\<lambda>i. d_OUT (f_i i) x) = (\<lambda>i. d_IN (f_i i) x)"
	using flowD_KIR[OF fn.g x] by(simp)
	finally have *: "(\<lambda>i. d_IN (f_i i) x) \<longlonglongrightarrow> d_OUT (\<lambda>x. ennreal (f' x)) x" .

	have "(\<lambda>i. \<integral> y. ?k i y x \<partial>count_space UNIV) sums \<integral> y. (\<Sum>i. ?k i y x) \<partial>count_space UNIV"
	using integrable_k' by(rule sums_integral)(simp_all add: summable_nk summable'_k')
	also have "\<dots> = \<integral> y. f' (y, x) \<partial>count_space UNIV" by(rule Bochner_Integration.integral_cong[OF refl])(rule suminf)
	finally have "(\<lambda>i. \<Sum>j<i. \<integral> y. ?k j y x \<partial>count_space UNIV) \<longlonglongrightarrow> \<dots>" unfolding sums_def .
	also have "(\<lambda>i. \<Sum>j<i. \<integral> y. ?k j y x \<partial>count_space UNIV) = (\<lambda>i. \<integral> y. f_i' i (y, x) \<partial>count_space UNIV)"
	unfolding sum_i' by(rule ext Bochner_Integration.integral_sum[symmetric] integrable_k')+
	finally have "(\<lambda>i. ennreal (\<integral> y. f_i' i (y, x) \<partial>count_space UNIV)) \<longlonglongrightarrow> ennreal (\<integral> y. f' (y, x) \<partial>count_space UNIV)" by simp
	also have "(\<lambda>i. ennreal (\<integral> y. f_i' i (y, x) \<partial>count_space UNIV)) = (\<lambda>i. d_IN (f_i i) x)"
	unfolding d_IN_def f_i' by(rule ext nn_integral_eq_integral[symmetric] integrable_f_i')+ simp
	also have "ennreal (\<integral> y. f' (y, x) \<partial>count_space UNIV) = d_IN f' x"
	unfolding d_IN_def by(rule nn_integral_eq_integral[symmetric])(simp_all add: f'_nonneg, simp add: suminf[symmetric] integrable_suminf integrable_k' summable_nk summable'_k')
	finally show "d_OUT f' x = d_IN f' x" using * by(blast intro: LIMSEQ_unique)
	qed
	moreover
	{ have "incseq (\<lambda>i. value_flow \<Delta> (f_i i))"
	by(rule incseq_SucI)(simp add: value_aux value_f_i real field_simps \<alpha>'_nonneg ennreal_leI del: f_i_simps)
	then have "(\<lambda>i. value_flow \<Delta> (f_i i)) \<longlonglongrightarrow> (SUP i. value_flow \<Delta> (f_i i))" by(rule LIMSEQ_SUP)
	also have "(SUP i. value_flow \<Delta> (f_i i)) = \<alpha>"
	proof -
	have "\<alpha> - (SUP i. value_flow \<Delta> (f_i i)) = (INF i. \<alpha> - value_flow \<Delta> (f_i i))"
	by(simp add: ennreal_SUP_const_minus real)
	also have "\<alpha> - value_flow \<Delta> (f_i i) = \<alpha>' / 2 ^ i" for i
	by(simp add: value_f_i value_aux real ennreal_minus_if field_simps mult_le_cancel_left1)
	hence "(INF i. \<alpha> - value_flow \<Delta> (f_i i)) = (INF i. ennreal (\<alpha>' / 2 ^ i))"
	by(auto intro: INF_cong)
	also have "\<dots> = 0"
	proof(rule LIMSEQ_unique)
	show "(\<lambda>i. \<alpha>' / 2 ^ i) \<longlonglongrightarrow> (INF i. ennreal (\<alpha>' / 2 ^ i))"
	by(rule LIMSEQ_INF)(simp add: field_simps real decseq_SucI)
	qed(simp add: LIMSEQ_divide_realpow_zero real ennreal_0[symmetric] del: ennreal_0)
	finally show "(SUP i. value_flow \<Delta> (f_i i)) = \<alpha>"
	apply (intro antisym)
	apply (auto simp: \<alpha>_def intro!: SUP_mono fn.g) []
	apply (rule ennreal_minus_eq_0)
	apply assumption
	done
	qed
	also have "(\<lambda>i. value_flow \<Delta> (f_i i)) \<longlonglongrightarrow> value_flow \<Delta> f'"
	by(simp add: value_flow[OF flow source_out] value_flow[OF fn.g source_out] f)
	ultimately have "value_flow \<Delta> f' = \<alpha>" by(blast intro: LIMSEQ_unique) }
	note value_f = this
	moreover {
	fix x
	have "d_IN f' x = \<integral>\<^sup>+ y. liminf (\<lambda>i. f_i i (y, x)) \<partial>count_space UNIV" unfolding d_IN_def using f
	by(simp add: tendsto_iff_Liminf_eq_Limsup)
	also have "\<dots> \<le> liminf (\<lambda>i. d_IN (f_i i) x)" unfolding d_IN_def
	by(rule nn_integral_liminf)(simp_all add:)
	also have "\<dots> \<le> liminf (\<lambda>i. \<alpha>)" using d_IN_i[of _ x] fn.g
	by(auto intro!: Liminf_mono SUP_upper2 eventually_sequentiallyI simp add: \<alpha>_def)
	also have "\<dots> = value_flow \<Delta> f'" using value_f by(simp add: Liminf_const)
	also note calculation
	} ultimately show ?thesis by blast
	qed

	theorem ex_max_flow'': \<comment> \<open>eliminate assumption of no antiparallel edges using locale @{const wf_residual_network}\<close>
	assumes source_out: "\<And>y. edge \<Delta> (source \<Delta>) y \<longleftrightarrow> y = x"
	and nontrivial: "\<^bold>E \<noteq> {}"
	and real: "\<alpha> = ennreal \<alpha>'" and nn[simp]: "0 \<le> \<alpha>'"
	shows "\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = \<alpha> \<and> (\<forall>x. d_IN f x \<le> value_flow \<Delta> f)"
	proof -
	interpret antiparallel_edges \<Delta> ..
	interpret \<Delta>'': flow_attainability \<Delta>''
	by(rule \<Delta>''_flow_attainability flow_attainability.axioms(2))+unfold_locales
	have wf_\<Delta>'': "\<Delta>''.wf_residual_network"
	by(rule \<Delta>''_wf_residual_network; simp add: no_loop)

	have source_out': "edge \<Delta>'' (source \<Delta>'') y \<longleftrightarrow> y = Edge (source \<Delta>) x" for y
	by(auto simp add: source_out)
	have nontrivial': "\<^bold>V\<^bsub>\<Delta>''\<^esub> - {source \<Delta>'', sink \<Delta>''} \<noteq> {}" using nontrivial by(auto simp add: "\<^bold>V_\<Delta>''")

	have "(SUP g \<in> {g. flow \<Delta>'' g}. value_flow \<Delta>'' g) = (SUP g \<in> {g. flow \<Delta> g}. value_flow \<Delta> g)" (is "?lhs = ?rhs")
	proof(intro antisym SUP_least; unfold mem_Collect_eq)
	fix g
	assume g: "flow \<Delta>'' g"
	hence "value_flow \<Delta>'' g = value_flow \<Delta> (collect g)" by(simp add: value_collect)
	also { from g have "flow \<Delta> (collect g)" by simp }
	then have "\<dots> \<le> ?rhs" by(blast intro: SUP_upper2)
	finally show "value_flow \<Delta>'' g \<le> \<dots>" .
	next
	fix g
	assume g: "flow \<Delta> g"
	hence "value_flow \<Delta> g = value_flow \<Delta>'' (split g)" by simp
	also { from g have "flow \<Delta>'' (split g)" by simp }
	then have "\<dots> \<le> ?lhs" by(blast intro: SUP_upper2)
	finally show "value_flow \<Delta> g \<le> ?lhs" .
	qed
	with real have eq: "(SUP g \<in> {g. flow \<Delta>'' g}. value_flow \<Delta>'' g) = ennreal \<alpha>'" by(simp add: \<alpha>_def)
	from \<Delta>''.ex_max_flow'[OF wf_\<Delta>'' source_out' nontrivial' eq]
	obtain f where f: "flow \<Delta>'' f"
	and "value_flow \<Delta>'' f = \<alpha>"
	and IN: "\<And>x. d_IN f x \<le> value_flow \<Delta>'' f" unfolding eq real using nn by blast
	hence "flow \<Delta> (collect f)" and "value_flow \<Delta> (collect f) = \<alpha>" by(simp_all add: value_collect)
	moreover {
	fix x
	have "d_IN (collect f) x = (\<Sum>\<^sup>+ y\<in>range (\<lambda>y. Edge y x). f (y, Vertex x))"
	by(simp add: nn_integral_count_space_reindex d_IN_def)
	also have "\<dots> \<le> d_IN f (Vertex x)" unfolding d_IN_def
	by (auto intro!: nn_integral_mono simp add: nn_integral_count_space_indicator split: split_indicator)
	also have "\<dots> \<le> value_flow \<Delta> (collect f)" using IN[of "Vertex x"] f by(simp add: value_collect)
	also note calculation }
	ultimately show ?thesis by blast
	qed

	context begin \<comment> \<open>We eliminate the assumption of only one edge leaving the source by introducing a new source vertex.\<close>
	private datatype (plugins del: transfer size) 'v' node = SOURCE \| Inner (inner: 'v')

	private lemma not_Inner_conv: "x \<notin> range Inner \<longleftrightarrow> x = SOURCE"
	by(cases x) auto

	private lemma inj_on_Inner [simp]: "inj_on Inner A"
	by(simp add: inj_on_def)

	private inductive edge' :: "'v node \<Rightarrow> 'v node \<Rightarrow> bool"
	where
	SOURCE: "edge' SOURCE (Inner (source \<Delta>))"
	\| Inner: "edge \<Delta> x y \<Longrightarrow> edge' (Inner x) (Inner y)"

	private inductive_simps edge'_simps [simp]:
	"edge' SOURCE x"
	"edge' (Inner y) x"
	"edge' y SOURCE"
	"edge' y (Inner x)"

	private fun capacity' :: "'v node flow"
	where
	"capacity' (SOURCE, Inner x) = (if x = source \<Delta> then \<alpha> else 0)"
	\| "capacity' (Inner x, Inner y) = capacity \<Delta> (x, y)"
	\| "capacity' _ = 0"

	private lemma capacity'_source_in [simp]: "capacity' (y, Inner (source \<Delta>)) = (if y = SOURCE then \<alpha> else 0)"
	by(cases y)(simp_all add: capacity_outside source_in)

	private definition \<Delta>' :: "'v node network"
	where "\<Delta>' = \<lparr>edge = edge', capacity = capacity', source = SOURCE, sink = Inner (sink \<Delta>)\<rparr>"

	private lemma \<Delta>'_sel [simp]:
	"edge \<Delta>' = edge'"
	"capacity \<Delta>' = capacity'"
	"source \<Delta>' = SOURCE"
	"sink \<Delta>' = Inner (sink \<Delta>)"
	by(simp_all add: \<Delta>'_def)

	private lemma "\<^bold>E_\<Delta>'": "\<^bold>E\<^bsub>\<Delta>'\<^esub> = {(SOURCE, Inner (source \<Delta>))} \<union> (\<lambda>(x, y). (Inner x, Inner y)) ` \<^bold>E"
	by(auto elim: edge'.cases)

	private lemma \<Delta>'_countable_network:
	assumes "\<alpha> \<noteq> \<top>"
	shows "countable_network \<Delta>'"
	proof
	show "countable \<^bold>E\<^bsub>\<Delta>'\<^esub>" unfolding "\<^bold>E_\<Delta>'" by simp
	show "source \<Delta>' \<noteq> sink \<Delta>'" by simp
	show "capacity \<Delta>' e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Delta>'\<^esub>" for e using that unfolding "\<^bold>E_\<Delta>'"
	by(cases e rule: capacity'.cases)(auto intro: capacity_outside)
	show "capacity \<Delta>' e \<noteq> \<top>" for e by(cases e rule: capacity'.cases)(simp_all add: assms)
	qed

	private lemma \<Delta>'_flow_attainability:
	assumes "\<alpha> \<noteq> \<top>"
	shows "flow_attainability \<Delta>'"
	proof -
	interpret \<Delta>': countable_network \<Delta>' using assms by(rule \<Delta>'_countable_network)
	show ?thesis
	proof
	show "d_IN (capacity \<Delta>') x \<noteq> \<top> \<or> d_OUT (capacity \<Delta>') x \<noteq> \<top>" if sink: "x \<noteq> sink \<Delta>'" for x
	proof(cases x)
	case (Inner x')
	consider (source) "x' = source \<Delta>" \| (IN) "x' \<noteq> source \<Delta>" "d_IN (capacity \<Delta>) x' \<noteq> \<top>" \| (OUT) "d_OUT (capacity \<Delta>) x' \<noteq> \<top>"
	using finite_capacity[of x'] sink Inner by(auto)
	thus ?thesis
	proof(cases)
	case source
	with Inner have "d_IN (capacity \<Delta>') x = (\<Sum>\<^sup>+ y. \<alpha> * indicator {SOURCE :: 'v node} y)"
	unfolding d_IN_def by(intro nn_integral_cong)(simp split: split_indicator)
	also have "\<dots> = \<alpha>" by(simp add: max_def)
	finally show ?thesis using assms by simp
	next
	case IN
	with Inner have "d_IN (capacity \<Delta>') x = (\<Sum>\<^sup>+ y\<in>range Inner. capacity \<Delta> (node.inner y, x'))"
	by(auto simp add: d_IN_def nn_integral_count_space_indicator not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_IN (capacity \<Delta>) x'" unfolding d_IN_def
	by(simp add: nn_integral_count_space_reindex)
	finally show ?thesis using Inner sink IN by(simp)
	next
	case OUT
	from Inner have "d_OUT (capacity \<Delta>') x = (\<Sum>\<^sup>+ y\<in>range Inner. capacity \<Delta> (x', node.inner y))"
	by(auto simp add: d_OUT_def nn_integral_count_space_indicator not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_OUT (capacity \<Delta>) x'" by(simp add: d_OUT_def nn_integral_count_space_reindex)
	finally show ?thesis using OUT by auto
	qed
	qed(simp add: d_IN_def)
	show "\<not> edge \<Delta>' x x" for x by(cases x)(simp_all add: no_loop)
	show "\<not> edge \<Delta>' x (source \<Delta>')" for x by simp
	qed
	qed

	private fun lift :: "'v flow \<Rightarrow> 'v node flow"
	where
	"lift f (SOURCE, Inner y) = (if y = source \<Delta> then value_flow \<Delta> f else 0)"
	\| "lift f (Inner x, Inner y) = f (x, y)"
	\| "lift f _ = 0"

	private lemma d_OUT_lift_Inner [simp]: "d_OUT (lift f) (Inner x) = d_OUT f x" (is "?lhs = ?rhs")
	proof -
	have "?lhs = (\<Sum>\<^sup>+ y\<in>range Inner. lift f (Inner x, y))"
	by(auto simp add: d_OUT_def nn_integral_count_space_indicator not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = ?rhs" by(simp add: nn_integral_count_space_reindex d_OUT_def)
	finally show ?thesis .
	qed

	private lemma d_OUT_lift_SOURCE [simp]: "d_OUT (lift f) SOURCE = value_flow \<Delta> f" (is "?lhs = ?rhs")
	proof -
	have "?lhs = (\<Sum>\<^sup>+ y. lift f (SOURCE, y) * indicator {Inner (source \<Delta>)} y)"
	unfolding d_OUT_def by(rule nn_integral_cong)(case_tac x; simp)
	also have "\<dots> = ?rhs" by(simp add: nn_integral_count_space_indicator max_def)
	finally show ?thesis .
	qed

	private lemma d_IN_lift_Inner [simp]:
	assumes "x \<noteq> source \<Delta>"
	shows "d_IN (lift f) (Inner x) = d_IN f x" (is "?lhs = ?rhs")
	proof -
	have "?lhs = (\<Sum>\<^sup>+ y\<in>range Inner. lift f (y, Inner x))" using assms
	by(auto simp add: d_IN_def nn_integral_count_space_indicator not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = ?rhs" by(simp add: nn_integral_count_space_reindex d_IN_def)
	finally show ?thesis .
	qed

	private lemma d_IN_lift_source [simp]: "d_IN (lift f) (Inner (source \<Delta>)) = value_flow \<Delta> f + d_IN f (source \<Delta>)" (is "?lhs = ?rhs")
	proof -
	have "?lhs = (\<Sum>\<^sup>+ y. lift f (y, Inner (source \<Delta>)) * indicator {SOURCE} y) + (\<Sum>\<^sup>+ y\<in>range Inner. lift f (y, Inner (source \<Delta>)))"
	(is "_ = ?SOURCE + ?rest")
	unfolding d_IN_def
	apply(subst nn_integral_count_space_indicator, simp)
	apply(subst nn_integral_add[symmetric])
	apply(auto simp add: AE_count_space max_def not_Inner_conv split: split_indicator intro!: nn_integral_cong)
	done
	also have "?rest = d_IN f (source \<Delta>)" by(simp add: nn_integral_count_space_reindex d_IN_def)
	also have "?SOURCE = value_flow \<Delta> f"
	by(simp add: max_def one_ennreal_def[symmetric] )
	finally show ?thesis .
	qed

	private lemma flow_lift [simp]:
	assumes "flow \<Delta> f"
	shows "flow \<Delta>' (lift f)"
	proof
	show "lift f e \<le> capacity \<Delta>' e" for e
	by(cases e rule: capacity'.cases)(auto intro: flowD_capacity[OF assms] simp add: \<alpha>_def intro: SUP_upper2 assms)

	fix x
	assume x: "x \<noteq> source \<Delta>'" "x \<noteq> sink \<Delta>'"
	then obtain x' where x': "x = Inner x'" by(cases x) auto
	then show "KIR (lift f) x" using x
	by(cases "x' = source \<Delta>")(auto simp add: flowD_source_IN[OF assms] dest: flowD_KIR[OF assms])
	qed

	private abbreviation (input) unlift :: "'v node flow \<Rightarrow> 'v flow"
	where "unlift f \<equiv> (\<lambda>(x, y). f (Inner x, Inner y))"

	private lemma flow_unlift [simp]:
	assumes f: "flow \<Delta>' f"
	shows "flow \<Delta> (unlift f)"
	proof
	show "unlift f e \<le> capacity \<Delta> e" for e using flowD_capacity[OF f, of "map_prod Inner Inner e"]
	by(cases e)(simp)
	next
	fix x
	assume x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	have "d_OUT (unlift f) x = (\<Sum>\<^sup>+ y\<in>range Inner. f (Inner x, y))"
	by(simp add: nn_integral_count_space_reindex d_OUT_def)
	also have "\<dots> = d_OUT f (Inner x)" using flowD_capacity[OF f, of "(Inner x, SOURCE)"]
	by(auto simp add: nn_integral_count_space_indicator d_OUT_def not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_IN f (Inner x)" using x flowD_KIR[OF f, of "Inner x"] by(simp)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. f (y, Inner x))"
	using x flowD_capacity[OF f, of "(SOURCE, Inner x)"]
	by(auto simp add: nn_integral_count_space_indicator d_IN_def not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_IN (unlift f) x" by(simp add: nn_integral_count_space_reindex d_IN_def)
	finally show "KIR (unlift f) x" .
	qed

	private lemma value_unlift:
	assumes f: "flow \<Delta>' f"
	shows "value_flow \<Delta> (unlift f) = value_flow \<Delta>' f"
	proof -
	have "value_flow \<Delta> (unlift f) = (\<Sum>\<^sup>+ y\<in>range Inner. f (Inner (source \<Delta>), y))"
	by(simp add: nn_integral_count_space_reindex d_OUT_def)
	also have "\<dots> = d_OUT f (Inner (source \<Delta>))" using flowD_capacity[OF f, of "(Inner (source \<Delta>), SOURCE)"]
	by(auto simp add: nn_integral_count_space_indicator d_OUT_def not_Inner_conv intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_IN f (Inner (source \<Delta>))" using flowD_KIR[OF f, of "Inner (source \<Delta>)"] by(simp)
	also have "\<dots> = (\<Sum>\<^sup>+ y. f (y, Inner (source \<Delta>)) * indicator {SOURCE} y)"
	unfolding d_IN_def using flowD_capacity[OF f, of "(x, Inner (source \<Delta>))" for x]
	by(intro nn_integral_cong)(auto intro!: antisym split: split_indicator if_split_asm elim: meta_allE)
	also have "\<dots> = f (SOURCE, Inner (source \<Delta>))" by simp
	also have "\<dots> = (\<Sum>\<^sup>+ y. f (SOURCE, y) * indicator {Inner (source \<Delta>)} y)"
	by(simp add: one_ennreal_def[symmetric])
	also have "\<dots> = value_flow \<Delta>' f" unfolding d_OUT_def
	unfolding d_OUT_def using flowD_capacity[OF f, of "(SOURCE, Inner x)" for x] flowD_capacity[OF f, of "(SOURCE, SOURCE)"]
	apply(intro nn_integral_cong)
	apply(case_tac x)
	apply(auto intro!: antisym split: split_indicator if_split_asm elim: meta_allE)
	done
	finally show ?thesis .
	qed

	theorem ex_max_flow:
	"\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = \<alpha> \<and> (\<forall>x. d_IN f x \<le> value_flow \<Delta> f)"
	proof(cases "\<alpha>")
	case (real \<alpha>')
	hence \<alpha>: "\<alpha> \<noteq> \<top>" by simp
	then interpret \<Delta>': flow_attainability \<Delta>' by(rule \<Delta>'_flow_attainability)

	have source_out: "edge \<Delta>' (source \<Delta>') y \<longleftrightarrow> y = Inner (source \<Delta>)" for y by(auto)
	have nontrivial: "\<^bold>E\<^bsub>\<Delta>'\<^esub> \<noteq> {}" by(auto intro: edge'.intros)

	have eq: "(SUP g \<in> {g. flow \<Delta>' g}. value_flow \<Delta>' g) = (SUP g \<in> {g. flow \<Delta> g}. value_flow \<Delta> g)" (is "?lhs = ?rhs")
	proof(intro antisym SUP_least; unfold mem_Collect_eq)
	fix g
	assume g: "flow \<Delta>' g"
	hence "value_flow \<Delta>' g = value_flow \<Delta> (unlift g)" by(simp add: value_unlift)
	also { from g have "flow \<Delta> (unlift g)" by simp }
	then have "\<dots> \<le> ?rhs" by(blast intro: SUP_upper2)
	finally show "value_flow \<Delta>' g \<le> \<dots>" .
	next
	fix g
	assume g: "flow \<Delta> g"
	hence "value_flow \<Delta> g = value_flow \<Delta>' (lift g)" by simp
	also { from g have "flow \<Delta>' (lift g)" by simp }
	then have "\<dots> \<le> ?lhs" by(blast intro: SUP_upper2)
	finally show "value_flow \<Delta> g \<le> ?lhs" .
	qed
	also have "\<dots> = ennreal \<alpha>'" using real by(simp add: \<alpha>_def)
	finally obtain f where f: "flow \<Delta>' f"
	and value_f: "value_flow \<Delta>' f = (\<Squnion>g\<in>{g. flow \<Delta>' g}. value_flow \<Delta>' g)"
	and IN_f: "\<And>x. d_IN f x \<le> value_flow \<Delta>' f"
	using \<open>0 \<le> \<alpha>'\<close> by(blast dest: \<Delta>'.ex_max_flow''[OF source_out nontrivial])
	have "flow \<Delta> (unlift f)" using f by simp
	moreover have "value_flow \<Delta> (unlift f) = \<alpha>" using f eq value_f by(simp add: value_unlift \<alpha>_def)
	moreover {
	fix x
	have "d_IN (unlift f) x = (\<Sum>\<^sup>+ y\<in>range Inner. f (y, Inner x))"
	by(simp add: nn_integral_count_space_reindex d_IN_def)
	also have "\<dots> \<le> d_IN f (Inner x)" unfolding d_IN_def
	by(auto intro!: nn_integral_mono simp add: nn_integral_count_space_indicator split: split_indicator)
	also have "\<dots> \<le> value_flow \<Delta> (unlift f)" using IN_f[of "Inner x"] f by(simp add: value_unlift)
	also note calculation }
	ultimately show ?thesis by blast
	next
	case top
	show ?thesis
	proof(cases "\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = \<top>")
	case True
	with top show ?thesis by auto
	next
	case False
	hence real: "\<forall>f. \<alpha> = \<top> \<longrightarrow> flow \<Delta> f \<longrightarrow> value_flow \<Delta> f < \<alpha>" using top by (auto simp: less_top)
	{ fix i
	have "2 * 2 ^ i < \<alpha>" using top by (simp_all add: ennreal_mult_less_top power_less_top_ennreal)
	from flow_by_value[OF this real] have "\<exists>f. flow \<Delta> f \<and> value_flow \<Delta> f = 2 * 2 ^ i" by blast }
	then obtain f_i where f_i: "\<And>i. flow \<Delta> (f_i i)"
	and value_i: "\<And>i. value_flow \<Delta> (f_i i) = 2 * 2 ^ i" by metis
	define f where "f e = (\<Sum>\<^sup>+ i. f_i i e / (2 * 2 ^ i))" for e
	have "flow \<Delta> f"
	proof
	fix e
	have "f e \<le> (\<Sum>\<^sup>+ i. (SUP i. f_i i e) / (2 * 2 ^ i))" unfolding f_def
	by(rule nn_integral_mono)(auto intro!: divide_right_mono_ennreal SUP_upper)
	also have "\<dots> = (SUP i. f_i i e) / 2 * (\<Sum>\<^sup>+ i. 1 / 2 ^ i)"
	apply(subst nn_integral_cmult[symmetric])
	apply(auto intro!: nn_integral_cong intro: SUP_upper2
	simp: divide_ennreal_def ennreal_inverse_mult power_less_top_ennreal mult_ac)
	done
	also have "(\<Sum>\<^sup>+ i. 1 / 2 ^ i) = (\<Sum>i. ennreal ((1 / 2) ^ i))"
	by(simp add: nn_integral_count_space_nat power_divide divide_ennreal[symmetric] ennreal_power[symmetric])
	also have "\<dots> = ennreal (\<Sum>i. (1 / 2) ^ i)"
	by(intro suminf_ennreal2 complete_algebra_summable_geometric) simp_all
	also have "\<dots> = 2" by(subst suminf_geometric; simp)
	also have "(SUP i. f_i i e) / 2 * 2 = (SUP i. f_i i e)"
	by (simp add: ennreal_divide_times)
	also have "\<dots> \<le> capacity \<Delta> e" by(rule SUP_least)(rule flowD_capacity[OF f_i])
	finally show "f e \<le> capacity \<Delta> e" .

	fix x
	assume x: "x \<noteq> source \<Delta>" "x \<noteq> sink \<Delta>"
	have "d_OUT f x = (\<Sum>\<^sup>+ i\<in>UNIV. \<Sum>\<^sup>+ y. f_i i (x, y) / (2 * 2 ^ i))"
	unfolding d_OUT_def f_def
	by(subst nn_integral_snd_count_space[where f="case_prod _", simplified])
	(simp add: nn_integral_fst_count_space[where f="case_prod _", simplified])
	also have "\<dots> = (\<Sum>\<^sup>+ i. d_OUT (f_i i) x / (2 * 2 ^ i))" unfolding d_OUT_def
	by(simp add: nn_integral_divide)
	also have "\<dots> = (\<Sum>\<^sup>+ i. d_IN (f_i i) x / (2 * 2 ^ i))" by(simp add: flowD_KIR[OF f_i, OF x])
	also have "\<dots> = (\<Sum>\<^sup>+ i\<in>UNIV. \<Sum>\<^sup>+ y. f_i i (y, x) / (2 * 2 ^ i))"
	by(simp add: nn_integral_divide d_IN_def)
	also have "\<dots> = d_IN f x" unfolding d_IN_def f_def
	by(subst nn_integral_snd_count_space[where f="case_prod _", simplified])
	(simp add: nn_integral_fst_count_space[where f="case_prod _", simplified])
	finally show "KIR f x" .
	qed
	moreover {
	have "value_flow \<Delta> f = (\<Sum>\<^sup>+ i. value_flow \<Delta> (f_i i) / (2 * 2 ^ i))"
	unfolding d_OUT_def f_def
	by(subst nn_integral_snd_count_space[where f="case_prod _", simplified])
	(simp add: nn_integral_fst_count_space[where f="case_prod _", simplified] nn_integral_divide[symmetric])
	also have "\<dots> = \<top>"
	by(simp add: value_i ennreal_mult_less_top power_less_top_ennreal)
	finally have "value_flow \<Delta> f = \<top>" .
	}
	ultimately show ?thesis using top by auto
	qed
	qed

	end

	end

	end

	end
	\ No newline at end of file
	diff --git a/thys/MFMC_Countable/MFMC_Unbounded.thy b/thys/MFMC_Countable/MFMC_Unbounded.thy
	--- a/thys/MFMC_Countable/MFMC_Unbounded.thy
	+++ b/thys/MFMC_Countable/MFMC_Unbounded.thy
	@@ -1,3467 +1,3467 @@
	(* Author: Andreas Lochbihler, ETH Zurich *)

	section \<open>The max-flow min-cut theorems in unbounded networks\<close>

	theory MFMC_Unbounded imports
	MFMC_Web
	MFMC_Flow_Attainability
	MFMC_Reduction
	begin

	subsection \<open>More about waves\<close>

	lemma SINK_plus_current: "SINK (plus_current f g) = SINK f \<inter> SINK g"
	by(auto simp add: SINK.simps set_eq_iff d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0 add_eq_0_iff_both_eq_0)

	abbreviation plus_web :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v current \<Rightarrow> 'v current" ("_ \<frown>\<index> _" [66, 66] 65)
	where "plus_web \<Gamma> f g \<equiv> plus_current f (g \<upharpoonleft> \<Gamma> / f)"

	lemma d_OUT_plus_web:
	fixes \<Gamma> (structure)
	shows "d_OUT (f \<frown> g) x = d_OUT f x + d_OUT (g \<upharpoonleft> \<Gamma> / f) x" (is "?lhs = ?rhs")
	proof -
	have "?lhs = d_OUT f x + (\<Sum>\<^sup>+ y. (if x \<in> RF\<^sup>\<circ> (TER f) then 0 else g (x, y) * indicator (- RF (TER f)) y))"
	unfolding d_OUT_def by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = ?rhs" by(auto simp add: d_OUT_def intro!: arg_cong2[where f="(+)"] nn_integral_cong)
	finally show "?thesis" .
	qed

	lemma d_IN_plus_web:
	fixes \<Gamma> (structure)
	shows "d_IN (f \<frown> g) y = d_IN f y + d_IN (g \<upharpoonleft> \<Gamma> / f) y" (is "?lhs = ?rhs")
	proof -
	have "?lhs = d_IN f y + (\<Sum>\<^sup>+ x. (if y \<in> RF (TER f) then 0 else g (x, y) * indicator (- RF\<^sup>\<circ> (TER f)) x))"
	unfolding d_IN_def by(subst nn_integral_add[symmetric])(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = ?rhs" by(auto simp add: d_IN_def intro!: arg_cong2[where f="(+)"] nn_integral_cong)
	finally show ?thesis .
	qed

	lemma plus_web_greater: "f e \<le> (f \<frown>\<^bsub>\<Gamma>\<^esub> g) e"
	by(cases e)(auto split: split_indicator)

	lemma current_plus_web:
	fixes \<Gamma> (structure)
	shows "\<lbrakk> current \<Gamma> f; wave \<Gamma> f; current \<Gamma> g \<rbrakk> \<Longrightarrow> current \<Gamma> (f \<frown> g)"
	by(blast intro: current_plus_current current_restrict_current)

	context
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure)
	and f g :: "'v current"
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	begin

	context
	fixes x :: "'v"
	assumes x: "x \<in> \<E> (TER f \<union> TER g)"
	begin

	qualified lemma RF_f: "x \<notin> RF\<^sup>\<circ> (TER f)"
	proof
	assume *: "x \<in> RF\<^sup>\<circ> (TER f)"

	from x obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. \<lbrakk>x \<noteq> y; z \<in> set p\<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> TER f \<union> TER g" by(rule \<E>_E) blast
	from rtrancl_path_distinct[OF p] obtain p'
	where p: "path \<Gamma> x p' y" and p': "set p' \<subseteq> set p" and distinct: "distinct (x # p')" .

	from * have x': "x \<in> RF (TER f)" and \<E>: "x \<notin> \<E> (TER f)" by(auto simp add: roofed_circ_def)
	hence "x \<notin> TER f" using not_essentialD[OF _ p y] p' bypass by blast
	with roofedD[OF x' p y] obtain z where z: "z \<in> set p'" "z \<in> TER f" by auto
	with p have "y \<in> set p'" by(auto dest!: rtrancl_path_last intro: last_in_set)
	with distinct have "x \<noteq> y" by auto
	with bypass z p' distinct show False by auto
	qed

	private lemma RF_g: "x \<notin> RF\<^sup>\<circ> (TER g)"
	proof
	assume *: "x \<in> RF\<^sup>\<circ> (TER g)"

	from x obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. \<lbrakk>x \<noteq> y; z \<in> set p\<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> TER f \<union> TER g" by(rule \<E>_E) blast
	from rtrancl_path_distinct[OF p] obtain p'
	where p: "path \<Gamma> x p' y" and p': "set p' \<subseteq> set p" and distinct: "distinct (x # p')" .

	from * have x': "x \<in> RF (TER g)" and \<E>: "x \<notin> \<E> (TER g)" by(auto simp add: roofed_circ_def)
	hence "x \<notin> TER g" using not_essentialD[OF _ p y] p' bypass by blast
	with roofedD[OF x' p y] obtain z where z: "z \<in> set p'" "z \<in> TER g" by auto
	with p have "y \<in> set p'" by(auto dest!: rtrancl_path_last intro: last_in_set)
	with distinct have "x \<noteq> y" by auto
	with bypass z p' distinct show False by auto
	qed

	lemma TER_plus_web_aux:
	assumes SINK: "x \<in> SINK (g \<upharpoonleft> \<Gamma> / f)" (is "_ \<in> SINK ?g")
	shows "x \<in> TER (f \<frown> g)"
	proof
	from x obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. \<lbrakk>x \<noteq> y; z \<in> set p\<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> TER f \<union> TER g" by(rule \<E>_E) blast
	from rtrancl_path_distinct[OF p] obtain p'
	where p: "path \<Gamma> x p' y" and p': "set p' \<subseteq> set p" and distinct: "distinct (x # p')" .

	from RF_f have "x \<in> SINK f"
	by(auto simp add: roofed_circ_def SINK.simps dest: waveD_OUT[OF w])
	thus "x \<in> SINK (f \<frown> g)" using SINK
	by(simp add: SINK.simps d_OUT_plus_web)
	show "x \<in> SAT \<Gamma> (f \<frown> g)"
	proof(cases "x \<in> TER f")
	case True
	hence "x \<in> SAT \<Gamma> f" by simp
	moreover have "\<dots> \<subseteq> SAT \<Gamma> (f \<frown> g)" by(rule SAT_mono plus_web_greater)+
	ultimately show ?thesis by blast
	next
	case False
	with x have "x \<in> TER g" by auto
	from False RF_f have "x \<notin> RF (TER f)" by(auto simp add: roofed_circ_def)
	moreover { fix z
	assume z: "z \<in> RF\<^sup>\<circ> (TER f)"
	have "(z, x) \<notin> \<^bold>E"
	proof
	assume "(z, x) \<in> \<^bold>E"
	hence path': "path \<Gamma> z (x # p') y" using p by(simp add: rtrancl_path.step)
	from z have "z \<in> RF (TER f)" by(simp add: roofed_circ_def)
	from roofedD[OF this path' y] False
	consider (path) z' where "z' \<in> set p'" "z' \<in> TER f" \| (TER) "z \<in> TER f" by auto
	then show False
	proof cases
	{ case (path z')
	with p distinct have "x \<noteq> y"
	by(auto 4 3 intro: last_in_set elim: rtrancl_path.cases dest: rtrancl_path_last[symmetric])
	from bypass[OF this, of z'] path False p' show False by auto }
	note that = this
	case TER
	with z have "\<not> essential \<Gamma> (B \<Gamma>) (TER f) z" by(simp add: roofed_circ_def)
	from not_essentialD[OF this path' y] False obtain z' where "z' \<in> set p'" "z' \<in> TER f" by auto
	thus False by(rule that)
	qed
	qed }
	ultimately have "d_IN ?g x = d_IN g x" unfolding d_IN_def
	by(intro nn_integral_cong)(clarsimp split: split_indicator simp add: currentD_outside[OF g])
	hence "d_IN (f \<frown> g) x \<ge> d_IN g x"
	by(simp add: d_IN_plus_web)
	with \<open>x \<in> TER g\<close> show ?thesis by(auto elim!: SAT.cases intro: SAT.intros)
	qed
	qed

	qualified lemma SINK_TER_in'':
	assumes "\<And>x. x \<notin> RF (TER g) \<Longrightarrow> d_OUT g x = 0"
	shows "x \<in> SINK g"
	using RF_g by(auto simp add: roofed_circ_def SINK.simps assms)

	end

	lemma wave_plus: "wave (quotient_web \<Gamma> f) (g \<upharpoonleft> \<Gamma> / f) \<Longrightarrow> wave \<Gamma> (f \<frown> g)"
	using f w by(rule wave_plus_current)(rule current_restrict_current[OF w g])

	lemma TER_plus_web'':
	assumes "\<And>x. x \<notin> RF (TER g) \<Longrightarrow> d_OUT g x = 0"
	shows "\<E> (TER f \<union> TER g) \<subseteq> TER (f \<frown> g)"
	proof
	fix x
	assume *: "x \<in> \<E> (TER f \<union> TER g)"
	moreover have "x \<in> SINK (g \<upharpoonleft> \<Gamma> / f)"
	by(rule in_SINK_restrict_current)(rule MFMC_Unbounded.SINK_TER_in''[OF f w g * assms])
	ultimately show "x \<in> TER (f \<frown> g)" by(rule TER_plus_web_aux)
	qed

	lemma TER_plus_web': "wave \<Gamma> g \<Longrightarrow> \<E> (TER f \<union> TER g) \<subseteq> TER (f \<frown> g)"
	by(rule TER_plus_web'')(rule waveD_OUT)

	lemma wave_plus': "wave \<Gamma> g \<Longrightarrow> wave \<Gamma> (f \<frown> g)"
	by(rule wave_plus)(rule wave_restrict_current[OF f w g])

	end

	lemma RF_TER_plus_web:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	and w': "wave \<Gamma> g"
	shows "RF (TER (f \<frown> g)) = RF (TER f \<union> TER g)"
	proof
	have "RF (\<E> (TER f \<union> TER g)) \<subseteq> RF (TER (f \<frown> g))"
	by(rule roofed_mono)(rule TER_plus_web'[OF f w g w'])
	also have "RF (\<E> (TER f \<union> TER g)) = RF (TER f \<union> TER g)" by(rule RF_essential)
	finally show "\<dots> \<subseteq> RF (TER (f \<frown> g))" .
	next
	have fg: "current \<Gamma> (f \<frown> g)" using f w g by(rule current_plus_web)
	show "RF (TER (f \<frown> g)) \<subseteq> RF (TER f \<union> TER g)"
	proof(intro subsetI roofedI)
	fix x p y
	assume RF: "x \<in> RF (TER (f \<frown> g))" and p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from roofedD[OF RF p y] obtain z where z: "z \<in> set (x # p)" and TER: "z \<in> TER (f \<frown> g)" by auto
	from TER have SINK: "z \<in> SINK f"
	by(auto simp add: SINK.simps d_OUT_plus_web add_eq_0_iff_both_eq_0)
	from TER have "z \<in> SAT \<Gamma> (f \<frown> g)" by simp
	hence SAT: "z \<in> SAT \<Gamma> f \<union> SAT \<Gamma> g"
	by(cases "z \<in> RF (TER f)")(auto simp add: currentD_SAT[OF f] currentD_SAT[OF g] currentD_SAT[OF fg] d_IN_plus_web d_IN_restrict_current_outside restrict_current_IN_not_RF[OF g] wave_not_RF_IN_zero[OF f w])

	show "(\<exists>z\<in>set p. z \<in> TER f \<union> TER g) \<or> x \<in> TER f \<union> TER g"
	proof(cases "z \<in> RF (TER g)")
	case False
	hence "z \<in> SINK g" by(simp add: SINK.simps waveD_OUT[OF w'])
	with SINK SAT have "z \<in> TER f \<union> TER g" by auto
	thus ?thesis using z by auto
	next
	case True
	from split_list[OF z] obtain ys zs where split: "x # p = ys @ z # zs" by blast
	with p have "path \<Gamma> z zs y" by(auto elim: rtrancl_path_appendE simp add: Cons_eq_append_conv)
	from roofedD[OF True this y] split show ?thesis by(auto simp add: Cons_eq_append_conv)
	qed
	qed
	qed

	lemma RF_TER_Sup:
	fixes \<Gamma> (structure)
	assumes f: "\<And>f. f \<in> Y \<Longrightarrow> current \<Gamma> f"
	and w: "\<And>f. f \<in> Y \<Longrightarrow> wave \<Gamma> f"
	and Y: "Complete_Partial_Order.chain (\<le>) Y" "Y \<noteq> {}" "countable (support_flow (Sup Y))"
	shows "RF (TER (Sup Y)) = RF (\<Union>f\<in>Y. TER f)"
	proof(rule set_eqI iffI)+
	fix x
	assume x: "x \<in> RF (TER (Sup Y))"
	have "x \<in> RF (RF (\<Union>f\<in>Y. TER f))"
	proof
	fix p y
	assume p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from roofedD[OF x p y] obtain z where z: "z \<in> set (x # p)" and TER: "z \<in> TER (Sup Y)" by auto
	from TER have SINK: "z \<in> SINK f" if "f \<in> Y" for f using that by(auto simp add: SINK_Sup[OF Y])

	from Y(2) obtain f where y: "f \<in> Y" by blast

	show "(\<exists>z\<in>set p. z \<in> RF (\<Union>f\<in>Y. TER f)) \<or> x \<in> RF (\<Union>f\<in>Y. TER f)"
	proof(cases "\<exists>f\<in>Y. z \<in> RF (TER f)")
	case True
	then obtain f where fY: "f \<in> Y" and zf: "z \<in> RF (TER f)" by blast
	from zf have "z \<in> RF (\<Union>f\<in>Y. TER f)" by(rule in_roofed_mono)(auto intro: fY)
	with z show ?thesis by auto
	next
	case False
	hence *: "d_IN f z = 0" if "f \<in> Y" for f using that by(auto intro: wave_not_RF_IN_zero[OF f w])
	hence "d_IN (Sup Y) z = 0" using Y(2) by(simp add: d_IN_Sup[OF Y])
	with TER have "z \<in> SAT \<Gamma> f" using *[OF y]
	by(simp add: SAT.simps)
	with SINK[OF y] have "z \<in> TER f" by simp
	with z y show ?thesis by(auto intro: roofed_greaterI)
	qed
	qed
	then show "x \<in> RF (\<Union>f\<in>Y. TER f)" unfolding roofed_idem .
	next
	fix x
	assume x: "x \<in> RF (\<Union>f\<in>Y. TER f)"
	have "x \<in> RF (RF (TER (\<Squnion>Y)))"
	proof(rule roofedI)
	fix p y
	assume p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from roofedD[OF x p y] obtain z f where *: "z \<in> set (x # p)"
	and **: "f \<in> Y" and TER: "z \<in> TER f" by auto
	have "z \<in> RF (TER (Sup Y))"
	proof(rule ccontr)
	assume z: "z \<notin> RF (TER (Sup Y))"
	have "wave \<Gamma> (Sup Y)" using Y(1-2) w Y(3) by(rule wave_lub)
	hence "d_OUT (Sup Y) z = 0" using z by(rule waveD_OUT)
	hence "z \<in> SINK (Sup Y)" by(simp add: SINK.simps)
	moreover have "z \<in> SAT \<Gamma> (Sup Y)" using TER SAT_Sup_upper[OF **, of \<Gamma>] by blast
	ultimately have "z \<in> TER (Sup Y)" by simp
	hence "z \<in> RF (TER (Sup Y))" by(rule roofed_greaterI)
	with z show False by contradiction
	qed
	thus "(\<exists>z\<in>set p. z \<in> RF (TER (Sup Y))) \<or> x \<in> RF (TER (Sup Y))" using * by auto
	qed
	then show "x \<in> RF (TER (\<Squnion>Y))" unfolding roofed_idem .
	qed

	subsection \<open>Hindered webs with reduced weights\<close>

	context countable_bipartite_web begin

	context
	fixes u :: "'v \<Rightarrow> ennreal"
	and \<epsilon>
	defines "\<epsilon> \<equiv> (\<integral>\<^sup>+ y. u y \<partial>count_space (B \<Gamma>))"
	assumes u_outside: "\<And>x. x \<notin> B \<Gamma> \<Longrightarrow> u x = 0"
	and finite_\<epsilon>: "\<epsilon> \<noteq> \<top>"
	begin

	private lemma u_A: "x \<in> A \<Gamma> \<Longrightarrow> u x = 0"
	using u_outside[of x] disjoint by auto

	private lemma u_finite: "u y \<noteq> \<top>"
	proof(cases "y \<in> B \<Gamma>")
	case True
	have "u y \<le> \<epsilon>" unfolding \<epsilon>_def by(rule nn_integral_ge_point)(simp add: True)
	also have "\<dots> < \<top>" using finite_\<epsilon> by (simp add: less_top[symmetric])
	finally show ?thesis by simp
	qed(simp add: u_outside)

	lemma hindered_reduce: \<comment> \<open>Lemma 6.7\<close>
	assumes u: "u \<le> weight \<Gamma>"
	assumes hindered_by: "hindered_by (\<Gamma>\<lparr>weight := weight \<Gamma> - u\<rparr>) \<epsilon>" (is "hindered_by ?\<Gamma> _")
	shows "hindered \<Gamma>"
	proof -
	note [simp] = u_finite
	let ?TER = "TER\<^bsub>?\<Gamma>\<^esub>"
	from hindered_by obtain f
	where hindrance_by: "hindrance_by ?\<Gamma> f \<epsilon>"
	and f: "current ?\<Gamma> f"
	and w: "wave ?\<Gamma> f" by cases
	from hindrance_by obtain a where a: "a \<in> A \<Gamma>" "a \<notin> \<E>\<^bsub>?\<Gamma>\<^esub> (?TER f)"
	and a_le: "d_OUT f a < weight \<Gamma> a"
	and \<epsilon>_less: "weight \<Gamma> a - d_OUT f a > \<epsilon>"
	and \<epsilon>_nonneg: "\<epsilon> \<ge> 0" by(auto simp add: u_A hindrance_by.simps)

	from f have f': "current \<Gamma> f" by(rule current_weight_mono)(auto intro: diff_le_self_ennreal)

	write Some ("\<langle>_\<rangle>")

	define edge'
	where "edge' xo yo =
	(case (xo, yo) of
	(None, Some y) \<Rightarrow> y \<in> \<^bold>V \<and> y \<notin> A \<Gamma>
	\| (Some x, Some y) \<Rightarrow> edge \<Gamma> x y \<or> edge \<Gamma> y x
	\| _ \<Rightarrow> False)" for xo yo
	define cap
	where "cap e =
	(case e of
	(None, Some y) \<Rightarrow> if y \<in> \<^bold>V then u y else 0
	\| (Some x, Some y) \<Rightarrow> if edge \<Gamma> x y \<and> x \<noteq> a then f (x, y) else if edge \<Gamma> y x then max (weight \<Gamma> x) (weight \<Gamma> y) + 1 else 0
	\| _ \<Rightarrow> 0)" for e
	define \<Psi> where "\<Psi> = \<lparr>edge = edge', capacity = cap, source = None, sink = Some a\<rparr>"

	have edge'_simps [simp]:
	"edge' None \<langle>y\<rangle> \<longleftrightarrow> y \<in> \<^bold>V \<and> y \<notin> A \<Gamma>"
	"edge' xo None \<longleftrightarrow> False"
	"edge' \<langle>x\<rangle> \<langle>y\<rangle> \<longleftrightarrow> edge \<Gamma> x y \<or> edge \<Gamma> y x"
	for xo x y by(simp_all add: edge'_def split: option.split)

	have edge_None1E [elim!]: thesis if "edge' None y" "\<And>z. \<lbrakk> y = \<langle>z\<rangle>; z \<in> \<^bold>V; z \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis" for y thesis
	using that by(simp add: edge'_def split: option.split_asm sum.split_asm)
	have edge_Some1E [elim!]: thesis if "edge' \<langle>x\<rangle> y" "\<And>z. \<lbrakk> y = \<langle>z\<rangle>; edge \<Gamma> x z \<or> edge \<Gamma> z x \<rbrakk> \<Longrightarrow> thesis" for x y thesis
	using that by(simp add: edge'_def split: option.split_asm sum.split_asm)
	have edge_Some2E [elim!]: thesis if "edge' x \<langle>y\<rangle>" "\<lbrakk> x = None; y \<in> \<^bold>V; y \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis" "\<And>z. \<lbrakk> x = \<langle>z\<rangle>; edge \<Gamma> z y \<or> edge \<Gamma> y z \<rbrakk> \<Longrightarrow> thesis" for x y thesis
	using that by(simp add: edge'_def split: option.split_asm sum.split_asm)

	have cap_simps [simp]:
	"cap (None, \<langle>y\<rangle>) = (if y \<in> \<^bold>V then u y else 0)"
	"cap (xo, None) = 0"
	"cap (\<langle>x\<rangle>, \<langle>y\<rangle>) =
	(if edge \<Gamma> x y \<and> x \<noteq> a then f (x, y) else if edge \<Gamma> y x then max (weight \<Gamma> x) (weight \<Gamma> y) + 1 else 0)"
	for xo x y by(simp_all add: cap_def split: option.split)

	have \<Psi>_sel [simp]:
	"edge \<Psi> = edge'"
	"capacity \<Psi> = cap"
	"source \<Psi> = None"
	"sink \<Psi> = \<langle>a\<rangle>"
	by(simp_all add: \<Psi>_def)

	have cap_outside1: "\<not> vertex \<Gamma> x \<Longrightarrow> cap (\<langle>x\<rangle>, y) = 0" for x y
	by(cases y)(auto simp add: vertex_def)
	have capacity_A_weight: "d_OUT cap \<langle>x\<rangle> \<le> weight \<Gamma> x" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_OUT cap \<langle>x\<rangle> \<le> (\<Sum>\<^sup>+ y\<in>range Some. f (x, the y))"
	using that disjoint a(1) unfolding d_OUT_def
	by(auto 4 4 intro!: nn_integral_mono simp add: nn_integral_count_space_indicator notin_range_Some currentD_outside[OF f] split: split_indicator dest: edge_antiparallel bipartite_E)
	also have "\<dots> = d_OUT f x" by(simp add: d_OUT_def nn_integral_count_space_reindex)
	also have "\<dots> \<le> weight \<Gamma> x" using f' by(rule currentD_weight_OUT)
	finally show ?thesis .
	qed
	have flow_attainability: "flow_attainability \<Psi>"
	proof
	have "\<^bold>E\<^bsub>\<Psi>\<^esub> = (\<lambda>(x, y). (\<langle>x\<rangle>, \<langle>y\<rangle>)) ` \<^bold>E \<union> (\<lambda>(x, y). (\<langle>y\<rangle>, \<langle>x\<rangle>)) ` \<^bold>E \<union> (\<lambda>x. (None, \<langle>x\<rangle>)) ` (\<^bold>V \<inter> - A \<Gamma>)"
	by(auto simp add: edge'_def split: option.split_asm)
	thus "countable \<^bold>E\<^bsub>\<Psi>\<^esub>" by simp
	next
	fix v
	assume "v \<noteq> sink \<Psi>"
	consider (sink) "v = None" \| (A) x where "v = \<langle>x\<rangle>" "x \<in> A \<Gamma>"
	\| (B) y where "v = \<langle>y\<rangle>" "y \<notin> A \<Gamma>" "y \<in> \<^bold>V" \| (outside) x where "v = \<langle>x\<rangle>" "x \<notin> \<^bold>V"
	by(cases v) auto
	then show "d_IN (capacity \<Psi>) v \<noteq> \<top> \<or> d_OUT (capacity \<Psi>) v \<noteq> \<top>"
	proof cases
	case sink thus ?thesis by(simp add: d_IN_def)
	next
	case (A x)
	thus ?thesis using capacity_A_weight[of x] by (auto simp: top_unique)
	next
	case (B y)
	have "d_IN (capacity \<Psi>) v \<le> (\<Sum>\<^sup>+ x. f (the x, y) * indicator (range Some) x + u y * indicator {None} x)"
	using B disjoint bipartite_V a(1) unfolding d_IN_def
	by(auto 4 4 intro!: nn_integral_mono simp add: nn_integral_count_space_indicator notin_range_Some currentD_outside[OF f] split: split_indicator dest: edge_antiparallel bipartite_E)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>range Some. f (the x, y)) + u y"
	by(subst nn_integral_add)(simp_all add: nn_integral_count_space_indicator)
	also have "\<dots> = d_IN f y + u y" by(simp add: d_IN_def nn_integral_count_space_reindex)
	also have "d_IN f y \<le> weight \<Gamma> y" using f' by(rule currentD_weight_IN)
	finally show ?thesis by(auto simp add: add_right_mono top_unique split: if_split_asm)
	next
	case outside
	hence "d_OUT (capacity \<Psi>) v = 0"
	by(auto simp add: d_OUT_def nn_integral_0_iff_AE AE_count_space cap_def vertex_def split: option.split)
	thus ?thesis by simp
	qed
	next
	show "capacity \<Psi> e \<noteq> \<top>" for e using weight_finite
	by(auto simp add: cap_def max_def vertex_def currentD_finite[OF f'] split: option.split prod.split simp del: weight_finite)
	show "capacity \<Psi> e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Psi>\<^esub>" for e
	using that bipartite_V disjoint
	by(auto simp add: cap_def max_def intro: u_outside split: option.split prod.split)
	show "\<not> edge \<Psi> x (source \<Psi>)" for x by simp
	show "\<not> edge \<Psi> x x" for x by(cases x)(simp_all add: no_loop)
	show "source \<Psi> \<noteq> sink \<Psi>" by simp
	qed
	then interpret \<Psi>: flow_attainability "\<Psi>" .

	define \<alpha> where "\<alpha> = (\<Squnion>g\<in>{g. flow \<Psi> g}. value_flow \<Psi> g)"
	have \<alpha>_le: "\<alpha> \<le> \<epsilon>"
	proof -
	have "\<alpha> \<le> d_OUT cap None" unfolding \<alpha>_def by(rule SUP_least)(auto intro!: d_OUT_mono dest: flowD_capacity)
	also have "\<dots> \<le> \<integral>\<^sup>+ y. cap (None, y) \<partial>count_space (range Some)" unfolding d_OUT_def
	by(auto simp add: nn_integral_count_space_indicator notin_range_Some intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> \<le> \<epsilon>" unfolding \<epsilon>_def
	by (subst (2) nn_integral_count_space_indicator, auto simp add: nn_integral_count_space_reindex u_outside intro!: nn_integral_mono split: split_indicator)
	finally show ?thesis by simp
	qed
	then have finite_flow: "\<alpha> \<noteq> \<top>" using finite_\<epsilon> by (auto simp: top_unique)

	from \<Psi>.ex_max_flow
	obtain j where j: "flow \<Psi> j"
	and value_j: "value_flow \<Psi> j = \<alpha>"
	and IN_j: "\<And>x. d_IN j x \<le> \<alpha>"
	unfolding \<alpha>_def by auto

	have j_le_f: "j (Some x, Some y) \<le> f (x, y)" if "edge \<Gamma> x y" for x y
	using that flowD_capacity[OF j, of "(Some x, Some y)"] a(1) disjoint
	by(auto split: if_split_asm dest: bipartite_E intro: order_trans)

	have IN_j_finite [simp]: "d_IN j x \<noteq> \<top>" for x using finite_flow by(rule neq_top_trans)(simp add: IN_j)

	have j_finite[simp]: "j (x, y) < \<top>" for x y
	by (rule le_less_trans[OF d_IN_ge_point]) (simp add: IN_j_finite[of y] less_top[symmetric])

	have OUT_j_finite: "d_OUT j x \<noteq> \<top>" for x
	proof(cases "x = source \<Psi> \<or> x = sink \<Psi>")
	case True thus ?thesis
	proof cases
	case left thus ?thesis using finite_flow value_j by simp
	next
	case right
	have "d_OUT (capacity \<Psi>) \<langle>a\<rangle> \<noteq> \<top>" using capacity_A_weight[of a] a(1) by(auto simp: top_unique)
	thus ?thesis unfolding right[simplified]
	by(rule neq_top_trans)(rule d_OUT_mono flowD_capacity[OF j])+
	qed
	next
	case False then show ?thesis by(simp add: flowD_KIR[OF j])
	qed

	have IN_j_le_weight: "d_IN j \<langle>x\<rangle> \<le> weight \<Gamma> x" for x
	proof(cases "x \<in> A \<Gamma>")
	case xA: True
	show ?thesis
	proof(cases "x = a")
	case True
	have "d_IN j \<langle>x\<rangle> \<le> \<alpha>" by(rule IN_j)
	also have "\<dots> \<le> \<epsilon>" by(rule \<alpha>_le)
	also have "\<epsilon> < weight \<Gamma> a" using \<epsilon>_less diff_le_self_ennreal less_le_trans by blast
	finally show ?thesis using True by(auto intro: order.strict_implies_order)
	next
	case False
	have "d_IN j \<langle>x\<rangle> = d_OUT j \<langle>x\<rangle>" using flowD_KIR[OF j, of "Some x"] False by simp
	also have "\<dots> \<le> d_OUT cap \<langle>x\<rangle>" using flowD_capacity[OF j] by(auto intro: d_OUT_mono)
	also have "\<dots> \<le> weight \<Gamma> x" using xA by(rule capacity_A_weight)
	finally show ?thesis .
	qed
	next
	case xA: False
	show ?thesis
	proof(cases "x \<in> B \<Gamma>")
	case True
	have "d_IN j \<langle>x\<rangle> \<le> d_IN cap \<langle>x\<rangle>" using flowD_capacity[OF j] by(auto intro: d_IN_mono)
	also have "\<dots> \<le> (\<Sum>\<^sup>+ z. f (the z, x) * indicator (range Some) z) + (\<Sum>\<^sup>+ z :: 'v option. u x * indicator {None} z)"
	using True disjoint
	by(subst nn_integral_add[symmetric])(auto simp add: vertex_def currentD_outside[OF f] d_IN_def B_out intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> = d_IN f x + u x"
	by(simp add: nn_integral_count_space_indicator[symmetric] nn_integral_count_space_reindex d_IN_def)
	also have "\<dots> \<le> weight \<Gamma> x" using currentD_weight_IN[OF f, of x] u_finite[of x]
	using \<epsilon>_less u by (auto simp add: ennreal_le_minus_iff le_fun_def)
	finally show ?thesis .
	next
	case False
	with xA have "x \<notin> \<^bold>V" using bipartite_V by blast
	then have "d_IN j \<langle>x\<rangle> = 0" using False
	by(auto simp add: d_IN_def nn_integral_0_iff emeasure_count_space_eq_0 vertex_def edge'_def split: option.split_asm intro!: \<Psi>.flowD_outside[OF j])
	then show ?thesis
	by simp
	qed
	qed

	let ?j = "j \<circ> map_prod Some Some \<circ> prod.swap"

	have finite_j_OUT: "(\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. j (\<langle>x\<rangle>, \<langle>y\<rangle>)) \<noteq> \<top>" (is "?j_OUT \<noteq> _") if "x \<in> A \<Gamma>" for x
	using currentD_finite_OUT[OF f', of x]
	by(rule neq_top_trans)(auto intro!: nn_integral_mono j_le_f simp add: d_OUT_def nn_integral_count_space_indicator outgoing_def split: split_indicator)
	have j_OUT_eq: "?j_OUT x = d_OUT j \<langle>x\<rangle>" if "x \<in> A \<Gamma>" for x
	proof -
	have "?j_OUT x = (\<Sum>\<^sup>+ y\<in>range Some. j (Some x, y))" using that disjoint
	by(simp add: nn_integral_count_space_reindex)(auto 4 4 simp add: nn_integral_count_space_indicator outgoing_def intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] dest: bipartite_E split: split_indicator)
	also have "\<dots> = d_OUT j \<langle>x\<rangle>"
	by(auto simp add: d_OUT_def nn_integral_count_space_indicator notin_range_Some intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] split: split_indicator)
	finally show ?thesis .
	qed

	define g where "g = f \<oplus> ?j"
	have g_simps: "g (x, y) = (f \<oplus> ?j) (x, y)" for x y by(simp add: g_def)

	have OUT_g_A: "d_OUT g x = d_OUT f x + d_IN j \<langle>x\<rangle> - d_OUT j \<langle>x\<rangle>" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_OUT g x = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. f (x, y) + j (\<langle>y\<rangle>, \<langle>x\<rangle>) - j (\<langle>x\<rangle>, \<langle>y\<rangle>))"
	by(auto simp add: d_OUT_def g_simps currentD_outside[OF f'] outgoing_def nn_integral_count_space_indicator intro!: nn_integral_cong)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. f (x, y) + j (\<langle>y\<rangle>, \<langle>x\<rangle>)) - (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. j (\<langle>x\<rangle>, \<langle>y\<rangle>))"
	(is "_ = _ - ?j_OUT") using finite_j_OUT[OF that]
	by(subst nn_integral_diff)(auto simp add: AE_count_space outgoing_def intro!: order_trans[OF j_le_f])
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. f (x, y)) + (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. j (Some y, Some x)) - ?j_OUT"
	(is "_ = ?f + ?j_IN - _") by(subst nn_integral_add) simp_all
	also have "?f = d_OUT f x" by(subst d_OUT_alt_def[where G=\<Gamma>])(simp_all add: currentD_outside[OF f])
	also have "?j_OUT = d_OUT j \<langle>x\<rangle>" using that by(rule j_OUT_eq)
	also have "?j_IN = (\<Sum>\<^sup>+ y\<in>range Some. j (y, \<langle>x\<rangle>))" using that disjoint
	by(simp add: nn_integral_count_space_reindex)(auto 4 4 simp add: nn_integral_count_space_indicator outgoing_def intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] split: split_indicator dest: bipartite_E)
	also have "\<dots> = d_IN j (Some x)" using that disjoint
	by(auto 4 3 simp add: d_IN_def nn_integral_count_space_indicator notin_range_Some intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] split: split_indicator)
	finally show ?thesis by simp
	qed

	have OUT_g_B: "d_OUT g x = 0" if "x \<notin> A \<Gamma>" for x
	using disjoint that
	by(auto simp add: d_OUT_def nn_integral_0_iff_AE AE_count_space g_simps dest: bipartite_E)

	have OUT_g_a: "d_OUT g a < weight \<Gamma> a" using a(1)
	proof -
	have "d_OUT g a = d_OUT f a + d_IN j \<langle>a\<rangle> - d_OUT j \<langle>a\<rangle>" using a(1) by(rule OUT_g_A)
	also have "\<dots> \<le> d_OUT f a + d_IN j \<langle>a\<rangle>"
	by(rule diff_le_self_ennreal)
	also have "\<dots> < weight \<Gamma> a + d_IN j \<langle>a\<rangle> - \<epsilon>"
	using finite_\<epsilon> \<epsilon>_less currentD_finite_OUT[OF f']
	by (simp add: less_diff_eq_ennreal less_top ac_simps)
	also have "\<dots> \<le> weight \<Gamma> a"
	using IN_j[THEN order_trans, OF \<alpha>_le] by (simp add: ennreal_minus_le_iff)
	finally show ?thesis .
	qed

	have OUT_jj: "d_OUT ?j x = d_IN j \<langle>x\<rangle> - j (None, \<langle>x\<rangle>)" for x
	proof -
	have "d_OUT ?j x = (\<Sum>\<^sup>+ y\<in>range Some. j (y, \<langle>x\<rangle>))" by(simp add: d_OUT_def nn_integral_count_space_reindex)
	also have "\<dots> = d_IN j \<langle>x\<rangle> - (\<Sum>\<^sup>+ y. j (y, \<langle>x\<rangle>) * indicator {None} y)" unfolding d_IN_def
	by(subst nn_integral_diff[symmetric])(auto simp add: max_def \<Psi>.flowD_finite[OF j] AE_count_space nn_integral_count_space_indicator split: split_indicator intro!: nn_integral_cong)
	also have "\<dots> = d_IN j \<langle>x\<rangle> - j (None, \<langle>x\<rangle>)" by(simp add: max_def)
	finally show ?thesis .
	qed

	have OUT_jj_finite [simp]: "d_OUT ?j x \<noteq> \<top>" for x
	by(simp add: OUT_jj)

	have IN_g: "d_IN g x = d_IN f x + j (None, \<langle>x\<rangle>)" for x
	proof(cases "x \<in> B \<Gamma>")
	case True
	have finite: "(\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. j (Some y, Some x)) \<noteq> \<top>" using currentD_finite_IN[OF f', of x]
	by(rule neq_top_trans)(auto intro!: nn_integral_mono j_le_f simp add: d_IN_def nn_integral_count_space_indicator incoming_def split: split_indicator)

	have "d_IN g x = d_IN (f \<oplus> ?j) x" by(simp add: g_def)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. f (y, x) + j (Some x, Some y) - j (Some y, Some x))"
	by(auto simp add: d_IN_def currentD_outside[OF f'] incoming_def nn_integral_count_space_indicator intro!: nn_integral_cong)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. f (y, x) + j (Some x, Some y)) - (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. j (Some y, Some x))"
	(is "_ = _ - ?j_IN") using finite
	by(subst nn_integral_diff)(auto simp add: AE_count_space incoming_def intro!: order_trans[OF j_le_f])
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. f (y, x)) + (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. j (Some x, Some y)) - ?j_IN"
	(is "_ = ?f + ?j_OUT - _") by(subst nn_integral_add) simp_all
	also have "?f = d_IN f x" by(subst d_IN_alt_def[where G=\<Gamma>])(simp_all add: currentD_outside[OF f])
	also have "?j_OUT = (\<Sum>\<^sup>+ y\<in>range Some. j (Some x, y))" using True disjoint
	by(simp add: nn_integral_count_space_reindex)(auto 4 4 simp add: nn_integral_count_space_indicator incoming_def intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] split: split_indicator dest: bipartite_E)
	also have "\<dots> = d_OUT j (Some x)" using disjoint
	by(auto 4 3 simp add: d_OUT_def nn_integral_count_space_indicator notin_range_Some intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] split: split_indicator)
	also have "\<dots> = d_IN j (Some x)" using flowD_KIR[OF j, of "Some x"] True a disjoint by auto
	also have "?j_IN = (\<Sum>\<^sup>+ y\<in>range Some. j (y, Some x))" using True disjoint
	by(simp add: nn_integral_count_space_reindex)(auto 4 4 simp add: nn_integral_count_space_indicator incoming_def intro!: nn_integral_cong \<Psi>.flowD_outside[OF j] dest: bipartite_E split: split_indicator)
	also have "\<dots> = d_IN j (Some x) - (\<Sum>\<^sup>+ y :: 'v option. j (None, Some x) * indicator {None} y)"
	unfolding d_IN_def using flowD_capacity[OF j, of "(None, Some x)"]
	by(subst nn_integral_diff[symmetric])
	(auto simp add: nn_integral_count_space_indicator AE_count_space top_unique image_iff
	intro!: nn_integral_cong ennreal_diff_self split: split_indicator if_split_asm)
	also have "d_IN f x + d_IN j (Some x) - \<dots> = d_IN f x + j (None, Some x)"
	using ennreal_add_diff_cancel_right[OF IN_j_finite[of "Some x"], of "d_IN f x + j (None, Some x)"]
	apply(subst diff_diff_ennreal')
	apply(auto simp add: d_IN_def intro!: nn_integral_ge_point ennreal_diff_le_mono_left)
	apply(simp add: ac_simps)
	done
	finally show ?thesis .
	next
	case False
	hence "d_IN g x = 0" "d_IN f x = 0" "j (None, \<langle>x\<rangle>) = 0"
	using disjoint currentD_IN[OF f', of x] bipartite_V currentD_outside_IN[OF f'] u_outside[OF False] flowD_capacity[OF j, of "(None, \<langle>x\<rangle>)"]
	by(cases "vertex \<Gamma> x"; auto simp add: d_IN_def nn_integral_0_iff_AE AE_count_space g_simps dest: bipartite_E split: if_split_asm)+
	thus ?thesis by simp
	qed

	have g: "current \<Gamma> g"
	proof
	show "d_OUT g x \<le> weight \<Gamma> x" for x
	proof(cases "x \<in> A \<Gamma>")
	case False
	thus ?thesis by(simp add: OUT_g_B)
	next
	case True
	with OUT_g_a show ?thesis
	by(cases "x = a")(simp_all add: OUT_g_A flowD_KIR[OF j] currentD_weight_OUT[OF f'])
	qed

	show "d_IN g x \<le> weight \<Gamma> x" for x
	proof(cases "x \<in> B \<Gamma>")
	case False
	hence "d_IN g x = 0" using disjoint
	by(auto simp add: d_IN_def nn_integral_0_iff_AE AE_count_space g_simps dest: bipartite_E)
	thus ?thesis by simp
	next
	case True
	have "d_IN g x \<le> (weight \<Gamma> x - u x) + u x" unfolding IN_g
	using currentD_weight_IN[OF f, of x] flowD_capacity[OF j, of "(None, Some x)"] True bipartite_V
	by(intro add_mono)(simp_all split: if_split_asm)
	also have "\<dots> = weight \<Gamma> x"
	using u by (intro diff_add_cancel_ennreal) (simp add: le_fun_def)
	finally show ?thesis .
	qed
	show "g e = 0" if "e \<notin> \<^bold>E" for e using that
	by(cases e)(auto simp add: g_simps)
	qed

	define cap' where "cap' = (\<lambda>(x, y). if edge \<Gamma> x y then g (x, y) else if edge \<Gamma> y x then 1 else 0)"

	have cap'_simps [simp]: "cap' (x, y) = (if edge \<Gamma> x y then g (x, y) else if edge \<Gamma> y x then 1 else 0)"
	for x y by(simp add: cap'_def)

	define G where "G = \<lparr>edge = \<lambda>x y. cap' (x, y) > 0\<rparr>"
	have G_sel [simp]: "edge G x y \<longleftrightarrow> cap' (x, y) > 0" for x y by(simp add: G_def)
	define reachable where "reachable x = (edge G)\<^sup>\<^sup> x a" for x
	have reachable_alt_def: "reachable \<equiv> \<lambda>x. \<exists>p. path G x p a"
	by(simp add: reachable_def [abs_def] rtranclp_eq_rtrancl_path)

	have [simp]: "reachable a" by(auto simp add: reachable_def)

	have AB_edge: "edge G x y" if "edge \<Gamma> y x" for x y
	using that
	by(auto dest: edge_antiparallel simp add: min_def le_neq_trans add_eq_0_iff_both_eq_0)
	have reachable_AB: "reachable y" if "reachable x" "(x, y) \<in> \<^bold>E" for x y
	using that by(auto simp add: reachable_def simp del: G_sel dest!: AB_edge intro: rtrancl_path.step)
	have reachable_BA: "g (x, y) = 0" if "reachable y" "(x, y) \<in> \<^bold>E" "\<not> reachable x" for x y
	proof(rule ccontr)
	assume "g (x, y) \<noteq> 0"
	then have "g (x, y) > 0" by (simp add: zero_less_iff_neq_zero)
	hence "edge G x y" using that by simp
	then have "reachable x" using \<open>reachable y\<close>
	unfolding reachable_def by(rule converse_rtranclp_into_rtranclp)
	with \<open>\<not> reachable x\<close> show False by contradiction
	qed
	have reachable_V: "vertex \<Gamma> x" if "reachable x" for x
	proof -
	from that obtain p where p: "path G x p a" unfolding reachable_alt_def ..
	then show ?thesis using rtrancl_path_nth[OF p, of 0] a(1) A_vertex
	by(cases "p = []")(auto 4 3 simp add: vertex_def elim: rtrancl_path.cases split: if_split_asm)
	qed

	have finite_j_IN: "(\<integral>\<^sup>+ y. j (Some y, Some x) \<partial>count_space (\<^bold>I\<^bold>N x)) \<noteq> \<top>" for x
	proof -
	have "(\<integral>\<^sup>+ y. j (Some y, Some x) \<partial>count_space (\<^bold>I\<^bold>N x)) \<le> d_IN f x"
	by(auto intro!: nn_integral_mono j_le_f simp add: d_IN_def nn_integral_count_space_indicator incoming_def split: split_indicator)
	thus ?thesis using currentD_finite_IN[OF f', of x] by (auto simp: top_unique)
	qed
	have j_outside: "j (x, y) = 0" if "\<not> edge \<Psi> x y" for x y
	using that flowD_capacity[OF j, of "(x, y)"] \<Psi>.capacity_outside[of "(x, y)"]
	by(auto)

	define h where "h = (\<lambda>(x, y). if reachable x \<and> reachable y then g (x, y) else 0)"
	have h_simps [simp]: "h (x, y) = (if reachable x \<and> reachable y then g (x, y) else 0)" for x y
	by(simp add: h_def)
	have h_le_g: "h e \<le> g e" for e by(cases e) simp

	have OUT_h: "d_OUT h x = (if reachable x then d_OUT g x else 0)" for x
	proof -
	have "d_OUT h x = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. h (x, y))" using h_le_g currentD_outside[OF g]
	by(intro d_OUT_alt_def) auto
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>O\<^bold>U\<^bold>T x. if reachable x then g (x, y) else 0)"
	by(auto intro!: nn_integral_cong simp add: outgoing_def dest: reachable_AB)
	also have "\<dots> = (if reachable x then d_OUT g x else 0)"
	by(auto intro!: d_OUT_alt_def[symmetric] currentD_outside[OF g])
	finally show ?thesis .
	qed
	have IN_h: "d_IN h x = (if reachable x then d_IN g x else 0)" for x
	proof -
	have "d_IN h x = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. h (y, x))"
	using h_le_g currentD_outside[OF g] by(intro d_IN_alt_def) auto
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>\<^bold>I\<^bold>N x. if reachable x then g (y, x) else 0)"
	by(auto intro!: nn_integral_cong simp add: incoming_def dest: reachable_BA)
	also have "\<dots> = (if reachable x then d_IN g x else 0)"
	by(auto intro!: d_IN_alt_def[symmetric] currentD_outside[OF g])
	finally show ?thesis .
	qed

	have h: "current \<Gamma> h" using g h_le_g
	proof(rule current_leI)
	show "d_OUT h x \<le> d_IN h x" if "x \<notin> A \<Gamma>" for x
	by(simp add: OUT_h IN_h currentD_OUT_IN[OF g that])
	qed

	have reachable_full: "j (None, \<langle>y\<rangle>) = u y" if reach: "reachable y" for y
	proof(rule ccontr)
	assume "j (None, \<langle>y\<rangle>) \<noteq> u y"
	with flowD_capacity[OF j, of "(None, \<langle>y\<rangle>)"]
	have le: "j (None, \<langle>y\<rangle>) < u y" by(auto split: if_split_asm simp add: u_outside \<Psi>.flowD_outside[OF j] zero_less_iff_neq_zero)
	then obtain y: "y \<in> B \<Gamma>" and uy: "u y > 0" using u_outside[of y]
	by(cases "y \<in> B \<Gamma>"; cases "u y = 0") (auto simp add: zero_less_iff_neq_zero)

	from reach obtain q where q: "path G y q a" and distinct: "distinct (y # q)"
	unfolding reachable_alt_def by(auto elim: rtrancl_path_distinct)
	have q_Nil: "q \<noteq> []" using q a(1) disjoint y by(auto elim!: rtrancl_path.cases)

	let ?E = "zip (y # q) q"
	define E where "E = (None, Some y) # map (map_prod Some Some) ?E"
	define \<zeta> where "\<zeta> = Min (insert (u y - j (None, Some y)) (cap' ` set ?E))"
	let ?j' = "\<lambda>e. (if e \<in> set E then \<zeta> else 0) + j e"
	define j' where "j' = cleanup ?j'"

	have j_free: "0 < cap' e" if "e \<in> set ?E" for e using that unfolding E_def list.sel
	proof -
	from that obtain i where e: "e = ((y # q) ! i, q ! i)"
	and i: "i < length q" by(auto simp add: set_zip)
	have e': "edge G ((y # q) ! i) (q ! i)" using q i by(rule rtrancl_path_nth)
	thus ?thesis using e by(simp)
	qed
	have \<zeta>_pos: "0 < \<zeta>" unfolding \<zeta>_def using le
	by(auto intro: j_free diff_gr0_ennreal)
	have \<zeta>_le: "\<zeta> \<le> cap' e" if "e \<in> set ?E" for e using that unfolding \<zeta>_def by auto
	have finite_\<zeta> [simplified]: "\<zeta> < \<top>" unfolding \<zeta>_def
	by(intro Min_less_iff[THEN iffD2])(auto simp add: less_top[symmetric])

	have E_antiparallel: "(x', y') \<in> set ?E \<Longrightarrow> (y', x') \<notin> set ?E" for x' y'
	using distinct
	apply(auto simp add: in_set_zip nth_Cons in_set_conv_nth)
	apply(auto simp add: distinct_conv_nth split: nat.split_asm)
	by (metis Suc_lessD less_Suc_eq less_irrefl_nat)

	have OUT_j': "d_OUT ?j' x' = \<zeta> * card (set [(x'', y) \<leftarrow> E. x'' = x']) + d_OUT j x'" for x'
	proof -
	have "d_OUT ?j' x' = d_OUT (\<lambda>e. if e \<in> set E then \<zeta> else 0) x' + d_OUT j x'"
	using \<zeta>_pos by(intro d_OUT_add)
	also have "d_OUT (\<lambda>e. if e \<in> set E then \<zeta> else 0) x' = \<integral>\<^sup>+ y. \<zeta> * indicator (set E) (x', y) \<partial>count_space UNIV"
	unfolding d_OUT_def by(rule nn_integral_cong)(simp)
	also have "\<dots> = (\<integral>\<^sup>+ e. \<zeta> * indicator (set E) e \<partial>embed_measure (count_space UNIV) (Pair x'))"
	by(simp add: measurable_embed_measure1 nn_integral_embed_measure)
	also have "\<dots> = (\<integral>\<^sup>+ e. \<zeta> * indicator (set [(x'', y) \<leftarrow> E. x'' = x']) e \<partial>count_space UNIV)"
	by(auto simp add: embed_measure_count_space' nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = \<zeta> * card (set [(x'', y) \<leftarrow> E. x'' = x'])" using \<zeta>_pos by(simp add: nn_integral_cmult)
	finally show ?thesis .
	qed
	have IN_j': "d_IN ?j' x' = \<zeta> * card (set [(y, x'') \<leftarrow> E. x'' = x']) + d_IN j x'" for x'
	proof -
	have "d_IN ?j' x' = d_IN (\<lambda>e. if e \<in> set E then \<zeta> else 0) x' + d_IN j x'"
	using \<zeta>_pos by(intro d_IN_add)
	also have "d_IN (\<lambda>e. if e \<in> set E then \<zeta> else 0) x' = \<integral>\<^sup>+ y. \<zeta> * indicator (set E) (y, x') \<partial>count_space UNIV"
	unfolding d_IN_def by(rule nn_integral_cong)(simp)
	also have "\<dots> = (\<integral>\<^sup>+ e. \<zeta> * indicator (set E) e \<partial>embed_measure (count_space UNIV) (\<lambda>y. (y, x')))"
	by(simp add: measurable_embed_measure1 nn_integral_embed_measure)
	also have "\<dots> = (\<integral>\<^sup>+ e. \<zeta> * indicator (set [(y, x'') \<leftarrow> E. x'' = x']) e \<partial>count_space UNIV)"
	by(auto simp add: embed_measure_count_space' nn_integral_count_space_indicator intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = \<zeta> * card (set [(y, x'') \<leftarrow> E. x'' = x'])"
	using \<zeta>_pos by(auto simp add: nn_integral_cmult)
	finally show ?thesis .
	qed

	have j': "flow \<Psi> j'"
	proof
	fix e :: "'v option edge"
	consider (None) "e = (None, Some y)"
	\| (Some) x y where "e = (Some x, Some y)" "(x, y) \<in> set ?E"
	\| (old) x y where "e = (Some x, Some y)" "(x, y) \<notin> set ?E"
	\| y' where "e = (None, Some y')" "y \<noteq> y'"
	\| "e = (None, None)" \| x where "e = (Some x, None)"
	by(cases e; case_tac a; case_tac b)(auto)
	then show "j' e \<le> capacity \<Psi> e" using uy \<zeta>_pos flowD_capacity[OF j, of e]
	proof(cases)
	case None
	have "\<zeta> \<le> u y - j (None, Some y)" by(simp add: \<zeta>_def)
	then have "\<zeta> + j (None, Some y) \<le> u y"
	using \<zeta>_pos by (auto simp add: ennreal_le_minus_iff)
	thus ?thesis using reachable_V[OF reach] None \<Psi>.flowD_outside[OF j, of "(Some y, None)"] uy
	by(auto simp add: j'_def E_def)
	next
	case (Some x' y')
	have e: "\<zeta> \<le> cap' (x', y')" using Some(2) by(rule \<zeta>_le)
	then consider (backward) "edge \<Gamma> x' y'" "x' \<noteq> a" \| (forward) "edge \<Gamma> y' x'" "\<not> edge \<Gamma> x' y'"
	\| (a') "edge \<Gamma> x' y'" "x' = a"
	using Some \<zeta>_pos by(auto split: if_split_asm)
	then show ?thesis
	proof cases
	case backward
	have "\<zeta> \<le> f (x', y') + j (Some y', Some x') - j (Some x', Some y')"
	using e backward Some(1) by(simp add: g_simps)
	hence "\<zeta> + j (Some x', Some y') - j (Some y', Some x') \<le> (f (x', y') + j (Some y', Some x') - j (Some x', Some y')) + j (Some x', Some y') - j (Some y', Some x')"
	by(intro ennreal_minus_mono add_right_mono) simp_all
	also have "\<dots> = f (x', y')"
	using j_le_f[OF \<open>edge \<Gamma> x' y'\<close>]
	by(simp_all add: add_increasing2 less_top diff_add_assoc2_ennreal)
	finally show ?thesis using Some backward
	by(auto simp add: j'_def E_def dest: in_set_tlD E_antiparallel)
	next
	case forward
	have "\<zeta> + j (Some x', Some y') - j (Some y', Some x') \<le> \<zeta> + j (Some x', Some y')"
	by(rule diff_le_self_ennreal)
	also have "j (Some x', Some y') \<le> d_IN j (Some y')"
	by(rule d_IN_ge_point)
	also have "\<dots> \<le> weight \<Gamma> y'" by(rule IN_j_le_weight)
	also have "\<zeta> \<le> 1" using e forward by simp
	finally have "\<zeta> + j (Some x', Some y') - j (Some y', Some x') \<le> max (weight \<Gamma> x') (weight \<Gamma> y') + 1"
	by(simp add: add_left_mono add_right_mono max_def)(metis (no_types, lifting) add.commute add_right_mono less_imp_le less_le_trans not_le)
	then show ?thesis using Some forward e
	by(auto simp add: j'_def E_def max_def dest: in_set_tlD E_antiparallel)
	next
	case a'
	with Some have "a \<in> set (map fst (zip (y # q) q))" by(auto intro: rev_image_eqI)
	also have "map fst (zip (y # q) q) = butlast (y # q)" by(induction q arbitrary: y) auto
	finally have False using rtrancl_path_last[OF q q_Nil] distinct q_Nil
	by(cases q rule: rev_cases) auto
	then show ?thesis ..
	qed
	next
	case (old x' y')
	hence "j' e \<le> j e" using \<zeta>_pos
	by(auto simp add: j'_def E_def intro!: diff_le_self_ennreal)
	also have "j e \<le> capacity \<Psi> e" using j by(rule flowD_capacity)
	finally show ?thesis .
	qed(auto simp add: j'_def E_def \<Psi>.flowD_outside[OF j] uy)
	next
	fix x'
	assume x': "x' \<noteq> source \<Psi>" "x' \<noteq> sink \<Psi>"
	then obtain x'' where x'': "x' = Some x''" by auto
	have "d_OUT ?j' x' = \<zeta> * card (set [(x'', y) \<leftarrow> E. x'' = x']) + d_OUT j x'" by(rule OUT_j')
	also have "card (set [(x'', y) \<leftarrow> E. x'' = x']) = card (set [(y, x'') \<leftarrow> E. x'' = x'])" (is "?lhs = ?rhs")
	proof -
	have "?lhs = length [(x'', y) \<leftarrow> E. x'' = x']" using distinct
	by(subst distinct_card)(auto simp add: E_def filter_map distinct_map inj_map_prod' distinct_zipI1)
	also have "\<dots> = length [x''' \<leftarrow> map fst ?E. x''' = x'']"
	by(simp add: E_def x'' split_beta cong: filter_cong)
	also have "map fst ?E = butlast (y # q)" by(induction q arbitrary: y) simp_all
	also have "[x''' \<leftarrow> butlast (y # q). x''' = x''] = [x''' \<leftarrow> y # q. x''' = x'']"
	using q_Nil rtrancl_path_last[OF q q_Nil] x' x''
	by(cases q rule: rev_cases) simp_all
	also have "q = map snd ?E" by(induction q arbitrary: y) auto
	also have "length [x''' \<leftarrow> y # \<dots>. x''' = x''] = length [x'' \<leftarrow> map snd E. x'' = x']" using x''
	by(simp add: E_def cong: filter_cong)
	also have "\<dots> = length [(y, x'') \<leftarrow> E. x'' = x']" by(simp cong: filter_cong add: split_beta)
	also have "\<dots> = ?rhs" using distinct
	by(subst distinct_card)(auto simp add: E_def filter_map distinct_map inj_map_prod' distinct_zipI1)
	finally show ?thesis .
	qed
	also have "\<zeta> * \<dots> + d_OUT j x' = d_IN ?j' x'"
	unfolding flowD_KIR[OF j x'] by(rule IN_j'[symmetric])
	also have "d_IN ?j' x' \<noteq> \<top>"
	using \<Psi>.flowD_finite_IN[OF j x'(2)] finite_\<zeta> IN_j'[of x'] by (auto simp: top_add ennreal_mult_eq_top_iff)
	ultimately show "KIR j' x'" unfolding j'_def by(rule KIR_cleanup)
	qed
	hence "value_flow \<Psi> j' \<le> \<alpha>" unfolding \<alpha>_def by(auto intro: SUP_upper)
	moreover have "value_flow \<Psi> j' > value_flow \<Psi> j"
	proof -
	have "value_flow \<Psi> j + 0 < value_flow \<Psi> j + \<zeta> * 1"
	using \<zeta>_pos value_j finite_flow by simp
	also have "[(x', y') \<leftarrow> E. x' = None] = [(None, Some y)]"
	using q_Nil by(cases q)(auto simp add: E_def filter_map cong: filter_cong split_beta)
	hence "\<zeta> * 1 \<le> \<zeta> * card (set [(x', y') \<leftarrow> E. x' = None])" using \<zeta>_pos
	by(intro mult_left_mono)(auto simp add: E_def real_of_nat_ge_one_iff neq_Nil_conv card.insert_remove)
	also have "value_flow \<Psi> j + \<dots> = value_flow \<Psi> ?j'"
	using OUT_j' by(simp add: add.commute)
	also have "\<dots> = value_flow \<Psi> j'" unfolding j'_def
	by(subst value_flow_cleanup)(auto simp add: E_def \<Psi>.flowD_outside[OF j])
	finally show ?thesis by(simp add: add_left_mono)
	qed
	ultimately show False using finite_flow \<zeta>_pos value_j
	by(cases "value_flow \<Psi> j" \<zeta> rule: ennreal2_cases) simp_all
	qed

	have sep_h: "y \<in> TER h" if reach: "reachable y" and y: "y \<in> B \<Gamma>" and TER: "y \<in> ?TER f" for y
	proof(rule ccontr)
	assume y': "y \<notin> TER h"
	from y a(1) disjoint have yna: "y \<noteq> a" by auto

	from reach obtain p' where "path G y p' a" unfolding reachable_alt_def ..
	then obtain p' where p': "path G y p' a" and distinct: "distinct (y # p')" by(rule rtrancl_path_distinct)

	have SINK: "y \<in> SINK h" using y disjoint
	by(auto simp add: SINK.simps d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0 intro: currentD_outside[OF g] dest: bipartite_E)
	have hg: "d_IN h y = d_IN g y" using reach by(simp add: IN_h)
	also have "\<dots> = d_IN f y + j (None, Some y)" by(simp add: IN_g)
	also have "d_IN f y = weight \<Gamma> y - u y" using currentD_weight_IN[OF f, of y] y disjoint TER
	by(auto elim!: SAT.cases)
	also have "d_IN h y < weight \<Gamma> y" using y' currentD_weight_IN[OF g, of y] y disjoint SINK
	by(auto intro: SAT.intros)
	ultimately have le: "j (None, Some y) < u y"
	by(cases "weight \<Gamma> y" "u y" "j (None, Some y)" rule: ennreal3_cases; cases "u y \<le> weight \<Gamma> y")
	(auto simp: ennreal_minus ennreal_plus[symmetric] add_top ennreal_less_iff ennreal_neg simp del: ennreal_plus)
	moreover from reach have "j (None, \<langle>y\<rangle>) = u y" by(rule reachable_full)
	ultimately show False by simp
	qed

	have w': "wave \<Gamma> h"
	proof
	show sep: "separating \<Gamma> (TER h)"
	proof(rule ccontr)
	assume "\<not> ?thesis"
	then obtain x p y where x: "x \<in> A \<Gamma>" and y: "y \<in> B \<Gamma>" and p: "path \<Gamma> x p y"
	and x': "x \<notin> TER h" and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER h"
	by(auto simp add: separating_gen.simps)
	from p disjoint x y have p_eq: "p = [y]" and edge: "(x, y) \<in> \<^bold>E"
	by -(erule rtrancl_path.cases, auto dest: bipartite_E)+
	from p_eq bypass have y': "y \<notin> TER h" by simp
	have "reachable x" using x' by(rule contrapos_np)(simp add: SINK.simps d_OUT_def SAT.A x)
	hence reach: "reachable y" using edge by(rule reachable_AB)

	have *: "x \<notin> \<E>\<^bsub>?\<Gamma>\<^esub> (?TER f)" using x'
	proof(rule contrapos_nn)
	assume *: "x \<in> \<E>\<^bsub>?\<Gamma>\<^esub> (?TER f)"
	have "d_OUT h x \<le> d_OUT g x" using h_le_g by(rule d_OUT_mono)
	also from * have "x \<noteq> a" using a by auto
	then have "d_OUT j (Some x) = d_IN j (Some x)" by(auto intro: flowD_KIR[OF j])
	hence "d_OUT g x \<le> d_OUT f x" using OUT_g_A[OF x] IN_j[of "Some x"] finite_flow
	by(auto split: if_split_asm)
	also have "\<dots> = 0" using * by(auto elim: SINK.cases)
	finally have "x \<in> SINK h" by(simp add: SINK.simps)
	with x show "x \<in> TER h" by(simp add: SAT.A)
	qed
	from p p_eq x y have "path ?\<Gamma> x [y] y" "x \<in> A ?\<Gamma>" "y \<in> B ?\<Gamma>" by simp_all
	from * separatingD[OF separating_essential, OF waveD_separating, OF w this]
	have "y \<in> ?TER f" by auto
	with reach y have "y \<in> TER h" by(rule sep_h)
	with y' show False by contradiction
	qed
	qed(rule h)

	have OUT_g_a: "d_OUT g a = d_OUT h a" by(simp add: OUT_h)
	have "a \<notin> \<E> (TER h)"
	proof
	assume *: "a \<in> \<E> (TER h)"

	have "j (Some a, Some y) = 0" for y
	using flowD_capacity[OF j, of "(Some a, Some y)"] a(1) disjoint
	by(auto split: if_split_asm dest: bipartite_E)
	then have "d_OUT f a \<le> d_OUT g a" unfolding d_OUT_def
	\<comment> \<open>This step requires that @{term j} does not decrease the outflow of @{term a}. That's
	why we set the capacity of the outgoing edges from @{term "Some a"} in @{term \<Psi>} to @{term "0 :: ennreal"}\<close>
	by(intro nn_integral_mono)(auto simp add: g_simps currentD_outside[OF f] intro: )
	then have "a \<in> SINK f" using OUT_g_a * by(simp add: SINK.simps)
	with a(1) have "a \<in> ?TER f" by(auto intro: SAT.A)
	with a(2) have a': "\<not> essential \<Gamma> (B \<Gamma>) (?TER f) a" by simp

	from * obtain y where ay: "edge \<Gamma> a y" and y: "y \<in> B \<Gamma>" and y': "y \<notin> TER h" using disjoint a(1)
	by(auto 4 4 simp add: essential_def elim: rtrancl_path.cases dest: bipartite_E)
	from not_essentialD[OF a' rtrancl_path.step, OF ay rtrancl_path.base y]
	have TER: "y \<in> ?TER f" by simp

	have "reachable y" using \<open>reachable a\<close> by(rule reachable_AB)(simp add: ay)
	hence "y \<in> TER h" using y TER by(rule sep_h)
	with y' show False by contradiction
	qed
	with \<open>a \<in> A \<Gamma>\<close> have "hindrance \<Gamma> h"
	proof
	have "d_OUT h a = d_OUT g a" by(simp add: OUT_g_a)
	also have "\<dots> \<le> d_OUT f a + \<integral>\<^sup>+ y. j (Some y, Some a) \<partial>count_space UNIV"
	unfolding d_OUT_def d_IN_def
	by(subst nn_integral_add[symmetric])(auto simp add: g_simps intro!: nn_integral_mono diff_le_self_ennreal)
	also have "(\<integral>\<^sup>+ y. j (Some y, Some a) \<partial>count_space UNIV) = (\<integral>\<^sup>+ y. j (y, Some a) \<partial>embed_measure (count_space UNIV) Some)"
	by(simp add: nn_integral_embed_measure measurable_embed_measure1)
	also have "\<dots> \<le> d_IN j (Some a)" unfolding d_IN_def
	by(auto simp add: embed_measure_count_space nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> \<le> \<alpha>" by(rule IN_j)
	also have "\<dots> \<le> \<epsilon>" by(rule \<alpha>_le)
	also have "d_OUT f a + \<dots> < d_OUT f a + (weight \<Gamma> a - d_OUT f a)" using \<epsilon>_less
	using currentD_finite_OUT[OF f'] by (simp add: ennreal_add_left_cancel_less)
	also have "\<dots> = weight \<Gamma> a"
	using a_le by simp
	finally show "d_OUT h a < weight \<Gamma> a" by(simp add: add_left_mono)
	qed
	then show ?thesis using h w' by(blast intro: hindered.intros)
	qed

	end

	corollary hindered_reduce_current: \<comment> \<open>Corollary 6.8\<close>
	fixes \<epsilon> g
	defines "\<epsilon> \<equiv> \<Sum>\<^sup>+ x\<in>B \<Gamma>. d_IN g x - d_OUT g x"
	assumes g: "current \<Gamma> g"
	and \<epsilon>_finite: "\<epsilon> \<noteq> \<top>"
	and hindered: "hindered_by (\<Gamma> \<ominus> g) \<epsilon>"
	shows "hindered \<Gamma>"
	proof -
	define \<Gamma>' where "\<Gamma>' = \<Gamma>\<lparr>weight := \<lambda>x. if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT g x else weight \<Gamma> x\<rparr>"
	have \<Gamma>'_sel [simp]:
	"edge \<Gamma>' = edge \<Gamma>"
	"A \<Gamma>' = A \<Gamma>"
	"B \<Gamma>' = B \<Gamma>"
	"weight \<Gamma>' x = (if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT g x else weight \<Gamma> x)"
	"vertex \<Gamma>' = vertex \<Gamma>"
	"web.more \<Gamma>' = web.more \<Gamma>"
	for x by(simp_all add: \<Gamma>'_def)
	have "countable_bipartite_web \<Gamma>'"
	by unfold_locales(simp_all add: A_in B_out A_vertex disjoint bipartite_V no_loop weight_outside currentD_outside_OUT[OF g] currentD_weight_OUT[OF g] edge_antiparallel, rule bipartite_E)
	then interpret \<Gamma>': countable_bipartite_web \<Gamma>' .
	let ?u = "\<lambda>x. (d_IN g x - d_OUT g x) * indicator (- A \<Gamma>) x"

	have "hindered \<Gamma>'"
	proof(rule \<Gamma>'.hindered_reduce)
	show "?u x = 0" if "x \<notin> B \<Gamma>'" for x using that bipartite_V
	by(cases "vertex \<Gamma>' x")(auto simp add: currentD_outside_OUT[OF g] currentD_outside_IN[OF g])

	have *: "(\<Sum>\<^sup>+ x\<in>B \<Gamma>'. ?u x) = \<epsilon>" using disjoint
	by(auto intro!: nn_integral_cong simp add: \<epsilon>_def nn_integral_count_space_indicator currentD_outside_OUT[OF g] currentD_outside_IN[OF g] not_vertex split: split_indicator)
	thus "(\<Sum>\<^sup>+ x\<in>B \<Gamma>'. ?u x) \<noteq> \<top>" using \<epsilon>_finite by simp

	have **: "\<Gamma>'\<lparr>weight := weight \<Gamma>' - ?u\<rparr> = \<Gamma> \<ominus> g"
	using currentD_weight_IN[OF g] currentD_OUT_IN[OF g] currentD_IN[OF g] currentD_finite_OUT[OF g]
	by(intro web.equality)(simp_all add: fun_eq_iff diff_diff_ennreal' ennreal_diff_le_mono_left)
	show "hindered_by (\<Gamma>'\<lparr>weight := weight \<Gamma>' - ?u\<rparr>) (\<Sum>\<^sup>+ x\<in>B \<Gamma>'. ?u x)"
	unfolding * ** by(fact hindered)
	show "(\<lambda>x. (d_IN g x - d_OUT g x) * indicator (- A \<Gamma>) x) \<le> weight \<Gamma>'"
	using currentD_weight_IN[OF g]
	by (simp add: le_fun_def ennreal_diff_le_mono_left)
	qed
	then show ?thesis
	by(rule hindered_mono_web[rotated -1]) simp_all
	qed

	end

	subsection \<open>Reduced weight in a loose web\<close>

	definition reduce_weight :: "('v, 'more) web_scheme \<Rightarrow> 'v \<Rightarrow> real \<Rightarrow> ('v, 'more) web_scheme"
	where "reduce_weight \<Gamma> x r = \<Gamma>\<lparr>weight := \<lambda>y. weight \<Gamma> y - (if x = y then r else 0)\<rparr>"

	lemma reduce_weight_sel [simp]:
	"edge (reduce_weight \<Gamma> x r) = edge \<Gamma>"
	"A (reduce_weight \<Gamma> x r) = A \<Gamma>"
	"B (reduce_weight \<Gamma> x r) = B \<Gamma>"
	"vertex (reduce_weight \<Gamma> x r) = vertex \<Gamma>"
	"weight (reduce_weight \<Gamma> x r) y = (if x = y then weight \<Gamma> x - r else weight \<Gamma> y)"
	"web.more (reduce_weight \<Gamma> x r) = web.more \<Gamma>"
	by(simp_all add: reduce_weight_def zero_ennreal_def[symmetric] vertex_def fun_eq_iff)

	lemma essential_reduce_weight [simp]: "essential (reduce_weight \<Gamma> x r) = essential \<Gamma>"
	by(simp add: fun_eq_iff essential_def)

	lemma roofed_reduce_weight [simp]: "roofed_gen (reduce_weight \<Gamma> x r) = roofed_gen \<Gamma>"
	by(simp add: fun_eq_iff roofed_def)

	context countable_bipartite_web begin

	context begin
	private datatype (plugins del: transfer size) 'a vertex = SOURCE \| SINK \| Inner (inner: 'a)

	private lemma notin_range_Inner: "x \<notin> range Inner \<longleftrightarrow> x = SOURCE \<or> x = SINK"
	by(cases x) auto

	private lemma inj_Inner [simp]: "\<And>A. inj_on Inner A"
	by(simp add: inj_on_def)

	lemma unhinder_bipartite:
	assumes h: "\<And>n :: nat. current \<Gamma> (h n)"
	and SAT: "\<And>n. (B \<Gamma> \<inter> \<^bold>V) - {b} \<subseteq> SAT \<Gamma> (h n)"
	and b: "b \<in> B \<Gamma>"
	and IN: "(SUP n. d_IN (h n) b) = weight \<Gamma> b"
	and h0_b: "\<And>n. d_IN (h 0) b \<le> d_IN (h n) b"
	and b_V: "b \<in> \<^bold>V"
	shows "\<exists>h'. current \<Gamma> h' \<and> wave \<Gamma> h' \<and> B \<Gamma> \<inter> \<^bold>V \<subseteq> SAT \<Gamma> h'"
	proof -
	write Inner ("\<langle>_\<rangle>")
	define edge'
	where "edge' xo yo =
	(case (xo, yo) of
	(\<langle>x\<rangle>, \<langle>y\<rangle>) \<Rightarrow> edge \<Gamma> x y \<or> edge \<Gamma> y x
	\| (\<langle>x\<rangle>, SINK) \<Rightarrow> x \<in> A \<Gamma>
	\| (SOURCE, \<langle>y\<rangle>) \<Rightarrow> y = b
	\| (SINK, \<langle>x\<rangle>) \<Rightarrow> x \<in> A \<Gamma>
	\| _ \<Rightarrow> False)" for xo yo
	have edge'_simps [simp]:
	"edge' \<langle>x\<rangle> \<langle>y\<rangle> \<longleftrightarrow> edge \<Gamma> x y \<or> edge \<Gamma> y x"
	"edge' \<langle>x\<rangle> SINK \<longleftrightarrow> x \<in> A \<Gamma>"
	"edge' SOURCE yo \<longleftrightarrow> yo = \<langle>b\<rangle>"
	"edge' SINK \<langle>x\<rangle> \<longleftrightarrow> x \<in> A \<Gamma>"
	"edge' SINK SINK \<longleftrightarrow> False"
	"edge' xo SOURCE \<longleftrightarrow> False"
	for x y yo xo by(simp_all add: edge'_def split: vertex.split)
	have edge'E: "thesis" if "edge' xo yo"
	"\<And>x y. \<lbrakk> xo = \<langle>x\<rangle>; yo = \<langle>y\<rangle>; edge \<Gamma> x y \<or> edge \<Gamma> y x \<rbrakk> \<Longrightarrow> thesis"
	"\<And>x. \<lbrakk> xo = \<langle>x\<rangle>; yo = SINK; x \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	"\<And>x. \<lbrakk> xo = SOURCE; yo = \<langle>b\<rangle> \<rbrakk> \<Longrightarrow> thesis"
	"\<And>y. \<lbrakk> xo = SINK; yo = \<langle>y\<rangle>; y \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	for xo yo thesis using that by(auto simp add: edge'_def split: option.split_asm vertex.split_asm)
	have edge'_Inner1 [elim!]: "thesis" if "edge' \<langle>x\<rangle> yo"
	"\<And>y. \<lbrakk> yo = \<langle>y\<rangle>; edge \<Gamma> x y \<or> edge \<Gamma> y x \<rbrakk> \<Longrightarrow> thesis"
	"\<lbrakk> yo = SINK; x \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	for x yo thesis using that by(auto elim: edge'E)
	have edge'_Inner2 [elim!]: "thesis" if "edge' xo \<langle>y\<rangle>"
	"\<And>x. \<lbrakk> xo = \<langle>x\<rangle>; edge \<Gamma> x y \<or> edge \<Gamma> y x \<rbrakk> \<Longrightarrow> thesis"
	"\<lbrakk> xo = SOURCE; y = b \<rbrakk> \<Longrightarrow> thesis"
	"\<lbrakk> xo = SINK; y \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	for xo y thesis using that by(auto elim: edge'E)
	have edge'_SINK1 [elim!]: "thesis" if "edge' SINK yo"
	"\<And>y. \<lbrakk> yo = \<langle>y\<rangle>; y \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	for yo thesis using that by(auto elim: edge'E)
	have edge'_SINK2 [elim!]: "thesis" if "edge' xo SINK"
	"\<And>x. \<lbrakk> xo = \<langle>x\<rangle>; x \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> thesis"
	for xo thesis using that by(auto elim: edge'E)

	define cap
	where "cap xoyo =
	(case xoyo of
	(\<langle>x\<rangle>, \<langle>y\<rangle>) \<Rightarrow> if edge \<Gamma> x y then h 0 (x, y) else if edge \<Gamma> y x then max (weight \<Gamma> x) (weight \<Gamma> y) else 0
	\| (\<langle>x\<rangle>, SINK) \<Rightarrow> if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT (h 0) x else 0
	\| (SOURCE, yo) \<Rightarrow> if yo = \<langle>b\<rangle> then weight \<Gamma> b - d_IN (h 0) b else 0
	\| (SINK, \<langle>y\<rangle>) \<Rightarrow> if y \<in> A \<Gamma> then weight \<Gamma> y else 0
	\| _ \<Rightarrow> 0)" for xoyo
	have cap_simps [simp]:
	"cap (\<langle>x\<rangle>, \<langle>y\<rangle>) = (if edge \<Gamma> x y then h 0 (x, y) else if edge \<Gamma> y x then max (weight \<Gamma> x) (weight \<Gamma> y) else 0)"
	"cap (\<langle>x\<rangle>, SINK) = (if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT (h 0) x else 0)"
	"cap (SOURCE, yo) = (if yo = \<langle>b\<rangle> then weight \<Gamma> b - d_IN (h 0) b else 0)"
	"cap (SINK, \<langle>y\<rangle>) = (if y \<in> A \<Gamma> then weight \<Gamma> y else 0)"
	"cap (SINK, SINK) = 0"
	"cap (xo, SOURCE) = 0"
	for x y yo xo by(simp_all add: cap_def split: vertex.split)
	define \<Psi> where "\<Psi> = \<lparr>edge = edge', capacity = cap, source = SOURCE, sink = SINK\<rparr>"
	have \<Psi>_sel [simp]:
	"edge \<Psi> = edge'"
	"capacity \<Psi> = cap"
	"source \<Psi> = SOURCE"
	"sink \<Psi> = SINK"
	by(simp_all add: \<Psi>_def)

	have cap_outside1: "\<not> vertex \<Gamma> x \<Longrightarrow> cap (\<langle>x\<rangle>, y) = 0" for x y using A_vertex
	by(cases y)(auto simp add: vertex_def)
	have capacity_A_weight: "d_OUT cap \<langle>x\<rangle> \<le> 2 * weight \<Gamma> x" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_OUT cap \<langle>x\<rangle> \<le> (\<Sum>\<^sup>+ y. h 0 (x, inner y) * indicator (range Inner) y + weight \<Gamma> x * indicator {SINK} y)"
	using that disjoint unfolding d_OUT_def
	by(auto intro!: nn_integral_mono diff_le_self_ennreal simp add: A_in notin_range_Inner split: split_indicator)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. h 0 (x, inner y)) + weight \<Gamma> x"
	by(auto simp add: nn_integral_count_space_indicator nn_integral_add)
	also have "(\<Sum>\<^sup>+ y\<in>range Inner. h 0 (x, inner y)) = d_OUT (h 0) x"
	by(simp add: d_OUT_def nn_integral_count_space_reindex)
	also have "\<dots> \<le> weight \<Gamma> x" using h by(rule currentD_weight_OUT)
	finally show ?thesis unfolding one_add_one[symmetric] distrib_right by(simp add: add_right_mono)
	qed
	have flow_attainability: "flow_attainability \<Psi>"
	proof
	have "\<^bold>E\<^bsub>\<Psi>\<^esub> \<subseteq> (\<lambda>(x, y). (\<langle>x\<rangle>, \<langle>y\<rangle>)) ` \<^bold>E \<union> (\<lambda>(x, y). (\<langle>y\<rangle>, \<langle>x\<rangle>)) ` \<^bold>E \<union> (\<lambda>x. (\<langle>x\<rangle>, SINK)) ` A \<Gamma> \<union> (\<lambda>x. (SINK, \<langle>x\<rangle>)) ` A \<Gamma> \<union> {(SOURCE, \<langle>b\<rangle>)}"
	by(auto simp add: edge'_def split: vertex.split_asm)
	moreover have "countable (A \<Gamma>)" using A_vertex by(rule countable_subset) simp
	ultimately show "countable \<^bold>E\<^bsub>\<Psi>\<^esub>" by(auto elim: countable_subset)
	next
	fix v
	assume "v \<noteq> sink \<Psi>"
	then consider (source) "v = SOURCE" \| (A) x where "v = \<langle>x\<rangle>" "x \<in> A \<Gamma>"
	\| (B) y where "v = \<langle>y\<rangle>" "y \<notin> A \<Gamma>" "y \<in> \<^bold>V" \| (outside) x where "v = \<langle>x\<rangle>" "x \<notin> \<^bold>V"
	by(cases v) auto
	then show "d_IN (capacity \<Psi>) v \<noteq> \<top> \<or> d_OUT (capacity \<Psi>) v \<noteq> \<top>"
	proof cases
	case source thus ?thesis by(simp add: d_IN_def)
	next
	case (A x)
	thus ?thesis using capacity_A_weight[of x] by (auto simp: top_unique ennreal_mult_eq_top_iff)
	next
	case (B y)
	have "d_IN (capacity \<Psi>) v \<le> (\<Sum>\<^sup>+ x. h 0 (inner x, y) * indicator (range Inner) x + weight \<Gamma> b * indicator {SOURCE} x)"
	using B bipartite_V
	by(auto 4 4 intro!: nn_integral_mono simp add: diff_le_self_ennreal d_IN_def notin_range_Inner nn_integral_count_space_indicator currentD_outside[OF h] split: split_indicator dest: bipartite_E)
	also have "\<dots> = (\<Sum>\<^sup>+ x\<in>range Inner. h 0 (inner x, y)) + weight \<Gamma> b"
	by(simp add: nn_integral_add nn_integral_count_space_indicator)
	also have "(\<Sum>\<^sup>+ x\<in>range Inner. h 0 (inner x, y)) = d_IN (h 0) y"
	by(simp add: d_IN_def nn_integral_count_space_reindex)
	also have "d_IN (h 0) y \<le> weight \<Gamma> y" using h by(rule currentD_weight_IN)
	finally show ?thesis by(auto simp add: top_unique add_right_mono split: if_split_asm)
	next
	case outside
	hence "d_OUT (capacity \<Psi>) v = 0" using A_vertex
	by(auto simp add: d_OUT_def nn_integral_0_iff_AE AE_count_space cap_def vertex_def split: vertex.split)
	thus ?thesis by simp
	qed
	next
	show "capacity \<Psi> e \<noteq> \<top>" for e
	by(auto simp add: cap_def max_def vertex_def currentD_finite[OF h] split: vertex.split prod.split)
	show "capacity \<Psi> e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Psi>\<^esub>" for e using that
	by(auto simp add: cap_def max_def split: prod.split; split vertex.split)+
	show "\<not> edge \<Psi> x (source \<Psi>)" for x using b by(auto simp add: B_out)
	show "\<not> edge \<Psi> x x" for x by(cases x)(simp_all add: no_loop)
	show "source \<Psi> \<noteq> sink \<Psi>" by simp
	qed
	then interpret \<Psi>: flow_attainability "\<Psi>" .
	define \<alpha> where "\<alpha> = (SUP f\<in>{f. flow \<Psi> f}. value_flow \<Psi> f)"

	define f
	where "f n xoyo =
	(case xoyo of
	(\<langle>x\<rangle>, \<langle>y\<rangle>) \<Rightarrow> if edge \<Gamma> x y then h 0 (x, y) - h n (x, y) else if edge \<Gamma> y x then h n (y, x) - h 0 (y, x) else 0
	\| (SOURCE, \<langle>y\<rangle>) \<Rightarrow> if y = b then d_IN (h n) b - d_IN (h 0) b else 0
	\| (\<langle>x\<rangle>, SINK) \<Rightarrow> if x \<in> A \<Gamma> then d_OUT (h n) x - d_OUT (h 0) x else 0
	\| (SINK, \<langle>y\<rangle>) \<Rightarrow> if y \<in> A \<Gamma> then d_OUT (h 0) y - d_OUT (h n) y else 0
	\| _ \<Rightarrow> 0)" for n xoyo
	have f_cases: thesis if "\<And>x y. e = (\<langle>x\<rangle>, \<langle>y\<rangle>) \<Longrightarrow> thesis" "\<And>y. e = (SOURCE, \<langle>y\<rangle>) \<Longrightarrow> thesis"
	"\<And>x. e = (\<langle>x\<rangle>, SINK) \<Longrightarrow> thesis" "\<And>y. e = (SINK, \<langle>y\<rangle>) \<Longrightarrow> thesis" "e = (SINK, SINK) \<Longrightarrow> thesis"
	"\<And>xo. e = (xo, SOURCE) \<Longrightarrow> thesis" "e = (SOURCE, SINK) \<Longrightarrow> thesis"
	for e :: "'v vertex edge" and thesis
	using that by(cases e; cases "fst e" "snd e" rule: vertex.exhaust[case_product vertex.exhaust]) simp_all
	have f_simps [simp]:
	"f n (\<langle>x\<rangle>, \<langle>y\<rangle>) = (if edge \<Gamma> x y then h 0 (x, y) - h n (x, y) else if edge \<Gamma> y x then h n (y, x) - h 0 (y, x) else 0)"
	"f n (SOURCE, \<langle>y\<rangle>) = (if y = b then d_IN (h n) b - d_IN (h 0) b else 0)"
	"f n (\<langle>x\<rangle>, SINK) = (if x \<in> A \<Gamma> then d_OUT (h n) x - d_OUT (h 0) x else 0)"
	"f n (SINK, \<langle>y\<rangle>) = (if y \<in> A \<Gamma> then d_OUT (h 0) y - d_OUT (h n) y else 0)"
	"f n (SOURCE, SINK) = 0"
	"f n (SINK, SINK) = 0"
	"f n (xo, SOURCE) = 0"
	for n x y xo by(simp_all add: f_def split: vertex.split)
	have OUT_f_SOURCE: "d_OUT (f n) SOURCE = d_IN (h n) b - d_IN (h 0) b" for n
	proof(rule trans)
	show "d_OUT (f n) SOURCE = (\<Sum>\<^sup>+ y. f n (SOURCE, y) * indicator {\<langle>b\<rangle>} y)" unfolding d_OUT_def
	apply(rule nn_integral_cong) subgoal for x by(cases x) auto done
	show "\<dots> = d_IN (h n) b - d_IN (h 0) b" using h0_b[of n]
	by(auto simp add: max_def)
	qed

	have OUT_f_outside: "d_OUT (f n) \<langle>x\<rangle> = 0" if "x \<notin> \<^bold>V" for x n using A_vertex that
	apply(clarsimp simp add: d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0)
	subgoal for y by(cases y)(auto simp add: vertex_def)
	done
	have IN_f_outside: "d_IN (f n) \<langle>x\<rangle> = 0" if "x \<notin> \<^bold>V" for x n using b_V that
	apply(clarsimp simp add: d_IN_def nn_integral_0_iff emeasure_count_space_eq_0)
	subgoal for y by(cases y)(auto simp add: currentD_outside_OUT[OF h] vertex_def)
	done

	have f: "flow \<Psi> (f n)" for n
	proof
	show f_le: "f n e \<le> capacity \<Psi> e" for e
	using currentD_weight_out[OF h] currentD_weight_IN[OF h] currentD_weight_OUT[OF h]
	by(cases e rule: f_cases)
	(auto dest: edge_antiparallel simp add: not_le le_max_iff_disj intro: ennreal_minus_mono ennreal_diff_le_mono_left)

	fix xo
	assume "xo \<noteq> source \<Psi>" "xo \<noteq> sink \<Psi>"
	then consider (A) x where "xo = \<langle>x\<rangle>" "x \<in> A \<Gamma>" \| (B) x where "xo = \<langle>x\<rangle>" "x \<in> B \<Gamma>" "x \<in> \<^bold>V"
	\| (outside) x where "xo = \<langle>x\<rangle>" "x \<notin> \<^bold>V" using bipartite_V by(cases xo) auto
	then show "KIR (f n) xo"
	proof cases
	case outside
	thus ?thesis by(simp add: OUT_f_outside IN_f_outside)
	next
	case A

	have finite1: "(\<Sum>\<^sup>+ y. h n (x, y) * indicator A y) \<noteq> \<top>" for A n
	using currentD_finite_OUT[OF h, of n x, unfolded d_OUT_def]
	by(rule neq_top_trans)(auto intro!: nn_integral_mono simp add: split: split_indicator)

	let ?h0_ge_hn = "{y. h 0 (x, y) \<ge> h n (x, y)}"
	let ?h0_lt_hn = "{y. h 0 (x, y) < h n (x, y)}"

	have "d_OUT (f n) \<langle>x\<rangle> = (\<Sum>\<^sup>+ y. f n (\<langle>x\<rangle>, y) * indicator (range Inner) y + f n (\<langle>x\<rangle>, y) * indicator {SINK} y)"
	unfolding d_OUT_def by(intro nn_integral_cong)(auto split: split_indicator simp add: notin_range_Inner)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. f n (\<langle>x\<rangle>, y)) + f n (\<langle>x\<rangle>, SINK)"
	by(simp add: nn_integral_add nn_integral_count_space_indicator max.left_commute max.commute)
	also have "(\<Sum>\<^sup>+ y\<in>range Inner. f n (\<langle>x\<rangle>, y)) = (\<Sum>\<^sup>+ y. h 0 (x, y) - h n (x, y))" using A
	apply(simp add: nn_integral_count_space_reindex cong: nn_integral_cong_simp outgoing_def)
	apply(auto simp add: nn_integral_count_space_indicator outgoing_def A_in max.absorb1 currentD_outside[OF h] intro!: nn_integral_cong split: split_indicator dest: edge_antiparallel)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_ge_hn y) - (\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_ge_hn y)"
	apply(subst nn_integral_diff[symmetric])
	apply(simp_all add: AE_count_space finite1 split: split_indicator)
	apply(rule nn_integral_cong; auto simp add: max_def not_le split: split_indicator)
	by (metis diff_eq_0_ennreal le_less not_le top_greatest)
	also have "(\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_ge_hn y) = d_OUT (h n) x - (\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_lt_hn y)"
	unfolding d_OUT_def
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space finite1 currentD_finite[OF h] split: split_indicator intro!: nn_integral_cong)
	done
	also have "(\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_ge_hn y) - \<dots> + f n (\<langle>x\<rangle>, SINK) =
	(\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_ge_hn y) + (\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_lt_hn y) - min (d_OUT (h n) x) (d_OUT (h 0) x)"
	using finite1[of n "{_}"] A finite1[of n UNIV]
	apply (subst diff_diff_ennreal')
	apply (auto simp: d_OUT_def finite1 AE_count_space nn_integral_diff[symmetric] top_unique nn_integral_add[symmetric]
	split: split_indicator intro!: nn_integral_mono ennreal_diff_self)
	apply (simp add: min_def not_le diff_eq_0_ennreal finite1 less_top[symmetric])
	apply (subst diff_add_assoc2_ennreal)
	apply (auto simp: add_diff_eq_ennreal intro!: nn_integral_mono split: split_indicator)
	apply (subst diff_diff_commute_ennreal)
	apply (simp add: ennreal_add_diff_cancel )
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_lt_hn y) - (d_OUT (h 0) x - (\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_ge_hn y)) + f n (SINK, \<langle>x\<rangle>)"
	apply(rule sym)
	using finite1[of 0 "{_}"] A finite1[of 0 UNIV]
	apply (subst diff_diff_ennreal')
	apply (auto simp: d_OUT_def finite1 AE_count_space nn_integral_diff[symmetric] top_unique nn_integral_add[symmetric]
	split: split_indicator intro!: nn_integral_mono ennreal_diff_self)
	apply (simp add: min_def not_le diff_eq_0_ennreal finite1 less_top[symmetric])
	apply (subst diff_add_assoc2_ennreal)
	apply (auto simp: add_diff_eq_ennreal intro!: nn_integral_mono split: split_indicator)
	apply (subst diff_diff_commute_ennreal)
	apply (simp_all add: ennreal_add_diff_cancel ac_simps)
	done
	also have "d_OUT (h 0) x - (\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_ge_hn y) = (\<Sum>\<^sup>+ y. h 0 (x, y) * indicator ?h0_lt_hn y)"
	unfolding d_OUT_def
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space finite1 currentD_finite[OF h] split: split_indicator intro!: nn_integral_cong)
	done
	also have "(\<Sum>\<^sup>+ y. h n (x, y) * indicator ?h0_lt_hn y) - \<dots> = (\<Sum>\<^sup>+ y. h n (x, y) - h 0 (x, y))"
	apply(subst nn_integral_diff[symmetric])
	apply(simp_all add: AE_count_space finite1 order.strict_implies_order split: split_indicator)
	apply(rule nn_integral_cong; auto simp add: currentD_finite[OF h] top_unique less_top[symmetric] not_less split: split_indicator intro!: diff_eq_0_ennreal)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. f n (y, \<langle>x\<rangle>))" using A
	apply(simp add: nn_integral_count_space_reindex cong: nn_integral_cong_simp outgoing_def)
	apply(auto simp add: nn_integral_count_space_indicator outgoing_def A_in max.commute currentD_outside[OF h] intro!: nn_integral_cong split: split_indicator dest: edge_antiparallel)
	done
	also have "\<dots> + f n (SINK, \<langle>x\<rangle>) = (\<Sum>\<^sup>+ y. f n (y, \<langle>x\<rangle>) * indicator (range Inner) y + f n (y, \<langle>x\<rangle>) * indicator {SINK} y)"
	by(simp add: nn_integral_add nn_integral_count_space_indicator)
	also have "\<dots> = d_IN (f n) \<langle>x\<rangle>"
	using A b disjoint unfolding d_IN_def
	by(intro nn_integral_cong)(auto split: split_indicator simp add: notin_range_Inner)
	finally show ?thesis using A by simp
	next
	case (B x)

	have finite1: "(\<Sum>\<^sup>+ y. h n (y, x) * indicator A y) \<noteq> \<top>" for A n
	using currentD_finite_IN[OF h, of n x, unfolded d_IN_def]
	by(rule neq_top_trans)(auto intro!: nn_integral_mono split: split_indicator)

	have finite_h[simp]: "h n (y, x) < \<top>" for y n
	using finite1[of n "{y}"] by (simp add: less_top)

	let ?h0_gt_hn = "{y. h 0 (y, x) > h n (y, x)}"
	let ?h0_le_hn = "{y. h 0 (y, x) \<le> h n (y, x)}"

	have eq: "d_IN (h 0) x + f n (SOURCE, \<langle>x\<rangle>) = d_IN (h n) x"
	proof(cases "x = b")
	case True with currentD_finite_IN[OF h, of _ b] show ?thesis
	by(simp add: add_diff_self_ennreal h0_b)
	next
	case False
	with B SAT have "x \<in> SAT \<Gamma> (h n)" "x \<in> SAT \<Gamma> (h 0)" by auto
	with B disjoint have "d_IN (h n) x = d_IN (h 0) x" by(auto simp add: currentD_SAT[OF h])
	thus ?thesis using False by(simp add: currentD_finite_IN[OF h])
	qed

	have "d_IN (f n) \<langle>x\<rangle> = (\<Sum>\<^sup>+ y. f n (y, \<langle>x\<rangle>) * indicator (range Inner) y + f n (y, \<langle>x\<rangle>) * indicator {SOURCE} y)"
	using B disjoint unfolding d_IN_def
	by(intro nn_integral_cong)(auto split: split_indicator simp add: notin_range_Inner)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. f n (y, \<langle>x\<rangle>)) + f n (SOURCE, \<langle>x\<rangle>)" using h0_b[of n]
	by(simp add: nn_integral_add nn_integral_count_space_indicator max_def)
	also have "(\<Sum>\<^sup>+ y\<in>range Inner. f n (y, \<langle>x\<rangle>)) = (\<Sum>\<^sup>+ y. h 0 (y, x) - h n (y, x))"
	using B disjoint
	apply(simp add: nn_integral_count_space_reindex cong: nn_integral_cong_simp outgoing_def)
	apply(auto simp add: nn_integral_count_space_indicator outgoing_def B_out max.commute currentD_outside[OF h] intro!: nn_integral_cong split: split_indicator dest: edge_antiparallel)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_gt_hn y) - (\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_gt_hn y)"
	apply(subst nn_integral_diff[symmetric])
	apply(simp_all add: AE_count_space finite1 order.strict_implies_order split: split_indicator)
	apply(rule nn_integral_cong; auto simp add: currentD_finite[OF h] top_unique less_top[symmetric] not_less split: split_indicator intro!: diff_eq_0_ennreal)
	done
	also have eq_h_0: "(\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_gt_hn y) = d_IN (h 0) x - (\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_le_hn y)"
	unfolding d_IN_def
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space finite1 currentD_finite[OF h] split: split_indicator intro!: nn_integral_cong)
	done
	also have eq_h_n: "(\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_gt_hn y) = d_IN (h n) x - (\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_le_hn y)"
	unfolding d_IN_def
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: AE_count_space finite1 currentD_finite[OF h] split: split_indicator intro!: nn_integral_cong)
	done
	also have "d_IN (h 0) x - (\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_le_hn y) - (d_IN (h n) x - (\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_le_hn y)) + f n (SOURCE, \<langle>x\<rangle>) =
	(\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_le_hn y) - (\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_le_hn y)"
	apply (subst diff_add_assoc2_ennreal)
	subgoal by (auto simp add: eq_h_0[symmetric] eq_h_n[symmetric] split: split_indicator intro!: nn_integral_mono)
	apply (subst diff_add_assoc2_ennreal)
	subgoal by (auto simp: d_IN_def split: split_indicator intro!: nn_integral_mono)
	apply (subst diff_diff_commute_ennreal)
	apply (subst diff_diff_ennreal')
	subgoal
	by (auto simp: d_IN_def split: split_indicator intro!: nn_integral_mono) []
	subgoal
	unfolding eq_h_n[symmetric]
	by (rule add_increasing2)
	(auto simp add: d_IN_def split: split_indicator intro!: nn_integral_mono)
	apply (subst diff_add_assoc2_ennreal[symmetric])
	unfolding eq
	using currentD_finite_IN[OF h]
	apply simp_all
	done
	also have "(\<Sum>\<^sup>+ y. h n (y, x) * indicator ?h0_le_hn y) - (\<Sum>\<^sup>+ y. h 0 (y, x) * indicator ?h0_le_hn y) = (\<Sum>\<^sup>+ y. h n (y, x) - h 0 (y, x))"
	apply(subst nn_integral_diff[symmetric])
	apply(simp_all add: AE_count_space max_def finite1 split: split_indicator)
	apply(rule nn_integral_cong; auto simp add: not_le split: split_indicator)
	by (metis diff_eq_0_ennreal le_less not_le top_greatest)
	also have "\<dots> = (\<Sum>\<^sup>+ y\<in>range Inner. f n (\<langle>x\<rangle>, y))" using B disjoint
	apply(simp add: nn_integral_count_space_reindex cong: nn_integral_cong_simp outgoing_def)
	apply(auto simp add: B_out currentD_outside[OF h] max.commute intro!: nn_integral_cong split: split_indicator dest: edge_antiparallel)
	done
	also have "\<dots> = (\<Sum>\<^sup>+ y. f n (\<langle>x\<rangle>, y) * indicator (range Inner) y)"
	by(simp add: nn_integral_add nn_integral_count_space_indicator max.left_commute max.commute)
	also have "\<dots> = d_OUT (f n) \<langle>x\<rangle>" using B disjoint
	unfolding d_OUT_def by(intro nn_integral_cong)(auto split: split_indicator simp add: notin_range_Inner)
	finally show ?thesis using B by(simp)
	qed
	qed

	have "weight \<Gamma> b - d_IN (h 0) b = (SUP n. value_flow \<Psi> (f n))"
	using OUT_f_SOURCE currentD_finite_IN[OF h, of 0 b] IN
	by (simp add: SUP_diff_ennreal less_top)
	also have "(SUP n. value_flow \<Psi> (f n)) \<le> \<alpha>" unfolding \<alpha>_def
	apply(rule SUP_least)
	apply(rule SUP_upper)
	apply(simp add: f)
	done
	also have "\<alpha> \<le> weight \<Gamma> b - d_IN (h 0) b" unfolding \<alpha>_def
	proof(rule SUP_least; clarsimp)
	fix f
	assume f: "flow \<Psi> f"
	have "d_OUT f SOURCE = (\<Sum>\<^sup>+ y. f (SOURCE, y) * indicator {\<langle>b\<rangle>} y)" unfolding d_OUT_def
	apply(rule nn_integral_cong)
	subgoal for x using flowD_capacity[OF f, of "(SOURCE, x)"]
	by(auto split: split_indicator)
	done
	also have "\<dots> = f (SOURCE, \<langle>b\<rangle>)" by(simp add: max_def)
	also have "\<dots> \<le> weight \<Gamma> b - d_IN (h 0) b" using flowD_capacity[OF f, of "(SOURCE, \<langle>b\<rangle>)"] by simp
	finally show "d_OUT f SOURCE \<le> \<dots>" .
	qed
	ultimately have \<alpha>: "\<alpha> = weight \<Gamma> b - d_IN (h 0) b" by(rule antisym[rotated])
	hence \<alpha>_finite: "\<alpha> \<noteq> \<top>" by simp

	from \<Psi>.ex_max_flow
	obtain g where g: "flow \<Psi> g"
	and value_g: "value_flow \<Psi> g = \<alpha>"
	and IN_g: "\<And>x. d_IN g x \<le> value_flow \<Psi> g" unfolding \<alpha>_def by blast

	have g_le_h0: "g (\<langle>x\<rangle>, \<langle>y\<rangle>) \<le> h 0 (x, y)" if "edge \<Gamma> x y" for x y
	using flowD_capacity[OF g, of "(\<langle>x\<rangle>, \<langle>y\<rangle>)"] that by simp
	note [simp] = \<Psi>.flowD_finite[OF g]

	have g_SOURCE: "g (SOURCE, \<langle>x\<rangle>) = (if x = b then \<alpha> else 0)" for x
	proof(cases "x = b")
	case True
	have "g (SOURCE, \<langle>x\<rangle>) = (\<Sum>\<^sup>+ y. g (SOURCE, y) * indicator {\<langle>x\<rangle>} y)" by(simp add: max_def)
	also have "\<dots> = value_flow \<Psi> g" unfolding d_OUT_def using True
	by(intro nn_integral_cong)(auto split: split_indicator intro: \<Psi>.flowD_outside[OF g])
	finally show ?thesis using value_g by(simp add: True)
	qed(simp add: \<Psi>.flowD_outside[OF g])

	let ?g = "\<lambda>(x, y). g (\<langle>y\<rangle>, \<langle>x\<rangle>)"

	define h' where "h' = h 0 \<oplus> ?g"
	have h'_simps: "h' (x, y) = (if edge \<Gamma> x y then h 0 (x, y) + g (\<langle>y\<rangle>, \<langle>x\<rangle>) - g (\<langle>x\<rangle>, \<langle>y\<rangle>) else 0)" for x y
	by(simp add: h'_def)

	have OUT_h'_B [simp]: "d_OUT h' x = 0" if "x \<in> B \<Gamma>" for x using that unfolding d_OUT_def
	by(simp add: nn_integral_0_iff emeasure_count_space_eq_0)(simp add: h'_simps B_out)
	have IN_h'_A [simp]: "d_IN h' x = 0" if "x \<in> A \<Gamma>" for x using that unfolding d_IN_def
	by(simp add: nn_integral_0_iff emeasure_count_space_eq_0)(simp add: h'_simps A_in)
	have h'_outside: "h' e = 0" if "e \<notin> \<^bold>E" for e unfolding h'_def using that by(rule plus_flow_outside)
	have OUT_h'_outside: "d_OUT h' x = 0" and IN_h'_outside: "d_IN h' x = 0" if "x \<notin> \<^bold>V" for x using that
	by(auto simp add: d_OUT_def d_IN_def nn_integral_0_iff emeasure_count_space_eq_0 vertex_def intro: h'_outside)

	have g_le_OUT: "g (SINK, \<langle>x\<rangle>) \<le> d_OUT g \<langle>x\<rangle>" for x
	by (subst flowD_KIR[OF g]) (simp_all add: d_IN_ge_point)

	have OUT_g_A: "d_OUT ?g x = d_OUT g \<langle>x\<rangle> - g (SINK, \<langle>x\<rangle>)" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_OUT ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (y, \<langle>x\<rangle>))"
	by(simp add: nn_integral_count_space_reindex d_OUT_def)
	also have "\<dots> = d_IN g \<langle>x\<rangle> - (\<Sum>\<^sup>+ y. g (y, \<langle>x\<rangle>) * indicator {SINK} y)" unfolding d_IN_def
	using that b disjoint flowD_capacity[OF g, of "(SOURCE, \<langle>x\<rangle>)"]
	by(subst nn_integral_diff[symmetric])
	(auto simp add: nn_integral_count_space_indicator notin_range_Inner max_def intro!: nn_integral_cong split: split_indicator if_split_asm)
	also have "\<dots> = d_OUT g \<langle>x\<rangle> - g (SINK, \<langle>x\<rangle>)" by(simp add: flowD_KIR[OF g] max_def)
	finally show ?thesis .
	qed
	have IN_g_A: "d_IN ?g x = d_OUT g \<langle>x\<rangle> - g (\<langle>x\<rangle>, SINK)" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_IN ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (\<langle>x\<rangle>, y))"
	by(simp add: nn_integral_count_space_reindex d_IN_def)
	also have "\<dots> = d_OUT g \<langle>x\<rangle> - (\<Sum>\<^sup>+ y. g (\<langle>x\<rangle>, y) * indicator {SINK} y)" unfolding d_OUT_def
	using that b disjoint flowD_capacity[OF g, of "(\<langle>x\<rangle>, SOURCE)"]
	by(subst nn_integral_diff[symmetric])
	(auto simp add: nn_integral_count_space_indicator notin_range_Inner max_def intro!: nn_integral_cong split: split_indicator if_split_asm)
	also have "\<dots> = d_OUT g \<langle>x\<rangle> - g (\<langle>x\<rangle>, SINK)" by(simp add: max_def)
	finally show ?thesis .
	qed
	have OUT_g_B: "d_OUT ?g x = d_IN g \<langle>x\<rangle> - g (SOURCE, \<langle>x\<rangle>)" if "x \<in> B \<Gamma>" for x
	proof -
	have "d_OUT ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (y, \<langle>x\<rangle>))"
	by(simp add: nn_integral_count_space_reindex d_OUT_def)
	also have "\<dots> = d_IN g \<langle>x\<rangle> - (\<Sum>\<^sup>+ y. g (y, \<langle>x\<rangle>) * indicator {SOURCE} y)" unfolding d_IN_def
	using that b disjoint flowD_capacity[OF g, of "(SINK, \<langle>x\<rangle>)"]
	by(subst nn_integral_diff[symmetric])
	(auto simp add: nn_integral_count_space_indicator notin_range_Inner max_def intro!: nn_integral_cong split: split_indicator if_split_asm)
	also have "\<dots> = d_IN g \<langle>x\<rangle> - g (SOURCE, \<langle>x\<rangle>)" by(simp add: max_def)
	finally show ?thesis .
	qed
	have IN_g_B: "d_IN ?g x = d_OUT g \<langle>x\<rangle>" if "x \<in> B \<Gamma>" for x
	proof -
	have "d_IN ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (\<langle>x\<rangle>, y))"
	by(simp add: nn_integral_count_space_reindex d_IN_def)
	also have "\<dots> = d_OUT g \<langle>x\<rangle>" unfolding d_OUT_def using that disjoint
	by(auto 4 3 simp add: nn_integral_count_space_indicator notin_range_Inner intro!: nn_integral_cong \<Psi>.flowD_outside[OF g] split: split_indicator)
	finally show ?thesis .
	qed

	have finite_g_IN: "d_IN ?g x \<noteq> \<top>" for x using \<alpha>_finite
	proof(rule neq_top_trans)
	have "d_IN ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (\<langle>x\<rangle>, y))"
	by(auto simp add: d_IN_def nn_integral_count_space_reindex)
	also have "\<dots> \<le> d_OUT g \<langle>x\<rangle>" unfolding d_OUT_def
	by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> = d_IN g \<langle>x\<rangle>" by(rule flowD_KIR[OF g]) simp_all
	also have "\<dots> \<le> \<alpha>" using IN_g value_g by simp
	finally show "d_IN ?g x \<le> \<alpha>" .
	qed

	have OUT_h'_A: "d_OUT h' x = d_OUT (h 0) x + g (\<langle>x\<rangle>, SINK) - g (SINK, \<langle>x\<rangle>)" if "x \<in> A \<Gamma>" for x
	proof -
	have "d_OUT h' x = d_OUT (h 0) x + (\<Sum>\<^sup>+ y. ?g (x, y) * indicator \<^bold>E (x, y)) - (\<Sum>\<^sup>+ y. ?g (y, x) * indicator \<^bold>E (x, y))"
	unfolding h'_def
	apply(subst OUT_plus_flow[of \<Gamma> "h 0" ?g, OF currentD_outside'[OF h]])
	apply(auto simp add: g_le_h0 finite_g_IN)
	done
	also have "(\<Sum>\<^sup>+ y. ?g (x, y) * indicator \<^bold>E (x, y)) = d_OUT ?g x" unfolding d_OUT_def using that
	by(auto simp add: A_in split: split_indicator intro!: nn_integral_cong \<Psi>.flowD_outside[OF g])
	also have "\<dots> = d_OUT g \<langle>x\<rangle> - g (SINK, \<langle>x\<rangle>)" using that by(rule OUT_g_A)
	also have "(\<Sum>\<^sup>+ y. ?g (y, x) * indicator \<^bold>E (x, y)) = d_IN ?g x" using that unfolding d_IN_def
	by(auto simp add: A_in split: split_indicator intro!: nn_integral_cong \<Psi>.flowD_outside[OF g])
	also have "\<dots> = d_OUT g \<langle>x\<rangle> - g (\<langle>x\<rangle>, SINK)" using that by(rule IN_g_A)
	also have "d_OUT (h 0) x + (d_OUT g \<langle>x\<rangle> - g (SINK, \<langle>x\<rangle>)) - \<dots> = d_OUT (h 0) x + g (\<langle>x\<rangle>, SINK) - g (SINK, \<langle>x\<rangle>)"
	apply(simp add: g_le_OUT add_diff_eq_ennreal d_OUT_ge_point)
	apply(subst diff_diff_commute_ennreal)
	apply(simp add: add_increasing d_OUT_ge_point g_le_OUT diff_diff_ennreal')
	apply(subst add.assoc)
	apply(subst (2) add.commute)
	apply(subst add.assoc[symmetric])
	apply(subst ennreal_add_diff_cancel_right)
	apply(simp_all add: \<Psi>.flowD_finite_OUT[OF g])
	done
	finally show ?thesis .
	qed

	have finite_g_OUT: "d_OUT ?g x \<noteq> \<top>" for x using \<alpha>_finite
	proof(rule neq_top_trans)
	have "d_OUT ?g x = (\<Sum>\<^sup>+ y\<in>range Inner. g (y, \<langle>x\<rangle>))"
	by(auto simp add: d_OUT_def nn_integral_count_space_reindex)
	also have "\<dots> \<le> d_IN g \<langle>x\<rangle>" unfolding d_IN_def
	by(auto simp add: nn_integral_count_space_indicator intro!: nn_integral_mono split: split_indicator)
	also have "\<dots> \<le> \<alpha>" using IN_g value_g by simp
	finally show "d_OUT ?g x \<le> \<alpha>" .
	qed

	have IN_h'_B: "d_IN h' x = d_IN (h 0) x + g (SOURCE, \<langle>x\<rangle>)" if "x \<in> B \<Gamma>" for x
	proof -
	have g_le: "g (SOURCE, \<langle>x\<rangle>) \<le> d_IN g \<langle>x\<rangle>"
	by (rule d_IN_ge_point)

	have "d_IN h' x = d_IN (h 0) x + (\<Sum>\<^sup>+ y. g (\<langle>x\<rangle>, \<langle>y\<rangle>) * indicator \<^bold>E (y, x)) - (\<Sum>\<^sup>+ y. g (\<langle>y\<rangle>, \<langle>x\<rangle>) * indicator \<^bold>E (y, x))"
	unfolding h'_def
	by(subst IN_plus_flow[of \<Gamma> "h 0" ?g, OF currentD_outside'[OF h]])
	(auto simp add: g_le_h0 finite_g_OUT)
	also have "(\<Sum>\<^sup>+ y. g (\<langle>x\<rangle>, \<langle>y\<rangle>) * indicator \<^bold>E (y, x)) = d_IN ?g x" unfolding d_IN_def using that
	by(intro nn_integral_cong)(auto split: split_indicator intro!: \<Psi>.flowD_outside[OF g] simp add: B_out)
	also have "\<dots> = d_OUT g \<langle>x\<rangle>" using that by(rule IN_g_B)
	also have "(\<Sum>\<^sup>+ y. g (\<langle>y\<rangle>, \<langle>x\<rangle>) * indicator \<^bold>E (y, x)) = d_OUT ?g x" unfolding d_OUT_def using that
	by(intro nn_integral_cong)(auto split: split_indicator intro!: \<Psi>.flowD_outside[OF g] simp add: B_out)
	also have "\<dots> = d_IN g \<langle>x\<rangle> - g (SOURCE, \<langle>x\<rangle>)" using that by(rule OUT_g_B)
	also have "d_IN (h 0) x + d_OUT g \<langle>x\<rangle> - \<dots> = d_IN (h 0) x + g (SOURCE, \<langle>x\<rangle>)"
	using \<Psi>.flowD_finite_IN[OF g] g_le
	by(cases "d_IN (h 0) x"; cases "d_IN g \<langle>x\<rangle>"; cases "d_IN g \<langle>x\<rangle>"; cases "g (SOURCE, \<langle>x\<rangle>)")
	(auto simp: flowD_KIR[OF g] top_add ennreal_minus_if ennreal_plus_if simp del: ennreal_plus)
	finally show ?thesis .
	qed

	have h': "current \<Gamma> h'"
	proof
	fix x
	consider (A) "x \<in> A \<Gamma>" \| (B) "x \<in> B \<Gamma>" \| (outside) "x \<notin> \<^bold>V" using bipartite_V by auto
	note cases = this

	show "d_OUT h' x \<le> weight \<Gamma> x"
	proof(cases rule: cases)
	case A
	then have "d_OUT h' x = d_OUT (h 0) x + g (\<langle>x\<rangle>, SINK) - g (SINK, \<langle>x\<rangle>)" by(simp add: OUT_h'_A)
	also have "\<dots> \<le> d_OUT (h 0) x + g (\<langle>x\<rangle>, SINK)" by(rule diff_le_self_ennreal)
	also have "g (\<langle>x\<rangle>, SINK) \<le> weight \<Gamma> x - d_OUT (h 0) x"
	using flowD_capacity[OF g, of "(\<langle>x\<rangle>, SINK)"] A by simp
	also have "d_OUT (h 0) x + \<dots> = weight \<Gamma> x"
	by(simp add: add_diff_eq_ennreal add_diff_inverse_ennreal currentD_finite_OUT[OF h] currentD_weight_OUT[OF h])
	finally show ?thesis by(simp add: add_left_mono)
	qed(simp_all add: OUT_h'_outside )

	show "d_IN h' x \<le> weight \<Gamma> x"
	proof(cases rule: cases)
	case B
	hence "d_IN h' x = d_IN (h 0) x + g (SOURCE, \<langle>x\<rangle>)" by(rule IN_h'_B)
	also have "\<dots> \<le> weight \<Gamma> x"
	by(simp add: g_SOURCE \<alpha> currentD_weight_IN[OF h] add_diff_eq_ennreal add_diff_inverse_ennreal currentD_finite_IN[OF h])
	finally show ?thesis .
	qed(simp_all add: IN_h'_outside)
	next
	show "h' e = 0" if "e \<notin> \<^bold>E" for e using that by(simp split: prod.split_asm add: h'_simps)
	qed
	moreover
	have SAT_h': "B \<Gamma> \<inter> \<^bold>V \<subseteq> SAT \<Gamma> h'"
	proof
	show "x \<in> SAT \<Gamma> h'" if "x \<in> B \<Gamma> \<inter> \<^bold>V" for x using that
	proof(cases "x = b")
	case True
	have "d_IN h' x = weight \<Gamma> x" using that True
	by(simp add: IN_h'_B g_SOURCE \<alpha> currentD_weight_IN[OF h] add_diff_eq_ennreal add_diff_inverse_ennreal currentD_finite_IN[OF h])
	thus ?thesis by(simp add: SAT.simps)
	next
	case False
	have "d_IN h' x = d_IN (h 0) x" using that False by(simp add: IN_h'_B g_SOURCE)
	also have "\<dots> = weight \<Gamma> x"
	using SAT[of 0, THEN subsetD, of x] False that currentD_SAT[OF h, of x 0] disjoint by auto
	finally show ?thesis by(simp add: SAT.simps)
	qed
	qed
	moreover
	have "wave \<Gamma> h'"
	proof
	have "separating \<Gamma> (B \<Gamma> \<inter> \<^bold>V)"
	proof
	fix x y p
	assume x: "x \<in> A \<Gamma>" and y: "y \<in> B \<Gamma>" and p: "path \<Gamma> x p y"
	hence Nil: "p \<noteq> []" using disjoint by(auto simp add: rtrancl_path_simps)
	from rtrancl_path_last[OF p Nil] last_in_set[OF Nil] y rtrancl_path_Range[OF p, of y]
	show "(\<exists>z\<in>set p. z \<in> B \<Gamma> \<inter> \<^bold>V) \<or> x \<in> B \<Gamma> \<inter> \<^bold>V" by(auto intro: vertexI2)
	qed
	moreover have TER: "B \<Gamma> \<inter> \<^bold>V \<subseteq> TER h'" using SAT_h' by(auto simp add: SINK)
	ultimately show "separating \<Gamma> (TER h')" by(rule separating_weakening)
	qed(rule h')
	ultimately show ?thesis by blast
	qed

	end

	lemma countable_bipartite_web_reduce_weight:
	assumes "weight \<Gamma> x \<ge> w"
	shows "countable_bipartite_web (reduce_weight \<Gamma> x w)"
	using bipartite_V A_vertex bipartite_E disjoint assms
	by unfold_locales (auto 4 3 simp add: weight_outside )

	lemma unhinder: \<comment> \<open>Lemma 6.9\<close>
	assumes loose: "loose \<Gamma>"
	and b: "b \<in> B \<Gamma>"
	and wb: "weight \<Gamma> b > 0"
	and \<delta>: "\<delta> > 0"
	shows "\<exists>\<epsilon>>0. \<epsilon> < \<delta> \<and> \<not> hindered (reduce_weight \<Gamma> b \<epsilon>)"
	proof(rule ccontr)
	assume "\<not> ?thesis"
	hence hindered: "hindered (reduce_weight \<Gamma> b \<epsilon>)" if "\<epsilon> > 0" "\<epsilon> < \<delta>" for \<epsilon> using that by simp

	from b disjoint have bnA: "b \<notin> A \<Gamma>" by blast

	define wb where "wb = enn2real (weight \<Gamma> b)"
	have wb_conv: "weight \<Gamma> b = ennreal wb" by(simp add: wb_def less_top[symmetric])
	have wb_pos: "wb > 0" using wb by(simp add: wb_conv)

	define \<epsilon> where "\<epsilon> n = min \<delta> wb / (n + 2)" for n :: nat
	have \<epsilon>_pos: "\<epsilon> n > 0" for n using wb_pos \<delta> by(simp add: \<epsilon>_def)
	have \<epsilon>_nonneg: "0 \<le> \<epsilon> n" for n using \<epsilon>_pos[of n] by simp
	have *: "\<epsilon> n \<le> min wb \<delta> / 2" for n using wb_pos \<delta>
	by(auto simp add: \<epsilon>_def field_simps min_def)
	have \<epsilon>_le: "\<epsilon> n \<le> wb" and \<epsilon>_less: "\<epsilon> n < wb" and \<epsilon>_less_\<delta>: "\<epsilon> n < \<delta>" and \<epsilon>_le': "\<epsilon> n \<le> wb / 2" for n
	using *[of n] \<epsilon>_pos[of n] by(auto)

	define \<Gamma>' where "\<Gamma>' n = reduce_weight \<Gamma> b (\<epsilon> n)" for n :: nat
	have \<Gamma>'_sel [simp]:
	"edge (\<Gamma>' n) = edge \<Gamma>"
	"A (\<Gamma>' n) = A \<Gamma>"
	"B (\<Gamma>' n) = B \<Gamma>"
	"weight (\<Gamma>' n) x = weight \<Gamma> x - (if x = b then \<epsilon> n else 0)"
	"essential (\<Gamma>' n) = essential \<Gamma>"
	"roofed_gen (\<Gamma>' n) = roofed_gen \<Gamma>"
	for n x by(simp_all add: \<Gamma>'_def)

	have vertex_\<Gamma>' [simp]: "vertex (\<Gamma>' n) = vertex \<Gamma>" for n
	by(simp add: vertex_def fun_eq_iff)

	from wb have "b \<in> \<^bold>V" using weight_outside[of b] by(auto intro: ccontr)
	interpret \<Gamma>': countable_bipartite_web "\<Gamma>' n" for n unfolding \<Gamma>'_def
	using wb_pos by(intro countable_bipartite_web_reduce_weight)(simp_all add: wb_conv \<epsilon>_le \<epsilon>_nonneg)

	obtain g where g: "\<And>n. current (\<Gamma>' n) (g n)"
	and w: "\<And>n. wave (\<Gamma>' n) (g n)"
	and hind: "\<And>n. hindrance (\<Gamma>' n) (g n)" using hindered[OF \<epsilon>_pos, unfolded wb_conv ennreal_less_iff, OF \<epsilon>_less_\<delta>]
	unfolding hindered.simps \<Gamma>'_def by atomize_elim metis
	from g have g\<Gamma>: "current \<Gamma> (g n)" for n
	by(rule current_weight_mono)(auto simp add: \<epsilon>_nonneg diff_le_self_ennreal)
	note [simp] = currentD_finite[OF g\<Gamma>]

	have b_TER: "b \<in> TER\<^bsub>\<Gamma>' n\<^esub> (g n)" for n
	proof(rule ccontr)
	assume b': "b \<notin> TER\<^bsub>\<Gamma>' n\<^esub> (g n)"
	then have TER: "TER\<^bsub>\<Gamma>' n\<^esub> (g n) = TER (g n)" using b \<epsilon>_nonneg[of n]
	by(auto simp add: SAT.simps split: if_split_asm intro: ennreal_diff_le_mono_left)
	from w[of n] TER have "wave \<Gamma> (g n)" by(simp add: wave.simps separating_gen.simps)
	moreover have "hindrance \<Gamma> (g n)" using hind[of n] TER bnA b'
	by(auto simp add: hindrance.simps split: if_split_asm)
	ultimately show False using loose_unhindered[OF loose] g\<Gamma>[of n] by(auto intro: hindered.intros)
	qed

	have IN_g_b: "d_IN (g n) b = weight \<Gamma> b - \<epsilon> n" for n using b_TER[of n] bnA
	by(auto simp add: currentD_SAT[OF g])

	define factor where "factor n = (wb - \<epsilon> 0) / (wb - \<epsilon> n)" for n
	have factor_le_1: "factor n \<le> 1" for n using wb_pos \<delta> \<epsilon>_less[of n]
	by(auto simp add: factor_def field_simps \<epsilon>_def min_def)
	have factor_pos: "0 < factor n" for n using wb_pos \<delta> * \<epsilon>_less by(simp add: factor_def field_simps)
	have factor: "(wb - \<epsilon> n) * factor n = wb - \<epsilon> 0" for n using \<epsilon>_less[of n]
	by(simp add: factor_def field_simps)

	define g' where "g' = (\<lambda>n (x, y). if y = b then g n (x, y) * factor n else g n (x, y))"
	have g'_simps: "g' n (x, y) = (if y = b then g n (x, y) * factor n else g n (x, y))" for n x y by(simp add: g'_def)
	have g'_le_g: "g' n e \<le> g n e" for n e using factor_le_1[of n]
	by(cases e "g n e" rule: prod.exhaust[case_product ennreal_cases])
	(auto simp add: g'_simps field_simps mult_left_le)

	have "4 + (n * 6 + n * (n * 2)) \<noteq> (0 :: real)" for n :: nat
	by(metis (mono_tags, opaque_lifting) add_is_0 of_nat_eq_0_iff of_nat_numeral zero_neq_numeral)
	then have IN_g': "d_IN (g' n) x = (if x = b then weight \<Gamma> b - \<epsilon> 0 else d_IN (g n) x)" for x n
	using b_TER[of n] bnA factor_pos[of n] factor[of n] wb_pos \<delta>
	by(auto simp add: d_IN_def g'_simps nn_integral_divide nn_integral_cmult currentD_SAT[OF g] wb_conv \<epsilon>_def field_simps
	ennreal_minus ennreal_mult'[symmetric] intro!: arg_cong[where f=ennreal])
	have OUT_g': "d_OUT (g' n) x = d_OUT (g n) x - g n (x, b) * (1 - factor n)" for n x
	proof -
	have "d_OUT (g' n) x = (\<Sum>\<^sup>+ y. g n (x, y)) - (\<Sum>\<^sup>+ y. (g n (x, y) * (1 - factor n)) * indicator {b} y)"
	using factor_le_1[of n] factor_pos[of n]
	apply(cases "g n (x, b)")
	apply(subst nn_integral_diff[symmetric])
	apply(auto simp add: g'_simps nn_integral_divide d_OUT_def AE_count_space mult_left_le ennreal_mult_eq_top_iff
	ennreal_mult'[symmetric] ennreal_minus_if
	intro!: nn_integral_cong split: split_indicator)
	apply(simp_all add: field_simps)
	done
	also have "\<dots> = d_OUT (g n) x - g n (x, b) * (1 - factor n)" using factor_le_1[of n]
	by(subst nn_integral_indicator_singleton)(simp_all add: d_OUT_def field_simps)
	finally show ?thesis .
	qed

	have g': "current (\<Gamma>' 0) (g' n)" for n
	proof
	show "d_OUT (g' n) x \<le> weight (\<Gamma>' 0) x" for x
	using b_TER[of n] currentD_weight_OUT[OF g, of n x] \<epsilon>_le[of 0] factor_le_1[of n]
	by(auto simp add: OUT_g' SINK.simps ennreal_diff_le_mono_left)
	show "d_IN (g' n) x \<le> weight (\<Gamma>' 0) x" for x
	using d_IN_mono[of "g' n" x, OF g'_le_g] currentD_weight_IN[OF g, of n x] b_TER[of n] b
	by(auto simp add: IN_g' SAT.simps wb_conv \<epsilon>_def)
	show "g' n e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Gamma>' 0\<^esub>" for e using that by(cases e)(clarsimp simp add: g'_simps currentD_outside[OF g])
	qed

	have SINK_g': "SINK (g n) = SINK (g' n)" for n using factor_pos[of n]
	by(auto simp add: SINK.simps currentD_OUT_eq_0[OF g] currentD_OUT_eq_0[OF g'] g'_simps split: if_split_asm)
	have SAT_g': "SAT (\<Gamma>' n) (g n) = SAT (\<Gamma>' 0) (g' n)" for n using b_TER[of n] \<epsilon>_le'[of 0]
	by(auto simp add: SAT.simps wb_conv IN_g' IN_g_b)
	have TER_g': "TER\<^bsub>\<Gamma>' n\<^esub> (g n) = TER\<^bsub>\<Gamma>' 0\<^esub> (g' n)" for n
	using b_TER[of n] by(auto simp add: SAT.simps SINK_g' OUT_g' IN_g' wb_conv \<epsilon>_def)

	have w': "wave (\<Gamma>' 0) (g' n)" for n
	proof
	have "separating (\<Gamma>' 0) (TER\<^bsub>\<Gamma>' n\<^esub> (g n))" using waveD_separating[OF w, of n]
	by(simp add: separating_gen.simps)
	then show "separating (\<Gamma>' 0) (TER\<^bsub>\<Gamma>' 0\<^esub> (g' n))" unfolding TER_g' .
	qed(rule g')

	define f where "f = rec_nat (g 0) (\<lambda>n rec. rec \<frown>\<^bsub>\<Gamma>' 0\<^esub> g' (n + 1))"
	have f_simps [simp]:
	"f 0 = g 0"
	"f (Suc n) = f n \<frown>\<^bsub>\<Gamma>' 0\<^esub> g' (n + 1)"
	for n by(simp_all add: f_def)

	have f: "current (\<Gamma>' 0) (f n)" and fw: "wave (\<Gamma>' 0) (f n)" for n
	proof(induction n)
	case (Suc n)
	{ case 1 show ?case unfolding f_simps using Suc.IH g' by(rule current_plus_web) }
	{ case 2 show ?case unfolding f_simps using Suc.IH g' w' by(rule wave_plus') }
	qed(simp_all add: g w)

	have f_inc: "n \<le> m \<Longrightarrow> f n \<le> f m" for n m
	proof(induction m rule: dec_induct)
	case (step k)
	note step.IH
	also have "f k \<le> (f k \<frown>\<^bsub>\<Gamma>' 0\<^esub> g' (k + 1))"
	by(rule le_funI plus_web_greater)+
	also have "\<dots> = f (Suc k)" by simp
	finally show ?case .
	qed simp
	have chain_f: "Complete_Partial_Order.chain (\<le>) (range f)"
	by(rule chain_imageI[where le_a="(\<le>)"])(simp_all add: f_inc)
	have "countable (support_flow (f n))" for n using current_support_flow[OF f, of n]
	by(rule countable_subset) simp
	hence supp_f: "countable (support_flow (SUP n. f n))" by(subst support_flow_Sup)simp

	have RF_f: "RF (TER\<^bsub>\<Gamma>' 0\<^esub> (f n)) = RF (\<Union>i\<le>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i))" for n
	proof(induction n)
	case 0 show ?case by(simp add: TER_g')
	next
	case (Suc n)
	have "RF (TER\<^bsub>\<Gamma>' 0\<^esub> (f (Suc n))) = RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (f n \<frown>\<^bsub>\<Gamma>' 0\<^esub> g' (n + 1)))" by simp
	also have "\<dots> = RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (f n) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' (n + 1)))" using f fw g' w'
	by(rule RF_TER_plus_web)
	also have "\<dots> = RF\<^bsub>\<Gamma>' 0\<^esub> (RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (f n)) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' (n + 1)))"
	by(simp add: roofed_idem_Un1)
	also have "RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (f n)) = RF\<^bsub>\<Gamma>' 0\<^esub> (\<Union>i\<le>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i))" by(simp add: Suc.IH)
	also have "RF\<^bsub>\<Gamma>' 0\<^esub> (\<dots> \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' (n + 1))) = RF\<^bsub>\<Gamma>' 0\<^esub> ((\<Union>i\<le>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i)) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' (n + 1)))"
	by(simp add: roofed_idem_Un1)
	also have "(\<Union>i\<le>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i)) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' (n + 1)) = (\<Union>i\<le>Suc n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i))"
	unfolding atMost_Suc UN_insert by(simp add: Un_commute)
	finally show ?case by simp
	qed

	define g\<omega> where "g\<omega> = (SUP n. f n)"
	have g\<omega>: "current (\<Gamma>' 0) g\<omega>" unfolding g\<omega>_def using chain_f
	by(rule current_Sup)(auto simp add: f supp_f)
	have w\<omega>: "wave (\<Gamma>' 0) g\<omega>" unfolding g\<omega>_def using chain_f
	by(rule wave_lub)(auto simp add: fw supp_f)
	from g\<omega> have g\<omega>': "current (\<Gamma>' n) g\<omega>" for n using wb_pos \<delta>
	by(elim current_weight_mono)(auto simp add: \<epsilon>_le wb_conv \<epsilon>_def field_simps ennreal_minus_if min_le_iff_disj)

	have SINK_g\<omega>: "SINK g\<omega> = (\<Inter>n. SINK (f n))" unfolding g\<omega>_def
	by(subst SINK_Sup[OF chain_f])(simp_all add: supp_f)
	have SAT_g\<omega>: "SAT (\<Gamma>' 0) (f n) \<subseteq> SAT (\<Gamma>' 0) g\<omega>" for n
	unfolding g\<omega>_def by(rule SAT_Sup_upper) simp

	have g_b_out: "g n (b, x) = 0" for n x using b_TER[of n] by(simp add: SINK.simps currentD_OUT_eq_0[OF g])
	have g'_b_out: "g' n (b, x) = 0" for n x by(simp add: g'_simps g_b_out)
	have "f n (b, x) = 0" for n x by(induction n)(simp_all add: g_b_out g'_b_out)
	hence b_SINK_f: "b \<in> SINK (f n)" for n by(simp add: SINK.simps d_OUT_def)
	hence b_SINK_g\<omega>: "b \<in> SINK g\<omega>" by(simp add: SINK_g\<omega>)

	have RF_circ: "RF\<^sup>\<circ>\<^bsub>\<Gamma>' n\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (g' n)) = RF\<^sup>\<circ>\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (g' n))" for n by(simp add: roofed_circ_def)
	have edge_restrict_\<Gamma>': "edge (quotient_web (\<Gamma>' 0) (g' n)) = edge (quotient_web (\<Gamma>' n) (g n))" for n
	by(simp add: fun_eq_iff TER_g' RF_circ)
	have restrict_curr_g': "f \<upharpoonleft> \<Gamma>' 0 / g' n = f \<upharpoonleft> \<Gamma>' n / g n" for n f
	by(simp add: restrict_current_def RF_circ TER_g')

	have RF_restrict: "roofed_gen (quotient_web (\<Gamma>' n) (g n)) = roofed_gen (quotient_web (\<Gamma>' 0) (g' n))" for n
	by(simp add: roofed_def fun_eq_iff edge_restrict_\<Gamma>')

	have g\<omega>r': "current (quotient_web (\<Gamma>' 0) (g' n)) (g\<omega> \<upharpoonleft> \<Gamma>' 0 / g' n)" for n using w' g\<omega>
	by(rule current_restrict_current)
	have g\<omega>r: "current (quotient_web (\<Gamma>' n) (g n)) (g\<omega> \<upharpoonleft> \<Gamma>' n / g n)" for n using w g\<omega>'
	by(rule current_restrict_current)
	have w\<omega>r: "wave (quotient_web (\<Gamma>' n) (g n)) (g\<omega> \<upharpoonleft> \<Gamma>' n / g n)" (is "wave ?\<Gamma>' ?g\<omega>") for n
	proof
	have *: "wave (quotient_web (\<Gamma>' 0) (g' n)) (g\<omega> \<upharpoonleft> \<Gamma>' 0 / g' n)"
	using g' w' g\<omega> w\<omega> by(rule wave_restrict_current)
	have "d_IN (g\<omega> \<upharpoonleft> \<Gamma>' n / g n) b = 0"
	by(rule d_IN_restrict_current_outside roofed_greaterI b_TER)+
	hence SAT_subset: "SAT (quotient_web (\<Gamma>' 0) (g' n)) (g\<omega> \<upharpoonleft> \<Gamma>' n / g n) \<subseteq> SAT ?\<Gamma>' (g\<omega> \<upharpoonleft> \<Gamma>' n / g n)"
	using b_TER[of n] wb_pos
	by(auto simp add: SAT.simps TER_g' RF_circ wb_conv \<epsilon>_def field_simps
	ennreal_minus_if split: if_split_asm)
	hence TER_subset: "TER\<^bsub>quotient_web (\<Gamma>' 0) (g' n)\<^esub> (g\<omega> \<upharpoonleft> \<Gamma>' n / g n) \<subseteq> TER\<^bsub>?\<Gamma>'\<^esub> (g\<omega> \<upharpoonleft> \<Gamma>' n / g n)"
	using SINK_g' by(auto simp add: restrict_curr_g')

	show "separating ?\<Gamma>' (TER\<^bsub>?\<Gamma>'\<^esub> ?g\<omega>)" (is "separating _ ?TER")
	proof
	fix x y p
	assume xy: "x \<in> A ?\<Gamma>'" "y \<in> B ?\<Gamma>'" and p: "path ?\<Gamma>' x p y"
	from p have p': "path (quotient_web (\<Gamma>' 0) (g' n)) x p y" by(simp add: edge_restrict_\<Gamma>')
	with waveD_separating[OF *, THEN separatingD, simplified, OF p'] TER_g'[of n] SINK_g' SAT_g' restrict_curr_g' SAT_subset xy
	show "(\<exists>z\<in>set p. z \<in> ?TER) \<or> x \<in> ?TER" by auto
	qed

	show "d_OUT (g\<omega> \<upharpoonleft> \<Gamma>' n / g n) x = 0" if "x \<notin> RF\<^bsub>?\<Gamma>'\<^esub> ?TER" for x
	unfolding restrict_curr_g'[symmetric] using TER_subset that
	by(intro waveD_OUT[OF *])(auto simp add: TER_g' restrict_curr_g' RF_restrict intro: in_roofed_mono)
	qed

	have RF_g\<omega>: "RF (TER\<^bsub>\<Gamma>' 0\<^esub> g\<omega>) = RF (\<Union>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' n))"
	proof -
	have "RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> g\<omega>) = RF (\<Union>i. TER\<^bsub>\<Gamma>' 0\<^esub> (f i))"
	unfolding g\<omega>_def by(subst RF_TER_Sup[OF _ _ chain_f])(auto simp add: f fw supp_f)
	also have "\<dots> = RF (\<Union>i. RF (TER\<^bsub>\<Gamma>' 0\<^esub> (f i)))" by(simp add: roofed_UN)
	also have "\<dots> = RF (\<Union>i. \<Union>j\<le>i. TER\<^bsub>\<Gamma>' 0\<^esub> (g' j))" unfolding RF_f roofed_UN by simp
	also have "(\<Union>i. \<Union>j\<le>i. TER\<^bsub>\<Gamma>' 0\<^esub> (g' j)) = (\<Union>i. TER\<^bsub>\<Gamma>' 0\<^esub> (g' i))" by auto
	finally show ?thesis by simp
	qed

	have SAT_plus_\<omega>: "SAT (\<Gamma>' n) (g n \<frown>\<^bsub>\<Gamma>' n\<^esub> g\<omega>) = SAT (\<Gamma>' 0) (g' n \<frown>\<^bsub>\<Gamma>' 0\<^esub> g\<omega>)" for n
	apply(intro set_eqI)
	apply(simp add: SAT.simps IN_plus_current[OF g w g\<omega>r] IN_plus_current[OF g' w' g\<omega>r'] TER_g')
	apply(cases "d_IN (g\<omega> \<upharpoonleft> \<Gamma>' n / g n) b")
	apply(auto simp add: SAT.simps wb_conv d_IN_plus_web IN_g')
	apply(simp_all add: wb_conv IN_g_b restrict_curr_g' \<epsilon>_def field_simps)
	apply(metis TER_g' b_TER roofed_greaterI)+
	done
	have SINK_plus_\<omega>: "SINK (g n \<frown>\<^bsub>\<Gamma>' n\<^esub> g\<omega>) = SINK (g' n \<frown>\<^bsub>\<Gamma>' 0\<^esub> g\<omega>)" for n
	apply(rule set_eqI; simp add: SINK.simps OUT_plus_current[OF g w g\<omega>r] OUT_plus_current[OF g' w'] current_restrict_current[OF w' g\<omega>])
	using factor_pos[of n]
	by(auto simp add: RF_circ TER_g' restrict_curr_g' currentD_OUT_eq_0[OF g] currentD_OUT_eq_0[OF g'] g'_simps split: if_split_asm)
	have TER_plus_\<omega>: "TER\<^bsub>\<Gamma>' n\<^esub> (g n \<frown>\<^bsub>\<Gamma>' n\<^esub> g\<omega>) = TER\<^bsub>\<Gamma>' 0\<^esub> (g' n \<frown>\<^bsub>\<Gamma>' 0\<^esub> g\<omega>)" for n
	by(rule set_eqI iffI)+(simp_all add: SAT_plus_\<omega> SINK_plus_\<omega>)

	define h where "h n = g n \<frown>\<^bsub>\<Gamma>' n\<^esub> g\<omega>" for n
	have h: "current (\<Gamma>' n) (h n)" for n unfolding h_def using g w
	by(rule current_plus_current)(rule current_restrict_current[OF w g\<omega>'])
	have hw: "wave (\<Gamma>' n) (h n)" for n unfolding h_def using g w g\<omega>' w\<omega>r by(rule wave_plus)

	define T where "T = TER\<^bsub>\<Gamma>' 0\<^esub> g\<omega>"
	have RF_h: "RF (TER\<^bsub>\<Gamma>' n\<^esub> (h n)) = RF T" for n
	proof -
	have "RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' n\<^esub> (h n)) = RF\<^bsub>\<Gamma>' 0\<^esub> (RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> g\<omega>) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' n))"
	unfolding h_def TER_plus_\<omega> RF_TER_plus_web[OF g' w' g\<omega> w\<omega>] roofed_idem_Un1 by(simp add: Un_commute)
	also have "\<dots> = RF ((\<Union>n. TER\<^bsub>\<Gamma>' 0\<^esub> (g' n)) \<union> TER\<^bsub>\<Gamma>' 0\<^esub> (g' n))"
	by(simp add: RF_g\<omega> roofed_idem_Un1)
	also have "\<dots> = RF\<^bsub>\<Gamma>' 0\<^esub> T" unfolding T_def
	by(auto simp add: RF_g\<omega> intro!: arg_cong2[where f=roofed] del: equalityI) auto
	finally show ?thesis by simp
	qed
	have OUT_h_nT: "d_OUT (h n) x = 0" if "x \<notin> RF T" for n x
	by(rule waveD_OUT[OF hw])(simp add: RF_h that)
	have IN_h_nT: "d_IN (h n) x = 0" if "x \<notin> RF T" for n x
	by(rule wave_not_RF_IN_zero[OF h hw])(simp add: RF_h that)
	have OUT_h_b: "d_OUT (h n) b = 0" for n using b_TER[of n] b_SINK_g\<omega>[THEN in_SINK_restrict_current]
	by(auto simp add: h_def OUT_plus_current[OF g w g\<omega>r] SINK.simps)
	have OUT_h_\<E>: "d_OUT (h n) x = 0" if "x \<in> \<E> T" for x n using that
	apply(subst (asm) \<E>_RF[symmetric])
	apply(subst (asm) (1 2) RF_h[symmetric, of n])
	apply(subst (asm) \<E>_RF)
	apply(simp add: SINK.simps)
	done
	have IN_h_\<E>: "d_IN (h n) x = weight (\<Gamma>' n) x" if "x \<in> \<E> T" "x \<notin> A \<Gamma>" for x n using that
	apply(subst (asm) \<E>_RF[symmetric])
	apply(subst (asm) (1 2) RF_h[symmetric, of n])
	apply(subst (asm) \<E>_RF)
	apply(simp add: currentD_SAT[OF h])
	done

	have b_SAT: "b \<in> SAT (\<Gamma>' 0) (h 0)" using b_TER[of 0]
	by(auto simp add: h_def SAT.simps d_IN_plus_web intro: order_trans)
	have b_T: "b \<in> T" using b_SINK_g\<omega> b_TER by(simp add: T_def)(metis SAT_g\<omega> subsetD f_simps(1))

	have essential: "b \<in> \<E> T"
	proof(rule ccontr)
	assume "b \<notin> \<E> T"
	hence b: "b \<notin> \<E> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0))"
	proof(rule contrapos_nn)
	assume "b \<in> \<E> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0))"
	then obtain p y where p: "path \<Gamma> b p y" and y: "y \<in> B \<Gamma>" and distinct: "distinct (b # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0))" by(rule \<E>_E_RF) auto
	from bypass have bypass': "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> T" unfolding RF_h by(auto intro: roofed_greaterI)
	have "essential \<Gamma> (B \<Gamma>) T b" using p y by(rule essentialI)(auto dest: bypass')
	then show "b \<in> \<E> T" using b_T by simp
	qed

	have h0: "current \<Gamma> (h 0)" using h[of 0] by(rule current_weight_mono)(simp_all add: wb_conv \<epsilon>_nonneg)
	moreover have "wave \<Gamma> (h 0)"
	proof
	have "separating (\<Gamma>' 0) (\<E>\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)))" by(rule separating_essential)(rule waveD_separating[OF hw])
	then have "separating \<Gamma> (\<E> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)))" by(simp add: separating_gen.simps)
	moreover have subset: "\<E> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)) \<subseteq> TER (h 0)" using \<epsilon>_nonneg[of 0] b
	by(auto simp add: SAT.simps wb_conv split: if_split_asm)
	ultimately show "separating \<Gamma> (TER (h 0))" by(rule separating_weakening)
	qed(rule h0)
	ultimately have "h 0 = zero_current" by(rule looseD_wave[OF loose])
	then have "d_IN (h 0) b = 0" by(simp)
	with b_SAT wb \<open>b \<notin> A \<Gamma>\<close> show False by(simp add: SAT.simps wb_conv \<epsilon>_def ennreal_minus_if split: if_split_asm)
	qed

	define S where "S = {x \<in> RF (T \<inter> B \<Gamma>) \<inter> A \<Gamma>. essential \<Gamma> (T \<inter> B \<Gamma>) (RF (T \<inter> B \<Gamma>) \<inter> A \<Gamma>) x}"
	define \<Gamma>_h where "\<Gamma>_h = \<lparr> edge = \<lambda>x y. edge \<Gamma> x y \<and> x \<in> S \<and> y \<in> T \<and> y \<in> B \<Gamma>, weight = \<lambda>x. weight \<Gamma> x * indicator (S \<union> T \<inter> B \<Gamma>) x, A = S, B = T \<inter> B \<Gamma>\<rparr>"
	have \<Gamma>_h_sel [simp]:
	"edge \<Gamma>_h x y \<longleftrightarrow> edge \<Gamma> x y \<and> x \<in> S \<and> y \<in> T \<and> y \<in> B \<Gamma>"
	"A \<Gamma>_h = S"
	"B \<Gamma>_h = T \<inter> B \<Gamma>"
	"weight \<Gamma>_h x = weight \<Gamma> x * indicator (S \<union> T \<inter> B \<Gamma>) x"
	for x y
	by(simp_all add: \<Gamma>_h_def)

	have vertex_\<Gamma>_hD: "x \<in> S \<union> (T \<inter> B \<Gamma>)" if "vertex \<Gamma>_h x" for x
	using that by(auto simp add: vertex_def)
	have S_vertex: "vertex \<Gamma>_h x" if "x \<in> S" for x
	proof -
	from that have a: "x \<in> A \<Gamma>" and RF: "x \<in> RF (T \<inter> B \<Gamma>)" and ess: "essential \<Gamma> (T \<inter> B \<Gamma>) (RF (T \<inter> B \<Gamma>) \<inter> A \<Gamma>) x"
	by(simp_all add: S_def)
	from ess obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and yT: "y \<in> T"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (T \<inter> B \<Gamma>) \<inter> A \<Gamma>" by(rule essentialE_RF)(auto intro: roofed_greaterI)
	from p a y disjoint have "edge \<Gamma> x y"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	with that y yT show ?thesis by(auto intro!: vertexI1)
	qed
	have OUT_not_S: "d_OUT (h n) x = 0" if "x \<notin> S" for x n
	proof(rule classical)
	assume *: "d_OUT (h n) x \<noteq> 0"
	consider (A) "x \<in> A \<Gamma>" \| (B) "x \<in> B \<Gamma>" \| (outside) "x \<notin> A \<Gamma>" "x \<notin> B \<Gamma>" by blast
	then show ?thesis
	proof cases
	case B with currentD_OUT[OF h, of x n] show ?thesis by simp
	next
	case outside with currentD_outside_OUT[OF h, of x n] show ?thesis by(simp add: not_vertex)
	next
	case A
	from * obtain y where xy: "h n (x, y) \<noteq> 0" using currentD_OUT_eq_0[OF h, of n x] by auto
	then have edge: "edge \<Gamma> x y" using currentD_outside[OF h] by(auto)
	hence p: "path \<Gamma> x [y] y" by(simp add: rtrancl_path_simps)

	from bipartite_E[OF edge] have x: "x \<in> A \<Gamma>" and y: "y \<in> B \<Gamma>" by simp_all
	moreover have "x \<in> RF (RF (T \<inter> B \<Gamma>))"
	proof
	fix p y'
	assume p: "path \<Gamma> x p y'" and y': "y' \<in> B \<Gamma>"
	from p x y' disjoint have py: "p = [y']"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	have "separating (\<Gamma>' 0) (RF\<^bsub>\<Gamma>' 0\<^esub> (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)))" unfolding separating_RF
	by(rule waveD_separating[OF hw])
	from separatingD[OF this, of x p y'] py p x y'
	have "x \<in> RF T \<or> y' \<in> RF T" by(auto simp add: RF_h)
	thus "(\<exists>z\<in>set p. z \<in> RF (T \<inter> B \<Gamma>)) \<or> x \<in> RF (T \<inter> B \<Gamma>)"
	proof cases
	case right with y' py show ?thesis by(simp add: RF_in_B)
	next
	case left
	have "x \<notin> \<E> T" using OUT_h_\<E>[of x n] xy by(auto simp add: currentD_OUT_eq_0[OF h])
	with left have "x \<in> RF\<^sup>\<circ> T" by(simp add: roofed_circ_def)
	from RF_circ_edge_forward[OF this, of y'] p py have "y' \<in> RF T" by(simp add: rtrancl_path_simps)
	with y' have "y' \<in> T" by(simp add: RF_in_B)
	with y' show ?thesis using py by(auto intro: roofed_greaterI)
	qed
	qed
	moreover have "y \<in> T" using IN_h_nT[of y n] y xy by(auto simp add: RF_in_B currentD_IN_eq_0[OF h])
	with p x y disjoint have "essential \<Gamma> (T \<inter> B \<Gamma>) (RF (T \<inter> B \<Gamma>) \<inter> A \<Gamma>) x" by(auto intro!: essentialI)
	ultimately have "x \<in> S" unfolding roofed_idem by(simp add: S_def)
	with that show ?thesis by contradiction
	qed
	qed

	have B_vertex: "vertex \<Gamma>_h y" if T: "y \<in> T" and B: "y \<in> B \<Gamma>" and w: "weight \<Gamma> y > 0" for y
	proof -
	from T B disjoint \<epsilon>_less[of 0] w
	have "d_IN (h 0) y > 0" using IN_h_\<E>[of y 0] by(cases "y \<in> A \<Gamma>")(auto simp add: essential_BI wb_conv ennreal_minus_if)
	then obtain x where xy: "h 0 (x, y) \<noteq> 0" using currentD_IN_eq_0[OF h, of 0 y] by(auto)
	then have edge: "edge \<Gamma> x y" using currentD_outside[OF h] by(auto)
	from xy have "d_OUT (h 0) x \<noteq> 0" by(auto simp add: currentD_OUT_eq_0[OF h])
	hence "x \<in> S" using OUT_not_S[of x 0] by(auto)
	with edge T B show ?thesis by(simp add: vertexI2)
	qed

	have \<Gamma>_h: "countable_bipartite_web \<Gamma>_h"
	proof
	show "\<^bold>V\<^bsub>\<Gamma>_h\<^esub> \<subseteq> A \<Gamma>_h \<union> B \<Gamma>_h" by(auto simp add: vertex_def)
	show "A \<Gamma>_h \<subseteq> \<^bold>V\<^bsub>\<Gamma>_h\<^esub>" using S_vertex by auto
	show "x \<in> A \<Gamma>_h \<and> y \<in> B \<Gamma>_h" if "edge \<Gamma>_h x y" for x y using that by auto
	show "A \<Gamma>_h \<inter> B \<Gamma>_h = {}" using disjoint by(auto simp add: S_def)
	have "\<^bold>E\<^bsub>\<Gamma>_h\<^esub> \<subseteq> \<^bold>E" by auto
	thus "countable \<^bold>E\<^bsub>\<Gamma>_h\<^esub>" by(rule countable_subset) simp
	show "weight \<Gamma>_h x \<noteq> \<top>" for x by(simp split: split_indicator)
	show "weight \<Gamma>_h x = 0" if "x \<notin> \<^bold>V\<^bsub>\<Gamma>_h\<^esub>" for x
	using that S_vertex B_vertex[of x]
	by(cases "weight \<Gamma>_h x > 0")(auto split: split_indicator)
	qed
	then interpret \<Gamma>_h: countable_bipartite_web \<Gamma>_h .

	have essential_T: "essential \<Gamma> (B \<Gamma>) T = essential \<Gamma> (B \<Gamma>) (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0))"
	proof(rule ext iffI)+
	fix x
	assume "essential \<Gamma> (B \<Gamma>) T x"
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and distinct: "distinct (x # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF T" by(rule essentialE_RF)auto
	from bypass have bypass': "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)"
	unfolding RF_h[of 0, symmetric] by(blast intro: roofed_greaterI)
	show "essential \<Gamma> (B \<Gamma>) (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)) x" using p y
	by(blast intro: essentialI dest: bypass')
	next
	fix x
	assume "essential \<Gamma> (B \<Gamma>) (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0)) x"
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and distinct: "distinct (x # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER\<^bsub>\<Gamma>' 0\<^esub> (h 0))" by(rule essentialE_RF)auto
	from bypass have bypass': "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> T"
	unfolding RF_h[of 0] by(blast intro: roofed_greaterI)
	show "essential \<Gamma> (B \<Gamma>) T x" using p y
	by(blast intro: essentialI dest: bypass')
	qed

	have h': "current \<Gamma>_h (h n)" for n
	proof
	show "d_OUT (h n) x \<le> weight \<Gamma>_h x" for x
	using currentD_weight_OUT[OF h, of n x] \<epsilon>_nonneg[of n] \<Gamma>'.currentD_OUT'[OF h, of x n] OUT_not_S
	by(auto split: split_indicator if_split_asm elim: order_trans intro: diff_le_self_ennreal in_roofed_mono simp add: OUT_h_b roofed_circ_def)

	show "d_IN (h n) x \<le> weight \<Gamma>_h x" for x
	using currentD_weight_IN[OF h, of n x] currentD_IN[OF h, of x n] \<epsilon>_nonneg[of n] b_T b \<Gamma>'.currentD_IN'[OF h, of x n] IN_h_nT[of x n]
	by(cases "x \<in> B \<Gamma>")(auto 4 3 split: split_indicator split: if_split_asm elim: order_trans intro: diff_le_self_ennreal simp add: S_def roofed_circ_def RF_in_B)

	show "h n e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Gamma>_h\<^esub>" for e
	using that OUT_not_S[of "fst e" n] currentD_outside'[OF h, of e n] \<Gamma>'.currentD_IN'[OF h, of "snd e" n] disjoint
	apply(cases "e \<in> \<^bold>E")
	apply(auto split: prod.split_asm simp add: currentD_OUT_eq_0[OF h] currentD_IN_eq_0[OF h])
	apply(cases "fst e \<in> S"; clarsimp simp add: S_def)
	apply(frule RF_circ_edge_forward[rotated])
	apply(erule roofed_circI, blast)
	apply(drule bipartite_E)
	apply(simp add: RF_in_B)
	done
	qed

	have SAT_h': "B \<Gamma>_h \<inter> \<^bold>V\<^bsub>\<Gamma>_h\<^esub> - {b} \<subseteq> SAT \<Gamma>_h (h n)" for n
	proof
	fix x
	assume "x \<in> B \<Gamma>_h \<inter> \<^bold>V\<^bsub>\<Gamma>_h\<^esub> - {b}"
	then have x: "x \<in> T" and B: "x \<in> B \<Gamma>" and b: "x \<noteq> b" and vertex: "x \<in> \<^bold>V\<^bsub>\<Gamma>_h\<^esub>" by auto
	from B disjoint have xnA: "x \<notin> A \<Gamma>" by blast
	from x B have "x \<in> \<E> T" by(simp add: essential_BI)
	hence "d_IN (h n) x = weight (\<Gamma>' n) x" using xnA by(rule IN_h_\<E>)
	with xnA b x B show "x \<in> SAT \<Gamma>_h (h n)" by(simp add: currentD_SAT[OF h'])
	qed
	moreover have "b \<in> B \<Gamma>_h" using b essential by simp
	moreover have "(\<lambda>n. min \<delta> wb * (1 / (real (n + 2)))) \<longlonglongrightarrow> 0"
	apply(rule LIMSEQ_ignore_initial_segment)
	apply(rule tendsto_mult_right_zero)
	apply(rule lim_1_over_real_power[where s=1, simplified])
	done
	then have "(INF n. ennreal (\<epsilon> n)) = 0" using wb_pos \<delta>
	apply(simp add: \<epsilon>_def)
	apply(rule INF_Lim)
	apply(rule decseq_SucI)
	apply(simp add: field_simps min_def)
	apply(simp add: add.commute ennreal_0[symmetric] del: ennreal_0)
	done
	then have "(SUP n. d_IN (h n) b) = weight \<Gamma>_h b" using essential b bnA wb IN_h_\<E>[of b]
	by(simp add: SUP_const_minus_ennreal)
	moreover have "d_IN (h 0) b \<le> d_IN (h n) b" for n using essential b bnA wb_pos \<delta> IN_h_\<E>[of b]
	by(simp add: wb_conv \<epsilon>_def field_simps ennreal_minus_if min_le_iff_disj)
	moreover have b_V: "b \<in> \<^bold>V\<^bsub>\<Gamma>_h\<^esub>" using b wb essential by(auto dest: B_vertex)
	ultimately have "\<exists>h'. current \<Gamma>_h h' \<and> wave \<Gamma>_h h' \<and> B \<Gamma>_h \<inter> \<^bold>V\<^bsub>\<Gamma>_h\<^esub> \<subseteq> SAT \<Gamma>_h h'"
	by(rule \<Gamma>_h.unhinder_bipartite[OF h'])
	then obtain h' where h': "current \<Gamma>_h h'" and h'w: "wave \<Gamma>_h h'"
	and B_SAT': "B \<Gamma>_h \<inter> \<^bold>V\<^bsub>\<Gamma>_h\<^esub> \<subseteq> SAT \<Gamma>_h h'" by blast

	have h'': "current \<Gamma> h'"
	proof
	show "d_OUT h' x \<le> weight \<Gamma> x" for x using currentD_weight_OUT[OF h', of x]
	by(auto split: split_indicator_asm elim: order_trans intro: )
	show "d_IN h' x \<le> weight \<Gamma> x" for x using currentD_weight_IN[OF h', of x]
	by(auto split: split_indicator_asm elim: order_trans intro: )
	show "h' e = 0" if "e \<notin> \<^bold>E" for e using currentD_outside'[OF h', of e] that by auto
	qed
	moreover have "wave \<Gamma> h'"
	proof
	have "separating (\<Gamma>' 0) T" unfolding T_def by(rule waveD_separating[OF w\<omega>])
	hence "separating \<Gamma> T" by(simp add: separating_gen.simps)
	hence *: "separating \<Gamma> (\<E> T)" by(rule separating_essential)
	show "separating \<Gamma> (TER h')"
	proof
	fix x p y
	assume x: "x \<in> A \<Gamma>" and p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from p x y disjoint have py: "p = [y]"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	from separatingD[OF * p x y] py have "x \<in> \<E> T \<or> y \<in> \<E> T" by auto
	then show "(\<exists>z\<in>set p. z \<in> TER h') \<or> x \<in> TER h'"
	proof cases
	case left
	then have "x \<notin> \<^bold>V\<^bsub>\<Gamma>_h\<^esub>" using x disjoint
	by(auto 4 4 dest!: vertex_\<Gamma>_hD simp add: S_def elim: essentialE_RF intro!: roofed_greaterI dest: roofedD)
	hence "d_OUT h' x = 0" by(intro currentD_outside_OUT[OF h'])
	with x have "x \<in> TER h'" by(auto simp add: SAT.A SINK.simps)
	thus ?thesis ..
	next
	case right
	have "y \<in> SAT \<Gamma> h'"
	proof(cases "weight \<Gamma> y > 0")
	case True
	with py x y right have "vertex \<Gamma>_h y" by(auto intro: B_vertex)
	hence "y \<in> SAT \<Gamma>_h h'" using B_SAT' right y by auto
	with right y disjoint show ?thesis
	by(auto simp add: currentD_SAT[OF h'] currentD_SAT[OF h''] S_def)
	qed(auto simp add: SAT.simps)
	with currentD_OUT[OF h', of y] y right have "y \<in> TER h'" by(auto simp add: SINK)
	thus ?thesis using py by simp
	qed
	qed
	qed(rule h'')
	ultimately have "h' = zero_current" by(rule looseD_wave[OF loose])
	hence "d_IN h' b = 0" by simp
	moreover from essential b b_V B_SAT' have "b \<in> SAT \<Gamma>_h h'" by(auto)
	ultimately show False using wb b essential disjoint by(auto simp add: SAT.simps S_def)
	qed

	end

	subsection \<open>Single-vertex saturation in unhindered bipartite webs\<close>

	text \<open>
	The proof of lemma 6.10 in @{cite "AharoniBergerGeorgakopoulusPerlsteinSpruessel2011JCT"} is flawed.
	The transfinite steps (taking the least upper bound) only preserves unhinderedness, but not looseness.
	However, the single steps to non-limit ordinals assumes that \<open>\<Omega> - f\<^sub>i\<close> is loose in order to
	apply Lemma 6.9.

	Counterexample: The bipartite web with three nodes \<open>a\<^sub>1\<close>, \<open>a\<^sub>2\<close>, \<open>a\<^sub>3\<close> in \<open>A\<close>
	and two nodes \<open>b\<^sub>1\<close>, \<open>b\<^sub>2\<close> in \<open>B\<close> and edges \<open>(a\<^sub>1, b\<^sub>1)\<close>, \<open>(a\<^sub>2, b\<^sub>1)\<close>,
	\<open>(a\<^sub>2, b\<^sub>2)\<close>, \<open>(a\<^sub>3, b\<^sub>2)\<close> and weights \<open>a\<^sub>1 = a\<^sub>3 = 1\<close> and \<open>a\<^sub>2 = 2\<close> and
	\<open>b\<^sub>1 = 3\<close> and \<open>b\<^sub>2 = 2\<close>.
	Then, we can get a sequence of weight reductions on \<open>b\<^sub>2\<close> from \<open>2\<close> to \<open>1.5\<close>,
	\<open>1.25\<close>, \<open>1.125\<close>, etc. with limit \<open>1\<close>.
	All maximal waves in the restricted webs in the sequence are @{term [source] zero_current}, so in
	the limit, we get \<open>k = 0\<close> and \<open>\<epsilon> = 1\<close> for \<open>a\<^sub>2\<close> and \<open>b\<^sub>2\<close>. Now, the
	restricted web for the two is not loose because it contains the wave which assigns 1 to \<open>(a\<^sub>3, b\<^sub>2)\<close>.

	We prove a stronger version which only assumes and ensures on unhinderedness.
	\<close>
	context countable_bipartite_web begin

	lemma web_flow_iff: "web_flow \<Gamma> f \<longleftrightarrow> current \<Gamma> f"
	using bipartite_V by(auto simp add: web_flow.simps)

	lemma countable_bipartite_web_minus_web:
	assumes f: "current \<Gamma> f"
	shows "countable_bipartite_web (\<Gamma> \<ominus> f)"
	using bipartite_V A_vertex bipartite_E disjoint currentD_finite_OUT[OF f] currentD_weight_OUT[OF f] currentD_weight_IN[OF f] currentD_outside_OUT[OF f] currentD_outside_IN[OF f]
	by unfold_locales (auto simp add: weight_outside)

	lemma current_plus_current_minus:
	assumes f: "current \<Gamma> f"
	and g: "current (\<Gamma> \<ominus> f) g"
	shows "current \<Gamma> (plus_current f g)" (is "current _ ?fg")
	proof
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> f" using f by(rule countable_bipartite_web_minus_web)
	show "d_OUT ?fg x \<le> weight \<Gamma> x" for x
	using currentD_weight_OUT[OF g, of x] currentD_OUT[OF g, of x] currentD_finite_OUT[OF f, of x] currentD_OUT[OF f, of x] currentD_outside_IN[OF f, of x] currentD_outside_OUT[OF f, of x] currentD_weight_OUT[OF f, of x]
	by(cases "x \<in> A \<Gamma> \<or> x \<in> B \<Gamma>")(auto simp add: add.commute d_OUT_def nn_integral_add not_vertex ennreal_le_minus_iff split: if_split_asm)
	show "d_IN ?fg x \<le> weight \<Gamma> x" for x
	using currentD_weight_IN[OF g, of x] currentD_IN[OF g, of x] currentD_finite_IN[OF f, of x] currentD_OUT[OF f, of x] currentD_outside_IN[OF f, of x] currentD_outside_OUT[OF f, of x] currentD_weight_IN[OF f, of x]
	by(cases "x \<in> A \<Gamma> \<or> x \<in> B \<Gamma>")(auto simp add: add.commute d_IN_def nn_integral_add not_vertex ennreal_le_minus_iff split: if_split_asm)
	show "?fg e = 0" if "e \<notin> \<^bold>E" for e using that currentD_outside'[OF f, of e] currentD_outside'[OF g, of e] by(cases e) simp
	qed

	lemma wave_plus_current_minus:
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current (\<Gamma> \<ominus> f) g"
	and w': "wave (\<Gamma> \<ominus> f) g"
	shows "wave \<Gamma> (plus_current f g)" (is "wave _ ?fg")
	proof
	show fg: "current \<Gamma> ?fg" using f g by(rule current_plus_current_minus)
	show sep: "separating \<Gamma> (TER ?fg)"
	proof
	fix x p y
	assume x: "x \<in> A \<Gamma>" and p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from p x y disjoint have py: "p = [y]"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	with waveD_separating[THEN separatingD, OF w p x y] have "x \<in> TER f \<or> y \<in> TER f" by auto
	thus "(\<exists>z\<in>set p. z \<in> TER ?fg) \<or> x \<in> TER ?fg"
	proof cases
	case right
	with y disjoint have "y \<in> TER ?fg" using currentD_OUT[OF fg y]
	by(auto simp add: SAT.simps SINK.simps d_IN_def nn_integral_add not_le add_increasing2)
	thus ?thesis using py by simp
	next
	case x': left
	from p have "path (\<Gamma> \<ominus> f) x p y" by simp
	from waveD_separating[THEN separatingD, OF w' this] x y py
	have "x \<in> TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g \<or> y \<in> TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g" by auto
	thus ?thesis
	proof cases
	case left
	hence "x \<in> TER ?fg" using x x'
	by(auto simp add: SAT.simps SINK.simps d_OUT_def nn_integral_add)
	thus ?thesis ..
	next
	case right
	hence "y \<in> TER ?fg" using disjoint y currentD_OUT[OF fg y] currentD_OUT[OF f y] currentD_finite_IN[OF f, of y]
	by(auto simp add: add.commute SINK.simps SAT.simps d_IN_def nn_integral_add ennreal_minus_le_iff split: if_split_asm)
	with py show ?thesis by auto
	qed
	qed
	qed
	qed

	lemma minus_plus_current:
	assumes f: "current \<Gamma> f"
	and g: "current (\<Gamma> \<ominus> f) g"
	shows "\<Gamma> \<ominus> plus_current f g = \<Gamma> \<ominus> f \<ominus> g" (is "?lhs = ?rhs")
	proof(rule web.equality)
	have "weight ?lhs x = weight ?rhs x" for x
	using currentD_weight_IN[OF f, of x] currentD_weight_IN[OF g, of x]
	by (auto simp add: d_IN_def d_OUT_def nn_integral_add diff_add_eq_diff_diff_swap_ennreal add_increasing2 diff_add_assoc2_ennreal add.assoc)
	thus "weight ?lhs = weight ?rhs" ..
	qed simp_all

	lemma unhindered_minus_web:
	assumes unhindered: "\<not> hindered \<Gamma>"
	and f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	shows "\<not> hindered (\<Gamma> \<ominus> f)"
	proof
	assume "hindered (\<Gamma> \<ominus> f)"
	then obtain g where g: "current (\<Gamma> \<ominus> f) g"
	and w': "wave (\<Gamma> \<ominus> f) g"
	and hind: "hindrance (\<Gamma> \<ominus> f) g" by cases
	let ?fg = "plus_current f g"
	have fg: "current \<Gamma> ?fg" using f g by(rule current_plus_current_minus)
	moreover have "wave \<Gamma> ?fg" using f w g w' by(rule wave_plus_current_minus)
	moreover from hind obtain a where a: "a \<in> A \<Gamma>" and n\<E>: "a \<notin> \<E>\<^bsub>\<Gamma> \<ominus> f\<^esub> (TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g)"
	and wa: "d_OUT g a < weight (\<Gamma> \<ominus> f) a" by cases auto
	from a have "hindrance \<Gamma> ?fg"
	proof
	show "a \<notin> \<E> (TER ?fg)"
	proof
	assume \<E>: "a \<in> \<E> (TER ?fg)"
	then obtain p y where p: "path \<Gamma> a p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER ?fg)" by(rule \<E>_E_RF) blast
	from p a y disjoint have py: "p = [y]"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	from bypass[of y] py have "y \<notin> TER ?fg" by(auto intro: roofed_greaterI)
	with currentD_OUT[OF fg y] have "y \<notin> SAT \<Gamma> ?fg" by(auto simp add: SINK.simps)
	hence "y \<notin> SAT (\<Gamma> \<ominus> f) g" using y currentD_OUT[OF f y] currentD_finite_IN[OF f, of y]
	by(auto simp add: SAT.simps d_IN_def nn_integral_add ennreal_minus_le_iff add.commute)
	hence "essential (\<Gamma> \<ominus> f) (B (\<Gamma> \<ominus> f)) (TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g) a" using p py y
	by(auto intro!: essentialI)
	moreover from \<E> a have "a \<in> TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g"
	by(auto simp add: SAT.A SINK_plus_current)
	ultimately have "a \<in> \<E>\<^bsub>\<Gamma> \<ominus> f\<^esub> (TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g)" by blast
	thus False using n\<E> by contradiction
	qed
	show "d_OUT ?fg a < weight \<Gamma> a" using a wa currentD_finite_OUT[OF f, of a]
	by(simp add: d_OUT_def less_diff_eq_ennreal less_top add.commute nn_integral_add)
	qed
	ultimately have "hindered \<Gamma>" by(blast intro: hindered.intros)
	with unhindered show False by contradiction
	qed

	lemma loose_minus_web:
	assumes unhindered: "\<not> hindered \<Gamma>"
	and f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and maximal: "\<And>w. \<lbrakk> current \<Gamma> w; wave \<Gamma> w; f \<le> w \<rbrakk> \<Longrightarrow> f = w"
	shows "loose (\<Gamma> \<ominus> f)" (is "loose ?\<Gamma>")
	proof
	fix g
	assume g: "current ?\<Gamma> g" and w': "wave ?\<Gamma> g"
	let ?g = "plus_current f g"
	from f g have "current \<Gamma> ?g" by(rule current_plus_current_minus)
	moreover from f w g w' have "wave \<Gamma> ?g" by(rule wave_plus_current_minus)
	moreover have "f \<le> ?g" by(clarsimp simp add: le_fun_def)
	ultimately have eq: "f = ?g" by(rule maximal)
	have "g e = 0" for e
	proof(cases e)
	case (Pair x y)
	have "f e \<le> d_OUT f x" unfolding d_OUT_def Pair by(rule nn_integral_ge_point) simp
	also have "\<dots> \<le> weight \<Gamma> x" by(rule currentD_weight_OUT[OF f])
	also have "\<dots> < \<top>" by(simp add: less_top[symmetric])
	finally show "g e = 0" using Pair eq[THEN fun_cong, of e]
	by(cases "f e" "g e" rule: ennreal2_cases)(simp_all add: fun_eq_iff)
	qed
	thus "g = (\<lambda>_. 0)" by(simp add: fun_eq_iff)
	next
	show "\<not> hindrance ?\<Gamma> zero_current" using unhindered
	proof(rule contrapos_nn)
	assume "hindrance ?\<Gamma> zero_current"
	then obtain x where a: "x \<in> A ?\<Gamma>" and \<E>: "x \<notin> \<E>\<^bsub>?\<Gamma>\<^esub> (TER\<^bsub>?\<Gamma>\<^esub> zero_current)"
	and weight: "d_OUT zero_current x < weight ?\<Gamma> x" by cases
	have "hindrance \<Gamma> f"
	proof
	show a': "x \<in> A \<Gamma>" using a by simp
	with weight show "d_OUT f x < weight \<Gamma> x"
	by(simp add: less_diff_eq_ennreal less_top[symmetric] currentD_finite_OUT[OF f])
	show "x \<notin> \<E> (TER f)"
	proof
	assume "x \<in> \<E> (TER f)"
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)" by(rule \<E>_E_RF) auto
	from p a' y disjoint have py: "p = [y]"
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	hence "y \<notin> (TER f)" using bypass[of y] by(auto intro: roofed_greaterI)
	hence "weight ?\<Gamma> y > 0" using currentD_OUT[OF f y] disjoint y
	by(auto simp add: SINK.simps SAT.simps diff_gr0_ennreal)
	hence "y \<notin> TER\<^bsub>?\<Gamma>\<^esub> zero_current" using y disjoint by(auto)
	hence "essential ?\<Gamma> (B ?\<Gamma>) (TER\<^bsub>?\<Gamma>\<^esub> zero_current) x" using p y py by(auto intro!: essentialI)
	with a have "x \<in> \<E>\<^bsub>?\<Gamma>\<^esub> (TER\<^bsub>?\<Gamma>\<^esub> zero_current)" by simp
	with \<E> show False by contradiction
	qed
	qed
	thus "hindered \<Gamma>" using f w ..
	qed
	qed

	lemma weight_minus_web:
	assumes f: "current \<Gamma> f"
	shows "weight (\<Gamma> \<ominus> f) x = (if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT f x else weight \<Gamma> x - d_IN f x)"
	proof(cases "x \<in> B \<Gamma>")
	case True
	with currentD_OUT[OF f True] disjoint show ?thesis by auto
	next
	case False
	hence "d_IN f x = 0" "d_OUT f x = 0" if "x \<notin> A \<Gamma>"
	using currentD_outside_OUT[OF f, of x] currentD_outside_IN[OF f, of x] bipartite_V that by auto
	then show ?thesis by simp
	qed


	lemma (in -) separating_minus_web [simp]: "separating_gen (G \<ominus> f) = separating_gen G"
	by(simp add: separating_gen.simps fun_eq_iff)

	lemma current_minus:
	assumes f: "current \<Gamma> f"
	and g: "current \<Gamma> g"
	and le: "\<And>e. g e \<le> f e"
	shows "current (\<Gamma> \<ominus> g) (f - g)"
	proof -
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> g" using g by(rule countable_bipartite_web_minus_web)
	note [simp del] = minus_web_sel(2)
	and [simp] = weight_minus_web[OF g]
	show ?thesis
	proof
	show "d_OUT (f - g) x \<le> weight (\<Gamma> \<ominus> g) x" for x unfolding fun_diff_def
	using currentD_weight_OUT[OF f, of x] currentD_weight_IN[OF g, of x]
	by(subst d_OUT_diff)(simp_all add: le currentD_finite_OUT[OF g] currentD_OUT'[OF f] currentD_OUT'[OF g] ennreal_minus_mono)
	show "d_IN (f - g) x \<le> weight (\<Gamma> \<ominus> g) x" for x unfolding fun_diff_def
	using currentD_weight_IN[OF f, of x] currentD_weight_OUT[OF g, of x]
	by(subst d_IN_diff)(simp_all add: le currentD_finite_IN[OF g] currentD_IN[OF f] currentD_IN[OF g] ennreal_minus_mono)
	show "(f - g) e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Gamma> \<ominus> g\<^esub>" for e using that currentD_outside'[OF f] currentD_outside'[OF g] by simp
	qed
	qed

	lemma
	assumes w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	and le: "\<And>e. g e \<le> f e"
	shows wave_minus: "wave (\<Gamma> \<ominus> g) (f - g)"
	and TER_minus: "TER f \<subseteq> TER\<^bsub>\<Gamma> \<ominus> g\<^esub> (f - g)"
	proof
	have "x \<in> SINK f \<Longrightarrow> x \<in> SINK (f - g)" for x using d_OUT_mono[of g _ f, OF le, of x]
	by(auto simp add: SINK.simps fun_diff_def d_OUT_diff le currentD_finite_OUT[OF g])
	moreover have "x \<in> SAT \<Gamma> f \<Longrightarrow> x \<in> SAT (\<Gamma> \<ominus> g) (f - g)" for x
	by(auto simp add: SAT.simps currentD_OUT'[OF g] fun_diff_def d_IN_diff le currentD_finite_IN[OF g] ennreal_minus_mono)
	ultimately show TER: "TER f \<subseteq> TER\<^bsub>\<Gamma> \<ominus> g\<^esub> (f - g)" by(auto)

	from w have "separating \<Gamma> (TER f)" by(rule waveD_separating)
	thus "separating (\<Gamma> \<ominus> g) (TER\<^bsub>\<Gamma> \<ominus> g\<^esub> (f - g))" using TER by(simp add: separating_weakening)

	fix x
	assume "x \<notin> RF\<^bsub>\<Gamma> \<ominus> g\<^esub> (TER\<^bsub>\<Gamma> \<ominus> g\<^esub> (f - g))"
	hence "x \<notin> RF (TER f)" using TER by(auto intro: in_roofed_mono)
	hence "d_OUT f x = 0" by(rule waveD_OUT[OF w])
	moreover have "0 \<le> f e" for e using le[of e] by simp
	ultimately show "d_OUT (f - g) x = 0" unfolding d_OUT_def
	by(simp add: nn_integral_0_iff emeasure_count_space_eq_0)
	qed

	lemma (in -) essential_minus_web [simp]: "essential (\<Gamma> \<ominus> f) = essential \<Gamma>"
	by(simp add: essential_def fun_eq_iff)

	lemma (in -) RF_in_essential: fixes B shows "essential \<Gamma> B S x \<Longrightarrow> x \<in> roofed_gen \<Gamma> B S \<longleftrightarrow> x \<in> S"
	by(auto intro: roofed_greaterI elim!: essentialE_RF dest: roofedD)

	lemma (in -) d_OUT_fun_upd:
	assumes "f (x, y) \<noteq> \<top>" "f (x, y) \<ge> 0" "k \<noteq> \<top>" "k \<ge> 0"
	shows "d_OUT (f((x, y) := k)) x' = (if x = x' then d_OUT f x - f (x, y) + k else d_OUT f x')"
	(is "?lhs = ?rhs")
	proof(cases "x = x'")
	case True
	have "?lhs = (\<Sum>\<^sup>+ y'. f (x, y') + k * indicator {y} y') - (\<Sum>\<^sup>+ y'. f (x, y') * indicator {y} y')"
	unfolding d_OUT_def using assms True
	by(subst nn_integral_diff[symmetric])
	(auto intro!: nn_integral_cong simp add: AE_count_space split: split_indicator)
	also have "(\<Sum>\<^sup>+ y'. f (x, y') + k * indicator {y} y') = d_OUT f x + (\<Sum>\<^sup>+ y'. k * indicator {y} y')"
	unfolding d_OUT_def using assms
	by(subst nn_integral_add[symmetric])
	(auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> - (\<Sum>\<^sup>+ y'. f (x, y') * indicator {y} y') = ?rhs" using True assms
	by(subst diff_add_assoc2_ennreal[symmetric])(auto simp add: d_OUT_def intro!: nn_integral_ge_point)
	finally show ?thesis .
	qed(simp add: d_OUT_def)

	lemma unhindered_saturate1: \<comment> \<open>Lemma 6.10\<close>
	assumes unhindered: "\<not> hindered \<Gamma>"
	and a: "a \<in> A \<Gamma>"
	shows "\<exists>f. current \<Gamma> f \<and> d_OUT f a = weight \<Gamma> a \<and> \<not> hindered (\<Gamma> \<ominus> f)"
	proof -
	from a A_vertex have a_vertex: "vertex \<Gamma> a" by auto
	from unhindered have "\<not> hindrance \<Gamma> zero_current" by(auto intro!: hindered.intros simp add: )
	then have a_\<E>: "a \<in> \<E> (A \<Gamma>)" if "weight \<Gamma> a > 0"
	proof(rule contrapos_np)
	assume "a \<notin> \<E> (A \<Gamma>)"
	with a have "\<not> essential \<Gamma> (B \<Gamma>) (A \<Gamma>) a" by simp
	hence "\<not> essential \<Gamma> (B \<Gamma>) (A \<Gamma> \<union> {x. weight \<Gamma> x \<le> 0}) a"
	by(rule contrapos_nn)(erule essential_mono; simp)
	with a that show "hindrance \<Gamma> zero_current" by(auto intro: hindrance)
	qed

	define F where "F = (\<lambda>(\<epsilon>, h :: 'v current). plus_current \<epsilon> h)"
	have F_simps: "F (\<epsilon>, h) = plus_current \<epsilon> h" for \<epsilon> h by(simp add: F_def)
	define Fld where "Fld = {(\<epsilon>, h).
	current \<Gamma> \<epsilon> \<and> (\<forall>x. x \<noteq> a \<longrightarrow> d_OUT \<epsilon> x = 0) \<and>
	current (\<Gamma> \<ominus> \<epsilon>) h \<and> wave (\<Gamma> \<ominus> \<epsilon>) h \<and>
	\<not> hindered (\<Gamma> \<ominus> F (\<epsilon>, h))}"
	define leq where "leq = restrict_rel Fld {(f, f'). f \<le> f'}"
	have Fld: "Field leq = Fld" by(auto simp add: leq_def)
	have F_I [intro?]: "(\<epsilon>, h) \<in> Field leq"
	if "current \<Gamma> \<epsilon>" and "\<And>x. x \<noteq> a \<Longrightarrow> d_OUT \<epsilon> x = 0"
	and "current (\<Gamma> \<ominus> \<epsilon>) h" and "wave (\<Gamma> \<ominus> \<epsilon>) h"
	and "\<not> hindered (\<Gamma> \<ominus> F (\<epsilon>, h))"
	for \<epsilon> h using that by(simp add: Fld Fld_def)
	have \<epsilon>_curr: "current \<Gamma> \<epsilon>" if "(\<epsilon>, h) \<in> Field leq" for \<epsilon> h using that by(simp add: Fld Fld_def)
	have OUT_\<epsilon>: "\<And>x. x \<noteq> a \<Longrightarrow> d_OUT \<epsilon> x = 0" if "(\<epsilon>, h) \<in> Field leq" for \<epsilon> h using that by(simp add: Fld Fld_def)
	have h: "current (\<Gamma> \<ominus> \<epsilon>) h" if "(\<epsilon>, h) \<in> Field leq" for \<epsilon> h using that by(simp add: Fld Fld_def)
	have h_w: "wave (\<Gamma> \<ominus> \<epsilon>) h" if "(\<epsilon>, h) \<in> Field leq" for \<epsilon> h using that by(simp add: Fld Fld_def)
	have unhindered': "\<not> hindered (\<Gamma> \<ominus> F \<epsilon>h)" if "\<epsilon>h \<in> Field leq" for \<epsilon>h using that by(simp add: Fld Fld_def split: prod.split_asm)
	have f: "current \<Gamma> (F \<epsilon>h)" if "\<epsilon>h \<in> Field leq" for \<epsilon>h using \<epsilon>_curr h that
	by(cases \<epsilon>h)(simp add: F_simps current_plus_current_minus)
	have out_\<epsilon>: "\<epsilon> (x, y) = 0" if "(\<epsilon>, h) \<in> Field leq" "x \<noteq> a" for \<epsilon> h x y
	proof(rule antisym)
	have "\<epsilon> (x, y) \<le> d_OUT \<epsilon> x" unfolding d_OUT_def by(rule nn_integral_ge_point) simp
	with OUT_\<epsilon>[OF that] show "\<epsilon> (x, y) \<le> 0" by simp
	qed simp
	have IN_\<epsilon>: "d_IN \<epsilon> x = \<epsilon> (a, x)" if "(\<epsilon>, h) \<in> Field leq" for \<epsilon> h x
	proof(rule trans)
	show "d_IN \<epsilon> x = (\<Sum>\<^sup>+ y. \<epsilon> (y, x) * indicator {a} y)" unfolding d_IN_def
	by(rule nn_integral_cong)(simp add: out_\<epsilon>[OF that] split: split_indicator)
	qed(simp add: max_def \<epsilon>_curr[OF that])
	have leqI: "((\<epsilon>, h), (\<epsilon>', h')) \<in> leq" if "\<epsilon> \<le> \<epsilon>'" "h \<le> h'" "(\<epsilon>, h) \<in> Field leq" "(\<epsilon>', h') \<in> Field leq" for \<epsilon> h \<epsilon>' h'
	using that unfolding Fld by(simp add: leq_def in_restrict_rel_iff)

	have chain_Field: "Sup M \<in> Field leq" if M: "M \<in> Chains leq" and nempty: "M \<noteq> {}" for M
	unfolding Sup_prod_def
	proof
	from nempty obtain \<epsilon> h where in_M: "(\<epsilon>, h) \<in> M" by auto
	with M have Field: "(\<epsilon>, h) \<in> Field leq" by(rule Chains_FieldD)

	from M have chain: "Complete_Partial_Order.chain (\<lambda>\<epsilon> \<epsilon>'. (\<epsilon>, \<epsilon>') \<in> leq) M"
	by(intro Chains_into_chain) simp
	hence chain': "Complete_Partial_Order.chain (\<le>) M"
	by(auto simp add: chain_def leq_def in_restrict_rel_iff)
	hence chain1: "Complete_Partial_Order.chain (\<le>) (fst ` M)"
	and chain2: "Complete_Partial_Order.chain (\<le>) (snd ` M)"
	by(rule chain_imageI; auto)+

	have outside1: "Sup (fst ` M) (x, y) = 0" if "\<not> edge \<Gamma> x y" for x y using that
	by(auto intro!: SUP_eq_const simp add: nempty dest!: Chains_FieldD[OF M] \<epsilon>_curr currentD_outside)
	then have "support_flow (Sup (fst ` M)) \<subseteq> \<^bold>E" by(auto elim!: support_flow.cases intro: ccontr)
	hence supp_flow1: "countable (support_flow (Sup (fst ` M)))" by(rule countable_subset) simp

	show SM1: "current \<Gamma> (Sup (fst ` M))"
	by(rule current_Sup[OF chain1 _ _ supp_flow1])(auto dest: Chains_FieldD[OF M, THEN \<epsilon>_curr] simp add: nempty)
	show OUT1_na: "d_OUT (Sup (fst ` M)) x = 0" if "x \<noteq> a" for x using that
	by(subst d_OUT_Sup[OF chain1 _ supp_flow1])(auto simp add: nempty intro!: SUP_eq_const dest: Chains_FieldD[OF M, THEN OUT_\<epsilon>])

	interpret SM1: countable_bipartite_web "\<Gamma> \<ominus> Sup (fst ` M)"
	using SM1 by(rule countable_bipartite_web_minus_web)

	let ?h = "Sup (snd ` M)"
	have outside2: "?h (x, y) = 0" if "\<not> edge \<Gamma> x y" for x y using that
	by(auto intro!: SUP_eq_const simp add: nempty dest!: Chains_FieldD[OF M] h currentD_outside)
	then have "support_flow ?h \<subseteq> \<^bold>E" by(auto elim!: support_flow.cases intro: ccontr)
	hence supp_flow2: "countable (support_flow ?h)" by(rule countable_subset) simp

	have OUT1: "d_OUT (Sup (fst ` M)) x = (SUP (\<epsilon>, h)\<in>M. d_OUT \<epsilon> x)" for x
	by (subst d_OUT_Sup [OF chain1 _ supp_flow1])
	(simp_all add: nempty split_beta image_comp)
	have OUT1': "d_OUT (Sup (fst ` M)) x = (if x = a then SUP (\<epsilon>, h)\<in>M. d_OUT \<epsilon> a else 0)" for x
	unfolding OUT1 by(auto intro!: SUP_eq_const simp add: nempty OUT_\<epsilon> dest!: Chains_FieldD[OF M])
	have OUT1_le: "(\<Squnion>\<epsilon>h\<in>M. d_OUT (fst \<epsilon>h) x) \<le> weight \<Gamma> x" for x
	using currentD_weight_OUT[OF SM1, of x] OUT1[of x] by(simp add: split_beta)
	- have OUT1_nonneg: "0 \<le> (\<Squnion>\<epsilon>h\<in>M. d_OUT (fst \<epsilon>h) x)" for x using in_M by(rule SUP_upper2)(simp add: )
	+ have OUT1_nonneg: "0 \<le> (\<Squnion>\<epsilon>h\<in>M. d_OUT (fst \<epsilon>h) x)" for x using in_M by(rule SUP_upper2)simp
	have IN1: "d_IN (Sup (fst ` M)) x = (SUP (\<epsilon>, h)\<in>M. d_IN \<epsilon> x)" for x
	by (subst d_IN_Sup [OF chain1 _ supp_flow1])
	(simp_all add: nempty split_beta image_comp)
	have IN1_le: "(\<Squnion>\<epsilon>h\<in>M. d_IN (fst \<epsilon>h) x) \<le> weight \<Gamma> x" for x
	using currentD_weight_IN[OF SM1, of x] IN1[of x] by(simp add: split_beta)
	have IN1_nonneg: "0 \<le> (\<Squnion>\<epsilon>h\<in>M. d_IN (fst \<epsilon>h) x)" for x using in_M by(rule SUP_upper2) simp
	have IN1': "d_IN (Sup (fst ` M)) x = (SUP (\<epsilon>, h)\<in>M. \<epsilon> (a, x))" for x
	unfolding IN1 by(rule SUP_cong[OF refl])(auto dest!: Chains_FieldD[OF M] IN_\<epsilon>)

	have directed: "\<exists>\<epsilon>k''\<in>M. F (snd \<epsilon>k) + F (fst \<epsilon>k') \<le> F (snd \<epsilon>k'') + F (fst \<epsilon>k'')"
	if mono: "\<And>f g. (\<And>z. f z \<le> g z) \<Longrightarrow> F f \<le> F g" "\<epsilon>k \<in> M" "\<epsilon>k' \<in> M"
	for \<epsilon>k \<epsilon>k' and F :: "_ \<Rightarrow> ennreal"
	using chainD[OF chain that(2-3)]
	proof cases
	case left
	hence "snd \<epsilon>k \<le> snd \<epsilon>k'" by(simp add: leq_def less_eq_prod_def in_restrict_rel_iff)
	hence "F (snd \<epsilon>k) + F (fst \<epsilon>k') \<le> F (snd \<epsilon>k') + F (fst \<epsilon>k')"
	by(intro add_right_mono mono)(clarsimp simp add: le_fun_def)
	with that show ?thesis by blast
	next
	case right
	hence "fst \<epsilon>k' \<le> fst \<epsilon>k" by(simp add: leq_def less_eq_prod_def in_restrict_rel_iff)
	hence "F (snd \<epsilon>k) + F (fst \<epsilon>k') \<le> F (snd \<epsilon>k) + F (fst \<epsilon>k)"
	by(intro add_left_mono mono)(clarsimp simp add: le_fun_def)
	with that show ?thesis by blast
	qed
	have directed_OUT: "\<exists>\<epsilon>k''\<in>M. d_OUT (snd \<epsilon>k) x + d_OUT (fst \<epsilon>k') x \<le> d_OUT (snd \<epsilon>k'') x + d_OUT (fst \<epsilon>k'') x"
	if "\<epsilon>k \<in> M" "\<epsilon>k' \<in> M" for x \<epsilon>k \<epsilon>k' by(rule directed; rule d_OUT_mono that)
	have directed_IN: "\<exists>\<epsilon>k''\<in>M. d_IN (snd \<epsilon>k) x + d_IN (fst \<epsilon>k') x \<le> d_IN (snd \<epsilon>k'') x + d_IN (fst \<epsilon>k'') x"
	if "\<epsilon>k \<in> M" "\<epsilon>k' \<in> M" for x \<epsilon>k \<epsilon>k' by(rule directed; rule d_IN_mono that)

	let ?\<Gamma> = "\<Gamma> \<ominus> Sup (fst ` M)"

	have hM2: "current ?\<Gamma> h" if \<epsilon>h: "(\<epsilon>, h) \<in> M" for \<epsilon> h
	proof
	from \<epsilon>h have Field: "(\<epsilon>, h) \<in> Field leq" by(rule Chains_FieldD[OF M])
	then have H: "current (\<Gamma> \<ominus> \<epsilon>) h" and \<epsilon>_curr': "current \<Gamma> \<epsilon>" by(rule h \<epsilon>_curr)+
	from \<epsilon>_curr' interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> \<epsilon>" by(rule countable_bipartite_web_minus_web)

	fix x
	have "d_OUT h x \<le> d_OUT ?h x" using \<epsilon>h by(intro d_OUT_mono)(auto intro: SUP_upper2)
	also have OUT: "\<dots> = (SUP h\<in>snd ` M. d_OUT h x)" using chain2 _ supp_flow2
	by(rule d_OUT_Sup)(simp_all add: nempty)
	also have "\<dots> = \<dots> + (SUP \<epsilon>\<in>fst ` M. d_OUT \<epsilon> x) - (SUP \<epsilon>\<in>fst ` M. d_OUT \<epsilon> x)"
	using OUT1_le[of x]
	by (intro ennreal_add_diff_cancel_right[symmetric] neq_top_trans[OF weight_finite, of _ x])
	(simp add: image_comp)
	also have "\<dots> = (SUP (\<epsilon>, k)\<in>M. d_OUT k x + d_OUT \<epsilon> x) - (SUP \<epsilon>\<in>fst ` M. d_OUT \<epsilon> x)" unfolding split_def
	by (subst SUP_add_directed_ennreal[OF directed_OUT])
	(simp_all add: image_comp)
	also have "(SUP (\<epsilon>, k)\<in>M. d_OUT k x + d_OUT \<epsilon> x) \<le> weight \<Gamma> x"
	apply(clarsimp dest!: Chains_FieldD[OF M] intro!: SUP_least)
	subgoal premises that for \<epsilon> h
	using currentD_weight_OUT[OF h[OF that], of x] currentD_weight_OUT[OF \<epsilon>_curr[OF that], of x]
	countable_bipartite_web_minus_web[OF \<epsilon>_curr, THEN countable_bipartite_web.currentD_OUT', OF that h[OF that], where x=x]
	by (auto simp add: ennreal_le_minus_iff split: if_split_asm)
	done
	also have "(SUP \<epsilon>\<in>fst ` M. d_OUT \<epsilon> x) = d_OUT (Sup (fst ` M)) x" using OUT1
	by (simp add: split_beta image_comp)
	finally show "d_OUT h x \<le> weight ?\<Gamma> x"
	using \<Gamma>.currentD_OUT'[OF h[OF Field], of x] currentD_weight_IN[OF SM1, of x] by(auto simp add: ennreal_minus_mono)

	have "d_IN h x \<le> d_IN ?h x" using \<epsilon>h by(intro d_IN_mono)(auto intro: SUP_upper2)
	also have IN: "\<dots> = (SUP h\<in>snd ` M. d_IN h x)" using chain2 _ supp_flow2
	by(rule d_IN_Sup)(simp_all add: nempty)
	also have "\<dots> = \<dots> + (SUP \<epsilon>\<in>fst ` M. d_IN \<epsilon> x) - (SUP \<epsilon>\<in>fst ` M. d_IN \<epsilon> x)"
	using IN1_le[of x]
	by (intro ennreal_add_diff_cancel_right [symmetric] neq_top_trans [OF weight_finite, of _ x])
	(simp add: image_comp)
	also have "\<dots> = (SUP (\<epsilon>, k)\<in>M. d_IN k x + d_IN \<epsilon> x) - (SUP \<epsilon>\<in>fst ` M. d_IN \<epsilon> x)" unfolding split_def
	by (subst SUP_add_directed_ennreal [OF directed_IN])
	(simp_all add: image_comp)
	also have "(SUP (\<epsilon>, k)\<in>M. d_IN k x + d_IN \<epsilon> x) \<le> weight \<Gamma> x"
	apply(clarsimp dest!: Chains_FieldD[OF M] intro!: SUP_least)
	subgoal premises that for \<epsilon> h
	using currentD_weight_OUT[OF h, OF that, where x=x] currentD_weight_IN[OF h, OF that, where x=x]
	countable_bipartite_web_minus_web[OF \<epsilon>_curr, THEN countable_bipartite_web.currentD_OUT', OF that h[OF that], where x=x]
	currentD_OUT'[OF \<epsilon>_curr, OF that, where x=x] currentD_IN[OF \<epsilon>_curr, OF that, of x] currentD_weight_IN[OF \<epsilon>_curr, OF that, where x=x]
	by (auto simp add: ennreal_le_minus_iff image_comp
	split: if_split_asm intro: add_increasing2 order_trans [rotated])
	done
	also have "(SUP \<epsilon>\<in>fst ` M. d_IN \<epsilon> x) = d_IN (Sup (fst ` M)) x"
	using IN1 by (simp add: split_beta image_comp)
	finally show "d_IN h x \<le> weight ?\<Gamma> x"
	using currentD_IN[OF h[OF Field], of x] currentD_weight_OUT[OF SM1, of x]
	by(auto simp add: ennreal_minus_mono)
	(auto simp add: ennreal_le_minus_iff add_increasing2)
	show "h e = 0" if "e \<notin> \<^bold>E\<^bsub>?\<Gamma>\<^esub>" for e using currentD_outside'[OF H, of e] that by simp
	qed

	from nempty have "snd ` M \<noteq> {}" by simp
	from chain2 this _ supp_flow2 show current: "current ?\<Gamma> ?h"
	by(rule current_Sup)(clarify; rule hM2; simp)

	have wM: "wave ?\<Gamma> h" if "(\<epsilon>, h) \<in> M" for \<epsilon> h
	proof
	let ?\<Gamma>' = "\<Gamma> \<ominus> \<epsilon>"
	have subset: "TER\<^bsub>?\<Gamma>'\<^esub> h \<subseteq> TER\<^bsub>?\<Gamma>\<^esub> h"
	using currentD_OUT'[OF SM1] currentD_OUT'[OF \<epsilon>_curr[OF Chains_FieldD[OF M that]]] that
	by(auto 4 7 elim!: SAT.cases intro: SAT.intros elim!: order_trans[rotated] intro: ennreal_minus_mono d_IN_mono intro!: SUP_upper2 split: if_split_asm)

	from h_w[OF Chains_FieldD[OF M], OF that] have "separating ?\<Gamma>' (TER\<^bsub>?\<Gamma>'\<^esub> h)" by(rule waveD_separating)
	then show "separating ?\<Gamma> (TER\<^bsub>?\<Gamma>\<^esub> h)" using subset by(auto intro: separating_weakening)
	qed(rule hM2[OF that])
	show wave: "wave ?\<Gamma> ?h" using chain2 \<open>snd ` M \<noteq> {}\<close> _ supp_flow2
	by(rule wave_lub)(clarify; rule wM; simp)

	define f where "f = F (Sup (fst ` M), Sup (snd ` M))"
	have supp_flow: "countable (support_flow f)"
	using supp_flow1 supp_flow2 support_flow_plus_current[of "Sup (fst ` M)" ?h]
	unfolding f_def F_simps by(blast intro: countable_subset)
	have f_alt: "f = Sup ((\<lambda>(\<epsilon>, h). plus_current \<epsilon> h) ` M)"
	apply (simp add: fun_eq_iff split_def f_def nempty F_def image_comp)
	apply (subst (1 2) add.commute)
	apply (subst SUP_add_directed_ennreal)
	apply (rule directed)
	apply (auto dest!: Chains_FieldD [OF M])
	done
	have f_curr: "current \<Gamma> f" unfolding f_def F_simps using SM1 current by(rule current_plus_current_minus)
	have IN_f: "d_IN f x = d_IN (Sup (fst ` M)) x + d_IN (Sup (snd ` M)) x" for x
	unfolding f_def F_simps plus_current_def
	by(rule d_IN_add SM1 current)+
	have OUT_f: "d_OUT f x = d_OUT (Sup (fst ` M)) x + d_OUT (Sup (snd ` M)) x" for x
	unfolding f_def F_simps plus_current_def
	by(rule d_OUT_add SM1 current)+

	show "\<not> hindered (\<Gamma> \<ominus> f)" (is "\<not> hindered ?\<Omega>") \<comment> \<open>Assertion 6.11\<close>
	proof
	assume hindered: "hindered ?\<Omega>"
	then obtain g where g: "current ?\<Omega> g" and g_w: "wave ?\<Omega> g" and hindrance: "hindrance ?\<Omega> g" by cases
	from hindrance obtain z where z: "z \<in> A \<Gamma>" and z\<E>: "z \<notin> \<E>\<^bsub>?\<Omega>\<^esub> (TER\<^bsub>?\<Omega>\<^esub> g)"
	and OUT_z: "d_OUT g z < weight ?\<Omega> z" by cases auto
	define \<delta> where "\<delta> = weight ?\<Omega> z - d_OUT g z"
	have \<delta>_pos: "\<delta> > 0" using OUT_z by(simp add: \<delta>_def diff_gr0_ennreal del: minus_web_sel)
	then have \<delta>_finite[simp]: "\<delta> \<noteq> \<top>" using z
	by(simp_all add: \<delta>_def)

	have "\<exists>(\<epsilon>, h) \<in> M. d_OUT f a < d_OUT (plus_current \<epsilon> h) a + \<delta>"
	proof(rule ccontr)
	assume "\<not> ?thesis"
	hence greater: "d_OUT (plus_current \<epsilon> h) a + \<delta> \<le> d_OUT f a" if "(\<epsilon>, h) \<in> M" for \<epsilon> h using that by auto

	have chain'': "Complete_Partial_Order.chain (\<le>) ((\<lambda>(\<epsilon>, h). plus_current \<epsilon> h) ` M)"
	using chain' by(rule chain_imageI)(auto simp add: le_fun_def add_mono)

	have "d_OUT f a + 0 < d_OUT f a + \<delta>"
	using currentD_finite_OUT[OF f_curr, of a] by (simp add: \<delta>_pos)
	also have "d_OUT f a + \<delta> = (SUP (\<epsilon>, h)\<in>M. d_OUT (plus_current \<epsilon> h) a) + \<delta>"
	using chain'' nempty supp_flow
	unfolding f_alt by (subst d_OUT_Sup)
	(simp_all add: plus_current_def [abs_def] split_def image_comp)
	also have "\<dots> \<le> d_OUT f a"
	unfolding ennreal_SUP_add_left[symmetric, OF nempty]
	proof(rule SUP_least, clarify)
	show "d_OUT (plus_current \<epsilon> h) a + \<delta> \<le> d_OUT f a" if "(\<epsilon>, h) \<in> M" for \<epsilon> h
	using greater[OF that] currentD_finite_OUT[OF Chains_FieldD[OF M that, THEN f], of a]
	by(auto simp add: ennreal_le_minus_iff add.commute F_def)
	qed
	finally show False by simp
	qed
	then obtain \<epsilon> h where hM: "(\<epsilon>, h) \<in> M" and close: "d_OUT f a < d_OUT (plus_current \<epsilon> h) a + \<delta>" by blast
	have Field: "(\<epsilon>, h) \<in> Field leq" using hM by(rule Chains_FieldD[OF M])
	then have \<epsilon>: "current \<Gamma> \<epsilon>"
	and unhindered_h: "\<not> hindered (\<Gamma> \<ominus> F (\<epsilon>, h))"
	and h_curr: "current (\<Gamma> \<ominus> \<epsilon>) h"
	and h_w: "wave (\<Gamma> \<ominus> \<epsilon>) h"
	and OUT_\<epsilon>: "x \<noteq> a \<Longrightarrow> d_OUT \<epsilon> x = 0" for x
	by(rule \<epsilon>_curr OUT_\<epsilon> h h_w unhindered')+
	let ?\<epsilon>h = "plus_current \<epsilon> h"
	have \<epsilon>h_curr: "current \<Gamma> ?\<epsilon>h" using Field unfolding F_simps[symmetric] by(rule f)

	interpret h: countable_bipartite_web "\<Gamma> \<ominus> \<epsilon>" using \<epsilon> by(rule countable_bipartite_web_minus_web)
	interpret \<epsilon>h: countable_bipartite_web "\<Gamma> \<ominus> ?\<epsilon>h" using \<epsilon>h_curr by(rule countable_bipartite_web_minus_web)
	note [simp del] = minus_web_sel(2)
	and [simp] = weight_minus_web[OF \<epsilon>h_curr] weight_minus_web[OF SM1, simplified]

	define k where "k e = Sup (fst ` M) e - \<epsilon> e" for e
	have k_simps: "k (x, y) = Sup (fst ` M) (x, y) - \<epsilon> (x, y)" for x y by(simp add: k_def)
	have k_alt: "k (x, y) = (if x = a \<and> edge \<Gamma> x y then Sup (fst ` M) (a, y) - \<epsilon> (a, y) else 0)" for x y
	by (cases "x = a")
	(auto simp add: k_simps out_\<epsilon> [OF Field] currentD_outside [OF \<epsilon>] image_comp
	intro!: SUP_eq_const [OF nempty] dest!: Chains_FieldD [OF M]
	intro: currentD_outside [OF \<epsilon>_curr] out_\<epsilon>)
	have OUT_k: "d_OUT k x = (if x = a then d_OUT (Sup (fst ` M)) a - d_OUT \<epsilon> a else 0)" for x
	proof -
	have "d_OUT k x = (if x = a then (\<Sum>\<^sup>+ y. Sup (fst ` M) (a, y) - \<epsilon> (a, y)) else 0)"
	using currentD_outside[OF SM1] currentD_outside[OF \<epsilon>]
	by(auto simp add: k_alt d_OUT_def intro!: nn_integral_cong)
	also have "(\<Sum>\<^sup>+ y. Sup (fst ` M) (a, y) - \<epsilon> (a, y)) = d_OUT (Sup (fst `M)) a - d_OUT \<epsilon> a"
	using currentD_finite_OUT[OF \<epsilon>, of a] hM unfolding d_OUT_def
	by(subst nn_integral_diff[symmetric])(auto simp add: AE_count_space intro!: SUP_upper2)
	finally show ?thesis .
	qed
	have IN_k: "d_IN k y = (if edge \<Gamma> a y then Sup (fst ` M) (a, y) - \<epsilon> (a, y) else 0)" for y
	proof -
	have "d_IN k y = (\<Sum>\<^sup>+ x. (if edge \<Gamma> x y then Sup (fst ` M) (a, y) - \<epsilon> (a, y) else 0) * indicator {a} x)"
	unfolding d_IN_def by(rule nn_integral_cong)(auto simp add: k_alt outgoing_def split: split_indicator)
	also have "\<dots> = (if edge \<Gamma> a y then Sup (fst ` M) (a, y) - \<epsilon> (a, y) else 0)" using hM
	by(auto simp add: max_def intro!: SUP_upper2)
	finally show ?thesis .
	qed

	have OUT_\<epsilon>h: "d_OUT ?\<epsilon>h x = d_OUT \<epsilon> x + d_OUT h x" for x
	unfolding plus_current_def by(rule d_OUT_add)+
	have IN_\<epsilon>h: "d_IN ?\<epsilon>h x = d_IN \<epsilon> x + d_IN h x" for x
	unfolding plus_current_def by(rule d_IN_add)+

	have OUT1_le': "d_OUT (Sup (fst`M)) x \<le> weight \<Gamma> x" for x
	using OUT1_le[of x] unfolding OUT1 by (simp add: split_beta')

	have k: "current (\<Gamma> \<ominus> ?\<epsilon>h) k"
	proof
	fix x
	show "d_OUT k x \<le> weight (\<Gamma> \<ominus> ?\<epsilon>h) x"
	using a OUT1_na[of x] currentD_weight_OUT[OF hM2[OF hM], of x] currentD_weight_IN[OF \<epsilon>h_curr, of x]
	currentD_weight_IN[OF \<epsilon>, of x] OUT1_le'[of x]
	apply(auto simp add: diff_add_eq_diff_diff_swap_ennreal diff_add_assoc2_ennreal[symmetric]
	OUT_k OUT_\<epsilon> OUT_\<epsilon>h IN_\<epsilon>h currentD_OUT'[OF \<epsilon>] IN_\<epsilon>[OF Field] h.currentD_OUT'[OF h_curr])
	apply(subst diff_diff_commute_ennreal)
	apply(intro ennreal_minus_mono)
	apply(auto simp add: ennreal_le_minus_iff ac_simps less_imp_le OUT1)
	done

	have *: "(\<Squnion>xa\<in>M. fst xa (a, x)) \<le> d_IN (Sup (fst`M)) x"
	unfolding IN1 by (intro SUP_subset_mono) (auto simp: split_beta' d_IN_ge_point)
	also have "\<dots> \<le> weight \<Gamma> x"
	using IN1_le[of x] IN1 by (simp add: split_beta')
	finally show "d_IN k x \<le> weight (\<Gamma> \<ominus> ?\<epsilon>h) x"
	using currentD_weight_IN[OF \<epsilon>h_curr, of x] currentD_weight_OUT[OF \<epsilon>h_curr, of x]
	currentD_weight_IN[OF hM2[OF hM], of x] IN_\<epsilon>[OF Field, of x] *
	apply (auto simp add: IN_k outgoing_def IN_\<epsilon>h IN_\<epsilon> A_in diff_add_eq_diff_diff_swap_ennreal)
	apply (subst diff_diff_commute_ennreal)
	apply (intro ennreal_minus_mono[OF _ order_refl])
	apply (auto simp add: ennreal_le_minus_iff ac_simps image_comp intro: order_trans add_mono)
	done
	show "k e = 0" if "e \<notin> \<^bold>E\<^bsub>\<Gamma> \<ominus> ?\<epsilon>h\<^esub>" for e
	using that by (cases e) (simp add: k_alt)
	qed

	define q where "q = (\<Sum>\<^sup>+ y\<in>B (\<Gamma> \<ominus> ?\<epsilon>h). d_IN k y - d_OUT k y)"
	have q_alt: "q = (\<Sum>\<^sup>+ y\<in>- A (\<Gamma> \<ominus> ?\<epsilon>h). d_IN k y - d_OUT k y)" using disjoint
	by(auto simp add: q_def nn_integral_count_space_indicator currentD_outside_OUT[OF k] currentD_outside_IN[OF k] not_vertex split: split_indicator intro!: nn_integral_cong)
	have q_simps: "q = d_OUT (Sup (fst ` M)) a - d_OUT \<epsilon> a"
	proof -
	have "q = (\<Sum>\<^sup>+ y. d_IN k y)" using a IN1 OUT1 OUT1_na unfolding q_alt
	by(auto simp add: nn_integral_count_space_indicator OUT_k IN_\<epsilon>[OF Field] OUT_\<epsilon> currentD_outside[OF \<epsilon>] outgoing_def no_loop A_in IN_k intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = d_OUT (Sup (fst ` M)) a - d_OUT \<epsilon> a" using currentD_finite_OUT[OF \<epsilon>, of a] hM currentD_outside[OF SM1] currentD_outside[OF \<epsilon>]
	by(subst d_OUT_diff[symmetric])(auto simp add: d_OUT_def IN_k intro!: SUP_upper2 nn_integral_cong)
	finally show ?thesis .
	qed
	have q_finite: "q \<noteq> \<top>" using currentD_finite_OUT[OF SM1, of a]
	by(simp add: q_simps)
	have q_nonneg: "0 \<le> q" using hM by(auto simp add: q_simps intro!: d_OUT_mono SUP_upper2)
	have q_less_\<delta>: "q < \<delta>" using close
	unfolding q_simps \<delta>_def OUT_\<epsilon>h OUT_f
	proof -
	let ?F = "d_OUT (Sup (fst`M)) a" and ?S = "d_OUT (Sup (snd`M)) a"
	and ?\<epsilon> = "d_OUT \<epsilon> a" and ?h = "d_OUT h a" and ?w = "weight (\<Gamma> \<ominus> f) z - d_OUT g z"
	have "?F + ?h \<le> ?F + ?S"
	using hM by (auto intro!: add_mono d_OUT_mono SUP_upper2)
	also assume "?F + ?S < ?\<epsilon> + ?h + ?w"
	finally have "?h + ?F < ?h + (?w + ?\<epsilon>)"
	by (simp add: ac_simps)
	then show "?F - ?\<epsilon> < ?w"
	using currentD_finite_OUT[OF \<epsilon>, of a] hM unfolding ennreal_add_left_cancel_less
	by (subst minus_less_iff_ennreal) (auto intro!: d_OUT_mono SUP_upper2 simp: less_top)
	qed

	define g' where "g' = plus_current g (Sup (snd ` M) - h)"
	have g'_simps: "g' e = g e + Sup (snd ` M) e - h e" for e
	using hM by(auto simp add: g'_def intro!: add_diff_eq_ennreal intro: SUP_upper2)
	have OUT_g': "d_OUT g' x = d_OUT g x + (d_OUT (Sup (snd ` M)) x - d_OUT h x)" for x
	unfolding g'_simps[abs_def] using \<epsilon>h.currentD_finite_OUT[OF k] hM h.currentD_finite_OUT[OF h_curr] hM
	apply(subst d_OUT_diff)
	apply(auto simp add: add_diff_eq_ennreal[symmetric] k_simps intro: add_increasing intro!: SUP_upper2)
	apply(subst d_OUT_add)
	apply(auto simp add: add_diff_eq_ennreal[symmetric] k_simps intro: add_increasing intro!:)
	apply(simp add: add_diff_eq_ennreal SUP_apply[abs_def])
	apply(auto simp add: g'_def image_comp intro!: add_diff_eq_ennreal[symmetric] d_OUT_mono intro: SUP_upper2)
	done
	have IN_g': "d_IN g' x = d_IN g x + (d_IN (Sup (snd ` M)) x - d_IN h x)" for x
	unfolding g'_simps[abs_def] using \<epsilon>h.currentD_finite_IN[OF k] hM h.currentD_finite_IN[OF h_curr] hM
	apply(subst d_IN_diff)
	apply(auto simp add: add_diff_eq_ennreal[symmetric] k_simps intro: add_increasing intro!: SUP_upper2)
	apply(subst d_IN_add)
	apply(auto simp add: add_diff_eq_ennreal[symmetric] k_simps intro: add_increasing intro!: SUP_upper)
	apply(auto simp add: g'_def SUP_apply[abs_def] image_comp intro!: add_diff_eq_ennreal[symmetric] d_IN_mono intro: SUP_upper2)
	done

	have h': "current (\<Gamma> \<ominus> Sup (fst ` M)) h" using hM by(rule hM2)

	let ?\<Gamma> = "\<Gamma> \<ominus> ?\<epsilon>h \<ominus> k"
	interpret \<Gamma>: web ?\<Gamma> using k by(rule \<epsilon>h.web_minus_web)
	note [simp] = \<epsilon>h.weight_minus_web[OF k] h.weight_minus_web[OF h_curr]
	weight_minus_web[OF f_curr] SM1.weight_minus_web[OF h', simplified]

	interpret \<Omega>: countable_bipartite_web "\<Gamma> \<ominus> f" using f_curr by(rule countable_bipartite_web_minus_web)

	have *: "\<Gamma> \<ominus> f = \<Gamma> \<ominus> Sup (fst ` M) \<ominus> Sup (snd ` M)" unfolding f_def F_simps
	using SM1 current by(rule minus_plus_current)
	have OUT_\<epsilon>k: "d_OUT (Sup (fst ` M)) x = d_OUT \<epsilon> x + d_OUT k x" for x
	using OUT1'[of x] currentD_finite_OUT[OF \<epsilon>] hM
	by(auto simp add: OUT_k OUT_\<epsilon> add_diff_self_ennreal SUP_upper2)
	have IN_\<epsilon>k: "d_IN (Sup (fst ` M)) x = d_IN \<epsilon> x + d_IN k x" for x
	using IN1'[of x] currentD_finite_IN[OF \<epsilon>] currentD_outside[OF \<epsilon>] currentD_outside[OF \<epsilon>_curr]
	by(auto simp add: IN_k IN_\<epsilon>[OF Field] add_diff_self_ennreal split_beta nempty image_comp
	dest!: Chains_FieldD[OF M] intro!: SUP_eq_const intro: SUP_upper2[OF hM])
	have **: "?\<Gamma> = \<Gamma> \<ominus> Sup (fst ` M) \<ominus> h"
	proof(rule web.equality)
	show "weight ?\<Gamma> = weight (\<Gamma> \<ominus> Sup (fst ` M) \<ominus> h)"
	using OUT_\<epsilon>k OUT_\<epsilon>h currentD_finite_OUT[OF \<epsilon>] IN_\<epsilon>k IN_\<epsilon>h currentD_finite_IN[OF \<epsilon>]
	by(auto simp add: diff_add_eq_diff_diff_swap_ennreal diff_diff_commute_ennreal)
	qed simp_all
	have g'_alt: "g' = plus_current (Sup (snd ` M)) g - h"
	by(simp add: fun_eq_iff g'_simps add_diff_eq_ennreal add.commute)

	have "current (\<Gamma> \<ominus> Sup (fst ` M)) (plus_current (Sup (snd ` M)) g)" using current g unfolding *
	by(rule SM1.current_plus_current_minus)
	hence g': "current ?\<Gamma> g'" unfolding * ** g'_alt using hM2[OF hM]
	by(rule SM1.current_minus)(auto intro!: add_increasing2 SUP_upper2 hM)

	have "wave (\<Gamma> \<ominus> Sup (fst ` M)) (plus_current (Sup (snd ` M)) g)" using current wave g g_w
	unfolding * by(rule SM1.wave_plus_current_minus)
	then have g'_w: "wave ?\<Gamma> g'" unfolding * ** g'_alt using hM2[OF hM]
	by(rule SM1.wave_minus)(auto intro!: add_increasing2 SUP_upper2 hM)

	have "hindrance_by ?\<Gamma> g' q"
	proof
	show "z \<in> A ?\<Gamma>" using z by simp
	show "z \<notin> \<E>\<^bsub>?\<Gamma>\<^esub> (TER\<^bsub>?\<Gamma>\<^esub> g')"
	proof
	assume "z \<in> \<E>\<^bsub>?\<Gamma>\<^esub> (TER\<^bsub>?\<Gamma>\<^esub> g')"
	hence OUT_z: "d_OUT g' z = 0"
	and ess: "essential ?\<Gamma> (B \<Gamma>) (TER\<^bsub>?\<Gamma>\<^esub> g') z" by(simp_all add: SINK.simps)
	from ess obtain p y where p: "path \<Gamma> z p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER\<^bsub>?\<Gamma>\<^esub> g')" by(rule essentialE_RF) auto
	from y have y': "y \<notin> A \<Gamma>" using disjoint by blast
	from p z y obtain py: "p = [y]" and edge: "edge \<Gamma> z y" using disjoint
	by(cases)(auto 4 3 elim: rtrancl_path.cases dest: bipartite_E)
	hence yRF: "y \<notin> RF (TER\<^bsub>?\<Gamma>\<^esub> g')" using bypass[of y] by(auto)
	with wave_not_RF_IN_zero[OF g' g'_w, of y] have IN_g'_y: "d_IN g' y = 0"
	by(auto intro: roofed_greaterI)
	with yRF y y' have w_y: "weight ?\<Gamma> y > 0" using currentD_OUT[OF g', of y]
	by(auto simp add: RF_in_B currentD_SAT[OF g'] SINK.simps zero_less_iff_neq_zero)
	have "y \<notin> SAT (\<Gamma> \<ominus> f) g"
	proof
	assume "y \<in> SAT (\<Gamma> \<ominus> f) g"
	with y disjoint have IN_g_y: "d_IN g y = weight (\<Gamma> \<ominus> f) y" by(auto simp add: currentD_SAT[OF g])
	have "0 < weight \<Gamma> y - d_IN (\<Squnion>x\<in>M. fst x) y - d_IN h y"
	using y' w_y unfolding ** by auto
	have "d_IN g' y > 0"
	using y' w_y hM unfolding **
	apply(simp add: IN_g' IN_f IN_g_y diff_add_eq_diff_diff_swap_ennreal)
	apply(subst add_diff_eq_ennreal)
	apply(auto intro!: SUP_upper2 d_IN_mono simp: diff_add_self_ennreal diff_gt_0_iff_gt_ennreal)
	done
	with IN_g'_y show False by simp
	qed
	then have "y \<notin> TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g" by simp
	with p y py have "essential \<Gamma> (B \<Gamma>) (TER\<^bsub>\<Gamma> \<ominus> f\<^esub> g) z" by(auto intro: essentialI)
	moreover with z waveD_separating[OF g_w, THEN separating_RF_A] have "z \<in> \<E>\<^bsub>?\<Omega>\<^esub> (TER\<^bsub>?\<Omega>\<^esub> g)"
	by(auto simp add: RF_in_essential)
	with z\<E> show False by contradiction
	qed
	have "\<delta> \<le> weight ?\<Gamma> z - d_OUT g' z"
	unfolding ** OUT_g' using z
	apply (simp add: \<delta>_def OUT_f diff_add_eq_diff_diff_swap_ennreal)
	apply (subst (5) diff_diff_commute_ennreal)
	apply (rule ennreal_minus_mono[OF _ order_refl])
	apply (auto simp add: ac_simps diff_add_eq_diff_diff_swap_ennreal[symmetric] add_diff_self_ennreal image_comp
	intro!: ennreal_minus_mono[OF order_refl] SUP_upper2[OF hM] d_OUT_mono)
	done
	then show q_z: "q < weight ?\<Gamma> z - d_OUT g' z" using q_less_\<delta> by simp
	then show "d_OUT g' z < weight ?\<Gamma> z" using q_nonneg z
	by(auto simp add: less_diff_eq_ennreal less_top[symmetric] ac_simps \<Gamma>.currentD_finite_OUT[OF g']
	intro: le_less_trans[rotated] add_increasing)
	qed
	then have hindered_by: "hindered_by (\<Gamma> \<ominus> ?\<epsilon>h \<ominus> k) q" using g' g'_w by(rule hindered_by.intros)
	then have "hindered (\<Gamma> \<ominus> ?\<epsilon>h)" using q_finite unfolding q_def by -(rule \<epsilon>h.hindered_reduce_current[OF k])
	with unhindered_h show False unfolding F_simps by contradiction
	qed
	qed

	define sat where "sat =
	(\<lambda>(\<epsilon>, h).
	let
	f = F (\<epsilon>, h);
	k = SOME k. current (\<Gamma> \<ominus> f) k \<and> wave (\<Gamma> \<ominus> f) k \<and> (\<forall>k'. current (\<Gamma> \<ominus> f) k' \<and> wave (\<Gamma> \<ominus> f) k' \<and> k \<le> k' \<longrightarrow> k = k')
	in
	if d_OUT (plus_current f k) a < weight \<Gamma> a then
	let
	\<Omega> = \<Gamma> \<ominus> f \<ominus> k;
	y = SOME y. y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Omega>\<^esub> a \<and> weight \<Omega> y > 0;
	\<delta> = SOME \<delta>. \<delta> > 0 \<and> \<delta> < enn2real (min (weight \<Omega> a) (weight \<Omega> y)) \<and> \<not> hindered (reduce_weight \<Omega> y \<delta>)
	in
	(plus_current \<epsilon> (zero_current((a, y) := \<delta>)), plus_current h k)
	else (\<epsilon>, h))"

	have zero: "(zero_current, zero_current) \<in> Field leq"
	by(rule F_I)(simp_all add: unhindered F_def)

	have a_TER: "a \<in> TER\<^bsub>\<Gamma> \<ominus> F \<epsilon>h\<^esub> k"
	if that: "\<epsilon>h \<in> Field leq"
	and k: "current (\<Gamma> \<ominus> F \<epsilon>h) k" and k_w: "wave (\<Gamma> \<ominus> F \<epsilon>h) k"
	and less: "d_OUT (plus_current (F \<epsilon>h) k) a < weight \<Gamma> a" for \<epsilon>h k
	proof(rule ccontr)
	assume "\<not> ?thesis"
	hence \<E>: "a \<notin> \<E>\<^bsub>\<Gamma> \<ominus> F \<epsilon>h\<^esub> (TER\<^bsub>\<Gamma> \<ominus> F \<epsilon>h\<^esub> k)" by auto
	from that have f: "current \<Gamma> (F \<epsilon>h)" and unhindered: "\<not> hindered (\<Gamma> \<ominus> F \<epsilon>h)"
	by(cases \<epsilon>h; simp add: f unhindered'; fail)+

	from less have "d_OUT k a < weight (\<Gamma> \<ominus> F \<epsilon>h) a" using a currentD_finite_OUT[OF f, of a]
	by(simp add: d_OUT_def nn_integral_add less_diff_eq_ennreal add.commute less_top[symmetric])
	with _ \<E> have "hindrance (\<Gamma> \<ominus> F \<epsilon>h) k" by(rule hindrance)(simp add: a)
	then have "hindered (\<Gamma> \<ominus> F \<epsilon>h)" using k k_w ..
	with unhindered show False by contradiction
	qed

	note minus_web_sel(2)[simp del]

	let ?P_y = "\<lambda>\<epsilon>h k y. y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Gamma> \<ominus> F \<epsilon>h \<ominus> k\<^esub> a \<and> weight (\<Gamma> \<ominus> F \<epsilon>h \<ominus> k) y > 0"
	have Ex_y: "Ex (?P_y \<epsilon>h k)"
	if that: "\<epsilon>h \<in> Field leq"
	and k: "current (\<Gamma> \<ominus> F \<epsilon>h) k" and k_w: "wave (\<Gamma> \<ominus> F \<epsilon>h) k"
	and less: "d_OUT (plus_current (F \<epsilon>h) k) a < weight \<Gamma> a" for \<epsilon>h k
	proof(rule ccontr)
	let ?\<Omega> = "\<Gamma> \<ominus> F \<epsilon>h \<ominus> k"
	assume *: "\<not> ?thesis"

	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> F \<epsilon>h" using f[OF that] by(rule countable_bipartite_web_minus_web)
	note [simp] = weight_minus_web[OF f[OF that]] \<Gamma>.weight_minus_web[OF k]

	have "hindrance ?\<Omega> zero_current"
	proof
	show "a \<in> A ?\<Omega>" using a by simp
	show "a \<notin> \<E>\<^bsub>?\<Omega>\<^esub> (TER\<^bsub>?\<Omega>\<^esub> zero_current)" (is "a \<notin> \<E>\<^bsub>_\<^esub> ?TER")
	proof
	assume "a \<in> \<E>\<^bsub>?\<Omega>\<^esub> ?TER"
	then obtain p y where p: "path ?\<Omega> a p y" and y: "y \<in> B ?\<Omega>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF\<^bsub>?\<Omega>\<^esub> ?TER" by(rule \<E>_E_RF)(auto)
	from a p y disjoint have Nil: "p \<noteq> []" by(auto simp add: rtrancl_path_simps)
	hence "edge ?\<Omega> a (p ! 0)" "p ! 0 \<notin> RF\<^bsub>?\<Omega>\<^esub> ?TER"
	using rtrancl_path_nth[OF p, of 0] bypass by auto
	with * show False by(auto simp add: not_less outgoing_def intro: roofed_greaterI)
	qed

	have "d_OUT (plus_current (F \<epsilon>h) k) x = d_OUT (F \<epsilon>h) x + d_OUT k x" for x
	by(simp add: d_OUT_def nn_integral_add)
	then show "d_OUT zero_current a < weight ?\<Omega> a" using less a_TER[OF that k k_w less] a
	by(simp add: SINK.simps diff_gr0_ennreal)
	qed
	hence "hindered ?\<Omega>"
	by(auto intro!: hindered.intros order_trans[OF currentD_weight_OUT[OF k]] order_trans[OF currentD_weight_IN[OF k]])
	moreover have "\<not> hindered ?\<Omega>" using unhindered'[OF that] k k_w by(rule \<Gamma>.unhindered_minus_web)
	ultimately show False by contradiction
	qed

	have increasing: "\<epsilon>h \<le> sat \<epsilon>h \<and> sat \<epsilon>h \<in> Field leq" if "\<epsilon>h \<in> Field leq" for \<epsilon>h
	proof(cases \<epsilon>h)
	case (Pair \<epsilon> h)
	with that have that: "(\<epsilon>, h) \<in> Field leq" by simp
	have f: "current \<Gamma> (F (\<epsilon>, h))" and unhindered: "\<not> hindered (\<Gamma> \<ominus> F (\<epsilon>, h))"
	and \<epsilon>: "current \<Gamma> \<epsilon>"
	and h: "current (\<Gamma> \<ominus> \<epsilon>) h" and h_w: "wave (\<Gamma> \<ominus> \<epsilon>) h" and OUT_\<epsilon>: "x \<noteq> a \<Longrightarrow> d_OUT \<epsilon> x = 0" for x
	using that by(rule f unhindered' \<epsilon>_curr OUT_\<epsilon> h h_w)+
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> F (\<epsilon>, h)" using f by(rule countable_bipartite_web_minus_web)
	note [simp] = weight_minus_web[OF f]

	let ?P_k = "\<lambda>k. current (\<Gamma> \<ominus> F (\<epsilon>, h)) k \<and> wave (\<Gamma> \<ominus> F (\<epsilon>, h)) k \<and> (\<forall>k'. current (\<Gamma> \<ominus> F (\<epsilon>, h)) k' \<and> wave (\<Gamma> \<ominus> F (\<epsilon>, h)) k' \<and> k \<le> k' \<longrightarrow> k = k')"
	define k where "k = Eps ?P_k"
	have "Ex ?P_k" by(intro ex_maximal_wave)(simp_all)
	hence "?P_k k" unfolding k_def by(rule someI_ex)
	hence k: "current (\<Gamma> \<ominus> F (\<epsilon>, h)) k" and k_w: "wave (\<Gamma> \<ominus> F (\<epsilon>, h)) k"
	and maximal: "\<And>k'. \<lbrakk> current (\<Gamma> \<ominus> F (\<epsilon>, h)) k'; wave (\<Gamma> \<ominus> F (\<epsilon>, h)) k'; k \<le> k' \<rbrakk> \<Longrightarrow> k = k'" by blast+
	note [simp] = \<Gamma>.weight_minus_web[OF k]

	let ?fk = "plus_current (F (\<epsilon>, h)) k"
	have IN_fk: "d_IN ?fk x = d_IN (F (\<epsilon>, h)) x + d_IN k x" for x
	by(simp add: d_IN_def nn_integral_add)
	have OUT_fk: "d_OUT ?fk x = d_OUT (F (\<epsilon>, h)) x + d_OUT k x" for x
	by(simp add: d_OUT_def nn_integral_add)
	have fk: "current \<Gamma> ?fk" using f k by(rule current_plus_current_minus)

	show ?thesis
	proof(cases "d_OUT ?fk a < weight \<Gamma> a")
	case less: True

	define \<Omega> where "\<Omega> = \<Gamma> \<ominus> F (\<epsilon>, h) \<ominus> k"
	have B_\<Omega> [simp]: "B \<Omega> = B \<Gamma>" by(simp add: \<Omega>_def)

	have loose: "loose \<Omega>" unfolding \<Omega>_def using unhindered k k_w maximal by(rule \<Gamma>.loose_minus_web)
	interpret \<Omega>: countable_bipartite_web \<Omega> using k unfolding \<Omega>_def
	by(rule \<Gamma>.countable_bipartite_web_minus_web)

	have a_\<E>: "a \<in> TER\<^bsub>\<Gamma> \<ominus> F (\<epsilon>, h)\<^esub> k" using that k k_w less by(rule a_TER)
	then have weight_\<Omega>_a: "weight \<Omega> a = weight \<Gamma> a - d_OUT (F (\<epsilon>, h)) a"
	using a disjoint by(auto simp add: roofed_circ_def \<Omega>_def SINK.simps)
	then have weight_a: "0 < weight \<Omega> a" using less a_\<E>
	by(simp add: OUT_fk SINK.simps diff_gr0_ennreal)

	let ?P_y = "\<lambda>y. y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Omega>\<^esub> a \<and> weight \<Omega> y > 0"
	define y where "y = Eps ?P_y"
	have "Ex ?P_y" using that k k_w less unfolding \<Omega>_def by(rule Ex_y)
	hence "?P_y y" unfolding y_def by(rule someI_ex)
	hence y_OUT: "y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Omega>\<^esub> a" and weight_y: "weight \<Omega> y > 0" by blast+
	from y_OUT have y_B: "y \<in> B \<Omega>" by(auto simp add: outgoing_def \<Omega>_def dest: bipartite_E)
	with weight_y have yRF: "y \<notin> RF\<^bsub>\<Gamma> \<ominus> F (\<epsilon>, h)\<^esub> (TER\<^bsub>\<Gamma> \<ominus> F (\<epsilon>, h)\<^esub> k)"
	unfolding \<Omega>_def using currentD_OUT[OF k, of y] disjoint
	by(auto split: if_split_asm simp add: SINK.simps currentD_SAT[OF k] roofed_circ_def RF_in_B \<Gamma>.currentD_finite_IN[OF k])
	hence IN_k_y: "d_IN k y = 0" by(rule wave_not_RF_IN_zero[OF k k_w])

	define bound where "bound = enn2real (min (weight \<Omega> a) (weight \<Omega> y))"
	have bound_pos: "bound > 0" using weight_y weight_a using \<Omega>.weight_finite
	by(cases "weight \<Omega> a" "weight \<Omega> y" rule: ennreal2_cases)
	(simp_all add: bound_def min_def split: if_split_asm)

	let ?P_\<delta> = "\<lambda>\<delta>. \<delta> > 0 \<and> \<delta> < bound \<and> \<not> hindered (reduce_weight \<Omega> y \<delta>)"
	define \<delta> where "\<delta> = Eps ?P_\<delta>"
	let ?\<Omega> = "reduce_weight \<Omega> y \<delta>"

	from \<Omega>.unhinder[OF loose _ weight_y bound_pos] y_B disjoint
	have "Ex ?P_\<delta>" by(auto simp add: \<Omega>_def)
	hence "?P_\<delta> \<delta>" unfolding \<delta>_def by(rule someI_ex)
	hence \<delta>_pos: "0 < \<delta>" and \<delta>_le_bound: "\<delta> < bound" and unhindered': "\<not> hindered ?\<Omega>" by blast+
	from \<delta>_pos have \<delta>_nonneg: "0 \<le> \<delta>" by simp
	from \<delta>_le_bound \<delta>_pos have \<delta>_le_a: "\<delta> < weight \<Omega> a" and \<delta>_le_y: "\<delta> < weight \<Omega> y"
	by(cases "weight \<Omega> a" "weight \<Omega> y" rule: ennreal2_cases;
	simp add: bound_def min_def ennreal_less_iff split: if_split_asm)+

	let ?\<Gamma> = "\<Gamma> \<ominus> ?fk"
	interpret \<Gamma>': countable_bipartite_web ?\<Gamma> by(rule countable_bipartite_web_minus_web fk)+
	note [simp] = weight_minus_web[OF fk]

	let ?g = "zero_current((a, y) := \<delta>)"
	have OUT_g: "d_OUT ?g x = (if x = a then \<delta> else 0)" for x
	proof(rule trans)
	show "d_OUT ?g x = (\<Sum>\<^sup>+ z. (if x = a then \<delta> else 0) * indicator {y} z)" unfolding d_OUT_def
	by(rule nn_integral_cong) simp
	show "\<dots> = (if x = a then \<delta> else 0)" using \<delta>_pos by(simp add: max_def)
	qed
	have IN_g: "d_IN ?g x = (if x = y then \<delta> else 0)" for x
	proof(rule trans)
	show "d_IN ?g x = (\<Sum>\<^sup>+ z. (if x = y then \<delta> else 0) * indicator {a} z)" unfolding d_IN_def
	by(rule nn_integral_cong) simp
	show "\<dots> = (if x = y then \<delta> else 0)" using \<delta>_pos by(simp add: max_def)
	qed

	have g: "current ?\<Gamma> ?g"
	proof
	show "d_OUT ?g x \<le> weight ?\<Gamma> x" for x
	proof(cases "x = a")
	case False
	then show ?thesis using currentD_weight_OUT[OF fk, of x] currentD_weight_IN[OF fk, of x]
	by(auto simp add: OUT_g zero_ennreal_def[symmetric])
	next
	case True
	then show ?thesis using \<delta>_le_a a a_\<E> \<delta>_pos unfolding OUT_g
	by(simp add: OUT_g \<Omega>_def SINK.simps OUT_fk split: if_split_asm)
	qed
	show "d_IN ?g x \<le> weight ?\<Gamma> x" for x
	proof(cases "x = y")
	case False
	then show ?thesis using currentD_weight_OUT[OF fk, of x] currentD_weight_IN[OF fk, of x]
	by(auto simp add: IN_g zero_ennreal_def[symmetric])
	next
	case True
	then show ?thesis using \<delta>_le_y y_B a_\<E> \<delta>_pos currentD_OUT[OF k, of y] IN_k_y
	by(simp add: OUT_g \<Omega>_def SINK.simps OUT_fk IN_fk IN_g split: if_split_asm)
	qed
	show "?g e = 0" if "e \<notin> \<^bold>E\<^bsub>?\<Gamma>\<^esub>" for e using y_OUT that by(auto simp add: \<Omega>_def outgoing_def)
	qed
	interpret \<Gamma>'': web "\<Gamma> \<ominus> ?fk \<ominus> ?g" using g by(rule \<Gamma>'.web_minus_web)

	let ?\<epsilon>' = "plus_current \<epsilon> (zero_current((a, y) := \<delta>))"
	let ?h' = "plus_current h k"
	have F': "F (?\<epsilon>', ?h') = plus_current (plus_current (F (\<epsilon>, h)) k) (zero_current((a, y) := \<delta>))" (is "_ = ?f'")
	by(auto simp add: F_simps fun_eq_iff add_ac)
	have sat: "sat (\<epsilon>, h) = (?\<epsilon>', ?h')" using less
	by(simp add: sat_def k_def \<Omega>_def Let_def y_def bound_def \<delta>_def)

	have le: "(\<epsilon>, h) \<le> (?\<epsilon>', ?h')" using \<delta>_pos
	by(auto simp add: le_fun_def add_increasing2 add_increasing)

	have "current (\<Gamma> \<ominus> \<epsilon>) ((\<lambda>_. 0)((a, y) := ennreal \<delta>))" using g
	by(rule current_weight_mono)(auto simp add: weight_minus_web[OF \<epsilon>] intro!: ennreal_minus_mono d_OUT_mono d_IN_mono, simp_all add: F_def add_increasing2)
	with \<epsilon> have \<epsilon>': "current \<Gamma> ?\<epsilon>'" by(rule current_plus_current_minus)
	moreover have eq_0: "d_OUT ?\<epsilon>' x = 0" if "x \<noteq> a" for x unfolding plus_current_def using that
	by(subst d_OUT_add)(simp_all add: \<delta>_nonneg d_OUT_fun_upd OUT_\<epsilon>)
	moreover
	from \<epsilon>' interpret \<epsilon>': countable_bipartite_web "\<Gamma> \<ominus> ?\<epsilon>'" by(rule countable_bipartite_web_minus_web)
	from \<epsilon> interpret \<epsilon>: countable_bipartite_web "\<Gamma> \<ominus> \<epsilon>" by(rule countable_bipartite_web_minus_web)
	have g': "current (\<Gamma> \<ominus> \<epsilon>) ?g" using g
	apply(rule current_weight_mono)
	apply(auto simp add: weight_minus_web[OF \<epsilon>] intro!: ennreal_minus_mono d_OUT_mono d_IN_mono)
	apply(simp_all add: F_def add_increasing2)
	done
	have k': "current (\<Gamma> \<ominus> \<epsilon> \<ominus> h) k" using k unfolding F_simps minus_plus_current[OF \<epsilon> h] .
	with h have "current (\<Gamma> \<ominus> \<epsilon>) (plus_current h k)" by(rule \<epsilon>.current_plus_current_minus)
	hence "current (\<Gamma> \<ominus> \<epsilon>) (plus_current (plus_current h k) ?g)" using g unfolding minus_plus_current[OF f k]
	unfolding F_simps minus_plus_current[OF \<epsilon> h] \<epsilon>.minus_plus_current[OF h k', symmetric]
	by(rule \<epsilon>.current_plus_current_minus)
	then have "current (\<Gamma> \<ominus> \<epsilon> \<ominus> ?g) (plus_current (plus_current h k) ?g - ?g)" using g'
	by(rule \<epsilon>.current_minus)(auto simp add: add_increasing)
	then have h'': "current (\<Gamma> \<ominus> ?\<epsilon>') ?h'"
	by(rule arg_cong2[where f=current, THEN iffD1, rotated -1])
	(simp_all add: minus_plus_current[OF \<epsilon> g'] fun_eq_iff add_diff_eq_ennreal[symmetric])
	moreover have "wave (\<Gamma> \<ominus> ?\<epsilon>') ?h'"
	proof
	have "separating (\<Gamma> \<ominus> \<epsilon>) (TER\<^bsub>\<Gamma> \<ominus> \<epsilon>\<^esub> (plus_current h k))"
	using k k_w unfolding F_simps minus_plus_current[OF \<epsilon> h]
	by(intro waveD_separating \<epsilon>.wave_plus_current_minus[OF h h_w])
	moreover have "TER\<^bsub>\<Gamma> \<ominus> \<epsilon>\<^esub> (plus_current h k) \<subseteq> TER\<^bsub>\<Gamma> \<ominus> ?\<epsilon>'\<^esub> (plus_current h k)"
	by(auto 4 4 simp add: SAT.simps weight_minus_web[OF \<epsilon>] weight_minus_web[OF \<epsilon>'] split: if_split_asm elim: order_trans[rotated] intro!: ennreal_minus_mono d_IN_mono add_increasing2 \<delta>_nonneg)
	ultimately show sep: "separating (\<Gamma> \<ominus> ?\<epsilon>') (TER\<^bsub>\<Gamma> \<ominus> ?\<epsilon>'\<^esub> ?h')"
	by(simp add: minus_plus_current[OF \<epsilon> g'] separating_weakening)
	qed(rule h'')
	moreover
	have "\<not> hindered (\<Gamma> \<ominus> F (?\<epsilon>', ?h'))" using unhindered'
	proof(rule contrapos_nn)
	assume "hindered (\<Gamma> \<ominus> F (?\<epsilon>', ?h'))"
	thus "hindered ?\<Omega>"
	proof(rule hindered_mono_web[rotated -1])
	show "weight ?\<Omega> z = weight (\<Gamma> \<ominus> F (?\<epsilon>', ?h')) z" if "z \<notin> A (\<Gamma> \<ominus> F (?\<epsilon>', ?h'))" for z
	using that unfolding F'
	apply(cases "z = y")
	apply(simp_all add: \<Omega>_def minus_plus_current[OF fk g] \<Gamma>'.weight_minus_web[OF g] IN_g)
	apply(simp_all add: plus_current_def d_IN_add diff_add_eq_diff_diff_swap_ennreal currentD_finite_IN[OF f])
	done
	have "y \<noteq> a" using y_B a disjoint by auto
	then show "weight (\<Gamma> \<ominus> F (?\<epsilon>', ?h')) z \<le> weight ?\<Omega> z" if "z \<in> A (\<Gamma> \<ominus> F (?\<epsilon>', ?h'))" for z
	using that y_B disjoint \<delta>_nonneg unfolding F'
	apply(cases "z = a")
	apply(simp_all add: \<Omega>_def minus_plus_current[OF fk g] \<Gamma>'.weight_minus_web[OF g] OUT_g)
	apply(auto simp add: plus_current_def d_OUT_add diff_add_eq_diff_diff_swap_ennreal currentD_finite_OUT[OF f])
	done
	qed(simp_all add: \<Omega>_def)
	qed
	ultimately have "(?\<epsilon>', ?h') \<in> Field leq" by-(rule F_I)
	with Pair le sat that show ?thesis by(auto)
	next
	case False
	with currentD_weight_OUT[OF fk, of a] have "d_OUT ?fk a = weight \<Gamma> a" by simp
	have "sat \<epsilon>h = \<epsilon>h" using False Pair by(simp add: sat_def k_def)
	thus ?thesis using that Pair by(auto)
	qed
	qed

	have "bourbaki_witt_fixpoint Sup leq sat" using increasing chain_Field unfolding leq_def
	by(intro bourbaki_witt_fixpoint_restrict_rel)(auto intro: Sup_upper Sup_least)
	then interpret bourbaki_witt_fixpoint Sup leq sat .

	define f where "f = fixp_above (zero_current, zero_current)"
	have Field: "f \<in> Field leq" using fixp_above_Field[OF zero] unfolding f_def .
	then have f: "current \<Gamma> (F f)" and unhindered: "\<not> hindered (\<Gamma> \<ominus> F f)"
	by(cases f; simp add: f unhindered'; fail)+
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> F f" using f by(rule countable_bipartite_web_minus_web)
	note [simp] = weight_minus_web[OF f]
	have Field': "(fst f, snd f) \<in> Field leq" using Field by simp

	let ?P_k = "\<lambda>k. current (\<Gamma> \<ominus> F f) k \<and> wave (\<Gamma> \<ominus> F f) k \<and> (\<forall>k'. current (\<Gamma> \<ominus> F f) k' \<and> wave (\<Gamma> \<ominus> F f) k' \<and> k \<le> k' \<longrightarrow> k = k')"
	define k where "k = Eps ?P_k"
	have "Ex ?P_k" by(intro ex_maximal_wave)(simp_all)
	hence "?P_k k" unfolding k_def by(rule someI_ex)
	hence k: "current (\<Gamma> \<ominus> F f) k" and k_w: "wave (\<Gamma> \<ominus> F f) k"
	and maximal: "\<And>k'. \<lbrakk> current (\<Gamma> \<ominus> F f) k'; wave (\<Gamma> \<ominus> F f) k'; k \<le> k' \<rbrakk> \<Longrightarrow> k = k'" by blast+
	note [simp] = \<Gamma>.weight_minus_web[OF k]

	let ?fk = "plus_current (F f) k"
	have IN_fk: "d_IN ?fk x = d_IN (F f) x + d_IN k x" for x
	by(simp add: d_IN_def nn_integral_add)
	have OUT_fk: "d_OUT ?fk x = d_OUT (F f) x + d_OUT k x" for x
	by(simp add: d_OUT_def nn_integral_add)
	have fk: "current \<Gamma> ?fk" using f k by(rule current_plus_current_minus)

	have "d_OUT ?fk a \<ge> weight \<Gamma> a"
	proof(rule ccontr)
	assume "\<not> ?thesis"
	hence less: "d_OUT ?fk a < weight \<Gamma> a" by simp

	define \<Omega> where "\<Omega> = \<Gamma> \<ominus> F f \<ominus> k"
	have B_\<Omega> [simp]: "B \<Omega> = B \<Gamma>" by(simp add: \<Omega>_def)

	have loose: "loose \<Omega>" unfolding \<Omega>_def using unhindered k k_w maximal by(rule \<Gamma>.loose_minus_web)
	interpret \<Omega>: countable_bipartite_web \<Omega> using k unfolding \<Omega>_def
	by(rule \<Gamma>.countable_bipartite_web_minus_web)

	have a_\<E>: "a \<in> TER\<^bsub>\<Gamma> \<ominus> F f\<^esub> k" using Field k k_w less by(rule a_TER)
	then have "weight \<Omega> a = weight \<Gamma> a - d_OUT (F f) a"
	using a disjoint by(auto simp add: roofed_circ_def \<Omega>_def SINK.simps)
	then have weight_a: "0 < weight \<Omega> a" using less a_\<E>
	by(simp add: OUT_fk SINK.simps diff_gr0_ennreal)

	let ?P_y = "\<lambda>y. y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Omega>\<^esub> a \<and> weight \<Omega> y > 0"
	define y where "y = Eps ?P_y"
	have "Ex ?P_y" using Field k k_w less unfolding \<Omega>_def by(rule Ex_y)
	hence "?P_y y" unfolding y_def by(rule someI_ex)
	hence "y \<in> \<^bold>O\<^bold>U\<^bold>T\<^bsub>\<Omega>\<^esub> a" and weight_y: "weight \<Omega> y > 0" by blast+
	then have y_B: "y \<in> B \<Omega>" by(auto simp add: outgoing_def \<Omega>_def dest: bipartite_E)

	define bound where "bound = enn2real (min (weight \<Omega> a) (weight \<Omega> y))"
	have bound_pos: "bound > 0" using weight_y weight_a \<Omega>.weight_finite
	by(cases "weight \<Omega> a" "weight \<Omega> y" rule: ennreal2_cases)
	(simp_all add: bound_def min_def split: if_split_asm)

	let ?P_\<delta> = "\<lambda>\<delta>. \<delta> > 0 \<and> \<delta> < bound \<and> \<not> hindered (reduce_weight \<Omega> y \<delta>)"
	define \<delta> where "\<delta> = Eps ?P_\<delta>"
	from \<Omega>.unhinder[OF loose _ weight_y bound_pos] y_B disjoint have "Ex ?P_\<delta>" by(auto simp add: \<Omega>_def)
	hence "?P_\<delta> \<delta>" unfolding \<delta>_def by(rule someI_ex)
	hence \<delta>_pos: "0 < \<delta>" by blast+

	let ?f' = "(plus_current (fst f) (zero_current((a, y) := \<delta>)), plus_current (snd f) k)"
	have sat: "?f' = sat f" using less by(simp add: sat_def k_def \<Omega>_def Let_def y_def bound_def \<delta>_def split_def)
	also have "\<dots> = f" unfolding f_def using fixp_above_unfold[OF zero] by simp
	finally have "fst ?f' (a, y) = fst f (a, y)" by simp
	hence "\<delta> = 0" using currentD_finite[OF \<epsilon>_curr[OF Field']] \<delta>_pos
	by(cases "fst f (a, y)") simp_all
	with \<delta>_pos show False by simp
	qed

	with currentD_weight_OUT[OF fk, of a] have "d_OUT ?fk a = weight \<Gamma> a" by simp
	moreover have "current \<Gamma> ?fk" using f k by(rule current_plus_current_minus)
	moreover have "\<not> hindered (\<Gamma> \<ominus> ?fk)" unfolding minus_plus_current[OF f k]
	using unhindered k k_w by(rule \<Gamma>.unhindered_minus_web)
	ultimately show ?thesis by blast
	qed

	end

	subsection \<open>Linkability of unhindered bipartite webs\<close>

	context countable_bipartite_web begin

	theorem unhindered_linkable:
	assumes unhindered: "\<not> hindered \<Gamma>"
	shows "linkable \<Gamma>"
	proof(cases "A \<Gamma> = {}")
	case True
	thus ?thesis by(auto intro!: exI[where x="zero_current"] linkage.intros simp add: web_flow_iff )
	next
	case nempty: False

	let ?P = "\<lambda>f a f'. current (\<Gamma> \<ominus> f) f' \<and> d_OUT f' a = weight (\<Gamma> \<ominus> f) a \<and> \<not> hindered (\<Gamma> \<ominus> f \<ominus> f')"

	define enum where "enum = from_nat_into (A \<Gamma>)"
	have enum_A: "enum n \<in> A \<Gamma>" for n using from_nat_into[OF nempty, of n] by(simp add: enum_def)
	have vertex_enum [simp]: "vertex \<Gamma> (enum n)" for n using enum_A[of n] A_vertex by blast

	define f where "f = rec_nat zero_current (\<lambda>n f. let f' = SOME f'. ?P f (enum n) f' in plus_current f f')"
	have f_0 [simp]: "f 0 = zero_current" by(simp add: f_def)
	have f_Suc: "f (Suc n) = plus_current (f n) (Eps (?P (f n) (enum n)))" for n by(simp add: f_def)

	have f: "current \<Gamma> (f n)"
	and sat: "\<And>m. m < n \<Longrightarrow> d_OUT (f n) (enum m) = weight \<Gamma> (enum m)"
	and unhindered: "\<not> hindered (\<Gamma> \<ominus> f n)" for n
	proof(induction n)
	case 0
	- { case 1 thus ?case by(simp add: ) }
	+ { case 1 thus ?case bysimp }
	{ case 2 thus ?case by simp }
	{ case 3 thus ?case using unhindered by simp }
	next
	case (Suc n)
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> f n" using Suc.IH(1) by(rule countable_bipartite_web_minus_web)

	define f' where "f' = Eps (?P (f n) (enum n))"
	have "Ex (?P (f n) (enum n))" using Suc.IH(3) by(rule \<Gamma>.unhindered_saturate1)(simp add: enum_A)
	hence "?P (f n) (enum n) f'" unfolding f'_def by(rule someI_ex)
	hence f': "current (\<Gamma> \<ominus> f n) f'"
	and OUT: "d_OUT f' (enum n) = weight (\<Gamma> \<ominus> f n) (enum n)"
	and unhindered': "\<not> hindered (\<Gamma> \<ominus> f n \<ominus> f')" by blast+
	have f_Suc: "f (Suc n) = plus_current (f n) f'" by(simp add: f'_def f_Suc)
	{ case 1 show ?case unfolding f_Suc using Suc.IH(1) f' by(rule current_plus_current_minus) }
	note f'' = this
	{ case (2 m)
	have "d_OUT (f (Suc n)) (enum m) \<le> weight \<Gamma> (enum m)" using f'' by(rule currentD_weight_OUT)
	moreover have "weight \<Gamma> (enum m) \<le> d_OUT (f (Suc n)) (enum m)"
	proof(cases "m = n")
	case True
	then show ?thesis unfolding f_Suc using OUT True
	by(simp add: d_OUT_def nn_integral_add enum_A add_diff_self_ennreal less_imp_le)
	next
	case False
	hence "m < n" using 2 by simp
	thus ?thesis using Suc.IH(2)[OF \<open>m < n\<close>] unfolding f_Suc
	by(simp add: d_OUT_def nn_integral_add add_increasing2 )
	qed
	ultimately show ?case by(rule antisym) }
	{ case 3 show ?case unfolding f_Suc minus_plus_current[OF Suc.IH(1) f'] by(rule unhindered') }
	qed
	interpret \<Gamma>: countable_bipartite_web "\<Gamma> \<ominus> f n" for n using f by(rule countable_bipartite_web_minus_web)

	have Ex_P: "Ex (?P (f n) (enum n))" for n using unhindered by(rule \<Gamma>.unhindered_saturate1)(simp add: enum_A)
	have f_mono: "f n \<le> f (Suc n)" for n using someI_ex[OF Ex_P, of n]
	by(auto simp add: le_fun_def f_Suc enum_A intro: add_increasing2 dest: )
	hence incseq: "incseq f" by(rule incseq_SucI)
	hence chain: "Complete_Partial_Order.chain (\<le>) (range f)" by(rule incseq_chain_range)

	define g where "g = Sup (range f)"
	have "support_flow g \<subseteq> \<^bold>E"
	by (auto simp add: g_def support_flow.simps currentD_outside [OF f] image_comp elim: contrapos_pp)
	then have countable_g: "countable (support_flow g)" by(rule countable_subset) simp
	with chain _ _ have g: "current \<Gamma> g" unfolding g_def by(rule current_Sup)(auto simp add: f)
	moreover
	have "d_OUT g x = weight \<Gamma> x" if "x \<in> A \<Gamma>" for x
	proof(rule antisym)
	show "d_OUT g x \<le> weight \<Gamma> x" using g by(rule currentD_weight_OUT)
	have "countable (A \<Gamma>)" using A_vertex by(rule countable_subset) simp
	from that subset_range_from_nat_into[OF this] obtain n where "x = enum n" unfolding enum_def by blast
	with sat[of n "Suc n"] have "d_OUT (f (Suc n)) x \<ge> weight \<Gamma> x" by simp
	then show "weight \<Gamma> x \<le> d_OUT g x" using countable_g unfolding g_def
	by(subst d_OUT_Sup[OF chain])(auto intro: SUP_upper2)
	qed
	ultimately show ?thesis by(auto simp add: web_flow_iff linkage.simps)
	qed

	end


	context countable_web begin

	theorem loose_linkable: \<comment> \<open>Theorem 6.2\<close>
	assumes "loose \<Gamma>"
	shows "linkable \<Gamma>"
	proof -
	interpret bi: countable_bipartite_web "bipartite_web_of \<Gamma>" by(rule countable_bipartite_web_of)
	have "\<not> hindered (bipartite_web_of \<Gamma>)" using assms by(rule unhindered_bipartite_web_of)
	then have "linkable (bipartite_web_of \<Gamma>)"
	by(rule bi.unhindered_linkable)
	then show ?thesis by(rule linkable_bipartite_web_ofD) simp
	qed

	lemma ex_orthogonal_current: \<comment> \<open>Lemma 4.15\<close>
	"\<exists>f S. web_flow \<Gamma> f \<and> separating \<Gamma> S \<and> orthogonal_current \<Gamma> f S"
	by(rule ex_orthogonal_current')(rule countable_web.loose_linkable[OF countable_web_quotient_web])

	end

	subsection \<open>Glueing the reductions together\<close>

	context countable_network begin

	context begin

	qualified lemma max_flow_min_cut':
	assumes source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
	and sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
	and undead: "\<And>x y. edge \<Delta> x y \<Longrightarrow> (\<exists>z. edge \<Delta> y z) \<or> (\<exists>z. edge \<Delta> z x)"
	and source_sink: "\<not> edge \<Delta> (source \<Delta>) (sink \<Delta>)"
	and no_loop: "\<And>x. \<not> edge \<Delta> x x"
	and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
	shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
	by(rule max_flow_min_cut')(rule countable_web.ex_orthogonal_current[OF countable_web_web_of_network], fact+)

	qualified lemma max_flow_min_cut'':
	assumes sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
	and source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
	and no_loop: "\<And>x. \<not> edge \<Delta> x x"
	and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
	shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
	proof -
	interpret antiparallel_edges \<Delta> ..
	interpret \<Delta>'': countable_network \<Delta>'' by(rule \<Delta>''_countable_network)
	have "\<exists>f S. flow \<Delta>'' f \<and> cut \<Delta>'' S \<and> orthogonal \<Delta>'' f S"
	by(rule \<Delta>''.max_flow_min_cut')(auto simp add: sink_out source_in no_loop capacity_pos elim: edg.cases)
	then obtain f S where f: "flow \<Delta>'' f" and cut: "cut \<Delta>'' S" and ortho: "orthogonal \<Delta>'' f S" by blast
	have "flow \<Delta> (collect f)" using f by(rule flow_collect)
	moreover have "cut \<Delta> (cut' S)" using cut by(rule cut_cut')
	moreover have "orthogonal \<Delta> (collect f) (cut' S)" using ortho f by(rule orthogonal_cut')
	ultimately show ?thesis by blast
	qed

	qualified lemma max_flow_min_cut''':
	assumes sink_out: "\<And>y. \<not> edge \<Delta> (sink \<Delta>) y"
	and source_in: "\<And>x. \<not> edge \<Delta> x (source \<Delta>)"
	and capacity_pos: "\<And>e. e \<in> \<^bold>E \<Longrightarrow> capacity \<Delta> e > 0"
	shows "\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
	proof -
	interpret antiparallel_edges \<Delta> ..
	interpret \<Delta>'': countable_network \<Delta>'' by(rule \<Delta>''_countable_network)
	have "\<exists>f S. flow \<Delta>'' f \<and> cut \<Delta>'' S \<and> orthogonal \<Delta>'' f S"
	by(rule \<Delta>''.max_flow_min_cut'')(auto simp add: sink_out source_in capacity_pos elim: edg.cases)
	then obtain f S where f: "flow \<Delta>'' f" and cut: "cut \<Delta>'' S" and ortho: "orthogonal \<Delta>'' f S" by blast
	have "flow \<Delta> (collect f)" using f by(rule flow_collect)
	moreover have "cut \<Delta> (cut' S)" using cut by(rule cut_cut')
	moreover have "orthogonal \<Delta> (collect f) (cut' S)" using ortho f by(rule orthogonal_cut')
	ultimately show ?thesis by blast
	qed

	theorem max_flow_min_cut:
	"\<exists>f S. flow \<Delta> f \<and> cut \<Delta> S \<and> orthogonal \<Delta> f S"
	proof -
	interpret \<Delta>''': countable_network \<Delta>''' by(rule \<Delta>'''_countable_network)
	have "\<exists>f S. flow \<Delta>''' f \<and> cut \<Delta>''' S \<and> orthogonal \<Delta>''' f S" by(rule \<Delta>'''.max_flow_min_cut''') auto
	then obtain f S where f: "flow \<Delta>''' f" and cut: "cut \<Delta>''' S" and ortho: "orthogonal \<Delta>''' f S" by blast
	from flow_\<Delta>'''[OF this] show ?thesis by blast
	qed

	end

	end

	end
	diff --git a/thys/MFMC_Countable/MFMC_Web.thy b/thys/MFMC_Countable/MFMC_Web.thy
	--- a/thys/MFMC_Countable/MFMC_Web.thy
	+++ b/thys/MFMC_Countable/MFMC_Web.thy
	@@ -1,1973 +1,1973 @@
	theory MFMC_Web imports
	MFMC_Network
	begin

	section \<open>Webs and currents\<close>

	record 'v web = "'v graph" +
	weight :: "'v \<Rightarrow> ennreal"
	A :: "'v set"
	B :: "'v set"

	lemma vertex_weight_update [simp]: "vertex (weight_update f \<Gamma>) = vertex \<Gamma>"
	by(simp add: vertex_def fun_eq_iff)

	type_synonym 'v current = "'v edge \<Rightarrow> ennreal"

	inductive current :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> bool"
	for \<Gamma> f
	where
	current:
	"\<lbrakk> \<And>x. d_OUT f x \<le> weight \<Gamma> x;
	\<And>x. d_IN f x \<le> weight \<Gamma> x;
	\<And>x. x \<notin> A \<Gamma> \<Longrightarrow> d_OUT f x \<le> d_IN f x;
	\<And>a. a \<in> A \<Gamma> \<Longrightarrow> d_IN f a = 0;
	\<And>b. b \<in> B \<Gamma> \<Longrightarrow> d_OUT f b = 0;
	\<And>e. e \<notin> \<^bold>E\<^bsub>\<Gamma>\<^esub> \<Longrightarrow> f e = 0 \<rbrakk>
	\<Longrightarrow> current \<Gamma> f"

	lemma currentD_weight_OUT: "current \<Gamma> f \<Longrightarrow> d_OUT f x \<le> weight \<Gamma> x"
	by(simp add: current.simps)

	lemma currentD_weight_IN: "current \<Gamma> f \<Longrightarrow> d_IN f x \<le> weight \<Gamma> x"
	by(simp add: current.simps)

	lemma currentD_OUT_IN: "\<lbrakk> current \<Gamma> f; x \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f x \<le> d_IN f x"
	by(simp add: current.simps)

	lemma currentD_IN: "\<lbrakk> current \<Gamma> f; a \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> d_IN f a = 0"
	by(simp add: current.simps)

	lemma currentD_OUT: "\<lbrakk> current \<Gamma> f; b \<in> B \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f b = 0"
	by(simp add: current.simps)

	lemma currentD_outside: "\<lbrakk> current \<Gamma> f; \<not> edge \<Gamma> x y \<rbrakk> \<Longrightarrow> f (x, y) = 0"
	by(blast elim: current.cases)

	lemma currentD_outside': "\<lbrakk> current \<Gamma> f; e \<notin> \<^bold>E\<^bsub>\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> f e = 0"
	by(blast elim: current.cases)

	lemma currentD_OUT_eq_0:
	assumes "current \<Gamma> f"
	shows "d_OUT f x = 0 \<longleftrightarrow> (\<forall>y. f (x, y) = 0)"
	by(simp add: d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0)

	lemma currentD_IN_eq_0:
	assumes "current \<Gamma> f"
	shows "d_IN f x = 0 \<longleftrightarrow> (\<forall>y. f (y, x) = 0)"
	by(simp add: d_IN_def nn_integral_0_iff emeasure_count_space_eq_0)

	lemma current_support_flow:
	fixes \<Gamma> (structure)
	assumes "current \<Gamma> f"
	shows "support_flow f \<subseteq> \<^bold>E"
	using currentD_outside[OF assms] by(auto simp add: support_flow.simps intro: ccontr)

	lemma currentD_outside_IN: "\<lbrakk> current \<Gamma> f; x \<notin> \<^bold>V\<^bsub>\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> d_IN f x = 0"
	by(auto simp add: d_IN_def vertex_def nn_integral_0_iff AE_count_space emeasure_count_space_eq_0 dest: currentD_outside)

	lemma currentD_outside_OUT: "\<lbrakk> current \<Gamma> f; x \<notin> \<^bold>V\<^bsub>\<Gamma>\<^esub> \<rbrakk> \<Longrightarrow> d_OUT f x = 0"
	by(auto simp add: d_OUT_def vertex_def nn_integral_0_iff AE_count_space emeasure_count_space_eq_0 dest: currentD_outside)

	lemma currentD_weight_in: "current \<Gamma> h \<Longrightarrow> h (x, y) \<le> weight \<Gamma> y"
	by (metis order_trans d_IN_ge_point currentD_weight_IN)

	lemma currentD_weight_out: "current \<Gamma> h \<Longrightarrow> h (x, y) \<le> weight \<Gamma> x"
	by (metis order_trans d_OUT_ge_point currentD_weight_OUT)

	lemma current_leI:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and le: "\<And>e. g e \<le> f e"
	and OUT_IN: "\<And>x. x \<notin> A \<Gamma> \<Longrightarrow> d_OUT g x \<le> d_IN g x"
	shows "current \<Gamma> g"
	proof
	show "d_OUT g x \<le> weight \<Gamma> x" for x
	using d_OUT_mono[of g x f, OF le] currentD_weight_OUT[OF f] by(rule order_trans)
	show "d_IN g x \<le> weight \<Gamma> x" for x
	using d_IN_mono[of g x f, OF le] currentD_weight_IN[OF f] by(rule order_trans)
	show "d_IN g a = 0" if "a \<in> A \<Gamma>" for a
	using d_IN_mono[of g a f, OF le] currentD_IN[OF f that] by auto
	show "d_OUT g b = 0" if "b \<in> B \<Gamma>" for b
	using d_OUT_mono[of g b f, OF le] currentD_OUT[OF f that] by auto
	show "g e = 0" if "e \<notin> \<^bold>E" for e
	using currentD_outside'[OF f that] le[of e] by simp
	qed(blast intro: OUT_IN)+

	lemma current_weight_mono:
	"\<lbrakk> current \<Gamma> f; edge \<Gamma> = edge \<Gamma>'; A \<Gamma> = A \<Gamma>'; B \<Gamma> = B \<Gamma>'; \<And>x. weight \<Gamma> x \<le> weight \<Gamma>' x \<rbrakk>
	\<Longrightarrow> current \<Gamma>' f"
	by(auto 4 3 elim!: current.cases intro!: current.intros intro: order_trans)

	abbreviation (input) zero_current :: "'v current"
	where "zero_current \<equiv> \<lambda>_. 0"

	lemma SINK_0 [simp]: "SINK zero_current = UNIV"
	by(auto simp add: SINK.simps)

	lemma current_0 [simp]: "current \<Gamma> zero_current"
	by(auto simp add: current.simps)

	inductive web_flow :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> bool"
	for \<Gamma> (structure) and f
	where
	web_flow: "\<lbrakk> current \<Gamma> f; \<And>x. \<lbrakk> x \<in> \<^bold>V; x \<notin> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> KIR f x \<rbrakk> \<Longrightarrow> web_flow \<Gamma> f"

	lemma web_flowD_current: "web_flow \<Gamma> f \<Longrightarrow> current \<Gamma> f"
	by(erule web_flow.cases)

	lemma web_flowD_KIR: "\<lbrakk> web_flow \<Gamma> f; x \<notin> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> KIR f x"
	apply(cases "x \<in> \<^bold>V\<^bsub>\<Gamma>\<^esub>")
	apply(fastforce elim!: web_flow.cases)
	apply(auto simp add: vertex_def d_OUT_def d_IN_def elim!: web_flow.cases)
	apply(subst (1 2) currentD_outside[of _ f]; auto)
	done

	subsection \<open>Saturated and terminal vertices\<close>

	inductive_set SAT :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v set"
	for \<Gamma> f
	where
	A: "x \<in> A \<Gamma> \<Longrightarrow> x \<in> SAT \<Gamma> f"
	\| IN: "d_IN f x \<ge> weight \<Gamma> x \<Longrightarrow> x \<in> SAT \<Gamma> f"
	\<comment> \<open>We use @{text "\<ge> weight"} such that @{text SAT} is monotone w.r.t. increasing currents\<close>

	lemma SAT_0 [simp]: "SAT \<Gamma> zero_current = A \<Gamma> \<union> {x. weight \<Gamma> x \<le> 0}"
	by(auto simp add: SAT.simps)

	lemma SAT_mono:
	assumes "\<And>e. f e \<le> g e"
	shows "SAT \<Gamma> f \<subseteq> SAT \<Gamma> g"
	proof
	fix x
	assume "x \<in> SAT \<Gamma> f"
	thus "x \<in> SAT \<Gamma> g"
	proof cases
	case IN
	also have "d_IN f x \<le> d_IN g x" using assms by(rule d_IN_mono)
	finally show ?thesis ..
	qed(rule SAT.A)
	qed

	lemma SAT_Sup_upper: "f \<in> Y \<Longrightarrow> SAT \<Gamma> f \<subseteq> SAT \<Gamma> (Sup Y)"
	by(rule SAT_mono)(rule Sup_upper[THEN le_funD])

	lemma currentD_SAT:
	assumes "current \<Gamma> f"
	shows "x \<in> SAT \<Gamma> f \<longleftrightarrow> x \<in> A \<Gamma> \<or> d_IN f x = weight \<Gamma> x"
	using currentD_weight_IN[OF assms, of x] by(auto simp add: SAT.simps)

	abbreviation terminal :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v set" ("TER\<index>")
	where "terminal \<Gamma> f \<equiv> SAT \<Gamma> f \<inter> SINK f"

	subsection \<open>Separation\<close>

	inductive separating_gen :: "('v, 'more) graph_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set \<Rightarrow> 'v set \<Rightarrow> bool"
	for G A B S
	where separating:
	"(\<And>x y p. \<lbrakk> x \<in> A; y \<in> B; path G x p y \<rbrakk> \<Longrightarrow> (\<exists>z \<in> set p. z \<in> S) \<or> x \<in> S)
	\<Longrightarrow> separating_gen G A B S"

	abbreviation separating :: "('v, 'more) web_scheme \<Rightarrow> 'v set \<Rightarrow> bool"
	where "separating \<Gamma> \<equiv> separating_gen \<Gamma> (A \<Gamma>) (B \<Gamma>)"

	abbreviation separating_network :: "('v, 'more) network_scheme \<Rightarrow> 'v set \<Rightarrow> bool"
	where "separating_network \<Delta> \<equiv> separating_gen \<Delta> {source \<Delta>} {sink \<Delta>}"

	lemma separating_networkI [intro?]:
	"(\<And>p. path \<Delta> (source \<Delta>) p (sink \<Delta>) \<Longrightarrow> (\<exists>z \<in> set p. z \<in> S) \<or> source \<Delta> \<in> S)
	\<Longrightarrow> separating_network \<Delta> S"
	by(auto intro: separating)

	lemma separatingD:
	"\<And>A B. \<lbrakk> separating_gen G A B S; path G x p y; x \<in> A; y \<in> B \<rbrakk> \<Longrightarrow> (\<exists>z \<in> set p. z \<in> S) \<or> x \<in> S"
	by(blast elim: separating_gen.cases)

	lemma separating_left [simp]: "\<And>A B. A \<subseteq> A' \<Longrightarrow> separating_gen \<Gamma> A B A'"
	by(auto simp add: separating_gen.simps)

	lemma separating_weakening:
	"\<And>A B. \<lbrakk> separating_gen G A B S; S \<subseteq> S' \<rbrakk> \<Longrightarrow> separating_gen G A B S'"
	by(rule separating; drule (3) separatingD; blast)

	definition essential :: "('v, 'more) graph_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set \<Rightarrow> 'v \<Rightarrow> bool"
	where \<comment> \<open>Should we allow only simple paths here?\<close>
	"\<And>B. essential G B S x \<longleftrightarrow> (\<exists>p. \<exists>y\<in>B. path G x p y \<and> (x \<noteq> y \<longrightarrow> (\<forall>z\<in>set p. z = x \<or> z \<notin> S)))"

	abbreviation essential_web :: "('v, 'more) web_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set" ("\<E>\<index>")
	where "essential_web \<Gamma> S \<equiv> {x\<in>S. essential \<Gamma> (B \<Gamma>) S x}"

	lemma essential_weight_update [simp]:
	"essential (weight_update f G) = essential G"
	by(simp add: essential_def fun_eq_iff)

	lemma not_essentialD:
	"\<And>B. \<lbrakk> \<not> essential G B S x; path G x p y; y \<in> B \<rbrakk> \<Longrightarrow> x \<noteq> y \<and> (\<exists>z\<in>set p. z \<noteq> x \<and> z \<in> S)"
	by(simp add: essential_def)

	lemma essentialE [elim?, consumes 1, case_names essential, cases pred: essential]:
	"\<And>B. \<lbrakk> essential G B S x; \<And>p y. \<lbrakk> path G x p y; y \<in> B; \<And>z. \<lbrakk> x \<noteq> y; z \<in> set p \<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> S \<rbrakk> \<Longrightarrow> thesis \<rbrakk> \<Longrightarrow> thesis"
	by(auto simp add: essential_def)

	lemma essentialI [intro?]:
	"\<And>B. \<lbrakk> path G x p y; y \<in> B; \<And>z. \<lbrakk> x \<noteq> y; z \<in> set p \<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> S \<rbrakk> \<Longrightarrow> essential G B S x"
	by(auto simp add: essential_def)

	lemma essential_vertex: "\<And>B. \<lbrakk> essential G B S x; x \<notin> B \<rbrakk> \<Longrightarrow>vertex G x"
	by(auto elim!: essentialE simp add: vertex_def elim: rtrancl_path.cases)

	lemma essential_BI: "\<And>B. x \<in> B \<Longrightarrow> essential G B S x"
	by(auto simp add: essential_def intro: rtrancl_path.base)

	lemma \<E>_E [elim?, consumes 1, case_names \<E>, cases set: essential_web]:
	fixes \<Gamma> (structure)
	assumes "x \<in> \<E> S"
	obtains p y where "path \<Gamma> x p y" "y \<in> B \<Gamma>" "\<And>z. \<lbrakk> x \<noteq> y; z \<in> set p \<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> S"
	using assms by(auto elim: essentialE)

	lemma essential_mono: "\<And>B. \<lbrakk> essential G B S x; S' \<subseteq> S \<rbrakk> \<Longrightarrow> essential G B S' x"
	by(auto simp add: essential_def)

	lemma separating_essential: \<comment> \<open>Lem. 3.4 (cf. Lem. 2.14 in [5])\<close>
	fixes G A B S
	assumes "separating_gen G A B S"
	shows "separating_gen G A B {x\<in>S. essential G B S x}" (is "separating_gen _ _ _ ?E")
	proof
	fix x y p
	assume x: "x \<in> A" and y: "y \<in> B" and p: "path G x p y"
	from separatingD[OF assms p x y] have "\<exists>z \<in> set (x # p). z \<in> S" by auto
	from split_list_last_prop[OF this] obtain ys z zs where decomp: "x # p = ys @ z # zs"
	and z: "z \<in> S" and last: "\<And>z. z \<in> set zs \<Longrightarrow> z \<notin> S" by auto
	from decomp consider (empty) "ys = []" "x = z" "p = zs"
	\| (Cons) ys' where "ys = x # ys'" "p = ys' @ z # zs"
	by(auto simp add: Cons_eq_append_conv)
	then show "(\<exists>z\<in>set p. z \<in> ?E) \<or> x \<in> ?E"
	proof(cases)
	case empty
	hence "x \<in> ?E" using z p last y by(auto simp add: essential_def)
	thus ?thesis ..
	next
	case (Cons ys')
	from p have "path G z zs y" unfolding Cons by(rule rtrancl_path_appendE)
	hence "z \<in> ?E" using z y last by(auto simp add: essential_def)
	thus ?thesis using Cons by auto
	qed
	qed

	definition roofed_gen :: "('v, 'more) graph_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set \<Rightarrow> 'v set"
	where roofed_def: "\<And>B. roofed_gen G B S = {x. \<forall>p. \<forall>y\<in>B. path G x p y \<longrightarrow> (\<exists>z\<in>set p. z \<in> S) \<or> x \<in> S}"

	abbreviation roofed :: "('v, 'more) web_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set" ("RF\<index>")
	where "roofed \<Gamma> \<equiv> roofed_gen \<Gamma> (B \<Gamma>)"

	abbreviation roofed_network :: "('v, 'more) network_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set" ("RF\<^sup>N\<index>")
	where "roofed_network \<Delta> \<equiv> roofed_gen \<Delta> {sink \<Delta>}"

	lemma roofedI [intro?]:
	"\<And>B. (\<And>p y. \<lbrakk> path G x p y; y \<in> B \<rbrakk> \<Longrightarrow> (\<exists>z\<in>set p. z \<in> S) \<or> x \<in> S) \<Longrightarrow> x \<in> roofed_gen G B S"
	by(auto simp add: roofed_def)

	lemma not_roofedE: fixes B
	assumes "x \<notin> roofed_gen G B S"
	obtains p y where "path G x p y" "y \<in> B" "\<And>z. z \<in> set (x # p) \<Longrightarrow> z \<notin> S"
	using assms by(auto simp add: roofed_def)

	lemma roofed_greater: "\<And>B. S \<subseteq> roofed_gen G B S"
	by(auto simp add: roofed_def)

	lemma roofed_greaterI: "\<And>B. x \<in> S \<Longrightarrow> x \<in> roofed_gen G B S"
	using roofed_greater[of S G] by blast

	lemma roofed_mono: "\<And>B. S \<subseteq> S' \<Longrightarrow> roofed_gen G B S \<subseteq> roofed_gen G B S'"
	by(fastforce simp add: roofed_def)

	lemma in_roofed_mono: "\<And>B. \<lbrakk> x \<in> roofed_gen G B S; S \<subseteq> S' \<rbrakk> \<Longrightarrow> x \<in> roofed_gen G B S'"
	using roofed_mono[THEN subsetD] .

	lemma roofedD: "\<And>B. \<lbrakk> x \<in> roofed_gen G B S; path G x p y; y \<in> B \<rbrakk> \<Longrightarrow> (\<exists>z\<in>set p. z \<in> S) \<or> x \<in> S"
	unfolding roofed_def by blast

	lemma separating_RF_A:
	fixes A B
	assumes "separating_gen G A B X"
	shows "A \<subseteq> roofed_gen G B X"
	by(rule subsetI roofedI)+(erule separatingD[OF assms])

	lemma roofed_idem: fixes B shows "roofed_gen G B (roofed_gen G B S) = roofed_gen G B S"
	proof(rule equalityI subsetI roofedI)+
	fix x p y
	assume x: "x \<in> roofed_gen G B (roofed_gen G B S)" and p: "path G x p y" and y: "y \<in> B"
	from roofedD[OF x p y] obtain z where *: "z \<in> set (x # p)" and z: "z \<in> roofed_gen G B S" by auto
	from split_list[OF *] obtain ys zs where split: "x # p = ys @ z # zs" by blast
	with p have p': "path G z zs y" by(auto simp add: Cons_eq_append_conv elim: rtrancl_path_appendE)
	from roofedD[OF z p' y] split show "(\<exists>z\<in>set p. z \<in> S) \<or> x \<in> S"
	by(auto simp add: Cons_eq_append_conv)
	qed(rule roofed_mono roofed_greater)+

	lemma in_roofed_mono': "\<And>B. \<lbrakk> x \<in> roofed_gen G B S; S \<subseteq> roofed_gen G B S' \<rbrakk> \<Longrightarrow> x \<in> roofed_gen G B S'"
	by(subst roofed_idem[symmetric])(erule in_roofed_mono)

	lemma roofed_mono': "\<And>B. S \<subseteq> roofed_gen G B S' \<Longrightarrow> roofed_gen G B S \<subseteq> roofed_gen G B S'"
	by(rule subsetI)(rule in_roofed_mono')

	lemma roofed_idem_Un1: fixes B shows "roofed_gen G B (roofed_gen G B S \<union> T) = roofed_gen G B (S \<union> T)"
	proof -
	have "S \<subseteq> T \<union> roofed_gen G B S"
	by (metis (no_types) UnCI roofed_greater subsetCE subsetI)
	then have "S \<union> T \<subseteq> T \<union> roofed_gen G B S \<and> T \<union> roofed_gen G B S \<subseteq> roofed_gen G B (S \<union> T)"
	by (metis (no_types) Un_subset_iff Un_upper2 roofed_greater roofed_mono sup.commute)
	then show ?thesis
	by (metis (no_types) roofed_idem roofed_mono subset_antisym sup.commute)
	qed

	lemma roofed_UN: fixes A B
	shows "roofed_gen G B (\<Union>i\<in>A. roofed_gen G B (X i)) = roofed_gen G B (\<Union>i\<in>A. X i)" (is "?lhs = ?rhs")
	proof(rule equalityI)
	show "?rhs \<subseteq> ?lhs" by(rule roofed_mono)(blast intro: roofed_greaterI)
	show "?lhs \<subseteq> ?rhs" by(rule roofed_mono')(blast intro: in_roofed_mono)
	qed

	lemma RF_essential: fixes \<Gamma> (structure) shows "RF (\<E> S) = RF S"
	proof(intro set_eqI iffI)
	fix x
	assume RF: "x \<in> RF S"
	show "x \<in> RF (\<E> S)"
	proof
	fix p y
	assume p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	from roofedD[OF RF this] have "\<exists>z\<in>set (x # p). z \<in> S" by auto
	from split_list_last_prop[OF this] obtain ys z zs where decomp: "x # p = ys @ z # zs"
	and z: "z \<in> S" and last: "\<And>z. z \<in> set zs \<Longrightarrow> z \<notin> S" by auto
	from decomp consider (empty) "ys = []" "x = z" "p = zs"
	\| (Cons) ys' where "ys = x # ys'" "p = ys' @ z # zs"
	by(auto simp add: Cons_eq_append_conv)
	then show "(\<exists>z\<in>set p. z \<in> \<E> S) \<or> x \<in> \<E> S"
	proof(cases)
	case empty
	hence "x \<in> \<E> S" using z p last y by(auto simp add: essential_def)
	thus ?thesis ..
	next
	case (Cons ys')
	from p have "path \<Gamma> z zs y" unfolding Cons by(rule rtrancl_path_appendE)
	hence "z \<in> \<E> S" using z y last by(auto simp add: essential_def)
	thus ?thesis using Cons by auto
	qed
	qed
	qed(blast intro: in_roofed_mono)

	lemma essentialE_RF:
	fixes \<Gamma> (structure) and B
	assumes "essential \<Gamma> B S x"
	obtains p y where "path \<Gamma> x p y" "y \<in> B" "distinct (x # p)" "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> roofed_gen \<Gamma> B S"
	proof -
	from assms obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B"
	and bypass: "\<And>z. \<lbrakk> x \<noteq> y; z \<in> set p \<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> S" by(rule essentialE) blast
	from p obtain p' where p': "path \<Gamma> x p' y" and distinct: "distinct (x # p')"
	and subset: "set p' \<subseteq> set p" by(rule rtrancl_path_distinct)
	{ fix z
	assume z: "z \<in> set p'"
	hence "y \<in> set p'" using rtrancl_path_last[OF p', symmetric] p'
	by(auto elim: rtrancl_path.cases intro: last_in_set)
	with distinct z subset have neq: "x \<noteq> y" and "z \<in> set p" by(auto)
	from bypass[OF this] z distinct have "z \<notin> S" by auto

	have "z \<notin> roofed_gen \<Gamma> B S"
	proof
	assume z': "z \<in> roofed_gen \<Gamma> B S"
	from split_list[OF z] obtain ys zs where decomp: "p' = ys @ z # zs" by blast
	with p' have "path \<Gamma> z zs y" by(auto elim: rtrancl_path_appendE)
	from roofedD[OF z' this y] \<open>z \<notin> S\<close> obtain z' where "z' \<in> set zs" "z' \<in> S" by auto
	with bypass[of z'] neq decomp subset distinct show False by auto
	qed }
	with p' y distinct show thesis ..
	qed

	lemma \<E>_E_RF:
	fixes \<Gamma> (structure)
	assumes "x \<in> \<E> S"
	obtains p y where "path \<Gamma> x p y" "y \<in> B \<Gamma>" "distinct (x # p)" "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF S"
	using assms by(auto elim: essentialE_RF)

	lemma in_roofed_essentialD:
	fixes \<Gamma> (structure)
	assumes RF: "x \<in> RF S"
	and ess: "essential \<Gamma> (B \<Gamma>) S x"
	shows "x \<in> S"
	proof -
	from ess obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and "distinct (x # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> S" by(rule essentialE_RF)(auto intro: roofed_greaterI)
	from roofedD[OF RF p y] bypass show "x \<in> S" by auto
	qed

	lemma separating_RF: fixes \<Gamma> (structure) shows "separating \<Gamma> (RF S) \<longleftrightarrow> separating \<Gamma> S"
	proof
	assume sep: "separating \<Gamma> (RF S)"
	show "separating \<Gamma> S"
	proof
	fix x y p
	assume p: "path \<Gamma> x p y" and x: "x \<in> A \<Gamma>" and y: "y \<in> B \<Gamma>"
	from separatingD[OF sep p x y] have "\<exists>z \<in> set (x # p). z \<in> RF S" by auto
	from split_list_last_prop[OF this] obtain ys z zs where split: "x # p = ys @ z # zs"
	and z: "z \<in> RF S" and bypass: "\<And>z'. z' \<in> set zs \<Longrightarrow> z' \<notin> RF S" by auto
	from p split have "path \<Gamma> z zs y" by(cases ys)(auto elim: rtrancl_path_appendE)
	hence "essential \<Gamma> (B \<Gamma>) S z" using y
	by(rule essentialI)(auto dest: bypass intro: roofed_greaterI)
	with z have "z \<in> S" by(rule in_roofed_essentialD)
	with split show "(\<exists>z\<in>set p. z \<in> S) \<or> x \<in> S" by(cases ys)auto
	qed
	qed(blast intro: roofed_greaterI separating_weakening)

	definition roofed_circ :: "('v, 'more) web_scheme \<Rightarrow> 'v set \<Rightarrow> 'v set" ("RF\<^sup>\<circ>\<index>")
	where "roofed_circ \<Gamma> S = roofed \<Gamma> S - \<E>\<^bsub>\<Gamma>\<^esub> S"

	lemma roofed_circI: fixes \<Gamma> (structure) shows
	"\<lbrakk> x \<in> RF T; x \<in> T \<Longrightarrow> \<not> essential \<Gamma> (B \<Gamma>) T x \<rbrakk> \<Longrightarrow> x \<in> RF\<^sup>\<circ> T"
	by(simp add: roofed_circ_def)

	lemma roofed_circE:
	fixes \<Gamma> (structure)
	assumes "x \<in> RF\<^sup>\<circ> T"
	obtains "x \<in> RF T" "\<not> essential \<Gamma> (B \<Gamma>) T x"
	using assms by(auto simp add: roofed_circ_def intro: in_roofed_essentialD)

	lemma \<E>_\<E>: fixes \<Gamma> (structure) shows "\<E> (\<E> S) = \<E> S"
	by(auto intro: essential_mono)

	lemma roofed_circ_essential: fixes \<Gamma> (structure) shows "RF\<^sup>\<circ> (\<E> S) = RF\<^sup>\<circ> S"
	unfolding roofed_circ_def RF_essential \<E>_\<E> ..

	lemma essential_RF: fixes B
	shows "essential G B (roofed_gen G B S) = essential G B S" (is "essential _ _ ?RF = _")
	proof(intro ext iffI)
	show "essential G B S x" if "essential G B ?RF x" for x using that
	by(rule essential_mono)(blast intro: roofed_greaterI)
	show "essential G B ?RF x" if "essential G B S x" for x
	using that by(rule essentialE_RF)(erule (1) essentialI, blast)
	qed

	lemma \<E>_RF: fixes \<Gamma> (structure) shows "\<E> (RF S) = \<E> S"
	by(auto dest: in_roofed_essentialD simp add: essential_RF intro: roofed_greaterI)

	lemma essential_\<E>: fixes \<Gamma> (structure) shows "essential \<Gamma> (B \<Gamma>) (\<E> S) = essential \<Gamma> (B \<Gamma>) S"
	by(subst essential_RF[symmetric])(simp only: RF_essential essential_RF)

	lemma RF_in_B: fixes \<Gamma> (structure) shows "x \<in> B \<Gamma> \<Longrightarrow> x \<in> RF S \<longleftrightarrow> x \<in> S"
	by(auto intro: roofed_greaterI dest: roofedD[OF _ rtrancl_path.base])

	lemma RF_circ_edge_forward:
	fixes \<Gamma> (structure)
	assumes x: "x \<in> RF\<^sup>\<circ> S"
	and edge: "edge \<Gamma> x y"
	shows "y \<in> RF S"
	proof
	fix p z
	assume p: "path \<Gamma> y p z" and z: "z \<in> B \<Gamma>"
	from x have rf: "x \<in> RF S" and ness: "x \<notin> \<E> S" by(auto elim: roofed_circE)
	show "(\<exists>z\<in>set p. z \<in> S) \<or> y \<in> S"
	proof(cases "\<exists>z'\<in>set (y # p). z' \<in> S")
	case False
	from edge p have p': "path \<Gamma> x (y # p) z" ..
	from roofedD[OF rf this z] False have "x \<in> S" by auto
	moreover have "essential \<Gamma> (B \<Gamma>) S x" using p' False z by(auto intro!: essentialI)
	ultimately have "x \<in> \<E> S" by simp
	with ness show ?thesis by contradiction
	qed auto
	qed

	subsection \<open>Waves\<close>

	inductive wave :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> bool"
	for \<Gamma> (structure) and f
	where
	wave:
	"\<lbrakk> separating \<Gamma> (TER f);
	\<And>x. x \<notin> RF (TER f) \<Longrightarrow> d_OUT f x = 0 \<rbrakk>
	\<Longrightarrow> wave \<Gamma> f"

	lemma wave_0 [simp]: "wave \<Gamma> zero_current"
	by rule simp_all

	lemma waveD_separating: "wave \<Gamma> f \<Longrightarrow> separating \<Gamma> (TER\<^bsub>\<Gamma>\<^esub> f)"
	by(simp add: wave.simps)

	lemma waveD_OUT: "\<lbrakk> wave \<Gamma> f; x \<notin> RF\<^bsub>\<Gamma>\<^esub> (TER\<^bsub>\<Gamma>\<^esub> f) \<rbrakk> \<Longrightarrow> d_OUT f x = 0"
	by(simp add: wave.simps)

	lemma wave_A_in_RF: fixes \<Gamma> (structure)
	shows "\<lbrakk> wave \<Gamma> f; x \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> x \<in> RF (TER f)"
	by(auto intro!: roofedI dest!: waveD_separating separatingD)

	lemma wave_not_RF_IN_zero:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and x: "x \<notin> RF (TER f)"
	shows "d_IN f x = 0"
	proof -
	from x obtain p z where z: "z \<in> B \<Gamma>" and p: "path \<Gamma> x p z"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER f" "x \<notin> TER f"
	by(clarsimp simp add: roofed_def)
	have "f (y, x) = 0" for y
	proof(cases "edge \<Gamma> y x")
	case edge: True
	have "d_OUT f y = 0"
	proof(cases "y \<in> TER f")
	case False
	with z p bypass edge have "y \<notin> RF (TER f)"
	by(auto simp add: roofed_def intro: rtrancl_path.step intro!: exI rev_bexI)
	thus "d_OUT f y = 0" by(rule waveD_OUT[OF w])
	qed(auto simp add: SINK.simps)
	moreover have "f (y, x) \<le> d_OUT f y" by (rule d_OUT_ge_point)
	ultimately show ?thesis by simp
	qed(simp add: currentD_outside[OF f])
	then show "d_IN f x = 0" unfolding d_IN_def
	by(simp add: nn_integral_0_iff emeasure_count_space_eq_0)
	qed

	lemma current_Sup:
	fixes \<Gamma> (structure)
	assumes chain: "Complete_Partial_Order.chain (\<le>) Y"
	and Y: "Y \<noteq> {}"
	and current: "\<And>f. f \<in> Y \<Longrightarrow> current \<Gamma> f"
	and countable [simp]: "countable (support_flow (Sup Y))"
	shows "current \<Gamma> (Sup Y)"
	proof(rule, goal_cases)
	case (1 x)
	have "d_OUT (Sup Y) x = (SUP f\<in>Y. d_OUT f x)" using chain Y by(simp add: d_OUT_Sup)
	also have "\<dots> \<le> weight \<Gamma> x" using 1
	by(intro SUP_least)(auto dest!: current currentD_weight_OUT)
	finally show ?case .
	next
	case (2 x)
	have "d_IN (Sup Y) x = (SUP f\<in>Y. d_IN f x)" using chain Y by(simp add: d_IN_Sup)
	also have "\<dots> \<le> weight \<Gamma> x" using 2
	by(intro SUP_least)(auto dest!: current currentD_weight_IN)
	finally show ?case .
	next
	case (3 x)
	have "d_OUT (Sup Y) x = (SUP f\<in>Y. d_OUT f x)" using chain Y by(simp add: d_OUT_Sup)
	also have "\<dots> \<le> (SUP f\<in>Y. d_IN f x)" using 3
	by(intro SUP_mono)(auto dest: current currentD_OUT_IN)
	also have "\<dots> = d_IN (Sup Y) x" using chain Y by(simp add: d_IN_Sup)
	finally show ?case .
	next
	case (4 a)
	have "d_IN (Sup Y) a = (SUP f\<in>Y. d_IN f a)" using chain Y by(simp add: d_IN_Sup)
	also have "\<dots> = (SUP f\<in>Y. 0)" using 4 by(intro SUP_cong)(auto dest!: current currentD_IN)
	also have "\<dots> = 0" using Y by simp
	finally show ?case .
	next
	case (5 b)
	have "d_OUT (Sup Y) b = (SUP f\<in>Y. d_OUT f b)" using chain Y by(simp add: d_OUT_Sup)
	also have "\<dots> = (SUP f\<in>Y. 0)" using 5 by(intro SUP_cong)(auto dest!: current currentD_OUT)
	also have "\<dots> = 0" using Y by simp
	finally show ?case .
	next
	fix e
	assume "e \<notin> \<^bold>E"
	from currentD_outside'[OF current this] have "f e = 0" if "f \<in> Y" for f using that by simp
	hence "Sup Y e = (SUP _\<in>Y. 0)" by(auto intro: SUP_cong)
	then show "Sup Y e = 0" using Y by(simp)
	qed

	lemma wave_lub: \<comment> \<open>Lemma 4.3\<close>
	fixes \<Gamma> (structure)
	assumes chain: "Complete_Partial_Order.chain (\<le>) Y"
	and Y: "Y \<noteq> {}"
	and wave: "\<And>f. f \<in> Y \<Longrightarrow> wave \<Gamma> f"
	and countable [simp]: "countable (support_flow (Sup Y))"
	shows "wave \<Gamma> (Sup Y)"
	proof
	{ fix x y p
	assume p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	define P where "P = {x} \<union> set p"

	let ?f = "\<lambda>f. SINK f \<inter> P"
	have "Complete_Partial_Order.chain (\<supseteq>) (?f ` Y)" using chain
	by(rule chain_imageI)(auto dest: SINK_mono')
	moreover have "\<dots> \<subseteq> Pow P" by auto
	hence "finite (?f ` Y)" by(rule finite_subset)(simp add: P_def)
	ultimately have "(\<Inter>(?f ` Y)) \<in> ?f ` Y"
	by(rule ccpo.in_chain_finite[OF complete_lattice_ccpo_dual])(simp add: Y)
	then obtain f where f: "f \<in> Y" and eq: "\<Inter>(?f ` Y) = ?f f" by clarify
	hence *: "(\<Inter>f\<in>Y. SINK f) \<inter> P = SINK f \<inter> P" by(clarsimp simp add: prod_lub_def Y)+
	{ fix g
	assume "g \<in> Y" "f \<le> g"
	with * have "(\<Inter>f\<in>Y. SINK f) \<inter> P = SINK g \<inter> P" by(blast dest: SINK_mono')
	then have "TER (Sup Y) \<inter> P \<supseteq> TER g \<inter> P"
	using SAT_Sup_upper[OF \<open>g \<in> Y\<close>, of \<Gamma>] SINK_Sup[OF chain Y countable] by blast }
	with f have "\<exists>f\<in>Y. \<forall>g\<in>Y. g \<ge> f \<longrightarrow> TER g \<inter> P \<subseteq> TER (Sup Y) \<inter> P" by blast }
	note subset = this

	show "separating \<Gamma> (TER (Sup Y))"
	proof
	fix x y p
	assume *: "path \<Gamma> x p y" "y \<in> B \<Gamma>" and "x \<in> A \<Gamma>"
	let ?P = "{x} \<union> set p"
	from subset[OF *] obtain f where f:"f \<in> Y"
	and subset: "TER f \<inter> ?P \<subseteq> TER (Sup Y) \<inter> ?P" by blast
	from wave[OF f] have "TER f \<inter> ?P \<noteq> {}" using * \<open>x \<in> A \<Gamma>\<close>
	by(auto simp add: wave.simps dest: separatingD)
	with subset show " (\<exists>z\<in>set p. z \<in> TER (Sup Y)) \<or> x \<in> TER (Sup Y)" by blast
	qed

	fix x
	assume "x \<notin> RF (TER (Sup Y))"
	then obtain p y where y: "y \<in> B \<Gamma>"
	and p: "path \<Gamma> x p y"
	and ter: "TER (Sup Y) \<inter> ({x} \<union> set p) = {}" by(auto simp add: roofed_def)
	let ?P = "{x} \<union> set p"
	from subset[OF p y] obtain f where f: "f \<in> Y"
	and subset: "\<And>g. \<lbrakk> g \<in> Y; f \<le> g \<rbrakk> \<Longrightarrow> TER g \<inter> ?P \<subseteq> TER (Sup Y) \<inter> ?P" by blast

	{ fix g
	assume g: "g \<in> Y"
	with chain f have "f \<le> g \<or> g \<le> f" by(rule chainD)
	hence "d_OUT g x = 0"
	proof
	assume "f \<le> g"
	from subset[OF g this] ter have "TER g \<inter> ?P = {}" by blast
	with p y have "x \<notin> RF (TER g)" by(auto simp add: roofed_def)
	with wave[OF g] show ?thesis by(blast elim: wave.cases)
	next
	assume "g \<le> f"
	from subset ter f have "TER f \<inter> ?P = {}" by blast
	with y p have "x \<notin> RF (TER f)" by(auto simp add: roofed_def)
	with wave[OF f] have "d_OUT f x = 0" by(blast elim: wave.cases)
	moreover have "d_OUT g x \<le> d_OUT f x" using \<open>g \<le> f\<close>[THEN le_funD] by(rule d_OUT_mono)
	ultimately show ?thesis by simp
	qed }
	thus "d_OUT (Sup Y) x = 0" using chain Y by(simp add: d_OUT_Sup)
	qed

	lemma ex_maximal_wave: \<comment> \<open>Corollary 4.4\<close>
	fixes \<Gamma> (structure)
	assumes countable: "countable \<^bold>E"
	shows "\<exists>f. current \<Gamma> f \<and> wave \<Gamma> f \<and> (\<forall>w. current \<Gamma> w \<and> wave \<Gamma> w \<and> f \<le> w \<longrightarrow> f = w)"
	proof -
	define Field_r where "Field_r = {f. current \<Gamma> f \<and> wave \<Gamma> f}"
	define r where "r = {(f, g). f \<in> Field_r \<and> g \<in> Field_r \<and> f \<le> g}"
	have Field_r: "Field r = Field_r" by(auto simp add: Field_def r_def)

	have "Partial_order r" unfolding order_on_defs
	by(auto intro!: refl_onI transI antisymI simp add: Field_r r_def Field_def)
	hence "\<exists>m\<in>Field r. \<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
	proof(rule Zorns_po_lemma)
	fix Y
	assume "Y \<in> Chains r"
	hence Y: "Complete_Partial_Order.chain (\<le>) Y"
	and w: "\<And>f. f \<in> Y \<Longrightarrow> wave \<Gamma> f"
	and f: "\<And>f. f \<in> Y \<Longrightarrow> current \<Gamma> f"
	by(auto simp add: Chains_def r_def chain_def Field_r_def)
	show "\<exists>w \<in> Field r. \<forall>f \<in> Y. (f, w) \<in> r"
	proof(cases "Y = {}")
	case True
	have "zero_current \<in> Field r" by(simp add: Field_r Field_r_def)
	with True show ?thesis by blast
	next
	case False
	have "support_flow (Sup Y) \<subseteq> \<^bold>E" by(auto simp add: support_flow_Sup elim!: support_flow.cases dest!: f dest: currentD_outside)
	hence c: "countable (support_flow (Sup Y))" using countable by(rule countable_subset)
	with Y False f w have "Sup Y \<in> Field r" unfolding Field_r Field_r_def
	by(blast intro: wave_lub current_Sup)
	moreover then have "(f, Sup Y) \<in> r" if "f \<in> Y" for f using w[OF that] f[OF that] that unfolding Field_r
	by(auto simp add: r_def Field_r_def intro: Sup_upper)
	ultimately show ?thesis by blast
	qed
	qed
	thus ?thesis by(simp add: Field_r Field_r_def)(auto simp add: r_def Field_r_def)
	qed

	lemma essential_leI:
	fixes \<Gamma> (structure)
	assumes g: "current \<Gamma> g" and w: "wave \<Gamma> g"
	and le: "\<And>e. f e \<le> g e"
	and x: "x \<in> \<E> (TER g)"
	shows "essential \<Gamma> (B \<Gamma>) (TER f) x"
	proof -
	from x obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and distinct: "distinct (x # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER g)" by(rule \<E>_E_RF) blast
	show ?thesis using p y
	proof
	fix z
	assume "z \<in> set p"
	hence z: "z \<notin> RF (TER g)" by(auto dest: bypass)
	with w have OUT: "d_OUT g z = 0" and IN: "d_IN g z = 0" by(rule waveD_OUT wave_not_RF_IN_zero[OF g])+
	with z have "z \<notin> A \<Gamma>" "weight \<Gamma> z > 0" by(auto intro!: roofed_greaterI simp add: SAT.simps SINK.simps)
	moreover from IN d_IN_mono[of f z g, OF le] have "d_IN f z \<le> 0" by(simp)
	ultimately have "z \<notin> TER f" by(auto simp add: SAT.simps)
	then show "z = x \<or> z \<notin> TER f" by simp
	qed
	qed

	lemma essential_eq_leI:
	fixes \<Gamma> (structure)
	assumes g: "current \<Gamma> g" and w: "wave \<Gamma> g"
	and le: "\<And>e. f e \<le> g e"
	and subset: "\<E> (TER g) \<subseteq> TER f"
	shows "\<E> (TER f) = \<E> (TER g)"
	proof
	show subset: "\<E> (TER g) \<subseteq> \<E> (TER f)"
	proof
	fix x
	assume x: "x \<in> \<E> (TER g)"
	hence "x \<in> TER f" using subset by blast
	moreover have "essential \<Gamma> (B \<Gamma>) (TER f) x" using g w le x by(rule essential_leI)
	ultimately show "x \<in> \<E> (TER f)" by simp
	qed

	show "\<dots> \<subseteq> \<E> (TER g)"
	proof
	fix x
	assume x: "x \<in> \<E> (TER f)"
	hence "x \<in> TER f" by auto
	hence "x \<in> RF (TER g)"
	proof(rule contrapos_pp)
	assume x: "x \<notin> RF (TER g)"
	with w have OUT: "d_OUT g x = 0" and IN: "d_IN g x = 0" by(rule waveD_OUT wave_not_RF_IN_zero[OF g])+
	with x have "x \<notin> A \<Gamma>" "weight \<Gamma> x > 0" by(auto intro!: roofed_greaterI simp add: SAT.simps SINK.simps)
	moreover from IN d_IN_mono[of f x g, OF le] have "d_IN f x \<le> 0" by(simp)
	ultimately show "x \<notin> TER f" by(auto simp add: SAT.simps)
	qed
	moreover have "x \<notin> RF\<^sup>\<circ> (TER g)"
	proof
	assume "x \<in> RF\<^sup>\<circ> (TER g)"
	hence RF: "x \<in> RF (\<E> (TER g))" and not_E: "x \<notin> \<E> (TER g)"
	unfolding RF_essential by(simp_all add: roofed_circ_def)
	from x obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and distinct: "distinct (x # p)"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)" by(rule \<E>_E_RF) blast
	from roofedD[OF RF p y] not_E obtain z where "z \<in> set p" "z \<in> \<E> (TER g)" by blast
	with subset bypass[of z] show False by(auto intro: roofed_greaterI)
	qed
	ultimately show "x \<in> \<E> (TER g)" by(simp add: roofed_circ_def)
	qed
	qed

	subsection \<open>Hindrances and looseness\<close>

	inductive hindrance_by :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> ennreal \<Rightarrow> bool"
	for \<Gamma> (structure) and f and \<epsilon>
	where
	hindrance_by:
	"\<lbrakk> a \<in> A \<Gamma>; a \<notin> \<E> (TER f); d_OUT f a < weight \<Gamma> a; \<epsilon> < weight \<Gamma> a - d_OUT f a \<rbrakk> \<Longrightarrow> hindrance_by \<Gamma> f \<epsilon>"

	inductive hindrance :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> bool"
	for \<Gamma> (structure) and f
	where
	hindrance:
	"\<lbrakk> a \<in> A \<Gamma>; a \<notin> \<E> (TER f); d_OUT f a < weight \<Gamma> a \<rbrakk> \<Longrightarrow> hindrance \<Gamma> f"

	inductive hindered :: "('v, 'more) web_scheme \<Rightarrow> bool"
	for \<Gamma> (structure)
	where hindered: "\<lbrakk> hindrance \<Gamma> f; current \<Gamma> f; wave \<Gamma> f \<rbrakk> \<Longrightarrow> hindered \<Gamma>"

	inductive hindered_by :: "('v, 'more) web_scheme \<Rightarrow> ennreal \<Rightarrow> bool"
	for \<Gamma> (structure) and \<epsilon>
	where hindered_by: "\<lbrakk> hindrance_by \<Gamma> f \<epsilon>; current \<Gamma> f; wave \<Gamma> f \<rbrakk> \<Longrightarrow> hindered_by \<Gamma> \<epsilon>"

	lemma hindrance_into_hindrance_by:
	assumes "hindrance \<Gamma> f"
	shows "\<exists>\<epsilon>>0. hindrance_by \<Gamma> f \<epsilon>"
	using assms
	proof cases
	case (hindrance a)
	let ?\<epsilon> = "if weight \<Gamma> a = \<top> then 1 else (weight \<Gamma> a - d_OUT f a) / 2"
	from \<open>d_OUT f a < weight \<Gamma> a\<close> have "weight \<Gamma> a - d_OUT f a > 0" "weight \<Gamma> a \<noteq> \<top> \<Longrightarrow> weight \<Gamma> a - d_OUT f a < \<top>"
	by(simp_all add: diff_gr0_ennreal less_top diff_less_top_ennreal)
	from ennreal_mult_strict_left_mono[of 1 2, OF _ this]
	have "0 < ?\<epsilon>" and "?\<epsilon> < weight \<Gamma> a - d_OUT f a" using \<open>d_OUT f a < weight \<Gamma> a\<close>
	by(auto intro!: diff_gr0_ennreal simp: ennreal_zero_less_divide divide_less_ennreal)
	with hindrance show ?thesis by(auto intro!: hindrance_by.intros)
	qed

	lemma hindrance_by_into_hindrance: "hindrance_by \<Gamma> f \<epsilon> \<Longrightarrow> hindrance \<Gamma> f"
	by(blast elim: hindrance_by.cases intro: hindrance.intros)

	lemma hindrance_conv_hindrance_by: "hindrance \<Gamma> f \<longleftrightarrow> (\<exists>\<epsilon>>0. hindrance_by \<Gamma> f \<epsilon>)"
	by(blast intro: hindrance_into_hindrance_by hindrance_by_into_hindrance)

	lemma hindered_into_hindered_by: "hindered \<Gamma> \<Longrightarrow> \<exists>\<epsilon>>0. hindered_by \<Gamma> \<epsilon>"
	by(blast intro: hindered_by.intros elim: hindered.cases dest: hindrance_into_hindrance_by)

	lemma hindered_by_into_hindered: "hindered_by \<Gamma> \<epsilon> \<Longrightarrow> hindered \<Gamma>"
	by(blast elim: hindered_by.cases intro: hindered.intros dest: hindrance_by_into_hindrance)

	lemma hindered_conv_hindered_by: "hindered \<Gamma> \<longleftrightarrow> (\<exists>\<epsilon>>0. hindered_by \<Gamma> \<epsilon>)"
	by(blast intro: hindered_into_hindered_by hindered_by_into_hindered)

	inductive loose :: "('v, 'more) web_scheme \<Rightarrow> bool"
	for \<Gamma>
	where
	loose: "\<lbrakk> \<And>f. \<lbrakk> current \<Gamma> f; wave \<Gamma> f \<rbrakk> \<Longrightarrow> f = zero_current; \<not> hindrance \<Gamma> zero_current \<rbrakk>
	\<Longrightarrow> loose \<Gamma>"

	lemma looseD_hindrance: "loose \<Gamma> \<Longrightarrow> \<not> hindrance \<Gamma> zero_current"
	by(simp add: loose.simps)

	lemma looseD_wave:
	"\<lbrakk> loose \<Gamma>; current \<Gamma> f; wave \<Gamma> f \<rbrakk> \<Longrightarrow> f = zero_current"
	by(simp add: loose.simps)

	lemma loose_unhindered:
	fixes \<Gamma> (structure)
	assumes "loose \<Gamma>"
	shows "\<not> hindered \<Gamma>"
	apply auto
	apply(erule hindered.cases)
	apply(frule (1) looseD_wave[OF assms])
	apply simp
	using looseD_hindrance[OF assms]
	by simp

	context
	fixes \<Gamma> \<Gamma>' :: "('v, 'more) web_scheme"
	assumes [simp]: "edge \<Gamma> = edge \<Gamma>'" "A \<Gamma> = A \<Gamma>'" "B \<Gamma> = B \<Gamma>'"
	and weight_eq: "\<And>x. x \<notin> A \<Gamma>' \<Longrightarrow> weight \<Gamma> x = weight \<Gamma>' x"
	and weight_le: "\<And>a. a \<in> A \<Gamma>' \<Longrightarrow> weight \<Gamma> a \<ge> weight \<Gamma>' a"
	begin

	private lemma essential_eq: "essential \<Gamma> = essential \<Gamma>'"
	by(simp add: fun_eq_iff essential_def)

	qualified lemma TER_eq: "TER\<^bsub>\<Gamma>\<^esub> f = TER\<^bsub>\<Gamma>'\<^esub> f"
	apply(auto simp add: SINK.simps SAT.simps)
	apply(erule contrapos_np; drule weight_eq; simp)+
	done

	qualified lemma separating_eq: "separating_gen \<Gamma> = separating_gen \<Gamma>'"
	by(intro ext iffI; rule separating_gen.intros; drule separatingD; simp)

	qualified lemma roofed_eq: "\<And>B. roofed_gen \<Gamma> B S = roofed_gen \<Gamma>' B S"
	by(simp add: roofed_def)

	lemma wave_eq_web: \<comment> \<open>Observation 4.6\<close>
	"wave \<Gamma> f \<longleftrightarrow> wave \<Gamma>' f"
	by(simp add: wave.simps separating_eq TER_eq roofed_eq)

	lemma current_mono_web: "current \<Gamma>' f \<Longrightarrow> current \<Gamma> f"
	apply(rule current, simp_all add: currentD_OUT_IN currentD_IN currentD_OUT currentD_outside')
	subgoal for x by(cases "x \<in> A \<Gamma>'")(auto dest!: weight_eq weight_le dest: currentD_weight_OUT intro: order_trans)
	subgoal for x by(cases "x \<in> A \<Gamma>'")(auto dest!: weight_eq weight_le dest: currentD_weight_IN intro: order_trans)
	done

	lemma hindrance_mono_web: "hindrance \<Gamma>' f \<Longrightarrow> hindrance \<Gamma> f"
	apply(erule hindrance.cases)
	apply(rule hindrance)
	apply simp
	apply(unfold TER_eq, simp add: essential_eq)
	apply(auto dest!: weight_le)
	done

	lemma hindered_mono_web: "hindered \<Gamma>' \<Longrightarrow> hindered \<Gamma>"
	apply(erule hindered.cases)
	apply(rule hindered.intros)
	apply(erule hindrance_mono_web)
	apply(erule current_mono_web)
	apply(simp add: wave_eq_web)
	done

	end

	subsection \<open>Linkage\<close>

	text \<open>
	The following definition of orthogonality is stronger than the original definition 3.5 in
	@{cite AharoniBergerGeorgakopoulusPerlsteinSpruessel2011JCT} in that the outflow from any
	\<open>A\<close>-vertices in the set must saturate the vertex; @{term "S \<subseteq> SAT \<Gamma> f"} is not enough.

	With the original definition of orthogonal current, the reduction from networks to webs fails because
	the induced flow need not saturate edges going out of the source. Consider the network with three
	nodes \<open>s\<close>, \<open>x\<close>, and \<open>t\<close> and edges \<open>(s, x)\<close> and \<open>(x, t)\<close> with
	capacity \<open>1\<close>. Then, the corresponding web has the vertices \<open>(s, x)\<close> and
	\<open>(x, t)\<close> and one edge from \<open>(s, x)\<close> to \<open>(x, t)\<close>. Clearly, the zero current
	@{term [source] zero_current} is a web-flow and \<open>TER zero_current = {(s, x)}\<close>, which is essential.
	Moreover, @{term [source] zero_current} and \<open>{(s, x)}\<close> are orthogonal because
	@{term [source] zero_current} trivially saturates \<open>(s, x)\<close> as this is a vertex in \<open>A\<close>.
	\<close>
	inductive orthogonal_current :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v set \<Rightarrow> bool"
	for \<Gamma> (structure) and f S
	where orthogonal_current:
	"\<lbrakk> \<And>x. \<lbrakk> x \<in> S; x \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> weight \<Gamma> x \<le> d_IN f x;
	\<And>x. \<lbrakk> x \<in> S; x \<in> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f x = weight \<Gamma> x;
	\<And>u v. \<lbrakk> v \<in> RF S; u \<notin> RF\<^sup>\<circ> S \<rbrakk> \<Longrightarrow> f (u, v) = 0 \<rbrakk>
	\<Longrightarrow> orthogonal_current \<Gamma> f S"

	lemma orthogonal_currentD_SAT: "\<lbrakk> orthogonal_current \<Gamma> f S; x \<in> S \<rbrakk> \<Longrightarrow> x \<in> SAT \<Gamma> f"
	by(auto elim!: orthogonal_current.cases intro: SAT.intros)

	lemma orthogonal_currentD_A: "\<lbrakk> orthogonal_current \<Gamma> f S; x \<in> S; x \<in> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f x = weight \<Gamma> x"
	by(auto elim: orthogonal_current.cases)

	lemma orthogonal_currentD_in: "\<lbrakk> orthogonal_current \<Gamma> f S; v \<in> RF\<^bsub>\<Gamma>\<^esub> S; u \<notin> RF\<^sup>\<circ>\<^bsub>\<Gamma>\<^esub> S \<rbrakk> \<Longrightarrow> f (u, v) = 0"
	by(auto elim: orthogonal_current.cases)

	inductive linkage :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> bool"
	for \<Gamma> f
	where \<comment> \<open>Omit the condition @{const web_flow}\<close>
	linkage: "(\<And>x. x \<in> A \<Gamma> \<Longrightarrow> d_OUT f x = weight \<Gamma> x) \<Longrightarrow> linkage \<Gamma> f"

	lemma linkageD: "\<lbrakk> linkage \<Gamma> f; x \<in> A \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f x = weight \<Gamma> x"
	by(rule linkage.cases)

	abbreviation linkable :: "('v, 'more) web_scheme \<Rightarrow> bool"
	where "linkable \<Gamma> \<equiv> \<exists>f. web_flow \<Gamma> f \<and> linkage \<Gamma> f"

	subsection \<open>Trimming\<close>

	context
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure)
	and f :: "'v current"
	begin

	inductive trimming :: "'v current \<Rightarrow> bool"
	for g
	where
	trimming:
	\<comment> \<open>omits the condition that @{term f} is a wave\<close>
	"\<lbrakk> current \<Gamma> g; wave \<Gamma> g; g \<le> f; \<And>x. \<lbrakk> x \<in> RF\<^sup>\<circ> (TER f); x \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> KIR g x; \<E> (TER g) - A \<Gamma> = \<E> (TER f) - A \<Gamma> \<rbrakk>
	\<Longrightarrow> trimming g"

	lemma assumes "trimming g"
	shows trimmingD_current: "current \<Gamma> g"
	and trimmingD_wave: "wave \<Gamma> g"
	and trimmingD_le: "\<And>e. g e \<le> f e"
	and trimmingD_KIR: "\<lbrakk> x \<in> RF\<^sup>\<circ> (TER f); x \<notin> A \<Gamma> \<rbrakk> \<Longrightarrow> KIR g x"
	and trimmingD_\<E>: "\<E> (TER g) - A \<Gamma> = \<E> (TER f) - A \<Gamma>"
	using assms by(blast elim: trimming.cases dest: le_funD)+

	lemma ex_trimming: \<comment> \<open>Lemma 4.8\<close>
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and countable: "countable \<^bold>E"
	and weight_finite: "\<And>x. weight \<Gamma> x \<noteq> \<top>"
	shows "\<exists>g. trimming g"
	proof -
	define F where "F = {g. current \<Gamma> g \<and> wave \<Gamma> g \<and> g \<le> f \<and> \<E> (TER g) = \<E> (TER f)}"
	define leq where "leq = restrict_rel F {(g, g'). g' \<le> g}"
	have in_F [simp]: "g \<in> F \<longleftrightarrow> current \<Gamma> g \<and> wave \<Gamma> g \<and> (\<forall>e. g e \<le> f e) \<and> \<E> (TER g) = \<E> (TER f)" for g
	by(simp add: F_def le_fun_def)

	have f_finite [simp]: "f e \<noteq> \<top>" for e
	proof(cases e)
	case (Pair x y)
	have "f (x, y) \<le> d_IN f y" by (rule d_IN_ge_point)
	also have "\<dots> \<le> weight \<Gamma> y" by(rule currentD_weight_IN[OF f])
	also have "\<dots> < \<top>" by(simp add: weight_finite less_top[symmetric])
	finally show ?thesis using Pair by simp
	qed

	have chainD: "Inf M \<in> F" if M: "M \<in> Chains leq" and nempty: "M \<noteq> {}" for M
	proof -
	from nempty obtain g0 where g0: "g0 \<in> M" by auto
	have g0_le_f: "g0 e \<le> f e" and g: "current \<Gamma> g0" and w0: "wave \<Gamma> g0" for e
	using Chains_FieldD[OF M g0] by(cases e, auto simp add: leq_def)

	have finite_OUT: "d_OUT f x \<noteq> \<top>" for x using weight_finite[of x]
	by(rule neq_top_trans)(rule currentD_weight_OUT[OF f])
	have finite_IN: "d_IN f x \<noteq> \<top>" for x using weight_finite[of x]
	by(rule neq_top_trans)(rule currentD_weight_IN[OF f])

	from M have "M \<in> Chains {(g, g'). g' \<le> g}"
	by(rule mono_Chains[THEN subsetD, rotated])(auto simp add: leq_def in_restrict_rel_iff)
	then have chain: "Complete_Partial_Order.chain (\<ge>) M" by(rule Chains_into_chain)
	hence chain': "Complete_Partial_Order.chain (\<le>) M" by(simp add: chain_dual)

	have countable': "countable (support_flow f)"
	using current_support_flow[OF f] by(rule countable_subset)(rule countable)

	have OUT_M: "d_OUT (Inf M) x = (INF g\<in>M. d_OUT g x)" for x using chain' nempty countable' _ finite_OUT
	by(rule d_OUT_Inf)(auto dest!: Chains_FieldD[OF M] simp add: leq_def)
	have IN_M: "d_IN (Inf M) x = (INF g\<in>M. d_IN g x)" for x using chain' nempty countable' _ finite_IN
	by(rule d_IN_Inf)(auto dest!: Chains_FieldD[OF M] simp add: leq_def)

	have c: "current \<Gamma> (Inf M)" using g
	proof(rule current_leI)
	show "(Inf M) e \<le> g0 e" for e using g0 by(auto intro: INF_lower)
	show "d_OUT (\<Sqinter>M) x \<le> d_IN (\<Sqinter>M) x" if "x \<notin> A \<Gamma>" for x
	by(auto 4 4 simp add: IN_M OUT_M leq_def intro!: INF_mono dest: Chains_FieldD[OF M] intro: currentD_OUT_IN[OF _ that])
	qed

	have INF_le_f: "Inf M e \<le> f e" for e using g0 by(auto intro!: INF_lower2 g0_le_f)
	have eq: "\<E> (TER (Inf M)) = \<E> (TER f)" using f w INF_le_f
	proof(rule essential_eq_leI; intro subsetI)
	fix x
	assume x: "x \<in> \<E> (TER f)"
	hence "x \<in> SINK (Inf M)" using d_OUT_mono[of "Inf M" x f, OF INF_le_f]
	by(auto simp add: SINK.simps)
	moreover from x have "x \<in> SAT \<Gamma> g" if "g \<in> M" for g using Chains_FieldD[OF M that] by(auto simp add: leq_def)
	hence "x \<in> SAT \<Gamma> (Inf M)" by(auto simp add: SAT.simps IN_M intro!: INF_greatest)
	ultimately show "x \<in> TER (Inf M)" by auto
	qed

	have w': "wave \<Gamma> (Inf M)"
	proof
	have "separating \<Gamma> (\<E> (TER f))" by(rule separating_essential)(rule waveD_separating[OF w])
	then show "separating \<Gamma> (TER (Inf M))" unfolding eq[symmetric] by(rule separating_weakening) auto

	fix x
	assume "x \<notin> RF (TER (Inf M))"
	hence "x \<notin> RF (\<E> (TER (Inf M)))" unfolding RF_essential .
	hence "x \<notin> RF (TER f)" unfolding eq RF_essential .
	hence "d_OUT f x = 0" by(rule waveD_OUT[OF w])
	with d_OUT_mono[of _ x f, OF INF_le_f]
	show "d_OUT (Inf M) x = 0" by (metis le_zero_eq)
	qed
	from c w' INF_le_f eq show ?thesis by simp
	qed

	define trim1
	where "trim1 g =
	(if trimming g then g
	else let z = SOME z. z \<in> RF\<^sup>\<circ> (TER g) \<and> z \<notin> A \<Gamma> \<and> \<not> KIR g z;
	factor = d_OUT g z / d_IN g z
	in (\<lambda>(y, x). (if x = z then factor else 1) * g (y, x)))" for g

	have increasing: "trim1 g \<le> g \<and> trim1 g \<in> F" if "g \<in> F" for g
	proof(cases "trimming g")
	case True
	thus ?thesis using that by(simp add: trim1_def)
	next
	case False
	let ?P = "\<lambda>z. z \<in> RF\<^sup>\<circ> (TER g) \<and> z \<notin> A \<Gamma> \<and> \<not> KIR g z"
	define z where "z = Eps ?P"
	from that have g: "current \<Gamma> g" and w': "wave \<Gamma> g" and le_f: "\<And>e. g e \<le> f e"
	and \<E>: "\<E> (TER g) = \<E> (TER f)" by(auto simp add: le_fun_def)
	{ with False obtain z where z: "z \<in> RF\<^sup>\<circ> (TER f)" and A: "z \<notin> A \<Gamma>" and neq: "d_OUT g z \<noteq> d_IN g z"
	by(auto simp add: trimming.simps le_fun_def)
	from z have "z \<in> RF\<^sup>\<circ> (\<E> (TER f))" unfolding roofed_circ_essential .
	with \<E> roofed_circ_essential[of \<Gamma> "TER g"] have "z \<in> RF\<^sup>\<circ> (TER g)" by simp
	with A neq have "\<exists>x. ?P x" by auto }
	hence "?P z" unfolding z_def by(rule someI_ex)
	hence RF: "z \<in> RF\<^sup>\<circ> (TER g)" and A: "z \<notin> A \<Gamma>" and neq: "d_OUT g z \<noteq> d_IN g z" by simp_all
	let ?factor = "d_OUT g z / d_IN g z"
	have trim1 [simp]: "trim1 g (y, x) = (if x = z then ?factor else 1) * g (y, x)" for x y
	using False by(auto simp add: trim1_def z_def Let_def)

	from currentD_OUT_IN[OF g A] neq have less: "d_OUT g z < d_IN g z" by auto
	hence "?factor \<le> 1" (is "?factor \<le> _")
	by (auto intro!: divide_le_posI_ennreal simp: zero_less_iff_neq_zero)
	hence le': "?factor * g (y, x) \<le> 1 * g (y, x)" for y x
	by(rule mult_right_mono) simp
	hence le: "trim1 g e \<le> g e" for e by(cases e)simp
	moreover {
	have c: "current \<Gamma> (trim1 g)" using g le
	proof(rule current_leI)
	fix x
	assume x: "x \<notin> A \<Gamma>"
	have "d_OUT (trim1 g) x \<le> d_OUT g x" unfolding d_OUT_def using le' by(auto intro: nn_integral_mono)
	also have "\<dots> \<le> d_IN (trim1 g) x"
	proof(cases "x = z")
	case True
	have "d_OUT g x = d_IN (trim1 g) x" unfolding d_IN_def
	using True currentD_weight_IN[OF g, of x] currentD_OUT_IN[OF g x]
	apply (cases "d_IN g x = 0")
	apply(auto simp add: nn_integral_divide nn_integral_cmult d_IN_def[symmetric] ennreal_divide_times)
	apply (subst ennreal_divide_self)
	apply (auto simp: less_top[symmetric] top_unique weight_finite)
	done
	thus ?thesis by simp
	next
	case False
	have "d_OUT g x \<le> d_IN g x" using x by(rule currentD_OUT_IN[OF g])
	also have "\<dots> \<le> d_IN (trim1 g) x" unfolding d_IN_def using False by(auto intro!: nn_integral_mono)
	finally show ?thesis .
	qed
	finally show "d_OUT (trim1 g) x \<le> d_IN (trim1 g) x" .
	qed
	moreover have le_f: "trim1 g \<le> f" using le le_f by(blast intro: le_funI order_trans)
	moreover have eq: "\<E> (TER (trim1 g)) = \<E> (TER f)" unfolding \<E>[symmetric] using g w' le
	proof(rule essential_eq_leI; intro subsetI)
	fix x
	assume x: "x \<in> \<E> (TER g)"
	hence "x \<in> SINK (trim1 g)" using d_OUT_mono[of "trim1 g" x g, OF le]
	by(auto simp add: SINK.simps)
	moreover from x have "x \<noteq> z" using RF by(auto simp add: roofed_circ_def)
	hence "d_IN (trim1 g) x = d_IN g x" unfolding d_IN_def by simp
	with \<open>x \<in> \<E> (TER g)\<close> have "x \<in> SAT \<Gamma> (trim1 g)" by(auto simp add: SAT.simps)
	ultimately show "x \<in> TER (trim1 g)" by auto
	qed
	moreover have "wave \<Gamma> (trim1 g)"
	proof
	have "separating \<Gamma> (\<E> (TER f))" by(rule separating_essential)(rule waveD_separating[OF w])
	then show "separating \<Gamma> (TER (trim1 g))" unfolding eq[symmetric] by(rule separating_weakening) auto

	fix x
	assume "x \<notin> RF (TER (trim1 g))"
	hence "x \<notin> RF (\<E> (TER (trim1 g)))" unfolding RF_essential .
	hence "x \<notin> RF (TER f)" unfolding eq RF_essential .
	hence "d_OUT f x = 0" by(rule waveD_OUT[OF w])
	with d_OUT_mono[of _ x f, OF le_f[THEN le_funD]]
	show "d_OUT (trim1 g) x = 0" by (metis le_zero_eq)
	qed
	ultimately have "trim1 g \<in> F" by(simp add: F_def) }
	ultimately show ?thesis using that by(simp add: le_fun_def del: trim1)
	qed

	have "bourbaki_witt_fixpoint Inf leq trim1" using chainD increasing unfolding leq_def
	by(intro bourbaki_witt_fixpoint_restrict_rel)(auto intro: Inf_greatest Inf_lower)
	then interpret bourbaki_witt_fixpoint Inf leq trim1 .

	have f_Field: "f \<in> Field leq" using f w by(simp add: leq_def)

	define g where "g = fixp_above f"

	have "g \<in> Field leq" using f_Field unfolding g_def by(rule fixp_above_Field)
	hence le_f: "g \<le> f"
	and g: "current \<Gamma> g"
	and w': "wave \<Gamma> g"
	and TER: "\<E> (TER g) = \<E> (TER f)" by(auto simp add: leq_def intro: le_funI)

	have "trimming g"
	proof(rule ccontr)
	let ?P = "\<lambda>x. x \<in> RF\<^sup>\<circ> (TER g) \<and> x \<notin> A \<Gamma> \<and> \<not> KIR g x"
	define x where "x = Eps ?P"
	assume False: "\<not> ?thesis"
	hence "\<exists>x. ?P x" using le_f g w' TER
	by(auto simp add: trimming.simps roofed_circ_essential[of \<Gamma> "TER g", symmetric] roofed_circ_essential[of \<Gamma> "TER f", symmetric])
	hence "?P x" unfolding x_def by(rule someI_ex)
	hence x: "x \<in> RF\<^sup>\<circ> (TER g)" and A: "x \<notin> A \<Gamma>" and neq: "d_OUT g x \<noteq> d_IN g x" by simp_all
	from neq have "\<exists>y. edge \<Gamma> y x \<and> g (y, x) > 0"
	proof(rule contrapos_np)
	assume "\<not> ?thesis"
	hence "d_IN g x = 0" using currentD_outside[OF g, of _ x]
	by(force simp add: d_IN_def nn_integral_0_iff_AE AE_count_space not_less)
	with currentD_OUT_IN[OF g A] show "KIR g x" by simp
	qed
	then obtain y where y: "edge \<Gamma> y x" and gr0: "g (y, x) > 0" by blast

	have [simp]: "g (y, x) \<noteq> \<top>"
	proof -
	have "g (y, x) \<le> d_OUT g y" by (rule d_OUT_ge_point)
	also have "\<dots> \<le> weight \<Gamma> y" by(rule currentD_weight_OUT[OF g])
	also have "\<dots> < \<top>" by(simp add: weight_finite less_top[symmetric])
	finally show ?thesis by simp
	qed

	from neq have factor: "d_OUT g x / d_IN g x \<noteq> 1"
	by (simp add: divide_eq_1_ennreal)

	have "trim1 g (y, x) = g (y, x) * (d_OUT g x / d_IN g x)"
	by(clarsimp simp add: False trim1_def Let_def x_def[symmetric] mult.commute)
	moreover have "\<dots> \<noteq> g (y, x) * 1" unfolding ennreal_mult_cancel_left using gr0 factor by auto
	ultimately have "trim1 g (y, x) \<noteq> g (y, x)" by auto
	hence "trim1 g \<noteq> g" by(auto simp add: fun_eq_iff)
	moreover have "trim1 g = g" using f_Field unfolding g_def by(rule fixp_above_unfold[symmetric])
	ultimately show False by contradiction
	qed
	then show ?thesis by blast
	qed

	end

	lemma trimming_\<E>:
	fixes \<Gamma> (structure)
	assumes w: "wave \<Gamma> f" and trimming: "trimming \<Gamma> f g"
	shows "\<E> (TER f) = \<E> (TER g)"
	proof(rule set_eqI)
	show "x \<in> \<E> (TER f) \<longleftrightarrow> x \<in> \<E> (TER g)" for x
	proof(cases "x \<in> A \<Gamma>")
	case False
	thus ?thesis using trimmingD_\<E>[OF trimming] by blast
	next
	case True
	show ?thesis
	proof
	assume x: "x \<in> \<E> (TER f)"
	hence "x \<in> TER g" using d_OUT_mono[of g x f, OF trimmingD_le[OF trimming]] True
	by(simp add: SINK.simps SAT.A)
	moreover from x have "essential \<Gamma> (B \<Gamma>) (TER f) x" by simp
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)" by(rule essentialE_RF) blast
	from p y have "essential \<Gamma> (B \<Gamma>) (\<E> (TER g)) x"
	proof(rule essentialI)
	fix z
	assume "z \<in> set p"
	hence z: "z \<notin> RF (TER f)" by(rule bypass)
	with waveD_separating[OF w, THEN separating_RF_A] have "z \<notin> A \<Gamma>" by blast
	with z have "z \<notin> \<E> (TER g)" using trimmingD_\<E>[OF trimming] by(auto intro: roofed_greaterI)
	thus "z = x \<or> z \<notin> \<E> (TER g)" ..
	qed
	ultimately show "x \<in> \<E> (TER g)" unfolding essential_\<E> by simp
	next
	assume "x \<in> \<E> (TER g)"
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER g)" by(rule \<E>_E_RF) blast
	have z: "z \<notin> \<E> (TER f)" if "z \<in> set p" for z
	proof -
	from that have z: "z \<notin> RF (TER g)" by(rule bypass)
	with waveD_separating[OF trimmingD_wave[OF trimming], THEN separating_RF_A] have "z \<notin> A \<Gamma>" by blast
	with z show "z \<notin> \<E> (TER f)" using trimmingD_\<E>[OF trimming] by(auto intro: roofed_greaterI)
	qed
	then have "essential \<Gamma> (B \<Gamma>) (\<E> (TER f)) x" by(intro essentialI[OF p y]) auto
	moreover have "x \<in> TER f"
	using waveD_separating[THEN separating_essential, THEN separatingD, OF w p True y] z
	by auto
	ultimately show "x \<in> \<E> (TER f)" unfolding essential_\<E> by simp
	qed
	qed
	qed

	subsection \<open>Composition of waves via quotients\<close>

	definition quotient_web :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> ('v, 'more) web_scheme"
	where \<comment> \<open>Modifications to original Definition 4.9: No incoming edges to nodes in @{const A},
	@{term "B \<Gamma> - A \<Gamma>"} is not part of @{const A} such that @{const A} contains only vertices
	is disjoint from @{const B}. The weight of vertices in @{const B} saturated by @{term f} is
	therefore set to @{term "0 :: ennreal"}.\<close>
	"quotient_web \<Gamma> f =
	\<lparr>edge = \<lambda>x y. edge \<Gamma> x y \<and> x \<notin> roofed_circ \<Gamma> (TER\<^bsub>\<Gamma>\<^esub> f) \<and> y \<notin> roofed \<Gamma> (TER\<^bsub>\<Gamma>\<^esub> f),
	weight = \<lambda>x. if x \<in> RF\<^sup>\<circ>\<^bsub>\<Gamma>\<^esub> (TER\<^bsub>\<Gamma>\<^esub> f) \<or> x \<in> TER\<^bsub>\<Gamma>\<^esub> f \<inter> B \<Gamma> then 0 else weight \<Gamma> x,
	A = \<E>\<^bsub>\<Gamma>\<^esub> (TER\<^bsub>\<Gamma>\<^esub> f) - (B \<Gamma> - A \<Gamma>),
	B = B \<Gamma>,
	\<dots> = web.more \<Gamma>\<rparr>"

	lemma quotient_web_sel [simp]:
	fixes \<Gamma> (structure) shows
	"edge (quotient_web \<Gamma> f) x y \<longleftrightarrow> edge \<Gamma> x y \<and> x \<notin> RF\<^sup>\<circ> (TER f) \<and> y \<notin> RF (TER f)"
	"weight (quotient_web \<Gamma> f) x = (if x \<in> RF\<^sup>\<circ> (TER f) \<or> x \<in> TER\<^bsub>\<Gamma>\<^esub> f \<inter> B \<Gamma> then 0 else weight \<Gamma> x)"
	"A (quotient_web \<Gamma> f) = \<E> (TER f)- (B \<Gamma> - A \<Gamma>)"
	"B (quotient_web \<Gamma> f) = B \<Gamma>"
	"web.more (quotient_web \<Gamma> f) = web.more \<Gamma>"
	by(simp_all add: quotient_web_def)

	lemma vertex_quotient_webD: fixes \<Gamma> (structure) shows
	"vertex (quotient_web \<Gamma> f) x \<Longrightarrow> vertex \<Gamma> x \<and> x \<notin> RF\<^sup>\<circ> (TER f)"
	by(auto simp add: vertex_def roofed_circ_def)

	lemma path_quotient_web:
	fixes \<Gamma> (structure)
	assumes "path \<Gamma> x p y"
	and "x \<notin> RF\<^sup>\<circ> (TER f)"
	and "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)"
	shows "path (quotient_web \<Gamma> f) x p y"
	using assms by(induction)(auto intro: rtrancl_path.intros simp add: roofed_circ_def)

	definition restrict_current :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v current \<Rightarrow> 'v current"
	where "restrict_current \<Gamma> f g = (\<lambda>(x, y). g (x, y) * indicator (- RF\<^sup>\<circ>\<^bsub>\<Gamma>\<^esub> (TER\<^bsub>\<Gamma>\<^esub> f)) x * indicator (- RF\<^bsub>\<Gamma>\<^esub> (TER\<^bsub>\<Gamma>\<^esub> f)) y)"

	abbreviation restrict_curr :: "'v current \<Rightarrow> ('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> 'v current" ("_ \<upharpoonleft> _ '/ _" [100, 0, 100] 100)
	where "restrict_curr g \<Gamma> f \<equiv> restrict_current \<Gamma> f g"

	lemma restrict_current_simps [simp]: fixes \<Gamma> (structure) shows
	"(g \<upharpoonleft> \<Gamma> / f) (x, y) = (g (x, y) * indicator (- RF\<^sup>\<circ> (TER f)) x * indicator (- RF (TER f)) y)"
	by(simp add: restrict_current_def)

	lemma d_OUT_restrict_current_outside: fixes \<Gamma> (structure) shows
	"x \<in> RF\<^sup>\<circ> (TER f) \<Longrightarrow> d_OUT (g \<upharpoonleft> \<Gamma> / f) x = 0"
	by(simp add: d_OUT_def)

	lemma d_IN_restrict_current_outside: fixes \<Gamma> (structure) shows
	"x \<in> RF (TER f) \<Longrightarrow> d_IN (g \<upharpoonleft> \<Gamma> / f) x = 0"
	by(simp add: d_IN_def)

	lemma restrict_current_le: "(g \<upharpoonleft> \<Gamma> / f) e \<le> g e"
	by(cases e)(clarsimp split: split_indicator)

	lemma d_OUT_restrict_current_le: "d_OUT (g \<upharpoonleft> \<Gamma> / f) x \<le> d_OUT g x"
	unfolding d_OUT_def by(rule nn_integral_mono, simp split: split_indicator)

	lemma d_IN_restrict_current_le: "d_IN (g \<upharpoonleft> \<Gamma> / f) x \<le> d_IN g x"
	unfolding d_IN_def by(rule nn_integral_mono, simp split: split_indicator)

	lemma restrict_current_IN_not_RF:
	fixes \<Gamma> (structure)
	assumes g: "current \<Gamma> g"
	and x: "x \<notin> RF (TER f)"
	shows "d_IN (g \<upharpoonleft> \<Gamma> / f) x = d_IN g x"
	proof -
	{
	fix y
	assume y: "y \<in> RF\<^sup>\<circ> (TER f)"
	have "g (y, x) = 0"
	proof(cases "edge \<Gamma> y x")
	case True
	from y have y': "y \<in> RF (TER f)" and essential: "y \<notin> \<E> (TER f)" by(simp_all add: roofed_circ_def)
	moreover from x obtain p z where z: "z \<in> B \<Gamma>" and p: "path \<Gamma> x p z"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER f" "x \<notin> TER f"
	by(clarsimp simp add: roofed_def)
	from roofedD[OF y' rtrancl_path.step, OF True p z] bypass have "x \<in> TER f \<or> y \<in> TER f" by auto
	with roofed_greater[THEN subsetD, of x "TER f" \<Gamma>] x have "x \<notin> TER f" "y \<in> TER f" by auto
	with essential bypass have False
	by(auto dest!: not_essentialD[OF _ rtrancl_path.step, OF _ True p z])
	thus ?thesis ..
	qed(simp add: currentD_outside[OF g]) }
	then show ?thesis unfolding d_IN_def
	using x by(auto intro!: nn_integral_cong split: split_indicator)
	qed

	lemma restrict_current_IN_A:
	"a \<in> A (quotient_web \<Gamma> f) \<Longrightarrow> d_IN (g \<upharpoonleft> \<Gamma> / f) a = 0"
	by(simp add: d_IN_restrict_current_outside roofed_greaterI)

	lemma restrict_current_nonneg: "0 \<le> g e \<Longrightarrow> 0 \<le> (g \<upharpoonleft> \<Gamma> / f) e"
	by(cases e) simp

	lemma in_SINK_restrict_current: "x \<in> SINK g \<Longrightarrow> x \<in> SINK (g \<upharpoonleft> \<Gamma> / f)"
	using d_OUT_restrict_current_le[of \<Gamma> f g x]
	by(simp add: SINK.simps)

	lemma SAT_restrict_current:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and g: "current \<Gamma> g"
	shows "SAT (quotient_web \<Gamma> f) (g \<upharpoonleft> \<Gamma> / f) = RF (TER f) \<union> (SAT \<Gamma> g - A \<Gamma>)" (is "SAT ?\<Gamma> ?g = ?rhs")
	proof(intro set_eqI iffI; (elim UnE DiffE)?)
	show "x \<in> ?rhs" if "x \<in> SAT ?\<Gamma> ?g" for x using that
	proof cases
	case IN
	thus ?thesis using currentD_weight_OUT[OF f, of x]
	by(cases "x \<in> RF (TER f)")(auto simp add: d_IN_restrict_current_outside roofed_circ_def restrict_current_IN_not_RF[OF g] SAT.IN currentD_IN[OF g] roofed_greaterI SAT.A SINK.simps RF_in_B split: if_split_asm intro: essentialI[OF rtrancl_path.base])
	qed(simp add: roofed_greaterI)
	show "x \<in> SAT ?\<Gamma> ?g" if "x \<in> RF (TER f)" for x using that
	by(auto simp add: SAT.simps roofed_circ_def d_IN_restrict_current_outside)
	show "x \<in> SAT ?\<Gamma> ?g" if "x \<in> SAT \<Gamma> g" "x \<notin> A \<Gamma>" for x using that
	by(auto simp add: SAT.simps roofed_circ_def d_IN_restrict_current_outside restrict_current_IN_not_RF[OF g])
	qed

	lemma current_restrict_current:
	fixes \<Gamma> (structure)
	assumes w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	shows "current (quotient_web \<Gamma> f) (g \<upharpoonleft> \<Gamma> / f)" (is "current ?\<Gamma> ?g")
	proof
	show "d_OUT ?g x \<le> weight ?\<Gamma> x" for x
	using d_OUT_restrict_current_le[of \<Gamma> f g x] currentD_weight_OUT[OF g, of x] currentD_OUT[OF g, of x]
	by(auto simp add: d_OUT_restrict_current_outside)
	show "d_IN ?g x \<le> weight ?\<Gamma> x" for x
	using d_IN_restrict_current_le[of \<Gamma> f g x] currentD_weight_IN[OF g, of x]
	by(auto simp add: d_IN_restrict_current_outside roofed_circ_def)
	(subst d_IN_restrict_current_outside[of x \<Gamma> f g]; simp add: roofed_greaterI)

	fix x
	assume "x \<notin> A ?\<Gamma>"
	hence x: "x \<notin> \<E> (TER f) - B \<Gamma>" by simp
	show "d_OUT ?g x \<le> d_IN ?g x"
	proof(cases "x \<in> RF (TER f)")
	case True
	with x have "x \<in> RF\<^sup>\<circ> (TER f) \<union> B \<Gamma>" by(simp add: roofed_circ_def)
	with True show ?thesis using currentD_OUT[OF g, of x] d_OUT_restrict_current_le[of \<Gamma> f g x]
	by(auto simp add: d_OUT_restrict_current_outside d_IN_restrict_current_outside)
	next
	case False
	then obtain p z where z: "z \<in> B \<Gamma>" and p: "path \<Gamma> x p z"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER f" "x \<notin> TER f"
	by(clarsimp simp add: roofed_def)
	from g False have "d_IN ?g x = d_IN g x" by(rule restrict_current_IN_not_RF)
	moreover have "d_OUT ?g x \<le> d_OUT g x"
	by(rule d_OUT_mono restrict_current_le)+
	moreover have "x \<notin> A \<Gamma>"
	using separatingD[OF waveD_separating[OF w] p _ z] bypass by blast
	note currentD_OUT_IN[OF g this]
	ultimately show ?thesis by simp
	qed
	next
	show "d_IN ?g a = 0" if "a \<in> A ?\<Gamma>" for a using that by(rule restrict_current_IN_A)
	show "d_OUT ?g b = 0" if "b \<in> B ?\<Gamma>" for b
	using d_OUT_restrict_current_le[of \<Gamma> f g b] currentD_OUT[OF g, of b] that by simp
	show "?g e = 0" if "e \<notin> \<^bold>E\<^bsub>?\<Gamma>\<^esub>" for e using that currentD_outside'[OF g, of e]
	by(cases e)(auto split: split_indicator)
	qed

	lemma TER_restrict_current:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	shows "TER g \<subseteq> TER\<^bsub>quotient_web \<Gamma> f\<^esub> (g \<upharpoonleft> \<Gamma> / f)" (is "_ \<subseteq> ?TER" is "_ \<subseteq> TER\<^bsub>?\<Gamma>\<^esub> ?g")
	proof
	fix x
	assume x: "x \<in> TER g"
	hence "x \<in> SINK ?g" by(simp add: in_SINK_restrict_current)
	moreover have "x \<in> RF (TER f)" if "x \<in> A \<Gamma>"
	using waveD_separating[OF w, THEN separatingD, OF _ that] by(rule roofedI)
	then have "x \<in> SAT ?\<Gamma> ?g" using SAT_restrict_current[OF f g] x by auto
	ultimately show "x \<in> ?TER" by simp
	qed

	lemma wave_restrict_current:
	fixes \<Gamma> (structure)
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current \<Gamma> g"
	and w': "wave \<Gamma> g"
	shows "wave (quotient_web \<Gamma> f) (g \<upharpoonleft> \<Gamma> / f)" (is "wave ?\<Gamma> ?g")
	proof
	show "separating ?\<Gamma> (TER\<^bsub>?\<Gamma>\<^esub> ?g)" (is "separating _ ?TER")
	proof
	fix x y p
	assume "x \<in> A ?\<Gamma>" "y \<in> B ?\<Gamma>" and p: "path ?\<Gamma> x p y"
	hence x: "x \<in> \<E> (TER f)" and y: "y \<in> B \<Gamma>" and SAT: "x \<in> SAT ?\<Gamma> ?g" by(simp_all add: SAT.A)
	from p have p': "path \<Gamma> x p y" by(rule rtrancl_path_mono) simp

	{ assume "x \<notin> ?TER"
	hence "x \<notin> SINK ?g" using SAT by(simp)
	hence "x \<notin> SINK g" using d_OUT_restrict_current_le[of \<Gamma> f g x]
	by(auto simp add: SINK.simps)
	hence "x \<in> RF (TER g)" using waveD_OUT[OF w'] by(auto simp add: SINK.simps)
	from roofedD[OF this p' y] \<open>x \<notin> SINK g\<close> have "(\<exists>z\<in>set p. z \<in> ?TER)"
	using TER_restrict_current[OF f w g] by blast }
	then show "(\<exists>z\<in>set p. z \<in> ?TER) \<or> x \<in> ?TER" by blast
	qed

	fix x
	assume "x \<notin> RF\<^bsub>?\<Gamma>\<^esub> ?TER"
	hence "x \<notin> RF (TER g)"
	proof(rule contrapos_nn)
	assume *: "x \<in> RF (TER g)"
	show "x \<in> RF\<^bsub>?\<Gamma>\<^esub> ?TER"
	proof
	fix p y
	assume "path ?\<Gamma> x p y" "y \<in> B ?\<Gamma>"
	hence "path \<Gamma> x p y" "y \<in> B \<Gamma>" by(auto elim: rtrancl_path_mono)
	from roofedD[OF * this] show "(\<exists>z\<in>set p. z \<in> ?TER) \<or> x \<in> ?TER"
	using TER_restrict_current[OF f w g] by blast
	qed
	qed
	with w' have "d_OUT g x = 0" by(rule waveD_OUT)
	with d_OUT_restrict_current_le[of \<Gamma> f g x]
	show "d_OUT ?g x = 0" by simp
	qed

	definition plus_current :: "'v current \<Rightarrow> 'v current \<Rightarrow> 'v current"
	where "plus_current f g = (\<lambda>e. f e + g e)"

	lemma plus_current_simps [simp]: "plus_current f g e = f e + g e"
	by(simp add: plus_current_def)

	lemma plus_zero_current [simp]: "plus_current f zero_current = f"
	by(simp add: fun_eq_iff)

	lemma support_flow_plus_current: "support_flow (plus_current f g) \<subseteq> support_flow f \<union> support_flow g"
	by(clarsimp simp add: support_flow.simps)

	context
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure) and f g
	assumes f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and g: "current (quotient_web \<Gamma> f) g"
	begin

	lemma OUT_plus_current: "d_OUT (plus_current f g) x = (if x \<in> RF\<^sup>\<circ> (TER f) then d_OUT f x else d_OUT g x)" (is "d_OUT ?g _ = _")
	proof -
	have "d_OUT ?g x = d_OUT f x + d_OUT g x" unfolding plus_current_def
	by(subst d_OUT_add) simp_all
	also have "\<dots> = (if x \<in> RF\<^sup>\<circ> (TER f) then d_OUT f x else d_OUT g x)"
	proof(cases "x \<in> RF\<^sup>\<circ> (TER f)")
	case True
	hence "d_OUT g x = 0" by(intro currentD_outside_OUT[OF g])(auto dest: vertex_quotient_webD)
	thus ?thesis using True by simp
	next
	case False
	hence "d_OUT f x = 0" by(auto simp add: roofed_circ_def SINK.simps dest: waveD_OUT[OF w])
	with False show ?thesis by simp
	qed
	finally show ?thesis .
	qed

	lemma IN_plus_current: "d_IN (plus_current f g) x = (if x \<in> RF (TER f) then d_IN f x else d_IN g x)" (is "d_IN ?g _ = _")
	proof -
	have "d_IN ?g x = d_IN f x + d_IN g x" unfolding plus_current_def
	by(subst d_IN_add) simp_all
	also consider (RF) "x \<in> RF (TER f) - (B \<Gamma> - A \<Gamma>)" \| (B) "x \<in> RF (TER f)" "x \<in> B \<Gamma> - A \<Gamma>" \| (beyond) "x \<notin> RF (TER f)" by blast
	then have "d_IN f x + d_IN g x = (if x \<in> RF (TER f) then d_IN f x else d_IN g x)"
	proof(cases)
	case RF
	hence "d_IN g x = 0"
	by(cases "x \<in> \<E> (TER f)")(auto intro: currentD_outside_IN[OF g] currentD_IN[OF g] dest!: vertex_quotient_webD simp add: roofed_circ_def)
	thus ?thesis using RF by simp
	next
	case B
	hence "d_IN g x = 0" using currentD_outside_IN[OF g, of x] currentD_weight_IN[OF g, of x]
	by(auto dest: vertex_quotient_webD simp add: roofed_circ_def)
	with B show ?thesis by simp
	next
	case beyond
	from f w beyond have "d_IN f x = 0" by(rule wave_not_RF_IN_zero)
	with beyond show ?thesis by simp
	qed
	finally show ?thesis .
	qed

	lemma in_TER_plus_current:
	assumes RF: "x \<notin> RF\<^sup>\<circ> (TER f)"
	and x: "x \<in> TER\<^bsub>quotient_web \<Gamma> f\<^esub> g" (is "_ \<in> ?TER _")
	shows "x \<in> TER (plus_current f g)" (is "_ \<in> TER ?g")
	proof(cases "x \<in> \<E> (TER f) - (B \<Gamma> - A \<Gamma>)")
	case True
	with x show ?thesis using currentD_IN[OF g, of x]
	by(fastforce intro: roofed_greaterI SAT.intros simp add: SINK.simps OUT_plus_current IN_plus_current elim!: SAT.cases)
	next
	case *: False
	have "x \<in> SAT \<Gamma> ?g"
	proof(cases "x \<in> B \<Gamma> - A \<Gamma>")
	case False
	with x RF * have "weight \<Gamma> x \<le> d_IN g x"
	by(auto elim!: SAT.cases split: if_split_asm simp add: essential_BI)
	also have "\<dots> \<le> d_IN ?g x" unfolding plus_current_def by(intro d_IN_mono) simp
	finally show ?thesis ..
	next
	case True
	with * x have "weight \<Gamma> x \<le> d_IN ?g x" using currentD_OUT[OF f, of x]
	by(auto simp add: IN_plus_current RF_in_B SINK.simps roofed_circ_def elim!: SAT.cases split: if_split_asm)
	thus ?thesis ..
	qed
	moreover have "x \<in> SINK ?g" using x by(simp add: SINK.simps OUT_plus_current RF)
	ultimately show ?thesis by simp
	qed

	lemma current_plus_current: "current \<Gamma> (plus_current f g)" (is "current _ ?g")
	proof
	show "d_OUT ?g x \<le> weight \<Gamma> x" for x
	using currentD_weight_OUT[OF g, of x] currentD_weight_OUT[OF f, of x]
	by(auto simp add: OUT_plus_current split: if_split_asm elim: order_trans)
	show "d_IN ?g x \<le> weight \<Gamma> x" for x
	using currentD_weight_IN[OF f, of x] currentD_weight_IN[OF g, of x]
	by(auto simp add: IN_plus_current roofed_circ_def split: if_split_asm elim: order_trans)
	show "d_OUT ?g x \<le> d_IN ?g x" if "x \<notin> A \<Gamma>" for x
	proof(cases "x \<in> \<E> (TER f)")
	case False
	thus ?thesis
	using currentD_OUT_IN[OF f that] currentD_OUT_IN[OF g, of x] that
	by(auto simp add: OUT_plus_current IN_plus_current roofed_circ_def SINK.simps)
	next
	case True
	with that have "d_OUT f x = 0" "weight \<Gamma> x \<le> d_IN f x"
	by(auto simp add: SINK.simps elim: SAT.cases)
	thus ?thesis using that True currentD_OUT_IN[OF g, of x] currentD_weight_OUT[OF g, of x]
	by(auto simp add: OUT_plus_current IN_plus_current roofed_circ_def intro: roofed_greaterI split: if_split_asm)
	qed
	show "d_IN ?g a = 0" if "a \<in> A \<Gamma>" for a
	using wave_A_in_RF[OF w that] currentD_IN[OF f that] by(simp add: IN_plus_current)
	show "d_OUT ?g b = 0" if "b \<in> B \<Gamma>" for b
	using that currentD_OUT[OF f that] currentD_OUT[OF g, of b] that
	by(auto simp add: OUT_plus_current SINK.simps roofed_circ_def intro: roofed_greaterI)
	show "?g e = 0" if "e \<notin> \<^bold>E" for e using currentD_outside'[OF f, of e] currentD_outside'[OF g, of e] that
	by(cases e) auto
	qed

	context
	assumes w': "wave (quotient_web \<Gamma> f) g"
	begin

	lemma separating_TER_plus_current:
	assumes x: "x \<in> RF (TER f)" and y: "y \<in> B \<Gamma>" and p: "path \<Gamma> x p y"
	shows "(\<exists>z\<in>set p. z \<in> TER (plus_current f g)) \<or> x \<in> TER (plus_current f g)" (is "_ \<or> _ \<in> TER ?g")
	proof -
	from x have "x \<in> RF (\<E> (TER f))" unfolding RF_essential .
	from roofedD[OF this p y] have "\<exists>z\<in>set (x # p). z \<in> \<E> (TER f)" by auto
	from split_list_last_prop[OF this] obtain ys z zs
	where decomp: "x # p = ys @ z # zs" and z: "z \<in> \<E> (TER f)"
	and outside: "\<And>z. z \<in> set zs \<Longrightarrow> z \<notin> \<E> (TER f)" by auto
	have zs: "path \<Gamma> z zs y" using decomp p
	by(cases ys)(auto elim: rtrancl_path_appendE)
	moreover have "z \<notin> RF\<^sup>\<circ> (TER f)" using z by(simp add: roofed_circ_def)
	moreover have RF: "z' \<notin> RF (TER f)" if "z' \<in> set zs" for z'
	proof
	assume "z' \<in> RF (TER f)"
	hence z': "z' \<in> RF (\<E> (TER f))" by(simp only: RF_essential)
	from split_list[OF that] obtain ys' zs' where decomp': "zs = ys' @ z' # zs'" by blast
	with zs have "path \<Gamma> z' zs' y" by(auto elim: rtrancl_path_appendE)
	from roofedD[OF z' this y] outside decomp' show False by auto
	qed
	ultimately have p': "path (quotient_web \<Gamma> f) z zs y" by(rule path_quotient_web)
	show ?thesis
	proof(cases "z \<in> B \<Gamma> - A \<Gamma>")
	case False
	with separatingD[OF waveD_separating[OF w'] p'] z y
	obtain z' where z': "z' \<in> set (z # zs)" and TER: "z' \<in> TER\<^bsub>quotient_web \<Gamma> f\<^esub> g" by auto
	hence "z' \<in> TER ?g" using in_TER_plus_current[of z'] RF[of z'] \<open>z \<notin> RF\<^sup>\<circ> (TER f)\<close> by(auto simp add: roofed_circ_def)
	with decomp z' show ?thesis by(cases ys) auto
	next
	case True
	hence "z \<in> TER ?g" using currentD_OUT[OF current_plus_current, of z] z
	by(auto simp add: SINK.simps SAT.simps IN_plus_current intro: roofed_greaterI)
	then show ?thesis using decomp by(cases ys) auto
	qed
	qed

	lemma wave_plus_current: "wave \<Gamma> (plus_current f g)" (is "wave _ ?g")
	proof
	let ?\<Gamma> = "quotient_web \<Gamma> f"
	let ?TER = "TER\<^bsub>?\<Gamma>\<^esub>"

	show "separating \<Gamma> (TER ?g)" using separating_TER_plus_current[OF wave_A_in_RF[OF w]] by(rule separating)

	fix x
	assume x: "x \<notin> RF (TER ?g)"
	hence "x \<notin> RF (TER f)" by(rule contrapos_nn)(rule roofedI, rule separating_TER_plus_current)
	hence *: "x \<notin> RF\<^sup>\<circ> (TER f)" by(simp add: roofed_circ_def)
	moreover have "x \<notin> RF\<^bsub>?\<Gamma>\<^esub> (?TER g)"
	proof
	assume RF': "x \<in> RF\<^bsub>?\<Gamma>\<^esub> (?TER g)"
	from x obtain p y where y: "y \<in> B \<Gamma>" and p: "path \<Gamma> x p y"
	and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> TER ?g" and x': "x \<notin> TER ?g"
	by(auto simp add: roofed_def)
	have RF: "z \<notin> RF (TER f)" if "z \<in> set p" for z
	proof
	assume z: "z \<in> RF (TER f)"
	from split_list[OF that] obtain ys' zs' where decomp: "p = ys' @ z # zs'" by blast
	with p have "path \<Gamma> z zs' y" by(auto elim: rtrancl_path_appendE)
	from separating_TER_plus_current[OF z y this] decomp bypass show False by auto
	qed
	with p have "path ?\<Gamma> x p y" using *
	by(induction)(auto intro: rtrancl_path.intros simp add: roofed_circ_def)
	from roofedD[OF RF' this] y consider (x) "x \<in> ?TER g" \| (z) z where "z \<in> set p" "z \<in> ?TER g" by auto
	then show False
	proof(cases)
	case x
	with * have "x \<in> TER ?g" by(rule in_TER_plus_current)
	with x' show False by contradiction
	next
	case (z z)
	from z(1) have "z \<notin> RF (TER f)" by(rule RF)
	hence "z \<notin> RF\<^sup>\<circ> (TER f)" by(simp add: roofed_circ_def)
	hence "z \<in> TER ?g" using z(2) by(rule in_TER_plus_current)
	moreover from z(1) have "z \<notin> TER ?g" by(rule bypass)
	ultimately show False by contradiction
	qed
	qed
	with w' have "d_OUT g x = 0" by(rule waveD_OUT)
	ultimately show "d_OUT ?g x = 0" by(simp add: OUT_plus_current)
	qed

	end

	end

	lemma loose_quotient_web:
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure)
	assumes weight_finite: "\<And>x. weight \<Gamma> x \<noteq> \<top>"
	and f: "current \<Gamma> f"
	and w: "wave \<Gamma> f"
	and maximal: "\<And>w. \<lbrakk> current \<Gamma> w; wave \<Gamma> w; f \<le> w \<rbrakk> \<Longrightarrow> f = w"
	shows "loose (quotient_web \<Gamma> f)" (is "loose ?\<Gamma>")
	proof
	fix g
	assume g: "current ?\<Gamma> g" and w': "wave ?\<Gamma> g"
	let ?g = "plus_current f g"
	from f w g have "current \<Gamma> ?g" "wave \<Gamma> ?g" by(rule current_plus_current wave_plus_current)+ (rule w')
	moreover have "f \<le> ?g" by(clarsimp simp add: le_fun_def add_eq_0_iff_both_eq_0)
	ultimately have eq: "f = ?g" by(rule maximal)
	have "g e = 0" for e
	proof(cases e)
	case (Pair x y)
	have "f e \<le> d_OUT f x" unfolding Pair by (rule d_OUT_ge_point)
	also have "\<dots> \<le> weight \<Gamma> x" by(rule currentD_weight_OUT[OF f])
	also have "\<dots> < \<top>" by(simp add: weight_finite less_top[symmetric])
	finally show "g e = 0" using Pair eq[THEN fun_cong, of e]
	by(cases "f e" "g e" rule: ennreal2_cases)(simp_all add: fun_eq_iff)
	qed
	thus "g = (\<lambda>_. 0)" by(simp add: fun_eq_iff)
	next
	- have 0: "current ?\<Gamma> zero_current" by(simp add: )
	+ have 0: "current ?\<Gamma> zero_current" bysimp
	show "\<not> hindrance ?\<Gamma> zero_current"
	proof
	assume "hindrance ?\<Gamma> zero_current"
	then obtain x where a: "x \<in> A ?\<Gamma>" and \<E>: "x \<notin> \<E>\<^bsub>?\<Gamma>\<^esub> (TER\<^bsub>?\<Gamma>\<^esub> zero_current)"
	and "d_OUT zero_current x < weight ?\<Gamma> x" by cases
	from a have "x \<in> \<E> (TER f)" by simp
	then obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>"
	and bypass: "\<And>z. \<lbrakk>x \<noteq> y; z \<in> set p\<rbrakk> \<Longrightarrow> z = x \<or> z \<notin> TER f" by(rule \<E>_E) blast
	from p obtain p' where p': "path \<Gamma> x p' y" and distinct: "distinct (x # p')"
	and subset: "set p' \<subseteq> set p" by(auto elim: rtrancl_path_distinct)
	note p'
	moreover have RF: "z \<notin> RF (TER f)" if "z \<in> set p'" for z
	proof
	assume z: "z \<in> RF (TER f)"
	from split_list[OF that] obtain ys zs where decomp: "p' = ys @ z # zs" by blast
	with p' have "y \<in> set p'" by(auto dest!: rtrancl_path_last intro: last_in_set)
	with distinct have neq: "x \<noteq> y" by auto
	from decomp p' have "path \<Gamma> z zs y" by(auto elim: rtrancl_path_appendE)
	from roofedD[OF z this y] obtain z' where "z' \<in> set (z # zs)" "z' \<in> TER f" by auto
	with distinct decomp subset bypass[OF neq] show False by auto
	qed
	moreover have "x \<notin> RF\<^sup>\<circ> (TER f)" using \<open>x \<in> \<E> (TER f)\<close> by(simp add: roofed_circ_def)
	ultimately have p'': "path ?\<Gamma> x p' y"
	by(induction)(auto intro: rtrancl_path.intros simp add: roofed_circ_def)
	from a \<E> have "\<not> essential ?\<Gamma> (B ?\<Gamma>) (TER\<^bsub>?\<Gamma>\<^esub> zero_current) x" by simp
	from not_essentialD[OF this p''] y obtain z where neq: "x \<noteq> y"
	and "z \<in> set p'" "z \<noteq> x" "z \<in> TER\<^bsub>?\<Gamma>\<^esub> zero_current" by auto
	moreover with subset RF[of z] have "z \<in> TER f"
	using currentD_weight_OUT[OF f, of z] currentD_weight_IN[OF f, of z]
	by(auto simp add: roofed_circ_def SINK.simps intro: SAT.IN split: if_split_asm)
	ultimately show False using bypass[of z] subset by auto
	qed
	qed

	lemma quotient_web_trimming:
	fixes \<Gamma> (structure)
	assumes w: "wave \<Gamma> f"
	and trimming: "trimming \<Gamma> f g"
	shows "quotient_web \<Gamma> f = quotient_web \<Gamma> g" (is "?lhs = ?rhs")
	proof(rule web.equality)
	from trimming have \<E>: "\<E> (TER g) - A \<Gamma> = \<E> (TER f) - A \<Gamma>" by cases

	have RF: "RF (TER g) = RF (TER f)"
	by(subst (1 2) RF_essential[symmetric])(simp only: trimming_\<E>[OF w trimming])
	have RFc: "RF\<^sup>\<circ> (TER g) = RF\<^sup>\<circ> (TER f)"
	by(subst (1 2) roofed_circ_essential[symmetric])(simp only: trimming_\<E>[OF w trimming])

	show "edge ?lhs = edge ?rhs" by(rule ext)+(simp add: RF RFc)
	have "weight ?lhs = (\<lambda>x. if x \<in> RF\<^sup>\<circ> (TER g) \<or> x \<in> RF (TER g) \<inter> B \<Gamma> then 0 else weight \<Gamma> x)"
	unfolding RF RFc by(auto simp add: fun_eq_iff RF_in_B)
	also have "\<dots> = weight ?rhs" by(auto simp add: fun_eq_iff RF_in_B)
	finally show "weight ?lhs = weight ?rhs" .

	show "A ?lhs = A ?rhs" unfolding quotient_web_sel trimming_\<E>[OF w trimming] ..
	qed simp_all

	subsection \<open>Well-formed webs\<close>

	locale web =
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure)
	assumes A_in: "x \<in> A \<Gamma> \<Longrightarrow> \<not> edge \<Gamma> y x"
	and B_out: "x \<in> B \<Gamma> \<Longrightarrow> \<not> edge \<Gamma> x y"
	and A_vertex: "A \<Gamma> \<subseteq> \<^bold>V"
	and disjoint: "A \<Gamma> \<inter> B \<Gamma> = {}"
	and no_loop: "\<And>x. \<not> edge \<Gamma> x x"
	and weight_outside: "\<And>x. x \<notin> \<^bold>V \<Longrightarrow> weight \<Gamma> x = 0"
	and weight_finite [simp]: "\<And>x. weight \<Gamma> x \<noteq> \<top>"
	begin

	lemma web_weight_update:
	assumes "\<And>x. \<not> vertex \<Gamma> x \<Longrightarrow> w x = 0"
	and "\<And>x. w x \<noteq> \<top>"
	shows "web (\<Gamma>\<lparr>weight := w\<rparr>)"
	by unfold_locales(simp_all add: A_in B_out A_vertex disjoint no_loop assms)

	lemma currentI [intro?]:
	assumes "\<And>x. d_OUT f x \<le> weight \<Gamma> x"
	and "\<And>x. d_IN f x \<le> weight \<Gamma> x"
	and OUT_IN: "\<And>x. \<lbrakk> x \<notin> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> d_OUT f x \<le> d_IN f x"
	and outside: "\<And>e. e \<notin> \<^bold>E \<Longrightarrow> f e = 0"
	shows "current \<Gamma> f"
	proof
	show "d_IN f a = 0" if "a \<in> A \<Gamma>" for a using that
	by(auto simp add: d_IN_def nn_integral_0_iff emeasure_count_space_eq_0 A_in intro: outside)
	show "d_OUT f b = 0" if "b \<in> B \<Gamma>" for b using that
	by(auto simp add: d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0 B_out intro: outside)
	then show "d_OUT f x \<le> d_IN f x" if "x \<notin> A \<Gamma>" for x using OUT_IN[OF that]
	by(cases "x \<in> B \<Gamma>") auto
	qed(blast intro: assms)+

	lemma currentD_finite_IN:
	assumes f: "current \<Gamma> f"
	shows "d_IN f x \<noteq> \<top>"
	proof(cases "x \<in> \<^bold>V")
	case True
	have "d_IN f x \<le> weight \<Gamma> x" using f by(rule currentD_weight_IN)
	also have "\<dots> < \<top>" using True weight_finite[of x] by (simp add: less_top[symmetric])
	finally show ?thesis by simp
	next
	case False
	then have "d_IN f x = 0"
	by(auto simp add: d_IN_def nn_integral_0_iff emeasure_count_space_eq_0 vertex_def intro: currentD_outside[OF f])
	thus ?thesis by simp
	qed

	lemma currentD_finite_OUT:
	assumes f: "current \<Gamma> f"
	shows "d_OUT f x \<noteq> \<top>"
	proof(cases "x \<in> \<^bold>V")
	case True
	have "d_OUT f x \<le> weight \<Gamma> x" using f by(rule currentD_weight_OUT)
	also have "\<dots> < \<top>" using True weight_finite[of x] by (simp add: less_top[symmetric])
	finally show ?thesis by simp
	next
	case False
	then have "d_OUT f x = 0"
	by(auto simp add: d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0 vertex_def intro: currentD_outside[OF f])
	thus ?thesis by simp
	qed

	lemma currentD_finite:
	assumes f: "current \<Gamma> f"
	shows "f e \<noteq> \<top>"
	proof(cases e)
	case (Pair x y)
	have "f (x, y) \<le> d_OUT f x" by (rule d_OUT_ge_point)
	also have "\<dots> < \<top>" using currentD_finite_OUT[OF f] by (simp add: less_top[symmetric])
	finally show ?thesis by(simp add: Pair)
	qed

	lemma web_quotient_web: "web (quotient_web \<Gamma> f)" (is "web ?\<Gamma>")
	proof
	show "\<not> edge ?\<Gamma> y x" if "x \<in> A ?\<Gamma>" for x y using that by(auto intro: roofed_greaterI)
	show "\<not> edge ?\<Gamma> x y" if "x \<in> B ?\<Gamma>" for x y using that by(auto simp add: B_out)
	show "A ?\<Gamma> \<inter> B ?\<Gamma> = {}" using disjoint by auto
	show "A ?\<Gamma> \<subseteq> \<^bold>V\<^bsub>?\<Gamma>\<^esub>"
	proof
	fix x
	assume "x \<in> A ?\<Gamma>"
	hence \<E>: "x \<in> \<E> (TER f)" and x: "x \<notin> B \<Gamma>" using disjoint by auto
	from this(1) obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)"
	by(rule \<E>_E_RF) blast
	from p y x have "p \<noteq> []" by(auto simp add: rtrancl_path_simps)
	with rtrancl_path_nth[OF p, of 0] have "edge \<Gamma> x (p ! 0)" by simp
	moreover have "x \<notin> RF\<^sup>\<circ> (TER f)" using \<E> by(simp add: roofed_circ_def)
	moreover have "p ! 0 \<notin> RF (TER f)" using bypass \<open>p \<noteq> []\<close> by auto
	ultimately have "edge ?\<Gamma> x (p ! 0)" by simp
	thus "x \<in> \<^bold>V\<^bsub>?\<Gamma>\<^esub>" by(auto intro: vertexI1)
	qed
	show "\<not> edge ?\<Gamma> x x" for x by(simp add: no_loop)
	show "weight ?\<Gamma> x = 0" if "x \<notin> \<^bold>V\<^bsub>?\<Gamma>\<^esub>" for x
	proof(cases "x \<in> RF\<^sup>\<circ> (TER f) \<or> x \<in> TER f \<inter> B \<Gamma>")
	case True thus ?thesis by simp
	next
	case False
	hence RF: "x \<notin> RF\<^sup>\<circ> (TER f)" and B: "x \<in> B \<Gamma> \<Longrightarrow> x \<notin> TER f" by auto
	from RF obtain p y where p: "path \<Gamma> x p y" and y: "y \<in> B \<Gamma>" and bypass: "\<And>z. z \<in> set p \<Longrightarrow> z \<notin> RF (TER f)"
	apply(cases "x \<notin> RF (RF (TER f))")
	apply(auto elim!: not_roofedE)[1]
	apply(auto simp add: roofed_circ_def roofed_idem elim: essentialE_RF)
	done
	from that have "p = []" using p y B RF bypass
	by(auto 4 3 simp add: vertex_def dest!: rtrancl_path_nth[where i=0])
	with p have xy: "x = y" by(simp add: rtrancl_path_simps)
	with B y have "x \<notin> TER f" by simp
	hence RF': "x \<notin> RF (TER f)" using xy y by(subst RF_in_B) auto
	have "\<not> vertex \<Gamma> x"
	proof
	assume "vertex \<Gamma> x"
	then obtain x' where "edge \<Gamma> x' x" using xy y by(auto simp add: vertex_def B_out)
	moreover hence "x' \<notin> RF\<^sup>\<circ> (TER f)" using RF' by(auto dest: RF_circ_edge_forward)
	ultimately have "edge ?\<Gamma> x' x" using RF' by simp
	hence "vertex ?\<Gamma> x" by(rule vertexI2)
	with that show False by simp
	qed
	thus ?thesis by(simp add: weight_outside)
	qed
	show "weight ?\<Gamma> x \<noteq> \<top>" for x by simp
	qed

	end

	locale countable_web = web \<Gamma>
	for \<Gamma> :: "('v, 'more) web_scheme" (structure)
	+
	assumes countable [simp]: "countable \<^bold>E"
	begin

	lemma countable_V [simp]: "countable \<^bold>V"
	by(simp add: "\<^bold>V_def")

	lemma countable_web_quotient_web: "countable_web (quotient_web \<Gamma> f)" (is "countable_web ?\<Gamma>")
	proof -
	interpret r: web ?\<Gamma> by(rule web_quotient_web)
	show ?thesis
	proof
	have "\<^bold>E\<^bsub>?\<Gamma>\<^esub> \<subseteq> \<^bold>E" by auto
	then show "countable \<^bold>E\<^bsub>?\<Gamma>\<^esub>" by(rule countable_subset) simp
	qed
	qed

	end

	subsection \<open>Subtraction of a wave\<close>

	definition minus_web :: "('v, 'more) web_scheme \<Rightarrow> 'v current \<Rightarrow> ('v, 'more) web_scheme" (infixl "\<ominus>" 65) \<comment> \<open>Definition 6.6\<close>
	where "\<Gamma> \<ominus> f = \<Gamma>\<lparr>weight := \<lambda>x. if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT f x else weight \<Gamma> x + d_OUT f x - d_IN f x\<rparr>"

	lemma minus_web_sel [simp]:
	"edge (\<Gamma> \<ominus> f) = edge \<Gamma>"
	"weight (\<Gamma> \<ominus> f) x = (if x \<in> A \<Gamma> then weight \<Gamma> x - d_OUT f x else weight \<Gamma> x + d_OUT f x - d_IN f x)"
	"A (\<Gamma> \<ominus> f) = A \<Gamma>"
	"B (\<Gamma> \<ominus> f) = B \<Gamma>"
	"\<^bold>V\<^bsub>\<Gamma> \<ominus> f\<^esub> = \<^bold>V\<^bsub>\<Gamma>\<^esub>"
	"\<^bold>E\<^bsub>\<Gamma> \<ominus> f\<^esub> = \<^bold>E\<^bsub>\<Gamma>\<^esub>"
	"web.more (\<Gamma> \<ominus> f) = web.more \<Gamma>"
	by(auto simp add: minus_web_def vertex_def)

	lemma vertex_minus_web [simp]: "vertex (\<Gamma> \<ominus> f) = vertex \<Gamma>"
	by(simp add: vertex_def fun_eq_iff)

	lemma roofed_gen_minus_web [simp]: "roofed_gen (\<Gamma> \<ominus> f) = roofed_gen \<Gamma>"
	by(simp add: fun_eq_iff roofed_def)

	lemma minus_zero_current [simp]: "\<Gamma> \<ominus> zero_current = \<Gamma>"
	by(rule web.equality)(simp_all add: fun_eq_iff)

	lemma (in web) web_minus_web:
	assumes f: "current \<Gamma> f"
	shows "web (\<Gamma> \<ominus> f)"
	unfolding minus_web_def
	apply(rule web_weight_update)
	apply(auto simp: weight_outside currentD_weight_IN[OF f] currentD_outside_OUT[OF f]
	currentD_outside_IN[OF f] currentD_weight_OUT[OF f] currentD_finite_OUT[OF f])
	done

	subsection \<open>Bipartite webs\<close>

	locale countable_bipartite_web =
	fixes \<Gamma> :: "('v, 'more) web_scheme" (structure)
	assumes bipartite_V: "\<^bold>V \<subseteq> A \<Gamma> \<union> B \<Gamma>"
	and A_vertex: "A \<Gamma> \<subseteq> \<^bold>V"
	and bipartite_E: "edge \<Gamma> x y \<Longrightarrow> x \<in> A \<Gamma> \<and> y \<in> B \<Gamma>"
	and disjoint: "A \<Gamma> \<inter> B \<Gamma> = {}"
	and weight_outside: "\<And>x. x \<notin> \<^bold>V \<Longrightarrow> weight \<Gamma> x = 0"
	and weight_finite [simp]: "\<And>x. weight \<Gamma> x \<noteq> \<top>"
	and countable_E [simp]: "countable \<^bold>E"
	begin

	lemma not_vertex: "\<lbrakk> x \<notin> A \<Gamma>; x \<notin> B \<Gamma> \<rbrakk> \<Longrightarrow> \<not> vertex \<Gamma> x"
	using bipartite_V by blast

	lemma no_loop: "\<not> edge \<Gamma> x x"
	using disjoint by(auto dest: bipartite_E)

	lemma edge_antiparallel: "edge \<Gamma> x y \<Longrightarrow> \<not> edge \<Gamma> y x"
	using disjoint by(auto dest: bipartite_E)

	lemma A_in: "x \<in> A \<Gamma> \<Longrightarrow> \<not> edge \<Gamma> y x"
	using disjoint by(auto dest: bipartite_E)

	lemma B_out: "x \<in> B \<Gamma> \<Longrightarrow> \<not> edge \<Gamma> x y"
	using disjoint by(auto dest: bipartite_E)

	sublocale countable_web using disjoint
	by(unfold_locales)(auto simp add: A_in B_out A_vertex no_loop weight_outside)

	lemma currentD_OUT':
	assumes f: "current \<Gamma> f"
	and x: "x \<notin> A \<Gamma>"
	shows "d_OUT f x = 0"
	using currentD_outside_OUT[OF f, of x] x currentD_OUT[OF f, of x] bipartite_V by auto

	lemma currentD_IN':
	assumes f: "current \<Gamma> f"
	and x: "x \<notin> B \<Gamma>"
	shows "d_IN f x = 0"
	using currentD_outside_IN[OF f, of x] x currentD_IN[OF f, of x] bipartite_V by auto

	lemma current_bipartiteI [intro?]:
	assumes OUT: "\<And>x. d_OUT f x \<le> weight \<Gamma> x"
	and IN: "\<And>x. d_IN f x \<le> weight \<Gamma> x"
	and outside: "\<And>e. e \<notin> \<^bold>E \<Longrightarrow> f e = 0"
	shows "current \<Gamma> f"
	proof
	fix x
	assume "x \<notin> A \<Gamma>" "x \<notin> B \<Gamma>"
	hence "d_OUT f x = 0" by(auto simp add: d_OUT_def nn_integral_0_iff emeasure_count_space_eq_0 intro!: outside dest: bipartite_E)
	then show "d_OUT f x \<le> d_IN f x" by simp
	qed(rule OUT IN outside)+

	lemma wave_bipartiteI [intro?]:
	assumes sep: "separating \<Gamma> (TER f)"
	and f: "current \<Gamma> f"
	shows "wave \<Gamma> f"
	using sep
	proof(rule wave.intros)
	fix x
	assume "x \<notin> RF (TER f)"
	then consider "x \<notin> \<^bold>V" \| "x \<in> \<^bold>V" "x \<in> B \<Gamma>" using separating_RF_A[OF sep] bipartite_V by auto
	then show "d_OUT f x = 0" using currentD_OUT[OF f, of x] currentD_outside_OUT[OF f, of x]
	by cases auto
	qed


	lemma web_flow_iff: "web_flow \<Gamma> f \<longleftrightarrow> current \<Gamma> f"
	using bipartite_V by(auto simp add: web_flow.simps)

	end

	end
	diff --git a/thys/Markov_Models/Continuous_Time_Markov_Chain.thy b/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
	--- a/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
	+++ b/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
	@@ -1,1464 +1,1464 @@
	(* Author: Johannes Hölzl <hoelzl@in.tum.de> *)

	section \<open>Continuous-time Markov chains\<close>

	theory Continuous_Time_Markov_Chain
	imports Discrete_Time_Markov_Process Discrete_Time_Markov_Chain
	begin

	subsection \<open>Trace Operations: relate @{typ "('a \<times> real) stream"} and @{typ "real \<Rightarrow> 'a"}\<close>

	partial_function (tailrec) trace_at :: "'a \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> real \<Rightarrow> 'a"
	where
	"trace_at s \<omega> j = (case \<omega> of (t', s')##\<omega> \<Rightarrow> if t' \<le> j then trace_at s' \<omega> j else s)"

	lemma trace_at_simp[simp]: "trace_at s ((t', s')##\<omega>) j = (if t' \<le> j then trace_at s' \<omega> j else s)"
	by (subst trace_at.simps) simp

	lemma trace_at_eq:
	"trace_at s \<omega> j = (case sfirst (\<lambda>x. j < fst (shd x)) \<omega> of \<infinity> \<Rightarrow> undefined \| enat i \<Rightarrow> (s ## smap snd \<omega>) !! i)"
	proof (split enat.split; safe)
	assume "sfirst (\<lambda>x. j < fst (shd x)) \<omega> = \<infinity>"
	with sfirst_finite[of "\<lambda>x. j < fst (shd x)" \<omega>]
	have "alw (\<lambda>x. fst (shd x) \<le> j) \<omega>"
	by (simp add: not_ev_iff not_less)
	then show "trace_at s \<omega> j = undefined"
	by (induction arbitrary: s \<omega> rule: trace_at.fixp_induct) (auto split: stream.split)
	next
	show "sfirst (\<lambda>x. j < fst (shd x)) \<omega> = enat n \<Longrightarrow> trace_at s \<omega> j = (s ## smap snd \<omega>) !! n" for n
	proof (induction n arbitrary: s \<omega>)
	case 0 then show ?case
	by (subst trace_at.simps) (auto simp add: enat_0 sfirst_eq_0 split: stream.split)
	next
	case (Suc n) show ?case
	using sfirst.simps[of "\<lambda>x. j < fst (shd x)" \<omega>] Suc.prems Suc.IH[of "stl \<omega>" "snd (shd \<omega>)"]
	by (cases \<omega>) (auto simp add: eSuc_enat[symmetric] split: stream.split if_split_asm)
	qed
	qed

	lemma trace_at_shift: "trace_at s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>) t = trace_at s \<omega> (t - t')"
	by (induction arbitrary: s \<omega> rule: trace_at.fixp_induct) (auto split: stream.split)

	primcorec merge_at :: "(real \<times> 'a) stream \<Rightarrow> real \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> (real \<times> 'a) stream"
	where
	"merge_at \<omega> j \<omega>' = (case \<omega> of (t, s) ## \<omega> \<Rightarrow> if t \<le> j then (t, s)##merge_at \<omega> j \<omega>' else \<omega>')"

	lemma merge_at_simp[simp]: "merge_at (x##\<omega>) j \<omega>' = (if fst x \<le> j then x##merge_at \<omega> j \<omega>' else \<omega>')"
	by (cases x) (subst merge_at.code; simp)

	subsection \<open>Exponential Distribution\<close>

	definition exponential :: "real \<Rightarrow> real measure"
	where
	"exponential l = density lborel (exponential_density l)"

	lemma space_exponential: "space (exponential l) = UNIV"
	by (simp add: exponential_def)

	lemma sets_exponential[measurable_cong]: "sets (exponential l) = sets borel"
	by (simp add: exponential_def)

	lemma prob_space_exponential: "0 < l \<Longrightarrow> prob_space (exponential l)"
	unfolding exponential_def by (intro prob_space_exponential_density)

	lemma AE_exponential: "0 < l \<Longrightarrow> AE x in exponential l. 0 < x"
	unfolding exponential_def using AE_lborel_singleton[of 0] by (auto simp add: AE_density exponential_density_def)

	lemma emeasure_exponential_Ioi_cutoff:
	assumes "0 < l"
	shows "emeasure (exponential l) {x <..} = exp (- (max 0 x) * l)"
	proof -
	interpret prob_space "exponential l"
	unfolding exponential_def using \<open>0<l\<close> by (rule prob_space_exponential_density)
	have : "prob {xa \<in> space (exponential l). max 0 x < xa} = exp (- max 0 x l)"
	apply (rule exponential_distributedD_gt[OF _ _ \<open>0<l\<close>])
	apply (auto simp: exponential_def distributed_def)
	apply (subst (6) distr_id[symmetric])
	apply (subst (2) distr_cong)
	apply simp_all
	done
	have "emeasure (exponential l) {x <..} = emeasure (exponential l) {max 0 x <..}"
	using AE_exponential[OF \<open>0<l\<close>] by (intro emeasure_eq_AE) auto
	also have "\<dots> = exp (- (max 0 x) * l)"
	using * unfolding emeasure_eq_measure by (simp add: space_exponential greaterThan_def)
	finally show ?thesis .
	qed

	lemma emeasure_exponential_Ioi:
	"0 < l \<Longrightarrow> 0 \<le> x \<Longrightarrow> emeasure (exponential l) {x <..} = exp (- x * l)"
	using emeasure_exponential_Ioi_cutoff[of l x] by simp

	lemma exponential_eq_stretch:
	assumes "0 < l"
	shows "exponential l = distr (exponential 1) borel (\<lambda>x. (1/l) * x)"
	proof (intro measure_eqI)
	fix A assume "A \<in> sets (exponential l)"
	then have [measurable]: "A \<in> sets borel"
	by (simp add: sets_exponential)
	then have [measurable]: "(\<lambda>x. x / l) -` A \<in> sets borel"
	by (rule measurable_sets_borel[rotated]) simp
	have "emeasure (exponential l) A =
	(\<integral>\<^sup>+x. ennreal l * (indicator ((() (1/l) -` A) \<inter> {0 ..}) (l x) * ennreal (exp (- (l * x)))) \<partial>lborel)"
	using \<open>0 < l\<close>
	by (auto simp: ac_simps emeasure_distr exponential_def emeasure_density exponential_density_def
	ennreal_mult zero_le_mult_iff
	intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = (\<integral>\<^sup>+x. indicator ((() (1/l) -` A) \<inter> {0 ..}) x ennreal (exp (- x)) \<partial>lborel)"
	using \<open>0<l\<close>
	apply (subst nn_integral_stretch)
	apply (auto simp: nn_integral_cmult)
	apply (simp add: ennreal_mult[symmetric] mult.assoc[symmetric])
	done
	also have "\<dots> = emeasure (distr (exponential 1) borel (\<lambda>x. (1/l) * x)) A"
	by (auto simp add: emeasure_distr exponential_def emeasure_density exponential_density_def
	intro!: nn_integral_cong split: split_indicator)
	finally show "emeasure (exponential l) A = emeasure (distr (exponential 1) borel (\<lambda>x. (1/l) * x)) A" .
	qed (simp add: sets_exponential)

	lemma uniform_measure_exponential:
	assumes "0 < l" "0 \<le> t"
	shows "uniform_measure (exponential l) {t <..} = distr (exponential l) borel ((+) t)" (is "?L = ?R")
	proof (rule measure_eqI_lessThan)
	fix x
	have "0 < emeasure (exponential l) {t<..}"
	unfolding emeasure_exponential_Ioi[OF assms] by simp
	with assms show "?L {x<..} < \<infinity>"
	by (simp add: ennreal_divide_eq_top_iff less_top[symmetric] lessThan_Int_lessThan
	emeasure_exponential_Ioi)
	have *: "((+) t -` {x<..} \<inter> space (exponential l)) = {x - t <..}"
	by (auto simp: space_exponential)
	show "?L {x<..} = ?R {x<..}"
	using assms by (simp add: lessThan_Int_lessThan emeasure_exponential_Ioi divide_ennreal
	emeasure_distr * emeasure_exponential_Ioi_cutoff exp_diff[symmetric] field_simps split: split_max)
	qed (auto simp: sets_exponential)

	lemma emeasure_PiM_exponential_Ioi_finite:
	assumes "J \<subseteq> I" "finite J" "\<And>i. i \<in> I \<Longrightarrow> 0 < R i" "0 \<le> x"
	shows "emeasure (\<Pi>\<^sub>M i\<in>I. exponential (R i)) (prod_emb I (\<lambda>i. exponential (R i)) J (\<Pi>\<^sub>E j\<in>J. {x<..})) = exp (- x * (\<Sum>i\<in>J. R i))"
	proof (subst emeasure_PiM_emb)
	from assms show "(\<Prod>i\<in>J. emeasure (exponential (R i)) {x<..}) = ennreal (exp (- x * sum R J))"
	by (subst prod.cong[OF refl emeasure_exponential_Ioi])
	(auto simp add: prod_ennreal exp_sum sum_negf[symmetric] sum_distrib_left)
	qed (insert assms, auto intro!: prob_space_exponential)

	lemma emeasure_PiM_exponential_Ioi_sequence:
	assumes R: "summable R" "\<And>i. 0 < R i" "0 \<le> x"
	shows "emeasure (\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (\<Pi> i\<in>UNIV. {x<..}) = exp (- x * suminf R)"
	proof -
	let ?R = "\<lambda>i. exponential (R i)" let ?P = "\<Pi>\<^sub>M i\<in>UNIV. ?R i"
	let ?N = "\<lambda>n::nat. prod_emb UNIV ?R {..<n} (\<Pi>\<^sub>E i\<in>{..<n}. {x<..})"
	interpret prob_space ?P
	by (intro prob_space_PiM prob_space_exponential R)
	have "(\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (\<Inter>n. ?N n) = (INF n. (\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (?N n))"
	by (intro INF_emeasure_decseq[symmetric] decseq_emb_PiE) (auto simp: incseq_def)
	also have "\<dots> = (INF n. ennreal (exp (- x * (\<Sum>i<n. R i))))"
	using R by (intro INF_cong emeasure_PiM_exponential_Ioi_finite) auto
	also have "\<dots> = ennreal (exp (- x * (SUP n. (\<Sum>i<n. R i))))"
	using R
	by (subst continuous_at_Sup_antimono[where f="\<lambda>r. ennreal (exp (- x * r))"])
	(auto intro!: bdd_aboveI2[where M="\<Sum>i. R i"] sum_le_suminf summable_mult mult_left_mono
	continuous_mult continuous_at_ennreal continuous_within_exp[THEN continuous_within_compose3] continuous_minus
	simp: less_imp_le antimono_def image_comp)
	also have "\<dots> = ennreal (exp (- x * (\<Sum>i. R i)))"
	using R by (subst suminf_eq_SUP_real) (auto simp: less_imp_le)
	also have "(\<Inter>n. ?N n) = (\<Pi> i\<in>UNIV. {x<..})"
	by (fastforce simp: prod_emb_def Pi_iff PiE_iff space_exponential)
	finally show ?thesis
	using R by simp
	qed

	lemma emeasure_PiM_exponential_Ioi_countable:
	assumes R: "J \<subseteq> I" "countable J" "\<And>i. i \<in> I \<Longrightarrow> 0 < R i" "0 \<le> x" and finite: "integrable (count_space J) R"
	shows "emeasure (\<Pi>\<^sub>M i\<in>I. exponential (R i)) (prod_emb I (\<lambda>i. exponential (R i)) J (\<Pi>\<^sub>E j\<in>J. {x<..})) =
	exp (- x * (LINT i\|count_space J. R i))"
	proof cases
	assume "finite J" with assms show ?thesis
	by (subst emeasure_PiM_exponential_Ioi_finite)
	(auto simp: lebesgue_integral_count_space_finite)
	next
	assume "infinite J"
	let ?R = "\<lambda>i. exponential (R i)" let ?P = "\<Pi>\<^sub>M i\<in>I. ?R i"
	define f where "f = from_nat_into J"
	have J_eq: "J = range f" and f: "inj f" "f \<in> UNIV \<rightarrow> I"
	using from_nat_into_inj_infinite[of J] range_from_nat_into[of J] \<open>countable J\<close> \<open>infinite J\<close> \<open>J \<subseteq> I\<close>
	by (auto simp: inj_on_def f_def simp del: range_from_nat_into)
	have Bf: "bij_betw f UNIV J"
	unfolding J_eq using inj_on_imp_bij_betw[OF f(1)] .

	have summable_R: "summable (\<lambda>i. R (f i))"
	using finite unfolding integrable_bij_count_space[OF Bf, symmetric] integrable_count_space_nat_iff
	by (rule summable_norm_cancel)

	have "emeasure (\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) (\<Pi> i\<in>UNIV. {x<..}) = exp (- x * (\<Sum>i. R (f i)))"
	using finite assms unfolding J_eq by (intro emeasure_PiM_exponential_Ioi_sequence[OF summable_R]) auto
	also have "(\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) = distr ?P (\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) (\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i))"
	using R by (intro distr_PiM_reindex[symmetric, OF _ f] prob_space_exponential) auto
	also have "\<dots> (\<Pi> i\<in>UNIV. {x<..}) = ?P ((\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i)) -` (\<Pi> i\<in>UNIV. {x<..}) \<inter> space ?P)"
	using f(2) by (intro emeasure_distr infprod_in_sets) (auto simp: Pi_iff)
	also have "(\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i)) -` (\<Pi> i\<in>UNIV. {x<..}) \<inter> space ?P = prod_emb I ?R J (\<Pi>\<^sub>E j\<in>J. {x<..})"
	by (auto simp: prod_emb_def space_PiM space_exponential Pi_iff J_eq)
	also have "(\<Sum>i. R (f i)) = (LINT i\|count_space J. R i)"
	using finite
	by (subst integral_count_space_nat[symmetric])
	(auto simp: integrable_bij_count_space[OF Bf] integral_bij_count_space[OF Bf])
	finally show ?thesis .
	qed

	lemma AE_PiM_exponential_suminf_infty:
	fixes R :: "nat \<Rightarrow> real"
	assumes R: "\<And>n. 0 < R n" and finite: "(\<Sum>n. ennreal (1 / R n)) = top"
	shows "AE \<omega> in \<Pi>\<^sub>M n\<in>UNIV. exponential (R n). (\<Sum>n. ereal (\<omega> n)) = \<infinity>"
	proof -
	let ?P = "\<Pi>\<^sub>M n\<in>UNIV. exponential (R n)"
	interpret prob_space "exponential (R n)" for n
	by (intro prob_space_exponential R)
	interpret product_prob_space "\<lambda>n. exponential (R n)" UNIV
	proof qed

	have AE_pos: "AE \<omega> in ?P. \<forall>i. 0 < \<omega> i"
	unfolding AE_all_countable by (intro AE_PiM_component allI prob_space_exponential R AE_exponential) simp

	have indep: "indep_vars (\<lambda>i. borel) (\<lambda>i x. x i) UNIV"
	using PiM_component
	apply (subst P.indep_vars_iff_distr_eq_PiM)
	apply (auto simp: restrict_UNIV distr_id2)
	apply (subst distr_id2)
	apply (intro sets_PiM_cong)
	apply (auto simp: sets_exponential cong: distr_cong)
	done

	have [simp]: "0 \<le> x + x * R i \<longleftrightarrow> 0 \<le> x" for x i
	using zero_le_mult_iff[of x "1 + R i"] R[of i] by (simp add: field_simps)

	have "(\<integral>\<^sup>+\<omega>. eexp (\<Sum>n. - ereal (\<omega> n)) \<partial>?P) = (\<integral>\<^sup>+\<omega>. (INF n. \<Prod>i<n. eexp (- ereal (\<omega> i))) \<partial>?P)"
	proof (intro nn_integral_cong_AE, use AE_pos in eventually_elim)
	fix \<omega> :: "nat \<Rightarrow> real" assume \<omega>: "\<forall>i. 0 < \<omega> i"
	show "eexp (\<Sum>n. - ereal (\<omega> n)) = (\<Sqinter>n. \<Prod>i<n. eexp (- ereal (\<omega> i)))"
	proof (rule LIMSEQ_unique[OF _ LIMSEQ_INF])
	show "(\<lambda>i. \<Prod>i<i. eexp (- ereal (\<omega> i))) \<longlonglongrightarrow> eexp (\<Sum>n. - ereal (\<omega> n))"
	using \<omega> by (intro eexp_suminf summable_minus_ereal summable_ereal_pos) (auto intro: less_imp_le)
	show "decseq (\<lambda>n. \<Prod>i<n. eexp (- ereal (\<omega> i)))"
	using \<omega> by (auto simp: decseq_def intro!: prod_mono3 intro: less_imp_le)
	qed
	qed
	also have "\<dots> = (INF n. (\<integral>\<^sup>+\<omega>. (\<Prod>i<n. eexp (- ereal (\<omega> i))) \<partial>?P))"
	proof (intro nn_integral_monotone_convergence_INF_AE')
	show "AE \<omega> in ?P. (\<Prod>i<Suc n. eexp (- ereal (\<omega> i))) \<le> (\<Prod>i<n. eexp (- ereal (\<omega> i)))" for n
	using AE_pos
	proof eventually_elim
	case (elim \<omega>)
	show ?case
	by (rule prod_mono3) (auto simp: elim le_less)
	qed
	qed (auto simp: less_top[symmetric])
	also have "\<dots> = (INF n. (\<Prod>i<n. (\<integral>\<^sup>+\<omega>. eexp (- ereal (\<omega> i)) \<partial>?P)))"
	proof (intro INF_cong refl indep_vars_nn_integral)
	show "indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. eexp (- ereal (\<omega> i))) {..<n}" for n
	proof (rule indep_vars_compose2[of _ _ _ "\<lambda>i x. eexp(- ereal x)"])
	show "indep_vars (\<lambda>i. borel) (\<lambda>i x. x i) {..<n}"
	by (rule indep_vars_subset[OF indep]) auto
	qed auto
	qed auto
	also have "\<dots> = (INF n. (\<Prod>i<n. R i * (\<integral>\<^sup>+x. indicator {0 ..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) \<partial>lborel)))"
	by (subst product_nn_integral_component)
	(auto simp: field_simps exponential_def nn_integral_density ennreal_mult'[symmetric] ennreal_mult''[symmetric]
	exponential_density_def exp_diff exp_minus nn_integral_cmult[symmetric]
	intro!: INF_cong prod.cong nn_integral_cong split: split_indicator)
	also have "\<dots> = (INF n. (\<Prod>i<n. ennreal (R i / (1 + R i))))"
	proof (intro INF_cong prod.cong refl)
	show "R i * (\<integral>\<^sup>+ x. indicator {0..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) \<partial>lborel) =
	ennreal (R i / (1 + R i))" for i
	using nn_intergal_power_times_exp_Ici[of 0] \<open>0 < R i\<close>
	by (subst nn_integral_stretch[where c="1 + R i"])
	(auto simp: mult.assoc[symmetric] ennreal_mult''[symmetric] less_imp_le mult.commute)
	qed
	also have "\<dots> = (INF n. ennreal (\<Prod>i<n. R i / (1 + R i)))"
	using R by (intro INF_cong refl prod_ennreal divide_nonneg_nonneg) (auto simp: less_imp_le)
	also have "\<dots> = (INF n. ennreal (inverse (\<Prod>i<n. (1 + R i) / R i)))"
	by (subst prod_inversef[symmetric]) simp_all
	also have "\<dots> = (INF n. inverse (ennreal (\<Prod>i<n. (1 + R i) / R i)))"
	using R by (subst inverse_ennreal) (auto intro!: prod_pos divide_pos_pos simp: add_pos_pos)
	also have "\<dots> = inverse (SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i))"
	by (subst continuous_at_Sup_antimono [where f = inverse])
	(auto simp: antimono_def image_comp intro!: continuous_on_imp_continuous_within[OF continuous_on_inverse_ennreal'])
	also have "(SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i)) = top"
	proof (cases "SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i)")
	case (real r)
	have "(\<lambda>n. ennreal (\<Prod>i<n. (1 + R i) / R i)) \<longlonglongrightarrow> r"
	using R unfolding real(2)[symmetric]
	by (intro LIMSEQ_SUP monoI ennreal_leI prod_mono2) (auto intro!: divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le)
	then have "(\<lambda>n. (\<Prod>i<n. (1 + R i) / R i)) \<longlonglongrightarrow> r"
	by (rule tendsto_ennrealD)
	(use R real in \<open>auto intro!: always_eventually prod_nonneg divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le\<close>)
	moreover have "(1 + R i) / R i = 1 / R i + 1" for i
	using \<open>0 < R i\<close> by (auto simp: field_simps)
	ultimately have "convergent (\<lambda>n. \<Prod>i<n. 1 / R i + 1)"
	by (auto simp: convergent_def)
	then have "summable (\<lambda>i. 1 / R i)"
	using R by (subst summable_iff_convergent_prod) (auto intro: less_imp_le)
	moreover have "0 \<le> 1 / R i" for i
	using R by (auto simp: less_imp_le)
	ultimately show ?thesis
	using finite ennreal_suminf_neq_top[of "\<lambda>i. 1 / R i"] by blast
	qed
	finally have "(\<integral>\<^sup>+\<omega>. eexp (\<Sum>n. - ereal (\<omega> n)) \<partial>?P) = 0"
	by simp
	then have "AE \<omega> in ?P. eexp (\<Sum>n. - ereal (\<omega> n)) = 0"
	by (subst (asm) nn_integral_0_iff_AE) auto
	then show ?thesis
	using AE_pos
	proof eventually_elim
	show "(\<forall>i. 0 < \<omega> i) \<Longrightarrow> eexp (\<Sum>n. - ereal (\<omega> n)) = 0 \<Longrightarrow> (\<Sum>n. ereal (\<omega> n)) = \<infinity>" for \<omega>
	apply (auto simp del: uminus_ereal.simps simp add: uminus_ereal.simps[symmetric]
	intro!: summable_iff_suminf_neq_top intro: less_imp_le)
	apply (subst (asm) suminf_minus_ereal)
	apply (auto intro!: summable_ereal_pos intro: less_imp_le)
	done
	qed
	qed

	subsection \<open>Transition Rates\<close>

	locale transition_rates =
	fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> real"
	assumes R_nonneg[simp]: "\<And>x y. 0 \<le> R x y"
	assumes R_diagonal_0[simp]: "\<And>x. R x x = 0"
	assumes finite_weight: "\<And>x. (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV) < \<infinity>"
	assumes positive_weight: "\<And>x. 0 < (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV)"
	begin

	abbreviation S :: "(real \<times> 'a) measure"
	where "S \<equiv> (borel \<Otimes>\<^sub>M count_space UNIV)"

	abbreviation T :: "(real \<times> 'a) stream measure"
	where "T \<equiv> stream_space S"

	abbreviation I :: "'a \<Rightarrow> 'a set"
	where "I x \<equiv> {y. 0 < R x y}"

	lemma I_countable: "countable (I x)"
	proof -
	let ?P = "point_measure UNIV (R x)"
	interpret finite_measure ?P
	proof
	show "emeasure ?P (space ?P) \<noteq> \<infinity>"
	using finite_weight
	by (simp add: emeasure_density point_measure_def less_top)
	qed
	from countable_support emeasure_point_measure_finite2[of "{_}" UNIV "R x"]
	show ?thesis
	by (simp add: emeasure_eq_measure less_le)
	qed

	definition escape_rate :: "'a \<Rightarrow> real" where
	"escape_rate x = \<integral>y. R x y \<partial>count_space UNIV"

	lemma ennreal_escape_rate: "ennreal (escape_rate x) = (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV)"
	using finite_weight[of x] unfolding escape_rate_def
	by (intro nn_integral_eq_integral[symmetric]) (auto simp: integrable_iff_bounded)

	lemma escape_rate_pos: "0 < escape_rate x"
	using positive_weight unfolding ennreal_escape_rate[symmetric] by simp

	lemma nonneg_escape_rate[simp]: "0 \<le> escape_rate x"
	using escape_rate_pos[THEN less_imp_le] .

	lemma prob_space_exponential_escape_rate: "prob_space (exponential (escape_rate x))"
	using escape_rate_pos by (rule prob_space_exponential)

	lemma measurable_escape_rate[measurable]: "escape_rate \<in> count_space UNIV \<rightarrow>\<^sub>M borel"
	by auto

	lemma measurable_exponential_escape_rate[measurable]: "(\<lambda>x. exponential (escape_rate x)) \<in> count_space UNIV \<rightarrow>\<^sub>M prob_algebra borel"
	by (auto simp: space_prob_algebra sets_exponential prob_space_exponential_escape_rate)

	interpretation pmf_as_function .

	lift_definition J :: "'a \<Rightarrow> 'a pmf" is "\<lambda>x y. R x y / escape_rate x"
	proof safe
	show "0 \<le> R x y / escape_rate x" for x y
	by (auto intro!: integral_nonneg_AE divide_nonneg_nonneg R_nonneg simp: escape_rate_def)
	show "(\<integral>\<^sup>+y. R x y / escape_rate x \<partial>count_space UNIV) = 1" for x
	using escape_rate_pos[of x]
	by (auto simp add: divide_ennreal[symmetric] nn_integral_divide ennreal_escape_rate[symmetric] intro!: ennreal_divide_self)
	qed

	lemma set_pmf_J: "set_pmf (J x) = I x"
	using escape_rate_pos[of x] by (auto simp: set_pmf_iff J.rep_eq less_le)

	interpretation exp_esc: pair_prob_space "distr (exponential (escape_rate x)) borel ((+) t)" "J x" for x
	proof -
	interpret prob_space "distr (exponential (escape_rate x)) borel ((+) t)"
	by (intro prob_space.prob_space_distr prob_space_exponential_escape_rate) simp
	show "pair_prob_space (distr (exponential (escape_rate x)) borel ((+) t)) (measure_pmf (J x))"
	by standard
	qed

	subsection \<open>Continuous-time Kernel\<close>

	definition K :: "(real \<times> 'a) \<Rightarrow> (real \<times> 'a) measure" where
	"K = (\<lambda>(t, x). (distr (exponential (escape_rate x)) borel ((+) t)) \<Otimes>\<^sub>M J x)"

	interpretation K: discrete_Markov_process "borel \<Otimes>\<^sub>M count_space UNIV" K
	proof
	show "K \<in> borel \<Otimes>\<^sub>M count_space UNIV \<rightarrow>\<^sub>M prob_algebra (borel \<Otimes>\<^sub>M count_space UNIV)"
	unfolding K_def
	apply measurable
	apply (rule measurable_snd[THEN measurable_compose])
	apply (auto simp: space_prob_algebra prob_space_measure_pmf)
	done
	qed

	interpretation DTMC: MC_syntax J .

	lemma in_space_S[simp]: "x \<in> space S"
	by (simp add: space_pair_measure)

	lemma in_space_T[simp]: "x \<in> space T"
	by (simp add: space_pair_measure space_stream_space)

	lemma in_space_lim_stream: "\<omega> \<in> space (K.lim_stream x)"
	unfolding K.space_lim_stream space_stream_space[symmetric] by simp

	lemma prob_space_K_lim: "prob_space (K.lim_stream x)"
	using K.lim_stream[THEN measurable_space] by (simp add: space_prob_algebra)

	definition select_first :: "'a \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> bool"
	where "select_first x p y = (y \<in> I x \<and> (\<forall>y'\<in>I x - {y}. p y < p y'))"

	lemma select_firstD1: "select_first x p y \<Longrightarrow> y \<in> I x"
	by (simp add: select_first_def)

	lemma select_first_unique:
	assumes y: "select_first x p y1" " select_first x p y2" shows "y1 = y2"
	proof -
	have "y1 \<noteq> y2 \<Longrightarrow> p y1 < p y2" "y1 \<noteq> y2 \<Longrightarrow> p y2 < p y1"
	using y by (auto simp: select_first_def)
	then show "y1 = y2"
	by (rule_tac ccontr) auto
	qed

	lemma The_select_first[simp]: "select_first x p y \<Longrightarrow> The (select_first x p) = y"
	by (intro the_equality select_first_unique)

	lemma select_first_INF:
	"select_first x p y \<Longrightarrow> (INF x\<in>I x. p x) = p y"
	by (intro antisym cINF_greatest cINF_lower bdd_belowI2[where m="p y"])
	(auto simp: select_first_def le_less)

	lemma measurable_select_first[measurable]:
	"(\<lambda>p. select_first x p y) \<in> (\<Pi>\<^sub>M y\<in>I x. borel) \<rightarrow>\<^sub>M count_space UNIV"
	using I_countable unfolding select_first_def by (intro measurable_pred_countable pred_intros_conj1') measurable

	lemma measurable_THE_select_first[measurable]:
	"(\<lambda>p. The (select_first x p)) \<in> (\<Pi>\<^sub>M y\<in>I x. borel) \<rightarrow>\<^sub>M count_space UNIV"
	by (rule measurable_THE) (auto intro: select_first_unique I_countable dest: select_firstD1)

	lemma sets_S_eq: "sets S = sigma_sets UNIV { {t ..} \<times> A \| t A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s}) }"
	proof (subst sets_pair_eq)
	let ?CI = "\<lambda>a::real. {a ..}" let ?Ea = "range ?CI"

	show "?Ea \<subseteq> Pow (space borel)" "sets borel = sigma_sets (space borel) ?Ea"
	unfolding borel_Ici by auto
	show "?CI`Rats \<subseteq> ?Ea" "(\<Union>i\<in>Rats. ?CI i) = space borel"
	using Rats_dense_in_real[of "x - 1" "x" for x] by (auto intro: less_imp_le)

	let ?Eb = "Pow (- I x) \<union> (\<lambda>s. {s}) ` I x"
	have "b \<in> sigma_sets UNIV (Pow (- I x) \<union> (\<lambda>s. {s}) ` I x)" for b
	proof -
	have "b = (b - I x) \<union> (\<Union>x\<in>b \<inter> I x. {x})"
	by auto
	also have "\<dots> \<in> sigma UNIV (Pow (- I x) \<union> (\<lambda>s. {s}) ` I x)"
	using I_countable by (intro sets.Un sets.countable_UN') auto
	finally show ?thesis
	by simp
	qed
	then show "sets (count_space UNIV) = sigma_sets (space (count_space UNIV)) ?Eb"
	by auto
	show "countable ({- I x} \<union> (\<Union>s\<in>I x. {{s}}))"
	using I_countable by auto
	show "sets (sigma (space borel \<times> space (count_space UNIV)) {a \<times> b \|a b. a \<in> ?Ea \<and> b \<in> ?Eb}) =
	sigma_sets UNIV {{t ..} \<times> A \|t A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s})}"
	apply simp
	apply (intro arg_cong[where f="sigma_sets _"])
	apply auto
	done
	qed (auto intro: countable_rat)

	subsection \<open>Kernel equals Parallel Choice\<close>

	abbreviation PAR :: "'a \<Rightarrow> ('a \<Rightarrow> real) measure"
	where
	"PAR x \<equiv> (\<Pi>\<^sub>M y\<in>I x. exponential (R x y))"

	lemma PAR_least:
	assumes y: "y \<in> I x"
	shows "PAR x {p\<in>space (PAR x). t \<le> p y \<and> select_first x p y} =
	emeasure (exponential (escape_rate x)) {t ..} * ennreal (pmf (J x) y)"
	proof -
	let ?E = "\<lambda>y. exponential (R x y)" let ?P' = "\<Pi>\<^sub>M y\<in>I x - {y}. ?E y"
	interpret P': prob_space ?P'
	by (intro prob_space_PiM prob_space_exponential) simp
	have *: "PAR x = (\<Pi>\<^sub>M y\<in>insert y (I x - {y}). ?E y)"
	using y by (intro PiM_cong) auto
	have "0 < R x y"
	using y by simp
	have **: "(\<lambda>(x, X). X(y := x)) \<in> exponential (R x y) \<Otimes>\<^sub>M Pi\<^sub>M (I x - {y}) (\<lambda>i. exponential (R x i)) \<rightarrow>\<^sub>M PAR x"
	using y
	apply (subst measurable_cong_sets[OF sets_pair_measure_cong[OF sets_exponential sets_PiM_cong[OF refl sets_exponential]] sets_PiM_cong[OF refl sets_exponential]])
	apply measurable
	apply (rule measurable_fun_upd[where J="I x - {y}"])
	apply auto
	done
	have "PAR x {p\<in>space (PAR x). t \<le> p y \<and> (\<forall>y'\<in>I x-{y}. p y < p y')} =
	(\<integral>\<^sup>+ty. indicator {t..} ty * ?P' {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'} \<partial>?E y)"
	unfolding * using \<open>y \<in> I x\<close>
	apply (subst distr_pair_PiM_eq_PiM[symmetric])
	apply (auto intro!: prob_space_exponential simp: emeasure_distr insert_absorb)
	apply (subst emeasure_distr[OF **])
	subgoal
	using I_countable by (auto simp: pred_def[symmetric])
	apply (subst P'.emeasure_pair_measure_alt)
	subgoal
	using I_countable[of x]
	apply (intro measurable_sets[OF **])
	apply (auto simp: pred_def[symmetric])
	done
	apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator if_split_asm
	simp: space_exponential space_PiM space_pair_measure PiE_iff extensional_def)
	done
	also have "\<dots> = (\<integral>\<^sup>+ty. indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y))) \<partial>?E y)"
	apply (intro nn_integral_cong_AE)
	using AE_exponential[OF \<open>0 < R x y\<close>]
	proof eventually_elim
	fix ty :: real assume "0 < ty"
	have "escape_rate x =
	(\<integral>\<^sup>+y'. R x y' * indicator {y} y' \<partial>count_space UNIV) + (\<integral>\<^sup>+y'. R x y' * indicator (I x - {y}) y' \<partial>count_space UNIV)"
	unfolding ennreal_escape_rate by (subst nn_integral_add[symmetric]) (auto simp: less_le split: split_indicator intro!: nn_integral_cong)
	also have "\<dots> = R x y + (\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y}))"
	by (auto simp add: nn_integral_count_space_indicator less_le simp del: nn_integral_indicator_singleton
	intro!: arg_cong2[where f="(+)"] nn_integral_cong split: split_indicator)
	finally have "(\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y})) = escape_rate x - R x y \<and> R x y \<le> escape_rate x"
	using escape_rate_pos[THEN less_imp_le]
	by (cases "(\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y}))")
	(auto simp: add_top ennreal_plus[symmetric] simp del: ennreal_plus)
	then have "integrable (count_space (I x - {y})) (R x)" "(LINT y'\|count_space (I x - {y}). R x y') = escape_rate x - R x y"
	by (auto simp: nn_integral_eq_integrable)
	then have "?P' (prod_emb (I x-{y}) ?E (I x-{y}) (\<Pi>\<^sub>E j\<in>(I x-{y}). {ty<..})) = exp (- ty * (escape_rate x - R x y))"
	using I_countable \<open>0 < ty\<close> by (subst emeasure_PiM_exponential_Ioi_countable) auto
	also have "prod_emb (I x-{y}) ?E (I x-{y}) (\<Pi>\<^sub>E j\<in>(I x-{y}). {ty<..}) = {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'}"
	by (simp add: set_eq_iff prod_emb_def space_PiM space_exponential ac_simps Pi_iff)
	finally show "indicator {t..} ty * ?P' {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'} =
	indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y)))"
	by simp
	qed
	also have "\<dots> = (\<integral>\<^sup>+ty. ennreal (R x y) * (ennreal (exp (- ty * escape_rate x)) * indicator {max 0 t..} ty) \<partial>lborel)"
	by (auto simp add: exponential_def exponential_density_def nn_integral_density ennreal_mult[symmetric] exp_add[symmetric] field_simps
	intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = (R x y / escape_rate x) * emeasure (exponential (escape_rate x)) {max 0 t..}"
	using escape_rate_pos[of x]
	by (auto simp: exponential_def exponential_density_def emeasure_density nn_integral_cmult[symmetric] ennreal_mult[symmetric]
	split: split_indicator intro!: nn_integral_cong )
	also have "\<dots> = pmf (J x) y * emeasure (exponential (escape_rate x)) {t..}"
	using AE_exponential[OF escape_rate_pos[of x]]
	by (intro arg_cong2[where f="(*)"] emeasure_eq_AE) (auto simp: J.rep_eq )
	finally show ?thesis
	using assms by (simp add: mult_ac select_first_def)
	qed

	lemma AE_PAR_least: "AE p in PAR x. \<exists>y\<in>I x. select_first x p y"
	proof -
	have D: "disjoint_family_on (\<lambda>y. {p \<in> space (PAR x). select_first x p y}) (I x)"
	by (auto simp: disjoint_family_on_def dest: select_first_unique)
	have "PAR x {p\<in>space (PAR x). \<exists>y\<in>I x. select_first x p y} =
	PAR x (\<Union>y\<in>I x. {p\<in>space (PAR x). select_first x p y})"
	by (auto intro!: arg_cong2[where f=emeasure])
	also have "\<dots> = (\<integral>\<^sup>+y. PAR x {p\<in>space (PAR x). select_first x p y} \<partial>count_space (I x))"
	using I_countable by (intro emeasure_UN_countable D) auto
	also have "\<dots> = (\<integral>\<^sup>+y. PAR x {p\<in>space (PAR x). 0 \<le> p y \<and> select_first x p y} \<partial>count_space (I x))"
	proof (intro nn_integral_cong emeasure_eq_AE, goal_cases)
	case (1 y) with AE_PiM_component[of "I x" "\<lambda>y. exponential (R x y)" y "(<) 0"] AE_exponential[of "R x y"] show ?case
	by (auto simp: prob_space_exponential)
	qed (insert I_countable, auto)
	also have "\<dots> = (\<integral>\<^sup>+y. emeasure (exponential (escape_rate x)) {0 ..} * ennreal (pmf (J x) y) \<partial>count_space (I x))"
	by (auto simp add: PAR_least intro!: nn_integral_cong)
	also have "\<dots> = (\<integral>\<^sup>+y. emeasure (exponential (escape_rate x)) {0 ..} \<partial>J x)"
	by (auto simp: nn_integral_measure_pmf nn_integral_count_space_indicator ac_simps pmf_eq_0_set_pmf set_pmf_J
	simp del: nn_integral_const intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = 1"
	using AE_exponential[of "escape_rate x"]
	by (auto intro!: prob_space.emeasure_eq_1_AE prob_space_exponential simp: escape_rate_pos less_imp_le)
	finally show ?thesis
	using I_countable
	by (subst prob_space.AE_iff_emeasure_eq_1 prob_space_PiM prob_space_exponential)
	(auto intro!: prob_space_PiM prob_space_exponential simp del: Set.bex_simps(6))
	qed

	lemma K_alt: "K (t, x) = distr (\<Pi>\<^sub>M y\<in>I x. exponential (R x y)) S (\<lambda>p. (t + (INF y\<in>I x. p y), The (select_first x p)))" (is "_ = ?R")
	proof (rule measure_eqI_generator_eq_countable)
	let ?E = "{ {t ..} \<times> A \| (t::real) A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s}) }"
	show "Int_stable ?E"
	apply (auto simp: Int_stable_def)
	subgoal for t1 A1 t2 A2
	by (intro exI[of _ "max t1 t2"] exI[of _ "A1 \<inter> A2"]) auto
	subgoal for t1 t2 y1 y2
	by (intro exI[of _ "max t1 t2"] exI[of _ "{y1} \<inter> {y2}"]) auto
	done
	show "sets (K (t, x)) = sigma_sets UNIV ?E"
	unfolding K.sets_K[OF in_space_S] by (subst sets_S_eq) rule
	show "sets ?R = sigma_sets UNIV ?E"
	using sets_S_eq by simp
	show "countable ((\<lambda>(t, A). {t ..} \<times> A) ` (\<rat> \<times> ({- I x} \<union> (\<lambda>s. {s}) ` I x)))"
	by (intro countable_image countable_SIGMA countable_rat countable_Un I_countable) auto

	have *: "(+) t -` {t'..} \<inter> space (exponential (escape_rate x)) = {t' - t..}" for t'
	by (auto simp: space_exponential)
	{ fix X assume "X \<in> ?E"
	then consider
	t' s where "s \<in> I x" "X = {t' ..} \<times> {s}"
	\| t' A where "A \<subseteq> - I x" "X = {t' ..} \<times> A"
	by auto
	then show "K (t, x) X = ?R X"
	proof cases
	case 1
	have "AE p in PAR x. (t' - t \<le> p s \<and> select_first x p s) =
	(t' \<le> t + (\<Sqinter>x\<in>I x. p x) \<and> The (select_first x p) = s)"
	using AE_PAR_least by eventually_elim (auto dest: select_first_unique simp: select_first_INF)
	with 1 I_countable show ?thesis
	by (auto simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr emeasure_pmf_single *
	PAR_least[symmetric] intro!: emeasure_eq_AE)
	next
	case 2
	moreover
	then have "emeasure (measure_pmf (J x)) A = 0"
	by (subst AE_iff_measurable[symmetric, where P="\<lambda>x. x \<notin> A"])
	(auto simp: AE_measure_pmf_iff set_pmf_J subset_eq)
	moreover
	have "PAR x ((\<lambda>p. (t + \<Sqinter>(p ` (I x)), The (select_first x p))) -` ({t'..} \<times> A) \<inter> space (PAR x)) = 0"
	using \<open>A \<subseteq> - I x\<close> AE_PAR_least[of x] I_countable
	by (subst AE_iff_measurable[symmetric, where P="\<lambda>p. (t + \<Sqinter>(p ` (I x)), The (select_first x p)) \<notin> {t'..} \<times> A"])
	(auto simp del: all_simps(5) simp add: imp_ex imp_conjL subset_eq)
	ultimately show ?thesis
	using I_countable
	by (simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr *)
	qed }

	interpret prob_space "K ts" for ts
	by (rule K.prob_space_K) simp
	show "emeasure (K (t, x)) a \<noteq> \<infinity>" for a
	using emeasure_finite by simp
	qed (insert Rats_dense_in_real[of "x - 1" x for x], auto, blast intro: less_imp_le)

	lemma AE_K: "AE y in K x. fst x < fst y \<and> snd y \<in> J (snd x)"
	unfolding K_def split_beta
	apply (subst exp_esc.AE_pair_iff[symmetric])
	apply measurable
	apply (simp_all add: AE_distr_iff AE_measure_pmf_iff exponential_def AE_density exponential_density_def cong del: AE_cong)
	using AE_lborel_singleton[of 0]
	apply eventually_elim
	apply simp
	done

	lemma AE_lim_stream:
	"AE \<omega> in K.lim_stream x. \<forall>i. snd ((x ## \<omega>) !! i) \<in> DTMC.acc``{snd x} \<and> snd (\<omega> !! i) \<in> J (snd ((x ## \<omega>) !! i)) \<and> fst ((x ## \<omega>) !! i) < fst (\<omega> !! i)"
	(is "AE \<omega> in K.lim_stream x. \<forall>i. ?P \<omega> i")
	unfolding AE_all_countable
	proof
	let ?F = "\<lambda>i x \<omega>. fst ((x ## \<omega>) !! i)" and ?S = "\<lambda>i x \<omega>. snd ((x ## \<omega>) !! i)"
	fix i show "AE \<omega> in K.lim_stream x. ?P \<omega> i"
	proof (induction i arbitrary: x)
	case 0 with AE_K[of x] show ?case
	by (subst K.AE_lim_stream) (auto simp add: space_pair_measure cong del: AE_cong)
	next
	case (Suc i)
	show ?case
	proof (subst K.AE_lim_stream, goal_cases)
	case 2 show ?case
	using DTMC.countable_reachable
	by (intro measurable_compose_countable_restrict[where f="?S (Suc i) x"])
	(simp_all del: Image_singleton_iff)
	next
	case 3 show ?case
	apply (simp del: AE_conj_iff cong del: AE_cong)
	using AE_K[of x]
	apply eventually_elim
	subgoal premises K_prems for y
	using Suc
	by eventually_elim (insert K_prems, auto intro: converse_rtrancl_into_rtrancl)
	done
	qed (simp add: space_pair_measure)
	qed
	qed

	lemma measurable_merge_at[measurable]: "(\<lambda>(\<omega>, \<omega>'). merge_at \<omega> j \<omega>') \<in> (T \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M T"
	proof (rule measurable_stream_space2)
	define F where "F x n = (case x of (\<omega>::(real \<times> 'a) stream, \<omega>') \<Rightarrow> merge_at \<omega> j \<omega>') !! n" for x n
	fix n
	have "(\<lambda>x. F x n) \<in> stream_space S \<Otimes>\<^sub>M stream_space S \<rightarrow>\<^sub>M S"
	proof (induction n)
	case 0 then show ?case
	by (simp add: F_def split_beta' stream.case_eq_if)
	next
	case (Suc n)
	from Suc[measurable]
	have eq: "F x (Suc n) = (case fst x of (t, s) ## \<omega> \<Rightarrow> if t \<le> j then F (\<omega>, snd x) n else snd x !! Suc n)" for x
	by (auto simp: F_def split: prod.split stream.split)
	show ?case
	unfolding eq stream.case_eq_if by measurable
	qed
	then show "(\<lambda>x. (case x of (\<omega>, \<omega>') \<Rightarrow> merge_at \<omega> j \<omega>') !! n) \<in> stream_space S \<Otimes>\<^sub>M stream_space S \<rightarrow>\<^sub>M S"
	unfolding F_def by auto
	qed

	lemma measurable_trace_at[measurable]: "(\<lambda>(s, \<omega>). trace_at s \<omega> j) \<in> (count_space UNIV \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M count_space UNIV"
	unfolding trace_at_eq by measurable

	lemma measurable_trace_at': "(\<lambda>((s, j), \<omega>). trace_at s \<omega> j) \<in> ((count_space UNIV \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M count_space UNIV"
	unfolding trace_at_eq split_beta' by measurable

	lemma K_time_split:
	assumes "t \<le> j" and [measurable]: "f \<in> S \<rightarrow>\<^sub>M borel"
	shows "(\<integral>\<^sup>+x. f x * indicator {j <..} (fst x) \<partial>K (t, s)) = (\<integral>\<^sup>+x. f x \<partial>K (j, s)) * exponential (escape_rate s) {j - t <..}"
	proof -
	have "(\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) * indicator {j<..} (t + x) \<partial>exponential (escape_rate s) \<partial>J s) =
	(\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) * indicator {j - t<..} x \<partial>exponential (escape_rate s) \<partial>J s)"
	by (intro nn_integral_cong) (auto split: split_indicator)
	also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) \<partial>uniform_measure (exponential (escape_rate s)) {j-t <..} \<partial>J s) *
	emeasure (exponential (escape_rate s)) {j - t <..}"
	using \<open>t \<le> j\<close> escape_rate_pos
	by (subst nn_integral_uniform_measure)
	(auto simp: nn_integral_divide ennreal_divide_times emeasure_exponential_Ioi)
	also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (j + x, y) \<partial>exponential (escape_rate s) \<partial>J s) *
	emeasure (exponential (escape_rate s)) {j - t <..}"
	using \<open>t \<le> j\<close> escape_rate_pos by (simp add: uniform_measure_exponential nn_integral_distr)
	finally show ?thesis
	by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr)
	qed

	lemma K_in_space[simp]: "K x \<in> space (prob_algebra S)"
	by (rule measurable_space [OF K.K]) simp

	lemma L_in_space[simp]: "K.lim_stream x \<in> space (prob_algebra T)"
	by (rule measurable_space [OF K.lim_stream]) simp

	subsection \<open>Markov Chain Property\<close>

	lemma lim_time_split:
	"t \<le> j \<Longrightarrow> K.lim_stream (t, s) = do { \<omega> \<leftarrow> K.lim_stream (t, s) ; \<omega>' \<leftarrow> K.lim_stream (j, trace_at s \<omega> j) ; return T (merge_at \<omega> j \<omega>')}"
	(is "_ \<Longrightarrow> _ = ?DO t s")
	proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
	case step let ?L = K.lim_stream

	note measurable_compose[OF measurable_prob_algebraD measurable_emeasure_subprob_algebra, measurable (raw)]

	define B' where "B' = (\<lambda>(t', s). if t' \<le> j then ?DO t' s else ?L (t', s))"
	show ?case
	proof (intro bexI conjI AE_I2)
	show [measurable]: "B' \<in> S \<rightarrow>\<^sub>M prob_algebra T"
	unfolding B'_def by measurable
	show "(\<exists>t s. y = (t, s) \<and> B' y = ?DO t s \<and> t \<le> j) \<or> ?L y = B' y" for y
	by (cases y; cases "fst y \<le> j") (auto simp: B'_def)
	let ?C = "\<lambda>x. do { \<omega> \<leftarrow> ?L x; \<omega>' \<leftarrow> ?L (j, trace_at s (x##\<omega>) j); return T (merge_at (x##\<omega>) j \<omega>') }"
	have "?DO t s = do { x \<leftarrow> K (t, s); ?C x }"
	apply (subst K.lim_stream_eq[OF in_space_S])
	apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
	apply (subst measurable_cong_sets[OF K.sets_K[OF in_space_S] refl])
	apply measurable
	apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
	apply measurable
	apply (subst bind_cong[OF refl bind_cong[OF refl bind_return[OF measurable_prob_algebraD]]])
	apply measurable
	done
	also have "\<dots> = K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))" (is "?DO' = ?R")
	proof (rule measure_eqI)
	have "sets ?DO' = sets T"
	by (intro sets_bind'[OF K_in_space]) measurable
	moreover have "sets ?R = sets T"
	by (intro sets_bind'[OF K_in_space]) measurable
	ultimately show "sets ?DO' = sets ?R"
	by simp
	fix A assume "A \<in> sets ?DO'"
	then have A[measurable]: "A \<in> T"
	unfolding \<open>sets ?DO' = sets T\<close> .
	have "?DO' A = (\<integral>\<^sup>+x. ?C x A \<partial>K (t, s))"
	by (subst emeasure_bind_prob_algebra[OF K_in_space]) measurable
	also have "\<dots> = (\<integral>\<^sup>+x. ?C x A * indicator {.. j} (fst x) \<partial>K (t, s)) +
	(\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s))"
	by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
	also have "(\<integral>\<^sup>+x. ?C x A * indicator {.. j} (fst x) \<partial>K (t, s)) =
	(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {.. j} (fst y) \<partial>K (t, s))"
	proof (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
	fix x :: "real \<times> 'a" assume "indicator {..j} (fst x) \<noteq> (0::ennreal)"
	then have "fst x \<le> j"
	by (auto split: split_indicator_asm)
	then show "?C x = (B' x \<bind> (\<lambda>\<omega>. return T (x ## \<omega>)))"
	apply (cases x)
	apply (simp add: B'_def)
	apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
	apply measurable
	apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
	apply measurable
	apply (subst bind_return)
	apply measurable
	done
	qed
	also have "(\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s)) =
	(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
	proof -
	have *: "(+) t -` {j<..} = {j - t <..}"
	by auto

	have "(\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s)) =
	(\<integral>\<^sup>+x. ?L (j, s) A * indicator {j <..} (fst x) \<partial>K (t, s))"
	by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
	(auto simp: K.sets_lim_stream bind_return'' bind_const' prob_space_K_lim prob_space_imp_subprob_space split: split_indicator_asm)
	also have "\<dots> = ?L (j, s) A * exponential (escape_rate s) {j - t <..}"
	by (subst nn_integral_cmult) (simp_all add: K_def exp_esc.nn_integral_snd[symmetric] emeasure_distr space_exponential *)
	also have "\<dots> = (\<integral>\<^sup>+x. emeasure (?L x \<bind> (\<lambda>\<omega>. return T (x ## \<omega>))) A \<partial>K (j, s)) * exponential (escape_rate s) {j - t <..}"
	by (subst K.lim_stream_eq) (auto simp: emeasure_bind_prob_algebra[OF K_in_space _ A])
	also have "\<dots> = (\<integral>\<^sup>+y. emeasure (?L y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
	using \<open>t \<le> j\<close> by (rule K_time_split[symmetric]) measurable
	also have "\<dots> = (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
	by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
	(auto simp add: B'_def split: split_indicator_asm)
	finally show ?thesis .
	qed
	also have "(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {.. j} (fst y) \<partial>K (t, s)) +
	(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s)) =
	(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A \<partial>K (t, s))"
	by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
	also have "\<dots> = emeasure (K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))) A"
	by (rule emeasure_bind_prob_algebra[symmetric, OF K_in_space _ A]) auto
	finally show "?DO' A = emeasure (K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))) A" .
	qed
	finally show "?DO t s = K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))" .
	qed
	qed (simp add: space_pair_measure)

	lemma K_eq: "K (t, s) = distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) S (\<lambda>(t', s). (t + t', s))"
	proof -
	have "distr (exponential (escape_rate s)) borel ((+) t) \<Otimes>\<^sub>M distr (J s) (J s) (\<lambda>x. x) =
	distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) (borel \<Otimes>\<^sub>M J s) (\<lambda>(x, y). (t + x, y))"
	proof (intro pair_measure_distr)
	interpret prob_space "distr (measure_pmf (J s)) (measure_pmf (J s)) (\<lambda>x. x)"
	by (intro measure_pmf.prob_space_distr) simp
	show "sigma_finite_measure (distr (measure_pmf (J s)) (measure_pmf (J s)) (\<lambda>x. x))"
	by unfold_locales
	qed auto
	also have "\<dots> = distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) S (\<lambda>(x, y). (t + x, y))"
	by (intro distr_cong refl sets_pair_measure_cong) simp
	finally show ?thesis
	by (simp add: K_def)
	qed

	lemma K_shift: "K (t + t', s) = distr (K (t, s)) S (\<lambda>(t, s). (t + t', s))"
	unfolding K_eq by (subst distr_distr) (auto simp: comp_def split_beta' ac_simps)

	lemma K_not_empty: "space (K x) \<noteq> {}"
	by (simp add: K_def space_pair_measure split: prod.split)

	lemma lim_stream_not_empty: "space (K.lim_stream x) \<noteq> {}"
	by (simp add: K.space_lim_stream space_pair_measure split: prod.split)

	lemma lim_shift: \<comment> \<open>Generalize to bijective function on @{const K.lim_stream} invariant on @{const K}\<close>
	"K.lim_stream (t + t', s) = distr (K.lim_stream (t, s)) T (smap (\<lambda>(t, s). (t + t', s)))"
	(is "_ = ?D t s")
	proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
	case step then show ?case
	proof (intro bexI[of _ "\<lambda>(t, s). ?D (t - t') s"] conjI)
	show "?D t s = K (t + t', s) \<bind> (\<lambda>y. (case y of (t, s) \<Rightarrow> ?D (t - t') s) \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))"
	apply (subst K.lim_stream_eq[OF in_space_S])
	apply (subst K_shift)
	apply (subst distr_bind[OF measurable_prob_algebraD K_not_empty])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (subst bind_distr[OF _ measurable_prob_algebraD K_not_empty])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (intro bind_cong refl)
	apply (subst distr_bind[OF measurable_prob_algebraD lim_stream_not_empty])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (simp add: distr_return split_beta)
	apply (subst bind_distr[OF _ measurable_prob_algebraD lim_stream_not_empty])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (simp add: split_beta')
	done
	qed (auto cong: conj_cong intro!: exI[of _ "_ - t'"])
	qed simp

	lemma lim_0: "K.lim_stream (t, s) = distr (K.lim_stream (0, s)) T (smap (\<lambda>(t', s). (t' + t, s)))"
	using lim_shift[of 0 t s] by simp

	subsection \<open>Explosion time\<close>

	definition explosion :: "(real \<times> 'a) stream \<Rightarrow> ereal"
	where "explosion \<omega> = (SUP i. ereal (fst (\<omega> !! i)))"

	lemma ball_less_Suc_eq: "(\<forall>i<Suc n. P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i<n. P (Suc i)))"
	using less_Suc_eq_0_disj by auto

	lemma lim_stream_timediff_eq_exponential_1:
	"distr (K.lim_stream ts) (PiM UNIV (\<lambda>_. borel))
	(\<lambda>\<omega> i. escape_rate (snd ((ts##\<omega>) !! i)) * (fst (\<omega> !! i) - fst ((ts##\<omega>) !! i))) =
	PiM UNIV (\<lambda>_. exponential 1)"
	(is "?D = ?P")
	proof (rule measure_eqI_PiM_sequence)
	show "sets ?D = sets (PiM UNIV (\<lambda>_. borel))" "sets ?P = sets (PiM UNIV (\<lambda>_. borel))"
	by (auto intro!: sets_PiM_cong simp: sets_exponential)
	have [measurable]: "ts \<in> space S"
	by auto
	{ interpret prob_space ?D
	by (intro prob_space.prob_space_distr K.prob_space_lim_stream measurable_abs_UNIV) auto
	show "finite_measure ?D"
	by unfold_locales }

	interpret E: prob_space "exponential 1"
	by (rule prob_space_exponential) simp
	interpret P: product_prob_space "\<lambda>_. exponential 1" UNIV
	by unfold_locales

	let "distr _ _ (?f ts)" = ?D

	fix A :: "nat \<Rightarrow> real set" and n :: nat assume A[measurable]: "\<And>i. A i \<in> sets borel"
	define n' where "n' = Suc n"
	have "emeasure ?D (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A)) =
	emeasure (K.lim_stream ts) {\<omega>\<in>space (stream_space S). \<forall>i<n'. ?f ts \<omega> i \<in> A i}"
	apply (subst emeasure_distr)
	apply (auto intro!: measurable_abs_UNIV arg_cong[where f="emeasure _"])
	apply (auto simp: prod_emb_def K.space_lim_stream space_pair_measure n'_def)
	done
	also have "\<dots> = (\<Prod>i<n'. emeasure (exponential 1) (A i))"
	using A
	proof (induction n' arbitrary: A ts)
	case 0 then show ?case
	using prob_space.emeasure_space_1[OF prob_space_K_lim]
	by (simp add: K.space_lim_stream space_pair_measure)
	next
	case (Suc n A ts)
	from Suc.prems[measurable]
	have [measurable]: "ts \<in> space S"
	by auto

	have "emeasure (K.lim_stream ts) {\<omega> \<in> space (stream_space S). \<forall>i<Suc n. ?f ts \<omega> i \<in> A i} =
	(\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) *
	emeasure (K.lim_stream ts') {\<omega> \<in> space (stream_space S). \<forall>i<n. ?f ts' \<omega> i \<in> A (Suc i)} \<partial>K ts)"
	apply (subst K.emeasure_lim_stream)
	apply simp
	apply measurable
	apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator
	simp: ball_less_Suc_eq)
	done
	also have "\<dots> = (\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) \<partial>K ts) *
	(\<Prod>i<n. emeasure (exponential 1) (A (Suc i)))"
	by (subst Suc.IH) (simp_all add: nn_integral_multc)
	also have "(\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) \<partial>K ts) =
	(\<integral>\<^sup>+t. indicator (A 0) (escape_rate (snd ts) * t) \<partial>exponential (escape_rate (snd ts)))"
	by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr split: prod.split)
	also have "\<dots> = emeasure (exponential 1) (A 0)"
	using escape_rate_pos[of "snd ts"]
	by (subst exponential_eq_stretch) (simp_all add: nn_integral_distr)
	also have "emeasure (exponential 1) (A 0) * (\<Prod>i<n. emeasure (exponential 1) (A (Suc i))) =
	(\<Prod>i<Suc n. emeasure (exponential 1) (A i))"
	by (rule prod.lessThan_Suc_shift[symmetric])
	finally show ?case .
	qed
	also have "\<dots> = emeasure ?P (prod_emb UNIV (\<lambda>_. borel) {..<n'} (Pi\<^sub>E {..<n'} A))"
	using P.emeasure_PiM_emb[of "{..<n'}" A] by (simp add: prod_emb_def space_exponential)
	finally show "emeasure ?D (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A)) =
	emeasure ?P (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A))"
	by (simp add: n'_def lessThan_Suc_atMost)
	qed

	lemma AE_explosion_infty:
	assumes bdd: "bdd_above (range escape_rate)"
	shows "AE \<omega> in K.lim_stream x. explosion \<omega> = \<infinity>"
	proof -
	have "escape_rate undefined \<le> (SUP x. escape_rate x)"
	using bdd by (intro cSUP_upper) auto
	then have SUP_escape_pos: "0 < (SUP x. escape_rate x)"
	using escape_rate_pos[of undefined] by simp
	then have SUP_escape_nonneg: "0 \<le> (SUP x. escape_rate x)"
	by (rule less_imp_le)

	have [measurable]: "x \<in> space S" by auto
	have "(\<Sum>i. 1::ennreal) = top"
	by (rule sums_unique[symmetric]) (auto simp: sums_def of_nat_tendsto_top_ennreal)
	then have "AE \<omega> in (PiM UNIV (\<lambda>_. exponential 1)). (\<Sum>i. ereal (\<omega> i)) = \<infinity>"
	by (intro AE_PiM_exponential_suminf_infty) auto
	then have "AE \<omega> in K.lim_stream x.
	(\<Sum>i. ereal (escape_rate (snd ((x##\<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x##\<omega>) !! i)))) = \<infinity>"
	apply (subst (asm) lim_stream_timediff_eq_exponential_1[symmetric, of x])
	apply (subst (asm) AE_distr_iff)
	apply (auto intro!: measurable_abs_UNIV)
	done
	then show ?thesis
	using AE_lim_stream
	proof eventually_elim
	case (elim \<omega>)
	then have le: "fst ((x##\<omega>) !! n) \<le> fst ((x ## \<omega>) !! m)" if "n \<le> m" for n m
	by (intro lift_Suc_mono_le[OF _ \<open>n \<le> m\<close>, of "\<lambda>i. fst ((x ## \<omega>) !! i)"]) (auto intro: less_imp_le)
	have [simp]: "fst x \<le> fst ((x##\<omega>) !! i)" "fst ((x##\<omega>) !! i) \<le> fst (\<omega> !! i)" for i
	using le[of "i" "Suc i"] le[of 0 i] by auto

	have "(\<Sum>i. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i)))) =
	(SUP n. \<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))"
	by (intro suminf_ereal_eq_SUP) (auto intro!: mult_nonneg_nonneg)
	also have "\<dots> \<le> (SUP n. (SUP x. escape_rate x) * (ereal (fst ((x ## \<omega>) !! n)) - ereal (fst x)))"
	proof (intro SUP_least SUP_upper2)
	fix n
	have "(\<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i)))) \<le>
	(\<Sum>i<n. ereal ((SUP i. escape_rate i) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))"
	using elim bdd by (intro sum_mono) (auto intro!: cSUP_upper)
	also have "\<dots> = (SUP i. escape_rate i) * (\<Sum>i<n. fst ((x ## \<omega>) !! Suc i) - fst ((x ## \<omega>) !! i))"
	using elim bdd by (subst sum_ereal) (auto simp: sum_distrib_left)
	also have "\<dots> = (SUP i. escape_rate i) * (fst ((x ## \<omega>) !! n) - fst x)"
	by (subst sum_lessThan_telescope) simp
	finally show "(\<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))
	\<le> (SUP x. escape_rate x) * (ereal (fst ((x ## \<omega>) !! n)) - ereal (fst x))"
	by simp
	qed simp
	also have "\<dots> = (SUP x. escape_rate x) * ((SUP n. ereal (fst ((x ## \<omega>) !! n))) - ereal (fst x))"
	using elim SUP_escape_nonneg by (subst SUP_ereal_mult_left) (auto simp: SUP_ereal_minus_left[symmetric])
	also have "(SUP n. ereal (fst ((x ## \<omega>) !! n))) = explosion \<omega>"
	unfolding explosion_def
	apply (intro SUP_eq)
	subgoal for i by (intro bexI[of _ i]) auto
	subgoal for i by (intro bexI[of _ "Suc i"]) auto
	done
	finally show "explosion \<omega> = \<infinity>"
	using elim SUP_escape_pos by (cases "explosion \<omega>") (auto split: if_splits)
	qed
	qed

	subsection \<open>Transition probability $p_t$\<close>

	context
	begin

	declare [[inductive_internals = true]]

	inductive trace_in :: "'a set \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> bool" for S t
	where
	"t < t' \<Longrightarrow> s \<in> S \<Longrightarrow> trace_in S t s ((t', s')##\<omega>)"
	\| "t \<ge> t' \<Longrightarrow> trace_in S t s' \<omega> \<Longrightarrow> trace_in S t s ((t', s')##\<omega>)"

	end

	lemma trace_in_simps[simp]:
	"trace_in ss t s (x##\<omega>) = (if t < fst x then s \<in> ss else trace_in ss t (snd x) \<omega>)"
	by (cases x) (subst trace_in.simps; auto)

	lemma trace_in_eq_lfp:
	"trace_in ss t = lfp (\<lambda>F s. \<lambda>(t', s')##\<omega> \<Rightarrow> if t < t' then s \<in> ss else F s' \<omega>)"
	unfolding trace_in_def by (intro arg_cong[where f=lfp] ext) (auto split: stream.splits)

	lemma trace_in_shiftD: "trace_in ss t s \<omega> \<Longrightarrow> trace_in ss (t + t') s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>)"
	by (induction rule: trace_in.induct) auto

	lemma trace_in_shift[simp]: "trace_in ss t s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>) \<longleftrightarrow> trace_in ss (t - t') s \<omega>"
	using trace_in_shiftD[of ss t s "smap (\<lambda>(t, s'). (t + t', s')) \<omega>" "- t'"]
	trace_in_shiftD[of ss "t - t'" s \<omega> t']
	by (auto simp add: stream.map_comp prod.case_eq_if)

	lemma measurable_trace_in':
	"Measurable.pred (borel \<Otimes>\<^sub>M count_space UNIV \<Otimes>\<^sub>M T) (\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>)"
	(is "?M (\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>)")
	proof -
	let ?F = "\<lambda>F. \<lambda>(t, s, (t', s')##\<omega>) \<Rightarrow> if t < t' then s \<in> ss else F (t, s', \<omega>)"
	have [measurable]: "Measurable.pred (count_space UNIV) (\<lambda>x. x \<in> ss)"
	by simp
	have "trace_in ss = (\<lambda>t s \<omega>. lfp ?F (t, s, \<omega>))"
	unfolding trace_in_def
	apply (subst lfp_arg)
	apply (subst lfp_rolling[where g="\<lambda>F t s \<omega>. F (t, s, \<omega>)"])
	subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
	subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
	subgoal
	by (intro arg_cong[where f=lfp])
	(auto simp: mono_def le_fun_def split_beta' not_less fun_eq_iff split: stream.splits intro!: arg_cong[where f=lfp])
	done
	then have eq: "(\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>) = lfp ?F"
	by simp
	have "sup_continuous ?F"
	by (auto simp: sup_continuous_def fun_eq_iff split: stream.splits)
	then show ?thesis
	unfolding eq
	proof (rule measurable_lfp)
	fix F assume "?M F" then show "?M (?F F)"
	by measurable
	qed
	qed

	lemma measurable_trace_in[measurable (raw)]:
	assumes [measurable]: "f \<in> M \<rightarrow>\<^sub>M borel" "g \<in> M \<rightarrow>\<^sub>M count_space UNIV" "h \<in> M \<rightarrow>\<^sub>M T"
	shows "Measurable.pred M (\<lambda>x. trace_in ss (f x) (g x) (h x))"
	using measurable_compose[of "\<lambda>x. (f x, g x, h x)" M, OF _ measurable_trace_in'[of ss]] by simp

	definition p :: "'a \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> real"
	where "p s s' t = \<P>(\<omega> in K.lim_stream (0, s). trace_in {s'} t s \<omega>)"

	lemma p[measurable]: "(\<lambda>(s, t). p s s' t) \<in> (count_space UNIV \<Otimes>\<^sub>M borel) \<rightarrow>\<^sub>M borel"
	proof -
	have *: "(SIGMA x:space (count_space UNIV \<Otimes>\<^sub>M borel). {\<omega> \<in> streams (space S). trace_in {s'} (snd x) (fst x) \<omega>}) =
	{x\<in>space ((count_space UNIV \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M T). trace_in {s'} (snd (fst x)) (fst (fst x)) (snd x)}"
	by (auto simp: space_pair_measure)

	note measurable_trace_at'[measurable]
	show ?thesis
	unfolding p_def[abs_def] split_beta'
	by (rule measure_measurable_prob_algebra2[where N=T])
	(auto simp: K.space_lim_stream * pred_def[symmetric]
	intro!: pred_count_space_const1 measurable_trace_at'[unfolded split_beta'])
	qed

	lemma p_nonpos: assumes "t \<le> 0" shows "p s s' t = of_bool (s = s')"
	proof -
	have "AE \<omega> in K.lim_stream (0, s). trace_in {s'} t s \<omega> = (s = s')"
	proof (subst K.AE_lim_stream)
	show "AE y in K (0, s). AE \<omega> in K.lim_stream y. trace_in {s'} t s (y ## \<omega>) = (s = s')"
	using AE_K
	proof eventually_elim
	fix y :: "real \<times> 'a" assume "fst (0, s) < fst y \<and> snd y \<in> set_pmf (J (snd (0, s)))"
	with \<open>t\<le>0\<close> show "AE \<omega> in K.lim_stream y. trace_in {s'} t s (y ## \<omega>) = (s = s')"
	by (cases y) auto
	qed
	qed auto
	then have "p s s' t = \<P>(\<omega> in K.lim_stream (0, s). s = s')"
	unfolding p_def by (intro prob_space.prob_eq_AE K.prob_space_lim_stream) auto
	then show ?thesis
	using prob_space.prob_space[OF K.prob_space_lim_stream] by simp
	qed

	lemma p_0: "p s s' 0 = of_bool (s = s')"
	using p_nonpos[of 0] by simp

	lemma in_sets_T[measurable (raw)]: "Measurable.pred T P \<Longrightarrow> {\<omega>. P \<omega>} \<in> sets T"
	unfolding pred_def by simp

	lemma distr_id': "sets M = sets N \<Longrightarrow> distr M N (\<lambda>x. x) = M"
	by (subst distr_cong[of M M N M _ "\<lambda>x. x"] ) simp_all

	lemma p_nonneg[simp]: "0 \<le> p s s' t"
	by (simp add: p_def)

	lemma p_le_1[simp]: "p s s' t \<le> 1"
	unfolding p_def by (intro prob_space.prob_le_1 K.prob_space_lim_stream) simp

	lemma p_eq:
	assumes "0 \<le> t"
	shows "p s s'' t = (of_bool (s = s'') + (LINT u:{0..t}\|lborel. escape_rate s * exp (escape_rate s * u) * (LINT s'\|J s. p s' s'' u))) / exp (t * escape_rate s)"
	proof -
	have *: "(+) 0 = (\<lambda>x::real. x)"
	by auto
	interpret L: prob_space "K.lim_stream x" for x
	by (rule K.prob_space_lim_stream) simp
	interpret E: prob_space "exponential (escape_rate s)" for s
	by (intro escape_rate_pos prob_space_exponential)
	have "p s s'' t = emeasure (K.lim_stream (0, s)) {\<omega>\<in>space T. trace_in {s''} t s \<omega>}"
	by (simp add: p_def L.emeasure_eq_measure K.space_lim_stream space_stream_space del: in_space_T)
	also have "\<dots> = (\<integral>\<^sup>+y. emeasure (K.lim_stream y) {\<omega>\<in>space T. trace_in {s''} t s (y##\<omega>) } \<partial>K (0, s))"
	apply (subst K.lim_stream_eq[OF in_space_S])
	apply (subst emeasure_bind_prob_algebra[OF K_in_space])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (subst bind_return_distr'[OF lim_stream_not_empty])
	apply (measurable; fail)
	apply (simp add: emeasure_distr)
	done
	also have "\<dots> = (\<integral>\<^sup>+y. indicator {t <..} (fst y) * of_bool (s = s'') + indicator {0<..t} (fst y) * p (snd y) s'' (t - fst y) \<partial>K (0, s))"
	apply (intro nn_integral_cong_AE)
	using AE_K
	apply eventually_elim
	subgoal for y
	using L.emeasure_space_1
	apply (cases y)
	apply (auto split: split_indicator simp del: in_space_T)
	subgoal for t' s2
	unfolding p_def L.emeasure_eq_measure[symmetric] K.space_lim_stream space_stream_space[symmetric]
	by (subst lim_0) (simp add: emeasure_distr)
	subgoal
	by (auto split: split_indicator cong: rev_conj_cong simp add: K.space_lim_stream space_stream_space simp del: in_space_T)
	done
	done
	also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+s'. indicator {t <..} u * of_bool (s = s'') +
	indicator {0<..t} u * p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s))"
	unfolding K_def
	by (simp add: K_def measure_pmf.nn_integral_fst[symmetric] * distr_id' sets_exponential)
	also have "\<dots> = ennreal (exp (- t * escape_rate s) * of_bool (s = s'')) +
	(\<integral>\<^sup>+u. indicator {0<..t} u * \<integral>\<^sup>+s'. p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s))"
	using \<open>0\<le>t\<close> by (simp add: nn_integral_add nn_integral_cmult ennreal_indicator ennreal_mult emeasure_exponential_Ioi escape_rate_pos)
	also have "(\<integral>\<^sup>+u. indicator {0<..t} u * \<integral>\<^sup>+s'. p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s)) =
	(\<integral>\<^sup>+u. indicator {0<..t} u *\<^sub>R (LINT s'\|J s. p s' s'' (t - u)) \<partial>exponential (escape_rate s))"
	by (simp add: measure_pmf.integrable_const_bound[of _ 1] nn_integral_eq_integral ennreal_mult ennreal_indicator)
	also have "\<dots> = (LINT u:{0<..t}\|exponential (escape_rate s). (LINT s'\|J s. p s' s'' (t - u)))"
	unfolding set_lebesgue_integral_def
	by (intro nn_integral_eq_integral E.integrable_const_bound[of _ 1] AE_I2)
	(auto intro!: mult_le_one measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
	also have "\<dots> = (LINT u:{0<..t}\|lborel. escape_rate s * exp (- escape_rate s * u) * (LINT s'\|J s. p s' s'' (t - u)))"
	unfolding exponential_def set_lebesgue_integral_def
	by (subst integral_density)
	(auto simp: ac_simps exponential_density_def fun_eq_iff split: split_indicator
	simp del: integral_mult_right integral_mult_right_zero intro!: arg_cong2[where f="integral\<^sup>L"])
	also have "\<dots> = (LINT u:{0..t}\|lborel. escape_rate s * exp (- escape_rate s * (t - u)) * (LINT s'\|J s. p s' s'' u))"
	using AE_lborel_singleton[of 0] AE_lborel_singleton[of t] unfolding set_lebesgue_integral_def
	by (subst lborel_integral_real_affine[where t=t and c="-1"])
	(auto intro!: integral_cong_AE split: split_indicator)
	also have "\<dots> = exp (- t * escape_rate s) * escape_rate s * (LINT u:{0..t}\|lborel. exp (escape_rate s * u) * (LINT s'\|J s. p s' s'' u))"
	by (simp add: field_simps exp_diff exp_minus)
	finally show "p s s'' t = (of_bool (s = s'') + (LBINT u:{0..t}. escape_rate s * exp (escape_rate s * u) * (LINT s'\|J s. p s' s'' u))) / exp (t * escape_rate s)"
	unfolding set_lebesgue_integral_def
	by (simp del: ennreal_plus add: ennreal_plus[symmetric] exp_minus field_simps)
	qed

	lemma continuous_on_p: "continuous_on A (p s s')"
	proof -
	interpret E: prob_space "exponential (escape_rate s'')" for s''
	by (intro escape_rate_pos prob_space_exponential)
	have "continuous_on {..0} (p s s')"
	by (simp add: p_nonpos continuous_on_const cong: continuous_on_cong_simp)
	moreover have "continuous_on {0..} (p s s')"
	proof (subst continuous_on_cong[OF refl p_eq])
	let ?I = "\<lambda>t. escape_rate s * exp (escape_rate s * t) * (LINT s''\|J s. p s'' s' t)"
	show "continuous_on {0..} (\<lambda>t. (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) / exp (t * escape_rate s))"
	proof (intro continuous_intros continuous_on_LBINT[THEN continuous_on_subset])
	fix t :: real assume t: "0 \<le> t"
	then have "0 \<le> x \<Longrightarrow> x \<le> t \<Longrightarrow> exp (x * escape_rate s) * (LINT s''\|J s. p s'' s' x) \<le> exp (t * escape_rate s) * 1" for x
	by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
	with t show "set_integrable lborel {0..t} ?I"
	using escape_rate_pos[of s] unfolding set_integrable_def
	by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
	(auto simp: field_simps)
	qed auto
	qed simp
	ultimately have "continuous_on ({0..} \<union> {..0}) (p s s')"
	by (intro continuous_on_closed_Un) auto
	also have "{0..} \<union> {..0::real} = UNIV" by auto
	finally show ?thesis
	by (rule continuous_on_subset) simp
	qed

	lemma p_vector_derivative: \<comment> \<open>Backward equation\<close>
	assumes "0 \<le> t"
	shows "(p s s' has_vector_derivative (LINT s''\|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t)
	(at t within {0..})"
	(is "(_ has_vector_derivative ?A) _")
	proof -
	let ?I = "\<lambda>t. escape_rate s * exp (escape_rate s * t) * (LINT s''\|J s. p s'' s' t)"
	let ?p = "\<lambda>t. (of_bool (s = s') + integral {0..t} ?I) * exp (t *\<^sub>R - escape_rate s)"

	{ fix t :: real assume "0 \<le> t"
	have "p s s' t = (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) * exp (- t * escape_rate s)"
	using p_eq[OF \<open>0 \<le> t\<close>, of s s'] by (simp add: exp_minus field_simps)
	also have "(LBINT u:{0..t}. ?I u) = integral {0..t} ?I"
	proof (intro set_borel_integral_eq_integral)
	have "0 \<le> x \<Longrightarrow> x \<le> t \<Longrightarrow> exp (x * escape_rate s) * (LINT s''\|J s. p s'' s' x) \<le> exp (t * escape_rate s) * 1" for x
	by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
	with \<open>0\<le>t\<close> show "set_integrable lborel {0..t} ?I"
	using escape_rate_pos[of s] unfolding set_integrable_def
	by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
	(auto simp: field_simps)
	qed
	finally have "p s s' t = ?p t"
	by simp }
	note p_eq = this

	have at_eq: "at t within {0..} = at t within {0 .. t + 1}"
	by (intro at_within_nhd[where S="{..< t+1}"]) auto

	have c_I: "continuous_on {0..t + 1} ?I"
	by (intro continuous_intros continuous_on_LINT_pmf[where B=1] continuous_on_p) simp

	show ?thesis
	proof (subst has_vector_derivative_cong_ev)
	show "\<forall>\<^sub>F u in nhds t. u \<in> {0..} \<longrightarrow> p s s' u = ?p u" "p s s' t = ?p t"
	using \<open>0\<le>t\<close> by (simp_all add: p_eq)
	have "(?p has_vector_derivative escape_rate s * ((LINT s''\|J s. p s'' s' t) - p s s' t)) (at t within {0..})"
	unfolding at_eq
	apply (intro refl derivative_eq_intros)
	apply rule
	apply (rule integral_has_vector_derivative[OF c_I])
	apply (simp add: \<open>0 \<le> t\<close>)
	apply rule
	apply (rule exp_scaleR_has_vector_derivative_right)
	apply (simp add: field_simps exp_minus p_eq \<open>0\<le>t\<close> split del: split_of_bool)
	done
	also have "escape_rate s * ((LINT s''\|J s. p s'' s' t) - p s s' t) =
	(LINT s''\|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t"
	using escape_rate_pos[of s]
	by (simp add: measure_pmf_eq_density integral_density J.rep_eq field_simps)
	finally show "(?p has_vector_derivative ?A) (at t within {0..})" .
	qed
	qed

	coinductive wf_times :: "real \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> bool"
	where
	"t < t' \<Longrightarrow> wf_times t' \<omega> \<Longrightarrow> wf_times t ((t', s') ## \<omega>)"

	lemma wf_times_simp[simp]: "wf_times t (x ## \<omega>) \<longleftrightarrow> t < fst x \<and> wf_times (fst x) \<omega>"
	by (cases x) (subst wf_times.simps; simp)

	lemma trace_in_merge_at:
	assumes \<omega>': "wf_times t' \<omega>'"
	shows "trace_in ss t x (merge_at \<omega> t' \<omega>') \<longleftrightarrow>
	(if t < t' then trace_in ss t x \<omega> else \<exists>y. trace_in {y} t' x \<omega> \<and> trace_in ss t y \<omega>')"
	(is "?merge \<longleftrightarrow> ?cases")
	proof safe
	assume ?merge from this \<omega>' show ?cases
	proof (induction \<omega>\<equiv>"merge_at \<omega> t' \<omega>'" arbitrary: \<omega> \<omega>')
	case (1 j s' y \<omega>'') then show ?case
	by (cases \<omega>) (auto split: if_splits)
	next
	case (2 j x \<omega>' s' \<omega> \<omega>'') then show ?case
	by (cases \<omega>) (auto split: if_splits)
	qed
	next
	assume ?cases then show ?merge
	proof (split if_split_asm)
	assume "trace_in ss t x \<omega>" "t < t'" from this \<omega>' show ?thesis
	proof induction
	case 1 then show ?case
	by (cases \<omega>') auto
	qed auto
	next
	assume "\<exists>y. trace_in {y} t' x \<omega> \<and> trace_in ss t y \<omega>'" "\<not> t < t'"
	then obtain y where "trace_in {y} t' x \<omega>" "trace_in ss t y \<omega>'" "t' \<le> t"
	by auto
	from this \<omega>' show ?thesis
	by induction auto
	qed
	qed

	lemma AE_lim_wf_times: "AE \<omega> in K.lim_stream (t, s). wf_times t \<omega>"
	using AE_lim_stream
	proof eventually_elim
	fix \<omega> assume *: "\<forall>i. snd (((t, s) ## \<omega>) !! i) \<in> DTMC.acc `` {snd (t, s)} \<and>
	snd (\<omega> !! i) \<in> J (snd (((t, s) ## \<omega>) !! i)) \<and>
	fst (((t, s) ## \<omega>) !! i) < fst (\<omega> !! i)"
	have "(t ## smap fst \<omega>) !! i < fst (\<omega> !! i)" for i
	using *[THEN spec, of i] by (cases i) auto
	then show "wf_times t \<omega>"
	proof (coinduction arbitrary: t \<omega>)
	case wf_times from this[THEN spec, of 0] this[THEN spec, of "Suc i" for i] show ?case
	by (cases \<omega>) auto
	qed
	qed

	lemma wf_times_shiftD: "wf_times t' (smap (\<lambda>(t', y). (t' + t, y)) \<omega>) \<Longrightarrow> wf_times (t' - t) \<omega>"
	apply (coinduction arbitrary: t' t \<omega>)
	subgoal for t' t \<omega>
	apply (cases \<omega>; cases "shd \<omega>")
	- apply (auto simp: )
	+ apply auto
	subgoal for \<omega>' j x
	by (rule exI[of _ "j + t"]) auto
	done
	done

	lemma wf_times_shift[simp]: "wf_times t' (smap (\<lambda>(t', y). (t' + t, y)) \<omega>) = wf_times (t' - t) \<omega>"
	using wf_times_shiftD[of "t' - t" "-t" "smap (\<lambda>(t', y). (t' + t, y)) \<omega>"]
	by (auto simp: stream.map_comp stream.case_eq_if prod.case_eq_if wf_times_shiftD)

	lemma trace_in_unique: "trace_in {y1} t x \<omega> \<Longrightarrow> trace_in {y2} t x \<omega> \<Longrightarrow> y1 = y2"
	by (induction rule: trace_in.induct) auto

	lemma trace_at_eq: "trace_in {z} t x \<omega> \<Longrightarrow> trace_at x \<omega> t = z"
	by (induction rule: trace_in.induct) auto

	lemma AE_lim_acc: "AE \<omega> in K.lim_stream (t, x). \<forall>t z. trace_in {z} t x \<omega> \<longrightarrow> (x, z) \<in> DTMC.acc"
	using AE_lim_stream
	proof (eventually_elim, safe)
	fix t' z \<omega> assume *: "\<forall>i. snd (((t, x) ## \<omega>) !! i) \<in> DTMC.acc `` {snd (t, x)} \<and>
	snd (\<omega> !! i) \<in> J (snd (((t, x) ## \<omega>) !! i)) \<and> fst (((t, x) ## \<omega>) !! i) < fst (\<omega> !! i)"
	and t: "trace_in {z} t' x \<omega>"
	define X where "X = DTMC.acc `` {x}"
	have "(x ## smap snd \<omega>) !! i \<in> X" for i
	using *[THEN spec, of i] by (cases i) (auto simp: X_def)
	from t this have "z \<in> X"
	proof induction
	case (1 j y x \<omega>) with "1.prems"[of 0] show ?case
	by simp
	next
	case (2 j y \<omega> x) with "2.prems"[of "Suc i" for i] show ?case
	by simp
	qed
	then show "(x, z) \<in> DTMC.acc"
	by (simp add: X_def)
	qed

	lemma p_add:
	assumes "0 \<le> t" "0 \<le> t'"
	shows "p x y (t + t') = (LINT z\|count_space (DTMC.acc``{x}). p x z t * p z y t')"
	proof -
	interpret L: prob_space "K.lim_stream xy" for xy
	by (rule K.prob_space_lim_stream) simp
	interpret A: sigma_finite_measure "count_space (DTMC.acc``{x})"
	by (intro sigma_finite_measure_count_space_countable DTMC.countable_acc) simp
	interpret LA: pair_sigma_finite "count_space (DTMC.acc``{x})" "K.lim_stream xy" for xy
	by unfold_locales

	have "p x y (t + t') = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. indicator {\<omega>\<in>space T. trace_in {y} (t + t') x \<omega>} (merge_at \<omega> t \<omega>')
	\<partial>K.lim_stream (t, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
	unfolding p_def L.emeasure_eq_measure[symmetric]
	apply (subst lim_time_split[OF \<open>0 \<le> t\<close>])
	apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (intro nn_integral_cong)
	apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
	apply (measurable; fail)
	apply (measurable; fail)
	apply (simp add: in_space_lim_stream)
	done
	also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. indicator {\<omega>\<in>space T. trace_in {y} (t + t') x \<omega>} (merge_at \<omega> t (smap (\<lambda>(t'', s). (t'' + t, s)) \<omega>'))
	\<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
	unfolding lim_0[of t] by (subst nn_integral_distr) (measurable; fail)+
	also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. of_bool (\<exists>z\<in>DTMC.acc``{x}. trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
	\<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
	apply (rule nn_integral_cong_AE)
	using AE_lim_wf_times AE_lim_acc
	apply eventually_elim
	subgoal premises \<omega> for \<omega>
	apply (rule nn_integral_cong_AE)
	using AE_lim_wf_times AE_lim_acc
	apply eventually_elim
	using \<omega> assms
	apply (auto simp add: trace_in_merge_at indicator_eq_1_iff)
	done
	done
	also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. \<integral>\<^sup>+z. of_bool (trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
	\<partial>count_space (DTMC.acc``{x}) \<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
	by (intro nn_integral_cong of_bool_Bex_eq_nn_integral) (auto dest: trace_in_unique)
	also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+z. \<integral>\<^sup>+\<omega>'. of_bool (trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
	\<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>count_space (DTMC.acc``{x}) \<partial>K.lim_stream (0, x))"
	apply (subst LA.Fubini')
	apply (subst measurable_split_conv)
	apply (rule measurable_compose_countable'[OF _ measurable_fst])
	apply (auto simp: DTMC.countable_acc)
	done
	also have "\<dots> = (\<integral>\<^sup>+z. \<integral>\<^sup>+ \<omega>. of_bool (trace_in {z} t x \<omega>) * \<integral>\<^sup>+\<omega>'. of_bool (trace_in {y} t' z \<omega>')
	\<partial>K.lim_stream (0, z) \<partial>K.lim_stream (0, x) \<partial>count_space (DTMC.acc``{x}))"
	apply (subst LA.Fubini')
	apply (subst measurable_split_conv)
	apply (rule measurable_compose_countable'[OF _ measurable_fst])
	apply (rule nn_integral_measurable_subprob_algebra2)
	apply (measurable; fail)
	apply (rule measurable_prob_algebraD)
	apply (auto simp: DTMC.countable_acc trace_at_eq intro!: nn_integral_cong)
	done
	also have "\<dots> = (\<integral>\<^sup>+z. (\<integral>\<^sup>+ \<omega>. of_bool (trace_in {z} t x \<omega>)\<partial>K.lim_stream (0, x)) *
	(\<integral>\<^sup>+\<omega>'. of_bool (trace_in {y} t' z \<omega>') \<partial>K.lim_stream (0, z)) \<partial>count_space (DTMC.acc``{x}))"
	by (auto intro!: nn_integral_cong simp: nn_integral_multc)
	also have "\<dots> = (\<integral>\<^sup>+z. ennreal (p x z t) * ennreal (p z y t') \<partial>count_space (DTMC.acc``{x}))"
	unfolding p_def L.emeasure_eq_measure[symmetric]
	by (auto intro!: nn_integral_cong arg_cong2[where f="(*)"]
	simp: nn_integral_indicator[symmetric] simp del: nn_integral_indicator )
	finally have "(\<integral>\<^sup>+z. p x z t * p z y t' \<partial>count_space (DTMC.acc``{x})) = p x y (t + t')"
	by (simp add: ennreal_mult)
	then show ?thesis
	by (subst (asm) nn_integral_eq_integrable) auto
	qed

	end

	end
	diff --git a/thys/Markov_Models/ex/PCTL.thy b/thys/Markov_Models/ex/PCTL.thy
	--- a/thys/Markov_Models/ex/PCTL.thy
	+++ b/thys/Markov_Models/ex/PCTL.thy
	@@ -1,982 +1,982 @@
	(* Author: Johannes Hölzl <hoelzl@in.tum.de>
	Author: Tobias Nipkow <nipkow@in.tum.de> *)
	theory PCTL
	imports
	"../Discrete_Time_Markov_Chain"
	"Gauss-Jordan-Elim-Fun.Gauss_Jordan_Elim_Fun"
	"HOL-Library.While_Combinator"
	"HOL-Library.Monad_Syntax"
	begin

	section \<open>Adapt Gauss-Jordan elimination to DTMCs\<close>

	locale Finite_DTMC =
	fixes K :: "'s \<Rightarrow> 's pmf" and S :: "'s set" and \<rho> :: "'s \<Rightarrow> real" and \<iota> :: "'s \<Rightarrow> 's \<Rightarrow> real"
	assumes \<iota>_nonneg[simp]: "\<And>s t. 0 \<le> \<iota> s t" and \<rho>_nonneg[simp]: "\<And>s. 0 \<le> \<rho> s"
	assumes measurable_\<iota>: "(\<lambda>(a, b). \<iota> a b) \<in> borel_measurable (count_space UNIV \<Otimes>\<^sub>M count_space UNIV)"
	assumes finite_S[simp]: "finite S" and S_not_empty: "S \<noteq> {}"
	assumes E_closed: "(\<Union>s\<in>S. set_pmf (K s)) \<subseteq> S"
	begin

	lemma measurable_\<iota>'[measurable (raw)]:
	"f \<in> measurable M (count_space UNIV) \<Longrightarrow> g \<in> measurable M (count_space UNIV) \<Longrightarrow>
	(\<lambda>x. \<iota> (f x) (g x)) \<in> borel_measurable M"
	using measurable_compose[OF _ measurable_\<iota>, of "\<lambda>x. (f x, g x)" M] by simp

	lemma measurable_\<rho>[measurable]: "\<rho> \<in> borel_measurable (count_space UNIV)"
	by simp

	sublocale R?: MC_with_rewards K \<iota> \<rho>
	by standard (auto intro: \<iota>_nonneg \<rho>_nonneg)

	lemma single_l:
	fixes s and x :: real assumes "s \<in> S"
	shows "(\<Sum>s'\<in>S. (if s' = s then 1 else 0) * l s') = x \<longleftrightarrow> l s = x"
	by (simp add: assms if_distrib [of "\<lambda>x. x * a" for a] cong: if_cong)

	definition "order = (SOME f. bij_betw f {..< card S} S)"

	lemma
	shows bij_order[simp]: "bij_betw order {..< card S} S"
	and inj_order[simp]: "inj_on order {..<card S}"
	and image_order[simp]: "order ` {..<card S} = S"
	and order_S[simp, intro]: "\<And>i. i < card S \<Longrightarrow> order i \<in> S"
	proof -
	from finite_same_card_bij[OF _ finite_S] show "bij_betw order {..< card S} S"
	unfolding order_def by (rule someI_ex) auto
	then show "inj_on order {..<card S}" "order ` {..<card S} = S"
	unfolding bij_betw_def by auto
	then show "\<And>i. i < card S \<Longrightarrow> order i \<in> S"
	by auto
	qed

	lemma order_Ex:
	assumes "s \<in> S" obtains i where "i < card S" "s = order i"
	proof -
	from \<open>s \<in> S\<close> have "s \<in> order ` {..<card S}"
	by simp
	with that show thesis
	by (auto simp del: image_order)
	qed

	definition "iorder = the_inv_into {..<card S} order"

	lemma bij_iorder: "bij_betw iorder S {..<card S}"
	unfolding iorder_def by (rule bij_betw_the_inv_into bij_order)+

	lemma iorder_image_eq: "iorder ` S = {..<card S}"
	and inj_iorder: "inj_on iorder S"
	using bij_iorder unfolding bij_betw_def by auto

	lemma order_iorder: "\<And>s. s \<in> S \<Longrightarrow> order (iorder s) = s"
	unfolding iorder_def using bij_order
	by (intro f_the_inv_into_f) (auto simp: bij_betw_def)

	definition gauss_jordan' :: "('s \<Rightarrow> 's \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) option" where
	"gauss_jordan' M a = do {
	let M' = (\<lambda>i j. if j = card S then a (order i) else M (order i) (order j)) ;
	sol \<leftarrow> gauss_jordan M' (card S) ;
	Some (\<lambda>i. sol (iorder i) (card S))
	}"

	lemma gauss_jordan'_correct:
	assumes "gauss_jordan' M a = Some f"
	shows "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * f s') = a s"
	proof -
	note \<open>gauss_jordan' M a = Some f\<close>
	moreover define M' where "M' = (\<lambda>i j. if j = card S then
	a (order i) else M (order i) (order j))"
	ultimately obtain sol where sol: "gauss_jordan M' (card S) = Some sol"
	and f: "f = (\<lambda>i. sol (iorder i) (card S))"
	by (auto simp: gauss_jordan'_def Let_def split: bind_split_asm)

	from gauss_jordan_correct[OF sol]
	have "\<forall>i\<in>{..<card S}. (\<Sum>j<card S. M (order i) (order j) * sol j (card S)) = a (order i)"
	unfolding solution_def M'_def by (simp add: atLeast0LessThan)
	then show ?thesis
	unfolding iorder_image_eq[symmetric] f using inj_iorder
	by (subst (asm) sum.reindex) (auto simp: order_iorder)
	qed

	lemma gauss_jordan'_complete:
	assumes exists: "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x s') = a s"
	assumes unique: "\<And>y. \<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * y s') = a s \<Longrightarrow> \<forall>s\<in>S. y s = x s"
	shows "\<exists>y. gauss_jordan' M a = Some y"
	proof -
	define M' where "M' = (\<lambda>i j. if j = card S then
	a (order i) else M (order i) (order j))"

	{ fix x
	have iorder_neq_card_S: "\<And>s. s \<in> S \<Longrightarrow> iorder s \<noteq> card S"
	using iorder_image_eq by (auto simp: set_eq_iff less_le)
	have "solution2 M' (card S) (card S) x \<longleftrightarrow>
	(\<forall>s\<in>{..<card S}. (\<Sum>s'\<in>{..<card S}. M' s s' * x s') = M' s (card S))"
	unfolding solution2_def by (auto simp: atLeast0LessThan)
	also have "\<dots> \<longleftrightarrow> (\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x (iorder s')) = a s)"
	unfolding iorder_image_eq[symmetric] M'_def
	using inj_iorder iorder_neq_card_S
	by (simp add: sum.reindex order_iorder)
	finally have "solution2 M' (card S) (card S) x \<longleftrightarrow>
	(\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * x (iorder s')) = a s)" . }
	note sol2_eq = this
	have "usolution M' (card S) (card S) (\<lambda>i. x (order i))"
	unfolding usolution_def
	proof safe
	from exists show "solution2 M' (card S) (card S) (\<lambda>i. x (order i))"
	by (simp add: sol2_eq order_iorder)
	next
	fix y j assume y: "solution2 M' (card S) (card S) y" and "j < card S"
	then have "\<forall>s\<in>S. (\<Sum>s'\<in>S. M s s' * y (iorder s')) = a s"
	by (simp add: sol2_eq)
	from unique[OF this]
	have "\<forall>i\<in>{..<card S}. y i = x (order i)"
	unfolding iorder_image_eq[symmetric]
	by (simp add: order_iorder)
	with \<open>j < card S\<close> show "y j = x (order j)" by simp
	qed
	from gauss_jordan_complete[OF _ this]
	show ?thesis
	by (auto simp: gauss_jordan'_def simp: M'_def)
	qed

	end

	section \<open>pCTL model checking\<close>

	subsection \<open>Syntax\<close>

	datatype realrel = LessEqual \| Less \| Greater \| GreaterEqual \| Equal

	datatype 's sform = "true"
	\| "Label" "'s set"
	\| "Neg" "'s sform"
	\| "And" "'s sform" "'s sform"
	\| "Prob" "realrel" "real" "'s pform"
	\| "Exp" "realrel" "real" "'s eform"
	and 's pform = "X" "'s sform"
	\| "U" "nat" "'s sform" "'s sform"
	\| "UInfinity" "'s sform" "'s sform" ("U\<^sup>\<infinity>")
	and 's eform = "Cumm" "nat" ("C\<^sup>\<le>")
	\| "State" "nat" ("I\<^sup>=")
	\| "Future" "'s sform"

	primrec bound_until where
	"bound_until 0 \<phi> \<psi> = \<psi>"
	\| "bound_until (Suc n) \<phi> \<psi> = \<psi> or (\<phi> aand nxt (bound_until n \<phi> \<psi>))"

	lemma measurable_bound_until[measurable]:
	assumes [measurable]: "Measurable.pred (stream_space M) \<phi>" "Measurable.pred (stream_space M) \<psi>"
	shows "Measurable.pred (stream_space M) (bound_until n \<phi> \<psi>)"
	by (induct n) simp_all

	subsection \<open>Semantics\<close>

	primrec inrealrel :: "realrel \<Rightarrow> 'a \<Rightarrow> ('a::linorder) \<Rightarrow> bool" where
	"inrealrel LessEqual r q \<longleftrightarrow> q \<le> r" \|
	"inrealrel Less r q \<longleftrightarrow> q < r" \|
	"inrealrel Greater r q \<longleftrightarrow> q > r" \|
	"inrealrel GreaterEqual r q \<longleftrightarrow> q \<ge> r" \|
	"inrealrel Equal r q \<longleftrightarrow> q = r"

	context Finite_DTMC
	begin

	abbreviation "prob s P \<equiv> measure (T s) {x\<in>space (T s). P x}"
	abbreviation "E s \<equiv> set_pmf (K s)"

	primrec svalid :: "'s sform \<Rightarrow> 's set"
	and pvalid :: "'s pform \<Rightarrow> 's stream \<Rightarrow> bool"
	and reward :: "'s eform \<Rightarrow> 's stream \<Rightarrow> ennreal" where
	"svalid true = S" \|
	"svalid (Label L) = {s \<in> S. s \<in> L}" \|
	"svalid (Neg F) = S - svalid F" \|
	"svalid (And F1 F2) = svalid F1 \<inter> svalid F2" \|
	"svalid (Prob rel r F) = {s \<in> S. inrealrel rel r \<P>(\<omega> in T s. pvalid F (s ## \<omega>)) }" \|
	"svalid (Exp rel r F) = {s \<in> S. inrealrel rel (ennreal r) (\<integral>\<^sup>+ \<omega>. reward F (s ## \<omega>) \<partial>T s) }" \|

	"pvalid (X F) = nxt (HLD (svalid F))" \|
	"pvalid (U k F1 F2) = bound_until k (HLD (svalid F1)) (HLD (svalid F2))" \|
	"pvalid (U\<^sup>\<infinity> F1 F2) = HLD (svalid F1) suntil HLD (svalid F2)" \|

	"reward (C\<^sup>\<le> k) = (\<lambda>\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))))" \|
	"reward (I\<^sup>= k) = (\<lambda>\<omega>. \<rho> (\<omega> !! k))" \|
	"reward (Future F) = (\<lambda>\<omega>. if ev (HLD (svalid F)) \<omega> then reward_until (svalid F) (shd \<omega>) (stl \<omega>) else \<infinity>)"

	lemma svalid_subset_S: "svalid F \<subseteq> S"
	by (induct F) auto

	lemma finite_svalid[simp, intro]: "finite (svalid F)"
	using svalid_subset_S finite_S by (blast intro: finite_subset)

	lemma svalid_sets[measurable]: "svalid F \<in> sets (count_space S)"
	using svalid_subset_S by auto

	lemma pvalid_sets[measurable]: "Measurable.pred R.S (pvalid F)"
	by (cases F) (auto intro!: svalid_sets)

	lemma reward_measurable[measurable]: "reward F \<in> borel_measurable R.S"
	by (cases F) auto

	subsection \<open>Implementation of \<open>Sat\<close>\<close>

	subsubsection \<open>\<open>Prob0\<close>\<close>

	definition Prob0 where
	"Prob0 \<Phi> \<Psi> = S - while (\<lambda>R. \<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R) (\<lambda>R. R \<union> {s\<in>\<Phi>. R \<inter> E s \<noteq> {}}) \<Psi>"

	lemma Prob0_subset_S: "Prob0 \<Phi> \<Psi> \<subseteq> S"
	unfolding Prob0_def by auto

	lemma Prob0_iff_reachable:
	assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
	shows "Prob0 \<Phi> \<Psi> = {s \<in> S. ((SIGMA x:\<Phi>. E x)\<^sup>* `` {s}) \<inter> \<Psi> = {}}" (is "_ = ?U")
	unfolding Prob0_def
	proof (intro while_rule[where Q="\<lambda>R. S - R = ?U" and P="\<lambda>R. \<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U"] conjI)
	show "wf {(B, A). A \<subset> B \<and> B \<subseteq> S}"
	by (rule wf_bounded_set[where ub="\<lambda>_. S" and f="\<lambda>x. x"]) auto
	show "\<Psi> \<subseteq> S - ?U"
	using assms by auto

	let ?\<Delta> = "\<lambda>R. {s\<in>\<Phi>. R \<inter> E s \<noteq> {}}"
	{ fix R assume R: "\<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U" and "\<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R"
	with assms show "(R \<union> ?\<Delta> R, R) \<in> {(B, A). A \<subset> B \<and> B \<subseteq> S}" "\<Psi> \<subseteq> R \<union> ?\<Delta> R"
	by auto

	{ fix s s' assume s: "s \<in> \<Phi>" "s' \<in> R" "s' \<in> E s" and r: "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
	with R have "(s, s') \<in> (Sigma \<Phi> E)\<^sup>*" "s' \<in> \<Phi> - \<Psi>"
	by (auto elim: converse_rtranclE)
	moreover with \<open>s' \<in> R\<close> R obtain s'' where "(s', s'') \<in> (Sigma \<Phi> E)\<^sup>*" "s'' \<in> \<Psi>"
	by auto
	ultimately have "(s, s'') \<in> (Sigma \<Phi> E)\<^sup>*" "s'' \<in> \<Psi>"
	by auto
	with r have False
	by auto }
	with \<open>\<Phi> \<subseteq> S\<close> R show "R \<union> ?\<Delta> R \<subseteq> S - ?U" by auto }

	{ fix R assume R: "\<Psi> \<subseteq> R \<and> R \<subseteq> S - ?U" and dR: "\<not> (\<exists>s\<in>\<Phi>. R \<inter> E s \<noteq> {} \<and> s \<notin> R)"
	{ fix s t assume s: "s \<in> S - R"
	assume s_t: "(s, t) \<in> (Sigma \<Phi> E)\<^sup>*" then have "t \<in> S - R"
	proof induct
	case (step t u) with R dR E_closed show ?case
	by auto
	qed fact
	then have "t \<notin> \<Psi>"
	using R by auto }
	with R show "S - R = ?U"
	by auto }
	qed rule

	lemma Prob0_iff:
	assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
	shows "Prob0 \<Phi> \<Psi> = {s\<in>S. AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}" (is "_ = ?U")
	unfolding Prob0_iff_reachable[OF assms]
	proof (intro Collect_cong conj_cong refl iffI)
	fix s assume s: "s \<in> S" "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
	{ fix \<omega> assume "(HLD \<Phi> suntil HLD \<Psi>) \<omega>" "enabled (shd \<omega>) (stl \<omega>)" "(Sigma \<Phi> E)\<^sup>* `` {shd \<omega>} \<inter> \<Psi> = {}"
	from this have False
	proof induction
	case (step \<omega>)
	moreover
	then have "(shd \<omega>, shd (stl \<omega>)) \<in> (Sigma \<Phi> E)\<^sup>*"
	by (auto simp: enabled.simps[of _ "stl \<omega>"] HLD_iff)
	then have "(Sigma \<Phi> E)\<^sup>* `` {shd (stl \<omega>)} \<subseteq> (Sigma \<Phi> E)\<^sup>* `` {shd \<omega>}"
	by auto
	ultimately show ?case
	by (auto simp add: enabled.simps[of _ "stl \<omega>"])
	qed (auto simp: HLD_iff) }
	from s this[of "s ## \<omega>" for \<omega>] show "AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
	using AE_T_enabled[of s] by auto
	next
	fix s assume s: "AE \<omega> in T s. \<not> (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
	{ fix t assume "(s, t) \<in> (Sigma \<Phi> E)\<^sup>*" from this s have "t \<notin> \<Psi>"
	proof (induction rule: converse_rtrancl_induct)
	case (step s u) then show ?case
	by (simp add: AE_T_iff[where x=s] suntil_Stream[of _ _ s])
	qed (simp add: suntil_Stream) }
	then show "(Sigma \<Phi> E)\<^sup>* `` {s} \<inter> \<Psi> = {}"
	by auto
	qed

	lemma E_rtrancl_closed:
	assumes "s \<in> S" "(s, t) \<in> (SIGMA x:A. B x)\<^sup>*" "\<And>x. x \<in> A \<Longrightarrow> B x \<subseteq> E x" shows "t \<in> S"
	using assms(2,3,1) E_closed by induction force+

	subsubsection \<open>\<open>Prob1\<close>\<close>

	definition Prob1 where
	"Prob1 Y \<Phi> \<Psi> = Prob0 (\<Phi> - \<Psi>) Y"

	lemma Prob1_iff:
	assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S"
	shows "Prob1 (Prob0 \<Phi> \<Psi>) \<Phi> \<Psi> = {s\<in>S. AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}"
	(is "Prob1 ?P0 _ _ = {s\<in>S. ?pU s}")
	proof -
	note P0 = Prob0_iff_reachable[OF assms]
	have *: "\<Phi> - \<Psi> \<subseteq> S" "?P0 \<subseteq> S"
	using P0 assms by auto

	have P0_subset: "S - \<Phi> - \<Psi> \<subseteq> ?P0"
	unfolding P0 by (auto elim: converse_rtranclE)

	have "Prob1 ?P0 \<Phi> \<Psi> = {s \<in> S. (Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> ?P0 = {}}"
	unfolding Prob0_iff_reachable[OF *] Prob1_def ..
	also have "\<dots> = {s\<in>S. AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)}"
	proof (intro Collect_cong conj_cong refl iffI)
	fix s assume s: "s \<in> S" "(Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> ?P0 = {}"
	then have "s \<notin> ?P0"
	by auto
	then have "s \<in> \<Phi> - \<Psi> \<or> s \<in> \<Psi>"
	using P0_subset \<open>s \<in> S\<close> by auto
	moreover
	{ assume "s \<in> \<Phi> - \<Psi>"
	have "AE \<omega> in T s. ev (HLD (\<Psi> \<union> ?P0)) \<omega>"
	proof (rule AE_T_ev_HLD)
	fix t assume s_t: "(s, t) \<in> acc_on (- (\<Psi> \<union> ?P0))"
	from \<open>s \<in> S\<close> s_t have "t \<in> S"
	by (rule E_rtrancl_closed) auto

	show "\<exists>t'\<in>\<Psi> \<union> ?P0. (t, t') \<in> acc"
	proof cases
	assume "t \<in> ?P0" then show ?thesis by auto
	next
	assume "t \<notin> ?P0"
	with \<open>t\<in>S\<close> obtain s where t_s: "(t, s) \<in> (SIGMA x:\<Phi>. E x)\<^sup>*" and "s \<in> \<Psi>"
	unfolding P0 by auto
	from t_s have "(t, s) \<in> acc"
	by (rule rev_subsetD) (intro rtrancl_mono Sigma_mono, auto)
	with \<open>s \<in> \<Psi>\<close> show ?thesis by auto
	qed
	next
	have "acc_on (- (\<Psi> \<union> ?P0)) `` {s} \<subseteq> S"
	using \<open>s \<in> S\<close> by (auto intro: E_rtrancl_closed)
	then show "finite (acc_on (- (\<Psi> \<union> ?P0)) `` {s})"
	using finite_S by (auto dest: finite_subset)
	qed
	then have "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) \<omega>"
	using AE_T_enabled
	proof eventually_elim
	fix \<omega> assume "ev (HLD (\<Psi> \<union> ?P0)) \<omega>" "enabled s \<omega>"
	from this s \<open>s \<in> \<Phi> - \<Psi>\<close> show "(HLD \<Phi> suntil HLD \<Psi>) \<omega>"
	proof (induction arbitrary: s)
	case (base \<omega>) then show ?case
	by (auto simp: HLD_iff enabled.simps[of s] intro: suntil.intros)
	next
	case (step \<omega>)
	then have "(s, shd \<omega>) \<in> (Sigma (\<Phi> - \<Psi>) E)"
	by (auto simp: enabled.simps[of s])
	then have : "(Sigma (\<Phi> - \<Psi>) E)\<^sup> `` {shd \<omega>} \<inter> ?P0 = {}"
	using step.prems by (auto intro: converse_rtrancl_into_rtrancl)
	then have "shd \<omega> \<in> \<Phi> - \<Psi> \<or> shd \<omega> \<in> \<Psi>" "shd \<omega> \<in> S"
	using P0_subset step.prems(1,2) E_closed by (auto simp add: enabled.simps[of s])
	then show ?case
	using step.prems(1) step.IH[OF _ _ *] \<open>shd \<omega> \<in> S\<close>
	by (auto simp add: suntil.simps[of _ _ \<omega>] HLD_iff[abs_def] enabled.simps[of s \<omega>])
	qed
	qed }
	ultimately show "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
	by (cases "s \<in> \<Phi> - \<Psi>") (auto simp add: suntil_Stream)
	next
	fix s assume s: "s \<in> S" "AE \<omega> in T s. (HLD \<Phi> suntil HLD \<Psi>) (s ## \<omega>)"
	{ fix t assume "(s, t) \<in> (SIGMA s:\<Phi>-\<Psi>. E s)\<^sup>*"
	from this \<open>s \<in> S\<close> have "(AE \<omega> in T t. (HLD \<Phi> suntil HLD \<Psi>) (t ## \<omega>)) \<and> t \<in> S"
	proof induction
	case (step t u) with E_closed show ?case
	by (auto simp add: AE_T_iff[of _ t] suntil_Stream)
	qed (insert s, auto)
	then have "t \<notin> ?P0"
	unfolding Prob0_iff[OF assms] by (auto dest: T.AE_contr) }
	then show "(Sigma (\<Phi> - \<Psi>) E)\<^sup>* `` {s} \<inter> Prob0 \<Phi> \<Psi> = {}"
	by auto
	qed
	finally show ?thesis .
	qed

	subsubsection \<open>\<open>ProbU\<close>, \<open>ExpCumm\<close>, and \<open>ExpState\<close>\<close>

	abbreviation "\<tau> s t \<equiv> pmf (K s) t"

	fun ProbU :: "'s \<Rightarrow> nat \<Rightarrow> 's set \<Rightarrow> 's set \<Rightarrow> real" where
	"ProbU q 0 S1 S2 = (if q \<in> S2 then 1 else 0)" \|
	"ProbU q (Suc k) S1 S2 =
	(if q \<in> S1 - S2 then (\<Sum>q'\<in>S. \<tau> q q' * ProbU q' k S1 S2)
	else if q \<in> S2 then 1 else 0)"

	fun ExpCumm :: "'s \<Rightarrow> nat \<Rightarrow> ennreal" where
	"ExpCumm s 0 = 0" \|
	"ExpCumm s (Suc k) = \<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * (\<iota> s s' + ExpCumm s' k))"

	fun ExpState :: "'s \<Rightarrow> nat \<Rightarrow> ennreal" where
	"ExpState s 0 = \<rho> s" \|
	"ExpState s (Suc k) = (\<Sum>s'\<in>S. \<tau> s s' * ExpState s' k)"

	subsubsection \<open>\<open>LES\<close>\<close>

	definition LES :: "'s set \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> real" where
	"LES F r c =
	(if r \<in> F then (if c = r then 1 else 0)
	else (if c = r then \<tau> r c - 1 else \<tau> r c ))"


	subsubsection \<open>\<open>ProbUinfty\<close>, compute unbounded until\<close>

	definition ProbUinfty :: "'s set \<Rightarrow> 's set \<Rightarrow> ('s \<Rightarrow> real) option" where
	"ProbUinfty S1 S2 = gauss_jordan' (LES (Prob0 S1 S2 \<union> S2))
	(\<lambda>i. if i \<in> S2 then 1 else 0)"

	subsubsection \<open>\<open>ExpFuture\<close>, compute unbounded reward\<close>

	definition ExpFuture :: "'s set \<Rightarrow> ('s \<Rightarrow> ennreal) option" where
	"ExpFuture F = do {
	let N = Prob0 S F ;
	let Y = Prob1 N S F ;
	sol \<leftarrow> gauss_jordan' (LES (S - Y \<union> F))
	(\<lambda>i. if i \<in> Y \<and> i \<notin> F then - \<rho> i - (\<Sum>s'\<in>S. \<tau> i s' * \<iota> i s') else 0) ;
	Some (\<lambda>s. if s \<in> Y then ennreal (sol s) else \<infinity>)
	}"

	subsubsection \<open>\<open>Sat\<close>\<close>

	fun Sat :: "'s sform \<Rightarrow> 's set option" where
	"Sat true = Some S" \|
	"Sat (Label L) = Some {s \<in> S. s \<in> L}" \|
	"Sat (Neg F) = do { F \<leftarrow> Sat F ; Some (S - F) }" \|
	"Sat (And F1 F2) = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; Some (F1 \<inter> F2) }" \|

	"Sat (Prob rel r (X F)) = do { F \<leftarrow> Sat F ; Some {q \<in> S. inrealrel rel r (\<Sum>q'\<in>F. \<tau> q q')} }" \|
	"Sat (Prob rel r (U k F1 F2)) = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; Some {q \<in> S. inrealrel rel r (ProbU q k F1 F2) } }" \|
	"Sat (Prob rel r (U\<^sup>\<infinity> F1 F2)) = do { F1 \<leftarrow> Sat F1 ; F2 \<leftarrow> Sat F2 ; P \<leftarrow> ProbUinfty F1 F2 ; Some {q \<in> S. inrealrel rel r (P q) } }" \|

	"Sat (Exp rel r (Cumm k)) = Some {s \<in> S. inrealrel rel r (ExpCumm s k) }" \|
	"Sat (Exp rel r (State k)) = Some {s \<in> S. inrealrel rel r (ExpState s k) }" \|
	"Sat (Exp rel r (Future F)) = do { F \<leftarrow> Sat F ; E \<leftarrow> ExpFuture F ; Some {q \<in> S. inrealrel rel (ennreal r) (E q) } }"


	lemma prob_sum:
	"s \<in> S \<Longrightarrow> Measurable.pred R.S P \<Longrightarrow> \<P>(\<omega> in T s. P \<omega>) = (\<Sum>t\<in>S. \<tau> s t * \<P>(\<omega> in T t. P (t ## \<omega>)))"
	unfolding prob_T using E_closed by (subst integral_measure_pmf[OF finite_S]) (auto simp: mult.commute)

	lemma nn_integral_eq_sum:
	"s \<in> S \<Longrightarrow> f \<in> borel_measurable R.S \<Longrightarrow> (\<integral>\<^sup>+x. f x \<partial>T s) = (\<Sum>t\<in>S. \<tau> s t * (\<integral>\<^sup>+x. f (t ## x) \<partial>T t))"
	unfolding nn_integral_T using E_closed
	by (subst nn_integral_measure_pmf_support[OF finite_S])
	(auto simp: mult.commute)

	lemma T_space[simp]: "measure (T s) (space R.S) = 1"
	using T.prob_space by simp

	lemma emeasure_T_space[simp]: "emeasure (T s) (space R.S) = 1"
	using T.emeasure_space_1 by simp

	lemma \<tau>_distr[simp]: "s \<in> S \<Longrightarrow> (\<Sum>t\<in>S. \<tau> s t) = 1"
	using prob_sum[of s "\<lambda>_. True"] by simp

	lemma ProbU:
	"q \<in> S \<Longrightarrow> ProbU q k (svalid F1) (svalid F2) = \<P>(\<omega> in T q. pvalid (U k F1 F2) (q ## \<omega>))"
	proof (induct k arbitrary: q)
	case 0 with T.prob_space show ?case by simp
	next
	case (Suc k)

	have "\<P>(\<omega> in T q. pvalid (U (Suc k) F1 F2) (q ## \<omega>)) =
	(if q \<in> svalid F2 then 1 else if q \<in> svalid F1 then
	\<Sum>t\<in>S. \<tau> q t * \<P>(\<omega> in T t. pvalid (U k F1 F2) (t ## \<omega>)) else 0)"
	using \<open>q \<in> S\<close> by (subst prob_sum) simp_all
	also have "\<dots> = ProbU q (Suc k) (svalid F1) (svalid F2)"
	using Suc by simp
	finally show ?case ..
	qed

	lemma Prob0_imp_not_Psi:
	assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S" "s \<in> Prob0 \<Phi> \<Psi>" shows "s \<notin> \<Psi>"
	proof -
	have "s \<in> S" using \<open>s \<in> Prob0 \<Phi> \<Psi>\<close> Prob0_subset_S by auto
	with assms show ?thesis by (auto simp add: Prob0_iff suntil_Stream)
	qed

	lemma Psi_imp_not_Prob0:
	assumes "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S" shows "s \<in> \<Psi> \<Longrightarrow> s \<notin> Prob0 \<Phi> \<Psi>"
	using Prob0_imp_not_Psi[OF assms] by metis

	subsubsection \<open>Finite expected reward\<close>

	abbreviation "s0 \<equiv> SOME s. s \<in> S"

	lemma s0_in_S: "s0 \<in> S"
	using S_not_empty by (auto intro!: someI_ex[of "\<lambda>x. x \<in> S"])

	lemma nn_integral_reward_finite:
	assumes "s \<in> S"
	assumes until: "AE \<omega> in T s. (HLD S suntil HLD (svalid F)) (s ## \<omega>)"
	shows "(\<integral>\<^sup>+ \<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) \<noteq> \<infinity>"
	proof -
	have "(\<integral>\<^sup>+ \<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = (\<integral>\<^sup>+ \<omega>. reward_until (svalid F) s \<omega> \<partial>T s)"
	using until by (auto intro!: nn_integral_cong_AE ev_suntil)
	also have "\<dots> \<noteq> \<infinity>"
	proof cases
	assume "s \<notin> svalid F"
	show ?thesis
	proof (rule nn_integral_reward_until_finite)
	have "acc `` {s} \<subseteq> S"
	using E_rtrancl_closed[of s _ _ E] \<open>s \<in> S\<close> by auto
	then show "finite (acc `` {s})"
	using finite_S by (auto dest: finite_subset)
	show "AE \<omega> in T s. (ev (HLD (svalid F))) \<omega>"
	using until by (auto simp add: suntil_Stream \<open>s \<notin> svalid F\<close> intro: ev_suntil)
	qed auto
	qed simp
	finally show ?thesis .
	qed

	lemma unique:
	assumes in_S: "\<Phi> \<subseteq> S" "\<Psi> \<subseteq> S" "N \<subseteq> S" "Prob0 \<Phi> \<Psi> \<subseteq> N" "\<Psi> \<subseteq> N"
	assumes l1: "\<And>s. s \<in> S \<Longrightarrow> s \<notin> N \<Longrightarrow> l1 s - c s = (\<Sum>s'\<in>S. \<tau> s s' * l1 s')"
	assumes l2: "\<And>s. s \<in> S \<Longrightarrow> s \<notin> N \<Longrightarrow> l2 s - c s = (\<Sum>s'\<in>S. \<tau> s s' * l2 s')"
	assumes eq: "\<And>s. s \<in> N \<Longrightarrow> l1 s = l2 s"
	shows "\<forall>s\<in>S. l1 s = l2 s"
	proof
	fix s assume "s \<in> S"
	show "l1 s = l2 s"
	proof cases
	assume "s \<in> N" then show ?thesis
	by (rule eq)
	next
	assume "s \<notin> N"
	show ?thesis
	proof (rule unique_les[of _ "S - N" K N])
	show "finite ((\<lambda>x. l1 x - l2 x) ` (S - N \<union> N))" "(\<Union>x\<in>S - N. E x) \<subseteq> S - N \<union> N"
	using E_closed finite_S \<open>N \<subseteq> S\<close> by (auto dest: finite_subset)
	show "\<And>s. s \<in> N \<Longrightarrow> l1 s = l2 s" by fact
	{ fix s assume "s \<in> S - N" with E_closed finite_S show "integrable (K s) l1" "integrable (K s) l2"
	by (auto intro!: integrable_measure_pmf_finite dest: finite_subset)
	obtain t where "(t \<in> \<Psi> \<and> (s, t) \<in> (Sigma \<Phi> E)\<^sup>*) \<or> s \<in> N"
	using \<open>s \<in> S - N\<close> in_S(4) unfolding Prob0_iff_reachable[OF in_S(1,2)] by auto
	moreover have "(Sigma \<Phi> E)\<^sup>* \<subseteq> acc"
	by (intro rtrancl_mono Sigma_mono) auto
	ultimately show "\<exists>t\<in>N. (s, t) \<in> acc"
	using \<open>\<Psi> \<subseteq> N\<close> by auto
	show "l1 s = integral\<^sup>L (K s) l1 + c s"
	using E_closed l1 \<open>s \<in> S - N\<close>
	by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps)
	show "l2 s = integral\<^sup>L (K s) l2 + c s"
	using E_closed l2 \<open>s \<in> S - N\<close>
	by (subst integral_measure_pmf[OF finite_S]) (auto simp: subset_eq field_simps) }
	qed (insert \<open>s \<notin> N\<close> \<open>s \<in> S\<close>, auto)
	qed
	qed

	lemma uniqueness_of_ProbU:
	assumes sol:
	"\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2) s s' * l s') =
	(if s \<in> svalid F2 then 1 else 0)"
	shows "\<forall>s\<in>S. l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
	proof (rule unique)
	show "svalid F1 \<subseteq> S" "svalid F2 \<subseteq> S"
	"Prob0 (svalid F1) (svalid F2) \<subseteq> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
	"svalid F2 \<subseteq> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
	"Prob0 (svalid F1) (svalid F2) \<union> svalid F2 \<subseteq> S"
	using svalid_subset_S by (auto simp: Prob0_def)
	next
	fix s assume s: "s \<in> S" "s \<notin> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
	have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s') =
	(\<Sum>s'\<in>S. \<tau> s s' * l s' - (if s' = s then 1 else 0) * l s')"
	by (auto intro!: sum.cong simp: field_simps)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
	using \<open>s \<in> S\<close> by (simp add: sum_subtractf single_l)
	finally show "l s - 0 = (\<Sum>s'\<in>S. \<tau> s s' * l s')"
	using sol[THEN bspec, of s] s by (simp add: LES_def)
	next
	fix s assume s: "s \<in> S" "s \<notin> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
	then show "\<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>)) - 0 =
	(\<Sum>t\<in>S. \<tau> s t * \<P>(\<omega> in T t. pvalid (U\<^sup>\<infinity> F1 F2) (t ## \<omega>)))"
	unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S]
	by (subst prob_sum) (auto simp add: suntil_Stream)
	next
	fix s assume "s \<in> Prob0 (svalid F1) (svalid F2) \<union> svalid F2"
	then show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
	proof
	assume P0: "s \<in> Prob0 (svalid F1) (svalid F2)"
	then have "s \<in> S" "AE \<omega> in T s. \<not> (HLD (svalid F1) suntil HLD (svalid F2)) (s ## \<omega>)"
	unfolding Prob0_iff[OF svalid_subset_S svalid_subset_S] by auto
	then have "\<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>)) = 0"
	by (intro T.prob_eq_0_AE) simp
	moreover have "l s = 0"
	using \<open>s \<in> S\<close> P0 sol[THEN bspec, of s] Prob0_subset_S
	Prob0_imp_not_Psi[OF svalid_subset_S svalid_subset_S P0]
	by (auto simp: LES_def single_l split: if_split_asm)
	ultimately show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))" by simp
	next
	assume s: "s \<in> svalid F2"
	moreover with svalid_subset_S have "s \<in> S" by auto
	moreover note Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S s]
	ultimately have "l s = 1"
	using sol[THEN bspec, of s]
	by (auto simp: LES_def single_l dest: Psi_imp_not_Prob0[OF svalid_subset_S svalid_subset_S])
	then show "l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
	using s by (simp add: suntil_Stream)
	qed
	qed

	lemma infinite_reward:
	fixes s F
	defines "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
	defines "Y \<equiv> Prob1 N S (svalid F)"
	assumes s: "s \<in> S" "s \<notin> Y"
	shows "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = \<infinity>"
	proof -
	{ assume "(AE \<omega> in T s. ev (HLD ?F) \<omega>)"
	with AE_T_enabled have "(AE \<omega> in T s. (HLD S suntil HLD ?F) \<omega>)"
	proof eventually_elim
	fix \<omega> assume "ev (HLD ?F) \<omega>" "enabled s \<omega>"
	from this \<open>s \<in> S\<close> show "(HLD S suntil HLD ?F) \<omega>"
	proof (induction arbitrary: s)
	case (step \<omega>) show ?case
	using E_closed step.IH[of "shd \<omega>"] step.prems
	by (auto simp: subset_eq enabled.simps[of s] suntil.simps[of _ _ \<omega>] HLD_iff)
	qed (auto intro: suntil.intros)
	qed }
	moreover have "\<not> (AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>))"
	using s svalid_subset_S unfolding N_def Y_def by (simp add: Prob1_iff)
	ultimately have *: "\<not> (AE \<omega> in T s. ev (HLD ?F) (s ## \<omega>))"
	using \<open>s \<in> S\<close> by (cases "s \<in> ?F") (auto simp add: suntil_Stream ev_Stream)

	show ?thesis
	proof (rule ccontr)
	assume "\<not> ?thesis"
	from nn_integral_PInf_AE[OF _ this] \<open>s\<in>S\<close>
	have "AE \<omega> in T s. ev (HLD ?F) (s ## \<omega>)"
	by (simp split: if_split_asm)
	with * show False ..
	qed
	qed

	subsubsection \<open>The expected reward implies a unique LES\<close>

	lemma existence_of_ExpFuture:
	fixes s F
	assumes N_def: "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
	assumes Y_def: "Y \<equiv> Prob1 N S (svalid F)"
	assumes s: "s \<in> S" "s \<notin> S - (Y - ?F)"
	shows "enn2real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) =
	(\<Sum>s'\<in>S. \<tau> s s' * enn2real (\<integral>\<^sup>+\<omega>. reward (Future F) (s' ## \<omega>) \<partial>T s'))"
	proof -
	let ?R = "reward (Future F)"

	from s have "s \<in> Prob1 (Prob0 S ?F) S ?F"
	unfolding Y_def N_def by auto
	then have AE_until: "AE \<omega> in T s. (HLD S suntil HLD (svalid F)) (s ## \<omega>)"
	using Prob1_iff[of S ?F] svalid_subset_S by auto

	from s have "s \<notin> ?F" by auto

	let ?E = "\<lambda>s'. \<integral>\<^sup>+ \<omega>. reward (Future F) (s' ## \<omega>) \<partial>T s'"
	have : "(\<Sum>s'\<in>S. \<tau> s s' ?E s') = (\<Sum>s'\<in>S. ennreal (\<tau> s s' * enn2real (?E s')))"
	proof (rule sum.cong)
	fix s' assume "s' \<in> S"
	show "\<tau> s s' * ?E s' = ennreal (\<tau> s s' * enn2real (?E s'))"
	proof cases
	assume "\<tau> s s' \<noteq> 0"
	with \<open>s \<in> S\<close> \<open>s' \<in> S\<close> have "s' \<in> E s" by (simp add: set_pmf_iff)
	from \<open>s \<notin> ?F\<close> AE_until have "AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>)"
	using svalid_subset_S \<open>s \<in> S\<close> by simp
	with nn_integral_reward_finite[OF \<open>s' \<in> S\<close>, of F] \<open>s \<in> S\<close> \<open>s' \<in> E s\<close> \<open>s \<notin> ?F\<close>
	have "?E s' \<noteq> \<infinity>"
	by (simp add: AE_T_iff[of _ s] AE_measure_pmf_iff suntil_Stream
	del: reward.simps)
	then show ?thesis by (cases "?E s'") (auto simp: ennreal_mult)
	qed simp
	qed simp

	have "AE \<omega> in T s. ?R (s ## \<omega>) = \<rho> s + \<iota> s (shd \<omega>) + ?R \<omega>"
	using \<open>s \<notin> svalid F\<close> by (auto simp: ev_Stream )
	then have "(\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s) = (\<integral>\<^sup>+\<omega>. (\<rho> s + \<iota> s (shd \<omega>)) + ?R \<omega> \<partial>T s)"
	by (rule nn_integral_cong_AE)
	also have "\<dots> = (\<integral>\<^sup>+\<omega>. \<rho> s + \<iota> s (shd \<omega>) \<partial>T s) +
	(\<integral>\<^sup>+\<omega>. ?R \<omega> \<partial>T s)"
	using \<open>s \<in> S\<close>
	by (subst nn_integral_add)
	(auto simp add: space_PiM PiE_iff simp del: reward.simps)
	also have "\<dots> = ennreal (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) + (\<integral>\<^sup>+\<omega>. ?R \<omega> \<partial>T s)"
	using \<open>s \<in> S\<close>
	by (subst nn_integral_eq_sum)
	(auto simp: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric] sum_nonneg)
	finally show ?thesis
	apply (simp del: reward.simps)
	apply (subst nn_integral_eq_sum[OF \<open>s \<in> S\<close> reward_measurable])
	apply (simp del: reward.simps ennreal_plus add: * ennreal_plus[symmetric] sum_nonneg)
	done
	qed

	lemma uniqueness_of_ExpFuture:
	fixes F
	assumes N_def: "N \<equiv> Prob0 S (svalid F)" (is "_ \<equiv> Prob0 S ?F")
	assumes Y_def: "Y \<equiv> Prob1 N S (svalid F)"
	assumes const_def: "const \<equiv> \<lambda>s. if s \<in> Y \<and> s \<notin> svalid F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0"
	assumes sol: "\<And>s. s\<in>S \<Longrightarrow> (\<Sum>s'\<in>S. LES (S - Y \<union> ?F) s s' * l s') = const s"
	shows "\<forall>s\<in>S. l s = enn2real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)"
	(is "\<forall>s\<in>S. l s = enn2real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)")
	proof (rule unique)
	show "S \<subseteq> S" "?F \<subseteq> S" using svalid_subset_S by auto
	show "S - (Y - ?F) \<subseteq> S" "Prob0 S ?F \<subseteq> S - (Y - ?F)" "?F \<subseteq> S - (Y - ?F)"
	using svalid_subset_S
	by (auto simp add: Y_def N_def Prob1_iff)
	(auto simp add: Prob0_iff dest!: T.AE_contr)
	next
	fix s assume "s \<in> S" "s \<notin> S - (Y - ?F)"
	then show "enn2real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s) - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) =
	(\<Sum>s'\<in>S. \<tau> s s' * enn2real (\<integral>\<^sup>+\<omega>. ?R (s' ## \<omega>) \<partial>T s'))"
	by (rule existence_of_ExpFuture[OF N_def Y_def])
	next
	fix s assume "s \<in> S" "s \<notin> S - (Y - ?F)"
	then have "s \<in> Y" "s \<notin> ?F" by auto
	have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s') =
	(\<Sum>s'\<in>S. \<tau> s s' * l s' - (if s' = s then 1 else 0) * l s')"
	by (auto intro!: sum.cong simp: field_simps)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * l s') - l s"
	using \<open>s \<in> S\<close> by (simp add: sum_subtractf single_l)
	finally have "l s = (\<Sum>s'\<in>S. \<tau> s s' * l s') - (\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * l s')"
	by (simp add: field_simps)
	then show "l s - (\<rho> s + (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s')) = (\<Sum>s'\<in>S. \<tau> s s' * l s')"
	using sol[OF \<open>s \<in> S\<close>] \<open>s \<in> Y\<close> \<open>s \<notin> ?F\<close> by (simp add: const_def LES_def)
	next
	fix s assume s: "s \<in> S - (Y - ?F)"
	with sol[of s] have "l s = 0"
	by (cases "s \<in> ?F") (simp_all add: const_def LES_def single_l)
	also have "0 = enn2real (\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s)"
	proof cases
	assume "s \<in> ?F" then show ?thesis
	by (simp add: HLD_iff ev_Stream)
	next
	assume "s \<notin> ?F"
	with s have "s \<in> S - Y" by auto
	with infinite_reward[of s F] show ?thesis
	by (simp add: Y_def N_def del: reward.simps)
	qed
	finally show "l s = enn2real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)" .
	qed

	subsection \<open>Soundness of @{const Sat}\<close>

	theorem Sat_sound:
	"Sat F \<noteq> None \<Longrightarrow> Sat F = Some (svalid F)"
	proof (induct F rule: Sat.induct)
	case (5 rel r F)
	{ fix q assume "q \<in> S"
	with svalid_subset_S have "sum (\<tau> q) (svalid F) = \<P>(\<omega> in T q. HLD (svalid F) \<omega>)"
	by (subst prob_sum[OF \<open>q\<in>S\<close>]) (auto intro!: sum.mono_neutral_cong_left) }
	with 5 show ?case
	by (auto split: bind_split_asm)

	next
	case (6 rel r k F1 F2)
	then show ?case
	by (simp add: ProbU cong: conj_cong split: bind_split_asm)

	next
	case (7 rel r F1 F2)
	moreover
	define constants :: "'s \<Rightarrow> real" where "constants = (\<lambda>s. if s \<in> (svalid F2) then 1 else 0)"
	moreover define distr where "distr = LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2)"
	ultimately obtain l where eq: "Sat F1 = Some (svalid F1)" "Sat F2 = Some (svalid F2)"
	and l: "gauss_jordan' distr constants = Some l"
	by atomize_elim (simp add: ProbUinfty_def split: bind_split_asm)

	from l have P: "ProbUinfty (svalid F1) (svalid F2) = Some l"
	unfolding ProbUinfty_def constants_def distr_def by simp

	have "\<forall>s\<in>S. l s = \<P>(\<omega> in T s. pvalid (U\<^sup>\<infinity> F1 F2) (s ## \<omega>))"
	proof (rule uniqueness_of_ProbU)
	show "\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (Prob0 (svalid F1) (svalid F2) \<union> svalid F2) s s' * l s') =
	(if s \<in> svalid F2 then 1 else 0)"
	using gauss_jordan'_correct[OF l]
	unfolding distr_def constants_def by simp
	qed
	then show ?case
	by (auto simp add: eq P)
	next
	case (8 rel r k)
	{ fix s assume "s \<in> S"
	then have "ExpCumm s k = (\<integral>\<^sup>+ x. ennreal (\<Sum>i<k. \<rho> ((s ## x) !! i) + \<iota> ((s ## x) !! i) (x !! i)) \<partial>T s)"
	proof (induct k arbitrary: s)
	case 0 then show ?case by simp
	next
	case (Suc k)
	have "(\<integral>\<^sup>+\<omega>. ennreal (\<Sum>i<Suc k. \<rho> ((s ## \<omega>) !! i) + \<iota> ((s ## \<omega>) !! i) (\<omega> !! i)) \<partial>T s)
	= (\<integral>\<^sup>+\<omega>. ennreal (\<rho> s + \<iota> s (\<omega> !! 0)) + ennreal (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
	by (auto intro!: nn_integral_cong
	simp del: ennreal_plus
	simp: ennreal_plus[symmetric] sum_nonneg sum.reindex lessThan_Suc_eq_insert_0 zero_notin_Suc_image)
	also have "\<dots> = (\<integral>\<^sup>+\<omega>. \<rho> s + \<iota> s (\<omega> !! 0) \<partial>T s) +
	(\<integral>\<^sup>+\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
	using \<open>s \<in> S\<close>
	by (intro nn_integral_add AE_I2) (auto simp: sum_nonneg)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * (\<rho> s + \<iota> s s')) +
	(\<integral>\<^sup>+\<omega>. (\<Sum>i<k. \<rho> (\<omega> !! i) + \<iota> (\<omega> !! i) (\<omega> !! (Suc i))) \<partial>T s)"
	using \<open>s \<in> S\<close> by (subst nn_integral_eq_sum)
	(auto simp del: ennreal_plus simp: ennreal_plus[symmetric] ennreal_mult[symmetric] sum_nonneg)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * (\<rho> s + \<iota> s s')) +
	(\<Sum>s'\<in>S. \<tau> s s' * ExpCumm s' k)"
	using \<open>s \<in> S\<close> by (subst nn_integral_eq_sum) (auto simp: Suc)
	also have "\<dots> = ExpCumm s (Suc k)"
	using \<open>s \<in> S\<close>
	by (simp add: field_simps sum.distrib sum_distrib_left[symmetric] ennreal_mult[symmetric]
	ennreal_plus[symmetric] sum_nonneg del: ennreal_plus)
	finally show ?case by simp
	qed }
	then show ?case by auto

	next
	case (9 rel r k)
	{ fix s assume "s \<in> S"
	then have "ExpState s k = (\<integral>\<^sup>+ x. ennreal (\<rho> ((s ## x) !! k)) \<partial>T s)"
	proof (induct k arbitrary: s)
	case (Suc k) then show ?case by (simp add: nn_integral_eq_sum[of s])
	qed simp }
	then show ?case by auto

	next
	case (10 rel r F)
	moreover
	let ?F = "svalid F"
	define N where "N \<equiv> Prob0 S ?F"
	moreover define Y where "Y \<equiv> Prob1 N S ?F"
	moreover define const where "const \<equiv> (\<lambda>s. if s \<in> Y \<and> s \<notin> ?F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0)"
	ultimately obtain l
	where l: "gauss_jordan' (LES (S - Y \<union> ?F)) const = Some l"
	and F: "Sat F = Some ?F"
	by (auto simp: ExpFuture_def Let_def split: bind_split_asm)

	from l have EF: "ExpFuture ?F =
	Some (\<lambda>s. if s \<in> Y then ennreal (l s) else \<infinity>)"
	unfolding ExpFuture_def N_def Y_def const_def by auto

	let ?R = "reward (Future F)"
	have l_eq: "\<forall>s\<in>S. l s = enn2real (\<integral>\<^sup>+\<omega>. ?R (s ## \<omega>) \<partial>T s)"
	proof (rule uniqueness_of_ExpFuture[OF N_def Y_def const_def])
	fix s assume "s \<in> S"
	show "\<And>s. s\<in>S \<Longrightarrow> (\<Sum>s'\<in>S. LES (S - Y \<union> ?F) s s' * l s') = const s"
	using gauss_jordan'_correct[OF l] by auto
	qed
	{ fix s assume [simp]: "s \<in> S" "s \<in> Y"
	then have "s \<in> Prob1 (Prob0 S ?F) S ?F"
	unfolding Y_def N_def by auto
	then have "AE \<omega> in T s. (HLD S suntil HLD ?F) (s ## \<omega>)"
	using svalid_subset_S by (auto simp add: Prob1_iff)
	from nn_integral_reward_finite[OF \<open>s \<in> S\<close>] this
	have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) \<noteq> \<infinity>"
	- by (simp add: )
	+ by simp
	with l_eq \<open>s \<in> S\<close> have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = ennreal (l s)"
	by (auto simp: less_top) }
	moreover
	{ fix s assume "s \<in> S" "s \<notin> Y"
	with infinite_reward[of s F]
	have "(\<integral>\<^sup>+\<omega>. reward (Future F) (s ## \<omega>) \<partial>T s) = \<infinity>"
	by (simp add: Y_def N_def) }
	ultimately show ?case
	apply (auto simp add: EF F simp del: reward.simps)
	apply (case_tac "x \<in> Y")
	apply auto
	done
	qed (auto split: bind_split_asm)

	subsection \<open>Completeness of @{const Sat}\<close>

	theorem Sat_complete:
	"Sat F \<noteq> None"
	proof (induct F rule: Sat.induct)
	case (7 r rel \<Phi> \<Psi>)
	then have F: "Sat \<Phi> = Some (svalid \<Phi>)" "Sat \<Psi> = Some (svalid \<Psi>)"
	by (auto intro!: Sat_sound)

	define constants :: "'s \<Rightarrow> real" where "constants = (\<lambda>s. if s \<in> svalid \<Psi> then 1 else 0)"
	define distr where "distr = LES (Prob0 (svalid \<Phi>) (svalid \<Psi>) \<union> svalid \<Psi>)"
	have "\<exists>l. gauss_jordan' distr constants = Some l"
	proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ProbU])
	show "\<forall>s\<in>S. (\<Sum>s'\<in>S. distr s s' * \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))) = constants s"
	apply (simp add: distr_def constants_def LES_def del: pvalid.simps space_T)
	proof safe
	fix s assume "s \<in> svalid \<Psi>" "s \<in> S"
	then show "(\<Sum>s'\<in>S. (if s' = s then 1 else 0) * \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))) = 1"
	by (simp add: single_l suntil_Stream)
	next
	fix s assume s: "s \<notin> svalid \<Psi>" "s \<in> S"
	let ?x = "\<lambda>s'. \<P>(\<omega> in T s'. pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>))"
	show "(\<Sum>s'\<in>S. (if s \<in> Prob0 (svalid \<Phi>) (svalid \<Psi>) then if s' = s then 1 else 0 else if s' = s then \<tau> s s' - 1 else \<tau> s s') * ?x s') = 0"
	proof cases
	assume "s \<in> Prob0 (svalid \<Phi>) (svalid \<Psi>)"
	with s show ?thesis
	by (simp add: single_l Prob0_iff svalid_subset_S T.prob_eq_0_AE del: space_T)
	next
	assume s_not_0: "s \<notin> Prob0 (svalid \<Phi>) (svalid \<Psi>)"
	with s have *:"\<And>s' \<omega>. s' \<in> S \<Longrightarrow> pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s ## s' ## \<omega>) = pvalid (U\<^sup>\<infinity> \<Phi> \<Psi>) (s' ## \<omega>)"
	by (auto simp: suntil_Stream Prob0_iff svalid_subset_S)

	have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * ?x s') =
	(\<Sum>s'\<in>S. \<tau> s s' * ?x s' - (if s' = s then 1 else 0) * ?x s')"
	by (auto intro!: sum.cong simp: field_simps)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * ?x s') - ?x s"
	using s by (simp add: single_l sum_subtractf)
	finally show ?thesis
	using * prob_sum[OF \<open>s \<in> S\<close>] s_not_0 by (simp del: pvalid.simps)
	qed
	qed
	qed (simp add: distr_def constants_def)
	then have P: "\<exists>l. ProbUinfty (svalid \<Phi>) (svalid \<Psi>) = Some l"
	unfolding ProbUinfty_def constants_def distr_def by simp
	with F show ?case
	by auto
	next
	case (10 rel r \<Phi>)
	then have F: "Sat \<Phi> = Some (svalid \<Phi>)"
	by (auto intro!: Sat_sound)

	let ?F = "svalid \<Phi>"
	define N where "N \<equiv> Prob0 S ?F"
	define Y where "Y \<equiv> Prob1 N S ?F"
	define const where "const \<equiv> (\<lambda>s. if s \<in> Y \<and> s \<notin> ?F then - \<rho> s - (\<Sum>s'\<in>S. \<tau> s s' * \<iota> s s') else 0)"
	let ?E = "\<lambda>s'. \<integral>\<^sup>+ \<omega>. reward (Future \<Phi>) (s' ## \<omega>) \<partial>T s'"
	have "\<exists>l. gauss_jordan' (LES (S - Y \<union> ?F)) const = Some l"
	proof (rule gauss_jordan'_complete[OF _ uniqueness_of_ExpFuture[OF N_def Y_def const_def]])
	show "\<forall>s\<in>S. (\<Sum>s'\<in>S. LES (S - Y \<union> svalid \<Phi>) s s' * enn2real (?E s')) = const s"
	proof
	fix s assume "s \<in> S"
	show "(\<Sum>s'\<in>S. LES (S - Y \<union> svalid \<Phi>) s s' * enn2real (?E s')) = const s"
	proof cases
	assume s: "s \<in> S - (Y - svalid \<Phi>)"
	show ?thesis
	proof cases
	assume "s \<in> Y"
	with \<open>s \<in> S\<close> s \<open>s \<in> Y\<close> show ?thesis
	by (simp add: LES_def const_def single_l ev_Stream)
	next
	assume "s \<notin> Y"
	with infinite_reward[of s \<Phi>] Y_def N_def s \<open>s \<in> S\<close>
	show ?thesis by (simp add: const_def LES_def single_l del: reward.simps)
	qed
	next
	assume s: "s \<notin> S - (Y - svalid \<Phi>)"

	have "(\<Sum>s'\<in>S. (if s' = s then \<tau> s s' - 1 else \<tau> s s') * enn2real (?E s')) =
	(\<Sum>s'\<in>S. \<tau> s s' * enn2real (?E s') - (if s' = s then 1 else 0) * enn2real (?E s'))"
	by (auto intro!: sum.cong simp: field_simps)
	also have "\<dots> = (\<Sum>s'\<in>S. \<tau> s s' * enn2real (?E s')) - enn2real (?E s)"
	using \<open>s \<in> S\<close> by (simp add: sum_subtractf single_l)
	finally show ?thesis
	using s \<open>s \<in> S\<close> existence_of_ExpFuture[OF N_def Y_def \<open>s \<in> S\<close> s]
	by (simp add: LES_def const_def del: reward.simps)
	qed
	qed
	qed simp
	then have P: "\<exists>l. ExpFuture (svalid \<Phi>) = Some l"
	unfolding ExpFuture_def const_def N_def Y_def by auto
	with F show ?case
	by auto
	qed (force split: bind_split)+

	subsection \<open>Completeness and Soundness @{const Sat}\<close>

	corollary Sat: "Sat \<Phi> = Some (svalid \<Phi>)"
	using Sat_sound Sat_complete by auto

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/Ex/Lorenz/Lorenz_Approximation.thy b/thys/Ordinary_Differential_Equations/Ex/Lorenz/Lorenz_Approximation.thy
	--- a/thys/Ordinary_Differential_Equations/Ex/Lorenz/Lorenz_Approximation.thy
	+++ b/thys/Ordinary_Differential_Equations/Ex/Lorenz/Lorenz_Approximation.thy
	@@ -1,3051 +1,3051 @@
	section"Example: Lorenz attractor"
	theory Lorenz_Approximation
	imports
	"HOL-ODE-Numerics.ODE_Numerics"
	Result_File_Coarse
	begin

	lemma replicate_numeral [simp]: "replicate (numeral k) x = x # replicate (pred_numeral k) x"
	by (simp add: numeral_eq_Suc)


	text \<open>\label{sec:lorenz}\<close>

	text \<open>TODO: move to isabelle? \<close>
	lifting_update blinfun.lifting
	lifting_forget blinfun.lifting


	lemma eventually_uniformly_on:
	"(\<forall>\<^sub>F x in uniformly_on T l. P x) = (\<exists>e>0. \<forall>f. (\<forall>x\<in>T. dist (f x) (l x) < e) \<longrightarrow> P f)"
	unfolding uniformly_on_def
	apply (subst eventually_INF)
	apply safe
	subgoal for E
	apply (cases "E = {}")
	subgoal by (auto intro!: exI[where x=1])
	subgoal
	apply (auto simp: INF_principal_finite eventually_principal elim!: )
	proof goal_cases
	case (1 x)
	from 1 have "0 < Min E"
	apply (subst Min_gr_iff)
	apply force apply force apply force done
	have *: "(\<Inter>e\<in>E. {f. \<forall>t\<in>T. dist (f t) (l t) < e}) = {f. \<forall>t\<in>T. dist (f t) (l t) < Min E}"
	- using 1 apply (auto simp: )
	+ using 1 apply auto
	apply (subst Min_gr_iff)
	apply force apply force apply force
	apply (drule bspec, assumption)
	apply (rule less_le_trans, assumption)
	apply auto
	done
	from 1 have "\<forall>f. (\<forall>x\<in>T. dist (f x) (l x) < Min E) \<longrightarrow> P f" unfolding * by simp
	then show ?case
	using 1(4)[rule_format, OF \<open>0 < Min E\<close>] by auto
	qed
	done
	subgoal for e
	apply (rule exI[where x="{e}"])
	by (auto simp: eventually_principal)
	done


	lemma op_cast_image_impl[autoref_rules]:
	"(\<lambda>x. x, op_cast_image::'a::executable_euclidean_space set \<Rightarrow>
	'b::executable_euclidean_space set)
	\<in> aform.appr_rel \<rightarrow> aform.appr_rel"
	if "DIM('a) = DIM('b)"
	using that
	apply (auto simp: aform.appr_rel_def intro!: relcompI)
	unfolding lv_rel_def set_rel_br
	by (force simp: intro!: brI dest!: brD)

	lemma cast_bl_blinfun_of_list[simp]:
	"cast_bl (blinfun_of_list xs::'a \<Rightarrow>\<^sub>L 'a) =
	(blinfun_of_list xs::'b\<Rightarrow>\<^sub>L'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	using that
	apply (auto simp: cast_bl_rep intro!: blinfun_eqI)
	by (auto simp: blinfun_of_list_def blinfun_of_matrix_apply
	linear_sum linear.scaleR sum_Basis_sum_nth_Basis_list
	linear_cast)

	lemma cast_idem[simp]: "cast x = x"
	by (auto simp: cast_def)

	lemma cast_bl_idem[simp]: "cast_bl x = x"
	by (auto simp: cast_bl_rep intro!: blinfun_eqI)

	lemma op_cast_eucl1_image_impl[autoref_rules]:
	"(\<lambda>x. x, op_cast_eucl1_image::'a::executable_euclidean_space c1_info set \<Rightarrow>
	'b::executable_euclidean_space c1_info set)
	\<in> aform.appr1_rel \<rightarrow> aform.appr1_rel"
	if "DIM_precond TYPE('a) D"
	"DIM_precond TYPE('b) D"
	using that
	proof (auto, goal_cases)
	case (1 a b a')
	then show ?case
	apply (auto simp: aform.appr1_rel_br set_rel_br br_def)
	subgoal for w x y z
	apply (auto simp: aform.c1_info_of_appr_def cast_eucl1_def aform.c1_info_invar_def
	split: option.splits)
	apply (rule image_eqI)
	apply (rule cast_eucl_of_list, force, force simp: Joints_imp_length_eq, force)
	subgoal for s t
	apply (rule image_eqI[where x="t"])
	supply [simp del] = eucl_of_list_take_DIM
	apply (auto simp: flow1_of_list_def)
	apply (subst cast_eucl_of_list)
	subgoal by simp
	subgoal
	by (auto dest!: Joints_imp_length_eq
	simp: power2_eq_square flow1_of_list_def[abs_def])
	subgoal by simp
	done
	done
	subgoal for w x
	apply (rule image_eqI[where x="cast_eucl1 (w, x)"])
	apply (auto simp: aform.c1_info_of_appr_def cast_eucl1_def
	aform.c1_info_invar_def
	split: option.splits)
	apply (rule image_eqI)
	apply (rule cast_eucl_of_list, force, force simp: Joints_imp_length_eq, force)
	subgoal for s t
	apply (rule image_eqI[where x="t"])
	supply [simp del] = eucl_of_list_take_DIM
	apply (auto simp: flow1_of_list_def)
	apply (subst cast_eucl_of_list)
	subgoal by simp
	subgoal
	by (auto dest!: Joints_imp_length_eq
	simp: power2_eq_square flow1_of_list_def[abs_def])
	subgoal by simp
	done
	done
	done
	qed

	lemma less_3_iff: "i < (3::nat) \<longleftrightarrow> i = 0 \<or> i = 1 \<or> i = 2"
	by arith

	definition mat3_of_vec::"R3 \<Rightarrow> real^3^3" where
	"mat3_of_vec x = (let xs = list_of_eucl x in eucl_of_list [xs!0,0,0, xs!1,0,0, xs!2,0,0])"

	lemma ll3: "{..<3} = {0,1,2::nat}"
	by (auto simp: less_3_iff)

	lemma mat3_of_vec: "cast (mat3_of_vec x *v eucl_of_list [1, 0, 0]) = x"
	by (auto simp: mat3_of_vec_def eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list
	linear_sum linear_cast linear.scaleR ll3 linear_add Basis_list_R3 inner_prod_def
	prod_eq_iff)

	primrec bisect_form where
	"bisect_form p f xs l u 0 = (l, u)"
	\| "bisect_form p f xs l u (Suc n) =
	(let m = (l + u)/2 in
	if approx_form_aform p (f m) xs
	then bisect_form p f xs l m n
	else bisect_form p f xs m u n)"

	text \<open>This should prove that the expansion estimates are sufficient.\<close>

	lemma expansion_main: "expansion_main (coarse_results) = Some True"
	by eval

	context includes floatarith_notation begin

	definition "matrix_of_degrees2\<^sub>e =
	(let
	e = Var 2;
	ur = Rad_of (Var 0);
	vr = Rad_of (Var 1);
	x1 = Cos ur;
	x2 = Cos vr;
	y1 = Sin ur;
	y2 = Sin vr
	in
	[x1 + (e * (x2 - x1)), 0, 0,
	y1 + (e * (y2 - y1)), 0, 0,
	0, 0, 0])"

	definition "matrix_of_degrees2 u v =
	approx_floatariths 30 matrix_of_degrees2\<^sub>e (aforms_of_ivls [u, v, 0] [u, v, 1])"

	text \<open>following \<open>vector_field.h\<close> / \<open>vector_field.cc\<close>\<close>

	abbreviation "S \<equiv> 10::real"
	abbreviation "B \<equiv> 8/3::real"
	abbreviation "TEMP \<equiv> sqrt((S + 1) * (S + 1) + 4 * S * (28 - 1))"
	abbreviation "K1 \<equiv> S / TEMP"
	abbreviation "K2 \<equiv> (S - 1 + TEMP) / (2 * S)"
	abbreviation "K3 \<equiv> (S - 1 - TEMP) / (2 * S)"
	abbreviation "E1 \<equiv> (- (S + 1) + TEMP) / 2"
	abbreviation "E2 \<equiv> (- (S + 1) - TEMP) / 2"
	abbreviation "E3 \<equiv> - B"
	abbreviation "C1 \<equiv> \<lambda>X. X ! 0 + X ! 1"
	abbreviation "C2 \<equiv> \<lambda>X. K1 * C1 X * X ! 2"

	schematic_goal
	lorenz_fas:
	"[E1 * X!0 - C2 X,
	E2 * X!1 + C2 X,
	E3 * X!2 + C1 X * (K2 * X!0 + K3 * X!1)] =
	interpret_floatariths ?fas X"
	by (reify_floatariths)
	concrete_definition lorenz_fas uses lorenz_fas
	end

	interpretation lorenz: ode_interpretation true_form UNIV lorenz_fas "\<lambda>(X0, X1, X2).
	(E1 * X0 - K1 * (X0 + X1) * X2,
	E2 * X1 + K1 * (X0 + X1) * X2,
	E3 * X2 + (X0 + X1) * (K2 * X0 + K3 * X1))::realrealreal"
	"d::3" for d
	by standard
	(auto simp: lorenz_fas_def less_Suc_eq_0_disj nth_Basis_list_prod Basis_list_real_def
	mk_ode_ops_def eucl_of_list_prod power2_eq_square inverse_eq_divide intro!: isFDERIV_I)

	value [code] "length (slp_of_fas lorenz_fas)"

	definition "mig_aform p x = mig_componentwise (Inf_aform' p x) (Sup_aform' p x)"

	context includes floatarith_notation begin

	definition "mig_aforms p x = real_of_float ((lower o the) ((approx p (Norm (map (Num o float_of o (mig_aform p)) x))) []))"

	definition
	"column_of_c1_info x N j = (map (\<lambda>i. the (snd x) ! i) (map (\<lambda>i. i * N + j) [0..<N]))"

	definition "rotate_x_fa a =
	[1, 0, 0,
	0, Cos a, - Sin a,
	0, Sin a, Cos a]"

	definition "rotate_y_fa a =
	[Cos a, 0, Sin a,
	0, 1, 0,
	- Sin a, 0, Cos a]"

	definition "rotate_z_fa a =
	[Cos a, - Sin a, 0,
	Sin a, Cos a, 0,
	0, 0, 1]"

	definition "rotate_zx_slp a b xs =
	slp_of_fas (mvmult_fa 3 3 (mmult_fa 3 3 3 (rotate_x_fa (Rad_of (R\<^sub>e b))) (rotate_z_fa (Rad_of (R\<^sub>e a)))) xs)"

	definition "perspective_projection_aforms xs =
	the (approx_slp_outer 30 3 (rotate_zx_slp (-30) (-60) (map Var [0..<3])) xs)"

	definition "print_lorenz_aform print_fun cx cy cz ci
	cd1 cd2
	= (\<lambda>a b.
	let (s1, n) = ((-6), False);
	_ = print_fun (String.implode (''# gen(''@ show a@''): ''@ shows_aforms_hr (b) '''' @ ''\<newline>''));
	_ = print_fun (String.implode (''# box(''@ show a@''): ''@ shows_box_of_aforms_hr (b) '''' @ ''\<newline>''));
	((x0, y0, z0), (x1, y1, z1)) = case (map (Inf_aform' 30) (take 3 b), map (Sup_aform' 30) (take 3 b)) of
	([x0, y0, z0], [x1, y1, z1]) \<Rightarrow> ((x0, y0, z0), (x1, y1, z1));
	_ = print_fun (String.implode (shows_segments_of_aform 0 1 b ((shows cx o shows_space o shows z0 o shows_space o shows z1)'''') ''\<newline>''));
	_ = print_fun (String.implode (shows_segments_of_aform 0 2 b ((shows cy o shows_space o shows y0 o shows_space o shows y1)'''') ''\<newline>''));
	_ = print_fun (String.implode (shows_segments_of_aform 1 2 b ((shows cz o shows_space o shows x0 o shows_space o shows x1)'''') ''\<newline>''));
	PS = perspective_projection_aforms b;
	_ = print_fun (String.implode (shows_segments_of_aform 0 1 PS
	((shows ci o shows_space o shows (fst (PS ! 2)) o shows_space o shows (fst (b ! 2))) '''') ''\<newline>''))
	in if \<not> a \<and> length b > 10 then
	print_fun (String.implode (shows_aforms_vareq 3 [(0, 1), (0, 2), (1, 2)] [0..<3]
	cd1
	cd2
	(FloatR 1 s1 * (if n then
	real_divl 30 1 (max (mig_aforms 30 (map (\<lambda>i. b ! i) [3,6,9]))
	(mig_aforms 30 (map (\<lambda>i. b ! i) [4,7,10])))
	else 1)) \<comment> \<open>always length \<open>2^s!\<close>\<close>
	''# no C1 info'' b ''''))
	else ())"

	definition "print_lorenz_aform_std print_fun =
	print_lorenz_aform print_fun ''0x000001'' ''0x000002'' ''0x000012'' ''0x000003''
	[''0xa66f00'', ''0x06266f'', ''0xc60000'']
	[''0xffaa00'', ''0x1240ab'', ''0xc60000'']"

	definition "lorenz_optns print_funo =
	(let
	pf = the_default (\<lambda>_ _. ()) (map_option print_lorenz_aform_std print_funo);
	tf = the_default (\<lambda>_ _. ()) (map_option (\<lambda>print_fun a b.
	let
	_ = print_fun (String.implode (''# '' @ a @ ''\<newline>''))
	in case b of Some b \<Rightarrow>
	(print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\<newline>'')))
	\| None \<Rightarrow> ()) print_funo)
	in
	\<lparr>
	precision = 30,
	adaptive_atol = FloatR 1 (-30),
	adaptive_rtol = FloatR 1 (-30),
	method_id = 2,
	start_stepsize = FloatR 1 (- 8),
	iterations = 40,
	halve_stepsizes = 10,
	widening_mod = 40,
	rk2_param = FloatR 1 0,
	default_reduce = correct_girard 30 50 25,
	printing_fun = pf,
	tracing_fun = tf
	\<rparr>)"

	definition lorenz_optns'
	where "lorenz_optns' pf m N rk2p a = lorenz_optns pf \<lparr>
	default_reduce := correct_girard 30 m N,
	rk2_param := rk2p,
	adaptive_atol := a,
	adaptive_rtol := a
	\<rparr>"

	definition mirror_irects
	where "mirror_irects =
	map (\<lambda>irect. case irect of [i, j, k] \<Rightarrow> [if j < 0 then - i else i , abs j, k] \| irect \<Rightarrow> irect)"

	definition "print_irects irects =
	(let _ = map (\<lambda>is.
	let _ = map (\<lambda>j.
	let _ = print (String.implode (show j)) in print (STR '' '')) is in print (STR ''\<newline>'')) irects
	in ())"

	abbreviation "aforms_of_ivl \<equiv> \<lambda>x. aforms_of_ivls (fst x) (snd x)"

	definition "conefield_propagation\<^sub>e =
	([Deg_of (Arctan (Var (6) / Var (3))),
	Deg_of (Arctan (Var (7) / Var (4))),
	Min (Norm [Var(3), Var (6), Var (9)]) (Norm [Var(4), Var (7), Var (10)])])"

	definition "conefield_propagation DX = approx_floatariths 30 conefield_propagation\<^sub>e DX"

	definition "conefield_propagation_slp = slp_of_fas conefield_propagation\<^sub>e"
	lemma [simp]: "length conefield_propagation_slp = 51"
	by eval

	definition op_with_unit_matrix :: "'a::real_normed_vector \<Rightarrow> 'a \<times> 'a \<Rightarrow>\<^sub>L 'a" where
	"op_with_unit_matrix X = (X, 1\<^sub>L)"

	context includes blinfun.lifting begin
	lemma matrix_vector_mult_blinfun_works[simp]: "matrix e *v g = e g" for e::"(real^'n) \<Rightarrow>\<^sub>L (real^'m)"
	by transfer (simp add: bounded_linear_def matrix_works)
	end

	lemma length_conefield_propagation\<^sub>e[simp]: "length conefield_propagation\<^sub>e = 3"
	by (simp add: conefield_propagation\<^sub>e_def)

	lemma interpret_floatariths_conefield_propagation:
	"interpret_floatariths conefield_propagation\<^sub>e
	(list_of_eucl (vec1_of_flow1 (xDX::(real^3) \<times> ((real^3)\<Rightarrow>\<^sub>L(real^3)))))
	=
	(let
	DX = snd xDX;
	DXu = DX (eucl_of_list [1, 0, 0]);
	DXv = DX (eucl_of_list [0, 1, 0])
	in
	[deg_of (arctan (vec_nth DXu 1 / vec_nth DXu 0)),
	deg_of (arctan (vec_nth DXv 1 / vec_nth DXv 0)),
	min (norm DXu) (norm DXv)]
	)"
	apply (auto simp: conefield_propagation\<^sub>e_def Let_def interpret_mvmult_nth[where 'n=3 and 'm=3]
	inverse_eq_divide vec1_of_flow1_def nth_append)
	apply (auto simp: matrix_inner_Basis_list )
	apply (auto simp: interpret_floatarith_norm[where 'a="real ^ 3"]
	einterpret_mvmult_fa[where 'n=3 and 'm=3] matrix_inner_Basis_list nth_append)
	by (auto simp: matrix_def axis_eq_eucl_of_list eucl_of_list_012)

	definition "conefield_bounds_form l u =
	(fold Conj [
	Less (-90) (N\<^sub>r l),
	LessEqual (N\<^sub>r l) (N\<^sub>r u),
	LessEqual (Var 9) (0),
	LessEqual 0 (Var 9),
	Less (N\<^sub>r u) (90),
	Less 0 (Var 3),
	AtLeastAtMost (Var 6) (Tan (Rad_of (N\<^sub>r l)) * Var 3) (Tan (Rad_of (N\<^sub>r u)) * Var 3)] true_form)"

	definition "contract_angles X i = (snd (bisect_form 30 (\<lambda>x. conefield_bounds_form x (89)) X 89 (-89) i),
	snd (bisect_form 30 (conefield_bounds_form (-89)) X (-89) 89 i))"

	definition "approx_conefield_bounds (DX::(R3 \<times> (R3 \<Rightarrow>\<^sub>L R3)) set) l u =
	do {
	let DX = (cast_eucl1 ` DX::3 eucl1 set);
	DXo \<leftarrow> aform.vec1rep DX;
	DX \<leftarrow> (case DXo of None \<Rightarrow> do {
	let _ = aform.print_msg (''# approx_conefield_bounds failed DXo...'');
	SUCCEED
	}
	\| Some DX \<Rightarrow> RETURN DX);
	let _ = aform.trace_set (''# approx_conefield_bounds DX: '') (Some DX);
	approx_form_spec (conefield_bounds_form l u) (list_of_eucl ` DX)
	}"

	lemma [autoref_rules]:
	includes autoref_syntax
	shows "(conefield_bounds_form, conefield_bounds_form) \<in> Id \<rightarrow> Id \<rightarrow> Id "
	by auto

	lemma [autoref_rules_raw]:
	"DIM_precond TYPE((real, 3) vec \<times> ((real, 3) vec, 3) vec) 12"
	"DIM_precond TYPE(R3) 3"
	"DIM_precond TYPE((real, 3) vec) 3"
	by auto

	schematic_goal approx_conefield_bounds_impl:
	includes autoref_syntax
	fixes optns::"real aform numeric_options"
	assumes [autoref_rules]: "(DXi, DX) \<in> aform.appr1_rel"
	assumes [autoref_rules]: "(li, l) \<in> Id"
	assumes [autoref_rules]: "(ui, u) \<in> Id"
	notes [autoref_rules] =
	aform.print_msg_impl[where optns = optns]
	aform.ivl_rep_of_set_autoref[where optns = optns]
	aform.transfer_operations(12)[where optns = optns]
	aform.approx_euclarithform[where optns=optns]
	aform.trace_set_impl[of optns]
	shows "(nres_of ?r, approx_conefield_bounds $ DX $ l $ u) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding approx_conefield_bounds_def
	including art
	by autoref_monadic
	concrete_definition approx_conefield_bounds_impl for optns li ui DXi uses
	approx_conefield_bounds_impl
	lemmas [autoref_rules] = approx_conefield_bounds_impl.refine

	context includes autoref_syntax begin
	lemma [autoref_rules]:
	"(real_of_ereal, real_of_ereal) \<in> ereal_rel \<rightarrow> rnv_rel"
	"(\<infinity>, \<infinity>) \<in> ereal_rel"
	by auto
	end

	lemma interpret_form_true_form[simp]: "interpret_form true_form \<equiv> \<lambda>_. True"
	by (force simp: true_form_def intro!: eq_reflection)

	lemma interpret_form_conefield_bounds_form_list:
	"interpret_form (conefield_bounds_form L U)
	[x, y, z, ux, vx, wx,
	uy, vy, wy,
	uz, vz, wz]
	\<longleftrightarrow>
	(0 < ux \<and> -90 < L \<and> L \<le> U \<and> U < 90 \<and> uz = 0 \<and>
	uy \<le> tan (rad_of U) * ux \<and>
	tan (rad_of L) * ux \<le> uy)"
	if "U \<in> float" "L \<in> float" "e \<in> float" "em \<in> float"
	using that
	by (auto simp: conefield_bounds_form_def L2_set_def)

	lemma list_of_eucl_eucl1_3:
	includes vec_syntax
	shows "(list_of_eucl (vec1_of_flow1 (xDX::(real^3) \<times> ((real^3)\<Rightarrow>\<^sub>L(real^3))))) =
	(let
	(x, DX) = xDX;
	DXu = DX (eucl_of_list [1, 0, 0]);
	DXv = DX (eucl_of_list [0, 1, 0]);
	DXw = DX (eucl_of_list [0, 0, 1])
	in [x $ 0, x $ 1, x $ 2, vec_nth DXu 0, vec_nth DXv 0, vec_nth DXw 0,
	vec_nth DXu 1, vec_nth DXv 1, vec_nth DXw 1,
	vec_nth DXu 2, vec_nth DXv 2, vec_nth DXw 2])"
	apply (auto simp: matrix_inner_Basis_list Let_def vec1_of_flow1_def
	concat_map_map_index less_Suc_eq_0_disj
	list_of_eucl_matrix eval_nat_numeral aform.inner_Basis_eq_vec_nth
	intro!: nth_equalityI
	split: prod.splits)
	by (auto simp: matrix_def axis_eq_eucl_of_list eucl_of_list_012)

	lemma interpret_form_conefield_bounds_form:
	"interpret_form (conefield_bounds_form L U)
	(list_of_eucl (vec1_of_flow1 (xDX::(real^3) \<times> ((real^3)\<Rightarrow>\<^sub>L(real^3)))))
	=
	(let
	DX = snd xDX;
	DXu = DX (eucl_of_list [1, 0, 0]);
	DXv = DX (eucl_of_list [0, 1, 0]);
	uz = vec_nth DXu 2;
	uy = vec_nth DXu 1;
	ux = vec_nth DXu 0;
	vy = vec_nth DXv 1;
	vx = vec_nth DXv 0
	in
	ux > 0 \<and> -90 < L \<and> L \<le> U \<and> U < 90 \<and> uz = 0 \<and>
	(uy / ux) \<in> {tan (rad_of L) .. tan (rad_of U)}
	)"
	if "L \<in> float" "U \<in> float"
	using that
	unfolding list_of_eucl_eucl1_3 Let_def
	by (auto split: prod.splits simp: interpret_form_conefield_bounds_form_list divide_simps)

	lemma approx_conefield_bounds_cast:
	"approx_conefield_bounds DX L U \<le> SPEC (\<lambda>b. b \<longrightarrow>
	(\<forall>(x, dx) \<in> cast_eucl1 ` DX::3 eucl1 set.
	let
	u' = dx (eucl_of_list [1, 0, 0])
	in
	vec_nth u' 1 / vec_nth u' 0 \<in> {tan (rad_of L) .. tan (rad_of U)}
	\<and> vec_nth u' 2 = 0 \<and> vec_nth u' 0 > 0 \<and> -90 < L \<and> L \<le> U \<and> U < 90)
	)"
	if "L \<in> float" "U \<in> float"
	unfolding approx_conefield_bounds_def
	apply refine_vcg
	apply (auto simp: env_len_def )
	subgoal for a b c
	apply (drule bspec, assumption)
	unfolding interpret_form_conefield_bounds_form[OF that]
	by (auto simp: Let_def divide_simps)
	done


	lemma approx_conefield_bounds[le, refine_vcg]:
	"approx_conefield_bounds DX l u \<le> SPEC (\<lambda>b. b \<longrightarrow>
	(\<forall>(x, dx) \<in> DX::R3 c1_info set.
	let
	(u'1, u'2, u'3) = dx ((1, 0, 0))
	in u'2 / u'1 \<in> {tan (rad_of l) .. tan (rad_of u)} \<and> u'3 = 0 \<and> u'1 > 0 \<and> -90 < l \<and> l \<le> u \<and> u < 90)
	)"
	if "l \<in> float" "u \<in> float"
	apply (rule approx_conefield_bounds_cast[le, OF that])
	apply (auto dest!: bspec simp: Let_def split: prod.splits)
	by (auto simp: cast_eucl1_def cast_def)

	schematic_goal MU\<^sub>e: "-E2 / E1 = interpret_floatarith ?fas []"
	by (reify_floatariths)
	concrete_definition MU\<^sub>e uses MU\<^sub>e
	schematic_goal NU\<^sub>e: "-E3 / E1 = interpret_floatarith ?fas []"
	by (reify_floatariths)
	concrete_definition NU\<^sub>e uses NU\<^sub>e

	definition "approx_ivls p fas xs = do {
	let xs = ivls_of_aforms p xs;
	res \<leftarrow> those (map (\<lambda>f. approx p f xs) fas);
	Some (map (real_of_float o lower) res, map (real_of_float o upper) res)
	}"
	definition
	"deform p t exit XDX = (case XDX of (lu, (X, DX)) \<Rightarrow>
	let
	d = ldec 0.1;
	d = if exit then (1 - real_of_float (lb_sqrt 30 (1 - 2 * float_of (d)))) else d;
	sd = real_of_float ((float_of (d*d)));
	C0Deform = aforms_of_ivls [-sd,-sd,-sd] [sd, sd, sd];
	result = msum_aforms' X C0Deform
	in (lu,
	case DX of None \<Rightarrow> (result, None)
	\| Some DX \<Rightarrow> let
	C1_norm = 2 * d;
	C1_norm = if exit then real_divr 30 C1_norm (1 - C1_norm) else C1_norm;
	l = -C1_norm;
	u = C1_norm;
	D_M = aforms_of_ivls [1 + l,0,0, 0,1 + l,0, 0,0,1 + l] [1 + u,0,0, 0,1 + u,0, 0,0,1 + u];
	(ri, ru) = the (approx_ivls p
	(mmult_fa 3 3 3 (map Var [0..<9]) (map Var [9..<18])) (D_M @ DX));
	Dresult = aforms_of_ivls ri ru;
	resultDresult = product_aforms result Dresult
	in (take 3 resultDresult, Some (drop 3 resultDresult))))"

	definition "ivls_of_aforms' p r = (map (Inf_aform' p) r, map (Sup_aform' p) r)"

	definition "compute_half_exit p t XDX = (case XDX of ((l, u::ereal), (X, DX)) \<Rightarrow>
	let
	\<comment> \<open>ASSERTING that \<open>Y\<close> straddles zero\<close>
	(x0, y0, _) = case map (Inf_aform' p) X of [x,y,z] \<Rightarrow> (x, y, z);
	(x1, y1, _) = case map (Sup_aform' p) X of [x,y,z] \<Rightarrow> (x, y, z);
	splitting = x0 = 0 \<or> x1 = 0;
	sign_x = if (x0 + x1) / 2 > 0 then 1 else -1;
	mag_x = max (abs x0) (abs x1);
	sign_x\<^sub>e = N\<^sub>r sign_x;
	exit_rad\<^sub>e = N\<^sub>r (ldec 0.1);
	X\<^sub>e = Var (0);
	Y\<^sub>e = Var (1);
	Z\<^sub>e = Var (2);
	max_x_over_r\<^sub>e = N\<^sub>r mag_x / exit_rad\<^sub>e;
	abs_x_over_r\<^sub>e = (Abs X\<^sub>e) / exit_rad\<^sub>e;
	result = (if splitting
	then let result = (the (approx_floatariths p [sign_x\<^sub>e * exit_rad\<^sub>e,
	Y\<^sub>e * Powr (max_x_over_r\<^sub>e) MU\<^sub>e,
	Z\<^sub>e * Powr (max_x_over_r\<^sub>e) NU\<^sub>e] X));
	(ir, sr) = ivls_of_aforms' p result
	in aforms_of_ivls (ir[1:=min 0 (ir!1), 2:=min 0 (ir!2)])
	(sr[1:=max 0 (sr!1), 2:=max 0 (sr!2)])
	else the (approx_floatariths p [sign_x\<^sub>e * exit_rad\<^sub>e,
	Y\<^sub>e * Powr (abs_x_over_r\<^sub>e) MU\<^sub>e,
	Z\<^sub>e * Powr (abs_x_over_r\<^sub>e) NU\<^sub>e] X));
	_ = ()
	in ((l::ereal, \<infinity>::ereal), (case DX of None \<Rightarrow> (result, None)
	\| Some DX \<Rightarrow>
	let
	ux\<^sub>e = Var (3);
	uy\<^sub>e = Var (6);
	P21\<^sub>e = if splitting
	then (MU\<^sub>e / exit_rad\<^sub>e) * Y\<^sub>e * sign_x\<^sub>e * Powr (max_x_over_r\<^sub>e) (MU\<^sub>e - 1) \<comment> \<open>No need for \<open>Hull(0)\<close> because \<open>y\<close> straddles zero\<close>
	else (MU\<^sub>e / exit_rad\<^sub>e) * Y\<^sub>e * sign_x\<^sub>e * Powr (abs_x_over_r\<^sub>e) (MU\<^sub>e - 1);
	P22\<^sub>e = if splitting
	then Powr (max_x_over_r\<^sub>e) MU\<^sub>e
	else Powr (abs_x_over_r\<^sub>e) MU\<^sub>e;
	P31\<^sub>e = if splitting
	then sign_x\<^sub>e * (NU\<^sub>e / exit_rad\<^sub>e) * Z\<^sub>e * Powr (max_x_over_r\<^sub>e) (NU\<^sub>e - 1) \<comment> \<open>No need for \<open>Hull(\<infinity>)\<close> because scaling afterwards\<close>
	else sign_x\<^sub>e * (NU\<^sub>e / exit_rad\<^sub>e) * Z\<^sub>e * Powr (abs_x_over_r\<^sub>e) (NU\<^sub>e - 1);
	ry = (P21\<^sub>e * ux\<^sub>e) + (P22\<^sub>e * uy\<^sub>e);
	rz = P31\<^sub>e * ux\<^sub>e;
	(iDr, sDr) = the (approx_ivls p ([0, 0, 0,
	ry, 0, 0,
	rz, 0, 0]) (X @ DX));
	Dresult = aforms_of_ivls (iDr[3:=min 0 (iDr!3)])
	(sDr[3:=max 0 (sDr!3)]);
	resultDresult = product_aforms result Dresult
	in (take 3 resultDresult, Some (drop 3 resultDresult))
	)))"

	fun list3 where "list3 [a,b,c] = (a, b, c)"

	definition
	"split_x n x0 y0 z0 x1 y1 z1 =
	(let
	elem = (\<lambda>(x0, x1). aforms_of_ivls [x0, y0, z0] [x1, y1, z1]);
	coord = (\<lambda>x0 n i. i * x0 * FloatR 1 (-int n));
	us = map (coord x0 n) (rev [0..<(2^n)]) @ map (coord x1 n) [Suc 0..<Suc (2^n)];
	ls = map (coord x0 n) (rev [Suc 0..<Suc (2^n)]) @ map (coord x1 n) [0..<(2^n)]
	in map elem (zip ls us))"

	definition "compute_cube_exit p t XDX =
	(let
	((l, u), (X', DX')) = deform p t False XDX;
	((x0, y0, z0), (x1, y1, z1)) = pairself list3 (ivls_of_aforms' p X');
	X's = [aforms_of_ivls [x0, y0, z0] [0, y1, z1], aforms_of_ivls [0, y0, z0] [x1, y1, z1]];
	XDX's = map (\<lambda>X'. ((l, u), (X', DX'))) X's;
	Xes = map (compute_half_exit p t) XDX's;
	Xlumpies = map (deform p t True) Xes
	in
	Xlumpies)"


	definition "cube_enteri = (map ldec [-0.1, -0.00015, 0.1, 0.8,0,0, 0.0005,0,0, 0,0,0],
	map udec [ 0.1, 0.00015, 0.1, 1.7,0,0, 0.002,0,0, 0,0,0])"
	definition "cube_enter = set_of_ivl (pairself eucl_of_list cube_enteri)"

	value [code] "println ((show) (map (ivls_of_aforms' 100 o list_of_appr1e_aform)
	(compute_cube_exit 30 (FloatR 1 (-10)) ((ereal 1, ereal 1),
	(aforms_of_ivls (take 3 (fst cube_enteri))
	(take 3 (snd cube_enteri)),
	Some (aforms_of_ivls (drop 3 (fst cube_enteri))
	(drop 3 (snd cube_enteri))))))))"

	definition "cube_exiti =
	[(aforms_of_ivls (map ldec [-0.12, -0.024, -0.012])
	(map udec [-0.088, 0.024, 0.13]),
	Some (aforms_of_ivls (map ldec [0,0,0, -0.56,0,0, -0.6,0,0])
	(map udec [0,0,0, 0.56,0,0, -0.08,0,0]))),
	(aforms_of_ivls (map ldec [ 0.088, -0.024, -0.012])
	(map udec [ 0.12, 0.024, 0.13]),
	Some (aforms_of_ivls (map ldec [0,0,0, -0.53,0,0, 0.08,0,0])
	(map udec [0,0,0, 0.56,0,0, 0.6,0,0])))]"
	definition "cube_exitv = aform.c1_info_of_apprs cube_exiti"

	lemma cube_enteri[autoref_rules]: "(cube_enteri, cube_enter::'a set) \<in> lvivl_rel"
	if "DIM_precond TYPE('a::executable_euclidean_space) 12"
	using that
	by (auto simp: cube_enteri_def cube_enter_def set_of_ivl_def
	intro!: brI lv_relivl_relI)

	lemma cube_exiti[autoref_rules]: "(cube_exiti, cube_exitv::'n eucl1 set) \<in> clw_rel aform.appr1_rel"
	if "DIM_precond TYPE('n::enum rvec) 3"
	unfolding cube_exitv_def cube_exiti_def
	apply (rule aform.clw_rel_appr1_relI)
	using that
	by (auto simp: aform.c1_info_invar_def power2_eq_square)

	definition "lorenz_interrupt (optns::real aform numeric_options) b (eX::3 eucl1 set) =
	do {
	((el, eu), X) \<leftarrow> scaleR2_rep eX;
	let fX = fst ` X;
	fentry \<leftarrow> op_image_fst_ivl (cube_enter::3 vec1 set);
	interrupt \<leftarrow> aform.op_subset (fX:::aform.appr_rel) fentry;
	(ol, ou) \<leftarrow> ivl_rep fentry;
	aform.CHECKs (ST ''asdf'') (0 < el \<and> ol \<le> ou);
	let _ = (if b then aform.trace_set (ST ''Potential Interrupt: '') (Some fX) else ());
	let _ = (if b then aform.trace_set (ST ''With: '') (Some ({ol .. ou::3 rvec}:::aform.appr_rel)) else ());
	if \<not>b \<or> \<not>interrupt then RETURN (op_empty_coll, mk_coll eX)
	else do {
	vX \<leftarrow> aform.vec1rep X;
	let _ = (if b then aform.trace_set1e (ST ''Actual Interrupt: '') (Some eX) else ());
	let l = (eucl_of_list [-1/2/2,-1/2/2,-1/2/2]::3 rvec);
	let u = eucl_of_list [1/2/2, 1/2/2, 1/2/2];
	ASSERT (l \<le> u);
	let CX = mk_coll ({l .. u}:::aform.appr_rel);
	(C0::3 eucl1 set) \<leftarrow> scaleRe_ivl_coll_spec el eu (fst ` cube_exitv \<times> UNIV);
	(C1::3 eucl1 set) \<leftarrow> scaleRe_ivl_coll_spec el eu (cube_exitv);
	case vX of None \<Rightarrow> RETURN (CX, C0)
	\| Some vX \<Rightarrow> do {
	b \<leftarrow> aform.op_subset vX cube_enter;
	aform.CHECKs (ST ''FAILED: TANGENT VECTORs are not contained'') b;
	RETURN (CX, C1)
	}
	}
	}"
	lemma [autoref_rules]:
	includes autoref_syntax
	shows
	"(real_of_int, real_of_int) \<in> int_rel \<rightarrow> rnv_rel"
	"(ldec, ldec) \<in> Id \<rightarrow> rnv_rel"
	"(udec, udec) \<in> Id \<rightarrow> rnv_rel"
	by auto

	schematic_goal lorenz_interrupti:
	includes autoref_syntax
	assumes[autoref_rules]: "(bi, b) \<in> bool_rel" "(Xi, X::3 eucl1 set) \<in> aform.appr1e_rel"
	"(optnsi, optns) \<in> Id"
	shows
	"(nres_of ?r, lorenz_interrupt optns b X) \<in> \<langle>clw_rel aform.appr_rel \<times>\<^sub>r clw_rel aform.appr1e_rel\<rangle>nres_rel"
	unfolding lorenz_interrupt_def
	including art
	by autoref_monadic
	concrete_definition lorenz_interrupti for optnsi1 bi Xi uses
	lorenz_interrupti[where optnsi = "optnsi"
	and optnsa = "\<lambda>_ _ _ _ _ _ _ _. optnsi"
	and optnsb = "\<lambda>_ _ _ _ _ _ _ _ _. optnsi"
	and optnsc = "\<lambda>_ _ _ _ _ _ _ _ _ _ _. optnsi"
	and optnsd = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. optnsi"
	and optnse = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. optnsi"
	and optnsf = "\<lambda>_ _ _ _ _ _ _ _ _. optnsi"
	and optns = "\<lambda>_ _ _ _ _. optnsi"
	for optnsi]
	lemma lorenz_interrupti_refine[autoref_rules]:
	includes autoref_syntax
	shows
	"(\<lambda>optnsi bi Xi. (lorenz_interrupti optnsi bi Xi),
	lorenz_interrupt)
	\<in> num_optns_rel \<rightarrow> bool_rel \<rightarrow> aform.appr1e_rel \<rightarrow> \<langle>clw_rel aform.appr_rel \<times>\<^sub>r clw_rel aform.appr1e_rel\<rangle>dres_nres_rel"
	using lorenz_interrupti.refine
	by (auto simp: nres_rel_def dres_nres_rel_def)

	definition "(large_cube::R3 set) = {-1/4 .. 1/4} \<times> {-1/4 .. 1/4} \<times> {-1/4 .. 1/4}"

	definition "cube_entry = (cast_eucl1 ` (flow1_of_vec1 ` cube_enter::3 eucl1 set)::R3 c1_info set)"
	definition "cube_exit = (cast_eucl1 ` (cube_exitv::3 eucl1 set)::R3 c1_info set)"

	text \<open>protect locale parameters\<close>
	lemma flow0_cong[cong]: "auto_ll_on_open.flow0 ode X = auto_ll_on_open.flow0 ode X"
	by (auto simp:)
	lemma existence_ivl0_cong[cong]:
	"auto_ll_on_open.existence_ivl0 ode X = auto_ll_on_open.existence_ivl0 ode X"
	by (auto simp:)
	lemma Dflow_cong[cong]: "c1_on_open_euclidean.Dflow ode ode_d X = c1_on_open_euclidean.Dflow ode ode_d X"
	by (auto simp:)
	lemma flowsto_cong[cong]:
	"c1_on_open_euclidean.flowsto ode ode_d D = c1_on_open_euclidean.flowsto ode ode_d D"
	by (auto simp:)
	lemma poincare_mapsto_cong[cong]:
	"c1_on_open_euclidean.poincare_mapsto ode X = c1_on_open_euclidean.poincare_mapsto ode X"
	by (auto simp:)
	lemma returns_to_cong[cong]:
	"auto_ll_on_open.returns_to ode X = auto_ll_on_open.returns_to ode X"
	by (auto simp:)
	lemma return_time_cong[cong]:
	"auto_ll_on_open.return_time ode X = auto_ll_on_open.return_time ode X"
	- by (auto simp: )
	+ by auto
	lemma poincare_map_cong[cong]:
	"auto_ll_on_open.poincare_map ode X = auto_ll_on_open.poincare_map ode X"
	- by (auto simp: )
	+ by auto

	lemma eq_nth_iff_index:
	"distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> i = xs ! n \<longleftrightarrow> index xs i = n"
	using index_nth_id by fastforce

	lemma cast_in_BasisI: "(cast i::'a) \<in> Basis"
	if "(i::'c) \<in> Basis""DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	using that
	by (auto simp: cast_def eucl_of_list_nth inner_Basis if_distrib if_distribR
	eq_nth_iff_index
	cong: if_cong)

	lemma cast_le_iff: "(cast (x::'a)::'c) \<le> y \<longleftrightarrow> x \<le> cast y"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	apply (auto simp: eucl_le[where 'a='a] eucl_le[where 'a='c]
	dest!: bspec intro!: )
	apply (rule cast_in_BasisI, assumption)
	apply (auto simp: that)
	apply (metis cast_eqI2 cast_inner that)
	apply (rule cast_in_BasisI, assumption)
	apply (auto simp: that)
	apply (metis cast_eqI2 cast_inner that)
	done

	lemma cast_le_cast_iff: "(cast (x::'a)::'c) \<le> cast y \<longleftrightarrow> x \<le> y"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	apply (auto simp: eucl_le[where 'a='a] eucl_le[where 'a='c]
	dest!: bspec intro!: )
	apply (rule cast_in_BasisI, assumption)
	apply (auto simp: that)
	apply (rule cast_in_BasisI, assumption)
	apply (auto simp: that)
	by (metis cast_eqI2 cast_inner that)

	lemma cast_image_Icc[simp]: "cast ` {a .. b::'c} = {cast a .. cast b::'a}"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	using that
	apply (auto simp: cast_le_iff dest!:)
	subgoal for x
	apply (rule image_eqI[where x="cast x"])
	by (auto simp: cast_le_iff)
	done

	lemma cast_eucl1_image_scaleR2:
	"cast_eucl1 ` scaleR2 l u X = scaleR2 l u (cast_eucl1 ` (X::'b c1_info set)::'a c1_info set)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	using that
	apply (auto simp: scaleR2_def image_def vimage_def cast_eucl1_def
	linear.scaleR linear_cast_bl)
	apply force+
	apply (rule exI conjI)+
	apply assumption
	apply (rule exI conjI)+
	apply assumption
	apply (rule bexI) prefer 2 apply assumption
	apply force
	by (auto simp: linear.scaleR linear_cast_bl)

	lemma scaleR2_diff_prod2: "scaleR2 d e (X) - Y \<times> UNIV = scaleR2 d e (X - Y \<times> UNIV)"
	by (force simp: scaleR2_def vimage_def image_def)

	end

	lemma (in c1_on_open_euclidean) flowsto_scaleR2I:
	"flowsto (scaleR2 d e X0) T (CX \<times> UNIV) (scaleR2 d e Y)"
	if "flowsto (X0) T (CX \<times> UNIV) (Y)"
	using that
	apply (auto simp: flowsto_def scaleR2_def)
	apply (drule bspec, assumption)
	apply auto
	apply (rule bexI) prefer 2 apply assumption
	apply auto
	subgoal for x a b h
	by (auto intro!: image_eqI[where x="(x, (flow0 a h, Dflow a h o\<^sub>L b))"] blinfun_eqI
	simp: blinfun.bilinear_simps)
	done

	definition "aforms_of_resultrect x0 x1 y0 y1 = aforms_of_ivl (ivl_of_resultrect x0 x1 y0 y1)"

	definition "flatten_varveq x = fst x @ the_default [] (snd x)"

	(*
	LessEqual (N\<^sub>r e) (N\<^sub>r em *\<^sub>e floatarith.Min (norm\<^sub>e [(3)\<^sub>e, (6)\<^sub>e, (9)\<^sub>e])
	(norm\<^sub>e [(4)\<^sub>e, (7)\<^sub>e, (10)\<^sub>e]))
	*)

	derive "show" ereal

	definition \<Sigma>::"(realrealreal) set" where
	"\<Sigma> = {(-6, -6, 27) .. (6, 6, 27)}"
	definition \<Sigma>\<^sub>l\<^sub>e::"(realrealreal) set" where
	"\<Sigma>\<^sub>l\<^sub>e = {(x, y, z). z \<le> 27}"

	definition "results = symmetrize coarse_results"
	definition "results_at x = {res \<in> set results. x \<in> source_of_res res}"

	text \<open>a part of the stable manifold (up to the (backward) first intersection with \<open>\<Sigma>\<close>)\<close>
	definition \<Gamma>::"(realrealreal) set" where
	"\<Gamma> = {x.
	{0..} \<subseteq> lorenz.existence_ivl0 x \<and>
	(\<forall>t>0. lorenz.flow0 x t \<notin> \<Sigma>) \<and>
	(lorenz.flow0 x \<longlongrightarrow> 0) at_top}"

	definition "\<Gamma>\<^sub>i intr = (if intr then \<Gamma> else {})"
	definition "\<Gamma>\<^sub>i\<^sub>v intr = cast ` (\<Gamma>\<^sub>i intr)"

	definition "sourcei_of_res res = source_of_res res - (\<Gamma>\<^sub>i (invoke_nf res))"
	definition "resultsi_at x = {res \<in> set results. x \<in> sourcei_of_res res}"

	definition "N = \<Union>(source_of_res ` (set results))"
	definition "\<CC> x = \<Union>(conefield_of_res ` (results_at x))"
	definition "R = lorenz.poincare_map \<Sigma>"
	definition "DR x = frechet_derivative (lorenz.poincare_map \<Sigma>) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	definition "\<E> x = Min (expansion ` results_at x)"
	definition "\<E>\<^sub>p x = Min (preexpansion ` results_at x)"

	abbreviation returns_to (infixl "returns'_to" 50) where
	"(x returns_to P) \<equiv> lorenz.returns_to P x"

	lemma closed_\<Sigma>[intro, simp]: "closed \<Sigma>"
	by (auto simp: \<Sigma>_def)

	lemma \<Gamma>_stable: "lorenz.stable_on (- \<Sigma>) \<Gamma>"
	unfolding lorenz.stable_on_def
	proof (intro allI impI)
	fix t x0
	assume outside: "\<forall>s\<in>{0<..t}. lorenz.flow0 x0 s \<in> - \<Sigma>"
	assume assms: "lorenz.flow0 x0 t \<in> \<Gamma>" "t \<in> lorenz.existence_ivl0 x0" "0 < t"
	from assms have *: "{0..} \<subseteq> lorenz.existence_ivl0 (lorenz.flow0 x0 t)"
	"(lorenz.flow0 (lorenz.flow0 x0 t) \<longlongrightarrow> 0) at_top"
	by (auto simp: \<Gamma>_def)
	have nonneg_exivl: "s \<in> lorenz.existence_ivl0 x0" if "s \<ge> 0" for s
	proof (cases "s \<le> t")
	case True
	then show ?thesis
	using \<open>0 \<le> s\<close> assms(2) lorenz.ivl_subset_existence_ivl[of t x0] by auto
	next
	case False
	define u where "u = s - t"
	with False have "u > 0" "s = t + u" by auto
	note this(2)
	also have "t + u \<in> lorenz.existence_ivl0 x0"
	apply (rule lorenz.existence_ivl_trans)
	apply fact
	using * \<open>u > 0\<close> by auto
	finally show ?thesis .
	qed
	show "x0 \<in> \<Gamma>"
	unfolding \<Gamma>_def
	proof (safe intro!: nonneg_exivl)
	have "\<forall>\<^sub>F s in at_top. (s::real) \<ge> 0"
	using eventually_ge_at_top by blast
	then have "\<forall>\<^sub>F s in at_top. lorenz.flow0 (lorenz.flow0 x0 t) s = lorenz.flow0 x0 (s + t)"
	proof eventually_elim
	case (elim s)
	then have "s \<in> lorenz.existence_ivl0 x0"
	using nonneg_exivl[OF \<open>0 \<le> s\<close>] by simp
	then have "lorenz.flow0 (lorenz.flow0 x0 t) s = lorenz.flow0 x0 (t + s)"
	apply (subst lorenz.flow_trans)
	using assms * elim by auto
	then show ?case by (simp add: ac_simps)
	qed
	then have "((\<lambda>s. (lorenz.flow0 x0 (s + t))) \<longlongrightarrow> 0) at_top"
	by (blast intro: * Lim_transform_eventually)
	then show "(lorenz.flow0 x0 \<longlongrightarrow> 0) at_top"
	unfolding aform.tendsto_at_top_translate_iff .
	next
	fix s::real assume s: "0 < s" "lorenz.flow0 x0 s \<in> \<Sigma>"
	show False
	proof (cases "s \<le> t")
	case True
	then show ?thesis
	using outside s
	by (auto simp: \<Gamma>_def)
	next
	case False
	then obtain u where u: "u = s - t" "u > 0"
	by auto
	then have "lorenz.flow0 x0 (s) = lorenz.flow0 x0 (t + u)" by (simp add: algebra_simps)
	also have "\<dots> = lorenz.flow0 (lorenz.flow0 x0 t) u"
	apply (subst lorenz.flow_trans)
	subgoal by fact
	subgoal unfolding u
	apply (rule lorenz.diff_existence_ivl_trans) apply fact+
	apply (rule nonneg_exivl) using \<open>0 < s\<close> by simp
	subgoal by simp
	done
	also from assms(1) \<open>u > 0\<close> have "\<dots> \<notin> \<Sigma>"
	by (auto simp: \<Gamma>_def)
	finally show ?thesis using s
	by auto
	qed
	qed
	qed

	lemma (in auto_ll_on_open) stable_on_empty[intro, simp]: "stable_on asdf {}"
	by (auto simp: stable_on_def)

	lemma \<Gamma>\<^sub>i_stable: "lorenz.stable_on (- \<Sigma>) (\<Gamma>\<^sub>i b)"
	using \<Gamma>_stable
	unfolding \<Gamma>\<^sub>i_def
	apply (cases b)
	subgoal by auto
	subgoal using lorenz.stable_on_empty
	by (auto simp: \<Gamma>\<^sub>i_def)
	done

	definition "\<Gamma>\<^sub>v = (cast ` \<Gamma>)"

	definition "NF = lorenz.flowsto (cube_entry - \<Gamma> \<times> UNIV) {0..} (large_cube \<times> UNIV) cube_exit"

	lemma NF0: "lorenz.flowsto ((fst ` cube_entry - \<Gamma>) \<times> UNIV) {0..} (large_cube \<times> UNIV)
	(fst ` cube_exit \<times> UNIV)"
	if NF
	using that
	unfolding NF_def lorenz.flowsto_def
	apply (auto simp: NF_def)
	apply (drule bspec, force)
	by auto

	lemma [autoref_rules]: includes autoref_syntax shows "(\<lambda>_. (), \<Gamma>\<^sub>i\<^sub>v) \<in> bool_rel \<rightarrow> ghost_rel"
	by (auto simp: ghost_rel_def)

	lemma lorenz_interrupt[le, refine_vcg]:
	"lorenz_interrupt optns b X \<le> SPEC (\<lambda>(CX, R).
	lorenz.flowsto ((cast_eucl1 ` X::R3 c1_info set) - (\<Gamma>\<^sub>i b \<times> UNIV)) {0..} (cast ` CX \<times> UNIV) (cast_eucl1 ` R))"
	if NF
	unfolding lorenz_interrupt_def
	apply refine_vcg
	subgoal
	by (rule lorenz.flowsto_self) auto
	subgoal
	by (auto simp: eucl_le[where 'a="3 rvec"] eucl_of_list_inner Basis_list_vec_def Basis_list_real_def)
	subgoal for a b c d e f g h i j k l m n p
	apply (auto)
	apply (simp add: cast_eucl1_image_scaleR2 scaleR2_diff_prod2)
	apply (erule make_neg_goal)
	apply (rule lorenz.flowsto_scaleR2I)
	using NF0[OF that]
	apply (rule lorenz.flowsto_subset)
	subgoal for q
	apply (auto simp: scaleR2_def cast_eucl1_def)
	apply (auto simp: linear_cast_bl linear.scaleR cube_entry_def cast_eucl1_def image_image)
	subgoal premises prems for r s t u v
	proof -
	from prems have "fst ` c \<subseteq> fst ` (cube_enter::3 vec1 set)"
	by auto
	with \<open>(u, v) \<in> c\<close> obtain w where "((u, w)::3 vec1) \<in> cube_enter"
	by auto
	from _ this have "cast u \<in> (\<lambda>x. cast (fst (x::3 vec1))) ` cube_enter"
	by (rule image_eqI) auto
	then show ?thesis using prems
	by blast
	qed
	subgoal by (auto simp: \<Gamma>\<^sub>i_def)
	done
	subgoal by simp
	subgoal premises _
	by (auto simp: eucl_le[where 'a="3 rvec"] eucl_of_list_inner Basis_list_vec_def Basis_list_real_def
	eucl_of_list_def
	large_cube_def)
	subgoal premises prems for x
	supply [[simproc del: defined_all]]
	apply (auto simp:)
	subgoal for A B C D E
	apply (rule image_eqI[where x="cast_eucl1 (((B, C, D), A))"])
	apply (auto simp: cast_eucl1_def)
	subgoal premises prems
	using prems(1)
	apply (auto simp: cube_exit_def aform.c1_info_of_apprs_def cube_exiti_def
	cast_eucl1_def aform.c1_info_of_appr_def)
	done
	done
	done
	done
	subgoal for a b c d e f g h i j k l m n p
	apply (auto)
	apply (erule make_neg_goal, thin_tac "\<not> _")
	apply (simp add: cast_eucl1_image_scaleR2 scaleR2_diff_prod2)
	apply (rule lorenz.flowsto_scaleR2I)
	using that[unfolded NF_def]
	apply (rule lorenz.flowsto_subset)
	subgoal for q
	apply (auto simp: scaleR2_def cast_eucl1_def )
	apply (auto simp: linear_cast_bl linear.scaleR cube_entry_def cast_eucl1_def image_image)
	subgoal premises prems for r s t u v
	proof -
	from prems have \<open>vec1_of_flow1 (u, v) \<in> cube_enter\<close>
	by auto
	from _ this have "(cast u, cast_bl v) \<in> (\<lambda>x. (cast (fst (x::3 vec1)), cast_bl (snd (flow1_of_vec1 x)))) ` cube_enter"
	- by (rule image_eqI) (auto simp: )
	+ by (rule image_eqI) auto
	then show ?thesis
	using prems by blast
	qed
	subgoal by (auto simp: \<Gamma>\<^sub>i_def)
	done
	subgoal by simp
	subgoal premises _
	by (auto simp: eucl_le[where 'a="3 rvec"] eucl_of_list_inner Basis_list_vec_def Basis_list_real_def
	eucl_of_list_def
	large_cube_def)
	subgoal by (simp add: cube_exit_def)
	done
	done


	definition "lorenz_S X = (case X of (x, y, z) \<Rightarrow> (-x, -y, z))"

	lemma lorenz_symI: "((\<lambda>t. lorenz_S (f t)) has_vderiv_on lf') T"
	if "(f has_vderiv_on f') T" "\<And>t. t \<in> T \<Longrightarrow> lf' t = lorenz_S (f' t)"
	using that
	by (auto simp: has_vderiv_on_def lorenz_S_def split_beta' has_vector_derivative_def
	intro!: derivative_eq_intros)

	lemma lorenz_S:
	"t \<in> lorenz.existence_ivl0 (lorenz_S X)" (is ?th1)
	"lorenz.flow0 (lorenz_S X) t = lorenz_S (lorenz.flow0 X t)" (is ?th2)
	if "t \<in> lorenz.existence_ivl0 X"
	proof -
	have 1: "((\<lambda>t. lorenz_S (lorenz.flow0 X t)) solves_ode
	(\<lambda>_ (X0, X1, X2).
	(E1 * X0 - K1 * (X0 + X1) * X2,
	E2 * X1 + K1 * (X0 + X1) * X2,
	E3 * X2 + (X0 + X1) * (K2 * X0 + K3 * X1))))
	{0--t} UNIV"
	apply (rule solves_odeI)
	apply (rule lorenz_symI)
	apply (rule lorenz.flow_has_vderiv_on_compose)
	apply simp
	apply simp
	apply (rule derivative_intros)
	apply (rule refl)
	using that
	apply (rule lorenz.in_existence_between_zeroI)
	apply assumption
	apply (rule refl)
	unfolding lorenz_S_def
	apply (split prod.splits)+
	apply (simp add: field_simps)
	apply simp
	done
	have "lorenz.flow0 X 0 = X"
	unfolding lorenz.flow_initial_time_if
	by simp
	then have 2:
	"lorenz_S (lorenz.flow0 X 0) = lorenz_S X"
	"is_interval {0--t}"
	"0 \<in> {0--t}"
	"{0--t} \<subseteq> UNIV"
	by auto
	from lorenz.maximal_existence_flow[OF 1 2]
	show ?th1 ?th2 by fast+
	qed

	lemma \<Sigma>\<^sub>l\<^sub>e_impl[autoref_rules]: "(Sctn [0, 0, 1] 27, \<Sigma>\<^sub>l\<^sub>e) \<in> \<langle>lv_rel\<rangle>below_rel"
	apply (auto simp: below_rel_def \<Sigma>\<^sub>l\<^sub>e_def below_halfspace_def sctn_rel_def
	intro!: relcompI[where b="Sctn (0, 0, 1) 27"] brI lv_relI)
	subgoal
	unfolding lv_rel_def
	by (auto intro!: brI)
	unfolding le_halfspace_def
	by (auto intro!: brI)

	lemma [autoref_rules]: "((), \<Gamma>\<^sub>v) \<in> ghost_rel"
	by (auto intro!: ghost_relI)

	no_notation vec_nth (infixl "$" 90) and vec_lambda (binder "\<chi>" 10)

	abbreviation "guards_rel \<equiv> \<langle>clw_rel (\<langle>\<langle>lv_rel\<rangle>ivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel) \<times>\<^sub>r aform.reach_optns_rel\<rangle>list_rel"


	definition "aform_poincare_onto_from optns = aform.poincare_onto_from"

	lemma aform_poincare_onto_from[autoref_rules]:
	includes autoref_syntax
	shows
	"DIM_precond TYPE('b rvec) E \<Longrightarrow>
	(XSi, XS::'b::enum eucl1 set) \<in> clw_rel aform.appr1e_rel \<Longrightarrow>
	(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel \<Longrightarrow>
	(ivli, ivl) \<in> \<langle>lv_rel\<rangle>ivl_rel \<Longrightarrow>
	(Si, Sa) \<in> \<langle>lv_rel\<rangle>halfspaces_rel \<Longrightarrow>
	(guardsi, guards) \<in> guards_rel \<Longrightarrow>
	(symstartd, symstart) \<in> aform.appr1e_rel \<rightarrow> \<langle>clw_rel aform.appr_rel \<times>\<^sub>r clw_rel aform.appr1e_rel\<rangle>dres_nres_rel \<Longrightarrow>
	((), trap) \<in> ghost_rel \<Longrightarrow>
	(roi, roptn) \<in> aform.reach_optns_rel \<Longrightarrow>
	(odoi, odo) \<in> ode_ops_rel \<Longrightarrow>
	(optnsi, optns) \<in> num_optns_rel \<Longrightarrow>
	(nres_of
	(solve_poincare_map_aform optnsi E odoi symstartd Si guardsi ivli
	sctni roi XSi),
	aform_poincare_onto_from $ optns $ odo $ symstart $ trap $ Sa $ guards $
	ivl $
	sctn $
	roptn $
	XS)
	\<in> \<langle>clw_rel aform.appr1e_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs aform_poincare_onto_from_def
	using aform.poincare_onto_from_impl.refine[OF _ aform_ncc aform_ncc,
	where 'a='b, of E odoi odo XSi XS Si Sa guardsi guards ivli ivl sctni sctn roi roptn
	"(\<lambda>x. nres_of (symstartd x))" symstart symstartd trap optnsi,
	unfolded autoref_tag_defs, OF _ _ _ _ _ _ _ _ _ order_refl]
	by (auto simp: dest!: aform.dres_nres_rel_nres_relD)

	definition "lorenz_odo_impl = init_ode_ops True True lorenz.odo"
	interpretation autoref_op_pat_def lorenz.odo .
	lemma lorenz_odo_impl[autoref_rules]: "(lorenz_odo_impl, lorenz.odo) \<in> ode_ops_rel"
	by (auto simp: ode_ops_rel_def lorenz_odo_impl_def)

	definition lorenz_poincare where
	"lorenz_poincare optns interrupt guards roptn XS0 =
	aform_poincare_onto_from optns lorenz.odo
	(lorenz_interrupt optns interrupt)
	(\<Gamma>\<^sub>i\<^sub>v interrupt:::ghost_rel)
	((below_halfspaces {Sctn (eucl_of_list [0, 0, 1]) 27}::(real^3) set):::\<langle>lv_rel\<rangle>halfspaces_rel)
	guards
	(op_atLeastAtMost_ivl (eucl_of_list [-6, -6, 27]:::lv_rel) (eucl_of_list [6, 6, 27]:::lv_rel):::lvivl_rel::(real^3) set)
	(Sctn (eucl_of_list [0, 0, -1]) (- 27)::(real^3) sctn)
	roptn
	XS0"

	lemma [autoref_rules_raw]:
	includes autoref_syntax
	shows "((),
	(OP \<Gamma>\<^sub>i\<^sub>v ::: bool_rel \<rightarrow> ghost_rel) $
	(OP intr ::: bool_rel))
	\<in> ghost_rel" by (auto simp: ghost_rel_def)

	schematic_goal lorenz_poincare_impl[autoref_rules]:
	includes autoref_syntax
	assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel aform.appr1e_rel"
	"(intri, intr) \<in> bool_rel"
	"(guardsi, guards) \<in> guards_rel"
	"(roi, roptn) \<in> aform.reach_optns_rel"
	"(optnsi, optns) \<in> num_optns_rel"
	shows "(nres_of ?r, lorenz_poincare $ optns $ intr $ guards $ roptn $ XS) \<in>
	\<langle>clw_rel aform.appr1e_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding lorenz_poincare_def
	including art
	supply [autoref_rules_raw] = ghost_relI
	by autoref_monadic

	lemma cast_image_eqI: "cast ` X = Y"
	if "DIM('a) = DIM('b)"
	"(X::'a::executable_euclidean_space set) = cast ` (Y::'b::executable_euclidean_space set)"
	using that
	by (auto simp: image_image)

	lemma transfer_\<Gamma>[transfer_rule]: "(rel_set lorenz.rel_ve) \<Gamma>\<^sub>v \<Gamma>"
	unfolding \<Gamma>\<^sub>v_def
	by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI)

	lemma transfer_\<Sigma>\<^sub>l\<^sub>e[transfer_rule]: "(rel_set lorenz.rel_ve) (cast ` \<Sigma>\<^sub>l\<^sub>e) \<Sigma>\<^sub>l\<^sub>e"
	by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI)

	lemma transfer_\<Gamma>\<^sub>i[transfer_rule]: "(rel_fun (=) (rel_set lorenz.rel_ve)) \<Gamma>\<^sub>i\<^sub>v \<Gamma>\<^sub>i"
	unfolding \<Gamma>\<^sub>i\<^sub>v_def
	by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI)

	lemma transfer_\<Sigma>[transfer_rule]: "(rel_set lorenz.rel_ve) (cast ` \<Sigma>) \<Sigma>"
	by (auto simp: lorenz.rel_ve_cast' intro!: rel_setI)

	lemma len_fas: "length lorenz_fas = 3"
	by (auto simp: lorenz_fas_def)

	lemma lorenz_poincare[le, refine_vcg]:
	"lorenz_poincare optns intr guards roptn XS \<le> SPEC (\<lambda>R.
	aform.poincare_mapsto lorenz.odo (cast ` \<Sigma>) (XS - (\<Gamma>\<^sub>i\<^sub>v intr \<times> UNIV)) (cast ` \<Sigma>\<^sub>l\<^sub>e)
	UNIV R)"
	if [refine_vcg]: NF
	unfolding lorenz_poincare_def aform_poincare_onto_from_def
	apply (refine_vcg)
	subgoal by (simp add: aform.wd_def aform.ode_e_def len_fas)
	subgoal for a b c d
	apply (auto simp: lorenz.flowsto_eq[symmetric])
	proof goal_cases
	case 1
	from 1(2)[unfolded lorenz.flowsto_eq[symmetric]]
	show ?case
	by transfer (simp add: lorenz.avflowsto_eq)
	qed
	subgoal
	unfolding aform.stable_on_def unfolding autoref_tag_defs
	proof (intro allI impI, goal_cases)
	case (1 t x0)
	from 1 have t: "t \<in> lorenz.v.existence_ivl0 x0"
	using lorenz.vex_ivl_eq by simp
	from 1 have f: "lorenz.v.flow0 x0 t \<in> \<Gamma>\<^sub>i\<^sub>v intr"
	using lorenz.vflow_eq[OF t] by simp
	from 1 have "lorenz.v.flow0 x0 s \<in> - cast ` \<Sigma>"
	if "s\<in>{0<..t}" for s
	proof -
	from that t have s: "s \<in> lorenz.v.existence_ivl0 x0"
	by (auto dest!: lorenz.a.v.closed_segment_subset_existence_ivl
	simp: closed_segment_eq_real_ivl)
	have "lorenz.v.flow0 x0 s
	\<in> aform.Csafe lorenz.odo -
	op_atLeastAtMost_ivl (eucl_of_list [- 6, - 6, 27]) (eucl_of_list [6, 6, 27]) \<inter>
	plane_of (Sctn (eucl_of_list [0, 0, - 1]) (- 27))"
	using 1(4)[rule_format, OF that]
	unfolding lorenz.vflow_eq[OF s]
	by auto
	also have "\<dots> \<subseteq> - cast ` \<Sigma>"
	by (auto simp: eucl_le[where 'a="real^3"] eucl_of_list_inner axis_eq_axis
	cast_def Basis_list_real_def Basis_list_vec3 \<Sigma>_def plane_of_def
	eucl_of_list_inner_eq inner_lv_rel_def)
	finally show "lorenz.v.flow0 x0 s \<in> - cast ` \<Sigma>" .
	qed
	show "x0 \<in> \<Gamma>\<^sub>i\<^sub>v intr"
	by (rule \<Gamma>\<^sub>i_stable[Transfer.untransferred, unfolded lorenz.v.stable_on_def, rule_format])
	fact+
	qed
	subgoal for R
	proof (clarsimp, goal_cases)
	case 1
	note 1(2)
	also have "({eucl_of_list [- 6, - 6, 27]..eucl_of_list [6, 6, 27]::3 rvec} \<inter>
	plane_of (Sctn (eucl_of_list [0, 0, - 1]) (- 27))) = cast ` \<Sigma>"
	apply auto
	apply (auto simp: \<Sigma>_def o_def plane_of_def
	eucl_of_list_def Basis_list_R3 Basis_list_vec3)
	subgoal
	by (auto simp: cast_def eucl_of_list_def Basis_list_R3 Basis_list_vec3)
	subgoal
	by (auto simp: cast_def eucl_of_list_def Basis_list_R3 Basis_list_vec3)
	subgoal
	apply (auto simp: cast_le_iff[symmetric])
	by (auto simp: cast_def eucl_of_list_def Basis_list_R3 Basis_list_vec3 less_eq_prod_def
	list_of_eucl_def inner_simps inner_axis_axis)
	subgoal
	apply (auto simp: cast_le_iff)
	by (auto simp: cast_def eucl_of_list_def Basis_list_R3 Basis_list_vec3 less_eq_prod_def
	list_of_eucl_def inner_simps inner_axis_axis)
	subgoal
	by (auto simp: cast_def eucl_of_list_def Basis_list_R3 Basis_list_vec3 less_eq_prod_def
	list_of_eucl_def inner_simps inner_axis_axis)
	done
	also have "(below_halfspaces {Sctn (eucl_of_list [0, 0, 1]::3 rvec) 27}) = (cast ` \<Sigma>\<^sub>l\<^sub>e)"
	apply (auto simp: \<Sigma>\<^sub>l\<^sub>e_def below_halfspaces_def below_halfspace_def le_halfspace_def
	eucl_of_list_def Basis_list_R3 Basis_list_vec3)
	apply (rule image_eqI)
	apply (rule cast_cast[symmetric])
	by (auto simp: cast_def list_of_eucl_def o_def plane_of_def inner_simps inner_axis_axis
	eucl_of_list_def Basis_list_R3 Basis_list_vec3)
	finally
	show ?case
	by (rule aform.poincare_mapsto_subset) (force simp: lorenz.vX_def intro: cast_cast[symmetric])+
	qed
	done

	context includes floatarith_notation begin

	definition "mat1\<^sub>e =
	[Var 0, Var 1, Var 2, Var 3, 0, 0,
	Var 4, 0, 0,
	Var 5, 0, 0]"

	definition mat1_nres::"3 rvec set \<Rightarrow> 3 rvec set \<Rightarrow> 3 eucl1 set nres"
	where
	"mat1_nres X v = do {
	Xv \<leftarrow> aform.approx_slp_appr mat1\<^sub>e (slp_of_fas mat1\<^sub>e) (concat ` listset [list_of_eucl ` X, list_of_eucl ` v]);
	RETURN (flow1_of_vec1 ` Xv)
	}"
	lemma [simp]: "(x, x') \<in> aform.appr_rel \<Longrightarrow> aform.ncc x'"
	using aform_ncc[where 'a='a]
	by (auto simp: aform.ncc_precond_def)
	lemma mat1e_autoref[autoref_rules]: "(mat1\<^sub>e, mat1\<^sub>e) \<in> \<langle>Id\<rangle>list_rel"
	by auto
	schematic_goal mat1_impl:
	includes autoref_syntax
	assumes [autoref_rules]: "(Xi, X) \<in> aform.appr_rel" "(vi, v) \<in> aform.appr_rel"
	shows "(nres_of ?r, mat1_nres $ X $ v) \<in> \<langle>aform.appr1_rel\<rangle>nres_rel"
	unfolding mat1_nres_def
	including art
	by autoref_monadic
	concrete_definition mat1_impl for Xi vi uses mat1_impl
	lemmas [autoref_rules] = mat1_impl.refine

	lemma mat_nres[le, refine_vcg]:
	"mat1_nres X v \<le> SPEC (\<lambda>M. X \<times> v \<subseteq> (\<lambda>x. (fst x, blinfun_apply (snd x) (eucl_of_list [1, 0, 0]))) ` M)"
	unfolding mat1_nres_def
	apply refine_vcg
	apply (auto simp: dest!: bspec)
	apply (auto simp: mat1\<^sub>e_def image_image )
	subgoal for x a b
	apply (rule image_eqI[where x="eucl_of_list
	[(list_of_eucl a @ list_of_eucl b) ! 0, (list_of_eucl a @ list_of_eucl b) ! Suc 0,
	(list_of_eucl a @ list_of_eucl b) ! 2, (list_of_eucl a @ list_of_eucl b) ! 3, 0, 0,
	(list_of_eucl a @ list_of_eucl b) ! 4, 0, 0, (list_of_eucl a @ list_of_eucl b) ! 5, 0, 0]"])
	apply (auto simp: eucl_of_list_prod eucl_of_list_inner nth_append Basis_list_vec3
	intro!: euclidean_eqI[where 'a="3 rvec"])
	unfolding Basis_list[symmetric] Basis_list_vec3
	by (auto simp: flow1_of_vec1_def blinfun_of_vmatrix.rep_eq Basis_list_vec3 inner_simps
	matrix_vector_mult_eq_list_of_eucl_nth ll3 inner_axis_axis)
	done

	definition [simp]: "op_image_cast_eucl1e = (`) cast_eucl1"
	definition [simp]: "op_image_cast_eucl1e_coll = (`) cast_eucl1"

	lemma prod_relI'': "\<lbrakk>(fst ab, a')\<in>R1; (snd ab, b')\<in>R2\<rbrakk> \<Longrightarrow> (ab,(a', b'))\<in>\<langle>R1,R2\<rangle>prod_rel"
	by (auto simp: prod_rel_def)

	lemma strange_aux_lemma:
	"(b, b') \<in> A \<Longrightarrow> (b, snd (a'a, b')) \<in> A"
	by auto

	lemma [autoref_rules]:
	includes autoref_syntax
	assumes
	"DIM_precond TYPE('a::executable_euclidean_space) D"
	"DIM_precond TYPE('b::executable_euclidean_space) D"
	shows
	"(\<lambda>x. x, (op_image_cast_eucl1e::('a::executable_euclidean_space c1_info set \<Rightarrow> 'b::executable_euclidean_space c1_info set))) \<in> aform.appr1e_rel \<rightarrow> aform.appr1e_rel"
	(is ?th1)
	and "(\<lambda>x. x, op_image_cast_eucl1e_coll::'a::executable_euclidean_space c1_info set \<Rightarrow> 'b::executable_euclidean_space c1_info set) \<in> clw_rel aform.appr1e_rel \<rightarrow> clw_rel aform.appr1e_rel"
	(is ?th2)
	proof -
	show 1: ?th1
	unfolding scaleR2_rel_def
	apply (rule subsetD)
	apply (rule fun_rel_comp_dist)
	apply (rule relcompI)
	apply (rule fun_relI)
	apply (erule prod_relE)
	apply simp
	apply (rule prod_relI)
	apply simp
	apply (rule fst_conv[symmetric])
	apply (rule op_cast_eucl1_image_impl[OF assms, param_fo])
	apply (rule strange_aux_lemma)
	apply (auto simp: br_def scaleR2_def image_def vimage_def
	cast_eucl1_def)
	subgoal for a b c d e f g
	apply (rule exI[where x=e] conjI)+
	apply assumption
	apply (rule exI conjI)+
	apply assumption
	apply (rule exI conjI)+
	apply (rule bexI) prefer 2 apply assumption
	apply (rule conjI) apply force
	apply (rule refl)
	using assms
	by (auto simp: blinfun.bilinear_simps linear_cast linear.scaleR
	intro!: blinfun_eqI)
	subgoal for a b c d e f g
	apply (rule exI[where x=e] exI conjI)+
	apply assumption
	apply (rule exI conjI)+
	apply assumption
	apply (rule bexI) prefer 2 apply assumption
	apply force
	using assms
	by (auto simp: blinfun.bilinear_simps linear_cast linear.scaleR
	intro!: blinfun_eqI)
	done
	have id_map: "(\<lambda>x. x) = (map (\<lambda>x. x))" by simp
	show ?th2
	apply (subst id_map)
	apply (rule lift_clw_rel_map)
	apply (rule relator_props)+
	subgoal using 1 by auto
	subgoal by auto
	done
	qed

	definition "lorenz_poincare_tangents optns interrupt guards roptn c1 (X0::R3 set) (tangents::R3 set) =
	do {
	X0tanmat \<leftarrow> (if c1 then
	do {
	R \<leftarrow> mat1_nres (cast ` X0) (cast ` tangents);
	RETURN (R::3 eucl1 set)
	} else RETURN (cast ` X0 \<times> UNIV));
	XDX0 \<leftarrow> scaleRe_ivl_spec 1 1 (X0tanmat);
	let _ = aform.trace_set1e ''START'' (Some XDX0);
	let _ = aform.print_set1e False (XDX0);
	P \<leftarrow> lorenz_poincare optns interrupt guards roptn ((mk_coll XDX0:::clw_rel aform.appr1e_rel));
	RETURN (op_image_cast_eucl1e_coll P::R3 c1_info set)
	}"
	lemma [autoref_rules_raw]: "DIM(real \<times> real \<times> real) = DIM((real, 3) vec)"
	by auto

	schematic_goal lorenz_poincare_tangents_impl:
	includes autoref_syntax
	assumes [autoref_rules]:
	"(optnsi, optns) \<in> Id"
	"(intrri, intr) \<in> bool_rel"
	"(guardsi, guards) \<in> guards_rel"
	"(roi, roptn) \<in> aform.reach_optns_rel"
	"(c1i, c1) \<in> bool_rel"
	"(X0i, X0) \<in> aform.appr_rel"
	"(tangentsi, tangents) \<in> aform.appr_rel"
	shows
	"(nres_of ?r, lorenz_poincare_tangents $ optns $ intr $ guards $ roptn $ c1 $ (X0::R3 set) $ tangents) \<in>
	\<langle>clw_rel aform.appr1e_rel\<rangle>nres_rel"
	unfolding lorenz_poincare_tangents_def
	including art
	by (autoref_monadic)

	concrete_definition lorenz_poincare_tangents_impl uses
	lorenz_poincare_tangents_impl[where
	optnsa = "\<lambda>_ _ _ _ _ _ _ _. optns"
	and optnsb = "\<lambda>_ _ _ _ _ _ _ _ _. optns"
	and optnsi = "optns"
	and optnsc = "optns"
	and optns = "\<lambda>_ _ _ _ _ _ _. optns"
	for optns optnsc]
	lemma lorenz_poincare_tangents_impl_refine[autoref_rules]:
	includes autoref_syntax
	shows
	"(\<lambda>optnsi intrri guardsi roi c1i X0i tangentsi. nres_of
	(lorenz_poincare_tangents_impl optnsi intrri guardsi roi c1i X0i tangentsi),
	lorenz_poincare_tangents)
	\<in> num_optns_rel \<rightarrow> bool_rel \<rightarrow> guards_rel \<rightarrow> aform.reach_optns_rel \<rightarrow> bool_rel \<rightarrow> aform.appr_rel \<rightarrow>
	aform.appr_rel \<rightarrow>
	\<langle>clw_rel aform.appr1e_rel\<rangle>nres_rel"
	using lorenz_poincare_tangents_impl.refine by force

	lemma transfer_UNIV_rel_blinfun[transfer_rule]:
	"(rel_set (rel_blinfun lorenz.rel_ve lorenz.rel_ve)) UNIV UNIV"
	apply (auto intro!: rel_setI simp: rel_blinfun_def)
	subgoal for x
	apply (rule exI[where x="cast_bl x"])
	by (auto intro!: rel_funI simp: lorenz.rel_ve_cast)
	subgoal for x
	apply (rule exI[where x="cast_bl x"])
	by (auto intro!: rel_funI simp: lorenz.rel_ve_cast)
	done

	lemma lorenz_vX[simp]: "lorenz.vX = (UNIV::3 rvec set)"
	by (force simp: lorenz.vX_def intro!: cast_cast[symmetric])

	lemma closed_cast_\<Sigma>[intro, simp]: "closed (cast ` \<Sigma>::3 rvec set)"
	by (auto simp: \<Sigma>_def )
	lemma blinfun_apply_transfer[transfer_rule]:
	"(rel_fun (rel_blinfun lorenz.rel_ve lorenz.rel_ve)
	(rel_fun (rel_prod (=) (rel_prod (=) (=))) lorenz.rel_ve))
	(blinfun_apply o cast_bl) blinfun_apply"
	by (auto intro!: rel_funI simp: rel_blinfun_def lorenz.rel_ve_cast
	dest!: rel_funD)

	lemma lorenz_poincare_tangents[le, refine_vcg]:
	"lorenz_poincare_tangents optns intr guards roptn c1 (X0::R3 set) tangents \<le>
	SPEC (\<lambda>x.
	(if c1 then \<exists>tans. X0 \<times> tangents \<subseteq> (\<lambda>(x, y). (x, blinfun_apply y (1, 0, 0))) ` tans \<and> lorenz.poincare_mapsto \<Sigma> (tans - \<Gamma>\<^sub>i intr \<times> UNIV) (\<Sigma>\<^sub>l\<^sub>e) UNIV x
	else lorenz.poincare_mapsto \<Sigma> ((X0 - \<Gamma>\<^sub>i intr) \<times> UNIV) (\<Sigma>\<^sub>l\<^sub>e) UNIV x))"
	if [refine_vcg]: NF
	unfolding lorenz_poincare_tangents_def
	apply refine_vcg
	apply auto
	apply (subst lorenz.poincare_mapsto_eq[symmetric])
	apply simp
	proof goal_cases
	case (2 R)
	then show ?case
	apply transfer
	apply (subst lorenz.vpoincare_mapsto_eq[symmetric])
	- apply (auto simp: )
	+ apply auto
	apply (rule aform.poincare_mapsto_subset, assumption)
	by (force simp: scaleR2_def )+
	next
	case (1 tans R)
	show ?case
	apply (rule exI[where x="cast_eucl1 ` tans"])
	apply (rule conjI)
	subgoal including lifting_syntax
	using 1(2)
	by transfer (force simp: cast_def o_def)
	subgoal
	using 1(3) apply transfer
	apply (subst lorenz.avpoincare_mapsto_eq[symmetric])
	- by (auto simp: )
	+ by auto
	done
	qed

	definition of_mat1_image::"R3 c1_info set \<Rightarrow> R3 set nres"
	where [refine_vcg_def]: "of_mat1_image X = SPEC (\<lambda>R. R = (\<lambda>x. blinfun_apply (snd x) (1, 0, 0)) ` X)"

	lemma of_mat1_image_impl[autoref_rules]:
	"(\<lambda>x. (case x of (_, Some xs) \<Rightarrow> RETURN [xs ! 0, xs ! 3, xs ! 6]
	\| (_, None) \<Rightarrow> SUCCEED), of_mat1_image) \<in> aform.appr1_rel \<rightarrow> \<langle>aform.appr_rel\<rangle>nres_rel"
	apply (auto simp: of_mat1_image_def RETURN_RES_refine_iff nres_rel_def
	aform.appr1_rel_internal aform.appr_rel_def
	intro!: relcompI
	split: option.splits)
	unfolding aforms_rel_def
	apply (rule brI)
	- apply (auto simp: )
	+ apply auto
	unfolding lv_rel_def set_rel_br
	apply (rule brI)
	prefer 2 apply (force simp: Joints_imp_length_eq)
	apply (auto elim!: mem_Joints_appendE simp: flow1_of_list_def Joints_imp_length_eq)
	subgoal for a b c d e f g h i j
	apply (rule image_eqI[where x="[j ! 0, j ! 3, j! 6]"])
	apply (auto simp: blinfun_of_list_def blinfun_of_matrix_apply
	Basis_prod_def Basis_list_R3 Basis_list_vec3 eval_nat_numeral zero_prod_def)
	apply (rule map_nth_Joints'[of _ _ "[0, Suc (Suc (Suc 0)), Suc (Suc (Suc (Suc (Suc (Suc 0)))))]",
	simplified])
	apply auto
	done
	subgoal for a b c d e f
	unfolding image_image
	apply (auto simp: Joints_def valuate_def)
	subgoal for g
	apply (rule image_eqI)
	prefer 2
	apply (rule image_eqI[where x=g])
	apply (rule refl)
	- apply (auto simp: )
	+ apply auto
	apply (auto simp: blinfun_of_list_def blinfun_of_matrix_apply flow1_of_list_def
	Basis_prod_def Basis_list_R3 Basis_list_vec3 eval_nat_numeral zero_prod_def)
	done
	done
	done

	definition [refine_vcg_def]: "floatdegs res = SPEC (\<lambda>_::unit. min_deg res \<in> float \<and> max_deg res \<in> float)"
	definition [simp]: "isinfloat x \<longleftrightarrow> x \<in> float"
	lemma [code]: "isinfloat (real_of_float x) = True"
	by (auto)

	lemma floatdegs_impl[autoref_rules]:
	includes autoref_syntax
	shows
	"(\<lambda>res. (if isinfloat (min_deg res) \<and> isinfloat (max_deg res) then RETURN () else SUCCEED), floatdegs)
	\<in> Id \<rightarrow> \<langle>unit_rel\<rangle>nres_rel"
	by (auto simp: nres_rel_def floatdegs_def)

	definition "check_c1_entry optns em P (res0::result) (res::result) = do {
	uv_ret \<leftarrow> of_mat1_image P;
	nuv \<leftarrow> aform.mig_set 3 uv_ret;
	floatdegs res0;
	floatdegs res;
	let e' = em * ereal nuv;
	b1 \<leftarrow> approx_conefield_bounds P (min_deg res) (max_deg res);
	let b2 = e' \<ge> preexpansion res;
	let b3 = e' \<ge> expansion res0;
	let _ = aform.print_msg ((shows ''# check_c1_entry: '' o shows_list [b1, b2, b3] o shows_space o
	shows_list [e', preexpansion res, expansion res0]) '''');
	RETURN (em \<ge> 0 \<and> b1 \<and> b2 \<and> b3)
	}"

	lemma [autoref_itype]:
	"shows_prec ::\<^sub>i i_nat \<rightarrow>\<^sub>i A \<rightarrow>\<^sub>i i_string \<rightarrow>\<^sub>i i_string"
	by auto

	lemma [autoref_rules]:
	includes autoref_syntax
	shows
	"PREFER_id A \<Longrightarrow> (shows_list, shows_list) \<in> \<langle>A\<rangle>list_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> string_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> ereal_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec::_\<Rightarrow>result \<Rightarrow>_) \<in> nat_rel \<rightarrow> Id \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_space, shows_space) \<in> string_rel \<rightarrow> string_rel"
	by (auto simp: string_rel_def)
	lemma [autoref_rules]:
	includes autoref_syntax
	shows
	"(expansion, expansion) \<in> Id \<rightarrow> rnv_rel"
	"(preexpansion, preexpansion) \<in> Id \<rightarrow> rnv_rel"
	"(min_deg, min_deg) \<in> Id \<rightarrow> rnv_rel"
	"(max_deg, max_deg) \<in> Id \<rightarrow> rnv_rel"
	by auto
	interpretation autoref_op_pat_def aform.mig_set .
	lemma [autoref_rules_raw]: "DIM_precond TYPE(real \<times> real \<times> real) (OP 3 ::: nat_rel)"
	by simp
	schematic_goal check_c1_entry_impl:
	includes autoref_syntax
	assumes [autoref_rules]:
	"(optnsi, optns) \<in> Id"
	"(res0i, res0) \<in> Id"
	"(resi, res) \<in> Id"
	"(emi, em) \<in> ereal_rel"
	"(Pei, P) \<in> aform.appr1_rel"
	shows
	"(nres_of ?r, check_c1_entry optns em P res0 res) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding check_c1_entry_def
	including art
	by autoref_monadic

	concrete_definition check_c1_entry_impl uses check_c1_entry_impl[
	where optns = "\<lambda>_ . optnsi"
	and optnsi="optnsi"
	and optnsc=optns
	and optnsa="\<lambda>_ _ _ _ _. optnsi"
	and optnsb="\<lambda>_ _ _ _ _ _ _ _ . optnsi"
	and optns="\<lambda>_. optnsi"
	for optns optnsi]
	lemmas check_c1_entry_impl_refine[autoref_rules] = check_c1_entry_impl.refine[autoref_higher_order_rule]

	definition "c1_entry_correct (em::ereal) (P::R3 c1_info set) res0 res = (\<forall>(_, d)\<in>P. case (d (1, 0, 0)) of (dx, dy, dz) \<Rightarrow>
	dz = 0 \<and> dx > 0 \<and> -90 < min_deg res \<and> min_deg res \<le> max_deg res \<and> max_deg res < 90 \<and>
	ereal (preexpansion res) \<le> em * (norm (dx, dy, dz)) \<and>
	ereal (expansion res0) \<le> em * (norm (dx, dy, dz)) \<and>
	dy / dx \<in> {tan (rad_of (min_deg res)) .. tan (rad_of (max_deg res))})"

	lemma check_c1_entry[le, refine_vcg]:
	"check_c1_entry optns em P res0 res \<le> SPEC (\<lambda>b. b \<longrightarrow> c1_entry_correct em P res0 res)"
	unfolding check_c1_entry_def c1_entry_correct_def
	apply refine_vcg
	apply (auto dest!: bspec simp:)
	apply (rule order_trans, assumption, rule ereal_mult_left_mono, force, force)
	apply (rule order_trans, assumption, rule ereal_mult_left_mono, force, force)
	done


	subsection \<open>options for the lorenz system\<close>

	definition aform_numeric_optns::"_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow>
	real aform numeric_options" where
	"aform_numeric_optns = numeric_options.fields"

	fun zbucket::"real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> ((real list \<times> real list) \<times> real list sctn) list"
	where "zbucket d (x0,x1) (y0, y1) (z0, z1) =
	[zsec' (x0 - d, x0 + d) (y0 - d, y1 + d) z0, \<comment> \<open>bottom\<close>
	xsec' x0 (y0 - d, y1 + d) (z0 - d, z1), \<comment> \<open>left\<close>
	xsec x1 (y0 - d, y1 + d) (z0 - d, z1), \<comment> \<open>right\<close>
	ysec' (x0 - d, x1 + d) y0 (z0 - d, z1), \<comment> \<open>backno\<close>
	ysec (x0 - d, x1 + d) y1 (z0 - d, z1)] \<comment> \<open>front\<close>"

	subsubsection \<open>Hybridizations\<close>

	definition "reduce_weak_params c1 = (if c1 then (12::nat, 0::nat) else (3, 0))"
	definition "reduce_hard_params c1 = (if c1 then (0::nat, 100::nat) else (0, 100))"
	definition "ro_split_weak c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro (w + 1) m n w w (-5))"
	definition "ro_split_weak' c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro w m n w w (-5))"
	definition "ro_split_weak'' c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro (w + 2) m n w w (-5))"
	definition "ro_split_weak4' c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro (w + 4) m n w w (-5))"
	definition "ro_split_weak2 c1 w w2 = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro (w + 1) m n w w2 (-5))"
	definition "ro_split_weak2' c1 w w2 = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro (w) m n w w2 (-5))"
	definition "ro_split_hard c1 w0 w1 = (case reduce_hard_params c1 of (m, n) \<Rightarrow> ro (w0 + 1) m n w0 w1 (-5))"
	definition "ro_split_hard'' c1 w0 w1 = (case reduce_hard_params c1 of (m, n) \<Rightarrow> ro (w0 + 2) m n w0 w1 (-5))"
	definition "ro_split_not c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro 0 m n w w (-5))"
	definition "ro_split_not2 c1 w w2 = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro 0 m n w w2 (-5))"

	definition "xsecs x y z = [xsec' (-x) (-y, y) (0, z), xsec x (-y, y) (0, z)]"

	type_synonym run_options = "(nat \<times> nat) \<times> int \<times>
	(((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options) list \<times> real aform reach_options"

	abbreviation "p1 \<equiv> ldec 0.1"

	definition mode_middle::"_ \<Rightarrow> run_options" where "mode_middle c1 = (reduce_weak_params c1, -14,
	[([zsec' (-2, 2) (-1, 1) 10], ro_split_weak' c1 (-3)),
	(xsecs (5 * p1) 10 10 @
	xsecs p1 10 (6) @
	[zsec' (-p1, p1) (-p1, p1) p1],
	ro_split_hard c1 (-5) (-2)),
	(xsecs (3/2/2) 10 (10), ro_split_not2 c1 0 (-2)), \<comment> \<open>To collect after interrupt\<close>
	([zsec (-30, -6) (-10, 10) 30, zsec (6, 30) (-10, 10) 30], ro_split_not2 c1 (-1) (-3))
	], ro_split_weak4' c1 (-5))"

	definition mode_inner3::"bool\<Rightarrow>bool\<Rightarrow>run_options" where "mode_inner3 c1 very_inner =
	(reduce_weak_params c1, -15,
	(if very_inner then [([zsec' (-2, 2) (-1, 1) 10], ro_split_weak' c1 (-2))] else [])@
	[(xsecs (3/2) 15 27@xsecs 1 (10) (11/2), ro_split_weak2 c1 (-2) (-1)),
	([ zsec (-30, -6) (-10, 10) 30, zsec (6, 30) (-10, 10) 30], ro_split_not2 c1 (-1) (-3))
	],
	if very_inner then ro_split_weak4' c1 (-5) else ro_split_weak'' c1 (-5))"

	definition mode_inner2::"bool \<Rightarrow> real \<Rightarrow> run_options" where "mode_inner2 c1 x =
	(reduce_weak_params c1, -14,
	[(xsecs x 10 27, ro_split_weak2' c1 (-2) (-1)),
	([zsec ( -30, -6) (-10, 10) 30, zsec (6, 30) (-10, 10) 30], ro_split_not2 c1 (-3) (-3))],
	ro_split_not c1 (-6))"

	definition "ro_outer c1 w = (case reduce_weak_params c1 of (m, n) \<Rightarrow> ro w m n (-6) (-6) (-5))"
	definition mode_outer::"bool\<Rightarrow>_\<Rightarrow>_\<Rightarrow>run_options" where
	"mode_outer c1 w i = (reduce_weak_params c1, (-i),
	[([zsec (-30, -6) (-10, 10) 27, zsec (6, 30) (-10, 10) 27], ro_split_not2 c1 (-3) (-4))], ro_outer c1 w)"

	definition lookup_mode::"bool \<Rightarrow> result \<Rightarrow> _" where
	"lookup_mode c1 i =
	(if gridx0 i \<le> - 1024 then mode_outer c1 (-3) 16
	else if gridx0 i \<le> - 120 then mode_outer c1 (-3) 14
	else if gridx0 i \<le> 107 then mode_inner2 c1 (4)
	else if gridx0 i \<le> 169 then mode_inner3 c1 False
	else if gridx0 i \<le> 196 then mode_inner3 c1 True
	else if gridx0 i \<le> 201 then mode_middle c1
	else if gridx0 i \<le> 235 then mode_inner3 c1 True
	else if gridx0 i \<le> 290 then mode_inner3 c1 False
	else if gridx0 i \<le> 450 then mode_inner2 c1 4
	else mode_outer c1 (-3) 14)"

	definition mode_ro_spec::"bool \<Rightarrow> result \<Rightarrow> ((nat \<times> nat) \<times>
	int \<times> ((real, 3) vec set \<times> unit) list \<times>
	unit) nres"
	where [refine_vcg_def]: "mode_ro_spec c1 res = SPEC (\<lambda>_. True)"

	lemma reach_options_rel_br: "reach_options_rel TYPE('ty) = br (\<lambda>_. ()) (\<lambda>_. True)"
	by (auto simp: reach_options_rel_def br_def)

	lemma mode_ro_spec_impl[autoref_rules]:
	includes autoref_syntax
	shows "(\<lambda>b x. RETURN (lookup_mode b x), mode_ro_spec) \<in> bool_rel \<rightarrow> Id \<rightarrow>
	\<langle>(nat_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r int_rel \<times>\<^sub>r guards_rel \<times>\<^sub>r aform.reach_optns_rel\<rangle>nres_rel"
	supply [simp del] = prod_rel_id_simp
	apply (rule fun_relI)
	apply (rule fun_relI)
	apply (rule nres_relI)
	unfolding mode_ro_spec_def
	apply (rule RETURN_SPEC_refine)
	apply (auto simp: mode_ro_spec_def nres_rel_def RETURN_RES_refine_iff)
	apply (rule exI)+
	apply (rule prod_relI'' IdI)+
	unfolding lv_rel_def ivl_rel_def br_rel_prod br_chain plane_rel_br inter_rel_br
	clw_rel_br br_list_rel Id_br prod_eq_iff reach_options_rel_br
	apply (rule brI refl)+
	defer apply (rule brI) apply (rule refl) apply auto
	apply (auto simp: lookup_mode_def mode_outer_def mode_inner2_def mode_inner3_def xsecs_def
	mode_middle_def)
	done

	lemma [autoref_rules]: includes autoref_syntax shows
	"(ivl_of_res, ivl_of_res) \<in> Id \<rightarrow> \<langle>rnv_rel\<rangle>list_rel \<times>\<^sub>r \<langle>rnv_rel\<rangle>list_rel"
	by auto


	lemma [autoref_rules]: includes autoref_syntax shows
	"(Polygon.pairself, Polygon.pairself) \<in> (A \<rightarrow> C) \<rightarrow> (A \<times>\<^sub>r A) \<rightarrow> (C \<times>\<^sub>r C)"
	by (auto dest: fun_relD)

	lemma set_of_ivl_impl[autoref_rules]: includes autoref_syntax shows
	"(\<lambda>x. x, set_of_ivl) \<in> (A \<times>\<^sub>r A) \<rightarrow> \<langle>A\<rangle>ivl_rel"
	by (auto simp: ivl_rel_def br_def)
	lemma eucl_of_list_pad: includes autoref_syntax shows
	"DIM_precond TYPE('a::executable_euclidean_space) D \<Longrightarrow>
	(\<lambda>xs. take D xs @ replicate (D - length xs) 0, eucl_of_list::_\<Rightarrow>'a) \<in> rl_rel \<rightarrow> lv_rel"
	unfolding lv_rel_def
	by (auto simp: intro!: brI)
	concrete_definition eucl_of_list_pad uses eucl_of_list_pad
	lemmas [autoref_rules] = eucl_of_list_pad.refine

	lemma source_of_res_impl[autoref_rules]: includes autoref_syntax shows
	"(ivl_of_res, source_of_res) \<in> Id \<rightarrow> \<langle>lv_rel\<rangle>ivl_rel"
	unfolding source_of_res_def
	apply (auto simp: ivl_rel_def intro!: relcompI brI)
	subgoal for a
	apply (auto simp: ivl_of_res_def ivl_of_resultrect_def
	intro!: lv_relI)
	unfolding lv_rel_def
	apply (auto intro!: brI)
	done
	done

	definition tangent_seg_of_res :: "real aform numeric_options \<Rightarrow> result \<Rightarrow> R3 set nres" where
	"tangent_seg_of_res optns res0 = do {
	let fas = map (OP (nth matrix_of_degrees2\<^sub>e)) [0, 3, 6];
	let u = min_deg res0;
	let v = max_deg res0;
	aform.approx_slp_appr fas (slp_of_fas fas) (lv_ivl [u, v, 0] [u, v, 1])
	}"
	lemmas [refine_vcg_def] = tangent_seg_of_res_spec_def
	lemma tangent_seg_of_res[le, refine_vcg]:
	"tangent_seg_of_res optns res \<le> tangent_seg_of_res_spec res"
	unfolding tangent_seg_of_res_def tangent_seg_of_res_spec_def
	apply refine_vcg
	apply (auto simp: matrix_of_degrees2\<^sub>e_def Let_def in_segment)
	subgoal for x a b c u
	by (drule bspec[where x="[min_deg res, max_deg res, u]"])
	(auto simp: tangent_of_deg_def lv_ivl_def algebra_simps intro!:)
	done
	lemma [autoref_rules]: includes autoref_syntax shows
	"(nth matrix_of_degrees2\<^sub>e, nth matrix_of_degrees2\<^sub>e) \<in> nat_rel \<rightarrow> Id"
	by auto
	schematic_goal tangent_seg_of_res_impl:
	includes autoref_syntax
	assumes [autoref_rules]: "(resi, res) \<in> Id"
	"(optnsi, optns) \<in> num_optns_rel"
	shows
	"(nres_of ?r, tangent_seg_of_res optns res) \<in> \<langle>aform.appr_rel\<rangle>nres_rel"
	unfolding tangent_seg_of_res_def
	including art
	by autoref_monadic
	concrete_definition tangent_seg_of_res_impl uses tangent_seg_of_res_impl
	lemmas [autoref_rules] = tangent_seg_of_res_impl.refine[where
	optnsi = optnsi and optnsa=optns and optns="\<lambda>_ _ _. optnsi" for optns optnsi, autoref_higher_order_rule]

	lemma return_of_res_impl:
	includes autoref_syntax shows
	"(\<lambda>results res. (get_results (inf_retx res) (inf_rety res) (sup_retx res) (sup_rety res) results),
	return_of_res) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> Id \<rightarrow> \<langle>Id\<rangle>list_wset_rel"
	by (auto simp: return_of_res_def list_wset_rel_def intro!: brI)
	concrete_definition return_of_res_impl uses return_of_res_impl
	lemmas [autoref_rules] = return_of_res_impl.refine

	lemma lorenz_optns'_impl[autoref_rules]: includes autoref_syntax shows
	"(lorenz_optns', lorenz_optns') \<in>
	\<langle>Id \<rightarrow> unit_rel\<rangle>option_rel \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel \<rightarrow> num_optns_rel"
	by auto
	lemma [autoref_rules]:
	includes autoref_syntax shows
	"(results, results) \<in> \<langle>Id\<rangle>list_rel"
	"(invoke_nf, invoke_nf) \<in> Id \<rightarrow> bool_rel"
	by auto

	definition "check_line_nres print_fun m0 n0 c1 res0 = do {
	let X0 = source_of_res res0;
	(X0l, X0u) \<leftarrow> ivl_rep X0;
	((m::nat, n::nat), a::int, modes, ro) \<leftarrow> mode_ro_spec c1 res0;
	let interrupt = invoke_nf res0;
	let optns = lorenz_optns' print_fun (the_default m m0) (the_default n n0) 1 (FloatR 1 a);
	tangents \<leftarrow> tangent_seg_of_res optns res0;
	aform.CHECKs (ST ''check_line_nres le'') (X0l \<le> X0u);
	sp \<leftarrow> aform.subset_spec_plane X0 (Sctn (eucl_of_list [0, 0, 1]) 27);
	aform.CHECKs (ST ''check_line_nres le'') sp;
	ASSERT (X0l \<le> X0u);
	Pe \<leftarrow> lorenz_poincare_tangents optns interrupt modes ro c1 ({X0l .. X0u}) tangents;
	PeS \<leftarrow> sets_of_coll Pe;
	let RETs = (return_of_res results res0);
	let RET = \<Union>((mk_coll ` (source_of_res ` RETs:::\<langle>lvivl_rel\<rangle>list_wset_rel):::\<langle>clw_rel lvivl_rel\<rangle>list_wset_rel));
	every \<leftarrow> WEAK_ALL\<^bsup>\<lambda>Pe. \<exists>P em eM Rivls. em > 0 \<and> Pe = scaleR2 em eM P \<and> fst ` P \<subseteq> \<Union>Rivls \<and> (\<forall>Rivl \<in> Rivls. (\<exists>res\<in>RETs. Rivl \<subseteq> source_of_res res \<and> (c1 \<longrightarrow> c1_entry_correct em P res0 res)))\<^esup>
	PeS (\<lambda>Pe. do {
	let _ = aform.trace_set1e (ST ''# Return Element: '') (Some Pe);
	((em, eM), P) \<leftarrow> scaleR2_rep Pe;
	aform.CHECKs (ST ''check_line_nres pos'') (0 < em);
	let R = (fst ` P:::aform.appr_rel);
	(Ri, Rs) \<leftarrow> op_ivl_rep_of_set R;
	let Rivl = (op_atLeastAtMost_ivl Ri Rs);
	Rivls \<leftarrow> aform.split_along_ivls2 3 (mk_coll Rivl) RET;
	Rivlss \<leftarrow> sets_of_coll Rivls;
	WEAK_ALL\<^bsup>\<lambda>Rivl. \<exists>res\<in>RETs. Rivl \<subseteq> source_of_res res \<and> (c1 \<longrightarrow> c1_entry_correct em P res0 res)\<^esup> Rivlss
	(\<lambda>Rivl. do {
	b \<leftarrow>
	WEAK_EX\<^bsup>\<lambda>res. Rivl \<subseteq> source_of_res res \<and> (c1 \<longrightarrow> c1_entry_correct em P res0 res)\<^esup> RETs
	(\<lambda>res. do {
	let src = (source_of_res res:::lvivl_rel);
	let subs = Rivl \<subseteq> src;
	cones \<leftarrow> if \<not>(c1 \<and> subs) then RETURN True else check_c1_entry optns em P res0 res;
	RETURN (subs \<and> cones)
	});
	let _ = aform.print_msg ((shows (ST ''# return of '') o shows res0 o
	shows (if b then ST '' OK'' else ST '' FAILED''))'''');
	RETURN b
	})
	});
	RETURN (every, Pe, RET)
	}"


	definition "aform_subset_spec_plane optns = aform.subset_spec_plane"

	lemma aform_subset_spec_plane_impl[autoref_rules]: includes autoref_syntax shows
	"DIM_precond TYPE('a::executable_euclidean_space) D \<Longrightarrow>
	(Xi, X::'a set) \<in> \<langle>lv_rel\<rangle>ivl_rel \<Longrightarrow>
	(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel \<Longrightarrow>
	(optnsi, optns) \<in> num_optns_rel \<Longrightarrow>
	(nres_of (subset_spec_plane_impl_aform optnsi D Xi sctni),
	aform_subset_spec_plane $ optns $ X $ sctn)
	\<in> \<langle>bool_rel\<rangle>nres_rel"
	using aform.subset_spec_plane_impl.refine[where 'a='a, of D Xi X sctni sctn optnsi]
	by (force simp: aform_subset_spec_plane_def)

	schematic_goal check_line_impl:
	includes autoref_syntax
	assumes [autoref_rules]: "(pfi, pf) \<in> \<langle>Id \<rightarrow> unit_rel\<rangle>option_rel"
	"(c1i, c1) \<in> bool_rel" "(res0i, res0) \<in> Id"
	"(m0i, m0) \<in> \<langle>nat_rel\<rangle>option_rel" "(n0i, n0) \<in> \<langle>nat_rel\<rangle>option_rel"
	shows
	"(nres_of ?r, check_line_nres $ pf $ m0 $ n0 $ c1 $ res0) \<in>
	\<langle>bool_rel \<times>\<^sub>r clw_rel aform.appr1e_rel \<times>\<^sub>r clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding check_line_nres_def
	including art
	by autoref_monadic

	concrete_definition check_line_impl uses check_line_impl[where
	optns = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ . lorenz_optns pfi"
	and optnsa = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and optnsb = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and optnsc = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and optnsd = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and optnse = "\<lambda>_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and optnsf = "\<lambda> _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _. lorenz_optns pfi"
	and pfi = pfi
	for pfi]
	lemmas [autoref_rules] = check_line_impl.refine


	lemma check_line_nres:
	"check_line_nres pf m0 n0 c1 res0 \<le> SPEC (\<lambda>(every, Pe, RET). \<exists>P. Pe = \<Union>P \<and>
	(if c1
	then \<exists>tans. source_of_res res0 \<times> {tangent_of_deg (min_deg res0)--tangent_of_deg (max_deg res0)} \<subseteq> (\<lambda>(x, y). (x, blinfun_apply y (1, 0, 0))) ` tans \<and>
	lorenz.poincare_mapsto \<Sigma> (tans - \<Gamma>\<^sub>i (invoke_nf res0) \<times> UNIV) \<Sigma>\<^sub>l\<^sub>e UNIV (Pe)
	else lorenz.poincare_mapsto \<Sigma> ((sourcei_of_res res0) \<times> UNIV) \<Sigma>\<^sub>l\<^sub>e UNIV (\<Union>P)) \<and>
	source_of_res res0 \<subseteq> plane_of (Sctn (0, 0, 1) 27) \<and>
	(every \<longrightarrow>
	(\<forall>x\<in>P. \<exists>P em. em > 0 \<and> (\<exists>eM. x = scaleR2 em eM P) \<and>
	(\<exists>Rivls. fst ` P \<subseteq> \<Union>Rivls \<and>
	(\<forall>Rivl\<in>Rivls.
	\<exists>res\<in>return_of_res results res0.
	Rivl \<subseteq> source_of_res res \<and> (c1 \<longrightarrow> c1_entry_correct em P res0 res))))))"
	if [refine_vcg]: NF
	unfolding check_line_nres_def sourcei_of_res_def
	apply (refine_vcg, clarsimp_all)
	using [[goals_limit=1]]
	subgoal for a0 a b c d e f g h i j k l m n p q r s t
	apply (rule exI[where x=i])
	apply (rule exI[where x=j])
	apply (rule conjI)
	apply force
	apply (rule conjI)
	apply (rule exI[where x=k])
	apply force
	apply (rule exI[where x=s])
	apply (rule conjI) defer apply force
	apply blast
	done
	subgoal for x0 y0 z0 x1 y1 z1 tangents s R every
	apply (rule exI[where x=R])
	apply auto
	subgoal for tans
	apply (rule exI[where x=tans])
	by auto
	subgoal for tans
	apply (rule exI[where x=tans])
	by auto
	done
	done

	definition "print_sets_color (print_fun::String.literal \<Rightarrow> unit) (c::string) (X::'a::executable_euclidean_space set) = ()"

	definition "print_lorenz_color print_fun cx cy cz ci cd1 cd2 P = ()"

	definition "print_aforms print_fun c aforms =
	fold (\<lambda>a _. print_fun (String.implode (shows_segments_of_aform 0 1 a c ''\<newline>''))) aforms ()"

	lemma print_sets_color_impl[autoref_rules]: includes autoref_syntax shows
	"(\<lambda>print_fun c X. print_aforms print_fun c X, print_sets_color) \<in>
	(Id \<rightarrow> unit_rel) \<rightarrow> string_rel \<rightarrow> clw_rel aform.appr_rel \<rightarrow> unit_rel"
	by auto

	lemma print_lorenz_color_impl[autoref_rules]: includes autoref_syntax shows
	"(\<lambda>print_fun cx cy cz ci cd1 cd2 P.
	fold (\<lambda>(_, x) b.
	print_lorenz_aform print_fun
	cx cy cz ci cd1 cd2
	False
	(fst x @ the_default [] (snd x))
	) P (), print_lorenz_color) \<in>
	(Id \<rightarrow> unit_rel) \<rightarrow> string_rel \<rightarrow> string_rel \<rightarrow> string_rel \<rightarrow> string_rel \<rightarrow>
	\<langle>\<langle>string_rel\<rangle>list_rel, \<langle>\<langle>string_rel\<rangle>list_rel, (\<langle>clw_rel aform.appr1e_rel, unit_rel\<rangle>fun_rel)\<rangle>fun_rel\<rangle>fun_rel"
	by auto

	definition check_line_core where
	"check_line_core print_funo m0 n0 c1 i =
	do {
	let print_fun = the_default (\<lambda>_. ()) print_funo;
	CHECK (\<lambda>_. print_fun (STR ''Hey, out of bounds!'')) (i < length results);
	let res = ((results:::\<langle>Id\<rangle>list_rel) ! (i:::nat_rel));
	(r, P, B) \<leftarrow> check_line_nres print_funo m0 n0 c1 res;
	let _ = print_sets_color print_fun (ST ''0x007f00'') (aform.sets_of_ivls B);
	(_, Pu) \<leftarrow> scaleR2_rep_coll P;
	let _ = print_sets_color print_fun (ST ''0x7f0000'')
	(aform.op_image_fst_coll (Pu:::clw_rel aform.appr1_rel):::clw_rel aform.appr_rel);
	let _ = print_lorenz_color print_fun
	(ST ''0x7f0000'') (ST ''0x7f0001'') (ST ''0x7f0002'') (ST ''0x7f0003'')
	[(ST ''0xc60000''), (ST ''0xc60000''), (ST ''0xc60000'')]
	[(ST ''0xf60000''), (ST ''0xf60000''), (ST ''0xf60000'')]
	P;
	let _ = (if r
	then print_fun
	(String.implode ((show (ST ''# VERIFIED '') @ show i @ show (ST ''\<newline>''))))
	else print_fun (String.implode ((show (ST ''# Failed to verify '') @ show i @ show (ST ''\<newline>'')) )));
	RETURN r
	}"
	lemma [autoref_rules]: includes autoref_syntax shows
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> string_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(String.implode, String.implode) \<in> string_rel \<rightarrow> Id"
	by (auto simp: string_rel_def)
	schematic_goal check_line_core_impl:
	includes autoref_syntax
	assumes [autoref_rules]: "(pfi, pf) \<in> \<langle>Id \<rightarrow> unit_rel\<rangle>option_rel"
	"(c1i, c1) \<in> bool_rel" "(ii, i) \<in> nat_rel"
	"(m0i, m0) \<in> \<langle>nat_rel\<rangle>option_rel" "(n0i, n0) \<in> \<langle>nat_rel\<rangle>option_rel"
	shows "(nres_of ?f, check_line_core $ pf $ m0 $ n0 $ c1 $ i) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding check_line_core_def
	including art
	by autoref_monadic
	concrete_definition check_line_core_impl for pfi m0i n0i c1i ii uses check_line_core_impl
	lemmas [autoref_rules] = check_line_core_impl.refine

	definition "c1i_of_res res = sourcei_of_res res \<times> conefield_of_res res"

	definition "correct_res res =
	((\<forall>(x, dx) \<in> c1i_of_res res.
	x \<in> plane_of (Sctn (0, 0, 1) 27) \<and>
	dx \<in> plane_of (Sctn (0, 0, 1) 0) \<and>
	((lorenz.returns_to \<Sigma> x \<and>
	lorenz.return_time \<Sigma> differentiable at x within \<Sigma>\<^sub>l\<^sub>e \<and>
	(\<exists>D. (lorenz.poincare_map \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e) \<and>
	norm (D dx) \<ge> expansion res * norm dx \<and>
	(\<exists>res2 \<in> return_of_res results res.
	(lorenz.poincare_map \<Sigma> x, D dx) \<in> c1_of_res res2 \<and>
	norm (D dx) \<ge> preexpansion res2 * norm dx))))))"

	lemma check_line_nres_c0_correct:
	"check_line_nres pf m0 n0 c1 res \<le> SPEC (\<lambda>(every, Pe, RET). every \<longrightarrow>
	(\<forall>x \<in> sourcei_of_res res. lorenz.poincare_map \<Sigma> x \<in> \<Union>(source_of_res ` return_of_res results res)))"
	if NF
	apply (rule check_line_nres[OF \<open>NF\<close>, le])
	apply (auto simp: c1i_of_res_def lorenz.poincare_mapsto_def)
	subgoal
	apply (drule bspec, force)
	apply (auto dest!: spec[where x="1\<^sub>L"])
	apply (drule bspec, force)
	apply (force simp: scaleR2_def image_def vimage_def)
	done
	subgoal premises prems for a b c d e tans
	proof -
	obtain t where
	"((c, d, e), t) \<in> tans - \<Gamma>\<^sub>i (invoke_nf res) \<times> UNIV"
	"((c, d, e), tangent_of_deg (min_deg res)) = (\<lambda>(x, y). (x, blinfun_apply y (1, 0, 0))) ((c, d, e), t)"
	using prems
	by (auto simp: sourcei_of_res_def)
	with prems(6)[rule_format, of "((c, d, e), t)"] prems(3)
	obtain D x where "tangent_of_deg (min_deg res) = blinfun_apply t (1, 0, 0)"
	"(c, d, e) returns_to \<Sigma>"
	"fst ` (tans - \<Gamma>\<^sub>i (invoke_nf res) \<times> UNIV) \<subseteq> \<Sigma>\<^sub>l\<^sub>e"
	"lorenz.return_time \<Sigma> differentiable at (c, d, e) within \<Sigma>\<^sub>l\<^sub>e"
	"(lorenz.poincare_map \<Sigma> has_derivative blinfun_apply D) (at (c, d, e) within \<Sigma>\<^sub>l\<^sub>e)"
	"x \<in> b" "(lorenz.poincare_map \<Sigma> (c, d, e), D o\<^sub>L t) \<in> x"
	by auto
	with prems
	show ?thesis
	subgoal
	apply (auto dest!: bspec[OF _ \<open>x \<in> b\<close>])
	apply (auto simp: scaleR2_def image_def vimage_def)
	apply (auto simp: subset_iff)
	by fastforce \<comment>\<open>slow\<close>
	done
	qed
	subgoal for a b c d e f
	apply (drule bspec[where A="sourcei_of_res res"]) apply force
	apply (auto dest!: spec[where x="1\<^sub>L"])
	apply (drule bspec, force)
	apply auto
	apply (auto simp: scaleR2_def image_def vimage_def)
	apply (auto simp: subset_iff)
	by fastforce\<comment> \<open>slow\<close>
	done

	lemma cone_conefield[intro, simp]: "cone (conefield a b)"
	unfolding conefield_alt_def
	by (rule cone_cone_hull)

	lemma in_segment_norm_bound: "c \<in> {a -- b} \<Longrightarrow> norm c \<le> max (norm a) (norm b)"
	apply (auto simp: in_segment max_def intro!: norm_triangle_le)
	apply (auto simp: algebra_simps intro: add_mono mult_left_mono
	mult_right_mono)
	using affine_ineq by blast

	lemma norm_tangent_of_deg[simp]: "norm (tangent_of_deg d) = 1"
	by (auto simp: tangent_of_deg_def norm_prod_def)

	lemma check_line_nres_c1_correct:
	"check_line_nres pf m0 n0 True res \<le> SPEC (\<lambda>(correct, Pe, RET). correct \<longrightarrow> correct_res res)"
	if NF
	proof (rule check_line_nres[OF \<open>NF\<close>, le], clarsimp, goal_cases)
	case P: (1 a P tans)
	let ?tans = "{tangent_of_deg (min_deg res)--tangent_of_deg (max_deg res)}"
	have tans_plane: "?tans \<subseteq> UNIV \<times> UNIV \<times> {0}"
	by (auto simp: in_segment tangent_of_deg_def)
	from P have *: "x \<in> plane_of (Sctn (0, 0, 1) 27)" if "x \<in> sourcei_of_res res" for x
	using that
	by (auto simp: that sourcei_of_res_def)
	from tans_plane P have **: "dx \<in> plane_of (Sctn (0, 0, 1) 0)"
	if "x \<in> sourcei_of_res res" "dx \<in> conefield_of_res res" for x dx
	proof -
	from tans_plane that obtain c dx' dy' where
	c: "dx = c *\<^sub>R (dx', dy', 0)" "(dx', dy', 0) \<in> ?tans" "c \<ge> 0"
	unfolding conefield_of_res_def conefield_alt_def cone_hull_expl
	by auto
	then show ?thesis by (auto simp: plane_of_def)
	qed
	show ?case
	unfolding correct_res_def
	proof (intro ballI conjI, clarsimp_all simp add:
	* ** c1i_of_res_def c1_of_res_def sourcei_of_res_def, goal_cases)
	case source: (1 x y z dx dy dz)
	from tans_plane source obtain c dx' dy' where
	c: "(dx, dy, dz) = c *\<^sub>R (dx', dy', 0)" "(dx', dy', 0) \<in> ?tans" "c \<ge> 0"
	unfolding conefield_of_res_def conefield_alt_def cone_hull_expl
	by auto
	from c source P
	obtain t where tans: "((x, y, z), t) \<in> tans" "blinfun_apply t (1, 0, 0) = (dx', dy', 0)"
	by auto
	from P(3) tans(1) source(3) obtain Re D where Re:
	"(x, y, z) returns_to \<Sigma>" "fst ` (tans - \<Gamma>\<^sub>i (invoke_nf res) \<times> UNIV) \<subseteq> \<Sigma>\<^sub>l\<^sub>e"
	"lorenz.return_time \<Sigma> differentiable at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e"
	"(lorenz.poincare_map \<Sigma> has_derivative blinfun_apply D) (at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e)"
	"Re \<in> P" "(lorenz.poincare_map \<Sigma> (x, y, z), D o\<^sub>L t) \<in> Re"
	by (auto simp: lorenz.poincare_mapsto_def dest!: bspec)
	from P(5)[rule_format, OF \<open>Re \<in> P\<close>]
	obtain R em eM Rivls
	where R: "Re = scaleR2 em eM R"
	"em > 0"
	"fst ` R \<subseteq> \<Union>Rivls"
	"\<And>Rivl. Rivl\<in>Rivls \<Longrightarrow>
	\<exists>resa\<in>return_of_res results res. Rivl \<subseteq> source_of_res resa \<and> c1_entry_correct em R res resa"
	by auto
	have "lorenz.poincare_map \<Sigma> (x, y, z) \<in> fst ` R"
	and s2: "(lorenz.poincare_map \<Sigma> (x, y, z), D o\<^sub>L t) \<in> scaleR2 em eM R"
	using Re R by (auto simp: scaleR2_def)
	then obtain Rivl res' where Rivl:
	"lorenz.poincare_map \<Sigma> (x, y, z) \<in> Rivl" "Rivl \<in> Rivls"
	"res' \<in> return_of_res results res" "Rivl \<subseteq> source_of_res res'"
	and c1: "c1_entry_correct em R res res'"
	using R
	by force
	from s2 obtain ed Dt where Dt:
	"em \<le> ereal ed" "ereal ed \<le> eM" "D o\<^sub>L t = ed *\<^sub>R Dt"
	"(lorenz.poincare_map \<Sigma> (x, y, z), Dt) \<in> R"
	by (force simp: scaleR2_def)
	then have Dt_simp[simp]: "Dt = inverse ed *\<^sub>R (D o\<^sub>L t)"
	using \<open>0 < em\<close>
	by (cases em) (auto simp: intro!: simp: blinfun.bilinear_simps inverse_eq_divide)
	from c1[unfolded c1_entry_correct_def, rule_format, OF Dt(4)]
	obtain dxr dyr where dxrdyr: "blinfun_apply D (dx', dy', 0) /\<^sub>R ed = (dxr, dyr, 0)"
	"ereal (preexpansion res') \<le> em * ereal (norm (dxr, dyr, 0::real))"
	"ereal (expansion res) \<le> em * ereal (norm (dxr, dyr, 0::real))"
	"-90 < min_deg res'" "min_deg res' \<le> max_deg res'"
	"tan (rad_of (min_deg res')) \<le> (dyr / dxr)"
	"(dyr / dxr) \<le> tan (rad_of (max_deg res'))"
	"max_deg res' < 90"
	"0 < dxr"
	by (auto simp: blinfun.bilinear_simps tans)

	then obtain emr where emr: "em = ereal emr" "0 < emr" "emr \<le> ed"
	"(preexpansion res') \<le> emr * (norm (dxr, dyr, 0::real))"
	"(expansion res) \<le> emr * (norm (dxr, dyr, 0::real))"
	using \<open>0 < em\<close> Dt
	by (cases em) (auto simp: simp: blinfun.bilinear_simps divide_simps prod_eq_iff)
	from dxrdyr have Ddx'dy': "D (dx', dy', 0) = ed *\<^sub>R (dxr, dyr, 0)"
	using \<open>0 < em\<close> Dt
	by (cases em) (auto simp: simp: blinfun.bilinear_simps divide_simps prod_eq_iff)

	note \<open>(x, y, z) returns_to \<Sigma>\<close>
	moreover note \<open>lorenz.return_time \<Sigma> differentiable at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e\<close>
	moreover note \<open>(lorenz.poincare_map \<Sigma> has_derivative D) (at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e)\<close>
	moreover note \<open>res' \<in> return_of_res results res\<close>
	moreover have "lorenz.poincare_map \<Sigma> (x, y, z) \<in> source_of_res res'"
	using Rivl by force
	moreover
	have \<open>0 \<le> ed\<close> using Dt \<open>0 < em\<close> by (cases em) auto
	have \<open>D (dx, dy, dz) \<in> conefield_of_res res'\<close>
	unfolding c blinfun.bilinear_simps conefield_of_res_def Ddx'dy'
	apply (intro mem_cone, simp_all add: \<open>0 \<le> ed\<close> \<open>0 \<le> c\<close> tangent_of_deg_def)
	apply (rule conefield_prod3I)
	unfolding fun_cong[OF tan_def, symmetric]
	subgoal by fact
	subgoal using dxrdyr
	apply (intro cos_gt_zero_pi)
	unfolding rad_of_lt_iff rad_of_gt_iff
	by (auto simp: deg_of_def)
	subgoal using dxrdyr
	apply (intro cos_gt_zero_pi)
	unfolding rad_of_lt_iff rad_of_gt_iff
	by (auto simp: deg_of_def)
	subgoal by fact
	subgoal by fact
	done
	moreover
	have norms_le: "emr * norm (dx', dy', 0::real) * (\<bar>c\<bar> * norm (dxr, dyr, 0::real)) \<le> \<bar>ed\<bar> * (\<bar>c\<bar> * norm (dxr, dyr, 0::real))"
	proof -
	from c(2)[THEN in_segment_norm_bound] have "norm (dx', dy', 0::real) \<le> 1"
	by auto
	also have "\<dots> \<le> ed / emr"
	using dxrdyr emr
	unfolding Ddx'dy'
	by auto
	finally show ?thesis
	using emr
	by (intro mult_right_mono) (auto simp: divide_simps ac_simps)
	qed
	then have "expansion res * norm (dx, dy, dz) \<le> norm (D (dx, dy, dz))"
	unfolding c blinfun.bilinear_simps conefield_of_res_def Ddx'dy' norm_scaleR
	apply -
	apply (rule order_trans)
	apply (rule mult_right_mono)
	apply (rule emr)
	by (auto simp: ac_simps)
	moreover have "preexpansion res' * norm (dx, dy, dz) \<le> norm (D (dx, dy, dz))"
	using norms_le
	unfolding c blinfun.bilinear_simps conefield_of_res_def Ddx'dy' norm_scaleR
	apply -
	apply (rule order_trans)
	apply (rule mult_right_mono)
	apply (rule emr)
	by (auto simp: ac_simps)
	ultimately
	show ?case
	by blast
	qed
	qed

	lemma conefield_ne_empyt[simp]: "conefield a b \<noteq> {}"
	by (auto simp: conefield_def conesegment_def cone_hull_empty_iff[symmetric])

	lemma in_return_of_resD: "res' \<in> return_of_res results res \<Longrightarrow> res' \<in> set results"
	by (auto simp: return_of_res_def get_results_def)
	lemma finite_results_at[intro, simp]: "finite (results_at x)"
	by (auto simp: results_at_def)


	lemma lorenz_bounds_lemma:
	"x returns_to \<Sigma>"
	"R x \<in> N"
	"(R has_derivative DR x) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"\<And>c. c \<in> \<CC> x \<Longrightarrow> DR x c \<in> \<CC> (R x)"
	"\<And>c. c \<in> \<CC> x \<Longrightarrow> norm (DR x c) \<ge> \<E> x * norm c"
	"\<And>c. c \<in> \<CC> x \<Longrightarrow> norm (DR x c) \<ge> \<E>\<^sub>p (R x) * norm c"
	if "x \<in> N - \<Gamma>" NF "\<And>res. res \<in> set results \<Longrightarrow> correct_res res"
	proof -
	from \<open>x \<in> N - \<Gamma>\<close> obtain res where res: "res \<in> set results" "x \<in> sourcei_of_res res"
	by (auto simp: N_def sourcei_of_res_def \<Gamma>\<^sub>i_def)
	then have ne: "c1i_of_res res \<noteq> {}"
	by (auto simp: c1i_of_res_def conefield_of_res_def)
	from res this obtain dx where dx: "(x, dx) \<in> c1i_of_res res"
	by (auto simp: c1i_of_res_def)
	from that(3)[OF \<open>res \<in> set _\<close>] have "correct_res res" by simp
	from this[unfolded correct_res_def, rule_format, OF dx] res
	obtain res' D where res': "x returns_to \<Sigma>"
	"lorenz.return_time \<Sigma> differentiable at x within \<Sigma>\<^sub>l\<^sub>e"
	"(lorenz.poincare_map \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"expansion res * norm dx \<le> norm (D dx)"
	"res' \<in> return_of_res results res"
	"(lorenz.poincare_map \<Sigma> x, D dx) \<in> c1_of_res res'"
	"preexpansion res' * norm dx \<le> norm (D dx)"
	by auto
	show "x returns_to \<Sigma>" by fact
	show "R x \<in> N" using res'
	by (auto simp: R_def N_def N_def c1i_of_res_def c1_of_res_def in_return_of_resD
	sourcei_of_res_def)
	show "(R has_derivative DR x) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	apply (auto simp: R_def DR_def N_def c1_of_res_def in_return_of_resD)
	apply (subst frechet_derivative_works[symmetric])
	apply (rule differentiableI)
	by fact
	next
	fix dx assume "dx \<in> \<CC> x"
	then obtain res where res: "res \<in> set results" and dx: "(x, dx) \<in> c1_of_res res"
	by (auto simp: \<CC>_def results_at_def c1_of_res_def )
	then have dx: "(x, dx) \<in> c1i_of_res res"
	using \<open>x \<in> N - _\<close>
	by (auto simp: c1i_of_res_def sourcei_of_res_def c1_of_res_def \<Gamma>\<^sub>i_def)
	from res dx have ne: "c1i_of_res res \<noteq> {}"
	by (auto simp: c1_of_res_def conefield_of_res_def)
	from that(3)[OF \<open>res \<in> set _\<close>] have "correct_res res" by simp
	from that this[unfolded correct_res_def, rule_format, OF dx] res
	obtain res' D where res': "x returns_to \<Sigma>" "x \<in> plane_of (Sctn (0, 0, 1) 27)"
	"lorenz.return_time \<Sigma> differentiable at x within \<Sigma>\<^sub>l\<^sub>e"
	"(lorenz.poincare_map \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"expansion res * norm dx \<le> norm (D dx)"
	"res' \<in> return_of_res results res"
	"(lorenz.poincare_map \<Sigma> x, D dx) \<in> c1_of_res res'"
	"preexpansion res' * norm dx \<le> norm (D dx)"
	by auto
	have DRD: "DR x = D"
	unfolding DR_def
	apply (rule frechet_derivative_unique_within)
	apply (subst frechet_derivative_works[symmetric])
	apply (rule differentiableI)
	apply fact
	apply fact using \<open>x \<in> plane_of _\<close>
	apply safe
	subgoal for _ _ _ e
	by (auto simp: \<Sigma>\<^sub>l\<^sub>e_def Basis_prod_def prod_eq_iff plane_of_def prod_eq_iff
	inner_prod_def intro!: exI[where x="-e/2"])
	done
	have [intro, simp]: "res' \<in> results_at (lorenz.poincare_map \<Sigma> x)"
	using res'
	by (auto simp: c1_of_res_def results_at_def in_return_of_resD R_def
	intro!: exI[where x=res'])
	have [intro, simp]: "res \<in> results_at x"
	using res dx
	by (auto simp: c1i_of_res_def results_at_def sourcei_of_res_def)
	show "DR x dx \<in> \<CC> (R x)"
	unfolding DRD \<CC>_def
	using res'
	by (auto simp: c1_of_res_def R_def)
	have "\<E> x * norm dx \<le> expansion res * norm dx"
	by (rule mult_right_mono) (auto simp: \<E>_def)
	also have "\<dots> \<le> norm (DR x dx)" unfolding DRD by fact
	finally show "\<E> x * norm dx \<le> norm (DR x dx)" .

	have "\<E>\<^sub>p (R x) * norm dx \<le> preexpansion res' * norm dx"
	by (rule mult_right_mono) (auto simp: \<E>\<^sub>p_def R_def)
	also have "\<dots> \<le> norm (DR x dx)" unfolding DRD by fact
	finally show "\<E>\<^sub>p (R x) * norm dx \<le> norm (DR x dx)" .
	qed


	lemma check_line_core_correct:
	"check_line_core pf m0 n0 True i \<le> SPEC (\<lambda>correct. correct \<longrightarrow> correct_res (results ! i))"
	if [refine_vcg]: NF
	unfolding check_line_core_def
	supply [refine_vcg] = check_line_nres_c1_correct[le]
	by refine_vcg


	text \<open>The symmetric reduction\<close>

	lemma source_of_res_mirror: "(x, y, z) \<in> source_of_res (mirror_result res) \<longleftrightarrow>
	(-x, -y, z) \<in> source_of_res res"
	by (cases res)
	(auto simp: source_of_res_def ivl_of_res_def ivl_of_resultrect_def set_of_ivl_def)

	lemma conefield_of_res_mirror[simp]: "(x, y, z) \<in> conefield_of_res (mirror_result res) \<longleftrightarrow>
	(x, y, z) \<in> conefield_of_res res"
	by (cases res) (auto simp: conefield_of_res_def ivl_of_res_def)

	lemma c1_of_res_mirror: "((x, y, z), dx, dy, dz) \<in> c1_of_res (mirror_result res) \<longleftrightarrow>
	((-x, -y, z), dx, dy, dz) \<in> c1_of_res res"
	by (auto simp: c1_of_res_def source_of_res_mirror)

	lemmas [simp] = lorenz_S(2)
	lemma lorenz_S_idem[simp]: "lorenz_S (lorenz_S x) = (x::R3)"
	by (auto simp: lorenz_S_def split_beta')
	lemma lorenz_S_exivl[simp]:
	"lorenz.existence_ivl0 (lorenz_S X) = lorenz.existence_ivl0 X"
	using lorenz_S(1)[of _ X]
	using lorenz_S(1)[of _ "lorenz_S X"]
	by auto
	lemma lorenz_S_zero[simp]: "lorenz_S x = 0 \<longleftrightarrow> (x::R3) = 0"
	by (auto simp: lorenz_S_def split_beta' prod_eq_iff)
	lemma lorenz_S_returns_toI[simp]:
	"x returns_to (lorenz_S ` P) \<Longrightarrow> lorenz_S x returns_to P"
	apply (auto simp: lorenz.returns_to_def)
	subgoal premises prems for t
	proof -
	have " \<forall>\<^sub>F s in at_right 0. s < t"
	using tendsto_ident_at \<open>0 < t\<close>
	by (rule order_tendstoD)
	then have " \<forall>\<^sub>F s in at_right 0. s \<in> lorenz.existence_ivl0 x"
	unfolding eventually_at_filter
	apply eventually_elim
	using \<open>0 < t\<close> lorenz.closed_segment_subset_existence_ivl[OF prems(3)]
	by (auto simp: closed_segment_eq_real_ivl subset_iff)
	then show ?thesis using prems(1)
	by eventually_elim force
	qed
	done

	lemma lorenz_S_returns_to[simp]:
	"lorenz_S x returns_to P \<longleftrightarrow> x returns_to (lorenz_S ` P)"
	using lorenz_S_returns_toI[of P x] lorenz_S_returns_toI[of "lorenz_S ` P" "lorenz_S x"]
	by (auto simp: image_image)
	lemma lorenz_S_image_Sigma[simp]: "lorenz_S ` \<Sigma> = \<Sigma>"
	apply (auto simp: \<Sigma>_def lorenz_S_def)
	apply (rule image_eqI)
	apply (rule lorenz_S_idem[symmetric])
	apply (auto simp: \<Sigma>_def lorenz_S_def)
	done

	lemma linear_lorenz_S: "linear lorenz_S"
	by unfold_locales (auto simp: lorenz_S_def)
	lemma inj_lorenz_S: "inj_on (lorenz_S::R3 \<Rightarrow> _) G"
	by (rule inj_onI) (auto simp: lorenz_S_def prod_eq_iff)

	lemma lorenz_S_return_time:
	"lorenz.return_time P (lorenz_S x) = lorenz.return_time (lorenz_S ` P) x"
	if "x returns_to (lorenz_S ` P)" "closed P"
	proof -
	from lorenz.returns_toE[OF that(1)] obtain t0 t1
	where f: "0 < t0" "t0 \<le> t1" " t1 \<in> lorenz.existence_ivl0 x"
	"lorenz.flow0 x t1 \<in> lorenz_S ` P"
	"\<And>t. 0 < t \<Longrightarrow> t < t0 \<Longrightarrow> lorenz.flow0 x t \<notin> lorenz_S ` P"
	by auto
	have [simp]: "lorenz.return_time (lorenz_S ` P) x \<in> lorenz.existence_ivl0 x"
	by (auto intro!: that closed_injective_linear_image linear_lorenz_S
	lorenz.return_time_exivl
	inj_lorenz_S)
	have c': "closed (lorenz_S ` P)"
	by (auto intro!: that closed_injective_linear_image linear_lorenz_S
	lorenz.return_time_exivl lorenz.return_time_pos
	inj_lorenz_S)
	show ?thesis
	using f(1-4)
	using lorenz.return_time_returns[OF that(1) c']
	apply (intro lorenz.return_time_eqI)
	apply (auto intro!: that closed_injective_linear_image linear_lorenz_S
	lorenz.return_time_exivl lorenz.return_time_pos c'
	inj_lorenz_S)
	subgoal premises prems for a b c d e f g
	proof -
	have [simp]: "a \<in> lorenz.existence_ivl0 x"
	using _ that(1)
	apply (rule lorenz.less_return_time_imp_exivl)
	using prems that(2) c'
	by auto
	have "lorenz.return_time (lorenz_S ` P) x \<le> a"
	apply (rule lorenz.return_time_le)
	using prems
	apply (auto intro!: that closed_injective_linear_image linear_lorenz_S
	lorenz.return_time_exivl lorenz.return_time_pos c'
	inj_lorenz_S)
	apply (rule image_eqI)
	apply (rule lorenz_S_idem[symmetric])
	by auto
	then show ?thesis using prems
	by simp
	qed
	done
	qed

	lemma lorenz_S_poincare_map:
	"lorenz.poincare_map P (lorenz_S x) = lorenz_S (lorenz.poincare_map (lorenz_S ` P) x)"
	if "x returns_to (lorenz_S ` P)" "closed P"
	using that
	unfolding lorenz.poincare_map_def
	apply (auto simp: lorenz_S_return_time)
	apply (subst lorenz_S)
	by (auto intro!: lorenz.return_time_exivl that
	closed_injective_linear_image linear_lorenz_S inj_lorenz_S)

	lemma [continuous_intros]: "isCont (lorenz_S::_\<Rightarrow>R3) x"
	"continuous_on (G::R3 set) lorenz_S"
	by (auto simp:lorenz_S_def[abs_def] split_beta' continuous_intros)

	lemma filtermap_lorenz_S_le: "filtermap lorenz_S (at x within lorenz_S ` P) \<le>(at (lorenz_S x::R3) within P)"\<comment> \<open>TODO: generalize!\<close>
	unfolding at_within_def
	apply (auto simp: intro!: antisym filtermap_inf[le] filtermap_inf[ge])
	apply (rule inf.coboundedI1)
	apply (subst filtermap_nhds_open_map)
	apply (auto simp: intro!: invariance_of_domain inj_lorenz_S continuous_intros)
	apply (rule inf.coboundedI2)
	apply (auto simp: image_image )
	apply (auto simp: lorenz_S_def split_beta')[]
	done

	lemma filtermap_lorenz_S_eq: "filtermap lorenz_S (at (x::R3) within lorenz_S ` P) = (at (lorenz_S x::R3) within P)"
	apply (rule antisym)
	using filtermap_lorenz_S_le[of "x" P]
	apply simp
	subgoal
	proof -
	have "filtermap lorenz_S (at (lorenz_S x) within P) \<le>
	filtermap lorenz_S (filtermap lorenz_S (at x within lorenz_S ` P))"
	using filtermap_lorenz_S_le[of "lorenz_S x" "lorenz_S ` P"]
	by (auto simp: image_image filtermap_filtermap)
	then show ?thesis
	apply (subst (asm) filtermap_mono_strong)
	by (auto simp: inj_lorenz_S)
	qed
	done

	lemma norm_lorenz_S[simp]: "norm (lorenz_S x) = norm x"
	by (auto simp: lorenz_S_def norm_prod_def split_beta')

	lemma bl_lorenz_S: "bounded_linear (lorenz_S)"
	by unfold_locales (auto simp: lorenz_S_def norm_prod_def intro!: exI[where x=1])

	lemma filtermap_lorenz_S_eq_bot[simp]:
	"filtermap (lorenz_S::R3\<Rightarrow>_) F = bot \<longleftrightarrow> F = bot"
	- apply (auto simp: )
	+ apply auto
	apply (subst (asm) filtermap_bot[symmetric])
	apply (subst (asm) filtermap_eq_strong)
	by (auto simp: inj_lorenz_S)

	lemma netlimit_filtermap[simp]:
	"at x within X \<noteq> bot \<Longrightarrow> netlimit (filtermap lorenz_S (at x within X)) = lorenz_S (x::R3)"
	apply (rule tendsto_Lim)
	unfolding filterlim_filtermap
	apply simp
	by (auto intro!: tendsto_eq_intros simp: split_beta' lorenz_S_def[abs_def])

	lemma lorenz_S_halfspace [simp]: "lorenz_S ` \<Sigma>\<^sub>l\<^sub>e = \<Sigma>\<^sub>l\<^sub>e"
	apply (auto simp: \<Sigma>\<^sub>l\<^sub>e_def lorenz_S_def[abs_def])
	apply (rule image_eqI)
	apply auto
	apply (rule sym)
	apply (rule minus_minus)
	apply (rule minus_minus[symmetric])
	done

	lemma closure_Sigma_le_eq: "closure \<Sigma>\<^sub>l\<^sub>e = \<Sigma>\<^sub>l\<^sub>e"
	proof (rule closure_closed)
	have "\<Sigma>\<^sub>l\<^sub>e = {x. x \<bullet> (0, 0, 1) \<le> 27}"
	by (auto simp: \<Sigma>\<^sub>l\<^sub>e_def )
	also have "closed \<dots>"
	by (rule closed_halfspace_component_le)
	finally show "closed \<Sigma>\<^sub>l\<^sub>e" .
	qed

	lemma closure_Sigma_le[simp]: "closure (\<Sigma>\<^sub>l\<^sub>e - {x}) = \<Sigma>\<^sub>l\<^sub>e"
	proof (cases "x \<in> \<Sigma>\<^sub>l\<^sub>e")
	case that: True
	have "closure \<Sigma>\<^sub>l\<^sub>e \<subseteq> closure (insert x (\<Sigma>\<^sub>l\<^sub>e - {x}))" by (rule closure_mono) auto
	also have "\<dots> = insert x (closure (\<Sigma>\<^sub>l\<^sub>e - {x}))"
	apply (subst closure_insert) by simp
	also
	have "x \<in> closure (\<Sigma>\<^sub>l\<^sub>e - {x})"
	apply (rule closed_sequentially[where f="\<lambda>n. x - (0, 0, inverse (Suc n))"])
	apply (rule closed_closure)
	subgoal
	- apply (auto simp: ) apply (rule subsetD) apply (rule closure_subset)
	+ apply auto apply (rule subsetD) apply (rule closure_subset)
	using that
	apply (auto simp: \<Sigma>\<^sub>l\<^sub>e_def prod_eq_iff)
	apply (rule order_trans)
	apply (rule diff_right_mono)
	apply (assumption)
	apply simp
	done
	subgoal
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule LIMSEQ_inverse_real_of_nat)
	by (auto simp: prod_eq_iff)
	done
	then have "insert x (closure (\<Sigma>\<^sub>l\<^sub>e - {x})) \<subseteq> closure (\<Sigma>\<^sub>l\<^sub>e - {x})"
	by auto
	finally have "closure \<Sigma>\<^sub>l\<^sub>e \<subseteq> closure (\<Sigma>\<^sub>l\<^sub>e - {x})" .
	moreover
	have "closure (\<Sigma>\<^sub>l\<^sub>e - {x}) \<subseteq> closure (\<Sigma>\<^sub>l\<^sub>e)"
	by (rule closure_mono) auto
	ultimately have "closure (\<Sigma>\<^sub>l\<^sub>e - {x}) = closure (\<Sigma>\<^sub>l\<^sub>e)"
	by simp
	also have "\<dots> = \<Sigma>\<^sub>l\<^sub>e"
	by (rule closure_Sigma_le_eq)
	finally show ?thesis .
	next
	case False
	then show ?thesis
	apply simp
	apply (rule closure_Sigma_le_eq)
	done
	qed

	lemma lorenz_S_return_time_has_derivative:
	assumes "(lorenz.return_time \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	and "lorenz.returns_to \<Sigma> x" and "x \<in> \<Sigma>\<^sub>l\<^sub>e"
	shows "(lorenz.return_time \<Sigma> has_derivative D o lorenz_S) (at (lorenz_S x) within \<Sigma>\<^sub>l\<^sub>e)"
	proof -
	have [simp]: "\<not>trivial_limit (at x within \<Sigma>\<^sub>l\<^sub>e)"
	unfolding at_within_eq_bot_iff
	using assms
	by simp
	interpret bounded_linear "lorenz_S::R3\<Rightarrow>_" by (rule bl_lorenz_S)
	have "\<forall>\<^sub>F x in at x within \<Sigma>\<^sub>l\<^sub>e. (x::R3) returns_to \<Sigma>"
	by (blast intro: lorenz.eventually_returns_to_continuousI has_derivative_continuous assms)
	then have "\<forall>\<^sub>F y in at x within \<Sigma>\<^sub>l\<^sub>e.
	inverse (norm (y - x)) * (lorenz.return_time \<Sigma> y - lorenz.return_time \<Sigma> x - D (y - x))
	= inverse (norm (lorenz_S y - lorenz_S x)) *
	(lorenz.return_time \<Sigma> (lorenz_S y) - lorenz.return_time \<Sigma> (lorenz_S x) - D (y - x))"
	by eventually_elim (auto simp: lorenz_S_return_time assms diff[symmetric])
	then show ?thesis
	using assms
	apply (subst filtermap_lorenz_S_eq[symmetric])
	apply (auto simp: has_derivative_def filterlim_filtermap)
	unfolding o_def
	apply (rule bounded_linear_compose, assumption, rule bl_lorenz_S)
	unfolding diff lorenz_S_idem
	apply (auto simp: Lim_ident_at)
	apply (blast intro: Lim_transform_eventually)
	done
	qed

	lemma lorenz_S_return_time_differentiable:
	"lorenz.return_time \<Sigma> differentiable at (lorenz_S x) within \<Sigma>\<^sub>l\<^sub>e"
	if "lorenz.return_time \<Sigma> differentiable at x within \<Sigma>\<^sub>l\<^sub>e"
	"lorenz.returns_to \<Sigma> x" "x \<in> \<Sigma>\<^sub>l\<^sub>e"
	proof -
	from that obtain D where "(lorenz.return_time \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	by (auto simp: differentiable_def)
	then have "(lorenz.return_time \<Sigma> has_derivative D o lorenz_S) (at (lorenz_S x) within \<Sigma>\<^sub>l\<^sub>e)"
	by (rule lorenz_S_return_time_has_derivative) fact+
	then show ?thesis
	by (auto simp: differentiable_def)
	qed

	lemma lorenz_S_has_derivative:
	"(lorenz_S has_derivative lorenz_S) (at (x::R3) within X)"
	by (auto simp: lorenz_S_def[abs_def] split_beta' intro!: derivative_eq_intros)

	lemma lorenz_S_poincare_map_has_derivative:
	assumes "(lorenz.poincare_map \<Sigma> has_derivative D) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"(lorenz.return_time \<Sigma> has_derivative Dr) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"lorenz.returns_to \<Sigma> x" "x \<in> \<Sigma>\<^sub>l\<^sub>e"
	shows "(lorenz.poincare_map \<Sigma> has_derivative lorenz_S o D o lorenz_S) (at (lorenz_S x) within \<Sigma>\<^sub>l\<^sub>e)"
	proof -
	have [simp]: "\<not>trivial_limit (at x within \<Sigma>\<^sub>l\<^sub>e)"
	unfolding at_within_eq_bot_iff
	using assms
	by simp
	interpret bounded_linear "lorenz_S::R3\<Rightarrow>_" by (rule bl_lorenz_S)
	have "\<forall>\<^sub>F x in at x within \<Sigma>\<^sub>l\<^sub>e. (x::R3) returns_to \<Sigma>"
	by (blast intro: lorenz.eventually_returns_to_continuousI has_derivative_continuous assms)
	then have "\<forall>\<^sub>F y in at x within \<Sigma>\<^sub>l\<^sub>e.
	(lorenz_S (lorenz.poincare_map \<Sigma> y) - lorenz_S (lorenz.poincare_map \<Sigma> x) - lorenz_S (D (y - x))) /\<^sub>R
	norm (y - x)
	= (lorenz.poincare_map \<Sigma> (lorenz_S y) - lorenz.poincare_map \<Sigma> (lorenz_S x) - lorenz_S (D (y - x))) /\<^sub>R
	norm (lorenz_S y - lorenz_S x)"
	by eventually_elim (auto simp: lorenz_S_return_time lorenz_S_poincare_map assms diff[symmetric])
	then show ?thesis
	using has_derivative_compose[OF assms(1) lorenz_S_has_derivative] assms
	apply (subst filtermap_lorenz_S_eq[symmetric])
	apply (auto simp: has_derivative_def filterlim_filtermap)
	unfolding o_def
	apply (rule bounded_linear_compose, rule bl_lorenz_S)
	apply (rule bounded_linear_compose, assumption, rule bl_lorenz_S)
	unfolding diff lorenz_S_idem
	apply (auto simp: Lim_ident_at)
	apply (blast intro: Lim_transform_eventually)
	done
	qed

	lemma [simp]: "expansion (mirror_result res) = expansion res"
	by (cases res) auto

	lemma lorenz_S_on_plane: "lorenz_S (dx, dy, 0::real) = - (dx, dy, 0)"
	by (auto simp: lorenz_S_def )

	lemma mirror_result_idem[simp]: "mirror_result (mirror_result x) = x"
	by (cases x) (auto simp: mirror_result_def)

	lemma mirror_in_set: "x \<in> set results \<Longrightarrow> mirror_result x \<in> set results"
	by (auto simp: results_def symmetrize_def)

	lemma mirror_result_in:
	"mirror_result res2 \<in> return_of_res results (mirror_result res)"
	if "res2 \<in> return_of_res results res"
	proof -
	from that have "res2 \<in> set results" by (rule in_return_of_resD)
	from mirror_in_set[OF this] have "mirror_result res2 \<in> set results" .
	then show ?thesis
	apply (cases res2; cases res)
	using that
	by (auto simp: return_of_res_def get_results_def)
	qed

	lemma in_source_of_res_mirrorI:
	"(x::R3) \<in> source_of_res (mirror_result (r))" if "lorenz_S x \<in> source_of_res r"
	using that
	apply (cases r; cases x)
	by (auto simp: source_of_res_def set_of_ivl_def ivl_of_res_def lorenz_S_def
	less_eq_prod_def ivl_of_resultrect_def)

	lemma conefield_of_res_mirror_simp[simp]: "conefield_of_res (mirror_result res2) = conefield_of_res res2"
	by (cases res2) (auto simp: conefield_of_res_def)

	lemma lorenz_minus_planeI: "lorenz_S (- x) = x" if "snd (snd (x::R3)) = 0"
	using that
	by (auto simp: lorenz_S_def split_beta' prod_eq_iff)

	lemma preexpansion_mirror_result[simp]: "preexpansion (mirror_result res2) = preexpansion res2"
	- by (cases res2) (auto simp: )
	+ by (cases res2) auto

	lemma lorenz_S_tendsto_0I: "(lorenz.flow0 (lorenz_S x) \<longlongrightarrow> 0) at_top"
	if "{0..} \<subseteq> lorenz.existence_ivl0 x" "(lorenz.flow0 x \<longlongrightarrow> 0) at_top"
	proof (rule Lim_transform_eventually)
	have "\<forall>\<^sub>F s in at_top. (s::real) \<ge> 0"
	using eventually_ge_at_top by blast
	then show "\<forall>\<^sub>F s in at_top. lorenz_S (lorenz.flow0 x s) = lorenz.flow0 (lorenz_S x) s"
	by eventually_elim (use that in auto)
	show "((\<lambda>s. lorenz_S (lorenz.flow0 x s)) \<longlongrightarrow> 0) at_top"
	unfolding Zfun_def[symmetric] by (rule bounded_linear.tendsto_zero[OF bl_lorenz_S that(2)])
	qed

	lemma lorenz_S_tendsto_0_iff:
	"(lorenz.flow0 (lorenz_S x) \<longlongrightarrow> 0) at_top \<longleftrightarrow> (lorenz.flow0 x \<longlongrightarrow> 0) at_top"
	if "{0..} \<subseteq> lorenz.existence_ivl0 x"
	using lorenz_S_tendsto_0I[of x, OF that] lorenz_S_tendsto_0I[of "lorenz_S x"] that
	by auto

	lemma lorenz_S_eq_iff[simp]: "lorenz_S y = lorenz_S x \<longleftrightarrow> y = x" for x y::"realrealreal"
	by (auto simp: lorenz_S_def split: prod.splits)

	lemma lorenz_S_\<Gamma>: "lorenz_S x \<in> \<Gamma> \<longleftrightarrow> x \<in> \<Gamma>"
	apply (auto simp: \<Gamma>_def lorenz_S_tendsto_0_iff )
	subgoal for t
	apply (auto simp: dest!: spec[where x=t])
	apply (subst (asm) lorenz_S) apply auto
	apply (subst (asm) (2) lorenz_S_image_Sigma[symmetric])
	by (simp del: lorenz_S_image_Sigma)
	subgoal for t
	apply (auto simp: dest!: spec[where x=t])
	apply (subst (asm) lorenz_S) apply auto
	apply (subst (asm) lorenz_S_image_Sigma[symmetric])
	apply (auto simp del: lorenz_S_image_Sigma)
	done
	done

	lemma sourcei_of_res_mirror: "(x, y, z) \<in> sourcei_of_res (mirror_result res) \<longleftrightarrow>
	(-x, -y, z) \<in> sourcei_of_res res"
	using lorenz_S_\<Gamma>[of "(x, y, z)"]
	by (cases res)
	(auto simp: source_of_res_def sourcei_of_res_def ivl_of_res_def ivl_of_resultrect_def
	set_of_ivl_def \<Gamma>\<^sub>i_def lorenz_S_def)

	lemma c1i_of_res_mirror: "((x, y, z), dx, dy, dz) \<in> c1i_of_res (mirror_result res) \<longleftrightarrow>
	((-x, -y, z), dx, dy, dz) \<in> c1i_of_res res"
	by (auto simp: c1i_of_res_def sourcei_of_res_mirror)

	lemma correct_res_mirror_result:
	"correct_res (mirror_result res)" if "correct_res res"
	unfolding correct_res_def
	proof (clarsimp simp add: c1i_of_res_mirror, goal_cases)
	case (1 x y z dx dy dz)
	then have 1: "(lorenz_S (x, y, z), dx, dy, dz) \<in> c1i_of_res res"
	by (auto simp: lorenz_S_def)
	from that[unfolded correct_res_def, rule_format, OF 1, simplified]
	have "(lorenz_S (x, y, z)) \<in> plane_of (Sctn (0, 0, 1) 27)"
	"(dx, dy, dz) \<in> plane_of (Sctn (0, 0, 1) 0)"
	by auto
	then have plane: "(x, y, z) \<in> plane_of (Sctn (0, 0, 1) 27)"
	"(dx, dy, dz) \<in> plane_of (Sctn (0, 0, 1) 0)"
	by (auto simp: plane_of_def lorenz_S_def)
	then show ?case
	proof (clarsimp, goal_cases)
	case mem: 1
	with that[unfolded correct_res_def, rule_format, OF 1, simplified]
	obtain D res2 where D:
	"lorenz_S (x, y, z) returns_to \<Sigma>"
	"lorenz.return_time \<Sigma> differentiable at (lorenz_S (x, y, z)) within \<Sigma>\<^sub>l\<^sub>e"
	"(lorenz.poincare_map \<Sigma> has_derivative D) (at (lorenz_S (x, y, z)) within \<Sigma>\<^sub>l\<^sub>e)"
	"expansion res * norm (dx, dy, dz) \<le> norm (D (dx, dy, dz))"
	"res2 \<in> return_of_res results res"
	"(lorenz.poincare_map \<Sigma> (lorenz_S (x, y, z)), D (dx, dy, dz)) \<in> c1_of_res res2"
	"preexpansion res2 * norm (dx, dy, dz) \<le> norm (D (dx, dy, dz))"
	by auto
	from plane have S_le: "lorenz_S (x, y, z) \<in> \<Sigma>\<^sub>l\<^sub>e"
	by (auto simp: \<Sigma>\<^sub>l\<^sub>e_def plane_of_def lorenz_S_def)
	interpret linear D by (rule has_derivative_linear; fact)

	have ret: "(x, y, z) returns_to \<Sigma>" using D(1) lorenz_S_returns_to by simp
	moreover have "lorenz.return_time \<Sigma> differentiable at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e"
	using lorenz_S_return_time_differentiable[OF D(2) D(1) S_le] by auto
	moreover from D obtain Dr where Dr: "(lorenz.return_time \<Sigma> has_derivative Dr) (at (lorenz_S (x, y, z)) within \<Sigma>\<^sub>l\<^sub>e)"
	by (auto simp: differentiable_def)
	let ?D = "lorenz_S \<circ> D \<circ> lorenz_S"
	have "(lorenz.poincare_map \<Sigma> has_derivative ?D) (at (x, y, z) within \<Sigma>\<^sub>l\<^sub>e)"
	using lorenz_S_poincare_map_has_derivative[OF D(3) Dr D(1) S_le]
	by auto
	moreover
	from plane have [simp]: "dz = 0" by (auto simp: plane_of_def)
	have "expansion (mirror_result res) * norm (dx, dy, dz) \<le> norm (?D (dx, dy, dz))"
	- using D(4) apply (auto simp: )
	+ using D(4) apply auto
	unfolding lorenz_S_on_plane neg
	by simp
	moreover have \<open>mirror_result res2 \<in> return_of_res results (mirror_result res)\<close>
	using D(5) by (rule mirror_result_in)
	moreover have "(lorenz.poincare_map \<Sigma> (x, y, z), ?D (dx, dy, dz)) \<in> c1_of_res (mirror_result res2)"
	using D(6) apply (subst (asm) lorenz_S_poincare_map)
	apply auto apply fact
	apply (auto simp: c1_of_res_def in_source_of_res_mirrorI)
	unfolding lorenz_S_on_plane neg
	apply (subst lorenz_minus_planeI)
	apply (auto simp: conefield_of_res_def conefield_alt_def cone_hull_expl
	in_segment tangent_of_deg_def)
	done
	moreover have "preexpansion (mirror_result res2) * norm (dx, dy, dz) \<le> norm (?D (dx, dy, dz))"
	- using D(7) apply (auto simp: )
	+ using D(7) apply auto
	unfolding lorenz_S_on_plane neg
	by simp
	ultimately show ?case
	by (force intro!: exI[where x = ?D] bexI[where x="mirror_result res2"])
	qed
	qed

	lemma reduce_lorenz_symmetry: "Ball (set results) correct_res"
	if "Ball (set coarse_results) correct_res"
	using that
	by (auto simp: results_def symmetrize_def intro!: correct_res_mirror_result)

	end

	subsection \<open>Code Generation\<close>

	definition [code_abbrev]: "my_divide_integer (i::integer) (j::integer) = i div j"
	code_printing constant my_divide_integer \<rightharpoonup> (SML) "IntInf.div/ (_,/ _)"

	subsection \<open>Tuning code equations\<close>

	definition mult_twopow_int::"int \<Rightarrow> int \<Rightarrow> int" where "mult_twopow_int x n = x * (power_int 2 n)"
	definition div_twopow_int :: "int \<Rightarrow> int \<Rightarrow> int" where "div_twopow_int x n = x div (power_int 2 n)"

	context includes integer.lifting begin

	lift_definition mult_twopow_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is mult_twopow_int .
	lift_definition div_twopow_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" is div_twopow_int .

	end

	lemma compute_float_round_down[code]:
	"float_round_down prec (Float m e) =
	(let d = bitlen \<bar>m\<bar> - int prec - 1 in
	if 0 < d then Float (div_twopow_int m d) (e + d)
	else Float m e)"
	including float.lifting
	using Float.compute_float_down[of "Suc prec - bitlen \<bar>m\<bar> - e" m e, symmetric]
	by transfer
	(auto simp add: field_simps abs_mult log_mult bitlen_alt_def truncate_down_def
	div_twopow_int_def power_int_def
	cong del: if_weak_cong)

	lemma compute_float_plus_down[code]:
	fixes p::nat and m1 e1 m2 e2::int
	shows "float_plus_down p (Float m1 e1) (Float m2 e2) =
	(if m1 = 0 then float_round_down p (Float m2 e2)
	else if m2 = 0 then float_round_down p (Float m1 e1)
	else
	(if e1 \<ge> e2 then
	(let k1 = Suc p - nat (bitlen \<bar>m1\<bar>) in
	if bitlen \<bar>m2\<bar> > e1 - e2 - k1 - 2
	then float_round_down p ((Float m1 e1) + (Float m2 e2))
	else float_round_down p (Float (mult_twopow_int m1 (int k1 + 2) + sgn m2) (e1 - int k1 - 2)))
	else float_plus_down p (Float m2 e2) (Float m1 e1)))"
	using Float.compute_float_plus_down[of p m1 e1 m2 e2]
	by (auto simp: mult_twopow_int_def Let_def power_int_def nat_add_distrib)

	subsection \<open>Codegen\<close>

	definition "is_dRETURN_True x = (case x of dRETURN b \<Rightarrow> b \| _ \<Rightarrow> False)"
	definition "file_output_option s f =
	(case s of None \<Rightarrow> f None
	\| Some s \<Rightarrow> file_output (String.implode s) (\<lambda>pf. f (Some pf)))"

	definition "check_line_lookup_out s m0 n0 c1 i =
	is_dRETURN_True (file_output_option s (\<lambda>pf. check_line_core_impl pf m0 n0 c1 i))"

	fun alternating where "alternating [] xs = xs"
	\| "alternating xs [] = xs"
	\| "alternating (x#xs) (y#ys) = x#y#alternating xs ys"

	definition "ordered_lines = alternating (rev [0..<222]) ([222..<400])"
	\<comment> \<open>the hard ones ``first'', potentially useless due to nondeterministic \<open>Parallel.map\<close>\<close>

	definition "parallel_check filenameo m n c1 ns =
	Parallel.forall (\<lambda>i.
	let
	_ = print (String.implode (''# Starting '' @ show i @ ''\<newline>''));
	b =
	check_line_lookup_out (map_option (\<lambda>f. f @ show i) filenameo)
	(Some m) (Some n) c1 i;
	_ = if b
	then print (String.implode (''# Success: '' @ show i @ ''\<newline>''))
	else print (String.implode (''# Failed: '' @ show i @ ''\<newline>''))
	in b
	) ns"

	ML \<open>val check_line = @{computation_check
	terms:
	Trueprop
	parallel_check
	ordered_lines
	check_line_core_impl
	check_line_lookup_out

	(* bool *)
	True False

	(* num *)
	Num.One Num.Bit0 Num.Bit1

	(* nat *)
	Suc "0::nat" "1::nat" "numeral::num\<Rightarrow>nat"

	(* int / integer*)
	"numeral::num\<Rightarrow>int"
	"numeral::num\<Rightarrow>integer"
	"uminus::_\<Rightarrow>int"
	"uminus::_\<Rightarrow>integer"
	int_of_integer integer_of_int
	"0::int"
	"1::int"

	(* Pairs *)
	"Pair::_ \<Rightarrow> _\<Rightarrow> (real list \<times> real list)"
	"Pair::_\<Rightarrow>_\<Rightarrow>(real list \<times> real list) \<times> real list sctn"
	"Pair::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options"

	(* Option *)
	"None::nat option"
	"Some::_\<Rightarrow>nat option"
	"None::string option"
	"Some::_\<Rightarrow>string option"

	(* Lists *)
	"Nil::real list"
	"Cons::_\<Rightarrow>_\<Rightarrow>real list"
	"Nil::nat list"
	"Cons::_\<Rightarrow>_\<Rightarrow>nat list"
	"Nil::real aform list"
	"Cons::_\<Rightarrow>_\<Rightarrow>real aform list"
	"Nil::((real list \<times> real list) \<times> real list sctn) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list"
	"Nil::(((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options)list"
	"Cons::_\<Rightarrow>_\<Rightarrow>(((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options)list"

	(* String *)
	String.Char
	String.implode "Cons::char \<Rightarrow> char list \<Rightarrow> char list" "Nil::char list"

	(* float *)
	Float float_of_int float_of_nat

	(* real *)
	"numeral::num\<Rightarrow>real" "real_of_float" "(/)::real\<Rightarrow>real\<Rightarrow>real" "uminus::real\<Rightarrow>_"
	real_divl real_divr
	real_of_int

	(* section *)
	"Sctn::_\<Rightarrow>_\<Rightarrow>real list sctn"

	(* aform *)
	"aforms_of_ivls::_\<Rightarrow>_\<Rightarrow>real aform list"

	(* input *)
	coarse_results

	(* modes *)
	xsec xsec' ysec ysec' zsec zsec' zbucket
	lookup_mode
	ro
	ro_outer
	mode_outer

	(* unit *)
	"()"

	}\<close>


	lemma is_dRETURN_True_iff[simp]: "is_dRETURN_True x \<longleftrightarrow> (x = dRETURN True)"
	by (auto simp: is_dRETURN_True_def split: dres.splits)

	lemma check_line_core_impl_True:
	"check_line_core_impl pfo m n True i = dRETURN True \<Longrightarrow> NF \<Longrightarrow> correct_res (results ! i)"
	apply (cases "check_line_core_impl pfo m n True i")
	using check_line_core_correct[of pfo m n i]
	check_line_core_impl.refine[of pfo pfo True True i i m m n n]
	apply (auto simp: nres_rel_def)
	apply (drule order_trans[where y="check_line_core pfo m n True i"])
	apply assumption
	by auto

	lemma check_line_lookup_out: "correct_res (results ! i)"
	if "\<exists>s m n. check_line_lookup_out s m n True i" NF
	using that
	by (auto simp: check_line_lookup_out_def file_output_iff check_line_core_impl_True
	file_output_option_def split: dres.splits option.splits)

	definition "check_lines c1 ns = list_all (\<lambda>i. \<exists>s m n. check_line_lookup_out s m n c1 i) ns"

	lemma check_linesI:
	"check_lines c1 ns"
	if "parallel_check s m n c1 ns"
	using that
	by (auto simp: parallel_check_def check_lines_def list_all_iff)

	subsection \<open>Automate generation of lemmas\<close>

	lemma length_coarse_results[simp]: "length coarse_results = 400"
	by (simp add: coarse_results_def)

	lemma correct_res_coarse_resultsI:
	"correct_res (results ! i) \<Longrightarrow> i < 400 \<Longrightarrow> correct_res (coarse_results ! i)"
	by (auto simp: results_def symmetrize_def nth_append)

	lemma Ball_coarseI: "Ball (set coarse_results) correct_res"
	if NF "check_lines True xs" "set xs = {..<400}"
	using that
	by (force simp: check_lines_def list_all_iff in_set_conv_nth
	intro!: correct_res_coarse_resultsI check_line_lookup_out)

	ML \<open>map_option (using_master_directory_term @{context}) (SOME "a")\<close>
	ML \<open>
	fun mk_optionT ty = Type (@{type_name "option"}, [ty])
	fun mk_None ty = Const (@{const_name "None"}, mk_optionT ty)
	fun mk_Some ty x = Const (@{const_name "Some"}, ty --> mk_optionT ty) $ x
	fun mk_option ty _ NONE = mk_None ty
	\| mk_option ty f (SOME x) = mk_Some ty (f x)
	fun check_lines_tac' s m n ctxt =
	resolve_tac ctxt
	[Thm.instantiate (TVars.empty,
	Vars.make ([
	("s", @{typ "string option"}, mk_option @{typ string} (using_master_directory_term ctxt) s),
	("m", @{typ nat}, HOLogic.mk_nat m),
	("n", @{typ nat}, HOLogic.mk_nat n)]
	\|> map (fn (s, ty, t) => (((s, 0), ty), Thm.cterm_of ctxt t))))
	@{thm check_linesI}]
	THEN' CONVERSION (check_line ctxt)
	THEN' resolve_tac ctxt @{thms TrueI}
	\<close>

	method_setup parallel_check = \<open>
	Scan.lift (Parse.maybe Parse.string) -- Scan.lift Parse.nat -- Scan.lift Parse.nat
	>> (fn ((s, m), n) => fn ctxt => SIMPLE_METHOD' (check_lines_tac' s m n ctxt))
	\<close>

	lemma lorenz_bounds_lemma_asym:
	"\<forall>x \<in> N - \<Gamma>. x returns_to \<Sigma>"
	"R ` (N - \<Gamma>) \<subseteq> N"
	"\<forall>x \<in> N - \<Gamma>. (R has_derivative DR x) (at x within \<Sigma>\<^sub>l\<^sub>e)"
	"\<forall>x \<in> N - \<Gamma>. DR x ` \<CC> x \<subseteq> \<CC> (R x)"
	"\<forall>x \<in> N - \<Gamma>. \<forall>c \<in> \<CC> x. norm (DR x c) \<ge> \<E> x * norm c"
	"\<forall>x \<in> N - \<Gamma>. \<forall>c \<in> \<CC> x. norm (DR x c) \<ge> \<E>\<^sub>p (R x) * norm c"
	if NF "Ball (set results) correct_res"
	using that
	by (auto intro!: lorenz_bounds_lemma)

	end
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Cones.thy b/thys/Ordinary_Differential_Equations/IVP/Cones.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Cones.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Cones.thy
	@@ -1,694 +1,694 @@
	theory Cones
	imports
	"HOL-Analysis.Analysis"
	Triangle.Triangle
	"../ODE_Auxiliarities"
	begin

	lemma arcsin_eq_zero_iff[simp]: "-1 \<le> x \<Longrightarrow> x \<le> 1 \<Longrightarrow> arcsin x = 0 \<longleftrightarrow> x = 0"
	using sin_arcsin by fastforce

	definition conemem :: "'a::real_vector \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a" where "conemem u v t = cos t \<^sub>R u + sin t \<^sub>R v"
	definition "conesegment u v = conemem u v ` {0.. pi / 2}"

	lemma
	bounded_linear_image_conemem:
	assumes "bounded_linear F"
	shows "F (conemem u v t) = conemem (F u) (F v) t"
	proof -
	from assms interpret bounded_linear F .
	show ?thesis
	by (auto simp: conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
	qed

	lemma
	bounded_linear_image_conesegment:
	assumes "bounded_linear F"
	shows "F ` conesegment u v = conesegment (F u) (F v)"
	proof -
	from assms interpret bounded_linear F .
	show ?thesis
	apply (auto simp: conesegment_def conemem_def[abs_def] cone_hull_expl closed_segment_def add scaleR)
	apply (auto simp: add[symmetric] scaleR[symmetric])
	done
	qed

	(* This is vangle in $AFP/Triangles/Angles *)

	lemma discriminant: "a * x\<^sup>2 + b * x + c = (0::real) \<Longrightarrow> 0 \<le> b\<^sup>2 - 4 * a * c"
	by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [2ax + b]^2))))")

	lemma quadratic_eq_factoring:
	assumes D: "D = b\<^sup>2 - 4 * a * c"
	assumes nn: "0 \<le> D"
	assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
	assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
	assumes a: "a \<noteq> 0"
	shows "a * x\<^sup>2 + b * x + c = a * (x - x\<^sub>1) * (x - x\<^sub>2)"
	using nn
	by (simp add: D x1 x2)
	(simp add: assms algebra_simps power2_eq_square power3_eq_cube divide_simps)

	lemma quadratic_eq_zeroes_iff:
	assumes D: "D = b\<^sup>2 - 4 * a * c"
	assumes x1: "x\<^sub>1 = (-b + sqrt D) / (2 * a)"
	assumes x2: "x\<^sub>2 = (-b - sqrt D) / (2 * a)"
	assumes a: "a \<noteq> 0"
	shows "a * x\<^sup>2 + b * x + c = 0 \<longleftrightarrow> (D \<ge> 0 \<and> (x = x\<^sub>1 \<or> x = x\<^sub>2))" (is "?z \<longleftrightarrow> _")
	using quadratic_eq_factoring[OF D _ x1 x2 a, of x] discriminant[of a x b c] a
	by (auto simp: D)

	lemma quadratic_ex_zero_iff:
	"(\<exists>x. a * x\<^sup>2 + b * x + c = 0) \<longleftrightarrow> (a \<noteq> 0 \<and> b\<^sup>2 - 4 * a * c \<ge> 0 \<or> a = 0 \<and> (b = 0 \<longrightarrow> c = 0))"
	for a b c::real
	apply (cases "a = 0")
	subgoal by (auto simp: intro: exI[where x="- c / b"])
	subgoal by (subst quadratic_eq_zeroes_iff[OF refl refl refl]) auto
	done

	lemma Cauchy_Schwarz_eq_iff:
	shows "(inner x y)\<^sup>2 = inner x x * inner y y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
	proof safe
	assume eq: "(x \<bullet> y)\<^sup>2 = x \<bullet> x * (y \<bullet> y)" and "y \<noteq> 0"
	define f where "f \<equiv> \<lambda>l. inner (x - l \<^sub>R y) (x - l \<^sub>R y)"
	have f_quadratic: "f l = inner y y * l\<^sup>2 + - 2 * inner x y * l + inner x x" for l
	by (auto simp: f_def algebra_simps power2_eq_square inner_commute)
	have "\<exists>l. f l = 0"
	unfolding f_quadratic quadratic_ex_zero_iff
	using \<open>y \<noteq> 0\<close>
	by (auto simp: eq)
	then show "(\<exists>k. x = k *\<^sub>R y)"
	by (auto simp: f_def)
	qed (auto simp: power2_eq_square)

	lemma Cauchy_Schwarz_strict_ineq:
	"(inner x y)\<^sup>2 < inner x x * inner y y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
	apply (rule neq_le_trans)
	subgoal
	using that
	unfolding Cauchy_Schwarz_eq_iff
	by auto
	subgoal by (rule Cauchy_Schwarz_ineq)
	done

	lemma Cauchy_Schwarz_eq2_iff:
	"\<bar>inner x y\<bar> = norm x * norm y \<longleftrightarrow> ((\<exists>k. x = k *\<^sub>R y) \<or> y = 0)"
	using Cauchy_Schwarz_eq_iff[of x y]
	by (subst power_eq_iff_eq_base[symmetric, where n = 2])
	(simp_all add: dot_square_norm power_mult_distrib)

	lemma Cauchy_Schwarz_strict_ineq2:
	"\<bar>inner x y\<bar> < norm x * norm y" if "y \<noteq> 0" "\<And>k. x \<noteq> k *\<^sub>R y"
	apply (rule neq_le_trans)
	subgoal
	using that
	unfolding Cauchy_Schwarz_eq2_iff
	by auto
	subgoal by (rule Cauchy_Schwarz_ineq2)
	done

	lemma gt_minus_one_absI: "abs k < 1 \<Longrightarrow> - 1 < k" for k::real
	by auto
	lemma gt_one_absI: "abs k < 1 \<Longrightarrow> k < 1" for k::real
	by auto

	lemma abs_impossible:
	"\<bar>y1\<bar> < x1 \<Longrightarrow> \<bar>y2\<bar> < x2 \<Longrightarrow> x1 * x2 + y1 * y2 \<noteq> 0" for x1 x2::real
	proof goal_cases
	case 1
	have "- y1 * y2 \<le> abs y1 * abs y2"
	by (metis abs_ge_minus_self abs_mult mult.commute mult_minus_right)
	also have "\<dots> < x1 * x2"
	apply (rule mult_strict_mono)
	using 1 by auto
	finally show ?case by auto
	qed

	lemma vangle_eq_arctan_minus:\<comment> \<open>TODO: generalize?!\<close>
	assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
	assumes xy1: "\<bar>y1\<bar> < x1"
	assumes xy2: "\<bar>y2\<bar> < x2"
	assumes less: "y2 / x2 > y1 / x1"
	shows "vangle (x1 \<^sub>R i + y1 \<^sub>R j) (x2 \<^sub>R i + y2 \<^sub>R j) = arctan (y2 / x2) - arctan (y1 / x1)"
	(is "vangle ?u ?v = _")
	proof -
	from assms have less2: "x2 * y1 - x1 * y2 < 0"
	by (auto simp: divide_simps abs_real_def algebra_simps split: if_splits)
	have norm_eucl: "norm (x \<^sub>R i + y \<^sub>R j) = sqrt ((norm x)\<^sup>2 + (norm y)\<^sup>2)" for x y
	apply (subst norm_eq_sqrt_inner)
	using ij ij_neq
	by (auto simp: inner_simps inner_Basis power2_eq_square)
	have nonzeroes: "x1 \<^sub>R i + y1 \<^sub>R j \<noteq> 0" "x2 \<^sub>R i + y2 \<^sub>R j \<noteq> 0"
	apply (auto simp: euclidean_eq_iff[where 'a='a] inner_simps intro!: bexI[where x=i])
	using assms
	by (auto simp: inner_Basis)
	have indep: "x1 \<^sub>R i + y1 \<^sub>R j \<noteq> k \<^sub>R (x2 \<^sub>R i + y2 *\<^sub>R j)" for k
	proof
	assume "x1 \<^sub>R i + y1 \<^sub>R j = k \<^sub>R (x2 \<^sub>R i + y2 *\<^sub>R j)"
	then have "x1 / x2 = k" "y1 = k * y2"
	using ij ij_neq xy1 xy2
	apply (auto simp: abs_real_def divide_simps algebra_simps euclidean_eq_iff[where 'a='a] inner_simps
	split: if_splits)
	by (auto simp: inner_Basis split: if_splits)
	then have "y1 = x1 / x2 * y2" by simp
	with less show False using xy1 by (auto split: if_splits)
	qed
	have "((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
	(1 - ((x1 \<^sub>R i + y1 \<^sub>R j) \<bullet> (x2 \<^sub>R i + y2 \<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
	((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
	(1 - (x1 * x2 + y1 * y2)\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2))))"
	using ij_neq ij
	by (auto simp: algebra_simps divide_simps inner_simps inner_Basis)
	also have "\<dots> = (x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) - (x1 * x2 + y1 * y2)\<^sup>2"
	unfolding right_diff_distrib by simp
	also have "\<dots> = (x2 * y1 - x1 * y2)^2"
	by (auto simp: algebra_simps power2_eq_square)
	also have "sqrt \<dots> = \<bar>x2 * y1 - x1 * y2\<bar>"
	by simp
	also have "\<dots> = x1 * y2 - x2 * y1"
	using less2
	by (simp add: abs_real_def)
	finally have sqrt_eq: "sqrt ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2) *
	(1 - ((x1 \<^sub>R i + y1 \<^sub>R j) \<bullet> (x2 \<^sub>R i + y2 \<^sub>R j))\<^sup>2 / ((x1\<^sup>2 + y1\<^sup>2) * (x2\<^sup>2 + y2\<^sup>2)))) =
	x1 * y2 - x2 * y1"
	.
	show ?thesis
	using ij xy1 xy2
	unfolding vangle_def
	apply (subst arccos_arctan)
	subgoal
	apply (rule gt_minus_one_absI)
	- apply (simp add: )
	+ apply simp
	apply (subst pos_divide_less_eq)
	subgoal
	apply (rule mult_pos_pos)
	using nonzeroes
	by auto
	subgoal
	apply simp
	apply (rule Cauchy_Schwarz_strict_ineq2)
	using nonzeroes indep
	by auto
	done
	subgoal
	apply (rule gt_one_absI)
	- apply (simp add: )
	+ apply simp
	apply (subst pos_divide_less_eq)
	subgoal
	apply (rule mult_pos_pos)
	using nonzeroes
	by auto
	subgoal
	apply simp
	apply (rule Cauchy_Schwarz_strict_ineq2)
	using nonzeroes indep
	by auto
	done
	subgoal
	apply (auto simp: nonzeroes)
	apply (subst (3) diff_conv_add_uminus)
	apply (subst arctan_minus[symmetric])
	apply (subst arctan_add)
	apply force
	apply force
	apply (subst arctan_inverse[symmetric])
	subgoal
	apply (rule divide_pos_pos)
	subgoal
	apply (auto simp add: inner_simps inner_Basis algebra_simps )
	apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j = i")
	apply (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + ((A<=0 * (A<0 * (A<2 * R<1))) * (R<1 * [1]^2))))")
	apply (thin_tac "_ \<in> Basis")+ apply (thin_tac "j \<noteq> i")
	by (sos "((((A<0 * (A<1 * (A<2 * A<3))) * R<1) + (((A<2 * (A<3 * R<1)) * (R<1/3 * [y1]^2)) + (((A<1 * (A<3 * R<1)) * ((R<1/12 * [x2 + y1]^2) + (R<1/12 * [x1 + y2]^2))) + (((A<1 * (A<2 * R<1)) * (R<1/12 * [~1x1 + x2 + y1 + y2]^2)) + (((A<0 (A<3 * R<1)) * (R<1/12 * [~1x1 + x2 + ~1y1 + ~1y2]^2)) + (((A<0 (A<2 * R<1)) * ((R<1/12 * [x2 + ~1y1]^2) + (R<1/12 [~1x1 + y2]^2))) + (((A<0 (A<1 * R<1)) * (R<1/3 * [y2]^2)) + ((A<=0 * R<1) * (R<1/3 * [x1 + x2]^2))))))))))")
	subgoal
	apply (intro mult_pos_pos)
	using nonzeroes indep
	apply auto
	apply (rule gt_one_absI)
	apply (simp add: power_divide power_mult_distrib power2_norm_eq_inner)
	apply (rule Cauchy_Schwarz_strict_ineq)
	apply auto
	done
	done
	subgoal
	apply (rule arg_cong[where f=arctan])
	using nonzeroes ij_neq
	apply (auto simp: norm_eucl)
	apply (subst real_sqrt_mult[symmetric])
	apply (subst real_sqrt_mult[symmetric])
	apply (subst real_sqrt_mult[symmetric])
	apply (subst power_divide)
	apply (subst real_sqrt_pow2)
	apply simp
	apply (subst nonzero_divide_eq_eq)
	subgoal
	apply (auto simp: algebra_simps inner_simps inner_Basis)
	by (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
	apply (subst sqrt_eq)
	apply (auto simp: algebra_simps inner_simps inner_Basis)
	apply (auto simp: algebra_simps divide_simps abs_real_def abs_impossible)
	by (auto split: if_splits)
	done
	done
	qed

	lemma vangle_le_pi2: "0 \<le> u \<bullet> v \<Longrightarrow> vangle u v \<le> pi/2"
	unfolding vangle_def atLeastAtMost_iff
	apply (simp del: le_divide_eq_numeral1)
	apply (intro impI arccos_le_pi2 arccos_lbound)
	using Cauchy_Schwarz_ineq2[of u v]
	by (auto simp: algebra_simps)

	lemma inner_eq_vangle: "u \<bullet> v = cos (vangle u v) * (norm u * norm v)"
	by (simp add: cos_vangle)

	lemma vangle_scaleR_self:
	"vangle (k *\<^sub>R v) v = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
	"vangle v (k *\<^sub>R v) = (if k = 0 \<or> v = 0 then pi / 2 else if k > 0 then 0 else pi)"
	by (auto simp: vangle_def dot_square_norm power2_eq_square)

	lemma vangle_scaleR:
	"vangle (k \<^sub>R v) w = vangle v w" "vangle w (k \<^sub>R v) = vangle w v" if "k > 0"
	using that
	by (auto simp: vangle_def)

	lemma cos_vangle_eq_zero_iff_vangle:
	"cos (vangle u v) = 0 \<longleftrightarrow> (u = 0 \<or> v = 0 \<or> u \<bullet> v = 0)"
	using Cauchy_Schwarz_ineq2[of u v]
	by (auto simp: vangle_def divide_simps algebra_split_simps split: if_splits)

	lemma ortho_imp_angle_pi_half: "u \<bullet> v = 0 \<Longrightarrow> vangle u v = pi / 2"
	using orthogonal_iff_vangle[of u v]
	by (auto simp: orthogonal_def)

	lemma arccos_eq_zero_iff: "arccos x = 0 \<longleftrightarrow> x = 1" if "-1 \<le> x" "x \<le> 1"
	using that
	apply auto
	using cos_arccos by fastforce


	lemma vangle_eq_zeroD: "vangle u v = 0 \<Longrightarrow> (\<exists>k. v = k *\<^sub>R u)"
	apply (auto simp: vangle_def split: if_splits)
	apply (subst (asm) arccos_eq_zero_iff)
	apply (auto simp: divide_simps mult_less_0_iff split: if_splits)
	apply (metis Real_Vector_Spaces.norm_minus_cancel inner_minus_left minus_le_iff norm_cauchy_schwarz)
	apply (metis norm_cauchy_schwarz)
	by (metis Cauchy_Schwarz_eq2_iff abs_of_pos inner_commute mult.commute mult_sign_intros(5) zero_less_norm_iff)

	lemma less_one_multI:\<comment> \<open>TODO: also in AA!\<close>
	fixes e x::real
	shows "e \<le> 1 \<Longrightarrow> 0 < x \<Longrightarrow> x < 1 \<Longrightarrow> e * x < 1"
	by (metis (erased, opaque_lifting) less_eq_real_def monoid_mult_class.mult.left_neutral
	mult_strict_mono zero_less_one)

	lemma conemem_expansion_estimate:
	fixes u v u' v'::"'a::euclidean_space"
	assumes "t \<in> {0 .. pi / 2}"
	assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
	assumes angle_le: "(vangle u' v') \<le> (vangle u v)"
	assumes "norm u = 1" "norm v = 1"
	shows "norm (conemem u' v' t) \<ge> min (norm u') (norm v') * norm (conemem u v t)"
	proof -
	define e_pre where "e_pre = min (norm u') (norm v')"
	let ?w = "conemem u v"
	let ?w' = "conemem u' v'"
	have cos_angle_le: "cos (vangle u' v') \<ge> cos (vangle u v)"
	using angle_pos vangle_bounds
	by (auto intro!: cos_monotone_0_pi_le angle_le)
	have e_pre_le: "e_pre\<^sup>2 \<le> norm u' * norm v'"
	by (auto simp: e_pre_def min_def power2_eq_square intro: mult_left_mono mult_right_mono)
	have lt: "0 < 1 + 2 * (u \<bullet> v) * sin t * cos t"
	proof -
	have "\<bar>u \<bullet> v\<bar> < norm u * norm v"
	apply (rule Cauchy_Schwarz_strict_ineq2)
	using assms
	apply auto
	apply (subst (asm) vangle_scaleR_self)+
	by (auto simp: split: if_splits)
	then have "abs (u \<bullet> v * sin (2 * t)) < 1"
	using assms
	apply (auto simp add: abs_mult)
	apply (subst mult.commute)
	apply (rule less_one_multI)
	apply (auto simp add: abs_mult inner_eq_vangle )
	by (auto simp: cos_vangle_eq_zero_iff_vangle dest!: ortho_imp_angle_pi_half)
	then show ?thesis
	by (subst mult.assoc sin_times_cos)+ auto
	qed
	have le: "0 \<le> 1 + 2 * (u \<bullet> v) * sin t * cos t"
	proof -
	have "\<bar>u \<bullet> v\<bar> \<le> norm u * norm v"
	by (rule Cauchy_Schwarz_ineq2)
	then have "abs (u \<bullet> v * sin (2 * t)) \<le> 1"
	by (auto simp add: abs_mult assms intro!: mult_le_one)
	then show ?thesis
	by (subst mult.assoc sin_times_cos)+ auto
	qed
	have "(norm (?w t))\<^sup>2 = (cos t)\<^sup>2 \<^sub>R (norm u)\<^sup>2 + (sin t)\<^sup>2 \<^sub>R (norm v)\<^sup>2 + 2 * (u \<bullet> v) * sin t * cos t"
	by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
	(auto simp: power2_eq_square inner_commute)
	also have "\<dots> = 1 + 2 * (u \<bullet> v) * sin t * cos t"
	by (auto simp: sin_squared_eq algebra_simps assms)
	finally have "(norm (conemem u v t))\<^sup>2 = 1 + 2 * (u \<bullet> v) * sin t * cos t" by simp
	moreover
	have "(norm (?w' t))\<^sup>2 = (cos t)\<^sup>2 \<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 \<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t"
	by (auto simp: conemem_def algebra_simps power2_norm_eq_inner)
	(auto simp: power2_eq_square inner_commute)
	ultimately
	have "(norm (?w' t) / norm (?w t))\<^sup>2 =
	((cos t)\<^sup>2 \<^sub>R (norm u')\<^sup>2 + (sin t)\<^sup>2 \<^sub>R (norm v')\<^sup>2 + 2 * (u' \<bullet> v') * sin t * cos t) /
	(1 + 2 * (u \<bullet> v) * sin t * cos t)"
	(is "_ = (?a + ?b) / ?c")
	by (auto simp: divide_inverse power_mult_distrib) (auto simp: inverse_eq_divide power2_eq_square)
	also have "\<dots> \<ge> (e_pre\<^sup>2 + ?b) / ?c"
	apply (rule divide_right_mono)
	apply (rule add_right_mono)
	subgoal using assms e_pre_def
	apply (auto simp: min_def)
	subgoal by (auto simp: algebra_simps cos_squared_eq intro!: mult_right_mono power_mono)
	subgoal by (auto simp: algebra_simps sin_squared_eq intro!: mult_right_mono power_mono)
	done
	subgoal by (rule le)
	done
	also (xtrans)
	have inner_nonneg: "u' \<bullet> v' \<ge> 0"
	using angle_le(1) angle_pos vangle_bounds[of u' v']
	by (auto simp: inner_eq_vangle intro!: mult_nonneg_nonneg cos_ge_zero)
	from vangle_bounds[of u' v'] vangle_le_pi2[OF this]
	have u'v'e_pre: "u' \<bullet> v' \<ge> cos (vangle u' v') * e_pre\<^sup>2"
	apply (subst inner_eq_vangle)
	apply (rule mult_left_mono)
	apply (rule e_pre_le)
	apply (rule cos_ge_zero)
	by auto
	have "(e_pre\<^sup>2 + ?b) / ?c \<ge> (e_pre\<^sup>2 + 2 * (cos (vangle u' v') * e_pre\<^sup>2) * sin t * cos t) / ?c"
	(is "_ \<ge> ?ddd")
	apply (intro divide_right_mono add_left_mono mult_right_mono mult_left_mono u'v'e_pre)
	using \<open>t \<in> _\<close>
	by (auto intro!: mult_right_mono sin_ge_zero divide_right_mono le cos_ge_zero
	simp: sin_times_cos u'v'e_pre)
	also (xtrans) have "?ddd = e_pre\<^sup>2 * ((1 + 2 * cos (vangle u' v') * sin t * cos t) / ?c)" (is "_ = ?ddd")
	by (auto simp add: divide_simps algebra_simps)
	also (xtrans)
	have sc_ge_0: "0 \<le> sin t * cos t"
	using \<open>t \<in> _\<close>
	by (auto simp: assms cos_angle_le intro!: mult_nonneg_nonneg sin_ge_zero cos_ge_zero)
	have "?ddd \<ge> e_pre\<^sup>2"
	apply (subst mult_le_cancel_left1)
	apply (auto simp add: divide_simps split: if_splits)
	apply (rule mult_right_mono)
	using lt
	by (auto simp: assms inner_eq_vangle intro!: mult_right_mono sc_ge_0 cos_angle_le)
	finally (xtrans)
	have "(norm (conemem u' v' t))\<^sup>2 \<ge> (e_pre * norm (conemem u v t))\<^sup>2"
	by (simp add: divide_simps power_mult_distrib split: if_splits)
	then show "norm (conemem u' v' t) \<ge> e_pre * norm (conemem u v t)"
	using norm_imp_pos_and_ge power2_le_imp_le by blast
	qed

	lemma conemem_commute: "conemem a b t = conemem b a (pi / 2 - t)" if "0 \<le> t" "t \<le> pi / 2"
	using that by (auto simp: conemem_def cos_sin_eq algebra_simps)

	lemma conesegment_commute: "conesegment a b = conesegment b a"
	apply (auto simp: conesegment_def )
	apply (subst conemem_commute)
	apply auto
	apply (subst conemem_commute)
	apply auto
	done


	definition "conefield u v = cone hull (conesegment u v)"

	lemma conefield_alt_def: "conefield u v = cone hull {u--v}"
	apply (auto simp: conesegment_def conefield_def cone_hull_expl in_segment)
	subgoal premises prems for c t
	proof -
	from prems
	have sc_pos: "sin t + cos t > 0"
	apply (cases "t = 0")
	subgoal
	by (rule add_nonneg_pos) auto
	subgoal
	by (auto intro!: add_pos_nonneg sin_gt_zero cos_ge_zero)
	done
	then have 1: "(sin t / (sin t + cos t) + cos t / (sin t + cos t)) = 1"
	by (auto simp: divide_simps)
	have "\<exists>c x. c > 0 \<and> 0 \<le> x \<and> x \<le> 1 \<and> c \<^sub>R conemem u v t = (1 - x) \<^sub>R u + x *\<^sub>R v"
	apply (auto simp: algebra_simps conemem_def)
	apply (rule exI[where x="1 / (sin t + cos t)"])
	using prems
	by (auto intro!: exI[where x="(1 / (sin t + cos t) * sin t)"] sc_pos
	divide_nonneg_nonneg sin_ge_zero add_nonneg_nonneg cos_ge_zero
	simp: scaleR_add_left[symmetric] 1 divide_le_eq_1)
	then obtain d x where dx: "d > 0" "conemem u v t = (1 / d) \<^sub>R ((1 - x) \<^sub>R u + x *\<^sub>R v)"
	"0 \<le> x" "x \<le> 1"
	by (auto simp: eq_vector_fraction_iff)
	show ?thesis
	apply (rule exI[where x="c / d"])
	using dx
	by (auto simp: intro!: divide_nonneg_nonneg prems )
	qed
	subgoal premises prems for c t
	proof -
	let ?x = "arctan (t / (1 - t))"
	let ?s = "t / sin ?x"
	have : "c \<^sub>R ((1 - t) \<^sub>R u + t \<^sub>R v) = (c * ?s) \<^sub>R (cos ?x \<^sub>R u + sin ?x *\<^sub>R v)"
	if "0 < t" "t < 1"
	using that
	by (auto simp: scaleR_add_right sin_arctan cos_arctan divide_simps)
	show ?thesis
	apply (cases "t = 0")
	subgoal
	apply simp
	apply (rule exI[where x=c])
	apply (rule exI[where x=u])
	using prems
	by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x=0])
	subgoal apply (cases "t = 1")
	subgoal
	apply simp
	apply (rule exI[where x=c])
	apply (rule exI[where x=v])
	using prems
	by (auto simp: conemem_def[abs_def] intro!: image_eqI[where x="pi/2"])
	subgoal
	apply (rule exI[where x="(c * ?s)"])
	apply (rule exI[where x="(cos ?x \<^sub>R u + sin ?x \<^sub>R v)"])
	using prems * arctan_ubound[of "t / (1 - t)"]
	apply (auto simp: conemem_def[abs_def] intro!: imageI)
	by (auto simp: scaleR_add_right sin_arctan)
	done
	done
	qed
	done

	lemma
	bounded_linear_image_cone_hull:
	assumes "bounded_linear F"
	shows "F ` (cone hull T) = cone hull (F ` T)"
	proof -
	from assms interpret bounded_linear F .
	show ?thesis
	apply (auto simp: conefield_def cone_hull_expl closed_segment_def add scaleR)
	- apply (auto simp: )
	+ apply auto
	apply (auto simp: add[symmetric] scaleR[symmetric])
	done
	qed

	lemma
	bounded_linear_image_conefield:
	assumes "bounded_linear F"
	shows "F ` conefield u v = conefield (F u) (F v)"
	unfolding conefield_def
	using assms
	by (auto simp: bounded_linear_image_conesegment bounded_linear_image_cone_hull)

	lemma conefield_commute: "conefield x y = conefield y x"
	by (auto simp: conefield_def conesegment_commute)

	lemma convex_conefield: "convex (conefield x y)"
	by (auto simp: conefield_alt_def convex_cone_hull)

	lemma conefield_scaleRI: "v \<in> conefield (r *\<^sub>R x) y" if "v \<in> conefield x y" "r > 0"
	using that
	using \<open>r > 0\<close>
	unfolding conefield_alt_def cone_hull_expl
	apply (auto simp: in_segment)
	proof goal_cases
	case (1 c u)
	let ?d = "c * (1 - u) / r + c * u"
	let ?t = "c * u / ?d"
	have "c * (1 - u) = ?d * (1 - ?t) * r" if "0 < u"
	using \<open>0 < r\<close> that(1) 1(3,5) mult_pos_pos
	by (force simp: divide_simps ac_simps ring_distribs[symmetric])
	then have eq1: "(c * (1 - u)) \<^sub>R x = (?d (1 - ?t) * r) *\<^sub>R x" if "0 < u"
	using that by simp
	have "c * u = ?d * ?t" if "u < 1"
	using \<open>0 < r\<close> that(1) 1(3,4,5) mult_pos_pos
	apply (auto simp: divide_simps ac_simps ring_distribs[symmetric])
	proof -
	assume "0 \<le> u"
	"0 < r"
	"1 - u + r * u = 0"
	"u < 1"
	then have False
	by (sos "((((A<0 * A<1) * R<1) + (([~1r] A=0) + ((A<=0 * R<1) * (R<1 * [r]^2)))))")
	then show "u = 0"
	by metis
	qed
	then have eq2: "(c * u) \<^sub>R y = (?d ?t) *\<^sub>R y" if "u < 1"
	using that by simp
	have : "c \<^sub>R ((1 - u) \<^sub>R x + u \<^sub>R y) = ?d \<^sub>R ((1 - ?t) \<^sub>R r \<^sub>R x + ?t \<^sub>R y)"
	if "0 < u" "u < 1"
	using that eq1 eq2
	by (auto simp: algebra_simps)
	show ?case
	apply (cases "u = 0")
	subgoal using 1 by (intro exI[where x="c / r"] exI[where x="r *\<^sub>R x"]) auto
	apply (cases "u = 1")
	subgoal using 1 by (intro exI[where x="c"] exI[where x="y"]) (auto intro!: exI[where x=1])
	subgoal
	apply (rule exI[where x="?d"])
	apply (rule exI[where x="((1 - ?t) \<^sub>R r \<^sub>R x + ?t *\<^sub>R y)"])
	apply (subst *)
	using 1
	apply (auto intro!: exI[where x = ?t])
	apply (auto simp: algebra_simps divide_simps)
	defer
	proof -
	assume a1: "c + c * (r * u) < c * u"
	assume a2: "0 \<le> c"
	assume a3: "0 \<le> u"
	assume a4: "u \<noteq> 0"
	assume a5: "0 < r"
	have "c + c * (r * u) \<le> c * u"
	using a1 less_eq_real_def by blast
	then show "c \<le> c * u"
	using a5 a4 a3 a2 by (metis (no_types) less_add_same_cancel1 less_eq_real_def
	mult_pos_pos order_trans real_scaleR_def real_vector.scale_zero_left)
	next
	assume a1: "0 \<le> c"
	assume a2: "u \<le> 1"
	have f3: "\<forall>x0. ((x0::real) < 1) = (\<not> 1 \<le> x0)"
	by auto
	have f4: "\<forall>x0. ((1::real) < x0) = (\<not> x0 \<le> 1)"
	by fastforce
	have "\<forall>x0 x1. ((x1::real) < x1 * x0) = (\<not> 0 \<le> x1 + - 1 * (x1 * x0))"
	by auto
	then have "(\<forall>r ra. ((r::real) < r * ra) = ((0 \<le> r \<longrightarrow> 1 < ra) \<and> (r \<le> 0 \<longrightarrow> ra < 1))) = (\<forall>r ra. (\<not> (0::real) \<le> r + - 1 * (r * ra)) = ((\<not> 0 \<le> r \<or> \<not> ra \<le> 1) \<and> (\<not> r \<le> 0 \<or> \<not> 1 \<le> ra)))"
	using f4 f3 by presburger
	then have "0 \<le> c + - 1 * (c * u)"
	using a2 a1 mult_less_cancel_left1 by blast
	then show "c * u \<le> c"
	by auto
	qed
	done
	qed

	lemma conefield_scaleRD: "v \<in> conefield x y" if "v \<in> conefield (r *\<^sub>R x) y" "r > 0"
	using conefield_scaleRI[OF that(1) positive_imp_inverse_positive[OF that(2)]] that(2)
	by auto

	lemma conefield_scaleR: "conefield (r *\<^sub>R x) y = conefield x y" if "r > 0"
	using conefield_scaleRD conefield_scaleRI that
	by blast

	lemma conefield_expansion_estimate:
	fixes u v::"'a::euclidean_space" and F::"'a \<Rightarrow> 'a"
	assumes "t \<in> {0 .. pi / 2}"
	assumes angle_pos: "0 < vangle u v" "vangle u v < pi / 2"
	assumes angle_le: "vangle (F u) (F v) \<le> vangle u v"
	assumes "bounded_linear F"
	assumes "x \<in> conefield u v"
	shows "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
	proof cases
	assume [simp]: "x \<noteq> 0"
	from assms have [simp]: "u \<noteq> 0" "v \<noteq> 0" by auto
	interpret bounded_linear F by fact
	define u1 where "u1 = u /\<^sub>R norm u"
	define v1 where "v1 = v /\<^sub>R norm v"
	note \<open>x \<in> conefield u v\<close>
	also have \<open>conefield u v = conefield u1 v1\<close>
	by (auto simp: u1_def v1_def conefield_scaleR conefield_commute[of u])
	finally obtain c t where x: "x = c *\<^sub>R conemem u1 v1 t" "t \<in> {0 .. pi / 2}" "c \<ge> 0"
	by (auto simp: conefield_def cone_hull_expl conesegment_def)
	then have xc: "x /\<^sub>R c = conemem u1 v1 t"
	by (auto simp: divide_simps)
	also have "F \<dots> = conemem (F u1) (F v1) t"
	by (simp add: bounded_linear_image_conemem assms)
	also have "norm \<dots> \<ge> min (norm (F u1)) (norm (F v1)) * norm (conemem u1 v1 t)"
	apply (rule conemem_expansion_estimate)
	subgoal by fact
	subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
	subgoal using angle_pos by (simp add: u1_def v1_def vangle_scaleR)
	subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
	subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
	subgoal using angle_le by (simp add: u1_def v1_def scaleR vangle_scaleR)
	done
	finally show "norm (F x) \<ge> min (norm (F u)/norm u) (norm (F v)/norm v) * norm x"
	unfolding xc[symmetric] scaleR u1_def v1_def norm_scaleR x
	using \<open>c \<ge> 0\<close>
	by (simp add: divide_simps split: if_splits)
	qed simp

	lemma conefield_rightI:
	assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
	assumes "y \<in> {y1 .. y2}"
	shows "(i + y \<^sub>R j) \<in> conefield (i + y1 \<^sub>R j) (i + y2 *\<^sub>R j)"
	unfolding conefield_alt_def
	apply (rule hull_inc)
	using assms
	by (auto simp: in_segment divide_simps inner_Basis algebra_simps
	intro!: exI[where x="(y - y1) / (y2 - y1)"] euclidean_eqI[where 'a='a] )

	lemma conefield_right_vangleI:
	assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
	assumes "y \<in> {y1 .. y2}" "y1 < y2"
	shows "(i + y \<^sub>R j) \<in> conefield (i + y1 \<^sub>R j) (i + y2 *\<^sub>R j)"
	unfolding conefield_alt_def
	apply (rule hull_inc)
	using assms
	by (auto simp: in_segment divide_simps inner_Basis algebra_simps
	intro!: exI[where x="(y - y1) / (y2 - y1)"] euclidean_eqI[where 'a='a] )

	lemma cone_conefield[intro, simp]: "cone (conefield x y)"
	unfolding conefield_def
	by (rule cone_cone_hull)

	lemma conefield_mk_rightI:
	assumes ij: "i \<in> Basis" "j \<in> Basis" and ij_neq: "i \<noteq> j"
	assumes "(i + (y / x) \<^sub>R j) \<in> conefield (i + (y1 / x1) \<^sub>R j) (i + (y2 / x2) *\<^sub>R j)"
	assumes "x > 0" "x1 > 0" "x2 > 0"
	shows "(x \<^sub>R i + y \<^sub>R j) \<in> conefield (x1 \<^sub>R i + y1 \<^sub>R j) (x2 \<^sub>R i + y2 \<^sub>R j)"
	proof -
	have rescale: "(x \<^sub>R i + y \<^sub>R j) = x \<^sub>R (i + (y / x) \<^sub>R j)" if "x > 0" for x y
	using that by (auto simp: algebra_simps)
	show ?thesis
	unfolding rescale[OF \<open>x > 0\<close>] rescale[OF \<open>x1 > 0\<close>] rescale[OF \<open>x2 > 0\<close>]
	conefield_scaleR[OF \<open>x1 > 0\<close>]
	apply (subst conefield_commute)
	unfolding conefield_scaleR[OF \<open>x2 > 0\<close>]
	apply (rule mem_cone)
	apply simp
	apply (subst conefield_commute)
	by (auto intro!: assms less_imp_le)
	qed

	lemma conefield_prod3I:
	assumes "x > 0" "x1 > 0" "x2 > 0"
	assumes "y1 / x1 \<le> y / x" "y / x \<le> y2 / x2"
	shows "(x, y, 0) \<in> (conefield (x1, y1, 0) (x2, y2, 0)::(realrealreal) set)"
	proof -
	have "(x \<^sub>R (1, 0, 0) + y \<^sub>R (0, 1, 0)) \<in>
	(conefield (x1 \<^sub>R (1, 0, 0) + y1 \<^sub>R (0, 1, 0)) (x2 \<^sub>R (1, 0, 0) + y2 \<^sub>R (0, 1, 0))::(realrealreal) set)"
	apply (rule conefield_mk_rightI)
	subgoal by (auto simp: Basis_prod_def zero_prod_def)
	subgoal by (auto simp: Basis_prod_def zero_prod_def)
	subgoal by (auto simp: Basis_prod_def zero_prod_def)
	subgoal using assms by (intro conefield_rightI) (auto simp: Basis_prod_def zero_prod_def)
	by (auto intro: assms)
	then show ?thesis by simp
	qed

	end
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Flow.thy b/thys/Ordinary_Differential_Equations/IVP/Flow.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Flow.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Flow.thy
	@@ -1,3199 +1,3199 @@
	section \<open>Flow\<close>
	theory Flow
	imports
	Picard_Lindeloef_Qualitative
	"HOL-Library.Diagonal_Subsequence"
	"../Library/Bounded_Linear_Operator"
	"../Library/Multivariate_Taylor"
	"../Library/Interval_Integral_HK"
	begin

	text \<open>TODO: extend theorems for dependence on initial time\<close>

	subsection \<open>simp rules for integrability (TODO: move)\<close>

	lemma blinfun_ext: "x = y \<longleftrightarrow> (\<forall>i. blinfun_apply x i = blinfun_apply y i)"
	by transfer auto

	notation id_blinfun ("1\<^sub>L")

	lemma blinfun_inverse_left:
	fixes f::"'a::euclidean_space \<Rightarrow>\<^sub>L 'a" and f'
	shows "f o\<^sub>L f' = 1\<^sub>L \<longleftrightarrow> f' o\<^sub>L f = 1\<^sub>L"
	by transfer
	(auto dest!: bounded_linear.linear simp: id_def[symmetric]
	linear_inverse_left)

	lemma onorm_zero_blinfun[simp]: "onorm (blinfun_apply 0) = 0"
	by transfer (simp add: onorm_zero)

	lemma blinfun_compose_1_left[simp]: "x o\<^sub>L 1\<^sub>L = x"
	and blinfun_compose_1_right[simp]: "1\<^sub>L o\<^sub>L y = y"
	by (auto intro!: blinfun_eqI)


	named_theorems integrable_on_simps

	lemma integrable_on_refl_ivl[intro, simp]: "g integrable_on {b .. (b::'b::ordered_euclidean_space)}"
	and integrable_on_refl_closed_segment[intro, simp]: "h integrable_on closed_segment a a"
	using integrable_on_refl by auto

	lemma integrable_const_ivl_closed_segment[intro, simp]: "(\<lambda>x. c) integrable_on closed_segment a (b::real)"
	by (auto simp: closed_segment_eq_real_ivl)

	lemma integrable_ident_ivl[intro, simp]: "(\<lambda>x. x) integrable_on closed_segment a (b::real)"
	and integrable_ident_cbox[intro, simp]: "(\<lambda>x. x) integrable_on cbox a (b::real)"
	by (auto simp: closed_segment_eq_real_ivl ident_integrable_on)

	lemma content_closed_segment_real:
	fixes a b::real
	shows "content (closed_segment a b) = abs (b - a)"
	by (auto simp: closed_segment_eq_real_ivl)

	lemma integral_const_closed_segment:
	fixes a b::real
	shows "integral (closed_segment a b) (\<lambda>x. c) = abs (b - a) *\<^sub>R c"
	by (auto simp: closed_segment_eq_real_ivl content_closed_segment_real)

	lemmas [integrable_on_simps] =
	integrable_on_empty \<comment> \<open>empty\<close>
	integrable_on_refl integrable_on_refl_ivl integrable_on_refl_closed_segment \<comment> \<open>singleton\<close>
	integrable_const integrable_const_ivl integrable_const_ivl_closed_segment \<comment> \<open>constant\<close>
	ident_integrable_on integrable_ident_ivl integrable_ident_cbox \<comment> \<open>identity\<close>

	lemma integrable_cmul_real:
	fixes K::real
	shows "f integrable_on X \<Longrightarrow> (\<lambda>x. K * f x) integrable_on X "
	unfolding real_scaleR_def[symmetric]
	by (rule integrable_cmul)

	lemmas [integrable_on_simps] =
	integrable_0
	integrable_neg
	integrable_cmul
	integrable_cmul_real
	integrable_on_cmult_iff
	integrable_on_cmult_left
	integrable_on_cmult_right
	integrable_on_cdivide
	integrable_on_cmult_iff
	integrable_on_cmult_left_iff
	integrable_on_cmult_right_iff
	integrable_on_cdivide_iff
	integrable_diff
	integrable_add
	integrable_sum

	lemma dist_cancel_add1: "dist (t0 + et) t0 = norm et"
	by (simp add: dist_norm)

	lemma double_nonneg_le:
	fixes a::real
	shows "a * 2 \<le> b \<Longrightarrow> a \<ge> 0 \<Longrightarrow> a \<le> b"
	by arith


	subsection \<open>Nonautonomous IVP on maximal existence interval\<close>

	context ll_on_open_it
	begin

	context
	fixes x0
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	begin

	lemmas closed_segment_iv_subset_domain = closed_segment_subset_domainI[OF iv_defined(1)]

	lemma
	local_unique_solutions:
	obtains t u L
	where
	"0 < t" "0 < u"
	"cball t0 t \<subseteq> existence_ivl t0 x0"
	"cball x0 (2 * u) \<subseteq> X"
	"\<And>t'. t' \<in> cball t0 t \<Longrightarrow> L-lipschitz_on (cball x0 (2 * u)) (f t')"
	"\<And>x. x \<in> cball x0 u \<Longrightarrow> (flow t0 x usolves_ode f from t0) (cball t0 t) (cball x u)"
	"\<And>x. x \<in> cball x0 u \<Longrightarrow> cball x u \<subseteq> X"
	proof -
	from local_unique_solution[OF iv_defined] obtain et ex B L
	where "0 < et" "0 < ex" "cball t0 et \<subseteq> T" "cball x0 ex \<subseteq> X"
	"unique_on_cylinder t0 (cball t0 et) x0 ex f B L"
	by metis
	then interpret cyl: unique_on_cylinder t0 "cball t0 et" x0 ex "cball x0 ex" f B L
	by auto

	from cyl.solution_solves_ode order_refl \<open>cball x0 ex \<subseteq> X\<close>
	have "(cyl.solution solves_ode f) (cball t0 et) X"
	by (rule solves_ode_on_subset)
	then have "cball t0 et \<subseteq> existence_ivl t0 x0"
	by (rule existence_ivl_maximal_interval) (insert \<open>cball t0 et \<subseteq> T\<close> \<open>0 < et\<close>, auto)

	have "cball t0 et = {t0 - et .. t0 + et}"
	using \<open>et > 0\<close> by (auto simp: dist_real_def)
	then have cylbounds[simp]: "cyl.tmin = t0 - et" "cyl.tmax = t0 + et"
	unfolding cyl.tmin_def cyl.tmax_def
	using \<open>0 < et\<close>
	by auto

	define et' where "et' \<equiv> et / 2"
	define ex' where "ex' \<equiv> ex / 2"

	have "et' > 0" "ex' > 0" using \<open>0 < et\<close> \<open>0 < ex\<close> by (auto simp: et'_def ex'_def)
	moreover
	from \<open>cball t0 et \<subseteq> existence_ivl t0 x0\<close> have "cball t0 et' \<subseteq> existence_ivl t0 x0"
	by (force simp: et'_def dest!: double_nonneg_le)
	moreover
	from this have "cball t0 et' \<subseteq> T" using existence_ivl_subset[of x0] by simp
	have "cball x0 (2 * ex') \<subseteq> X" "\<And>t'. t' \<in> cball t0 et' \<Longrightarrow> L-lipschitz_on (cball x0 (2 * ex')) (f t')"
	using cyl.lipschitz \<open>0 < et\<close> \<open>cball x0 ex \<subseteq> X\<close>
	by (auto simp: ex'_def et'_def intro!:)
	moreover
	{
	fix x0'::'a
	assume x0': "x0' \<in> cball x0 ex'"
	{
	fix b
	assume d: "dist x0' b \<le> ex'"
	have "dist x0 b \<le> dist x0 x0' + dist x0' b"
	by (rule dist_triangle)
	also have "\<dots> \<le> ex' + ex'"
	using x0' d by simp
	also have "\<dots> \<le> ex" by (simp add: ex'_def)
	finally have "dist x0 b \<le> ex" .
	} note triangle = this
	have subs1: "cball t0 et' \<subseteq> cball t0 et"
	and subs2: "cball x0' ex' \<subseteq> cball x0 ex"
	and subs: "cball t0 et' \<times> cball x0' ex' \<subseteq> cball t0 et \<times> cball x0 ex"
	using \<open>0 < ex\<close> \<open>0 < et\<close> x0'
	by (auto simp: ex'_def et'_def triangle dest!: double_nonneg_le)

	have subset_X: "cball x0' ex' \<subseteq> X"
	using \<open>cball x0 ex \<subseteq> X\<close> subs2 \<open>0 < ex'\<close> by force
	then have "x0' \<in> X" using \<open>0 < ex'\<close> by force
	have x0': "t0 \<in> T" "x0' \<in> X" by fact+
	have half_intros: "a \<le> ex' \<Longrightarrow> a \<le> ex" "a \<le> et' \<Longrightarrow> a \<le> et"
	and halfdiv_intro: "a * 2 \<le> ex / B \<Longrightarrow> a \<le> ex' / B" for a
	using \<open>0 < ex\<close> \<open>0 < et\<close>
	by (auto simp: ex'_def et'_def)

	interpret cyl': solution_in_cylinder t0 "cball t0 et'" x0' ex' f "cball x0' ex'" B
	using \<open>0 < et'\<close> \<open>0 < ex'\<close> \<open>0 < et\<close> cyl.norm_f cyl.continuous subs1 \<open>cball t0 et \<subseteq> T\<close>
	apply unfold_locales
	apply (auto simp: split_beta' dist_cancel_add1 intro!: triangle
	continuous_intros cyl.norm_f order_trans[OF _ cyl.e_bounded] halfdiv_intro)
	by (simp add: ex'_def et'_def dist_commute)

	interpret cyl': unique_on_cylinder t0 "cball t0 et'" x0' ex' "cball x0' ex'" f B L
	using cyl.lipschitz[simplified] subs subs1
	by (unfold_locales)
	(auto simp: triangle intro!: half_intros lipschitz_on_subset[OF _ subs2])
	from cyl'.solution_usolves_ode
	have "(flow t0 x0' usolves_ode f from t0) (cball t0 et') (cball x0' ex')"
	apply (rule usolves_ode_solves_odeI)
	subgoal
	apply (rule cyl'.solves_ode_on_subset_domain[where Y=X])
	subgoal
	apply (rule solves_ode_on_subset[where S="existence_ivl t0 x0'" and Y=X])
	subgoal by (rule flow_solves_ode[OF x0'])
	subgoal
	using subs2 \<open>cball x0 ex \<subseteq> X\<close> \<open>0 < et'\<close> \<open>cball t0 et' \<subseteq> T\<close>
	by (intro existence_ivl_maximal_interval[OF solves_ode_on_subset[OF cyl'.solution_solves_ode]])
	auto
	subgoal by force
	done
	subgoal by (force simp: \<open>x0' \<in> X\<close> iv_defined)
	subgoal using \<open>0 < et'\<close> by force
	subgoal by force
	subgoal by force
	done
	subgoal by (force simp: \<open>x0' \<in> X\<close> iv_defined cyl'.solution_iv)
	done
	note this subset_X
	} ultimately show thesis ..
	qed

	lemma Picard_iterate_mem_existence_ivlI:
	assumes "t \<in> T"
	assumes "compact C" "x0 \<in> C" "C \<subseteq> X"
	assumes "\<And>y s. s \<in> {t0 -- t} \<Longrightarrow> y t0 = x0 \<Longrightarrow> y \<in> {t0--s} \<rightarrow> C \<Longrightarrow> continuous_on {t0--s} y \<Longrightarrow>
	x0 + ivl_integral t0 s (\<lambda>t. f t (y t)) \<in> C"
	shows "t \<in> existence_ivl t0 x0" "\<And>s. s \<in> {t0 -- t} \<Longrightarrow> flow t0 x0 s \<in> C"
	proof -
	have "{t0 -- t} \<subseteq> T"
	by (intro closed_segment_subset_domain iv_defined assms)
	from lipschitz_on_compact[OF compact_segment \<open>{t0 -- t} \<subseteq> T\<close> \<open>compact C\<close> \<open>C \<subseteq> X\<close>]
	obtain L where L: "\<And>s. s \<in> {t0 -- t} \<Longrightarrow> L-lipschitz_on C (f s)" by metis
	interpret uc: unique_on_closed t0 "{t0 -- t}" x0 f C L
	using assms closed_segment_iv_subset_domain
	by unfold_locales
	(auto intro!: L compact_imp_closed \<open>compact C\<close> continuous_on_f continuous_intros
	simp: split_beta)
	have "{t0 -- t} \<subseteq> existence_ivl t0 x0"
	using assms closed_segment_iv_subset_domain
	by (intro maximal_existence_flow[OF solves_ode_on_subset[OF uc.solution_solves_ode]])
	- (auto simp: )
	+ auto
	thus "t \<in> existence_ivl t0 x0"
	using assms by auto
	show "flow t0 x0 s \<in> C" if "s \<in> {t0 -- t}" for s
	proof -
	have "flow t0 x0 s = uc.solution s" "uc.solution s \<in> C"
	using solves_odeD[OF uc.solution_solves_ode] that assms
	by (auto simp: closed_segment_iv_subset_domain
	intro!: maximal_existence_flowI(2)[where K="{t0 -- t}"])
	thus ?thesis by simp
	qed
	qed

	lemma flow_has_vderiv_on: "(flow t0 x0 has_vderiv_on (\<lambda>t. f t (flow t0 x0 t))) (existence_ivl t0 x0)"
	by (rule solves_ode_vderivD[OF flow_solves_ode[OF iv_defined]])

	lemmas flow_has_vderiv_on_compose[derivative_intros] =
	has_vderiv_on_compose2[OF flow_has_vderiv_on, THEN has_vderiv_on_eq_rhs]

	end

	lemma unique_on_intersection:
	assumes sols: "(x solves_ode f) U X" "(y solves_ode f) V X"
	assumes iv_mem: "t0 \<in> U" "t0 \<in> V" and subs: "U \<subseteq> T" "V \<subseteq> T"
	assumes ivls: "is_interval U" "is_interval V"
	assumes iv: "x t0 = y t0"
	assumes mem: "t \<in> U" "t \<in> V"
	shows "x t = y t"
	proof -
	from
	maximal_existence_flow(2)[OF sols(1) refl ivls(1) iv_mem(1) subs(1) mem(1)]
	maximal_existence_flow(2)[OF sols(2) iv[symmetric] ivls(2) iv_mem(2) subs(2) mem(2)]
	show ?thesis by simp
	qed

	lemma unique_solution:
	assumes sols: "(x solves_ode f) U X" "(y solves_ode f) U X"
	assumes iv_mem: "t0 \<in> U" and subs: "U \<subseteq> T"
	assumes ivls: "is_interval U"
	assumes iv: "x t0 = y t0"
	assumes mem: "t \<in> U"
	shows "x t = y t"
	by (metis unique_on_intersection assms)

	lemma
	assumes s: "s \<in> existence_ivl t0 x0"
	assumes t: "t + s \<in> existence_ivl s (flow t0 x0 s)"
	shows flow_trans: "flow t0 x0 (s + t) = flow s (flow t0 x0 s) (s + t)"
	and existence_ivl_trans: "s + t \<in> existence_ivl t0 x0"
	proof -
	note ll_on_open_it_axioms
	moreover
	from ll_on_open_it_axioms
	have iv_defined: "t0 \<in> T" "x0 \<in> X"
	and iv_defined': "s \<in> T" "flow t0 x0 s \<in> X"
	using ll_on_open_it.mem_existence_ivl_iv_defined s t
	by blast+

	have "{t0--s} \<subseteq> existence_ivl t0 x0"
	by (simp add: s segment_subset_existence_ivl iv_defined)

	have "s \<in> existence_ivl s (flow t0 x0 s)"
	by (rule ll_on_open_it.existence_ivl_initial_time; fact)
	have "{s--t + s} \<subseteq> existence_ivl s (flow t0 x0 s)"
	by (rule ll_on_open_it.segment_subset_existence_ivl; fact)

	have unique: "flow t0 x0 u = flow s (flow t0 x0 s) u"
	if "u \<in> {s--t + s}" "u \<in> {t0--s}" for u
	using
	ll_on_open_it_axioms
	ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined]
	ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined']
	s
	apply (rule ll_on_open_it.unique_on_intersection)
	using \<open>s \<in> existence_ivl s (flow t0 x0 s)\<close> existence_ivl_subset
	\<open>flow t0 x0 s \<in> X\<close> \<open>s \<in> T\<close> iv_defined s t ll_on_open_it.in_existence_between_zeroI
	that ll_on_open_it_axioms ll_on_open_it.mem_existence_ivl_subset
	by (auto simp: is_interval_existence_ivl)

	let ?un = "{t0 -- s} \<union> {s -- t + s}"
	let ?if = "\<lambda>t. if t \<in> {t0 -- s} then flow t0 x0 t else flow s (flow t0 x0 s) t"
	have "(?if solves_ode (\<lambda>t. if t \<in> {t0 -- s} then f t else f t)) ?un (X \<union> X)"
	apply (rule connection_solves_ode)
	subgoal by (rule solves_ode_on_subset[OF flow_solves_ode[OF iv_defined] \<open>{t0--s} \<subseteq> _\<close> order_refl])
	subgoal
	by (rule solves_ode_on_subset[OF ll_on_open_it.flow_solves_ode[OF ll_on_open_it_axioms iv_defined']
	\<open>{s--t + s} \<subseteq> _\<close> order_refl])
	subgoal by simp
	subgoal by simp
	subgoal by (rule unique) auto
	subgoal by simp
	done
	then have ifsol: "(?if solves_ode f) ?un X"
	by simp
	moreover
	have "?un \<subseteq> existence_ivl t0 x0"
	using existence_ivl_subset[of x0]
	ll_on_open_it.existence_ivl_subset[OF ll_on_open_it_axioms, of s "flow t0 x0 s"]
	\<open>{t0 -- s} \<subseteq> _\<close> \<open>{s--t + s} \<subseteq> _\<close>
	by (intro existence_ivl_maximal_interval[OF ifsol]) (auto intro!: is_real_interval_union)
	then show "s + t \<in> existence_ivl t0 x0"
	by (auto simp: ac_simps)
	have "(flow t0 x0 solves_ode f) ?un X"
	using \<open>{t0--s} \<subseteq> _\<close> \<open>{s -- t + s} \<subseteq> _\<close>
	by (intro solves_ode_on_subset[OF flow_solves_ode \<open>?un \<subseteq> _\<close> order_refl] iv_defined)
	moreover have "s \<in> ?un"
	by simp
	ultimately have "?if (s + t) = flow t0 x0 (s + t)"
	apply (rule ll_on_open_it.unique_solution)
	using existence_ivl_subset[of x0]
	ll_on_open_it.existence_ivl_subset[OF ll_on_open_it_axioms, of s "flow t0 x0 s"]
	\<open>{t0 -- s} \<subseteq> _\<close> \<open>{s--t + s} \<subseteq> _\<close>
	by (auto intro!: is_real_interval_union simp: ac_simps)
	with unique[of "s + t"]
	show "flow t0 x0 (s + t) = flow s (flow t0 x0 s) (s + t)"
	by (auto split: if_splits simp: ac_simps)
	qed

	lemma
	assumes t: "t \<in> existence_ivl t0 x0"
	shows flows_reverse: "flow t (flow t0 x0 t) t0 = x0"
	and existence_ivl_reverse: "t0 \<in> existence_ivl t (flow t0 x0 t)"
	proof -
	have iv_defined: "t0 \<in> T" "x0 \<in> X"
	using mem_existence_ivl_iv_defined t by blast+
	show "t0 \<in> existence_ivl t (flow t0 x0 t)"
	using assms
	by (metis (no_types, opaque_lifting) closed_segment_commute closed_segment_subset_interval
	ends_in_segment(2) general.csol(2-4)
	general.existence_ivl_maximal_segment general.is_interval_existence_ivl
	is_interval_closed_segment_1 iv_defined ll_on_open_it.equals_flowI
	local.existence_ivl_initial_time local.flow_initial_time local.ll_on_open_it_axioms)
	then have "flow t (flow t0 x0 t) (t + (t0 - t)) = flow t0 x0 (t + (t0 - t))"
	by (intro flow_trans[symmetric]) (auto simp: t iv_defined)
	then show "flow t (flow t0 x0 t) t0 = x0"
	by (simp add: iv_defined)
	qed

	lemma flow_has_derivative:
	assumes "t \<in> existence_ivl t0 x0"
	shows "(flow t0 x0 has_derivative (\<lambda>i. i *\<^sub>R f t (flow t0 x0 t))) (at t)"
	proof -
	have "(flow t0 x0 has_derivative (\<lambda>i. i *\<^sub>R f t (flow t0 x0 t))) (at t within existence_ivl t0 x0)"
	using flow_has_vderiv_on
	by (auto simp: has_vderiv_on_def has_vector_derivative_def assms mem_existence_ivl_iv_defined[OF assms])
	then show ?thesis
	by (simp add: at_within_open[OF assms open_existence_ivl])
	qed


	lemma flow_has_vector_derivative:
	assumes "t \<in> existence_ivl t0 x0"
	shows "(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at t)"
	using flow_has_derivative[OF assms]
	by (simp add: has_vector_derivative_def)

	lemma flow_has_vector_derivative_at_0:
	assumes"t \<in> existence_ivl t0 x0"
	shows "((\<lambda>h. flow t0 x0 (t + h)) has_vector_derivative f t (flow t0 x0 t)) (at 0)"
	proof -
	from flow_has_vector_derivative[OF assms]
	have
	"((+) t has_vector_derivative 1) (at 0)"
	"(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at (t + 0))"
	by (auto intro!: derivative_eq_intros)
	from vector_diff_chain_at[OF this]
	show ?thesis by (simp add: o_def)
	qed

	lemma
	assumes "t \<in> existence_ivl t0 x0"
	shows closed_segment_subset_existence_ivl: "closed_segment t0 t \<subseteq> existence_ivl t0 x0"
	and ivl_subset_existence_ivl: "{t0 .. t} \<subseteq> existence_ivl t0 x0"
	and ivl_subset_existence_ivl': "{t .. t0} \<subseteq> existence_ivl t0 x0"
	using assms in_existence_between_zeroI
	by (auto simp: closed_segment_eq_real_ivl)

	lemma flow_fixed_point:
	assumes t: "t \<in> existence_ivl t0 x0"
	shows "flow t0 x0 t = x0 + ivl_integral t0 t (\<lambda>t. f t (flow t0 x0 t))"
	proof -
	have "(flow t0 x0 has_vderiv_on (\<lambda>s. f s (flow t0 x0 s))) {t0 -- t}"
	using closed_segment_subset_existence_ivl[OF t]
	by (auto intro!: has_vector_derivative_at_within flow_has_vector_derivative
	simp: has_vderiv_on_def)
	from fundamental_theorem_of_calculus_ivl_integral[OF this]
	have "((\<lambda>t. f t (flow t0 x0 t)) has_ivl_integral flow t0 x0 t - x0) t0 t"
	by (simp add: mem_existence_ivl_iv_defined[OF assms])
	from this[THEN ivl_integral_unique]
	- show ?thesis by (simp add: )
	+ show ?thesis by simp
	qed

	lemma flow_continuous: "t \<in> existence_ivl t0 x0 \<Longrightarrow> continuous (at t) (flow t0 x0)"
	by (metis has_derivative_continuous flow_has_derivative)

	lemma flow_tendsto: "t \<in> existence_ivl t0 x0 \<Longrightarrow> (ts \<longlongrightarrow> t) F \<Longrightarrow>
	((\<lambda>s. flow t0 x0 (ts s)) \<longlongrightarrow> flow t0 x0 t) F"
	by (rule isCont_tendsto_compose[OF flow_continuous])

	lemma flow_continuous_on: "continuous_on (existence_ivl t0 x0) (flow t0 x0)"
	by (auto intro!: flow_continuous continuous_at_imp_continuous_on)

	lemma flow_continuous_on_intro:
	"continuous_on s g \<Longrightarrow>
	(\<And>xa. xa \<in> s \<Longrightarrow> g xa \<in> existence_ivl t0 x0) \<Longrightarrow>
	continuous_on s (\<lambda>xa. flow t0 x0 (g xa))"
	by (auto intro!: continuous_on_compose2[OF flow_continuous_on])

	lemma f_flow_continuous:
	assumes "t \<in> existence_ivl t0 x0"
	shows "isCont (\<lambda>t. f t (flow t0 x0 t)) t"
	by (rule continuous_on_interior)
	(insert existence_ivl_subset assms,
	auto intro!: flow_in_domain flow_continuous_on continuous_intros
	simp: interior_open open_existence_ivl)

	lemma exponential_initial_condition:
	assumes y0: "t \<in> existence_ivl t0 y0"
	assumes z0: "t \<in> existence_ivl t0 z0"
	assumes "Y \<subseteq> X"
	assumes remain: "\<And>s. s \<in> closed_segment t0 t \<Longrightarrow> flow t0 y0 s \<in> Y"
	"\<And>s. s \<in> closed_segment t0 t \<Longrightarrow> flow t0 z0 s \<in> Y"
	assumes lipschitz: "\<And>s. s \<in> closed_segment t0 t \<Longrightarrow> K-lipschitz_on Y (f s)"
	shows "norm (flow t0 y0 t - flow t0 z0 t) \<le> norm (y0 - z0) * exp ((K + 1) * abs (t - t0))"
	proof cases
	assume "y0 = z0"
	thus ?thesis
	by simp
	next
	assume ne: "y0 \<noteq> z0"
	define K' where "K' \<equiv> K + 1"
	from lipschitz have "K'-lipschitz_on Y (f s)" if "s \<in> {t0 -- t}" for s
	using that
	by (auto simp: lipschitz_on_def K'_def
	intro!: order_trans[OF _ mult_right_mono[of K "K + 1"]])

	from mem_existence_ivl_iv_defined[OF y0] mem_existence_ivl_iv_defined[OF z0]
	have "t0 \<in> T" and inX: "y0 \<in> X" "z0 \<in> X" by auto

	from remain[of t0] inX \<open>t0 \<in> T \<close> have "y0 \<in> Y" "z0 \<in> Y" by auto

	define v where "v \<equiv> \<lambda>t. norm (flow t0 y0 t - flow t0 z0 t)"
	{
	fix s
	assume s: "s \<in> {t0 -- t}"
	with s
	closed_segment_subset_existence_ivl[OF y0]
	closed_segment_subset_existence_ivl[OF z0]
	have
	y0': "s \<in> existence_ivl t0 y0" and
	z0': "s \<in> existence_ivl t0 z0"
	by (auto simp: closed_segment_eq_real_ivl)
	have integrable:
	"(\<lambda>t. f t (flow t0 y0 t)) integrable_on {t0--s}"
	"(\<lambda>t. f t (flow t0 z0 t)) integrable_on {t0--s}"
	using closed_segment_subset_existence_ivl[OF y0']
	closed_segment_subset_existence_ivl[OF z0']
	\<open>y0 \<in> X\<close> \<open>z0 \<in> X\<close> \<open>t0 \<in> T\<close>
	by (auto intro!: continuous_at_imp_continuous_on f_flow_continuous
	integrable_continuous_closed_segment)
	hence int: "flow t0 y0 s - flow t0 z0 s =
	y0 - z0 + ivl_integral t0 s (\<lambda>t. f t (flow t0 y0 t) - f t (flow t0 z0 t))"
	unfolding v_def
	using flow_fixed_point[OF y0'] flow_fixed_point[OF z0']
	s
	by (auto simp: algebra_simps ivl_integral_diff)
	have "v s \<le> v t0 + K' * integral {t0 -- s} (\<lambda>t. v t)"
	using closed_segment_subset_existence_ivl[OF y0'] closed_segment_subset_existence_ivl[OF z0'] s
	using closed_segment_closed_segment_subset[OF _ _ s, of _ t0, simplified]
	by (subst integral_mult)
	(auto simp: integral_mult v_def int inX \<open>t0 \<in> T\<close>
	simp del: Henstock_Kurzweil_Integration.integral_mult_right
	intro!: norm_triangle_le ivl_integral_norm_bound_integral
	integrable_continuous_closed_segment continuous_intros
	continuous_at_imp_continuous_on flow_continuous f_flow_continuous
	lipschitz_on_normD[OF \<open>_ \<Longrightarrow> K'-lipschitz_on _ _\<close>] remain)
	} note le = this
	have cont: "continuous_on {t0 -- t} v"
	using closed_segment_subset_existence_ivl[OF y0] closed_segment_subset_existence_ivl[OF z0] inX
	by (auto simp: v_def \<open>t0 \<in> T\<close>
	intro!: continuous_at_imp_continuous_on continuous_intros flow_continuous)
	have nonneg: "\<And>t. v t \<ge> 0"
	by (auto simp: v_def)
	from ne have pos: "v t0 > 0"
	by (auto simp: v_def \<open>t0 \<in> T\<close> inX)
	have lippos: "K' > 0"
	proof -
	have "0 \<le> dist (f t0 y0) (f t0 z0)" by simp
	also from lipschitz_onD[OF lipschitz \<open>y0 \<in> Y\<close> \<open>z0 \<in> Y\<close>, of t0]ne
	have "\<dots> \<le> K * dist y0 z0"
	by simp
	finally have "0 \<le> K"
	by (metis dist_le_zero_iff ne zero_le_mult_iff)
	thus ?thesis by (simp add: K'_def)
	qed
	from le cont nonneg pos \<open>0 < K'\<close>
	have "v t \<le> v t0 * exp (K' * abs (t - t0))"
	by (rule gronwall_general_segment) simp_all
	thus ?thesis
	by (simp add: v_def K'_def \<open>t0 \<in> T\<close> inX)
	qed

	lemma
	existence_ivl_cballs:
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	obtains t u L
	where
	"\<And>y. y \<in> cball x0 u \<Longrightarrow> cball t0 t \<subseteq> existence_ivl t0 y"
	"\<And>s y. y \<in> cball x0 u \<Longrightarrow> s \<in> cball t0 t \<Longrightarrow> flow t0 y s \<in> cball y u"
	"L-lipschitz_on (cball t0 t\<times>cball x0 u) (\<lambda>(t, x). flow t0 x t)"
	"\<And>y. y \<in> cball x0 u \<Longrightarrow> cball y u \<subseteq> X"
	"0 < t" "0 < u"
	proof -
	note iv_defined
	from local_unique_solutions[OF this]
	obtain t u L where tu: "0 < t" "0 < u"
	and subsT: "cball t0 t \<subseteq> existence_ivl t0 x0"
	and subs': "cball x0 (2 * u) \<subseteq> X"
	and lipschitz: "\<And>s. s \<in> cball t0 t \<Longrightarrow> L-lipschitz_on (cball x0 (2*u)) (f s)"
	and usol: "\<And>y. y \<in> cball x0 u \<Longrightarrow> (flow t0 y usolves_ode f from t0) (cball t0 t) (cball y u)"
	and subs: "\<And>y. y \<in> cball x0 u \<Longrightarrow> cball y u \<subseteq> X"
	by metis
	{
	fix y assume y: "y \<in> cball x0 u"
	from subs[OF y] \<open>0 < u\<close> have "y \<in> X" by auto
	note iv' = \<open>t0 \<in> T\<close> \<open>y \<in> X\<close>
	from usol[OF y, THEN usolves_odeD(1)]
	have sol1: "(flow t0 y solves_ode f) (cball t0 t) (cball y u)" .
	from sol1 order_refl subs[OF y]
	have sol: "(flow t0 y solves_ode f) (cball t0 t) X"
	by (rule solves_ode_on_subset)
	note * = maximal_existence_flow[OF sol flow_initial_time
	is_interval_cball_1 _ order_trans[OF subsT existence_ivl_subset],
	unfolded centre_in_cball, OF iv' less_imp_le[OF \<open>0 < t\<close>]]
	have eivl: "cball t0 t \<subseteq> existence_ivl t0 y"
	by (rule *)
	have "flow t0 y s \<in> cball y u" if "s \<in> cball t0 t" for s
	by (rule solves_odeD(2)[OF sol1 that])
	note eivl this
	} note * = this
	note *
	moreover
	have cont_on_f_flow:
	"\<And>x1 S. S \<subseteq> cball t0 t \<Longrightarrow> x1 \<in> cball x0 u \<Longrightarrow> continuous_on S (\<lambda>t. f t (flow t0 x1 t))"
	using subs[of x0] \<open>u > 0\<close> *(1) iv_defined
	by (auto intro!: continuous_at_imp_continuous_on f_flow_continuous)
	have "bounded ((\<lambda>(t, x). f t x) ` (cball t0 t \<times> cball x0 (2 * u)))"
	using subs' subsT existence_ivl_subset[of x0]
	by (auto intro!: compact_imp_bounded compact_continuous_image compact_Times
	continuous_intros simp: split_beta')
	then obtain B where B: "\<And>s y. s \<in> cball t0 t \<Longrightarrow> y \<in> cball x0 (2 * u) \<Longrightarrow> norm (f s y) \<le> B" "B > 0"
	by (auto simp: bounded_pos cball_def)
	have flow_in_cball: "flow t0 x1 s \<in> cball x0 (2 * u)"
	if s: "s \<in> cball t0 t" and x1: "x1 \<in> cball x0 u"
	for s::real and x1
	proof -
	from *(2)[OF x1 s] have "flow t0 x1 s \<in> cball x1 u" .
	also have "\<dots> \<subseteq> cball x0 (2 * u)"
	using x1
	by (auto intro!: dist_triangle_le[OF add_mono, of _ x1 u _ u, simplified]
	simp: dist_commute)
	finally show ?thesis .
	qed
	have "(B + exp ((L + 1) * \<bar>t\<bar>))-lipschitz_on (cball t0 t\<times>cball x0 u) (\<lambda>(t, x). flow t0 x t)"
	proof (rule lipschitz_onI, safe)
	fix t1 t2 :: real and x1 x2
	assume t1: "t1 \<in> cball t0 t" and t2: "t2 \<in> cball t0 t"
	and x1: "x1 \<in> cball x0 u" and x2: "x2 \<in> cball x0 u"
	have t1_ex: "t1 \<in> existence_ivl t0 x1"
	and t2_ex: "t2 \<in> existence_ivl t0 x1" "t2 \<in> existence_ivl t0 x2"
	and "x1 \<in> cball x0 (2u)" "x2 \<in> cball x0 (2u)"
	using (1)[OF x1] (1)[OF x2] t1 t2 x1 x2 tu by auto
	have "dist (flow t0 x1 t1) (flow t0 x2 t2) \<le>
	dist (flow t0 x1 t1) (flow t0 x1 t2) + dist (flow t0 x1 t2) (flow t0 x2 t2)"
	by (rule dist_triangle)
	also have "dist (flow t0 x1 t2) (flow t0 x2 t2) \<le> dist x1 x2 * exp ((L + 1) * \<bar>t2 - t0\<bar>)"
	unfolding dist_norm
	proof (rule exponential_initial_condition[where Y = "cball x0 (2 * u)"])
	fix s assume "s \<in> closed_segment t0 t2" hence s: "s \<in> cball t0 t"
	using t2
	by (auto simp: dist_real_def closed_segment_eq_real_ivl split: if_split_asm)
	show "flow t0 x1 s \<in> cball x0 (2 * u)"
	by (rule flow_in_cball[OF s x1])
	show "flow t0 x2 s \<in> cball x0 (2 * u)"
	by (rule flow_in_cball[OF s x2])
	show "L-lipschitz_on (cball x0 (2 * u)) (f s)" if "s \<in> closed_segment t0 t2" for s
	using that centre_in_cball convex_contains_segment less_imp_le t2 tu(1)
	by (blast intro!: lipschitz)
	qed (fact)+
	also have "\<dots> \<le> dist x1 x2 * exp ((L + 1) * \<bar>t\<bar>)"
	using \<open>u > 0\<close> t2
	by (auto
	intro!: mult_left_mono add_nonneg_nonneg lipschitz[THEN lipschitz_on_nonneg]
	simp: cball_eq_empty cball_eq_sing' dist_real_def)
	also
	have "x1 \<in> X"
	using x1 subs[of x0] \<open>u > 0\<close>
	by auto
	have *: "\<bar>t0 - t1\<bar> \<le> t \<Longrightarrow> x \<in> {t0--t1} \<Longrightarrow> \<bar>t0 - x\<bar> \<le> t"
	"\<bar>t0 - t2\<bar> \<le> t \<Longrightarrow> x \<in> {t0--t2} \<Longrightarrow> \<bar>t0 - x\<bar> \<le> t"
	"\<bar>t0 - t1\<bar> \<le> t \<Longrightarrow> \<bar>t0 - t2\<bar> \<le> t \<Longrightarrow> x \<in> {t1--t2} \<Longrightarrow> \<bar>t0 - x\<bar> \<le> t"
	for x
	using t1 t2 t1_ex x1 flow_in_cball[OF _ x1]
	by (auto simp: closed_segment_eq_real_ivl split: if_splits)

	have integrable:
	"(\<lambda>t. f t (flow t0 x1 t)) integrable_on {t0--t1}"
	"(\<lambda>t. f t (flow t0 x1 t)) integrable_on {t0--t2}"
	"(\<lambda>t. f t (flow t0 x1 t)) integrable_on {t1--t2}"
	using t1 t2 t1_ex x1 flow_in_cball[OF _ x1]
	by (auto intro!: order_trans[OF integral_bound[where B=B]] cont_on_f_flow B
	integrable_continuous_closed_segment
	intro: *
	simp: dist_real_def integral_minus_sets')

	have *: "\<bar>t0 - t1\<bar> \<le> t \<Longrightarrow> \<bar>t0 - t2\<bar> \<le> t \<Longrightarrow> s \<in> {t1--t2} \<Longrightarrow> \<bar>t0 - s\<bar> \<le> t" for s
	by (auto simp: closed_segment_eq_real_ivl split: if_splits)
	note [simp] = t1_ex t2_ex \<open>x1 \<in> X\<close> integrable
	have "dist (flow t0 x1 t1) (flow t0 x1 t2) \<le> dist t1 t2 * B"
	using t1 t2 x1 flow_in_cball[OF _ x1] \<open>t0 \<in> T\<close>
	ivl_integral_combine[of "\<lambda>t. f t (flow t0 x1 t)" t2 t0 t1]
	ivl_integral_combine[of "\<lambda>t. f t (flow t0 x1 t)" t1 t0 t2]
	by (auto simp: flow_fixed_point dist_norm add.commute closed_segment_commute
	norm_minus_commute ivl_integral_minus_sets' ivl_integral_minus_sets
	intro!: order_trans[OF ivl_integral_bound[where B=B]] cont_on_f_flow B dest: *)
	finally
	have "dist (flow t0 x1 t1) (flow t0 x2 t2) \<le>
	dist t1 t2 * B + dist x1 x2 * exp ((L + 1) * \<bar>t\<bar>)"
	by arith
	also have "\<dots> \<le> dist (t1, x1) (t2, x2) * B + dist (t1, x1) (t2, x2) * exp ((L + 1) * \<bar>t\<bar>)"
	using \<open>B > 0\<close>
	by (auto intro!: add_mono mult_right_mono simp: dist_prod_def)
	finally show "dist (flow t0 x1 t1) (flow t0 x2 t2)
	\<le> (B + exp ((L + 1) * \<bar>t\<bar>)) * dist (t1, x1) (t2, x2)"
	by (simp add: algebra_simps)
	qed (simp add: \<open>0 < B\<close> less_imp_le)
	ultimately
	show thesis using subs tu ..
	qed

	context
	fixes x0
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	begin

	lemma existence_ivl_notempty: "existence_ivl t0 x0 \<noteq> {}"
	using existence_ivl_initial_time iv_defined
	by auto

	lemma initial_time_bounds:
	shows "bdd_above (existence_ivl t0 x0) \<Longrightarrow> t0 < Sup (existence_ivl t0 x0)" (is "?a \<Longrightarrow> _")
	and "bdd_below (existence_ivl t0 x0) \<Longrightarrow> Inf (existence_ivl t0 x0) < t0" (is "?b \<Longrightarrow> _")
	proof -
	from local_unique_solutions[OF iv_defined]
	obtain te where te: "te > 0" "cball t0 te \<subseteq> existence_ivl t0 x0"
	by metis
	then
	show "t0 < Sup (existence_ivl t0 x0)" if bdd: "bdd_above (existence_ivl t0 x0)"
	using less_cSup_iff[OF existence_ivl_notempty bdd, of t0] iv_defined
	by (auto simp: dist_real_def intro!: bexI[where x="t0 + te"])

	from te show "Inf (existence_ivl t0 x0) < t0" if bdd: "bdd_below (existence_ivl t0 x0)"
	unfolding cInf_less_iff[OF existence_ivl_notempty bdd, of t0]
	by (auto simp: dist_real_def iv_defined intro!: bexI[where x="t0 - te"])
	qed

	lemma
	flow_leaves_compact_ivl_right:
	assumes bdd: "bdd_above (existence_ivl t0 x0)"
	defines "b \<equiv> Sup (existence_ivl t0 x0)"
	assumes "b \<in> T"
	assumes "compact K"
	assumes "K \<subseteq> X"
	obtains t where "t \<ge> t0" "t \<in> existence_ivl t0 x0" "flow t0 x0 t \<notin> K"
	proof (atomize_elim, rule ccontr, auto)
	note iv_defined
	note ne = existence_ivl_notempty
	assume K[rule_format]: "\<forall>t. t \<in> existence_ivl t0 x0 \<longrightarrow> t0 \<le> t \<longrightarrow> flow t0 x0 t \<in> K"
	have b_upper: "t \<le> b" if "t \<in> existence_ivl t0 x0" for t
	unfolding b_def
	by (rule cSup_upper[OF that bdd])

	have less_b_iff: "y < b \<longleftrightarrow> (\<exists>x\<in>existence_ivl t0 x0. y < x)" for y
	unfolding b_def less_cSup_iff[OF ne bdd] ..
	have "t0 \<le> b"
	by (simp add: iv_defined b_upper)
	then have geI: "t \<in> {t0--<b} \<Longrightarrow> t0 \<le> t" for t
	by (auto simp: half_open_segment_real)
	have subset: "{t0 --< b} \<subseteq> existence_ivl t0 x0"
	using \<open>t0 \<le> b\<close> in_existence_between_zeroI
	by (auto simp: half_open_segment_real iv_defined less_b_iff)
	have sol: "(flow t0 x0 solves_ode f) {t0 --< b} K"
	apply (rule solves_odeI)
	apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF flow_solves_ode] subset])
	using subset iv_defined
	by (auto intro!: K geI)
	have cont: "continuous_on ({t0--b} \<times> K) (\<lambda>(t, x). f t x)"
	using \<open>K \<subseteq> X\<close> closed_segment_subset_domainI[OF iv_defined(1) \<open>b \<in> T\<close>]
	by (auto simp: split_beta intro!: continuous_intros)

	from initial_time_bounds(1)[OF bdd] have "t0 \<noteq> b" by (simp add: b_def)
	from solves_ode_half_open_segment_continuation[OF sol cont \<open>compact K\<close> \<open>t0 \<noteq> b\<close>]
	obtain l where lim: "(flow t0 x0 \<longlongrightarrow> l) (at b within {t0--<b})"
	and limsol: "((\<lambda>t. if t = b then l else flow t0 x0 t) solves_ode f) {t0--b} K" .
	have "b \<in> existence_ivl t0 x0"
	using \<open>t0 \<noteq> b\<close> closed_segment_subset_domainI[OF \<open>t0 \<in> T\<close> \<open>b \<in> T\<close>]
	by (intro existence_ivl_maximal_segment[OF solves_ode_on_subset[OF limsol order_refl \<open>K \<subseteq> X\<close>]])
	(auto simp: iv_defined)

	have "flow t0 x0 b \<in> X"
	by (simp add: \<open>b \<in> existence_ivl t0 x0\<close> flow_in_domain iv_defined)

	from ll_on_open_it.local_unique_solutions[OF ll_on_open_it_axioms \<open>b \<in> T\<close> \<open>flow t0 x0 b \<in> X\<close>]
	obtain e where "e > 0" "cball b e \<subseteq> existence_ivl b (flow t0 x0 b)"
	by metis
	then have "e + b \<in> existence_ivl b (flow t0 x0 b)"
	by (auto simp: dist_real_def)
	from existence_ivl_trans[OF \<open>b \<in> existence_ivl t0 x0\<close> \<open>e + b \<in> existence_ivl _ _\<close>]
	have "b + e \<in> existence_ivl t0 x0" .
	from b_upper[OF this] \<open>e > 0\<close>
	show False
	by simp
	qed

	lemma
	flow_leaves_compact_ivl_left:
	assumes bdd: "bdd_below (existence_ivl t0 x0)"
	defines "b \<equiv> Inf (existence_ivl t0 x0)"
	assumes "b \<in> T"
	assumes "compact K"
	assumes "K \<subseteq> X"
	obtains t where "t \<le> t0" "t \<in> existence_ivl t0 x0" "flow t0 x0 t \<notin> K"
	proof -
	interpret rev: ll_on_open "(preflect t0 ` T)" "(\<lambda>t. - f (preflect t0 t))" X ..
	from antimono_preflect bdd have bdd_rev: "bdd_above (rev.existence_ivl t0 x0)"
	unfolding rev_existence_ivl_eq
	by (rule bdd_above_image_antimono)
	note ne = existence_ivl_notempty
	have "Sup (rev.existence_ivl t0 x0) = preflect t0 b"
	using continuous_at_Inf_antimono[OF antimono_preflect _ ne bdd]
	by (simp add: continuous_preflect b_def rev_existence_ivl_eq)
	then have Sup_mem: "Sup (rev.existence_ivl t0 x0) \<in> preflect t0 ` T"
	using \<open>b \<in> T\<close> by auto

	have rev_iv: "t0 \<in> preflect t0 ` T" "x0 \<in> X" using iv_defined by auto
	from rev.flow_leaves_compact_ivl_right[OF rev_iv bdd_rev Sup_mem \<open>compact K\<close> \<open>K \<subseteq> X\<close>]
	obtain t where "t0 \<le> t" "t \<in> rev.existence_ivl t0 x0" "rev.flow t0 x0 t \<notin> K" .

	then have "preflect t0 t \<le> t0" "preflect t0 t \<in> existence_ivl t0 x0" "flow t0 x0 (preflect t0 t) \<notin> K"
	by (auto simp: rev_existence_ivl_eq rev_flow_eq)
	thus ?thesis ..
	qed

	lemma
	sup_existence_maximal:
	assumes "\<And>t. t0 \<le> t \<Longrightarrow> t \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 t \<in> K"
	assumes "compact K" "K \<subseteq> X"
	assumes "bdd_above (existence_ivl t0 x0)"
	shows "Sup (existence_ivl t0 x0) \<notin> T"
	using flow_leaves_compact_ivl_right[of K] assms by force

	lemma
	inf_existence_minimal:
	assumes "\<And>t. t \<le> t0 \<Longrightarrow> t \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 t \<in> K"
	assumes "compact K" "K \<subseteq> X"
	assumes "bdd_below (existence_ivl t0 x0)"
	shows "Inf (existence_ivl t0 x0) \<notin> T"
	using flow_leaves_compact_ivl_left[of K] assms
	by force

	end

	lemma
	subset_mem_compact_implies_subset_existence_interval:
	assumes ivl: "t0 \<in> T'" "is_interval T'" "T' \<subseteq> T"
	assumes iv_defined: "x0 \<in> X"
	assumes mem_compact: "\<And>t. t \<in> T' \<Longrightarrow> t \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 t \<in> K"
	assumes K: "compact K" "K \<subseteq> X"
	shows "T' \<subseteq> existence_ivl t0 x0"
	proof (rule ccontr)
	assume "\<not> T' \<subseteq> existence_ivl t0 x0"
	then obtain t' where t': "t' \<notin> existence_ivl t0 x0" "t' \<in> T'"
	by auto
	from assms have iv_defined: "t0 \<in> T" "x0 \<in> X" by auto
	show False
	proof (cases rule: not_in_connected_cases[OF connected_existence_ivl t'(1) existence_ivl_notempty[OF iv_defined]])
	assume bdd: "bdd_below (existence_ivl t0 x0)"
	assume t'_lower: "t' \<le> y" if "y \<in> existence_ivl t0 x0" for y
	have i: "Inf (existence_ivl t0 x0) \<in> T'"
	using initial_time_bounds[OF iv_defined] iv_defined
	apply -
	by (rule mem_is_intervalI[of _ t' t0])
	(auto simp: ivl t' bdd intro!: t'_lower cInf_greatest[OF existence_ivl_notempty[OF iv_defined]])
	have *: "t \<in> T'" if "t \<le> t0" "t \<in> existence_ivl t0 x0" for t
	by (rule mem_is_intervalI[OF \<open>is_interval T'\<close> i \<open>t0 \<in> T'\<close>]) (auto intro!: cInf_lower that bdd)
	from inf_existence_minimal[OF iv_defined mem_compact K bdd, OF *]
	show False using i ivl by auto
	next
	assume bdd: "bdd_above (existence_ivl t0 x0)"
	assume t'_upper: "y \<le> t'" if "y \<in> existence_ivl t0 x0" for y
	have s: "Sup (existence_ivl t0 x0) \<in> T'"
	using initial_time_bounds[OF iv_defined]
	apply -
	apply (rule mem_is_intervalI[of _ t0 t'])
	by (auto simp: ivl t' bdd intro!: t'_upper cSup_least[OF existence_ivl_notempty[OF iv_defined]])
	have *: "t \<in> T'" if "t0 \<le> t" "t \<in> existence_ivl t0 x0" for t
	by (rule mem_is_intervalI[OF \<open>is_interval T'\<close> \<open>t0 \<in> T'\<close> s]) (auto intro!: cSup_upper that bdd)
	from sup_existence_maximal[OF iv_defined mem_compact K bdd, OF *]
	show False using s ivl by auto
	qed
	qed

	lemma
	mem_compact_implies_subset_existence_interval:
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	assumes mem_compact: "\<And>t. t \<in> T \<Longrightarrow> t \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 t \<in> K"
	assumes K: "compact K" "K \<subseteq> X"
	shows "T \<subseteq> existence_ivl t0 x0"
	by (rule subset_mem_compact_implies_subset_existence_interval; (fact \| rule order_refl interval iv_defined))

	lemma
	global_right_existence_ivl_explicit:
	assumes "b \<ge> t0"
	assumes b: "b \<in> existence_ivl t0 x0"
	obtains d K where "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {t0 .. b} \<Longrightarrow>
	dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	proof -
	note iv_defined = mem_existence_ivl_iv_defined[OF b]
	define seg where "seg \<equiv> (\<lambda>t. flow t0 x0 t) ` (closed_segment t0 b)"
	have [simp]: "x0 \<in> seg"
	by (auto simp: seg_def intro!: image_eqI[where x=t0] simp: closed_segment_eq_real_ivl iv_defined)
	have "seg \<noteq> {}" by (auto simp: seg_def closed_segment_eq_real_ivl)
	moreover
	have "compact seg"
	using iv_defined b
	by (auto simp: seg_def closed_segment_eq_real_ivl
	intro!: compact_continuous_image continuous_at_imp_continuous_on flow_continuous;
	metis (erased, opaque_lifting) atLeastAtMost_iff closed_segment_eq_real_ivl
	closed_segment_subset_existence_ivl contra_subsetD order.trans)
	moreover note open_domain(2)
	moreover have "seg \<subseteq> X"
	using closed_segment_subset_existence_ivl b
	by (auto simp: seg_def intro!: flow_in_domain iv_defined)
	ultimately
	obtain e where e: "0 < e" "{x. infdist x seg \<le> e} \<subseteq> X"
	thm compact_in_open_separated
	by (rule compact_in_open_separated)
	define A where "A \<equiv> {x. infdist x seg \<le> e}"

	have "A \<subseteq> X" using e by (simp add: A_def)

	have mem_existence_ivlI: "\<And>s. t0 \<le> s \<Longrightarrow> s \<le> b \<Longrightarrow> s \<in> existence_ivl t0 x0"
	by (rule in_existence_between_zeroI[OF b]) (auto simp: closed_segment_eq_real_ivl)

	have "compact A"
	unfolding A_def
	by (rule compact_infdist_le) fact+
	have "compact {t0 .. b}" "{t0 .. b} \<subseteq> T"
	subgoal by simp
	subgoal
	using mem_existence_ivlI mem_existence_ivl_subset[of _ x0] iv_defined b ivl_subset_existence_ivl
	by blast
	done
	from lipschitz_on_compact[OF this \<open>compact A\<close> \<open>A \<subseteq> X\<close>]
	obtain K' where K': "\<And>t. t \<in> {t0 .. b} \<Longrightarrow> K'-lipschitz_on A (f t)"
	by metis
	define K where "K \<equiv> K' + 1"
	have "0 < K" "0 \<le> K"
	using assms lipschitz_on_nonneg[OF K', of t0]
	by (auto simp: K_def)
	have K: "\<And>t. t \<in> {t0 .. b} \<Longrightarrow> K-lipschitz_on A (f t)"
	unfolding K_def
	using \<open>_ \<Longrightarrow> lipschitz_on K' A _\<close>
	by (rule lipschitz_on_mono) auto

	have [simp]: "x0 \<in> A" using \<open>0 < e\<close> by (auto simp: A_def)


	define d where "d \<equiv> min e (e * exp (-K * (b - t0)))"
	hence d: "0 < d" "d \<le> e" "d \<le> e * exp (-K * (b - t0))"
	using e by auto

	have d_times_exp_le: "d * exp (K * (t - t0)) \<le> e" if "t0 \<le> t" "t \<le> b" for t
	proof -
	from that have "d * exp (K * (t - t0)) \<le> d * exp (K * (b - t0))"
	using \<open>0 \<le> K\<close> \<open>0 < d\<close>
	by (auto intro!: mult_left_mono)
	also have "d * exp (K * (b - t0)) \<le> e"
	using d by (auto simp: exp_minus divide_simps)
	finally show ?thesis .
	qed
	have "ball x0 d \<subseteq> X" using d \<open>A \<subseteq> X\<close>
	by (auto simp: A_def dist_commute intro!: infdist_le2[where a=x0])
	note iv_defined
	{
	fix y
	assume y: "y \<in> ball x0 d"
	hence "y \<in> A" using d
	by (auto simp: A_def dist_commute intro!: infdist_le2[where a=x0])
	hence "y \<in> X" using \<open>A \<subseteq> X\<close> by auto
	note y_iv = \<open>t0 \<in> T\<close> \<open>y \<in> X\<close>
	have in_A: "flow t0 y t \<in> A" if t: "t0 \<le> t" "t \<in> existence_ivl t0 y" "t \<le> b" for t
	proof (rule ccontr)
	assume flow_out: "flow t0 y t \<notin> A"
	obtain t' where t':
	"t0 \<le> t'"
	"t' \<le> t"
	"\<And>t. t \<in> {t0 .. t'} \<Longrightarrow> flow t0 x0 t \<in> A"
	"infdist (flow t0 y t') seg \<ge> e"
	"\<And>t. t \<in> {t0 .. t'} \<Longrightarrow> flow t0 y t \<in> A"
	proof -
	let ?out = "((\<lambda>t. infdist (flow t0 y t) seg) -` {e..}) \<inter> {t0..t}"
	have "compact ?out"
	unfolding compact_eq_bounded_closed
	proof safe
	show "bounded ?out" by (auto intro!: bounded_closed_interval)
	have "continuous_on {t0 .. t} ((\<lambda>t. infdist (flow t0 y t) seg))"
	using closed_segment_subset_existence_ivl t iv_defined
	by (force intro!: continuous_at_imp_continuous_on
	continuous_intros flow_continuous
	simp: closed_segment_eq_real_ivl)
	thus "closed ?out"
	by (simp add: continuous_on_closed_vimage)
	qed
	moreover
	have "t \<in> (\<lambda>t. infdist (flow t0 y t) seg) -` {e..} \<inter> {t0..t}"
	using flow_out \<open>t0 \<le> t\<close>
	by (auto simp: A_def)
	hence "?out \<noteq> {}"
	by blast
	ultimately have "\<exists>s\<in>?out. \<forall>t\<in>?out. s \<le> t"
	by (rule compact_attains_inf)
	then obtain t' where t':
	"\<And>s. e \<le> infdist (flow t0 y s) seg \<Longrightarrow> t0 \<le> s \<Longrightarrow> s \<le> t \<Longrightarrow> t' \<le> s"
	"e \<le> infdist (flow t0 y t') seg"
	"t0 \<le> t'" "t' \<le> t"
	by (auto simp: vimage_def Ball_def) metis
	have flow_in: "flow t0 x0 s \<in> A" if s: "s \<in> {t0 .. t'}" for s
	proof -
	from s have "s \<in> closed_segment t0 b"
	using \<open>t \<le> b\<close> t' by (auto simp: closed_segment_eq_real_ivl)
	then show ?thesis
	using s \<open>e > 0\<close> by (auto simp: seg_def A_def)
	qed
	have "flow t0 y t' \<in> A" if "t' = t0"
	using y d iv_defined that
	by (auto simp: A_def \<open>y \<in> X\<close> infdist_le2[where a=x0] dist_commute)
	moreover
	have "flow t0 y s \<in> A" if s: "s \<in> {t0 ..< t'}" for s
	proof -
	from s have "s \<in> closed_segment t0 b"
	using \<open>t \<le> b\<close> t' by (auto simp: closed_segment_eq_real_ivl)
	from t'(1)[of s]
	have "t' > s \<Longrightarrow> t0 \<le> s \<Longrightarrow> s \<le> t \<Longrightarrow> e > infdist (flow t0 y s) seg"
	by force
	then show ?thesis
	using s t' \<open>e > 0\<close> by (auto simp: seg_def A_def)
	qed
	moreover
	note left_of_in = this
	have "closed A" using \<open>compact A\<close> by (auto simp: compact_eq_bounded_closed)
	have "((\<lambda>s. flow t0 y s) \<longlongrightarrow> flow t0 y t') (at_left t')"
	using closed_segment_subset_existence_ivl[OF t(2)] t' \<open>y \<in> X\<close> iv_defined
	by (intro flow_tendsto) (auto intro!: tendsto_intros simp: closed_segment_eq_real_ivl)
	with \<open>closed A\<close> _ _ have "t' \<noteq> t0 \<Longrightarrow> flow t0 y t' \<in> A"
	proof (rule Lim_in_closed_set)
	assume "t' \<noteq> t0"
	hence "t' > t0" using t' by auto
	hence "eventually (\<lambda>x. x \<ge> t0) (at_left t')"
	by (metis eventually_at_left less_imp_le)
	thus "eventually (\<lambda>x. flow t0 y x \<in> A) (at_left t')"
	unfolding eventually_at_filter
	by eventually_elim (auto intro!: left_of_in)
	qed simp
	ultimately have flow_y_in: "s \<in> {t0 .. t'} \<Longrightarrow> flow t0 y s \<in> A" for s
	by (cases "s = t'"; fastforce)
	have
	"t0 \<le> t'"
	"t' \<le> t"
	"\<And>t. t \<in> {t0 .. t'} \<Longrightarrow> flow t0 x0 t \<in> A"
	"infdist (flow t0 y t') seg \<ge> e"
	"\<And>t. t \<in> {t0 .. t'} \<Longrightarrow> flow t0 y t \<in> A"
	by (auto intro!: flow_in flow_y_in) fact+
	thus ?thesis ..
	qed
	{
	fix s assume s: "s \<in> {t0 .. t'}"
	hence "t0 \<le> s" by simp
	have "s \<le> b"
	using t t' s b
	by auto
	hence sx0: "s \<in> existence_ivl t0 x0"
	by (simp add: \<open>t0 \<le> s\<close> mem_existence_ivlI)
	have sy: "s \<in> existence_ivl t0 y"
	by (meson atLeastAtMost_iff contra_subsetD s t'(1) t'(2) that(2) ivl_subset_existence_ivl)
	have int: "flow t0 y s - flow t0 x0 s =
	y - x0 + (integral {t0 .. s} (\<lambda>t. f t (flow t0 y t)) -
	integral {t0 .. s} (\<lambda>t. f t (flow t0 x0 t)))"
	using iv_defined s
	unfolding flow_fixed_point[OF sx0] flow_fixed_point[OF sy]
	by (simp add: algebra_simps ivl_integral_def)
	have "norm (flow t0 y s - flow t0 x0 s) \<le> norm (y - x0) +
	norm (integral {t0 .. s} (\<lambda>t. f t (flow t0 y t)) -
	integral {t0 .. s} (\<lambda>t. f t (flow t0 x0 t)))"
	unfolding int
	by (rule norm_triangle_ineq)
	also
	have "norm (integral {t0 .. s} (\<lambda>t. f t (flow t0 y t)) -
	integral {t0 .. s} (\<lambda>t. f t (flow t0 x0 t))) =
	norm (integral {t0 .. s} (\<lambda>t. f t (flow t0 y t) - f t (flow t0 x0 t)))"
	using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy
	by (subst Henstock_Kurzweil_Integration.integral_diff)
	(auto intro!: integrable_continuous_real continuous_at_imp_continuous_on
	f_flow_continuous
	simp: closed_segment_eq_real_ivl)
	also have "\<dots> \<le> (integral {t0 .. s} (\<lambda>t. norm (f t (flow t0 y t) - f t (flow t0 x0 t))))"
	using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy
	by (intro integral_norm_bound_integral)
	(auto intro!: integrable_continuous_real continuous_at_imp_continuous_on
	f_flow_continuous continuous_intros
	simp: closed_segment_eq_real_ivl)
	also have "\<dots> \<le> (integral {t0 .. s} (\<lambda>t. K * norm ((flow t0 y t) - (flow t0 x0 t))))"
	using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy
	iv_defined s t'(3,5) \<open>s \<le> b\<close>
	by (auto simp del: Henstock_Kurzweil_Integration.integral_mult_right intro!: integral_le integrable_continuous_real
	continuous_at_imp_continuous_on lipschitz_on_normD[OF K]
	flow_continuous f_flow_continuous continuous_intros
	simp: closed_segment_eq_real_ivl)
	also have "\<dots> = K * integral {t0 .. s} (\<lambda>t. norm (flow t0 y t - flow t0 x0 t))"
	using closed_segment_subset_existence_ivl[of s x0] sx0 closed_segment_subset_existence_ivl[of s y] sy
	by (subst integral_mult)
	(auto intro!: integrable_continuous_real continuous_at_imp_continuous_on
	lipschitz_on_normD[OF K] flow_continuous f_flow_continuous continuous_intros
	simp: closed_segment_eq_real_ivl)
	finally
	have norm: "norm (flow t0 y s - flow t0 x0 s) \<le>
	norm (y - x0) + K * integral {t0 .. s} (\<lambda>t. norm (flow t0 y t - flow t0 x0 t))"
	by arith
	note norm \<open>s \<le> b\<close> sx0 sy
	} note norm_le = this
	from norm_le(2) t' have "t' \<in> closed_segment t0 b"
	by (auto simp: closed_segment_eq_real_ivl)
	hence "infdist (flow t0 y t') seg \<le> dist (flow t0 y t') (flow t0 x0 t')"
	by (auto simp: seg_def infdist_le)
	also have "\<dots> \<le> norm (flow t0 y t' - flow t0 x0 t')"
	by (simp add: dist_norm)
	also have "\<dots> \<le> norm (y - x0) * exp (K * \<bar>t' - t0\<bar>)"
	unfolding K_def
	apply (rule exponential_initial_condition[OF _ _ _ _ _ K'])
	subgoal by (metis atLeastAtMost_iff local.norm_le(4) order_refl t'(1))
	subgoal by (metis atLeastAtMost_iff local.norm_le(3) order_refl t'(1))
	subgoal using e by (simp add: A_def)
	subgoal by (metis closed_segment_eq_real_ivl t'(1,5))
	subgoal by (metis closed_segment_eq_real_ivl t'(1,3))
	subgoal by (simp add: closed_segment_eq_real_ivl local.norm_le(2) t'(1))
	done
	also have "\<dots> < d * exp (K * (t - t0))"
	using y d t' t
	by (intro mult_less_le_imp_less)
	(auto simp: dist_norm[symmetric] dist_commute intro!: mult_mono \<open>0 \<le> K\<close>)
	also have "\<dots> \<le> e"
	by (rule d_times_exp_le; fact)
	finally
	have "infdist (flow t0 y t') seg < e" .
	with \<open>infdist (flow t0 y t') seg \<ge> e\<close> show False
	by (auto simp: frontier_def)
	qed

	have "{t0..b} \<subseteq> existence_ivl t0 y"
	by (rule subset_mem_compact_implies_subset_existence_interval[OF
	_ is_interval_cc \<open>{t0..b} \<subseteq> T\<close> \<open>y \<in> X\<close> in_A \<open>compact A\<close> \<open>A \<subseteq> X\<close>])
	(auto simp: \<open>t0 \<le> b\<close>)
	with \<open>t0 \<le> b\<close> have b_in: "b \<in> existence_ivl t0 y"
	by force
	{
	fix t assume t: "t \<in> {t0 .. b}"
	also have "{t0 .. b} = {t0 -- b}"
	by (auto simp: closed_segment_eq_real_ivl assms)
	also note closed_segment_subset_existence_ivl[OF b_in]
	finally have t_in: "t \<in> existence_ivl t0 y" .

	note t
	also note \<open>{t0 .. b} = {t0 -- b}\<close>
	also note closed_segment_subset_existence_ivl[OF assms(2)]
	finally have t_in': "t \<in> existence_ivl t0 x0" .
	have "norm (flow t0 y t - flow t0 x0 t) \<le> norm (y - x0) * exp (K * \<bar>t - t0\<bar>)"
	unfolding K_def
	using t closed_segment_subset_existence_ivl[OF b_in] \<open>0 < e\<close>
	by (intro in_A exponential_initial_condition[OF t_in t_in' \<open>A \<subseteq> X\<close> _ _ K'])
	(auto simp: closed_segment_eq_real_ivl A_def seg_def)
	hence "dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * \<bar>t - t0\<bar>)"
	by (auto simp: dist_norm[symmetric] dist_commute)
	}
	note b_in this
	} from \<open>d > 0\<close> \<open>K > 0\<close> \<open>ball x0 d \<subseteq> X\<close> this show ?thesis ..
	qed

	lemma
	global_left_existence_ivl_explicit:
	assumes "b \<le> t0"
	assumes b: "b \<in> existence_ivl t0 x0"
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	obtains d K where "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {b .. t0} \<Longrightarrow> dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	proof -
	interpret rev: ll_on_open "(preflect t0 ` T)" "(\<lambda>t. - f (preflect t0 t))" X ..
	have t0': "t0 \<in> preflect t0 ` T" "x0 \<in> X"
	by (auto intro!: iv_defined)
	from assms have "preflect t0 b \<ge> t0" "preflect t0 b \<in> rev.existence_ivl t0 x0"
	by (auto simp: rev_existence_ivl_eq)
	from rev.global_right_existence_ivl_explicit[OF this]
	obtain d K where dK: "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> preflect t0 b \<in> rev.existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {t0 .. preflect t0 b} \<Longrightarrow> dist (rev.flow t0 x0 t) (rev.flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	by (auto simp: rev_flow_eq \<open>x0 \<in> X\<close>)

	have ex_ivlI: "dist x0 y < d \<Longrightarrow> t \<in> existence_ivl t0 y" if "b \<le> t" "t \<le> t0" for t y
	using that dK(4)[of y] dK(3) iv_defined
	by (auto simp: subset_iff rev_existence_ivl_eq[of ]
	closed_segment_eq_real_ivl iv_defined in_existence_between_zeroI)
	have "b \<in> existence_ivl t0 y" if "dist x0 y < d" for y
	using that dK
	by (subst existence_ivl_eq_rev) (auto simp: iv_defined intro!: image_eqI[where x="preflect t0 b"])
	with dK have "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {b .. t0} \<Longrightarrow> dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	by (auto simp: flow_eq_rev iv_defined ex_ivlI \<open>x0 \<in> X\<close> subset_iff
	intro!: order_trans[OF dK(5)] image_eqI[where x="preflect t0 b"])
	then show ?thesis ..
	qed

	lemma
	global_existence_ivl_explicit:
	assumes a: "a \<in> existence_ivl t0 x0"
	assumes b: "b \<in> existence_ivl t0 x0"
	assumes le: "a \<le> b"
	obtains d K where "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> a \<in> existence_ivl t0 y"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {a .. b} \<Longrightarrow>
	dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	proof -
	note iv_defined = mem_existence_ivl_iv_defined[OF a]
	define r where "r \<equiv> Max {t0, a, b}"
	define l where "l \<equiv> Min {t0, a, b}"
	have r: "r \<ge> t0" "r \<in> existence_ivl t0 x0"
	using a b by (auto simp: max_def r_def iv_defined)
	obtain dr Kr where right:
	"0 < dr" "0 < Kr" "ball x0 dr \<subseteq> X"
	"\<And>y. y \<in> ball x0 dr \<Longrightarrow> r \<in> existence_ivl t0 y"
	"\<And>y t. y \<in> ball x0 dr \<Longrightarrow> t \<in> {t0..r} \<Longrightarrow> dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (Kr * \<bar>t - t0\<bar>)"
	by (rule global_right_existence_ivl_explicit[OF r]) blast

	have l: "l \<le> t0" "l \<in> existence_ivl t0 x0"
	using a b by (auto simp: min_def l_def iv_defined)
	obtain dl Kl where left:
	"0 < dl" "0 < Kl" "ball x0 dl \<subseteq> X"
	"\<And>y. y \<in> ball x0 dl \<Longrightarrow> l \<in> existence_ivl t0 y"
	"\<And>y t. y \<in> ball x0 dl \<Longrightarrow> t \<in> {l .. t0} \<Longrightarrow> dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (Kl * \<bar>t - t0\<bar>)"
	by (rule global_left_existence_ivl_explicit[OF l iv_defined]) blast

	define d where "d \<equiv> min dr dl"
	define K where "K \<equiv> max Kr Kl"

	note iv_defined
	have "0 < d" "0 < K" "ball x0 d \<subseteq> X"
	using left right by (auto simp: d_def K_def)
	moreover
	{
	fix y assume y: "y \<in> ball x0 d"
	hence "y \<in> X" using \<open>ball x0 d \<subseteq> X\<close> by auto
	from y
	closed_segment_subset_existence_ivl[OF left(4), of y]
	closed_segment_subset_existence_ivl[OF right(4), of y]
	have "a \<in> existence_ivl t0 y" "b \<in> existence_ivl t0 y"
	by (auto simp: d_def l_def r_def min_def max_def closed_segment_eq_real_ivl split: if_split_asm)
	}
	moreover
	{
	fix t y
	assume y: "y \<in> ball x0 d"
	and t: "t \<in> {a .. b}"
	from y have "y \<in> X" using \<open>ball x0 d \<subseteq> X\<close> by auto
	have "dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	proof cases
	assume "t \<ge> t0"
	hence "dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (Kr * abs (t - t0))"
	using y t
	by (intro right) (auto simp: d_def r_def)
	also have "exp (Kr * abs (t - t0)) \<le> exp (K * abs (t - t0))"
	by (auto simp: mult_left_mono K_def max_def mult_right_mono)
	finally show ?thesis by (simp add: mult_left_mono)
	next
	assume "\<not>t \<ge> t0"
	hence "dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (Kl * abs (t - t0))"
	using y t
	by (intro left) (auto simp: d_def l_def)
	also have "exp (Kl * abs (t - t0)) \<le> exp (K * abs (t - t0))"
	by (auto simp: mult_left_mono K_def max_def mult_right_mono)
	finally show ?thesis by (simp add: mult_left_mono)
	qed
	} ultimately show ?thesis ..
	qed

	lemma eventually_exponential_separation:
	assumes a: "a \<in> existence_ivl t0 x0"
	assumes b: "b \<in> existence_ivl t0 x0"
	assumes le: "a \<le> b"
	obtains K where "K > 0" "\<forall>\<^sub>F y in at x0. \<forall>t\<in>{a..b}. dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * \<bar>t - t0\<bar>)"
	proof -
	from global_existence_ivl_explicit[OF assms]
	obtain d K where *: "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> a \<in> existence_ivl t0 y"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {a .. b} \<Longrightarrow>
	dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	by auto
	note \<open>K > 0\<close>
	moreover
	have "eventually (\<lambda>y. y \<in> ball x0 d) (at x0)"
	using \<open>d > 0\<close>[THEN eventually_at_ball]
	by eventually_elim simp
	hence "eventually (\<lambda>y. \<forall>t\<in>{a..b}. dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * \<bar>t - t0\<bar>)) (at x0)"
	by eventually_elim (safe intro!: *)
	ultimately show ?thesis ..
	qed

	lemma eventually_mem_existence_ivl:
	assumes b: "b \<in> existence_ivl t0 x0"
	shows "\<forall>\<^sub>F x in at x0. b \<in> existence_ivl t0 x"
	proof -
	from mem_existence_ivl_iv_defined[OF b] have iv_defined: "t0 \<in> T" "x0 \<in> X" by simp_all
	note eiit = existence_ivl_initial_time[OF iv_defined]
	{
	fix a b
	assume assms: "a \<in> existence_ivl t0 x0" "b \<in> existence_ivl t0 x0" "a \<le> b"
	from global_existence_ivl_explicit[OF assms]
	obtain d K where *: "d > 0" "K > 0"
	"ball x0 d \<subseteq> X"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> a \<in> existence_ivl t0 y"
	"\<And>y. y \<in> ball x0 d \<Longrightarrow> b \<in> existence_ivl t0 y"
	"\<And>t y. y \<in> ball x0 d \<Longrightarrow> t \<in> {a .. b} \<Longrightarrow>
	dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * abs (t - t0))"
	by auto
	have "eventually (\<lambda>y. y \<in> ball x0 d) (at x0)"
	using \<open>d > 0\<close>[THEN eventually_at_ball]
	by eventually_elim simp
	then have "\<forall>\<^sub>F x in at x0. a \<in> existence_ivl t0 x \<and> b \<in> existence_ivl t0 x"
	by (eventually_elim) (auto intro!: *)
	} from this[OF b eiit] this[OF eiit b]
	show ?thesis
	by (cases "t0 \<le> b") (auto simp: eventually_mono)
	qed

	lemma uniform_limit_flow:
	assumes a: "a \<in> existence_ivl t0 x0"
	assumes b: "b \<in> existence_ivl t0 x0"
	assumes le: "a \<le> b"
	shows "uniform_limit {a .. b} (flow t0) (flow t0 x0) (at x0)"
	proof (rule uniform_limitI)
	fix e::real assume "0 < e"
	from eventually_exponential_separation[OF assms] obtain K where "0 < K"
	"\<forall>\<^sub>F y in at x0. \<forall>t\<in>{a..b}. dist (flow t0 x0 t) (flow t0 y t) \<le> dist x0 y * exp (K * \<bar>t - t0\<bar>)"
	by auto
	note this(2)
	moreover
	let ?m = "max (abs (b - t0)) (abs (a - t0))"
	have "eventually (\<lambda>y. \<forall>t\<in>{a..b}. dist x0 y * exp (K * \<bar>t - t0\<bar>) \<le> dist x0 y * exp (K * ?m)) (at x0)"
	using \<open>a \<le> b\<close> \<open>0 < K\<close>
	by (auto intro!: mult_left_mono always_eventually)
	moreover
	have "eventually (\<lambda>y. dist x0 y * exp (K * ?m) < e) (at x0)"
	using \<open>0 < e\<close> by (auto intro!: order_tendstoD tendsto_eq_intros)
	ultimately
	show "eventually (\<lambda>y. \<forall>t\<in>{a..b}. dist (flow t0 y t) (flow t0 x0 t) < e) (at x0)"
	by eventually_elim (force simp: dist_commute)
	qed

	lemma eventually_at_fst:
	assumes "eventually P (at (fst x))"
	assumes "P (fst x)"
	shows "eventually (\<lambda>h. P (fst h)) (at x)"
	using assms
	unfolding eventually_at_topological
	by (metis open_vimage_fst rangeI range_fst vimageE vimageI)

	lemma eventually_at_snd:
	assumes "eventually P (at (snd x))"
	assumes "P (snd x)"
	shows "eventually (\<lambda>h. P (snd h)) (at x)"
	using assms
	unfolding eventually_at_topological
	by (metis open_vimage_snd rangeI range_snd vimageE vimageI)

	lemma
	shows open_state_space: "open (Sigma X (existence_ivl t0))"
	and flow_continuous_on_state_space:
	"continuous_on (Sigma X (existence_ivl t0)) (\<lambda>(x, t). flow t0 x t)"
	proof (safe intro!: topological_space_class.openI continuous_at_imp_continuous_on)
	fix t x assume "x \<in> X" and t: "t \<in> existence_ivl t0 x"
	have iv_defined: "t0 \<in> T" "x \<in> X"
	using mem_existence_ivl_iv_defined[OF t] by auto
	from \<open>x \<in> X\<close> t open_existence_ivl
	obtain e where e: "e > 0" "cball t e \<subseteq> existence_ivl t0 x"
	by (metis open_contains_cball)
	hence ivl: "t - e \<in> existence_ivl t0 x" "t + e \<in> existence_ivl t0 x" "t - e \<le> t + e"
	by (auto simp: cball_def dist_real_def)
	obtain d K where dK:
	"0 < d" "0 < K" "ball x d \<subseteq> X"
	"\<And>y. y \<in> ball x d \<Longrightarrow> t - e \<in> existence_ivl t0 y"
	"\<And>y. y \<in> ball x d \<Longrightarrow> t + e \<in> existence_ivl t0 y"
	"\<And>y s. y \<in> ball x d \<Longrightarrow> s \<in> {t - e..t + e} \<Longrightarrow>
	dist (flow t0 x s) (flow t0 y s) \<le> dist x y * exp (K * \<bar>s - t0\<bar>)"
	by (rule global_existence_ivl_explicit[OF ivl]) blast
	let ?T = "ball x d \<times> ball t e"
	have "open ?T" by (auto intro!: open_Times)
	moreover have "(x, t) \<in> ?T" by (auto simp: dK \<open>0 < e\<close>)
	moreover have "?T \<subseteq> Sigma X (existence_ivl t0)"
	proof safe
	fix s y assume y: "y \<in> ball x d" and s: "s \<in> ball t e"
	with \<open>ball x d \<subseteq> X\<close> show "y \<in> X" by auto
	have "ball t e \<subseteq> closed_segment t0 (t - e) \<union> closed_segment t0 (t + e)"
	by (auto simp: closed_segment_eq_real_ivl dist_real_def)
	with \<open>y \<in> X\<close> s closed_segment_subset_existence_ivl[OF dK(4)[OF y]]
	closed_segment_subset_existence_ivl[OF dK(5)[OF y]]
	show "s \<in> existence_ivl t0 y"
	by auto
	qed
	ultimately show "\<exists>T. open T \<and> (x, t) \<in> T \<and> T \<subseteq> Sigma X (existence_ivl t0)"
	by blast
	have *: "\<forall>\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) < 2 eps"
	if "eps > 0" for eps :: real
	proof -
	have "\<forall>\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) =
	norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s) +
	(flow t0 x (t + snd s) - flow t0 x t))"
	by auto
	moreover
	have "\<forall>\<^sub>F s in at 0.
	norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s) +
	(flow t0 x (t + snd s) - flow t0 x t)) \<le>
	norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s)) +
	norm (flow t0 x (t + snd s) - flow t0 x t)"
	by eventually_elim (rule norm_triangle_ineq)
	moreover
	have "\<forall>\<^sub>F s in at 0. t + snd s \<in> ball t e"
	by (auto simp: dist_real_def intro!: order_tendstoD[OF _ \<open>0 < e\<close>]
	intro!: tendsto_eq_intros)
	moreover from uniform_limit_flow[OF ivl, THEN uniform_limitD, OF \<open>eps > 0\<close>]
	have "\<forall>\<^sub>F (h::(_ )) in at (fst (0::'a*real)).
	\<forall>t\<in>{t - e..t + e}. dist (flow t0 x t) (flow t0 (x + h) t) < eps"
	by (subst (asm) at_to_0)
	(auto simp: eventually_filtermap dist_commute ac_simps)
	hence "\<forall>\<^sub>F (h::(_ * real)) in at 0.
	\<forall>t\<in>{t - e..t + e}. dist (flow t0 x t) (flow t0 (x + fst h) t) < eps"
	by (rule eventually_at_fst) (simp add: \<open>eps > 0\<close>)
	moreover
	have "\<forall>\<^sub>F h in at (snd (0::'a * _)). norm (flow t0 x (t + h) - flow t0 x t) < eps"
	using flow_continuous[OF t, unfolded isCont_def, THEN tendstoD, OF \<open>eps > 0\<close>]
	by (subst (asm) at_to_0)
	(auto simp: eventually_filtermap dist_norm ac_simps)
	hence "\<forall>\<^sub>F h::('a * _) in at 0. norm (flow t0 x (t + snd h) - flow t0 x t) < eps"
	by (rule eventually_at_snd) (simp add: \<open>eps > 0\<close>)
	ultimately
	show ?thesis
	proof eventually_elim
	case (elim s)
	note elim(1)
	also note elim(2)
	also note elim(5)
	also
	from elim(3) have "t + snd s \<in> {t - e..t + e}"
	by (auto simp: dist_real_def algebra_simps)
	from elim(4)[rule_format, OF this]
	have "norm (flow t0 (x + fst s) (t + snd s) - flow t0 x (t + snd s)) < eps"
	by (auto simp: dist_commute dist_norm[symmetric])
	finally
	show ?case by simp
	qed
	qed
	have *: "\<forall>\<^sub>F s in at 0. norm (flow t0 (x + fst s) (t + snd s) - flow t0 x t) < eps"
	if "eps > 0" for eps::real
	proof -
	from that have "eps / 2 > 0" by simp
	from **[OF this] show ?thesis by auto
	qed
	show "isCont (\<lambda>(x, y). flow t0 x y) (x, t)"
	unfolding isCont_iff
	by (rule LIM_zero_cancel)
	(auto simp: split_beta' norm_conv_dist[symmetric] intro!: tendstoI *)
	qed

	lemmas flow_continuous_on_compose[continuous_intros] =
	continuous_on_compose_Pair[OF flow_continuous_on_state_space]

	lemma flow_isCont_state_space: "t \<in> existence_ivl t0 x0 \<Longrightarrow> isCont (\<lambda>(x, t). flow t0 x t) (x0, t)"
	using flow_continuous_on_state_space[of] mem_existence_ivl_iv_defined[of t x0]
	using continuous_on_eq_continuous_at open_state_space by fastforce

	lemma
	flow_absolutely_integrable_on[integrable_on_simps]:
	assumes "s \<in> existence_ivl t0 x0"
	shows "(\<lambda>x. norm (flow t0 x0 x)) integrable_on closed_segment t0 s"
	using assms
	by (auto simp: closed_segment_eq_real_ivl intro!: integrable_continuous_real continuous_intros
	flow_continuous_on_intro
	intro: in_existence_between_zeroI)

	lemma existence_ivl_eq_domain:
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	assumes bnd: "\<And>tm tM t x. tm \<in> T \<Longrightarrow> tM \<in> T \<Longrightarrow> \<exists>M. \<exists>L. \<forall>t \<in> {tm .. tM}. \<forall>x \<in> X. norm (f t x) \<le> M + L * norm x"
	assumes "is_interval T" "X = UNIV"
	shows "existence_ivl t0 x0 = T"
	proof -
	from assms have XI: "x \<in> X" for x by auto
	{
	fix tm tM assume tm: "tm \<in> T" and tM: "tM \<in> T" and tmtM: "tm \<le> t0" "t0 \<le> tM"
	from bnd[OF tm tM] obtain M' L'
	where bnd': "\<And>x t. x \<in> X \<Longrightarrow> tm \<le> t \<Longrightarrow> t \<le> tM \<Longrightarrow> norm (f t x) \<le> M' + L' * norm x"
	by force
	define M where "M \<equiv> norm M' + 1"
	define L where "L \<equiv> norm L' + 1"
	have bnd: "\<And>x t. x \<in> X \<Longrightarrow> tm \<le> t \<Longrightarrow> t \<le> tM \<Longrightarrow> norm (f t x) \<le> M + L * norm x"
	by (auto simp: M_def L_def intro!: bnd'[THEN order_trans] add_mono mult_mono)
	have "M > 0" "L > 0" by (auto simp: L_def M_def)

	let ?r = "(norm x0 + \<bar>tm - tM\<bar> * M + 1) * exp (L * \<bar>tm - tM\<bar>)"
	define K where "K \<equiv> cball (0::'a) ?r"
	have K: "compact K" "K \<subseteq> X"
	by (auto simp: K_def \<open>X = UNIV\<close>)
	{
	fix t assume t: "t \<in> existence_ivl t0 x0" and le: "tm \<le> t" "t \<le> tM"
	{
	fix s assume sc: "s \<in> closed_segment t0 t"
	then have s: "s \<in> existence_ivl t0 x0" and le: "tm \<le> s" "s \<le> tM" using t le sc
	using closed_segment_subset_existence_ivl
	apply -
	subgoal by force
	subgoal by (metis (full_types) atLeastAtMost_iff closed_segment_eq_real_ivl order_trans tmtM(1))
	subgoal by (metis (full_types) atLeastAtMost_iff closed_segment_eq_real_ivl order_trans tmtM(2))
	done
	from sc have nle: "norm (t0 - s) \<le> norm (t0 - t)" by (auto simp: closed_segment_eq_real_ivl split: if_split_asm)
	from flow_fixed_point[OF s]
	have "norm (flow t0 x0 s) \<le> norm x0 + integral (closed_segment t0 s) (\<lambda>t. M + L * norm (flow t0 x0 t))"
	using tmtM
	using closed_segment_subset_existence_ivl[OF s] le
	by (auto simp:
	intro!: norm_triangle_le norm_triangle_ineq4[THEN order.trans]
	ivl_integral_norm_bound_integral bnd
	integrable_continuous_closed_segment
	integrable_continuous_real
	continuous_intros
	continuous_on_subset[OF flow_continuous_on]
	flow_in_domain
	mem_existence_ivl_subset)
	(auto simp: closed_segment_eq_real_ivl split: if_splits)
	also have "\<dots> = norm x0 + norm (t0 - s) * M + L * integral (closed_segment t0 s) (\<lambda>t. norm (flow t0 x0 t))"
	by (simp add: integral_add integrable_on_simps \<open>s \<in> existence_ivl _ _\<close>
	integral_const_closed_segment abs_minus_commute)
	also have "norm (t0 - s) * M \<le> norm (t0 - t) * M "
	using nle \<open>M > 0\<close> by auto
	also have "\<dots> \<le> \<dots> + 1" by simp
	finally have "norm (flow t0 x0 s) \<le> norm x0 + norm (t0 - t) * M + 1 +
	L * integral (closed_segment t0 s) (\<lambda>t. norm (flow t0 x0 t))" by simp
	}
	then have "norm (flow t0 x0 t) \<le> (norm x0 + norm (t0 - t) * M + 1) * exp (L * \<bar>t - t0\<bar>)"
	using closed_segment_subset_existence_ivl[OF t]
	by (intro gronwall_more_general_segment[where a=t0 and b = t and t = t])
	(auto simp: \<open>0 < L\<close> \<open>0 < M\<close> less_imp_le
	intro!: add_nonneg_pos mult_nonneg_nonneg add_nonneg_nonneg continuous_intros
	flow_continuous_on_intro)
	also have "\<dots> \<le> ?r"
	using le tmtM
	by (auto simp: less_imp_le \<open>0 < M\<close> \<open>0 < L\<close> abs_minus_commute intro!: mult_mono)
	finally
	have "flow t0 x0 t \<in> K" by (simp add: dist_norm K_def)
	} note flow_compact = this

	have "{tm..tM} \<subseteq> existence_ivl t0 x0"
	using tmtM tm \<open>x0 \<in> X\<close> \<open>compact K\<close> \<open>K \<subseteq> X\<close> mem_is_intervalI[OF \<open>is_interval T\<close> \<open>tm \<in> T\<close> \<open>tM \<in> T\<close>]
	by (intro subset_mem_compact_implies_subset_existence_interval[OF _ _ _ _flow_compact])
	(auto simp: tmtM is_interval_cc)
	} note bnds = this

	show "existence_ivl t0 x0 = T"
	proof safe
	fix x assume x: "x \<in> T"
	from bnds[OF x iv_defined(1)] bnds[OF iv_defined(1) x]
	show "x \<in> existence_ivl t0 x0"
	by (cases "x \<le> t0") auto
	qed (insert existence_ivl_subset, fastforce)
	qed

	lemma flow_unique:
	assumes "t \<in> existence_ivl t0 x0"
	assumes "phi t0 = x0"
	assumes "\<And>t. t \<in> existence_ivl t0 x0 \<Longrightarrow> (phi has_vector_derivative f t (phi t)) (at t)"
	assumes "\<And>t. t \<in> existence_ivl t0 x0 \<Longrightarrow> phi t \<in> X"
	shows "flow t0 x0 t = phi t"
	apply (rule maximal_existence_flow[where K="existence_ivl t0 x0"])
	subgoal by (auto intro!: solves_odeI simp: has_vderiv_on_def assms at_within_open[OF _ open_existence_ivl])
	subgoal by fact
	- subgoal by (simp add: )
	+ subgoal by simp
	subgoal using mem_existence_ivl_iv_defined[OF \<open>t \<in> existence_ivl t0 x0\<close>] by simp
	subgoal by (simp add: existence_ivl_subset)
	subgoal by fact
	done

	lemma flow_unique_on:
	assumes "t \<in> existence_ivl t0 x0"
	assumes "phi t0 = x0"
	assumes "(phi has_vderiv_on (\<lambda>t. f t (phi t))) (existence_ivl t0 x0)"
	assumes "\<And>t. t \<in> existence_ivl t0 x0 \<Longrightarrow> phi t \<in> X"
	shows "flow t0 x0 t = phi t"
	using flow_unique[where phi=phi, OF assms(1,2) _ assms(4)] assms(3)
	by (auto simp: has_vderiv_on_open)

	end \<comment> \<open>@{thm local_lipschitz}\<close>

	locale two_ll_on_open =
	F: ll_on_open T1 F X + G: ll_on_open T2 G X
	for F T1 G T2 X J x0 +
	fixes e::real and K
	assumes t0_in_J: "0 \<in> J"
	assumes J_subset: "J \<subseteq> F.existence_ivl 0 x0"
	assumes J_ivl: "is_interval J"
	assumes F_lipschitz: "\<And>t. t \<in> J \<Longrightarrow> K-lipschitz_on X (F t)"
	assumes K_pos: "0 < K"
	assumes F_G_norm_ineq: "\<And>t x. t \<in> J \<Longrightarrow> x \<in> X \<Longrightarrow> norm (F t x - G t x) < e"
	begin

	context begin

	lemma F_iv_defined: "0 \<in> T1" "x0 \<in> X"
	subgoal using F.existence_ivl_initial_time_iff J_subset t0_in_J by blast
	subgoal using F.mem_existence_ivl_iv_defined(2) J_subset t0_in_J by blast
	done

	lemma e_pos: "0 < e"
	using le_less_trans[OF norm_ge_zero F_G_norm_ineq[OF t0_in_J F_iv_defined(2)]]
	by assumption

	qualified definition "flow0 t = F.flow 0 x0 t"
	qualified definition "Y t = G.flow 0 x0 t"

	lemma norm_X_Y_bound:
	shows "\<forall>t \<in> J \<inter> G.existence_ivl 0 x0. norm (flow0 t - Y t) \<le> e / K * (exp(K * \<bar>t\<bar>) - 1)"
	proof(safe)
	fix t assume "t \<in> J"
	assume tG: "t \<in> G.existence_ivl 0 x0"
	have "0 \<in> J" by (simp add: t0_in_J)

	let ?u="\<lambda>t. norm (flow0 t - Y t)"
	show "norm (flow0 t - Y t) \<le> e / K * (exp (K * \<bar>t\<bar>) - 1)"
	proof(cases "0 \<le> t")
	assume "0 \<le> t"
	hence [simp]: "\<bar>t\<bar> = t" by simp

	have t0_t_in_J: "{0..t} \<subseteq> J"
	using \<open>t \<in> J\<close> \<open>0 \<in> J\<close> J_ivl
	using mem_is_interval_1_I atLeastAtMost_iff subsetI by blast

	note F_G_flow_cont[continuous_intros] =
	continuous_on_subset[OF F.flow_continuous_on]
	continuous_on_subset[OF G.flow_continuous_on]

	have "?u t + e/K \<le> e/K * exp(K * t)"
	proof(rule gronwall[where g="\<lambda>t. ?u t + e/K", OF _ _ _ _ K_pos \<open>0 \<le> t\<close> order.refl])
	fix s assume "0 \<le> s" "s \<le> t"
	hence "{0..s} \<subseteq> J" using t0_t_in_J by auto

	hence t0_s_in_existence:
	"{0..s} \<subseteq> F.existence_ivl 0 x0"
	"{0..s} \<subseteq> G.existence_ivl 0 x0"
	using J_subset tG \<open>0 \<le> s\<close> \<open>s \<le> t\<close> G.ivl_subset_existence_ivl[OF tG]
	by auto

	hence s_in_existence:
	"s \<in> F.existence_ivl 0 x0"
	"s \<in> G.existence_ivl 0 x0"
	using \<open>0 \<le> s\<close> by auto

	note cont_statements[continuous_intros] =
	F_iv_defined (* G.iv_defined *)
	F.flow_in_domain
	G.flow_in_domain
	F.mem_existence_ivl_subset
	G.mem_existence_ivl_subset

	have [integrable_on_simps]:
	"continuous_on {0..s} (\<lambda>s. F s (F.flow 0 x0 s))"
	"continuous_on {0..s} (\<lambda>s. G s (G.flow 0 x0 s))"
	"continuous_on {0..s} (\<lambda>s. F s (G.flow 0 x0 s))"
	"continuous_on {0..s} (\<lambda>s. G s (F.flow 0 x0 s))"
	using t0_s_in_existence
	by (auto intro!: continuous_intros integrable_continuous_real)

	have "flow0 s - Y s = integral {0..s} (\<lambda>s. F s (flow0 s) - G s (Y s))"
	using \<open>0 \<le> s\<close>
	by (simp add: flow0_def Y_def Henstock_Kurzweil_Integration.integral_diff integrable_on_simps ivl_integral_def
	F.flow_fixed_point[OF s_in_existence(1)]
	G.flow_fixed_point[OF s_in_existence(2)])
	also have "... = integral {0..s} (\<lambda>s. (F s (flow0 s) - F s (Y s)) + (F s (Y s) - G s (Y s)))"
	by simp
	also have "... = integral {0..s} (\<lambda>s. F s (flow0 s) - F s (Y s)) + integral {0..s} (\<lambda>s. F s (Y s) - G s (Y s))"
	by (simp add: Henstock_Kurzweil_Integration.integral_diff Henstock_Kurzweil_Integration.integral_add flow0_def Y_def integrable_on_simps)
	finally have "?u s \<le> norm (integral {0..s} (\<lambda>s. F s (flow0 s) - F s (Y s))) + norm (integral {0..s} (\<lambda>s. F s (Y s) - G s (Y s)))"
	by (simp add: norm_triangle_ineq)
	also have "... \<le> integral {0..s} (\<lambda>s. norm (F s (flow0 s) - F s (Y s))) + integral {0..s} (\<lambda>s. norm (F s (Y s) - G s (Y s)))"
	using t0_s_in_existence
	by (auto simp add: flow0_def Y_def
	intro!: add_mono continuous_intros continuous_on_imp_absolutely_integrable_on)
	also have "... \<le> integral {0..s} (\<lambda>s. K * ?u s) + integral {0..s} (\<lambda>s. e)"
	proof (rule add_mono[OF integral_le integral_le])
	show "norm (F x (flow0 x) - F x (Y x)) \<le> K * norm (flow0 x - Y x)" if "x \<in> {0..s}" for x
	using F_lipschitz[unfolded lipschitz_on_def, THEN conjunct2] that
	cont_statements(1,2,4)
	t0_s_in_existence F_iv_defined (* G.iv_defined *)
	by (metis F_lipschitz flow0_def Y_def \<open>{0..s} \<subseteq> J\<close> lipschitz_on_normD F.flow_in_domain
	G.flow_in_domain subsetCE)
	show "\<And>x. x \<in> {0..s} \<Longrightarrow> norm (F x (Y x) - G x (Y x)) \<le> e"
	using F_G_norm_ineq cont_statements(2,3) t0_s_in_existence
	using Y_def \<open>{0..s} \<subseteq> J\<close> cont_statements(5) subset_iff G.flow_in_domain
	by (metis eucl_less_le_not_le)
	qed (simp_all add: t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def)
	also have "... = K * integral {0..s} (\<lambda>s. ?u s + e / K)"
	using K_pos t0_s_in_existence
	by (simp_all add: algebra_simps Henstock_Kurzweil_Integration.integral_add flow0_def Y_def continuous_intros
	continuous_on_imp_absolutely_integrable_on)
	finally show "?u s + e / K \<le> e / K + K * integral {0..s} (\<lambda>s. ?u s + e / K)"
	by simp
	next
	show "continuous_on {0..t} (\<lambda>t. norm (flow0 t - Y t) + e / K)"
	using t0_t_in_J J_subset G.ivl_subset_existence_ivl[OF tG]
	by (auto simp add: flow0_def Y_def intro!: continuous_intros)
	next
	fix s assume "0 \<le> s" "s \<le> t"
	show "0 \<le> norm (flow0 s - Y s) + e / K"
	using e_pos K_pos by simp
	next
	show "0 < e / K" using e_pos K_pos by simp
	qed
	thus ?thesis by (simp add: algebra_simps)
	next
	assume "\<not>0 \<le> t"
	hence "t \<le> 0" by simp
	hence [simp]: "\<bar>t\<bar> = -t" by simp

	have t0_t_in_J: "{t..0} \<subseteq> J"
	using \<open>t \<in> J\<close> \<open>0 \<in> J\<close> J_ivl \<open>\<not> 0 \<le> t\<close> atMostAtLeast_subset_convex is_interval_convex_1
	by auto

	note F_G_flow_cont[continuous_intros] =
	continuous_on_subset[OF F.flow_continuous_on]
	continuous_on_subset[OF G.flow_continuous_on]

	have "?u t + e/K \<le> e/K * exp(- K * t)"
	proof(rule gronwall_left[where g="\<lambda>t. ?u t + e/K", OF _ _ _ _ K_pos order.refl \<open>t \<le> 0\<close>])
	fix s assume "t \<le> s" "s \<le> 0"
	hence "{s..0} \<subseteq> J" using t0_t_in_J by auto

	hence t0_s_in_existence:
	"{s..0} \<subseteq> F.existence_ivl 0 x0"
	"{s..0} \<subseteq> G.existence_ivl 0 x0"
	using J_subset G.ivl_subset_existence_ivl'[OF tG] \<open>s \<le> 0\<close> \<open>t \<le> s\<close>
	by auto

	hence s_in_existence:
	"s \<in> F.existence_ivl 0 x0"
	"s \<in> G.existence_ivl 0 x0"
	using \<open>s \<le> 0\<close> by auto

	note cont_statements[continuous_intros] =
	F_iv_defined
	F.flow_in_domain
	G.flow_in_domain
	F.mem_existence_ivl_subset
	G.mem_existence_ivl_subset
	then have [continuous_intros]:
	"{s..0} \<subseteq> T1"
	"{s..0} \<subseteq> T2"
	"F.flow 0 x0 ` {s..0} \<subseteq> X"
	"G.flow 0 x0 ` {s..0} \<subseteq> X"
	"s \<le> x \<Longrightarrow> x \<le> 0 \<Longrightarrow> x \<in> F.existence_ivl 0 x0"
	"s \<le> x \<Longrightarrow> x \<le> 0 \<Longrightarrow> x \<in> G.existence_ivl 0 x0" for x
	using t0_s_in_existence
	- by (auto simp: )
	+ by auto
	have "flow0 s - Y s = - integral {s..0} (\<lambda>s. F s (flow0 s) - G s (Y s))"
	using t0_s_in_existence \<open>s \<le> 0\<close>
	by (simp add: flow0_def Y_def ivl_integral_def
	F.flow_fixed_point[OF s_in_existence(1)]
	G.flow_fixed_point[OF s_in_existence(2)]
	continuous_intros integrable_on_simps Henstock_Kurzweil_Integration.integral_diff)
	also have "... = - integral {s..0} (\<lambda>s. (F s (flow0 s) - F s (Y s)) + (F s (Y s) - G s (Y s)))"
	by simp
	also have "... = - (integral {s..0} (\<lambda>s. F s (flow0 s) - F s (Y s)) + integral {s..0} (\<lambda>s. F s (Y s) - G s (Y s)))"
	using t0_s_in_existence
	by (subst Henstock_Kurzweil_Integration.integral_add) (simp_all add: integral_add flow0_def Y_def continuous_intros integrable_on_simps)
	finally have "?u s \<le> norm (integral {s..0} (\<lambda>s. F s (flow0 s) - F s (Y s))) + norm (integral {s..0} (\<lambda>s. F s (Y s) - G s (Y s)))"
	by (metis (no_types, lifting) norm_minus_cancel norm_triangle_ineq)
	also have "... \<le> integral {s..0} (\<lambda>s. norm (F s (flow0 s) - F s (Y s))) + integral {s..0} (\<lambda>s. norm (F s (Y s) - G s (Y s)))"
	using t0_s_in_existence
	by (auto simp add: flow0_def Y_def intro!: continuous_intros continuous_on_imp_absolutely_integrable_on add_mono)
	also have "... \<le> integral {s..0} (\<lambda>s. K * ?u s) + integral {s..0} (\<lambda>s. e)"
	proof (rule add_mono[OF integral_le integral_le])
	show "norm (F x (flow0 x) - F x (Y x)) \<le> K * norm (flow0 x - Y x)" if "x\<in>{s..0}" for x
	using F_lipschitz[unfolded lipschitz_on_def, THEN conjunct2]
	cont_statements(1,2,4) that
	t0_s_in_existence F_iv_defined (* G.iv_defined *)
	by (metis F_lipschitz flow0_def Y_def \<open>{s..0} \<subseteq> J\<close> lipschitz_on_normD F.flow_in_domain
	G.flow_in_domain subsetCE)
	show "\<And>x. x \<in> {s..0} \<Longrightarrow> norm (F x (Y x) - G x (Y x)) \<le> e"
	using F_G_norm_ineq Y_def \<open>{s..0} \<subseteq> J\<close> cont_statements(5) subset_iff t0_s_in_existence(2)
	using Y_def \<open>{s..0} \<subseteq> J\<close> cont_statements(5) subset_iff G.flow_in_domain
	by (metis eucl_less_le_not_le)
	qed (simp_all add: t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def)
	also have "... = K * integral {s..0} (\<lambda>s. ?u s + e / K)"
	using K_pos t0_s_in_existence
	by (simp_all add: algebra_simps Henstock_Kurzweil_Integration.integral_add t0_s_in_existence continuous_intros integrable_on_simps flow0_def Y_def)
	finally show "?u s + e / K \<le> e / K + K * integral {s..0} (\<lambda>s. ?u s + e / K)"
	by simp
	next
	show "continuous_on {t..0} (\<lambda>t. norm (flow0 t - Y t) + e / K)"
	using t0_t_in_J J_subset G.ivl_subset_existence_ivl'[OF tG] F_iv_defined
	by (auto simp add: flow0_def Y_def intro!: continuous_intros)
	next
	fix s assume "t \<le> s" "s \<le> 0"
	show "0 \<le> norm (flow0 s - Y s) + e / K"
	using e_pos K_pos by simp
	next
	show "0 < e / K" using e_pos K_pos by simp
	qed
	thus ?thesis by (simp add: algebra_simps)
	qed
	qed

	end

	end

	locale auto_ll_on_open =
	fixes f::"'a::{banach, heine_borel} \<Rightarrow> 'a" and X
	assumes auto_local_lipschitz: "local_lipschitz UNIV X (\<lambda>_::real. f)"
	assumes auto_open_domain[intro!, simp]: "open X"
	begin

	text \<open>autonomous flow and existence interval \<close>

	definition "flow0 x0 t = ll_on_open.flow UNIV (\<lambda>_. f) X 0 x0 t"

	definition "existence_ivl0 x0 = ll_on_open.existence_ivl UNIV (\<lambda>_. f) X 0 x0"

	sublocale ll_on_open_it UNIV "\<lambda>_. f" X 0
	rewrites "flow = (\<lambda>t0 x0 t. flow0 x0 (t - t0))"
	and "existence_ivl = (\<lambda>t0 x0. (+) t0 ` existence_ivl0 x0)"
	and "(+) 0 = (\<lambda>x::real. x)"
	and "s - 0 = s"
	and "(\<lambda>x. x) ` S = S"
	and "s \<in> (+) t ` S \<longleftrightarrow> s - t \<in> (S::real set)"
	and "P (s + t - s) = P (t::real)"\<comment> \<open>TODO: why does just the equation not work?\<close>
	and "P (t + s - s) = P t"\<comment> \<open>TODO: why does just the equation not work?\<close>
	proof -
	interpret ll_on_open UNIV "\<lambda>_. f" X
	by unfold_locales (auto intro!: continuous_on_const auto_local_lipschitz)
	show "ll_on_open_it UNIV (\<lambda>_. f) X" ..
	show "(+) 0 = (\<lambda>x::real. x)" "(\<lambda>x. x) ` S = S" "s - 0 = s" "P (t + s - s) = P t" "P (s + t - s) = P (t::real)"
	by auto
	show "flow = (\<lambda>t0 x0 t. flow0 x0 (t - t0))"
	unfolding flow0_def
	apply (rule ext)
	apply (rule ext)
	apply (rule flow_eq_in_existence_ivlI)
	apply (auto intro: flow_shift_autonomous1
	mem_existence_ivl_shift_autonomous1 mem_existence_ivl_shift_autonomous2)
	done
	show "existence_ivl = (\<lambda>t0 x0. (+) t0 ` existence_ivl0 x0)"
	unfolding existence_ivl0_def
	apply (safe intro!: ext)
	subgoal using image_iff mem_existence_ivl_shift_autonomous1 by fastforce
	subgoal premises prems for t0 x0 x s
	proof -
	have f2: "\<forall>x1 x2. (x2::real) - x1 = - 1 * x1 + x2"
	by auto
	have "- 1 * t0 + (t0 + s) = s"
	by auto
	then show ?thesis
	using f2 prems mem_existence_ivl_iv_defined(2) mem_existence_ivl_shift_autonomous2
	by presburger
	qed
	done
	show "(s \<in> (+) t ` S) = (s - t \<in> S)" by force
	qed
	\<comment> \<open>at this point, there should be no theorems about \<open>existence_ivl\<close>, only \<open>existence_ivl0\<close>.
	Moreover, \<open>(+) _ ` _\<close> and \<open>_ + _ - _\<close> etc should have been removed\<close>

	lemma existence_ivl_zero: "x0 \<in> X \<Longrightarrow> 0 \<in> existence_ivl0 x0" by simp

	lemmas [continuous_intros del] = continuous_on_f
	lemmas continuous_on_f_comp[continuous_intros] = continuous_on_f[OF continuous_on_const _ subset_UNIV]

	lemma
	flow_in_compact_right_existence:
	assumes "\<And>t. 0 \<le> t \<Longrightarrow> t \<in> existence_ivl0 x \<Longrightarrow> flow0 x t \<in> K"
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "t \<ge> 0"
	shows "t \<in> existence_ivl0 x"
	proof (rule ccontr)
	assume "t \<notin> existence_ivl0 x"
	have "bdd_above (existence_ivl0 x)"
	by (rule bdd_above_is_intervalI[OF is_interval_existence_ivl \<open>0 \<le> t\<close> existence_ivl_zero]) fact+
	from sup_existence_maximal[OF UNIV_I \<open>x \<in> X\<close> assms(1-3) this]
	show False by auto
	qed

	lemma
	flow_in_compact_left_existence:
	assumes "\<And>t. t \<le> 0 \<Longrightarrow> t \<in> existence_ivl0 x \<Longrightarrow> flow0 x t \<in> K"
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "t \<le> 0"
	shows "t \<in> existence_ivl0 x"
	proof (rule ccontr)
	assume "t \<notin> existence_ivl0 x"
	have "bdd_below (existence_ivl0 x)"
	by (rule bdd_below_is_intervalI[OF is_interval_existence_ivl \<open>t \<le> 0\<close> _ existence_ivl_zero]) fact+
	from inf_existence_minimal[OF UNIV_I \<open>x \<in> X\<close> assms(1-3) this]
	show False by auto
	qed

	end

	locale compact_continuously_diff =
	derivative_on_prod T X f "\<lambda>(t, x). f' x o\<^sub>L snd_blinfun"
	for T X and f::"real \<Rightarrow> 'a::{banach,perfect_space,heine_borel} \<Rightarrow> 'a"
	and f'::"'a \<Rightarrow> ('a, 'a) blinfun" +
	assumes compact_domain: "compact X"
	assumes convex: "convex X"
	assumes nonempty_domains: "T \<noteq> {}" "X \<noteq> {}"
	assumes continuous_derivative: "continuous_on X f'"
	begin

	lemma ex_onorm_bound:
	"\<exists>B. \<forall>x \<in> X. norm (f' x) \<le> B"
	proof -
	from _ compact_domain have "compact (f' ` X)"
	by (intro compact_continuous_image continuous_derivative)
	hence "bounded (f' ` X)" by (rule compact_imp_bounded)
	thus ?thesis
	by (auto simp add: bounded_iff cball_def norm_blinfun.rep_eq)
	qed

	definition "onorm_bound = (SOME B. \<forall>x \<in> X. norm (f' x) \<le> B)"

	lemma onorm_bound: assumes "x \<in> X" shows "norm (f' x) \<le> onorm_bound"
	unfolding onorm_bound_def
	using someI_ex[OF ex_onorm_bound] assms
	by blast

	sublocale closed_domain X
	using compact_domain by unfold_locales (rule compact_imp_closed)

	sublocale global_lipschitz T X f onorm_bound
	proof (unfold_locales, rule lipschitz_onI)
	fix t z y
	assume "t \<in> T" "y \<in> X" "z \<in> X"
	then have "norm (f t y - f t z) \<le> onorm_bound * norm (y - z)"
	using onorm_bound
	by (intro differentiable_bound[where f'=f', OF convex])
	(auto intro!: derivative_eq_intros simp: norm_blinfun.rep_eq)
	thus "dist (f t y) (f t z) \<le> onorm_bound * dist y z"
	by (auto simp: dist_norm norm_Pair)
	next
	from nonempty_domains obtain x where x: "x \<in> X" by auto
	show "0 \<le> onorm_bound"
	using dual_order.trans local.onorm_bound norm_ge_zero x by blast
	qed

	end \<comment> \<open>@{thm compact_domain}\<close>

	locale unique_on_compact_continuously_diff = self_mapping +
	compact_interval T +
	compact_continuously_diff T X f
	begin

	sublocale unique_on_closed t0 T x0 f X onorm_bound
	by unfold_locales (auto intro!: f' has_derivative_continuous_on)

	end

	locale c1_on_open =
	fixes f::"'a::{banach, perfect_space, heine_borel} \<Rightarrow> 'a" and f' X
	assumes open_dom[simp]: "open X"
	assumes derivative_rhs:
	"\<And>x. x \<in> X \<Longrightarrow> (f has_derivative blinfun_apply (f' x)) (at x)"
	assumes continuous_derivative: "continuous_on X f'"
	begin

	lemmas continuous_derivative_comp[continuous_intros] =
	continuous_on_compose2[OF continuous_derivative]

	lemma derivative_tendsto[tendsto_intros]:
	assumes [tendsto_intros]: "(g \<longlongrightarrow> l) F"
	and "l \<in> X"
	shows "((\<lambda>x. f' (g x)) \<longlongrightarrow> f' l) F"
	using continuous_derivative[simplified continuous_on] assms
	by (auto simp: at_within_open[OF _ open_dom]
	intro!: tendsto_eq_intros
	intro: tendsto_compose)

	lemma c1_on_open_rev[intro, simp]: "c1_on_open (-f) (-f') X"
	using derivative_rhs continuous_derivative
	by unfold_locales
	(auto intro!: continuous_intros derivative_eq_intros
	simp: fun_Compl_def blinfun.bilinear_simps)

	lemma derivative_rhs_compose[derivative_intros]:
	"((g has_derivative g') (at x within s)) \<Longrightarrow> g x \<in> X \<Longrightarrow>
	((\<lambda>x. f (g x)) has_derivative
	(\<lambda>xa. blinfun_apply (f' (g x)) (g' xa)))
	(at x within s)"
	by (metis has_derivative_compose[of g g' x s f "f' (g x)"] derivative_rhs)

	sublocale auto_ll_on_open
	proof (standard, rule local_lipschitzI)
	fix x and t::real
	assume "x \<in> X"
	with open_contains_cball[of "UNIV::real set"] open_UNIV
	open_contains_cball[of X] open_dom
	obtain u v where uv: "cball t u \<subseteq> UNIV" "cball x v \<subseteq> X" "u > 0" "v > 0"
	by blast
	let ?T = "cball t u" and ?X = "cball x v"
	have "bounded ?X" by simp
	have "compact (cball x v)"
	by simp
	interpret compact_continuously_diff ?T ?X "\<lambda>_. f" f'
	using uv
	by unfold_locales
	(auto simp: convex_cball cball_eq_empty split_beta'
	intro!: derivative_eq_intros continuous_on_compose2[OF continuous_derivative]
	continuous_intros)
	have "onorm_bound-lipschitz_on ?X f"
	using lipschitz[of t] uv
	by auto
	thus "\<exists>u>0. \<exists>L. \<forall>t \<in> cball t u \<inter> UNIV. L-lipschitz_on (cball x u \<inter> X) f"
	by (intro exI[where x=v])
	(auto intro!: exI[where x=onorm_bound] \<open>0 < v\<close> simp: Int_absorb2 uv)
	qed (auto intro!: continuous_intros)

	end \<comment> \<open>@{thm derivative_rhs}\<close>

	locale c1_on_open_euclidean = c1_on_open f f' X
	for f::"'a::euclidean_space \<Rightarrow> _" and f' X
	begin
	lemma c1_on_open_euclidean_anchor: True ..

	definition "vareq x0 t = f' (flow0 x0 t)"

	interpretation var: ll_on_open "existence_ivl0 x0" "vareq x0" UNIV
	apply standard
	apply (auto intro!: c1_implies_local_lipschitz[where f' = "\<lambda>(t, x). vareq x0 t"] continuous_intros
	derivative_eq_intros
	simp: split_beta' blinfun.bilinear_simps vareq_def)
	using local.mem_existence_ivl_iv_defined(2) apply blast
	using local.existence_ivl_reverse local.mem_existence_ivl_iv_defined(2) apply blast
	using local.mem_existence_ivl_iv_defined(2) apply blast
	using local.existence_ivl_reverse local.mem_existence_ivl_iv_defined(2) apply blast
	done

	context begin

	lemma continuous_on_A[continuous_intros]:
	assumes "continuous_on S a"
	assumes "continuous_on S b"
	assumes "\<And>s. s \<in> S \<Longrightarrow> a s \<in> X"
	assumes "\<And>s. s \<in> S \<Longrightarrow> b s \<in> existence_ivl0 (a s)"
	shows "continuous_on S (\<lambda>s. vareq (a s) (b s))"
	proof -
	have "continuous_on S (\<lambda>x. f' (flow0 (a x) (b x)))"
	by (auto intro!: continuous_intros assms flow_in_domain)
	then show ?thesis
	by (rule continuous_on_eq) (auto simp: assms vareq_def)
	qed

	lemmas [intro] = mem_existence_ivl_iv_defined

	context
	fixes x0::'a
	begin

	lemma flow0_defined: "xa \<in> existence_ivl0 x0 \<Longrightarrow> flow0 x0 xa \<in> X"
	by (auto simp: flow_in_domain)

	lemma continuous_on_flow0: "continuous_on (existence_ivl0 x0) (flow0 x0)"
	by (auto simp: intro!: continuous_intros)

	lemmas continuous_on_flow0_comp[continuous_intros] = continuous_on_compose2[OF continuous_on_flow0]

	lemma varexivl_eq_exivl:
	assumes "t \<in> existence_ivl0 x0"
	shows "var.existence_ivl x0 t a = existence_ivl0 x0"
	proof (rule var.existence_ivl_eq_domain)
	fix s t x
	assume s: "s \<in> existence_ivl0 x0" and t: "t \<in> existence_ivl0 x0"
	then have "{s .. t} \<subseteq> existence_ivl0 x0"
	by (metis atLeastatMost_empty_iff2 empty_subsetI real_Icc_closed_segment var.closed_segment_subset_domain)
	then have "continuous_on {s .. t} (vareq x0)"
	by (auto simp: closed_segment_eq_real_ivl intro!: continuous_intros flow0_defined)
	then have "compact ((vareq x0) ` {s .. t})"
	using compact_Icc
	by (rule compact_continuous_image)
	then obtain B where B: "\<And>u. u \<in> {s .. t} \<Longrightarrow> norm (vareq x0 u) \<le> B"
	by (force dest!: compact_imp_bounded simp: bounded_iff)
	show "\<exists>M L. \<forall>t\<in>{s..t}. \<forall>x\<in>UNIV. norm (blinfun_apply (vareq x0 t) x) \<le> M + L * norm x"
	by (rule exI[where x=0], rule exI[where x=B])
	(auto intro!: order_trans[OF norm_blinfun] mult_right_mono B simp:)
	qed (auto intro: assms)

	definition "vector_Dflow u0 t \<equiv> var.flow x0 0 u0 t"

	qualified abbreviation "Y z t \<equiv> flow0 (x0 + z) t"

	text \<open>Linearity of the solution to the variational equation.
	TODO: generalize this and some other things for arbitrary linear ODEs\<close>
	lemma vector_Dflow_linear:
	assumes "t \<in> existence_ivl0 x0"
	shows "vector_Dflow (\<alpha> \<^sub>R a + \<beta> \<^sub>R b) t = \<alpha> \<^sub>R vector_Dflow a t + \<beta> \<^sub>R vector_Dflow b t"
	proof -
	note mem_existence_ivl_iv_defined[OF assms, intro, simp]
	have "((\<lambda>c. \<alpha> \<^sub>R var.flow x0 0 a c + \<beta> \<^sub>R var.flow x0 0 b c) solves_ode (\<lambda>x. vareq x0 x)) (existence_ivl0 x0) UNIV"
	by (auto intro!: derivative_intros var.flow_has_vector_derivative solves_odeI
	simp: blinfun.bilinear_simps varexivl_eq_exivl vareq_def[symmetric])
	moreover
	have "\<alpha> \<^sub>R var.flow x0 0 a 0 + \<beta> \<^sub>R var.flow x0 0 b 0 = \<alpha> \<^sub>R a + \<beta> \<^sub>R b" by simp
	moreover note is_interval_existence_ivl[of x0]
	ultimately show ?thesis
	unfolding vareq_def[symmetric] vector_Dflow_def
	by (rule var.maximal_existence_flow) (auto simp: assms)
	qed

	lemma linear_vector_Dflow:
	assumes "t \<in> existence_ivl0 x0"
	shows "linear (\<lambda>z. vector_Dflow z t)"
	using vector_Dflow_linear[OF assms, of 1 _ 1] vector_Dflow_linear[OF assms, of _ _ 0]
	by (auto intro!: linearI)

	lemma bounded_linear_vector_Dflow:
	assumes "t \<in> existence_ivl0 x0"
	shows "bounded_linear (\<lambda>z. vector_Dflow z t)"
	by (simp add: linear_linear linear_vector_Dflow assms)

	lemma vector_Dflow_continuous_on_time: "x0 \<in> X \<Longrightarrow> continuous_on (existence_ivl0 x0) (\<lambda>t. vector_Dflow z t)"
	using var.flow_continuous_on[of x0 0 z] varexivl_eq_exivl
	unfolding vector_Dflow_def
	by (auto simp: )

	proposition proposition_17_6_weak:
	\<comment> \<open>from "Differential Equations, Dynamical Systems, and an Introduction to Chaos",
	Hirsch/Smale/Devaney\<close>
	assumes "t \<in> existence_ivl0 x0"
	shows "(\<lambda>y. (Y (y - x0) t - flow0 x0 t - vector_Dflow (y - x0) t) /\<^sub>R norm (y - x0)) \<midarrow> x0 \<rightarrow> 0"
	proof-
	note x0_def = mem_existence_ivl_iv_defined[OF assms]
	have "0 \<in> existence_ivl0 x0"
	by (simp add: x0_def)

	text \<open>Find some \<open>J \<subseteq> existence_ivl0 x0\<close> with \<open>0 \<in> J\<close> and \<open>t \<in> J\<close>.\<close>
	define t0 where "t0 \<equiv> min 0 t"
	define t1 where "t1 \<equiv> max 0 t"
	define J where "J \<equiv> {t0..t1}"

	have "t0 \<le> 0" "0 \<le> t1" "0 \<in> J" "J \<noteq> {}" "t \<in> J" "compact J"
	and J_in_existence: "J \<subseteq> existence_ivl0 x0"
	using ivl_subset_existence_ivl ivl_subset_existence_ivl' x0_def assms
	by (auto simp add: J_def t0_def t1_def min_def max_def)

	{
	fix z S
	assume assms: "x0 + z \<in> X" "S \<subseteq> existence_ivl0 (x0 + z)"
	have "continuous_on S (Y z)"
	using flow_continuous_on assms(1)
	by (intro continuous_on_subset[OF _ assms(2)]) (simp add:)
	}
	note [continuous_intros] = this integrable_continuous_real blinfun.continuous_on

	have U_continuous[continuous_intros]: "\<And>z. continuous_on J (vector_Dflow z)"
	by(rule continuous_on_subset[OF vector_Dflow_continuous_on_time[OF \<open>x0 \<in> X\<close>] J_in_existence])

	from \<open>t \<in> J\<close>
	have "t0 \<le> t"
	and "t \<le> t1"
	and "t0 \<le> t1"
	and "t0 \<in> existence_ivl0 x0"
	and "t \<in> existence_ivl0 x0"
	and "t1 \<in> existence_ivl0 x0"
	using J_def J_in_existence by auto
	from global_existence_ivl_explicit[OF \<open>t0 \<in> existence_ivl0 x0\<close> \<open>t1 \<in> existence_ivl0 x0\<close> \<open>t0 \<le> t1\<close>]
	obtain u K where uK_def:
	"0 < u"
	"0 < K"
	"ball x0 u \<subseteq> X"
	"\<And>y. y \<in> ball x0 u \<Longrightarrow> t0 \<in> existence_ivl0 y"
	"\<And>y. y \<in> ball x0 u \<Longrightarrow> t1 \<in> existence_ivl0 y"
	"\<And>t y. y \<in> ball x0 u \<Longrightarrow> t \<in> J \<Longrightarrow> dist (flow0 x0 t) (Y (y - x0) t) \<le> dist x0 y * exp (K * \<bar>t\<bar>)"
	by (auto simp add: J_def)

	have J_in_existence_ivl: "\<And>y. y \<in> ball x0 u \<Longrightarrow> J \<subseteq> existence_ivl0 y"
	unfolding J_def
	using uK_def
	by (simp add: real_Icc_closed_segment segment_subset_existence_ivl t0_def t1_def)
	have ball_in_X: "\<And>z. z \<in> ball 0 u \<Longrightarrow> x0 + z \<in> X"
	using uK_def(3)
	by (auto simp: dist_norm)

	have flow0_J_props: "flow0 x0 ` J \<noteq> {}" "compact (flow0 x0 ` J)" "flow0 x0` J \<subseteq> X"
	using \<open>t0 \<le> t1\<close>
	using J_def(1) J_in_existence
	by (auto simp add: J_def intro!:
	compact_continuous_image continuous_intros flow_in_domain)

	have [continuous_intros]: "continuous_on J (\<lambda>s. f' (flow0 x0 s))"
	using J_in_existence
	by (auto intro!: continuous_intros flow_in_domain simp:)

	text \<open> Show the thesis via cases \<open>t = 0\<close>, \<open>0 < t\<close> and \<open>t < 0\<close>. \<close>
	show ?thesis
	proof(cases "t = 0")
	assume "t = 0"
	show ?thesis
	unfolding \<open>t = 0\<close> Lim_at
	proof(simp add: dist_norm[of _ 0] del: zero_less_dist_iff, safe, rule exI, rule conjI[OF \<open>0 < u\<close>], safe)
	fix e::real and x assume "0 < e" "0 < dist x x0" "dist x x0 < u"
	hence "x \<in> X"
	using uK_def(3)
	by (auto simp: dist_commute)
	hence "inverse (norm (x - x0)) * norm (Y (x - x0) 0 - flow0 x0 0 - vector_Dflow (x - x0) 0) = 0"
	using x0_def
	by (simp add: vector_Dflow_def)
	thus "inverse (norm (x - x0)) * norm (flow0 x 0 - flow0 x0 0 - vector_Dflow (x - x0) 0) < e"
	using \<open>0 < e\<close> by auto
	qed
	next
	assume "t \<noteq> 0"
	show ?thesis
	proof(unfold Lim_at, safe)
	fix e::real assume "0 < e"
	then obtain e' where "0 < e'" "e' < e"
	using dense by auto

	obtain N
	where N_ge_SupS: "Sup { norm (f' (flow0 x0 s)) \|s. s \<in> J } \<le> N" (is "Sup ?S \<le> N")
	and N_gr_0: "0 < N"
	\<comment> \<open>We need N to be an upper bound of @{term ?S}, but also larger than zero.\<close>
	by (meson le_cases less_le_trans linordered_field_no_ub)
	have N_ineq: "\<And>s. s \<in> J \<Longrightarrow> norm (f' (flow0 x0 s)) \<le> N"
	proof-
	fix s assume "s \<in> J"
	have "?S = (norm o f' o flow0 x0) ` J" by auto
	moreover have "continuous_on J (norm o f' o flow0 x0)"
	using J_in_existence
	by (auto intro!: continuous_intros)
	ultimately have "\<exists>a b. ?S = {a..b} \<and> a \<le> b"
	using continuous_image_closed_interval[OF \<open>t0 \<le> t1\<close>]
	by (simp add: J_def)
	then obtain a b where "?S = {a..b}" and "a \<le> b" by auto
	hence "bdd_above ?S" by simp
	from \<open>s \<in> J\<close> cSup_upper[OF _ this]
	have "norm (f' (flow0 x0 s)) \<le> Sup ?S"
	by auto
	thus "norm (f' (flow0 x0 s)) \<le> N"
	using N_ge_SupS by simp
	qed

	text \<open> Define a small region around \<open>flow0 ` J\<close>, that is a subset of the domain \<open>X\<close>. \<close>
	from compact_in_open_separated[OF flow0_J_props(1,2) auto_open_domain flow0_J_props(3)]
	obtain e_domain where e_domain_def: "0 < e_domain" "{x. infdist x (flow0 x0 ` J) \<le> e_domain} \<subseteq> X"
	by auto
	define G where "G \<equiv> {x\<in>X. infdist x (flow0 x0 ` J) < e_domain}"
	have G_vimage: "G = ((\<lambda>x. infdist x (flow0 x0 ` J)) -` {..<e_domain}) \<inter> X"
	by (auto simp: G_def)
	have "open G" "G \<subseteq> X"
	unfolding G_vimage
	by (auto intro!: open_Int open_vimage continuous_intros continuous_at_imp_continuous_on)

	text \<open>Define a compact subset H of G. Inside H, we can guarantee
	an upper bound on the Taylor remainder.\<close>
	define e_domain2 where "e_domain2 \<equiv> e_domain / 2"
	have "e_domain2 > 0" "e_domain2 < e_domain" using \<open>e_domain > 0\<close>
	by (simp_all add: e_domain2_def)
	define H where "H \<equiv> {x. infdist x (flow0 x0 ` J) \<le> e_domain2}"
	have H_props: "H \<noteq> {}" "compact H" "H \<subseteq> G"
	proof-
	have "x0 \<in> flow0 x0 ` J"
	unfolding image_iff
	using \<open>0 \<in> J\<close> x0_def
	by force

	hence "x0 \<in> H"
	using \<open>0 < e_domain2\<close>
	by (simp add: H_def x0_def)
	thus "H \<noteq> {}"
	by auto
	next
	show "compact H"
	unfolding H_def
	using \<open>0 < e_domain2\<close> flow0_J_props
	by (intro compact_infdist_le) simp_all
	next
	show "H \<subseteq> G"
	proof
	fix x assume "x \<in> H"
	then have *: "infdist x (flow0 x0 ` J) < e_domain"
	using \<open>0 < e_domain\<close>
	by (simp add: H_def e_domain2_def)
	then have "x \<in> X"
	using e_domain_def(2)
	by auto
	with * show "x \<in> G"
	unfolding G_def
	by auto
	qed
	qed

	have f'_cont_on_G: "(\<And>x. x \<in> G \<Longrightarrow> isCont f' x)"
	using continuous_on_interior[OF continuous_on_subset[OF continuous_derivative \<open>G \<subseteq> X\<close>]]
	by (simp add: interior_open[OF \<open>open G\<close>])

	define e1 where "e1 \<equiv> e' / (\<bar>t\<bar> * exp (K * \<bar>t\<bar>) * exp (N * \<bar>t\<bar>))"
	\<comment> \<open>@{term e1} is the bounding term for the Taylor remainder.\<close>
	have "0 < \<bar>t\<bar>"
	using \<open>t \<noteq> 0\<close>
	by simp
	hence "0 < e1"
	using \<open>0 < e'\<close>
	by (simp add: e1_def)

	text \<open> Taylor expansion of f on set G. \<close>
	from uniform_explicit_remainder_Taylor_1[where f=f and f'=f',
	OF derivative_rhs[OF subsetD[OF \<open>G \<subseteq> X\<close>]] f'_cont_on_G \<open>open G\<close> H_props \<open>0 < e1\<close>]
	obtain d_Taylor R
	where Taylor_expansion:
	"0 < d_Taylor"
	"\<And>x z. f z = f x + (f' x) (z - x) + R x z"
	"\<And>x y. x \<in> H \<Longrightarrow> y \<in> H \<Longrightarrow> dist x y < d_Taylor \<Longrightarrow> norm (R x y) \<le> e1 * dist x y"
	"continuous_on (G \<times> G) (\<lambda>(a, b). R a b)"
	by auto

	text \<open> Find d, such that solutions are always at least \<open>min (e_domain/2) d_Taylor\<close> apart,
	i.e. always in H. This later gives us the bound on the remainder. \<close>
	have "0 < min (e_domain/2) d_Taylor"
	using \<open>0 < d_Taylor\<close> \<open>0 < e_domain\<close>
	by auto
	from uniform_limit_flow[OF \<open>t0 \<in> existence_ivl0 x0\<close> \<open>t1 \<in> existence_ivl0 x0\<close> \<open>t0 \<le> t1\<close>,
	THEN uniform_limitD, OF this, unfolded eventually_at]
	obtain d_ivl where d_ivl_def:
	"0 < d_ivl"
	"\<And>x. 0 < dist x x0 \<Longrightarrow> dist x x0 < d_ivl \<Longrightarrow>
	(\<forall>t\<in>J. dist (flow0 x0 t) (Y (x - x0) t) < min (e_domain / 2) d_Taylor)"
	by (auto simp: dist_commute J_def)

	define d where "d \<equiv> min u d_ivl"
	have "0 < d" using \<open>0 < u\<close> \<open>0 < d_ivl\<close>
	by (simp add: d_def)
	hence "d \<le> u" "d \<le> d_ivl"
	by (auto simp: d_def)

	text \<open> Therefore, any flow0 starting in \<open>ball x0 d\<close> will be in G. \<close>
	have Y_in_G: "\<And>y. y \<in> ball x0 d \<Longrightarrow> (\<lambda>s. Y (y - x0) s) ` J \<subseteq> G"
	proof
	fix x y assume assms: "y \<in> ball x0 d" "x \<in> (\<lambda>s. Y (y - x0) s) ` J"
	show "x \<in> G"
	proof(cases)
	assume "y = x0"
	from assms(2)
	have "x \<in> flow0 x0 ` J"
	by (simp add: \<open>y = x0\<close>)
	thus "x \<in> G"
	using \<open>0 < e_domain\<close> \<open>flow0 x0 ` J \<subseteq> X\<close>
	by (auto simp: G_def)
	next
	assume "y \<noteq> x0"
	hence "0 < dist y x0"
	by (simp add: dist_norm)
	from d_ivl_def(2)[OF this] \<open>d \<le> d_ivl\<close> \<open>0 < e_domain\<close> assms(1)
	have dist_flow0_Y: "\<And>t. t \<in> J \<Longrightarrow> dist (flow0 x0 t) (Y (y - x0) t) < e_domain"
	by (auto simp: dist_commute)

	from assms(2)
	obtain t where t_def: "t \<in> J" "x = Y (y - x0) t"
	by auto
	have "x \<in> X"
	unfolding t_def(2)
	using uK_def(3) assms(1) \<open>d \<le> u\<close> subsetD[OF J_in_existence_ivl t_def(1)]
	by (auto simp: intro!: flow_in_domain)

	have "flow0 x0 t \<in> flow0 x0 ` J" using t_def by auto
	from dist_flow0_Y[OF t_def(1)]
	have "dist x (flow0 x0 t) < e_domain"
	by (simp add: t_def(2) dist_commute)
	from le_less_trans[OF infdist_le[OF \<open>flow0 x0 t \<in> flow0 x0 ` J\<close>] this] \<open>x \<in> X\<close>
	show "x \<in> G"
	by (auto simp: G_def)
	qed
	qed
	from this[of x0] \<open>0 < d\<close>
	have X_in_G: "flow0 x0 ` J \<subseteq> G"
	- by (simp add: )
	+ by simp

	show "\<exists>d>0. \<forall>x. 0 < dist x x0 \<and> dist x x0 < d \<longrightarrow>
	dist ((Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) /\<^sub>R norm (x - x0)) 0 < e"
	proof(rule exI, rule conjI[OF \<open>0 < d\<close>], safe, unfold norm_conv_dist[symmetric])
	fix x assume x_x0_dist: "0 < dist x x0" "dist x x0 < d"
	hence x_in_ball': "x \<in> ball x0 d"
	by (simp add: dist_commute)
	hence x_in_ball: "x \<in> ball x0 u"
	using \<open>d \<le> u\<close>
	by simp

	text \<open> First, some prerequisites. \<close>
	from x_in_ball
	have z_in_ball: "x - x0 \<in> ball 0 u"
	using \<open>0 < u\<close>
	by (simp add: dist_norm)
	hence [continuous_intros]: "dist x0 x < u"
	by (auto simp: dist_norm)

	from J_in_existence_ivl[OF x_in_ball]
	have J_in_existence_ivl_x: "J \<subseteq> existence_ivl0 x" .
	from ball_in_X[OF z_in_ball]
	have x_in_X[continuous_intros]: "x \<in> X"
	by simp

	text \<open> On all of \<open>J\<close>, we can find upper bounds for the distance of \<open>flow0\<close> and \<open>Y\<close>. \<close>
	have dist_flow0_Y: "\<And>s. s \<in> J \<Longrightarrow> dist (flow0 x0 s) (Y (x - x0) s) \<le> dist x0 x * exp (K * \<bar>t\<bar>)"
	using t0_def t1_def uK_def(2)
	by (intro order_trans[OF uK_def(6)[OF x_in_ball] mult_left_mono])
	(auto simp add: J_def intro!: mult_mono)
	from d_ivl_def x_x0_dist \<open>d \<le> d_ivl\<close>
	have dist_flow0_Y2: "\<And>t. t \<in> J \<Longrightarrow> dist (flow0 x0 t) (Y (x - x0) t) < min (e_domain2) d_Taylor"
	by (auto simp: e_domain2_def)

	let ?g = "\<lambda>t. norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t)"
	let ?C = "\<bar>t\<bar> * dist x0 x * exp (K * \<bar>t\<bar>) * e1"
	text \<open> Find an upper bound to \<open>?g\<close>, i.e. show that
	\<open>?g s \<le> ?C + N * integral {a..b} ?g\<close>
	for \<open>{a..b} = {0..s}\<close> or \<open>{a..b} = {s..0}\<close> for some \<open>s \<in> J\<close>.
	We can then apply Grönwall's inequality to obtain a true bound for \<open>?g\<close>. \<close>
	have g_bound: "?g s \<le> ?C + N * integral {a..b} ?g"
	if s_def: "s \<in> {a..b}"
	and J'_def: "{a..b} \<subseteq> J"
	and ab_cases: "(a = 0 \<and> b = s) \<or> (a = s \<and> b = 0)"
	for s a b
	proof -
	from that have "s \<in> J" by auto

	have s_in_existence_ivl_x0: "s \<in> existence_ivl0 x0"
	using J_in_existence \<open>s \<in> J\<close> by auto
	have s_in_existence_ivl: "\<And>y. y \<in> ball x0 u \<Longrightarrow> s \<in> existence_ivl0 y"
	using J_in_existence_ivl \<open>s \<in> J\<close> by auto
	have s_in_existence_ivl2: "\<And>z. z \<in> ball 0 u \<Longrightarrow> s \<in> existence_ivl0 (x0 + z)"
	using s_in_existence_ivl
	by (simp add: dist_norm)

	text \<open>Prove continuities beforehand.\<close>
	note continuous_on_0_s[continuous_intros] = continuous_on_subset[OF _ \<open>{a..b} \<subseteq> J\<close>]

	have[continuous_intros]: "continuous_on J (flow0 x0)"
	using J_in_existence
	by (auto intro!: continuous_intros simp:)
	{
	fix z S
	assume assms: "x0 + z \<in> X" "S \<subseteq> existence_ivl0 (x0 + z)"
	have "continuous_on S (\<lambda>s. f (Y z s))"
	proof(rule continuous_on_subset[OF _ assms(2)])
	show "continuous_on (existence_ivl0 (x0 + z)) (\<lambda>s. f (Y z s))"
	using assms
	by (auto intro!: continuous_intros flow_in_domain flow_continuous_on simp:)
	qed
	}
	note [continuous_intros] = this

	have [continuous_intros]: "continuous_on J (\<lambda>s. f (flow0 x0 s))"
	by(rule continuous_on_subset[OF _ J_in_existence])
	(auto intro!: continuous_intros flow_continuous_on flow_in_domain simp: x0_def)

	have [continuous_intros]: "\<And>z. continuous_on J (\<lambda>s. f' (flow0 x0 s) (vector_Dflow z s))"
	proof-
	fix z
	have a1: "continuous_on J (flow0 x0)"
	by (auto intro!: continuous_intros)

	have a2: "(\<lambda>s. (flow0 x0 s, vector_Dflow z s)) ` J \<subseteq> (flow0 x0 ` J) \<times> ((\<lambda>s. vector_Dflow z s) ` J)"
	by auto
	have a3: "continuous_on ((\<lambda>s. (flow0 x0 s, vector_Dflow z s)) ` J) (\<lambda>(x, u). f' x u)"
	using assms flow0_J_props
	by (auto intro!: continuous_intros simp: split_beta')
	from continuous_on_compose[OF continuous_on_Pair[OF a1 U_continuous] a3]
	show "continuous_on J (\<lambda>s. f' (flow0 x0 s) (vector_Dflow z s))"
	by simp
	qed

	have [continuous_intros]: "continuous_on J (\<lambda>s. R (flow0 x0 s) (Y (x - x0) s))"
	using J_in_existence J_in_existence_ivl[OF x_in_ball] X_in_G \<open>{a..b} \<subseteq> J\<close> Y_in_G
	x_x0_dist
	by (auto intro!: continuous_intros continuous_on_compose_Pair[OF Taylor_expansion(4)]
	simp: dist_commute subset_iff)
	hence [continuous_intros]:
	"(\<lambda>s. R (flow0 x0 s) (Y (x - x0) s)) integrable_on J"
	unfolding J_def
	by (rule integrable_continuous_real)

	have i1: "integral {a..b} (\<lambda>s. f (flow0 x s)) - integral {a..b} (\<lambda>s. f (flow0 x0 s)) =
	integral {a..b} (\<lambda>s. f (flow0 x s) - f (flow0 x0 s))"
	using J_in_existence_ivl[OF x_in_ball]
	apply (intro Henstock_Kurzweil_Integration.integral_diff[symmetric])
	by (auto intro!: continuous_intros existence_ivl_reverse)
	have i2:
	"integral {a..b} (\<lambda>s. f (flow0 x s) - f (flow0 x0 s) - (f' (flow0 x0 s)) (vector_Dflow (x - x0) s)) =
	integral {a..b} (\<lambda>s. f (flow0 x s) - f (flow0 x0 s)) -
	integral {a..b} (\<lambda>s. f' (flow0 x0 s) (vector_Dflow (x - x0) s))"
	using J_in_existence_ivl[OF x_in_ball]
	by (intro Henstock_Kurzweil_Integration.integral_diff[OF Henstock_Kurzweil_Integration.integrable_diff])
	(auto intro!: continuous_intros existence_ivl_reverse)
	from ab_cases
	have "?g s = norm (integral {a..b} (\<lambda>s'. f (Y (x - x0) s')) -
	integral {a..b} (\<lambda>s'. f (flow0 x0 s')) -
	integral {a..b} (\<lambda>s'. (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))"
	proof(safe)
	assume "a = 0" "b = s"
	hence "0 \<le> s" using \<open>s \<in> {a..b}\<close> by simp

	text\<open> Integral equations for flow0, Y and U. \<close>
	have flow0_integral_eq: "flow0 x0 s = x0 + ivl_integral 0 s (\<lambda>s. f (flow0 x0 s))"
	by (rule flow_fixed_point[OF s_in_existence_ivl_x0])
	have Y_integral_eq: "flow0 x s = x0 + (x - x0) + ivl_integral 0 s (\<lambda>s. f (Y (x - x0) s))"
	using flow_fixed_point \<open>0 \<le> s\<close> s_in_existence_ivl2[OF z_in_ball] ball_in_X[OF z_in_ball]
	by (simp add:)
	have U_integral_eq: "vector_Dflow (x - x0) s = (x - x0) + ivl_integral 0 s (\<lambda>s. vareq x0 s (vector_Dflow (x - x0) s))"
	unfolding vector_Dflow_def
	by (rule var.flow_fixed_point)
	(auto simp: \<open>0 \<le> s\<close> x0_def varexivl_eq_exivl s_in_existence_ivl_x0)
	show "?g s = norm (integral {0..s} (\<lambda>s'. f (Y (x - x0) s')) -
	integral {0..s} (\<lambda>s'. f (flow0 x0 s')) -
	integral {0..s} (\<lambda>s'. blinfun_apply (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))"
	using \<open>0 \<le> s\<close>
	unfolding vareq_def[symmetric]
	by (simp add: flow0_integral_eq Y_integral_eq U_integral_eq ivl_integral_def)
	next
	assume "a = s" "b = 0"
	hence "s \<le> 0" using \<open>s \<in> {a..b}\<close> by simp

	have flow0_integral_eq_left: "flow0 x0 s = x0 + ivl_integral 0 s (\<lambda>s. f (flow0 x0 s))"
	by (rule flow_fixed_point[OF s_in_existence_ivl_x0])
	have Y_integral_eq_left: "Y (x - x0) s = x0 + (x - x0) + ivl_integral 0 s (\<lambda>s. f (Y (x - x0) s))"
	using flow_fixed_point \<open>s \<le> 0\<close> s_in_existence_ivl2[OF z_in_ball] ball_in_X[OF z_in_ball]
	- by (simp add: )
	+ by simp
	have U_integral_eq_left: "vector_Dflow (x - x0) s = (x - x0) + ivl_integral 0 s (\<lambda>s. vareq x0 s (vector_Dflow (x - x0) s))"
	unfolding vector_Dflow_def
	by (rule var.flow_fixed_point)
	(auto simp: \<open>s \<le> 0\<close> x0_def varexivl_eq_exivl s_in_existence_ivl_x0)

	have "?g s =
	norm (- integral {s..0} (\<lambda>s'. f (Y (x - x0) s')) +
	integral {s..0} (\<lambda>s'. f (flow0 x0 s')) +
	integral {s..0} (\<lambda>s'. vareq x0 s' (vector_Dflow (x - x0) s')))"
	unfolding flow0_integral_eq_left Y_integral_eq_left U_integral_eq_left
	using \<open>s \<le> 0\<close>
	by (simp add: ivl_integral_def)
	also have "... = norm (integral {s..0} (\<lambda>s'. f (Y (x - x0) s')) -
	integral {s..0} (\<lambda>s'. f (flow0 x0 s')) -
	integral {s..0} (\<lambda>s'. vareq x0 s' (vector_Dflow (x - x0) s')))"
	by (subst norm_minus_cancel[symmetric], simp)
	finally show "?g s =
	norm (integral {s..0} (\<lambda>s'. f (Y (x - x0) s')) -
	integral {s..0} (\<lambda>s'. f (flow0 x0 s')) -
	integral {s..0} (\<lambda>s'. blinfun_apply (f' (flow0 x0 s')) (vector_Dflow (x - x0) s')))"
	unfolding vareq_def .
	qed
	also have "... =
	norm (integral {a..b} (\<lambda>s. f (Y (x - x0) s) - f (flow0 x0 s) - (f' (flow0 x0 s)) (vector_Dflow (x - x0) s)))"
	by (simp add: i1 i2)
	also have "... \<le>
	integral {a..b} (\<lambda>s. norm (f (Y (x - x0) s) - f (flow0 x0 s) - f' (flow0 x0 s) (vector_Dflow (x - x0) s)))"
	using x_in_X J_in_existence_ivl_x J_in_existence \<open>{a..b} \<subseteq> J\<close>
	by (auto intro!: continuous_intros continuous_on_imp_absolutely_integrable_on
	existence_ivl_reverse)
	also have "... = integral {a..b}
	(\<lambda>s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s) + R (flow0 x0 s) (Y (x - x0) s)))"
	proof (safe intro!: integral_spike[OF negligible_empty, simplified] arg_cong[where f=norm])
	fix s' assume "s' \<in> {a..b}"
	show "f' (flow0 x0 s') (Y (x - x0) s' - flow0 x0 s' - vector_Dflow (x - x0) s') + R (flow0 x0 s') (Y (x - x0) s') =
	f (Y (x - x0) s') - f (flow0 x0 s') - f' (flow0 x0 s') (vector_Dflow (x - x0) s')"
	by (simp add: blinfun.diff_right Taylor_expansion(2)[of "flow0 x s'" "flow0 x0 s'"])
	qed
	also have "... \<le> integral {a..b}
	(\<lambda>s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s)) +
	norm (R (flow0 x0 s) (Y (x - x0) s)))"
	using J_in_existence_ivl[OF x_in_ball] norm_triangle_ineq
	using \<open>continuous_on J (\<lambda>s. R (flow0 x0 s) (Y (x - x0) s))\<close>
	by (auto intro!: continuous_intros integral_le)
	also have "... =
	integral {a..b} (\<lambda>s. norm (f' (flow0 x0 s) (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))) +
	integral {a..b} (\<lambda>s. norm (R (flow0 x0 s) (Y (x - x0) s)))"
	using J_in_existence_ivl[OF x_in_ball]
	using \<open>continuous_on J (\<lambda>s. R (flow0 x0 s) (Y (x - x0) s))\<close>
	by (auto intro!: continuous_intros Henstock_Kurzweil_Integration.integral_add)
	also have "... \<le> N * integral {a..b} ?g + ?C" (is "?l1 + ?r1 \<le> _")
	proof(rule add_mono)
	have "?l1 \<le> integral {a..b} (\<lambda>s. norm (f' (flow0 x0 s)) * norm (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))"
	using norm_blinfun J_in_existence_ivl[OF x_in_ball]
	by (auto intro!: continuous_intros integral_le)

	also have "... \<le> integral {a..b} (\<lambda>s. N * norm (Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s))"
	using J_in_existence_ivl[OF x_in_ball] N_ineq[OF \<open>{a..b} \<subseteq> J\<close>[THEN subsetD]]
	by (intro integral_le) (auto intro!: continuous_intros mult_right_mono)

	also have "... = N * integral {a..b} (\<lambda>s. norm ((Y (x - x0) s - flow0 x0 s - vector_Dflow (x - x0) s)))"
	unfolding real_scaleR_def[symmetric]
	by(rule integral_cmul)
	finally show "?l1 \<le> N * integral {a..b} ?g" .
	next
	have "?r1 \<le> integral {a..b} (\<lambda>s. e1 * dist (flow0 x0 s) (Y (x - x0) s))"
	using J_in_existence_ivl[OF x_in_ball] \<open>0 < e_domain\<close> dist_flow0_Y2 \<open>0 < e_domain2\<close>
	by (intro integral_le)
	(force
	intro!: continuous_intros Taylor_expansion(3) order_trans[OF infdist_le]
	dest!: \<open>{a..b} \<subseteq> J\<close>[THEN subsetD]
	intro: less_imp_le
	simp: dist_commute H_def)+
	also have "... \<le> integral {a..b} (\<lambda>s. e1 * (dist x0 x * exp (K * \<bar>t\<bar>)))"
	apply(rule integral_le)
	subgoal using J_in_existence_ivl[OF x_in_ball] by (force intro!: continuous_intros)
	subgoal by force
	subgoal by (force dest!: \<open>{a..b} \<subseteq> J\<close>[THEN subsetD]
	intro!: less_imp_le[OF \<open>0 < e1\<close>] mult_left_mono[OF dist_flow0_Y])
	done
	also have "... \<le> ?C"
	using \<open>s \<in> J\<close> x_x0_dist \<open>0 < e1\<close> \<open>{a..b} \<subseteq> J\<close> \<open>0 < \<bar>t\<bar>\<close> t0_def t1_def
	by (auto simp: integral_const_real J_def(1))
	finally show "?r1 \<le> ?C" .
	qed
	finally show ?thesis
	by simp
	qed
	have g_continuous: "continuous_on J ?g"
	using J_in_existence_ivl[OF x_in_ball] J_in_existence
	using J_def(1) U_continuous
	by (auto simp: J_def intro!: continuous_intros)
	note [continuous_intros] = continuous_on_subset[OF g_continuous]
	have C_gr_zero: "0 < ?C"
	using \<open>0 < \<bar>t\<bar>\<close> \<open>0 < e1\<close> x_x0_dist(1)
	by (simp add: dist_commute)
	have "0 \<le> t \<or> t \<le> 0" by auto
	then have "?g t \<le> ?C * exp (N * \<bar>t\<bar>)"
	proof
	assume "0 \<le> t"
	moreover
	have "continuous_on {0..t} (vector_Dflow (x - x0))"
	using U_continuous
	by (rule continuous_on_subset) (auto simp: J_def t0_def t1_def)
	then have "norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) \<le>
	\<bar>t\<bar> * dist x0 x * exp (K * \<bar>t\<bar>) * e1 * exp (N * t)"
	using \<open>t \<in> J\<close> J_def \<open>t0 \<le> 0\<close> J_in_existence J_in_existence_ivl_x
	by (intro gronwall[OF g_bound _ _ C_gr_zero \<open>0 < N\<close> \<open>0 \<le> t\<close> order.refl])
	(auto intro!: continuous_intros simp: )
	ultimately show ?thesis by simp
	next
	assume "t \<le> 0"
	moreover
	have "continuous_on {t .. 0} (vector_Dflow (x - x0))"
	using U_continuous
	by (rule continuous_on_subset) (auto simp: J_def t0_def t1_def)
	then have "norm (Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) \<le>
	\<bar>t\<bar> * dist x0 x * exp (K * \<bar>t\<bar>) * e1 * exp (- N * t)"
	using \<open>t \<in> J\<close> J_def \<open>0 \<le> t1\<close> J_in_existence J_in_existence_ivl_x
	by (intro gronwall_left[OF g_bound _ _ C_gr_zero \<open>0 < N\<close> order.refl \<open>t \<le> 0\<close>])
	(auto intro!: continuous_intros)
	ultimately show ?thesis
	by simp
	qed
	also have "... = dist x x0 * (\<bar>t\<bar> * exp (K * \<bar>t\<bar>) * e1 * exp (N * \<bar>t\<bar>))"
	by (auto simp: dist_commute)
	also have "... < norm (x - x0) * e"
	unfolding e1_def
	using \<open>e' < e\<close> \<open>0 < \<bar>t\<bar>\<close> \<open>0 < e1\<close> x_x0_dist(1)
	by (simp add: dist_norm)
	finally show "norm ((Y (x - x0) t - flow0 x0 t - vector_Dflow (x - x0) t) /\<^sub>R norm (x - x0)) < e"
	by (simp, metis x_x0_dist(1) dist_norm divide_inverse mult.commute pos_divide_less_eq)
	qed
	qed
	qed
	qed

	lemma local_lipschitz_A:
	"OT \<subseteq> existence_ivl0 x0 \<Longrightarrow> local_lipschitz OT (OS::('a \<Rightarrow>\<^sub>L 'a) set) (\<lambda>t. (o\<^sub>L) (vareq x0 t))"
	by (rule local_lipschitz_subset[OF _ _ subset_UNIV, where T="existence_ivl0 x0"])
	(auto simp: split_beta' vareq_def
	intro!: c1_implies_local_lipschitz[where f'="\<lambda>(t, x). comp3 (f' (flow0 x0 t))"]
	derivative_eq_intros blinfun_eqI ext
	continuous_intros flow_in_domain)

	lemma total_derivative_ll_on_open:
	"ll_on_open (existence_ivl0 x0) (\<lambda>t. blinfun_compose (vareq x0 t)) (UNIV::('a \<Rightarrow>\<^sub>L 'a) set)"
	by standard (auto intro!: continuous_intros local_lipschitz_A[OF order_refl])

	end

	end

	sublocale mvar: ll_on_open "existence_ivl0 x0" "\<lambda>t. blinfun_compose (vareq x0 t)" "UNIV::('a \<Rightarrow>\<^sub>L 'a) set" for x0
	by (rule total_derivative_ll_on_open)

	lemma mvar_existence_ivl_eq_existence_ivl[simp]:\<comment> \<open>TODO: unify with @{thm varexivl_eq_exivl}\<close>
	assumes "t \<in> existence_ivl0 x0"
	shows "mvar.existence_ivl x0 t = (\<lambda>_. existence_ivl0 x0)"
	proof (rule ext, rule mvar.existence_ivl_eq_domain)
	fix s t x
	assume s: "s \<in> existence_ivl0 x0" and t: "t \<in> existence_ivl0 x0"
	then have "{s .. t} \<subseteq> existence_ivl0 x0"
	by (meson atLeastAtMost_iff is_interval_1 is_interval_existence_ivl subsetI)
	then have "continuous_on {s .. t} (vareq x0)"
	by (auto intro!: continuous_intros)
	then have "compact (vareq x0 ` {s .. t})"
	using compact_Icc
	by (rule compact_continuous_image)
	then obtain B where B: "\<And>u. u \<in> {s .. t} \<Longrightarrow> norm (vareq x0 u) \<le> B"
	by (force dest!: compact_imp_bounded simp: bounded_iff)
	show "\<exists>M L. \<forall>t\<in>{s .. t}. \<forall>x\<in>UNIV. norm (vareq x0 t o\<^sub>L x) \<le> M + L * norm x"
	unfolding o_def
	by (rule exI[where x=0], rule exI[where x=B])
	(auto intro!: order_trans[OF norm_blinfun_compose] mult_right_mono B)
	qed (auto intro: assms)

	lemma
	assumes "t \<in> existence_ivl0 x0"
	shows "continuous_on (UNIV \<times> existence_ivl0 x0) (\<lambda>(x, ta). mvar.flow x0 t x ta)"
	proof -
	from mvar.flow_continuous_on_state_space[of x0 t, unfolded mvar_existence_ivl_eq_existence_ivl[OF assms]]
	show "continuous_on (UNIV \<times> existence_ivl0 x0) (\<lambda>(x, ta). mvar.flow x0 t x ta)" .
	qed

	definition "Dflow x0 = mvar.flow x0 0 id_blinfun"

	lemma var_eq_mvar:
	assumes "t0 \<in> existence_ivl0 x0"
	assumes "t \<in> existence_ivl0 x0"
	shows "var.flow x0 t0 i t = mvar.flow x0 t0 id_blinfun t i"
	by (rule var.flow_unique)
	(auto intro!: assms derivative_eq_intros mvar.flow_has_derivative
	simp: varexivl_eq_exivl assms has_vector_derivative_def blinfun.bilinear_simps)

	lemma Dflow_zero[simp]: "x \<in> X \<Longrightarrow> Dflow x 0 = 1\<^sub>L"
	unfolding Dflow_def
	by (subst mvar.flow_initial_time) auto


	subsection \<open>Differentiability of the flow0\<close>

	text \<open> \<open>U t\<close>, i.e. the solution of the variational equation, is the space derivative at the initial
	value \<open>x0\<close>. \<close>
	lemma flow_dx_derivative:
	assumes "t \<in> existence_ivl0 x0"
	shows "((\<lambda>x0. flow0 x0 t) has_derivative (\<lambda>z. vector_Dflow x0 z t)) (at x0)"
	unfolding has_derivative_at2
	using assms
	by (intro iffD1[OF LIM_equal proposition_17_6_weak[OF assms]] conjI[OF bounded_linear_vector_Dflow[OF assms]])
	(simp add: diff_diff_add inverse_eq_divide)

	lemma flow_dx_derivative_blinfun:
	assumes "t \<in> existence_ivl0 x0"
	shows "((\<lambda>x. flow0 x t) has_derivative Blinfun (\<lambda>z. vector_Dflow x0 z t)) (at x0)"
	by (rule has_derivative_Blinfun[OF flow_dx_derivative[OF assms]])

	definition "flowderiv x0 t = comp12 (Dflow x0 t) (blinfun_scaleR_left (f (flow0 x0 t)))"

	lemma flowderiv_eq: "flowderiv x0 t (\<xi>\<^sub>1, \<xi>\<^sub>2) = (Dflow x0 t) \<xi>\<^sub>1 + \<xi>\<^sub>2 *\<^sub>R f (flow0 x0 t)"
	by (auto simp: flowderiv_def)

	lemma W_continuous_on: "continuous_on (Sigma X existence_ivl0) (\<lambda>(x0, t). Dflow x0 t)"
	\<comment> \<open>TODO: somewhere here is hidden continuity wrt rhs of ODE, extract it!\<close>
	unfolding continuous_on split_beta'
	proof (safe intro!: tendstoI)
	fix e'::real and t x assume x: "x \<in> X" and tx: "t \<in> existence_ivl0 x" and e': "e' > 0"
	let ?S = "Sigma X existence_ivl0"

	have "(x, t) \<in> ?S" using x tx by auto
	from open_prod_elim[OF open_state_space this]
	obtain OX OT where OXOT: "open OX" "open OT" "(x, t) \<in> OX \<times> OT" "OX \<times> OT \<subseteq> ?S"
	by blast
	then obtain dx dt
	where dx: "dx > 0" "cball x dx \<subseteq> OX"
	and dt: "dt > 0" "cball t dt \<subseteq> OT"
	by (force simp: open_contains_cball)

	from OXOT dt dx have "cball t dt \<subseteq> existence_ivl0 x" "cball x dx \<subseteq> X"
	apply (auto simp: subset_iff)
	subgoal for ta
	apply (drule spec[where x=ta])
	apply (drule spec[where x=t])+
	apply auto
	done
	done

	have one_exivl: "mvar.existence_ivl x 0 = (\<lambda>_. existence_ivl0 x)"
	by (rule mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \<open>x \<in> X\<close>]])

	have *: "closed ({t .. 0} \<union> {0 .. t})" "{t .. 0} \<union> {0 .. t} \<noteq> {}"
	by auto
	let ?T = "{t .. 0} \<union> {0 .. t} \<union> cball t dt"
	have "compact ?T"
	by (auto intro!: compact_Un)
	have "?T \<subseteq> existence_ivl0 x"
	by (intro Un_least ivl_subset_existence_ivl' ivl_subset_existence_ivl \<open>x \<in> X\<close>
	\<open>t \<in> existence_ivl0 x\<close> \<open>cball t dt \<subseteq> existence_ivl0 x\<close>)

	have "compact (mvar.flow x 0 id_blinfun ` ?T)"
	using \<open>?T \<subseteq> _\<close> \<open>x \<in> X\<close>
	mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \<open>x \<in> X\<close>]]
	by (auto intro!: \<open>0 < dx\<close> compact_continuous_image \<open>compact ?T\<close>
	continuous_on_subset[OF mvar.flow_continuous_on])

	let ?line = "mvar.flow x 0 id_blinfun ` ?T"
	let ?X = "{x. infdist x ?line \<le> dx}"
	have "compact ?X"
	using \<open>?T \<subseteq> _\<close> \<open>x \<in> X\<close>
	mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \<open>x \<in> X\<close>]]
	by (auto intro!: compact_infdist_le \<open>0 < dx\<close> compact_continuous_image compact_Un
	continuous_on_subset[OF mvar.flow_continuous_on ])

	from mvar.local_lipschitz \<open>?T \<subseteq> _\<close>
	have llc: "local_lipschitz ?T ?X (\<lambda>t. (o\<^sub>L) (vareq x t))"
	by (rule local_lipschitz_subset) auto

	have cont: "\<And>xa. xa \<in> ?X \<Longrightarrow> continuous_on ?T (\<lambda>t. vareq x t o\<^sub>L xa)"
	using \<open>?T \<subseteq> _\<close>
	by (auto intro!: continuous_intros \<open>x \<in> X\<close>)

	from local_lipschitz_compact_implies_lipschitz[OF llc \<open>compact ?X\<close> \<open>compact ?T\<close> cont]
	obtain K' where K': "\<And>ta. ta \<in> ?T \<Longrightarrow> K'-lipschitz_on ?X ((o\<^sub>L) (vareq x ta))"
	by blast
	define K where "K \<equiv> abs K' + 1"
	have "K > 0"
	by (simp add: K_def)
	have K: "\<And>ta. ta \<in> ?T \<Longrightarrow> K-lipschitz_on ?X ((o\<^sub>L) (vareq x ta))"
	by (auto intro!: lipschitz_onI mult_right_mono order_trans[OF lipschitz_onD[OF K']] simp: K_def)

	have ex_ivlI: "\<And>y. y \<in> cball x dx \<Longrightarrow> ?T \<subseteq> existence_ivl0 y"
	using dx dt OXOT
	by (intro Un_least ivl_subset_existence_ivl' ivl_subset_existence_ivl; force)

	have cont: "continuous_on ((?T \<times> ?X) \<times> cball x dx) (\<lambda>((ta, xa), y). (vareq y ta o\<^sub>L xa))"
	using \<open>cball x dx \<subseteq> X\<close> ex_ivlI
	by (force intro!: continuous_intros simp: split_beta' )

	have "mvar.flow x 0 id_blinfun t \<in> mvar.flow x 0 id_blinfun ` ({t..0} \<union> {0..t} \<union> cball t dt)"
	by auto
	then have mem: "(t, mvar.flow x 0 id_blinfun t, x) \<in> ?T \<times> ?X \<times> cball x dx"
	by (auto simp: \<open>0 < dx\<close> less_imp_le)

	define e where "e \<equiv> min e' (dx / 2) / 2"
	have "e > 0" using \<open>e' > 0\<close> by (auto simp: e_def \<open>0 < dx\<close>)
	define d where "d \<equiv> e * K / (exp (K * (abs t + abs dt + 1)) - 1)"
	have "d > 0" by (auto simp: d_def intro!: mult_pos_pos divide_pos_pos \<open>0 < e\<close> \<open>K > 0\<close>)

	have cmpct: "compact ((?T \<times> ?X) \<times> cball x dx)" "compact (?T \<times> ?X)"
	using \<open>compact ?T\<close> \<open>compact ?X\<close>
	by (auto intro!: compact_cball compact_Times)

	have compact_line: "compact ?line"
	using \<open>{t..0} \<union> {0..t} \<union> cball t dt \<subseteq> existence_ivl0 x\<close> one_exivl
	by (force intro!: compact_continuous_image \<open>compact ?T\<close> continuous_on_subset[OF mvar.flow_continuous_on] simp: \<open>x \<in> X\<close>)

	from compact_uniformly_continuous[OF cont cmpct(1), unfolded uniformly_continuous_on_def,
	rule_format, OF \<open>0 < d\<close>]
	obtain d' where d': "d' > 0"
	"\<And>ta xa xa' y. ta \<in> ?T \<Longrightarrow> xa \<in> ?X \<Longrightarrow> xa'\<in>cball x dx \<Longrightarrow> y\<in>cball x dx \<Longrightarrow> dist xa' y < d' \<Longrightarrow>
	dist (vareq xa' ta o\<^sub>L xa) (vareq y ta o\<^sub>L xa) < d"
	by (auto simp: dist_prod_def)
	{
	fix y
	assume dxy: "dist x y < d'"
	assume "y \<in> cball x dx"
	then have "y \<in> X"
	using dx dt OXOT by force+

	have two_exivl: "mvar.existence_ivl y 0 = (\<lambda>_. existence_ivl0 y)"
	by (rule mvar_existence_ivl_eq_existence_ivl[OF existence_ivl_zero[OF \<open>y \<in> X\<close>]])

	let ?X' = "\<Union>x \<in> ?line. ball x dx"
	have "open ?X'" by auto
	have "?X' \<subseteq> ?X"
	by (auto intro!: infdist_le2 simp: dist_commute)

	interpret oneR: ll_on_open "existence_ivl0 x" "(\<lambda>t. (o\<^sub>L) (vareq x t))" ?X'
	by standard (auto intro!: \<open>x \<in> X\<close> continuous_intros local_lipschitz_A[OF order_refl])
	interpret twoR: ll_on_open "existence_ivl0 y" "(\<lambda>t. (o\<^sub>L) (vareq y t))" ?X'
	by standard (auto intro!: \<open>y \<in> X\<close> continuous_intros local_lipschitz_A[OF order_refl])
	interpret both:
	two_ll_on_open "(\<lambda>t. (o\<^sub>L) (vareq x t))" "existence_ivl0 x" "(\<lambda>t. (o\<^sub>L) (vareq y t))" "existence_ivl0 y" ?X' ?T "id_blinfun" d K
	proof unfold_locales
	show "0 < K" by (simp add: \<open>0 < K\<close>)
	show iv_defined: "0 \<in> {t..0} \<union> {0..t} \<union> cball t dt"
	by auto
	show "is_interval ({t..0} \<union> {0..t} \<union> cball t dt)"
	by (auto simp: is_interval_def dist_real_def)
	show "{t..0} \<union> {0..t} \<union> cball t dt \<subseteq> oneR.existence_ivl 0 id_blinfun"
	apply (rule oneR.maximal_existence_flow[where x="mvar.flow x 0 id_blinfun"])
	subgoal
	apply (rule solves_odeI)
	apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF mvar.flow_solves_ode[of 0 x id_blinfun]]])
	subgoal using \<open>x \<in> X\<close> \<open>?T \<subseteq> _\<close> \<open>0 < dx\<close> by simp
	subgoal by simp
	subgoal by (simp add: \<open>cball t dt \<subseteq> existence_ivl0 x\<close> ivl_subset_existence_ivl ivl_subset_existence_ivl' one_exivl tx)
	subgoal using dx by (auto; force)
	done
	subgoal by (simp add: \<open>x \<in> X\<close>)
	subgoal by fact
	subgoal using iv_defined by blast
	subgoal using \<open>{t..0} \<union> {0..t} \<union> cball t dt \<subseteq> existence_ivl0 x\<close> by blast
	done
	fix s assume s: "s \<in> ?T"
	then show "K-lipschitz_on ?X' ((o\<^sub>L) (vareq x s))"
	by (intro lipschitz_on_subset[OF K \<open>?X' \<subseteq> ?X\<close>]) auto
	fix j assume j: "j \<in> ?X'"
	show "norm ((vareq x s o\<^sub>L j) - (vareq y s o\<^sub>L j)) < d"
	unfolding dist_norm[symmetric]
	apply (rule d')
	subgoal by (rule s)
	subgoal using \<open>?X' \<subseteq> ?X\<close> j ..
	subgoal using \<open>dx > 0\<close> by simp
	subgoal using \<open>y \<in> cball x dx\<close> by simp
	subgoal using dxy by simp
	done
	qed
	have less_e: "norm (Dflow x s - both.Y s) < e"
	if s: "s \<in> ?T \<inter> twoR.existence_ivl 0 id_blinfun" for s
	proof -
	from s have s_less: "\<bar>s\<bar> < \<bar>t\<bar> + \<bar>dt\<bar> + 1"
	by (auto simp: dist_real_def)
	note both.norm_X_Y_bound[rule_format, OF s]
	also have "d / K * (exp (K * \<bar>s\<bar>) - 1) =
	e * ((exp (K * \<bar>s\<bar>) - 1) / (exp (K * (\<bar>t\<bar> + \<bar>dt\<bar> + 1)) - 1))"
	by (simp add: d_def)
	also have "\<dots> < e * 1"
	by (rule mult_strict_left_mono[OF _ \<open>0 < e\<close>])
	(simp add: add_nonneg_pos \<open>0 < K\<close> \<open>0 < e\<close> s_less)
	also have "\<dots> = e" by simp
	also
	from s have s: "s \<in> ?T" by simp
	have "both.flow0 s = Dflow x s"
	unfolding both.flow0_def Dflow_def
	apply (rule oneR.maximal_existence_flow[where K="?T"])
	subgoal
	apply (rule solves_odeI)
	apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF mvar.flow_solves_ode[of 0 x id_blinfun]]])
	subgoal using \<open>x \<in> X\<close> \<open>0 < dx\<close> by simp
	subgoal by simp
	subgoal by (simp add: \<open>cball t dt \<subseteq> existence_ivl0 x\<close> ivl_subset_existence_ivl ivl_subset_existence_ivl' one_exivl tx)
	subgoal using dx by (auto; force)
	done
	subgoal by (simp add: \<open>x \<in> X\<close>)
	subgoal by (rule both.J_ivl)
	subgoal using both.t0_in_J by blast
	subgoal using \<open>{t..0} \<union> {0..t} \<union> cball t dt \<subseteq> existence_ivl0 x\<close> by blast
	subgoal using s by blast
	done
	finally show ?thesis .
	qed

	have "e < dx" using \<open>dx > 0\<close> by (auto simp: e_def)

	let ?i = "{y. infdist y (mvar.flow x 0 id_blinfun ` ?T) \<le> e}"
	have 1: "?i \<subseteq> (\<Union>x\<in>mvar.flow x 0 id_blinfun ` ?T. ball x dx)"
	proof -
	have cl: "closed ?line" "?line \<noteq> {}" using compact_line
	by (auto simp: compact_imp_closed)
	have "?i \<subseteq> (\<Union>y\<in>mvar.flow x 0 id_blinfun ` ?T. cball y e)"
	proof safe
	fix x
	assume H: "infdist x ?line \<le> e"
	from infdist_attains_inf[OF cl, of x]
	obtain y where "y \<in> ?line" "infdist x ?line = dist x y" by auto
	then show "x \<in> (\<Union>x\<in>?line. cball x e)"
	using H
	by (auto simp: dist_commute)
	qed
	also have "\<dots> \<subseteq> (\<Union>x\<in>?line. ball x dx)"
	using \<open>e < dx\<close>
	by auto
	finally show ?thesis .
	qed
	have 2: "twoR.flow 0 id_blinfun s \<in> ?i"
	if "s \<in> ?T" "s \<in> twoR.existence_ivl 0 id_blinfun" for s
	proof -
	from that have sT: "s \<in> ?T \<inter> twoR.existence_ivl 0 id_blinfun"
	by force
	from less_e[OF this]
	have "dist (twoR.flow 0 id_blinfun s) (mvar.flow x 0 id_blinfun s) \<le> e"
	unfolding Dflow_def both.Y_def dist_commute dist_norm by simp
	then show ?thesis
	using sT by (force intro: infdist_le2)
	qed
	have T_subset: "?T \<subseteq> twoR.existence_ivl 0 id_blinfun"
	apply (rule twoR.subset_mem_compact_implies_subset_existence_interval[
	where K="{x. infdist x ?line \<le> e}"])
	subgoal using \<open>0 < dt\<close> by force
	subgoal by (rule both.J_ivl)
	subgoal using \<open>y \<in> cball x dx\<close> ex_ivlI by blast
	subgoal using both.F_iv_defined(2) by blast
	subgoal by (rule 2)
	subgoal using \<open>dt > 0\<close> by (intro compact_infdist_le) (auto intro!: compact_line \<open>0 < e\<close>)
	subgoal by (rule 1)
	done
	also have "twoR.existence_ivl 0 id_blinfun \<subseteq> existence_ivl0 y"
	by (rule twoR.existence_ivl_subset)
	finally have "?T \<subseteq> existence_ivl0 y" .
	have "norm (Dflow x s - Dflow y s) < e" if s: "s \<in> ?T" for s
	proof -
	from s have "s \<in> ?T \<inter> twoR.existence_ivl 0 id_blinfun" using T_subset by force
	from less_e[OF this] have "norm (Dflow x s - both.Y s) < e" .
	also have "mvar.flow y 0 id_blinfun s = twoR.flow 0 id_blinfun s"
	apply (rule mvar.maximal_existence_flow[where K="?T"])
	subgoal
	apply (rule solves_odeI)
	apply (rule has_vderiv_on_subset[OF solves_odeD(1)[OF twoR.flow_solves_ode[of 0 id_blinfun]]])
	subgoal using \<open>y \<in> X\<close> by simp
	subgoal using both.F_iv_defined(2) by blast
	subgoal using T_subset by blast
	subgoal by simp
	done
	subgoal using \<open>y \<in> X\<close> auto_ll_on_open.existence_ivl_zero auto_ll_on_open_axioms both.F_iv_defined(2) twoR.flow_initial_time by blast
	subgoal by (rule both.J_ivl)
	subgoal using both.t0_in_J by blast
	subgoal using \<open>{t..0} \<union> {0..t} \<union> cball t dt \<subseteq> existence_ivl0 y\<close> by blast
	subgoal using s by blast
	done
	then have "both.Y s = Dflow y s"
	unfolding both.Y_def Dflow_def
	by simp
	finally show ?thesis .
	qed
	} note cont_data = this
	have "\<forall>\<^sub>F (y, s) in at (x, t) within ?S. dist x y < d'"
	unfolding at_within_open[OF \<open>(x, t) \<in> ?S\<close> open_state_space] UNIV_Times_UNIV[symmetric]
	using \<open>d' > 0\<close>
	by (intro eventually_at_Pair_within_TimesI1)
	(auto simp: eventually_at less_imp_le dist_commute)
	moreover
	have "\<forall>\<^sub>F (y, s) in at (x, t) within ?S. y \<in> cball x dx"
	unfolding at_within_open[OF \<open>(x, t) \<in> ?S\<close> open_state_space] UNIV_Times_UNIV[symmetric]
	using \<open>dx > 0\<close>
	by (intro eventually_at_Pair_within_TimesI1)
	(auto simp: eventually_at less_imp_le dist_commute)
	moreover
	have "\<forall>\<^sub>F (y, s) in at (x, t) within ?S. s \<in> ?T"
	unfolding at_within_open[OF \<open>(x, t) \<in> ?S\<close> open_state_space] UNIV_Times_UNIV[symmetric]
	using \<open>dt > 0\<close>
	by (intro eventually_at_Pair_within_TimesI2)
	(auto simp: eventually_at less_imp_le dist_commute)
	moreover
	have "0 \<in> existence_ivl0 x" by (simp add: \<open>x \<in> X\<close>)
	have "\<forall>\<^sub>F y in at t within existence_ivl0 x. dist (mvar.flow x 0 id_blinfun y) (mvar.flow x 0 id_blinfun t) < e"
	using mvar.flow_continuous_on[of x 0 id_blinfun]
	using \<open>0 < e\<close> tx
	by (auto simp add: continuous_on one_exivl dest!: tendstoD)
	then have "\<forall>\<^sub>F (y, s) in at (x, t) within ?S. dist (Dflow x s) (Dflow x t) < e"
	using \<open>0 < e\<close>
	unfolding at_within_open[OF \<open>(x, t) \<in> ?S\<close> open_state_space] UNIV_Times_UNIV[symmetric] Dflow_def
	by (intro eventually_at_Pair_within_TimesI2)
	(auto simp: at_within_open[OF tx open_existence_ivl])
	ultimately
	have "\<forall>\<^sub>F (y, s) in at (x, t) within ?S. dist (Dflow y s) (Dflow x t) < e'"
	apply eventually_elim
	proof (safe del: UnE, goal_cases)
	case (1 y s)
	have "dist (Dflow y s) (Dflow x t) \<le> dist (Dflow y s) (Dflow x s) + dist (Dflow x s) (Dflow x t)"
	by (rule dist_triangle)
	also
	have "dist (Dflow x s) (Dflow x t) < e"
	by (rule 1)
	also have "dist (Dflow y s) (Dflow x s) < e"
	unfolding dist_norm norm_minus_commute
	using 1
	by (intro cont_data)
	also have "e + e \<le> e'" by (simp add: e_def)
	finally show "dist (Dflow y s) (Dflow x t) < e'" by arith
	qed
	then show "\<forall>\<^sub>F ys in at (x, t) within ?S. dist (Dflow (fst ys) (snd ys)) (Dflow (fst (x, t)) (snd (x, t))) < e'"
	by (simp add: split_beta')
	qed

	lemma W_continuous_on_comp[continuous_intros]:
	assumes h: "continuous_on S h" and g: "continuous_on S g"
	shows "(\<And>s. s \<in> S \<Longrightarrow> h s \<in> X) \<Longrightarrow> (\<And>s. s \<in> S \<Longrightarrow> g s \<in> existence_ivl0 (h s)) \<Longrightarrow>
	continuous_on S (\<lambda>s. Dflow (h s) (g s))"
	using continuous_on_compose[OF continuous_on_Pair[OF h g] continuous_on_subset[OF W_continuous_on]]
	by auto

	lemma f_flow_continuous_on: "continuous_on (Sigma X existence_ivl0) (\<lambda>(x0, t). f (flow0 x0 t))"
	using flow_continuous_on_state_space
	by (auto intro!: continuous_on_f flow_in_domain simp: split_beta')

	lemma
	flow_has_space_derivative:
	assumes "t \<in> existence_ivl0 x0"
	shows "((\<lambda>x0. flow0 x0 t) has_derivative Dflow x0 t) (at x0)"
	by (rule flow_dx_derivative_blinfun[THEN has_derivative_eq_rhs])
	(simp_all add: var_eq_mvar assms blinfun.blinfun_apply_inverse Dflow_def vector_Dflow_def
	mem_existence_ivl_iv_defined[OF assms])

	lemma
	flow_has_flowderiv:
	assumes "t \<in> existence_ivl0 x0"
	shows "((\<lambda>(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within S)"
	proof -
	have Sigma: "(x0, t) \<in> Sigma X existence_ivl0"
	using assms by auto
	from open_state_space assms obtain e' where e': "e' > 0" "ball (x0, t) e' \<subseteq> Sigma X existence_ivl0"
	by (force simp: open_contains_ball)
	define e where "e = e' / sqrt 2"
	have "0 < e" using e' by (auto simp: e_def)
	have "ball x0 e \<times> ball t e \<subseteq> ball (x0, t) e'"
	by (auto simp: dist_prod_def real_sqrt_sum_squares_less e_def)
	also note e'(2)
	finally have subs: "ball x0 e \<times> ball t e \<subseteq> Sigma X existence_ivl0" .


	have d1: "((\<lambda>x0. flow0 x0 s) has_derivative blinfun_apply (Dflow y s)) (at y within ball x0 e)"
	if "y \<in> ball x0 e" "s \<in> ball t e" for y s
	using subs that
	by (subst at_within_open; force intro!: flow_has_space_derivative)
	have d2: "(flow0 y has_derivative blinfun_apply (blinfun_scaleR_left (f (flow0 y s)))) (at s within ball t e)"
	if "y \<in> ball x0 e" "s \<in> ball t e" for y s
	using subs that
	unfolding has_vector_derivative_eq_has_derivative_blinfun[symmetric]
	by (subst at_within_open; force intro!: flow_has_vector_derivative)
	have "((\<lambda>(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within ball x0 e \<times> ball t e)"
	using subs
	unfolding UNIV_Times_UNIV[symmetric]
	by (intro has_derivative_partialsI[OF d1 d2, THEN has_derivative_eq_rhs])
	(auto intro!: \<open>0 < e\<close> continuous_intros flow_in_domain
	continuous_on_imp_continuous_within[where s="Sigma X existence_ivl0"]
	assms
	simp: flowderiv_def split_beta' flow0_defined assms mem_ball)
	then have "((\<lambda>(x0, t). flow0 x0 t) has_derivative flowderiv x0 t) (at (x0, t) within Sigma X existence_ivl0)"
	by (auto simp: at_within_open[OF _ open_state_space] at_within_open[OF _ open_Times] assms \<open>0 < e\<close>
	mem_existence_ivl_iv_defined[OF assms])
	then show ?thesis unfolding at_within_open[OF Sigma open_state_space]
	by (rule has_derivative_at_withinI)
	qed

	lemma flow0_comp_has_derivative:
	assumes h: "h s \<in> existence_ivl0 (g s)"
	assumes [derivative_intros]: "(g has_derivative g') (at s within S)"
	assumes [derivative_intros]: "(h has_derivative h') (at s within S)"
	shows "((\<lambda>x. flow0 (g x) (h x)) has_derivative (\<lambda>x. blinfun_apply (flowderiv (g s) (h s)) (g' x, h' x)))
	(at s within S)"
	by (rule has_derivative_compose[where f="\<lambda>x. (g x, h x)" and s=S,
	OF _ flow_has_flowderiv[OF h], simplified])
	(auto intro!: derivative_eq_intros)

	lemma flowderiv_continuous_on: "continuous_on (Sigma X existence_ivl0) (\<lambda>(x0, t). flowderiv x0 t)"
	unfolding flowderiv_def split_beta'
	by (subst blinfun_of_matrix_works[where f="comp12 (Dflow (fst x) (snd x))
	(blinfun_scaleR_left (f (flow0 (fst x) (snd x))))" for x, symmetric])
	(auto intro!: continuous_intros flow_in_domain)

	lemma flowderiv_continuous_on_comp[continuous_intros]:
	assumes "continuous_on S x"
	assumes "continuous_on S t"
	assumes "\<And>s. s \<in> S \<Longrightarrow> x s \<in> X" "\<And>s. s \<in> S \<Longrightarrow> t s \<in> existence_ivl0 (x s)"
	shows "continuous_on S (\<lambda>xa. flowderiv (x xa) (t xa))"
	by (rule continuous_on_compose2[OF flowderiv_continuous_on, where f="\<lambda>s. (x s, t s)",
	unfolded split_beta' fst_conv snd_conv])
	(auto intro!: continuous_intros assms)

	lemmas [intro] = flow_in_domain

	lemma vareq_trans: "t0 \<in> existence_ivl0 x0 \<Longrightarrow> t \<in> existence_ivl0 (flow0 x0 t0) \<Longrightarrow>
	vareq (flow0 x0 t0) t = vareq x0 (t0 + t)"
	by (auto simp: vareq_def flow_trans)

	lemma diff_existence_ivl_trans:
	"t0 \<in> existence_ivl0 x0 \<Longrightarrow> t \<in> existence_ivl0 x0 \<Longrightarrow> t - t0 \<in> existence_ivl0 (flow0 x0 t0)" for t
	by (metis (no_types, opaque_lifting) add.left_neutral diff_add_eq
	local.existence_ivl_reverse local.existence_ivl_trans local.flows_reverse)

	lemma has_vderiv_on_blinfun_compose_right[derivative_intros]:
	assumes "(g has_vderiv_on g') T"
	assumes "\<And>x. x \<in> T \<Longrightarrow> gd' x = g' x o\<^sub>L d"
	shows "((\<lambda>x. g x o\<^sub>L d) has_vderiv_on gd') T"
	using assms
	by (auto simp: has_vderiv_on_def has_vector_derivative_def blinfun_ext blinfun.bilinear_simps
	intro!: derivative_eq_intros ext)

	lemma has_vderiv_on_blinfun_compose_left[derivative_intros]:
	assumes "(g has_vderiv_on g') T"
	assumes "\<And>x. x \<in> T \<Longrightarrow> gd' x = d o\<^sub>L g' x"
	shows "((\<lambda>x. d o\<^sub>L g x) has_vderiv_on gd') T"
	using assms
	by (auto simp: has_vderiv_on_def has_vector_derivative_def blinfun_ext blinfun.bilinear_simps
	intro!: derivative_eq_intros ext)

	lemma mvar_flow_shift:
	assumes "t0 \<in> existence_ivl0 x0" "t1 \<in> existence_ivl0 x0"
	shows "mvar.flow x0 t0 d t1 = Dflow (flow0 x0 t0) (t1 - t0) o\<^sub>L d"
	proof -
	have "mvar.flow x0 t0 d t1 = mvar.flow x0 t0 d (t0 + (t1 - t0))"
	by simp
	also have "\<dots> = mvar.flow x0 t0 (mvar.flow x0 t0 d t0) t1"
	by (subst mvar.flow_trans) (auto simp add: assms)
	also have "\<dots> = Dflow (flow0 x0 t0) (t1 - t0) o\<^sub>L d"
	apply (rule mvar.flow_unique_on)
	apply (auto simp add: assms mvar.flow_initial_time_if blinfun_ext Dflow_def
	intro!: derivative_intros derivative_eq_intros)
	apply (auto simp: assms has_vderiv_on_open has_vector_derivative_def
	intro!: derivative_eq_intros blinfun_eqI)
	apply (subst mvar_existence_ivl_eq_existence_ivl)
	by (auto simp add: vareq_trans assms diff_existence_ivl_trans)
	finally show ?thesis .
	qed

	lemma Dflow_trans:
	assumes "h \<in> existence_ivl0 x0"
	assumes "i \<in> existence_ivl0 (flow0 x0 h)"
	shows "Dflow x0 (h + i) = Dflow (flow0 x0 h) i o\<^sub>L (Dflow x0 h)"
	proof -
	have [intro, simp]: "h + i \<in> existence_ivl0 x0" "i + h \<in> existence_ivl0 x0" "x0 \<in> X"
	using assms
	by (auto simp add: add.commute existence_ivl_trans)
	show ?thesis
	unfolding Dflow_def
	apply (subst mvar.flow_trans[where s=h and t=i])
	subgoal by (auto simp: assms)
	subgoal by (auto simp: assms)
	by (subst mvar_flow_shift) (auto simp: assms Dflow_def )
	qed

	lemma Dflow_trans_apply:
	assumes "h \<in> existence_ivl0 x0"
	assumes "i \<in> existence_ivl0 (flow0 x0 h)"
	shows "Dflow x0 (h + i) d0 = Dflow (flow0 x0 h) i (Dflow x0 h d0)"
	proof -
	have [intro, simp]: "h + i \<in> existence_ivl0 x0" "i + h \<in> existence_ivl0 x0" "x0 \<in> X"
	using assms
	by (auto simp add: add.commute existence_ivl_trans)
	show ?thesis
	unfolding Dflow_def
	apply (subst mvar.flow_trans[where s=h and t=i])
	subgoal by (auto simp: assms)
	subgoal by (auto simp: assms)
	by (subst mvar_flow_shift) (auto simp: assms Dflow_def )
	qed


	end \<comment> \<open>@{thm c1_on_open_euclidean_anchor}\<close>

	end
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Flow_Congs.thy b/thys/Ordinary_Differential_Equations/IVP/Flow_Congs.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Flow_Congs.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Flow_Congs.thy
	@@ -1,472 +1,472 @@
	theory Flow_Congs
	imports Reachability_Analysis
	begin

	lemma lipschitz_on_congI:
	assumes "L'-lipschitz_on s' g'"
	assumes "s' = s"
	assumes "L' \<le> L"
	assumes "\<And>x y. x \<in> s \<Longrightarrow> g' x = g x"
	shows "L-lipschitz_on s g"
	using assms
	by (auto simp: lipschitz_on_def intro!: order_trans[OF _ mult_right_mono[OF \<open>L' \<le> L\<close>]])

	lemma local_lipschitz_congI:
	assumes "local_lipschitz s' t' g'"
	assumes "s' = s"
	assumes "t' = t"
	assumes "\<And>x y. x \<in> s \<Longrightarrow> y \<in> t \<Longrightarrow> g' x y = g x y"
	shows "local_lipschitz s t g"
	proof -
	from assms have "local_lipschitz s t g'"
	by (auto simp: local_lipschitz_def)
	then show ?thesis
	apply (auto simp: local_lipschitz_def)
	apply (drule_tac bspec, assumption)
	apply (drule_tac bspec, assumption)
	apply auto
	subgoal for x y u L
	apply (rule exI[where x=u])
	apply (auto intro!: exI[where x=L])
	apply (drule bspec)
	apply simp
	apply (rule lipschitz_on_congI, assumption, rule refl, rule order_refl)
	using assms
	apply (auto)
	done
	done
	qed

	context ll_on_open_it\<comment> \<open>TODO: do this more generically for @{const ll_on_open_it}\<close>
	begin

	context fixes S Y g assumes cong: "X = Y" "T = S" "\<And>x t. x \<in> Y \<Longrightarrow> t \<in> S \<Longrightarrow> f t x = g t x"
	begin

	lemma ll_on_open_congI: "ll_on_open S g Y"
	proof -
	interpret Y: ll_on_open_it S f Y t0
	apply (subst cong(1)[symmetric])
	apply (subst cong(2)[symmetric])
	by unfold_locales
	show ?thesis
	apply standard
	subgoal
	using local_lipschitz
	apply (rule local_lipschitz_congI)
	using cong by simp_all
	subgoal apply (subst continuous_on_cong) prefer 3 apply (rule cont)
	using cong by (auto)
	subgoal using open_domain by (auto simp: cong)
	subgoal using open_domain by (auto simp: cong)
	done
	qed

	lemma existence_ivl_subsetI:
	assumes t: "t \<in> existence_ivl t0 x0"
	shows "t \<in> ll_on_open.existence_ivl S g Y t0 x0"
	proof -
	from assms have \<open>t0 \<in> T\<close> "x0 \<in> X"
	by (rule mem_existence_ivl_iv_defined)+
	interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
	have "(flow t0 x0 solves_ode f) (existence_ivl t0 x0) X"
	by (rule flow_solves_ode) (auto simp: \<open>x0 \<in> X\<close> \<open>t0 \<in> T\<close>)
	then have "(flow t0 x0 solves_ode f) {t0--t} X"
	by (rule solves_ode_on_subset)
	(auto simp add: t local.closed_segment_subset_existence_ivl)
	then have "(flow t0 x0 solves_ode g) {t0--t} Y"
	apply (rule solves_ode_congI)
	apply (auto intro!: assms cong)
	using \<open>(flow t0 x0 solves_ode f) {t0--t} X\<close> local.cong(1) solves_ode_domainD apply blast
	using \<open>t0 \<in> T\<close> assms closed_segment_subset_domainI general.mem_existence_ivl_subset local.cong(2)
	by blast
	then show ?thesis
	apply (rule Y.existence_ivl_maximal_segment)
	subgoal by (simp add: \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>)
	apply (subst cong[symmetric])
	using \<open>t0 \<in> T\<close> assms closed_segment_subset_domainI general.mem_existence_ivl_subset local.cong(2)
	by blast
	qed

	lemma existence_ivl_cong:
	shows "existence_ivl t0 x0 = ll_on_open.existence_ivl S g Y t0 x0"
	proof -
	interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
	show ?thesis
	apply (auto )
	subgoal by (rule existence_ivl_subsetI)
	subgoal
	apply (rule Y.existence_ivl_subsetI)
	using cong
	by auto
	done
	qed

	lemma flow_cong:
	assumes "t \<in> existence_ivl t0 x0"
	shows "flow t0 x0 t = ll_on_open.flow S g Y t0 x0 t"
	proof -
	interpret Y: ll_on_open S g Y by (rule ll_on_open_congI)
	from assms have "t0 \<in> T" "x0 \<in> X"
	by (rule mem_existence_ivl_iv_defined)+
	from cong \<open>x0 \<in> X\<close> have "x0 \<in> Y" by auto
	from cong \<open>t0 \<in> T\<close> have "t0 \<in> S" by auto
	show ?thesis
	apply (rule Y.equals_flowI[where T'="existence_ivl t0 x0"])
	subgoal using \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close> by auto
	subgoal using \<open>x0 \<in> X\<close> by auto
	subgoal by (auto simp: existence_ivl_cong \<open>x0 \<in> X\<close>)
	subgoal
	apply (rule solves_ode_congI)
	apply (rule flow_solves_ode[OF \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>])
	using existence_ivl_subset[of x0]
	by (auto simp: cong(2)[symmetric] cong(1)[symmetric] assms flow_in_domain intro!: cong)
	subgoal using \<open>t0 \<in> S\<close> \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close>
	by (auto simp:)
	subgoal by fact
	done
	qed

	end

	end

	context auto_ll_on_open begin

	context fixes Y g assumes cong: "X = Y" "\<And>x t. x \<in> Y \<Longrightarrow> f x = g x"
	begin

	lemma auto_ll_on_open_congI: "auto_ll_on_open g Y"
	apply unfold_locales
	subgoal
	using local_lipschitz
	apply (rule local_lipschitz_congI)
	using cong by auto
	subgoal
	using open_domain
	using cong by auto
	done

	lemma existence_ivl0_cong:
	shows "existence_ivl0 x0 = auto_ll_on_open.existence_ivl0 g Y x0"
	proof -
	interpret Y: auto_ll_on_open g Y by (rule auto_ll_on_open_congI)
	show ?thesis
	unfolding Y.existence_ivl0_def
	apply (rule existence_ivl_cong)
	using cong by auto
	qed

	lemma flow0_cong:
	assumes "t \<in> existence_ivl0 x0"
	shows "flow0 x0 t = auto_ll_on_open.flow0 g Y x0 t"
	proof -
	interpret Y: auto_ll_on_open g Y by (rule auto_ll_on_open_congI)
	show ?thesis
	unfolding Y.flow0_def
	apply (rule flow_cong)
	using cong assms by auto
	qed

	end

	end


	context c1_on_open_euclidean begin

	context fixes Y g assumes cong: "X = Y" "\<And>x t. x \<in> Y \<Longrightarrow> f x = g x"
	begin

	lemma f'_cong: "(g has_derivative blinfun_apply (f' x)) (at x)" if "x \<in> Y"
	proof -
	from derivative_rhs[of x] that cong
	have "(f has_derivative blinfun_apply (f' x)) (at x within Y)"
	by (auto intro!: has_derivative_at_withinI)
	then have "(g has_derivative blinfun_apply (f' x)) (at x within Y)"
	by (rule has_derivative_transform_within[OF _ zero_less_one that])
	(auto simp: cong)
	then show ?thesis
	using at_within_open[OF that] cong open_dom
	- by (auto simp: )
	+ by auto
	qed

	lemma c1_on_open_euclidean_congI: "c1_on_open_euclidean g f' Y"
	proof -
	interpret Y: c1_on_open_euclidean f f' Y unfolding cong[symmetric] by unfold_locales
	show ?thesis
	apply standard
	subgoal using cong by simp
	subgoal by (rule f'_cong)
	subgoal by (simp add: cong[symmetric] continuous_derivative)
	done
	qed

	lemma vareq_cong: "vareq x0 t = c1_on_open_euclidean.vareq g f' Y x0 t"
	if "t \<in> existence_ivl0 x0"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	unfolding vareq_def Y.vareq_def
	apply (rule arg_cong[where f=f'])
	apply (rule flow0_cong)
	using cong that by auto
	qed

	lemma Dflow_cong:
	assumes "t \<in> existence_ivl0 x0"
	shows "Dflow x0 t = c1_on_open_euclidean.Dflow g f' Y x0 t"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	from assms have "x0 \<in> X"
	by (rule mem_existence_ivl_iv_defined)
	from cong \<open>x0 \<in> X\<close> have "x0 \<in> Y" by auto
	show ?thesis
	unfolding Dflow_def Y.Dflow_def
	apply (rule mvar.equals_flowI[symmetric, OF _ _ order_refl])
	subgoal using \<open>x0 \<in> X\<close> by auto
	subgoal using \<open>x0 \<in> X\<close> by auto
	subgoal
	apply (rule solves_ode_congI)
	apply (rule Y.mvar.flow_solves_ode)
	prefer 3 apply (rule refl)
	subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
	subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
	subgoal for t
	apply (subst vareq_cong)
	apply (subst (asm) Y.mvar_existence_ivl_eq_existence_ivl)
	subgoal using \<open>x0 \<in> Y\<close> by simp
	subgoal
	using cong
	by (subst (asm) existence_ivl0_cong[symmetric]) auto
	subgoal using \<open>x0 \<in> Y\<close> by simp
	done
	subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close>
	apply (subst mvar_existence_ivl_eq_existence_ivl)
	subgoal by simp
	apply (subst Y.mvar_existence_ivl_eq_existence_ivl)
	subgoal by simp
	using cong
	by (subst existence_ivl0_cong[symmetric]) auto
	subgoal by simp
	done
	subgoal using \<open>x0 \<in> X\<close> \<open>x0 \<in> Y\<close> by auto
	subgoal
	apply (subst mvar_existence_ivl_eq_existence_ivl)
	apply auto
	apply fact+
	done
	done
	qed

	lemma flowsto_congI1:
	assumes "flowsto A B C D"
	shows "c1_on_open_euclidean.flowsto g f' Y A B C D"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	using assms
	unfolding flowsto_def Y.flowsto_def
	apply (auto simp: existence_ivl0_cong[OF cong] flow0_cong[OF cong])
	apply (drule bspec, assumption)
	apply clarsimp
	apply (rule bexI)
	apply (rule conjI)
	apply assumption
	apply (subst flow0_cong[symmetric, OF cong])
	apply auto
	apply (subst existence_ivl0_cong[OF cong])
	apply auto
	apply (subst Dflow_cong[symmetric])
	apply auto
	apply (subst existence_ivl0_cong[OF cong])
	apply auto
	apply (drule bspec, assumption)
	apply (subst flow0_cong[symmetric, OF cong])
	apply auto
	apply (subst existence_ivl0_cong[OF cong])
	apply auto defer
	apply (subst Dflow_cong[symmetric])
	apply auto
	apply (subst existence_ivl0_cong[OF cong])
	apply auto
	apply (drule Y.closed_segment_subset_existence_ivl;
	auto simp: open_segment_eq_real_ivl closed_segment_eq_real_ivl split: if_splits)+
	done
	qed

	lemma flowsto_congI2:
	assumes "c1_on_open_euclidean.flowsto g f' Y A B C D"
	shows "flowsto A B C D"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	apply (rule Y.flowsto_congI1)
	using assms
	by (auto simp: cong)
	qed

	lemma flowsto_congI: "flowsto A B C D = c1_on_open_euclidean.flowsto g f' Y A B C D"
	using flowsto_congI1[of A B C D] flowsto_congI2[of A B C D] by auto

	lemma
	returns_to_congI1:
	assumes "returns_to A x"
	shows "auto_ll_on_open.returns_to g Y A x"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	from assms obtain t where t:
	"\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> A"
	"0 < t" "t \<in> existence_ivl0 x" "flow0 x t \<in> A"
	by (auto simp: returns_to_def)

	note t(1)
	moreover
	have "\<forall>\<^sub>F s in at_right 0. s < t"
	using tendsto_ident_at \<open>0 < t\<close>
	by (rule order_tendstoD)
	moreover have "\<forall>\<^sub>F s in at_right 0. 0 < s"
	by (auto simp: eventually_at_topological)
	ultimately have "\<forall>\<^sub>F t in at_right 0. Y.flow0 x t \<notin> A"
	apply eventually_elim
	using ivl_subset_existence_ivl[OF \<open>t \<in> _\<close>]
	apply (subst (asm) flow0_cong[OF cong])
	- by (auto simp: )
	+ by auto

	moreover have "\<exists>t>0. t \<in> Y.existence_ivl0 x \<and> Y.flow0 x t \<in> A"
	using t
	by (auto intro!: exI[where x=t] simp: flow0_cong[OF cong] existence_ivl0_cong[OF cong])
	ultimately show ?thesis
	by (auto simp: Y.returns_to_def)
	qed

	lemma
	returns_to_congI2:
	assumes "auto_ll_on_open.returns_to g Y x A"
	shows "returns_to x A"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	by (rule Y.returns_to_congI1) (auto simp: assms cong)
	qed

	lemma returns_to_cong: "auto_ll_on_open.returns_to g Y A x = returns_to A x"
	using returns_to_congI1 returns_to_congI2 by blast

	lemma
	return_time_cong:
	shows "return_time A x = auto_ll_on_open.return_time g Y A x"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	have P_eq: "0 < t \<and> t \<in> existence_ivl0 x \<and> flow0 x t \<in> A \<and> (\<forall>s\<in>{0<..<t}. flow0 x s \<notin> A) \<longleftrightarrow>
	0 < t \<and> t \<in> Y.existence_ivl0 x \<and> Y.flow0 x t \<in> A \<and> (\<forall>s\<in>{0<..<t}. Y.flow0 x s \<notin> A)"
	for t
	using ivl_subset_existence_ivl[of t x]
	apply (auto simp: existence_ivl0_cong[OF cong] flow0_cong[OF cong])
	apply (drule bspec)
	apply force
	apply (subst (asm) flow0_cong[OF cong])
	apply auto
	apply (auto simp: existence_ivl0_cong[OF cong, symmetric] flow0_cong[OF cong])
	apply (subst (asm) flow0_cong[OF cong])
	apply auto
	done
	show ?thesis
	unfolding return_time_def Y.return_time_def
	by (auto simp: returns_to_cong P_eq)
	qed

	lemma poincare_mapsto_congI1:
	assumes "poincare_mapsto A B C D E" "closed A"
	shows "c1_on_open_euclidean.poincare_mapsto g Y A B C D E"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	using assms
	unfolding poincare_mapsto_def Y.poincare_mapsto_def
	apply auto
	subgoal for a b
	by (rule returns_to_congI1) auto
	subgoal for a b
	by (subst return_time_cong[abs_def, symmetric]) auto
	subgoal for a b
	unfolding poincare_map_def Y.poincare_map_def
	apply (drule bspec, assumption)
	apply safe
	subgoal for D
	apply (auto intro!: exI[where x=D])
	subgoal premises prems
	proof -
	have "\<forall>\<^sub>F y in at a within C. returns_to A y"
	apply (rule eventually_returns_to_continuousI)
	apply fact apply fact
	apply (rule differentiable_imp_continuous_within)
	apply fact
	done
	moreover have "\<forall>\<^sub>F y in at a within C. y \<in> C"
	by (auto simp: eventually_at_filter)
	ultimately have "\<forall>\<^sub>F x' in at a within C. flow0 x' (return_time A x') = Y.flow0 x' (Y.return_time A x')"
	proof eventually_elim
	case (elim x')
	then show ?case
	apply (subst flow0_cong[OF cong, symmetric], force)
	apply (subst return_time_cong[symmetric])
	using prems
	apply (auto intro!: return_time_exivl)
	apply (subst return_time_cong[symmetric])
	apply auto
	done
	qed
	with prems(7)
	show ?thesis
	apply (rule has_derivative_transform_eventually)
	using prems
	apply (subst flow0_cong[OF cong, symmetric], force)
	apply (subst return_time_cong[symmetric])
	using prems
	apply (auto intro!: return_time_exivl)
	apply (subst return_time_cong[symmetric])
	apply auto
	done
	qed
	subgoal
	apply (subst flow0_cong[OF cong, symmetric], force)
	apply (subst return_time_cong[symmetric])
	apply (auto intro!: return_time_exivl)
	apply (subst return_time_cong[symmetric])
	apply auto
	done
	done
	done
	subgoal for a b t
	apply (drule bspec, assumption)
	apply (subst flow0_cong[OF cong, symmetric])
	apply auto
	apply (subst (asm) return_time_cong[symmetric])
	apply (rule less_return_time_imp_exivl)
	apply (rule less_imp_le, assumption)
	apply (auto simp: return_time_cong)
	done
	done
	qed

	lemma poincare_mapsto_congI2:
	assumes "c1_on_open_euclidean.poincare_mapsto g Y A B C D E" "closed A"
	shows "poincare_mapsto A B C D E"
	proof -
	interpret Y: c1_on_open_euclidean g f' Y by (rule c1_on_open_euclidean_congI)
	show ?thesis
	apply (rule Y.poincare_mapsto_congI1)
	using assms
	by (auto simp: cong)
	qed

	lemma poincare_mapsto_cong: "closed A \<Longrightarrow>
	poincare_mapsto A B C D E = c1_on_open_euclidean.poincare_mapsto g Y A B C D E"
	using poincare_mapsto_congI1[of A B C] poincare_mapsto_congI2[of A B C] by auto

	end

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Picard_Lindeloef_Qualitative.thy b/thys/Ordinary_Differential_Equations/IVP/Picard_Lindeloef_Qualitative.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Picard_Lindeloef_Qualitative.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Picard_Lindeloef_Qualitative.thy
	@@ -1,1020 +1,1020 @@
	theory Picard_Lindeloef_Qualitative
	imports Initial_Value_Problem
	begin

	subsection \<open>Picard-Lindeloef On Open Domains\<close>
	text\<open>\label{sec:qpl}\<close>

	subsubsection \<open>Local Solution with local Lipschitz\<close>
	text\<open>\label{sec:qpl-lipschitz}\<close>

	lemma cball_eq_closed_segment_real:
	fixes x e::real
	shows "cball x e = (if e \<ge> 0 then {x - e -- x + e} else {})"
	by (auto simp: closed_segment_eq_real_ivl dist_real_def mem_cball)

	lemma cube_in_cball:
	fixes x y :: "'a::euclidean_space"
	assumes "r > 0"
	assumes "\<And>i. i\<in> Basis \<Longrightarrow> dist (x \<bullet> i) (y \<bullet> i) \<le> r / sqrt(DIM('a))"
	shows "y \<in> cball x r"
	unfolding mem_cball euclidean_dist_l2[of x y] L2_set_def
	proof -
	have "(\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2) \<le> (\<Sum>(i::'a)\<in>Basis. (r / sqrt(DIM('a)))\<^sup>2)"
	proof (intro sum_mono)
	fix i :: 'a
	assume "i \<in> Basis"
	thus "(dist (x \<bullet> i) (y \<bullet> i))\<^sup>2 \<le> (r / sqrt(DIM('a)))\<^sup>2"
	using assms
	by (auto intro: sqrt_le_D)
	qed
	moreover
	have "... \<le> r\<^sup>2"
	using assms by (simp add: power_divide)
	ultimately
	show "sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (y \<bullet> i))\<^sup>2) \<le> r"
	using assms by (auto intro!: real_le_lsqrt sum_nonneg)
	qed

	lemma cbox_in_cball':
	fixes x::"'a::euclidean_space"
	assumes "0 < r"
	shows "\<exists>b > 0. b \<le> r \<and> (\<exists>B. B = (\<Sum>i\<in>Basis. b *\<^sub>R i) \<and> (\<forall>y \<in> cbox (x - B) (x + B). y \<in> cball x r))"
	proof (rule, safe)
	have "r / sqrt (real DIM('a)) \<le> r / 1"
	using assms by (auto simp: divide_simps real_of_nat_ge_one_iff)
	thus "r / sqrt (real DIM('a)) \<le> r" by simp
	next
	let ?B = "\<Sum>i\<in>Basis. (r / sqrt (real DIM('a))) *\<^sub>R i"
	show "\<exists>B. B = ?B \<and> (\<forall>y \<in> cbox (x - B) (x + B). y \<in> cball x r)"
	proof (rule, safe)
	fix y::'a
	assume "y \<in> cbox (x - ?B) (x + ?B)"
	hence bounds:
	"\<And>i. i \<in> Basis \<Longrightarrow> (x - ?B) \<bullet> i \<le> y \<bullet> i"
	"\<And>i. i \<in> Basis \<Longrightarrow> y \<bullet> i \<le> (x + ?B) \<bullet> i"
	by (auto simp: mem_box)
	show "y \<in> cball x r"
	proof (intro cube_in_cball)
	fix i :: 'a
	assume "i\<in> Basis"
	with bounds
	have bounds_comp:
	"x \<bullet> i - r / sqrt (real DIM('a)) \<le> y \<bullet> i"
	"y \<bullet> i \<le> x \<bullet> i + r / sqrt (real DIM('a))"
	by (auto simp: algebra_simps)
	thus "dist (x \<bullet> i) (y \<bullet> i) \<le> r / sqrt (real DIM('a))"
	unfolding dist_real_def by simp
	qed (auto simp add: assms)
	qed (rule)
	qed (auto simp: assms)

	lemma Pair1_in_Basis: "i \<in> Basis \<Longrightarrow> (i, 0) \<in> Basis"
	and Pair2_in_Basis: "i \<in> Basis \<Longrightarrow> (0, i) \<in> Basis"
	by (auto simp: Basis_prod_def)

	lemma le_real_sqrt_sumsq' [simp]: "y \<le> sqrt (x * x + y * y)"
	by (simp add: power2_eq_square [symmetric])

	lemma cball_Pair_split_subset: "cball (a, b) c \<subseteq> cball a c \<times> cball b c"
	by (auto simp: dist_prod_def mem_cball power2_eq_square
	intro: order_trans[OF le_real_sqrt_sumsq] order_trans[OF le_real_sqrt_sumsq'])

	lemma cball_times_subset: "cball a (c/2) \<times> cball b (c/2) \<subseteq> cball (a, b) c"
	proof -
	{
	fix a' b'
	have "sqrt ((dist a a')\<^sup>2 + (dist b b')\<^sup>2) \<le> dist a a' + dist b b'"
	by (rule real_le_lsqrt) (auto simp: power2_eq_square algebra_simps)
	also assume "a' \<in> cball a (c / 2)"
	then have "dist a a' \<le> c / 2" by (simp add: mem_cball)
	also assume "b' \<in> cball b (c / 2)"
	then have "dist b b' \<le> c / 2" by (simp add: mem_cball)
	finally have "sqrt ((dist a a')\<^sup>2 + (dist b b')\<^sup>2) \<le> c"
	by simp
	} thus ?thesis by (auto simp: dist_prod_def mem_cball)
	qed

	lemma eventually_bound_pairE:
	assumes "isCont f (t0, x0)"
	obtains B where
	"B \<ge> 1"
	"eventually (\<lambda>e. \<forall>x \<in> cball t0 e \<times> cball x0 e. norm (f x) \<le> B) (at_right 0)"
	proof -
	from assms[simplified isCont_def, THEN tendstoD, OF zero_less_one]
	obtain d::real where d: "d > 0"
	"\<And>x. x \<noteq> (t0, x0) \<Longrightarrow> dist x (t0, x0) < d \<Longrightarrow> dist (f x) (f (t0, x0)) < 1"
	by (auto simp: eventually_at)
	have bound: "norm (f (t, x)) \<le> norm (f (t0, x0)) + 1"
	if "t \<in> cball t0 (d/3)" "x \<in> cball x0 (d/3)" for t x
	proof -
	from that have "norm (f (t, x) - f (t0, x0)) < 1"
	using \<open>0 < d\<close>
	unfolding dist_norm[symmetric]
	apply (cases "(t, x) = (t0, x0)", force)
	by (rule d) (auto simp: dist_commute dist_prod_def mem_cball
	intro!: le_less_trans[OF sqrt_sum_squares_le_sum_abs])
	then show ?thesis
	by norm
	qed
	have "norm (f (t0, x0)) + 1 \<ge> 1"
	"eventually (\<lambda>e. \<forall>x \<in> cball t0 e \<times> cball x0 e.
	norm (f x) \<le> norm (f (t0, x0)) + 1) (at_right 0)"
	using d(1) bound
	by (auto simp: eventually_at dist_real_def mem_cball intro!: exI[where x="d/3"])
	thus ?thesis ..
	qed

	lemma
	eventually_in_cballs:
	assumes "d > 0" "c > 0"
	shows "eventually (\<lambda>e. cball t0 (c * e) \<times> (cball x0 e) \<subseteq> cball (t0, x0) d) (at_right 0)"
	using assms
	by (auto simp: eventually_at dist_real_def field_simps dist_prod_def mem_cball
	intro!: exI[where x="min d (d / c) / 3"]
	order_trans[OF sqrt_sum_squares_le_sum_abs])

	lemma cball_eq_sing':
	fixes x :: "'a::{metric_space,perfect_space}"
	shows "cball x e = {y} \<longleftrightarrow> e = 0 \<and> x = y"
	using cball_eq_sing[of x e]
	apply (cases "x = y", force)
	by (metis cball_empty centre_in_cball insert_not_empty not_le singletonD)

	locale ll_on_open = interval T for T +
	fixes f::"real \<Rightarrow> 'a::{banach, heine_borel} \<Rightarrow> 'a" and X
	assumes local_lipschitz: "local_lipschitz T X f"
	assumes cont: "\<And>x. x \<in> X \<Longrightarrow> continuous_on T (\<lambda>t. f t x)"
	assumes open_domain[intro!, simp]: "open T" "open X"
	begin

	text \<open>all flows on closed segments\<close>

	definition csols where
	"csols t0 x0 = {(x, t1). {t0--t1} \<subseteq> T \<and> x t0 = x0 \<and> (x solves_ode f) {t0--t1} X}"

	text \<open>the maximal existence interval\<close>

	definition "existence_ivl t0 x0 = (\<Union>(x, t1)\<in>csols t0 x0 . {t0--t1})"

	text \<open>witness flow\<close>

	definition "csol t0 x0 = (SOME csol. \<forall>t \<in> existence_ivl t0 x0. (csol t, t) \<in> csols t0 x0)"

	text \<open>unique flow\<close>

	definition flow where "flow t0 x0 = (\<lambda>t. if t \<in> existence_ivl t0 x0 then csol t0 x0 t t else 0)"

	end

	locale ll_on_open_it =
	general?:\<comment> \<open>TODO: why is this qualification necessary? It seems only because of @{thm ll_on_open_it_axioms}\<close>
	ll_on_open + fixes t0::real
	\<comment> \<open>if possible, all development should be done with \<open>t0\<close> as explicit parameter for initial time:
	then it can be instantiated with \<open>0\<close> for autonomous ODEs\<close>

	context ll_on_open begin

	sublocale ll_on_open_it where t0 = t0 for t0 ..

	sublocale continuous_rhs T X f
	by unfold_locales (rule continuous_on_TimesI[OF local_lipschitz cont])

	end

	context ll_on_open_it begin

	lemma ll_on_open_rev[intro, simp]: "ll_on_open (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X"
	using local_lipschitz interval
	by unfold_locales
	(auto intro!: continuous_intros cont intro: local_lipschitz_compose1
	simp: fun_Compl_def local_lipschitz_minus local_lipschitz_subset open_neg_translation
	image_image preflect_def)

	lemma eventually_lipschitz:
	assumes "t0 \<in> T" "x0 \<in> X" "c > 0"
	obtains L where
	"eventually (\<lambda>u. \<forall>t' \<in> cball t0 (c * u) \<inter> T.
	L-lipschitz_on (cball x0 u \<inter> X) (\<lambda>y. f t' y)) (at_right 0)"
	proof -
	from local_lipschitzE[OF local_lipschitz, OF \<open>t0 \<in> T\<close> \<open>x0 \<in> X\<close>]
	obtain u L where
	"u > 0"
	"\<And>t'. t' \<in> cball t0 u \<inter> T \<Longrightarrow> L-lipschitz_on (cball x0 u \<inter> X) (\<lambda>y. f t' y)"
	by auto
	hence "eventually (\<lambda>u. \<forall>t' \<in> cball t0 (c * u) \<inter> T.
	L-lipschitz_on (cball x0 u \<inter> X) (\<lambda>y. f t' y)) (at_right 0)"
	using \<open>u > 0\<close> \<open>c > 0\<close>
	by (auto simp: dist_real_def eventually_at divide_simps algebra_simps
	intro!: exI[where x="min u (u / c)"]
	intro: lipschitz_on_subset[where E="cball x0 u \<inter> X"])
	thus ?thesis ..
	qed

	lemmas continuous_on_Times_f = continuous
	lemmas continuous_on_f = continuous_rhs_comp

	lemma
	lipschitz_on_compact:
	assumes "compact K" "K \<subseteq> T"
	assumes "compact Y" "Y \<subseteq> X"
	obtains L where "\<And>t. t \<in> K \<Longrightarrow> L-lipschitz_on Y (f t)"
	proof -
	have cont: "\<And>x. x \<in> Y \<Longrightarrow> continuous_on K (\<lambda>t. f t x)"
	using \<open>Y \<subseteq> X\<close> \<open>K \<subseteq> T\<close>
	by (auto intro!: continuous_on_f continuous_intros)
	from local_lipschitz
	have "local_lipschitz K Y f"
	by (rule local_lipschitz_subset[OF _ \<open>K \<subseteq> T\<close> \<open>Y \<subseteq> X\<close>])
	from local_lipschitz_compact_implies_lipschitz[OF this \<open>compact Y\<close> \<open>compact K\<close> cont] that
	show ?thesis by metis
	qed

	lemma csols_empty_iff: "csols t0 x0 = {} \<longleftrightarrow> t0 \<notin> T \<or> x0 \<notin> X"
	proof cases
	assume iv_defined: "t0 \<in> T \<and> x0 \<in> X"
	then have "(\<lambda>_. x0, t0) \<in> csols t0 x0"
	by (auto simp: csols_def intro!: solves_ode_singleton)
	then show ?thesis using \<open>t0 \<in> T \<and> x0 \<in> X\<close> by auto
	qed (auto simp: solves_ode_domainD csols_def)

	lemma csols_notempty: "t0 \<in> T \<Longrightarrow> x0 \<in> X \<Longrightarrow> csols t0 x0 \<noteq> {}"
	by (simp add: csols_empty_iff)


	lemma existence_ivl_empty_iff[simp]: "existence_ivl t0 x0 = {} \<longleftrightarrow> t0 \<notin> T \<or> x0 \<notin> X"
	using csols_empty_iff
	by (auto simp: existence_ivl_def)

	lemma existence_ivl_empty1[simp]: "t0 \<notin> T \<Longrightarrow> existence_ivl t0 x0 = {}"
	and existence_ivl_empty2[simp]: "x0 \<notin> X \<Longrightarrow> existence_ivl t0 x0 = {}"
	using csols_empty_iff
	by (auto simp: existence_ivl_def)

	lemma flow_undefined:
	shows "t0 \<notin> T \<Longrightarrow> flow t0 x0 = (\<lambda>_. 0)"
	"x0 \<notin> X \<Longrightarrow> flow t0 x0 = (\<lambda>_. 0)"
	using existence_ivl_empty_iff
	by (auto simp: flow_def)

	lemma (in ll_on_open) flow_eq_in_existence_ivlI:
	assumes "\<And>u. x0 \<in> X \<Longrightarrow> u \<in> existence_ivl t0 x0 \<longleftrightarrow> g u \<in> existence_ivl s0 x0"
	assumes "\<And>u. x0 \<in> X \<Longrightarrow> u \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 u = flow s0 x0 (g u)"
	shows "flow t0 x0 = (\<lambda>t. flow s0 x0 (g t))"
	apply (cases "x0 \<in> X")
	subgoal using assms by (auto intro!: ext simp: flow_def)
	subgoal by (simp add: flow_undefined)
	done


	subsubsection \<open>Global maximal flow with local Lipschitz\<close>
	text\<open>\label{sec:qpl-global-flow}\<close>

	lemma local_unique_solution:
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	obtains et ex B L
	where "et > 0" "0 < ex" "cball t0 et \<subseteq> T" "cball x0 ex \<subseteq> X"
	"unique_on_cylinder t0 (cball t0 et) x0 ex f B L"
	proof -
	have "\<forall>\<^sub>F e::real in at_right 0. 0 < e"
	by (auto simp: eventually_at_filter)
	moreover

	from open_Times[OF open_domain] have "open (T \<times> X)" .
	from at_within_open[OF _ this] iv_defined
	have "isCont (\<lambda>(t, x). f t x) (t0, x0)"
	using continuous by (auto simp: continuous_on_eq_continuous_within)
	from eventually_bound_pairE[OF this]
	obtain B where B:
	"1 \<le> B" "\<forall>\<^sub>F e in at_right 0. \<forall>t\<in>cball t0 e. \<forall>x\<in>cball x0 e. norm (f t x) \<le> B"
	- by (force simp: )
	+ by force
	note B(2)
	moreover

	define t where "t \<equiv> inverse B"
	have te: "\<And>e. e > 0 \<Longrightarrow> t * e > 0"
	using \<open>1 \<le> B\<close> by (auto simp: t_def field_simps)
	have t_pos: "t > 0"
	using \<open>1 \<le> B\<close> by (auto simp: t_def)

	from B(2) obtain dB where "0 < dB" "0 < dB / 2"
	and dB: "\<And>d t x. 0 < d \<Longrightarrow> d < dB \<Longrightarrow> t\<in>cball t0 d \<Longrightarrow> x\<in>cball x0 d \<Longrightarrow>
	norm (f t x) \<le> B"
	by (auto simp: eventually_at dist_real_def Ball_def)

	hence dB': "\<And>t x. (t, x) \<in> cball (t0, x0) (dB / 2) \<Longrightarrow> norm (f t x) \<le> B"
	using cball_Pair_split_subset[of t0 x0 "dB / 2"]
	by (auto simp: eventually_at dist_real_def
	simp del: mem_cball
	intro!: dB[where d="dB/2"])
	from eventually_in_cballs[OF \<open>0 < dB/2\<close> t_pos, of t0 x0]
	have "\<forall>\<^sub>F e in at_right 0. \<forall>t\<in>cball t0 (t * e). \<forall>x\<in>cball x0 e. norm (f t x) \<le> B"
	unfolding eventually_at_filter
	by eventually_elim (auto intro!: dB')
	moreover

	from eventually_lipschitz[OF iv_defined t_pos] obtain L where
	"\<forall>\<^sub>F u in at_right 0. \<forall>t'\<in>cball t0 (t * u) \<inter> T. L-lipschitz_on (cball x0 u \<inter> X) (f t')"
	by auto
	moreover
	have "\<forall>\<^sub>F e in at_right 0. cball t0 (t * e) \<subseteq> T"
	using eventually_open_cball[OF open_domain(1) iv_defined(1)]
	by (subst eventually_filtermap[symmetric, where f="\<lambda>x. t * x"])
	(simp add: filtermap_times_pos_at_right t_pos)
	moreover
	have "eventually (\<lambda>e. cball x0 e \<subseteq> X) (at_right 0)"
	using open_domain(2) iv_defined(2)
	by (rule eventually_open_cball)
	ultimately have "\<forall>\<^sub>F e in at_right 0. 0 < e \<and> cball t0 (t * e) \<subseteq> T \<and> cball x0 e \<subseteq> X \<and>
	unique_on_cylinder t0 (cball t0 (t * e)) x0 e f B L"
	proof eventually_elim
	case (elim e)
	note \<open>0 < e\<close>
	moreover
	note T = \<open>cball t0 (t * e) \<subseteq> T\<close>
	moreover
	note X = \<open>cball x0 e \<subseteq> X\<close>
	moreover
	from elim Int_absorb2[OF \<open>cball x0 e \<subseteq> X\<close>]
	have L: "t' \<in> cball t0 (t * e) \<inter> T \<Longrightarrow> L-lipschitz_on (cball x0 e) (f t')" for t'
	by auto
	from elim have B: "\<And>t' x. t' \<in> cball t0 (t * e) \<Longrightarrow> x \<in> cball x0 e \<Longrightarrow> norm (f t' x) \<le> B"
	by auto


	have "t * e \<le> e / B"
	by (auto simp: t_def cball_def dist_real_def inverse_eq_divide)

	have "{t0 -- t0 + t * e} \<subseteq> cball t0 (t * e)"
	using \<open>t > 0\<close> \<open>e > 0\<close>
	by (auto simp: cball_eq_closed_segment_real closed_segment_eq_real_ivl)
	then have "unique_on_cylinder t0 (cball t0 (t * e)) x0 e f B L"
	using T X \<open>t > 0\<close> \<open>e > 0\<close> \<open>t * e \<le> e / B\<close>
	by unfold_locales
	(auto intro!: continuous_rhs_comp continuous_on_fst continuous_on_snd B L
	continuous_on_id
	simp: split_beta' dist_commute mem_cball)
	ultimately show ?case by auto
	qed
	from eventually_happens[OF this]
	obtain e where "0 < e" "cball t0 (t * e) \<subseteq> T" "cball x0 e \<subseteq> X"
	"unique_on_cylinder t0 (cball t0 (t * e)) x0 e f B L"
	by (metis trivial_limit_at_right_real)
	with mult_pos_pos[OF \<open>0 < t\<close> \<open>0 < e\<close>] show ?thesis ..
	qed

	lemma mem_existence_ivl_iv_defined:
	assumes "t \<in> existence_ivl t0 x0"
	shows "t0 \<in> T" "x0 \<in> X"
	using assms existence_ivl_empty_iff
	unfolding atomize_conj
	by blast

	lemma csol_mem_csols:
	assumes "t \<in> existence_ivl t0 x0"
	shows "(csol t0 x0 t, t) \<in> csols t0 x0"
	proof -
	have "\<exists>csol. \<forall>t \<in> existence_ivl t0 x0. (csol t, t) \<in> csols t0 x0"
	proof (safe intro!: bchoice)
	fix t assume "t \<in> existence_ivl t0 x0"
	then obtain csol t1 where csol: "(csol t, t1) \<in> csols t0 x0" "t \<in> {t0 -- t1}"
	by (auto simp: existence_ivl_def)
	then have "{t0--t} \<subseteq> {t0 -- t1}"
	by (auto simp: closed_segment_eq_real_ivl)
	then have "(csol t, t) \<in> csols t0 x0" using csol
	by (auto simp: csols_def intro: solves_ode_on_subset)
	then show "\<exists>y. (y, t) \<in> csols t0 x0" by force
	qed
	then have "\<forall>t \<in> existence_ivl t0 x0. (csol t0 x0 t, t) \<in> csols t0 x0"
	unfolding csol_def
	by (rule someI_ex)
	with assms show "?thesis" by auto
	qed

	lemma csol:
	assumes "t \<in> existence_ivl t0 x0"
	shows "t \<in> T" "{t0--t} \<subseteq> T" "csol t0 x0 t t0 = x0" "(csol t0 x0 t solves_ode f) {t0--t} X"
	using csol_mem_csols[OF assms]
	by (auto simp: csols_def)

	lemma existence_ivl_initial_time_iff[simp]: "t0 \<in> existence_ivl t0 x0 \<longleftrightarrow> t0 \<in> T \<and> x0 \<in> X"
	using csols_empty_iff
	by (auto simp: existence_ivl_def)

	lemma existence_ivl_initial_time: "t0 \<in> T \<Longrightarrow> x0 \<in> X \<Longrightarrow> t0 \<in> existence_ivl t0 x0"
	by simp

	lemmas mem_existence_ivl_subset = csol(1)

	lemma existence_ivl_subset:
	"existence_ivl t0 x0 \<subseteq> T"
	using mem_existence_ivl_subset by blast

	lemma is_interval_existence_ivl[intro, simp]: "is_interval (existence_ivl t0 x0)"
	unfolding is_interval_connected_1
	by (auto simp: existence_ivl_def intro!: connected_Union)

	lemma connected_existence_ivl[intro, simp]: "connected (existence_ivl t0 x0)"
	using is_interval_connected by blast

	lemma in_existence_between_zeroI:
	"t \<in> existence_ivl t0 x0 \<Longrightarrow> s \<in> {t0 -- t} \<Longrightarrow> s \<in> existence_ivl t0 x0"
	by (meson existence_ivl_initial_time interval.closed_segment_subset_domainI interval.intro
	is_interval_existence_ivl mem_existence_ivl_iv_defined(1) mem_existence_ivl_iv_defined(2))

	lemma segment_subset_existence_ivl:
	assumes "s \<in> existence_ivl t0 x0" "t \<in> existence_ivl t0 x0"
	shows "{s -- t} \<subseteq> existence_ivl t0 x0"
	using assms is_interval_existence_ivl
	unfolding is_interval_convex_1
	by (rule closed_segment_subset)

	lemma flow_initial_time_if: "flow t0 x0 t0 = (if t0 \<in> T \<and> x0 \<in> X then x0 else 0)"
	by (simp add: flow_def csol(3))

	lemma flow_initial_time[simp]: "t0 \<in> T \<Longrightarrow> x0 \<in> X \<Longrightarrow> flow t0 x0 t0 = x0"
	by (auto simp: flow_initial_time_if)

	lemma open_existence_ivl[intro, simp]: "open (existence_ivl t0 x0)"
	proof (rule openI)
	fix t assume t: "t \<in> existence_ivl t0 x0"
	note csol = csol[OF this]
	note mem_existence_ivl_iv_defined[OF t]

	have "flow t0 x0 t \<in> X" using \<open>t \<in> existence_ivl t0 x0\<close>
	using csol(4) solves_ode_domainD
	by (force simp add: flow_def)

	from ll_on_open_it.local_unique_solution[OF ll_on_open_it_axioms \<open>t \<in> T\<close> this]
	obtain et ex B L where lsol:
	"0 < et"
	"0 < ex"
	"cball t et \<subseteq> T"
	"cball (flow t0 x0 t) ex \<subseteq> X"
	"unique_on_cylinder t (cball t et) (flow t0 x0 t) ex f B L"
	by metis
	then interpret unique_on_cylinder t "cball t et" "flow t0 x0 t" ex "cball (flow t0 x0 t) ex" f B L
	by auto
	from solution_usolves_ode have lsol_ode: "(solution solves_ode f) (cball t et) (cball (flow t0 x0 t) ex)"
	by (intro usolves_odeD)
	show "\<exists>e>0. ball t e \<subseteq> existence_ivl t0 x0"
	proof cases
	assume "t = t0"
	show ?thesis
	proof (safe intro!: exI[where x="et"] mult_pos_pos \<open>0 < et\<close> \<open>0 < ex\<close>)
	fix t' assume "t' \<in> ball t et"
	then have subset: "{t0--t'} \<subseteq> ball t et"
	by (intro closed_segment_subset) (auto simp: \<open>0 < et\<close> \<open>0 < ex\<close> \<open>t = t0\<close>)
	also have "\<dots> \<subseteq> cball t et" by simp
	also note \<open>cball t _ \<subseteq> T\<close>
	finally have "{t0--t'} \<subseteq> T" by simp
	moreover have "(solution solves_ode f) {t0--t'} X"
	using lsol_ode
	apply (rule solves_ode_on_subset)
	using subset lsol
	by (auto simp: mem_ball mem_cball)
	ultimately have "(solution, t') \<in> csols t0 x0"
	unfolding csols_def
	using lsol \<open>t' \<in> ball _ _\<close> lsol \<open>t = t0\<close> solution_iv \<open>x0 \<in> X\<close>
	by (auto simp: csols_def)
	then show "t' \<in> existence_ivl t0 x0"
	unfolding existence_ivl_def
	by force
	qed
	next
	assume "t \<noteq> t0"
	let ?m = "min et (dist t0 t / 2)"
	show ?thesis
	proof (safe intro!: exI[where x = ?m])
	let ?t1' = "if t0 \<le> t then t + et else t - et"
	have lsol_ode: "(solution solves_ode f) {t -- ?t1'} (cball (flow t0 x0 t) ex)"
	by (rule solves_ode_on_subset[OF lsol_ode])
	(insert \<open>0 < et\<close> \<open>0 < ex\<close>, auto simp: mem_cball closed_segment_eq_real_ivl dist_real_def)
	let ?if = "\<lambda>ta. if ta \<in> {t0--t} then csol t0 x0 t ta else solution ta"
	let ?iff = "\<lambda>ta. if ta \<in> {t0--t} then f ta else f ta"
	have "(?if solves_ode ?iff) ({t0--t} \<union> {t -- ?t1'}) X"
	apply (rule connection_solves_ode[OF csol(4) lsol_ode, unfolded Un_absorb2[OF \<open>_ \<subseteq> X\<close>]])
	using lsol solution_iv \<open>t \<in> existence_ivl t0 x0\<close>
	by (auto intro!: simp: closed_segment_eq_real_ivl flow_def split: if_split_asm)
	also have "?iff = f" by auto
	also have Un_eq: "{t0--t} \<union> {t -- ?t1'} = {t0 -- ?t1'}"
	using \<open>0 < et\<close> \<open>0 < ex\<close>
	by (auto simp: closed_segment_eq_real_ivl)
	finally have continuation: "(?if solves_ode f) {t0--?t1'} X" .
	have subset_T: "{t0 -- ?t1'} \<subseteq> T"
	unfolding Un_eq[symmetric]
	apply (intro Un_least)
	subgoal using csol by force
	subgoal using _ lsol(3)
	apply (rule order_trans)
	using \<open>0 < et\<close> \<open>0 < ex\<close>
	by (auto simp: closed_segment_eq_real_ivl subset_iff mem_cball dist_real_def)
	done
	fix t' assume "t' \<in> ball t ?m"
	then have scs: "{t0 -- t'} \<subseteq> {t0--?t1'}"
	using \<open>0 < et\<close> \<open>0 < ex\<close>
	by (auto simp: closed_segment_eq_real_ivl dist_real_def abs_real_def mem_ball split: if_split_asm)
	with continuation have "(?if solves_ode f) {t0 -- t'} X"
	by (rule solves_ode_on_subset) simp
	then have "(?if, t') \<in> csols t0 x0"
	using lsol \<open>t' \<in> ball _ _\<close> csol scs subset_T
	by (auto simp: csols_def subset_iff)
	then show "t' \<in> existence_ivl t0 x0"
	unfolding existence_ivl_def
	by force
	qed (insert \<open>t \<noteq> t0\<close> \<open>0 < et\<close> \<open>0 < ex\<close>, simp)
	qed
	qed

	lemma csols_unique:
	assumes "(x, t1) \<in> csols t0 x0"
	assumes "(y, t2) \<in> csols t0 x0"
	shows "\<forall>t \<in> {t0 -- t1} \<inter> {t0 -- t2}. x t = y t"
	proof (rule ccontr)
	let ?S = "{t0 -- t1} \<inter> {t0 -- t2}"
	let ?Z0 = "(\<lambda>t. x t - y t) -` {0} \<inter> ?S"
	let ?Z = "connected_component_set ?Z0 t0"
	from assms have t1: "t1 \<in> existence_ivl t0 x0" and t2: "t2 \<in> existence_ivl t0 x0"
	and x: "(x solves_ode f) {t0 -- t1} X"
	and y: "(y solves_ode f) {t0 -- t2} X"
	and sub1: "{t0--t1} \<subseteq> T"
	and sub2: "{t0--t2} \<subseteq> T"
	and x0: "x t0 = x0"
	and y0: "y t0 = x0"
	by (auto simp: existence_ivl_def csols_def)

	assume "\<not> (\<forall>t\<in>?S. x t = y t)"
	hence "\<exists>t\<in>?S. x t \<noteq> y t" by simp
	then obtain t_ne where t_ne: "t_ne \<in> ?S" "x t_ne \<noteq> y t_ne" ..
	from assms have x: "(x solves_ode f) {t0--t1} X"
	and y:"(y solves_ode f) {t0--t2} X"
	by (auto simp: csols_def)
	have "compact ?S"
	by auto
	have "closed ?Z"
	by (intro closed_connected_component closed_vimage_Int)
	(auto intro!: continuous_intros continuous_on_subset[OF solves_ode_continuous_on[OF x]]
	continuous_on_subset[OF solves_ode_continuous_on[OF y]])
	moreover
	have "t0 \<in> ?Z" using assms
	by (auto simp: csols_def)
	then have "?Z \<noteq> {}"
	by (auto intro!: exI[where x=t0])
	ultimately
	obtain t_max where max: "t_max \<in> ?Z" "y \<in> ?Z \<Longrightarrow> dist t_ne t_max \<le> dist t_ne y" for y
	by (blast intro: distance_attains_inf)
	have max_equal_flows: "x t = y t" if "t \<in> {t0 -- t_max}" for t
	using max(1) that
	by (auto simp: connected_component_def vimage_def subset_iff closed_segment_eq_real_ivl
	split: if_split_asm) (metis connected_iff_interval)+
	then have t_ne_outside: "t_ne \<notin> {t0 -- t_max}" using t_ne by auto

	have "x t_max = y t_max"
	by (rule max_equal_flows) simp
	have "t_max \<in> ?S" "t_max \<in> T"
	using max sub1 sub2
	by (auto simp: connected_component_def)
	with solves_odeD[OF x]
	have "x t_max \<in> X"
	by auto

	from ll_on_open_it.local_unique_solution[OF ll_on_open_it_axioms \<open>t_max \<in> T\<close> \<open>x t_max \<in> X\<close>]
	obtain et ex B L
	where "0 < et" "0 < ex"
	and "cball t_max et \<subseteq> T" "cball (x t_max) ex \<subseteq> X"
	and "unique_on_cylinder t_max (cball t_max et) (x t_max) ex f B L"
	by metis
	then interpret unique_on_cylinder t_max "cball t_max et" "x t_max" ex "cball (x t_max) ex" f B L
	by auto

	from usolves_ode_on_superset_domain[OF solution_usolves_ode solution_iv \<open>cball _ _ \<subseteq> X\<close>]
	have solution_usolves_on_X: "(solution usolves_ode f from t_max) (cball t_max et) X" by simp

	have ge_imps: "t0 \<le> t1" "t0 \<le> t2" "t0 \<le> t_max" "t_max < t_ne" if "t0 \<le> t_ne"
	using that t_ne_outside \<open>0 < et\<close> \<open>0 < ex\<close> max(1) \<open>t_max \<in> ?S\<close> \<open>t_max \<in> T\<close> t_ne x0 y0
	by (auto simp: min_def dist_real_def max_def closed_segment_eq_real_ivl split: if_split_asm)
	have le_imps: "t0 \<ge> t1" "t0 \<ge> t2" "t0 \<ge> t_max" "t_max > t_ne" if "t0 \<ge> t_ne"
	using that t_ne_outside \<open>0 < et\<close> \<open>0 < ex\<close> max(1) \<open>t_max \<in> ?S\<close> \<open>t_max \<in> T\<close> t_ne x0 y0
	by (auto simp: min_def dist_real_def max_def closed_segment_eq_real_ivl split: if_split_asm)

	define tt where "tt \<equiv> if t0 \<le> t_ne then min (t_max + et) t_ne else max (t_max - et) t_ne"
	have "tt \<in> cball t_max et" "tt \<in> {t0 -- t1}" "tt \<in> {t0 -- t2}"
	using ge_imps le_imps \<open>0 < et\<close> t_ne(1)
	by (auto simp: mem_cball closed_segment_eq_real_ivl tt_def dist_real_def abs_real_def min_def max_def not_less)

	have segment_unsplit: "{t0 -- t_max} \<union> {t_max -- tt} = {t0 -- tt}"
	using ge_imps le_imps \<open>0 < et\<close>
	by (auto simp: tt_def closed_segment_eq_real_ivl min_def max_def split: if_split_asm) arith

	have "tt \<in> {t0 -- t1}"
	using ge_imps le_imps \<open>0 < et\<close> t_ne(1)
	by (auto simp: tt_def closed_segment_eq_real_ivl min_def max_def split: if_split_asm)

	have "tt \<in> ?Z"
	proof (safe intro!: connected_componentI[where T = "{t0 -- t_max} \<union> {t_max -- tt}"])
	fix s assume s: "s \<in> {t_max -- tt}"
	have "{t_max--s} \<subseteq> {t_max -- tt}"
	by (rule closed_segment_subset) (auto simp: s)
	also have "\<dots> \<subseteq> cball t_max et"
	using \<open>tt \<in> cball t_max et\<close> \<open>0 < et\<close>
	by (intro closed_segment_subset) auto
	finally have subset: "{t_max--s} \<subseteq> cball t_max et" .
	from s show "s \<in> {t0--t1}" "s \<in> {t0--t2}"
	using ge_imps le_imps t_ne \<open>0 < et\<close>
	by (auto simp: tt_def min_def max_def closed_segment_eq_real_ivl split: if_split_asm)
	have ivl: "t_max \<in> {t_max -- s}" "is_interval {t_max--s}"
	using \<open>tt \<in> cball t_max et\<close> \<open>0 < et\<close> s
	by (simp_all add: is_interval_convex_1)
	{
	note ivl subset
	moreover
	have "{t_max--s} \<subseteq> {t0--t1}"
	using \<open>s \<in> {t0 -- t1}\<close> \<open>t_max \<in> ?S\<close>
	by (simp add: closed_segment_subset)
	from x this order_refl have "(x solves_ode f) {t_max--s} X"
	by (rule solves_ode_on_subset)
	moreover note solution_iv[symmetric]
	ultimately
	have "x s = solution s"
	by (rule usolves_odeD(4)[OF solution_usolves_on_X]) simp
	} moreover {
	note ivl subset
	moreover
	have "{t_max--s} \<subseteq> {t0--t2}"
	using \<open>s \<in> {t0 -- t2}\<close> \<open>t_max \<in> ?S\<close>
	by (simp add: closed_segment_subset)
	from y this order_refl have "(y solves_ode f) {t_max--s} X"
	by (rule solves_ode_on_subset)
	moreover from solution_iv[symmetric] have "y t_max = solution t_max"
	by (simp add: \<open>x t_max = y t_max\<close>)
	ultimately
	have "y s = solution s"
	by (rule usolves_odeD[OF solution_usolves_on_X]) simp
	} ultimately show "s \<in> (\<lambda>t. x t - y t) -` {0}" by simp
	next
	fix s assume s: "s \<in> {t0 -- t_max}"
	then show "s \<in> (\<lambda>t. x t - y t) -` {0}"
	by (auto intro!: max_equal_flows)
	show "s \<in> {t0--t1}" "s \<in> {t0--t2}"
	by (metis Int_iff \<open>t_max \<in> ?S\<close> closed_segment_closed_segment_subset ends_in_segment(1) s)+
	qed (auto simp: segment_unsplit)
	then have "dist t_ne t_max \<le> dist t_ne tt"
	by (rule max)
	moreover have "dist t_ne t_max > dist t_ne tt"
	using le_imps ge_imps \<open>0 < et\<close>
	by (auto simp: tt_def dist_real_def)
	ultimately show False by simp
	qed

	lemma csol_unique:
	assumes t1: "t1 \<in> existence_ivl t0 x0"
	assumes t2: "t2 \<in> existence_ivl t0 x0"
	assumes t: "t \<in> {t0 -- t1}" "t \<in> {t0 -- t2}"
	shows "csol t0 x0 t1 t = csol t0 x0 t2 t"
	using csols_unique[OF csol_mem_csols[OF t1] csol_mem_csols[OF t2]] t
	by simp

	lemma flow_vderiv_on_left:
	"(flow t0 x0 has_vderiv_on (\<lambda>x. f x (flow t0 x0 x))) (existence_ivl t0 x0 \<inter> {..t0})"
	unfolding has_vderiv_on_def
	proof safe
	fix t
	assume t: "t \<in> existence_ivl t0 x0" "t \<le> t0"
	with open_existence_ivl
	obtain e where "e > 0" and e: "\<And>s. s \<in> cball t e \<Longrightarrow> s \<in> existence_ivl t0 x0"
	by (force simp: open_contains_cball)
	have csol_eq: "csol t0 x0 (t - e) s = flow t0 x0 s" if "t - e \<le> s" "s \<le> t0" for s
	unfolding flow_def
	using that \<open>0 < e\<close> t e
	by (auto simp: cball_def dist_real_def abs_real_def closed_segment_eq_real_ivl subset_iff
	intro!: csol_unique in_existence_between_zeroI[of "t - e" x0 s]
	split: if_split_asm)
	from e[of "t - e"] \<open>0 < e\<close> have "t - e \<in> existence_ivl t0 x0" by (auto simp: mem_cball)

	let ?l = "existence_ivl t0 x0 \<inter> {..t0}"
	let ?s = "{t0 -- t - e}"

	from csol(4)[OF e[of "t - e"]] \<open>0 < e\<close>
	have 1: "(csol t0 x0 (t - e) solves_ode f) ?s X"
	by (auto simp: mem_cball)
	have "t \<in> {t0 -- t - e}" using t \<open>0 < e\<close> by (auto simp: closed_segment_eq_real_ivl)
	from solves_odeD(1)[OF 1, unfolded has_vderiv_on_def, rule_format, OF this]
	have "(csol t0 x0 (t - e) has_vector_derivative f t (csol t0 x0 (t - e) t)) (at t within ?s)" .
	also have "at t within ?s = (at t within ?l)"
	using t \<open>0 < e\<close>
	by (intro at_within_nhd[where S="{t - e <..< t0 + 1}"])
	(auto simp: closed_segment_eq_real_ivl intro!: in_existence_between_zeroI[OF \<open>t - e \<in> existence_ivl t0 x0\<close>])
	finally
	have "(csol t0 x0 (t - e) has_vector_derivative f t (csol t0 x0 (t - e) t)) (at t within existence_ivl t0 x0 \<inter> {..t0})" .
	also have "csol t0 x0 (t - e) t = flow t0 x0 t"
	using \<open>0 < e\<close> \<open>t \<le> t0\<close> by (auto intro!: csol_eq)
	finally
	show "(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at t within existence_ivl t0 x0 \<inter> {..t0})"
	apply (rule has_vector_derivative_transform_within[where d=e])
	using t \<open>0 < e\<close>
	by (auto intro!: csol_eq simp: dist_real_def)
	qed

	lemma flow_vderiv_on_right:
	"(flow t0 x0 has_vderiv_on (\<lambda>x. f x (flow t0 x0 x))) (existence_ivl t0 x0 \<inter> {t0..})"
	unfolding has_vderiv_on_def
	proof safe
	fix t
	assume t: "t \<in> existence_ivl t0 x0" "t0 \<le> t"
	with open_existence_ivl
	obtain e where "e > 0" and e: "\<And>s. s \<in> cball t e \<Longrightarrow> s \<in> existence_ivl t0 x0"
	by (force simp: open_contains_cball)
	have csol_eq: "csol t0 x0 (t + e) s = flow t0 x0 s" if "s \<le> t + e" "t0 \<le> s" for s
	unfolding flow_def
	using e that \<open>0 < e\<close>
	by (auto simp: cball_def dist_real_def abs_real_def closed_segment_eq_real_ivl subset_iff
	intro!: csol_unique in_existence_between_zeroI[of "t + e" x0 s]
	split: if_split_asm)
	from e[of "t + e"] \<open>0 < e\<close> have "t + e \<in> existence_ivl t0 x0" by (auto simp: mem_cball dist_real_def)

	let ?l = "existence_ivl t0 x0 \<inter> {t0..}"
	let ?s = "{t0 -- t + e}"

	from csol(4)[OF e[of "t + e"]] \<open>0 < e\<close>
	have 1: "(csol t0 x0 (t + e) solves_ode f) ?s X"
	by (auto simp: dist_real_def mem_cball)
	have "t \<in> {t0 -- t + e}" using t \<open>0 < e\<close> by (auto simp: closed_segment_eq_real_ivl)
	from solves_odeD(1)[OF 1, unfolded has_vderiv_on_def, rule_format, OF this]
	have "(csol t0 x0 (t + e) has_vector_derivative f t (csol t0 x0 (t + e) t)) (at t within ?s)" .
	also have "at t within ?s = (at t within ?l)"
	using t \<open>0 < e\<close>
	by (intro at_within_nhd[where S="{t0 - 1 <..< t + e}"])
	(auto simp: closed_segment_eq_real_ivl intro!: in_existence_between_zeroI[OF \<open>t + e \<in> existence_ivl t0 x0\<close>])
	finally
	have "(csol t0 x0 (t + e) has_vector_derivative f t (csol t0 x0 (t + e) t)) (at t within ?l)" .
	also have "csol t0 x0 (t + e) t = flow t0 x0 t"
	using \<open>0 < e\<close> \<open>t0 \<le> t\<close> by (auto intro!: csol_eq)
	finally
	show "(flow t0 x0 has_vector_derivative f t (flow t0 x0 t)) (at t within ?l)"
	apply (rule has_vector_derivative_transform_within[where d=e])
	using t \<open>0 < e\<close>
	by (auto intro!: csol_eq simp: dist_real_def)
	qed

	lemma flow_usolves_ode:
	assumes iv_defined: "t0 \<in> T" "x0 \<in> X"
	shows "(flow t0 x0 usolves_ode f from t0) (existence_ivl t0 x0) X"
	proof (rule usolves_odeI)
	let ?l = "existence_ivl t0 x0 \<inter> {..t0}" and ?r = "existence_ivl t0 x0 \<inter> {t0..}"
	let ?split = "?l \<union> ?r"
	have insert_idem: "insert t0 ?l = ?l" "insert t0 ?r = ?r" using iv_defined
	by auto
	from existence_ivl_initial_time have cl_inter: "closure ?l \<inter> closure ?r = {t0}"
	proof safe
	from iv_defined have "t0 \<in> ?l" by simp also note closure_subset finally show "t0 \<in> closure ?l" .
	from iv_defined have "t0 \<in> ?r" by simp also note closure_subset finally show "t0 \<in> closure ?r" .
	fix x
	assume xl: "x \<in> closure ?l"
	assume "x \<in> closure ?r"
	also have "closure ?r \<subseteq> closure {t0..}"
	by (rule closure_mono) simp
	finally have "t0 \<le> x" by simp
	moreover
	{
	note xl
	also have cl: "closure ?l \<subseteq> closure {..t0}"
	by (rule closure_mono) simp
	finally have "x \<le> t0" by simp
	} ultimately show "x = t0" by simp
	qed
	have "(flow t0 x0 has_vderiv_on (\<lambda>t. f t (flow t0 x0 t))) ?split"
	by (rule has_vderiv_on_union)
	(auto simp: cl_inter insert_idem flow_vderiv_on_right flow_vderiv_on_left)
	also have "?split = existence_ivl t0 x0"
	by auto
	finally have "(flow t0 x0 has_vderiv_on (\<lambda>t. f t (flow t0 x0 t))) (existence_ivl t0 x0)" .
	moreover
	have "flow t0 x0 t \<in> X" if "t \<in> existence_ivl t0 x0" for t
	using solves_odeD(2)[OF csol(4)[OF that]] that
	by (simp add: flow_def)
	ultimately show "(flow t0 x0 solves_ode f) (existence_ivl t0 x0) X"
	by (rule solves_odeI)
	show "t0 \<in> existence_ivl t0 x0" using iv_defined by simp
	show "is_interval (existence_ivl t0 x0)" by (simp add: is_interval_existence_ivl)
	fix z t
	assume z: "{t0 -- t} \<subseteq> existence_ivl t0 x0" "(z solves_ode f) {t0 -- t} X" "z t0 = flow t0 x0 t0"
	then have "t \<in> existence_ivl t0 x0" by auto
	moreover
	from csol[OF this] z have "(z, t) \<in> csols t0 x0" by (auto simp: csols_def)
	moreover have "(csol t0 x0 t, t) \<in> csols t0 x0"
	by (rule csol_mem_csols) fact
	ultimately
	show "z t = flow t0 x0 t"
	unfolding flow_def
	by (auto intro: csols_unique[rule_format])
	qed

	lemma flow_solves_ode: "t0 \<in> T \<Longrightarrow> x0 \<in> X \<Longrightarrow> (flow t0 x0 solves_ode f) (existence_ivl t0 x0) X"
	by (rule usolves_odeD[OF flow_usolves_ode])

	lemma equals_flowI:
	assumes "t0 \<in> T'"
	"is_interval T'"
	"T' \<subseteq> existence_ivl t0 x0"
	"(z solves_ode f) T' X"
	"z t0 = flow t0 x0 t0" "t \<in> T'"
	shows "z t = flow t0 x0 t"
	proof -
	from assms have iv_defined: "t0 \<in> T" "x0 \<in> X"
	unfolding atomize_conj
	using assms existence_ivl_subset mem_existence_ivl_iv_defined
	by blast
	show ?thesis
	using assms
	by (rule usolves_odeD[OF flow_usolves_ode[OF iv_defined]])
	qed

	lemma existence_ivl_maximal_segment:
	assumes "(x solves_ode f) {t0 -- t} X" "x t0 = x0"
	assumes "{t0 -- t} \<subseteq> T"
	shows "t \<in> existence_ivl t0 x0"
	using assms
	by (auto simp: existence_ivl_def csols_def)

	lemma existence_ivl_maximal_interval:
	assumes "(x solves_ode f) S X" "x t0 = x0"
	assumes "t0 \<in> S" "is_interval S" "S \<subseteq> T"
	shows "S \<subseteq> existence_ivl t0 x0"
	proof
	fix t assume "t \<in> S"
	with assms have subset1: "{t0--t} \<subseteq> S"
	by (intro closed_segment_subset) (auto simp: is_interval_convex_1)
	with \<open>S \<subseteq> T\<close> have subset2: "{t0 -- t} \<subseteq> T" by auto
	have "(x solves_ode f) {t0 -- t} X"
	using assms(1) subset1 order_refl
	by (rule solves_ode_on_subset)
	from this \<open>x t0 = x0\<close> subset2 show "t \<in> existence_ivl t0 x0"
	by (rule existence_ivl_maximal_segment)
	qed

	lemma maximal_existence_flow:
	assumes sol: "(x solves_ode f) K X" and iv: "x t0 = x0"
	assumes "is_interval K"
	assumes "t0 \<in> K"
	assumes "K \<subseteq> T"
	shows "K \<subseteq> existence_ivl t0 x0" "\<And>t. t \<in> K \<Longrightarrow> flow t0 x0 t = x t"
	proof -
	from assms have iv_defined: "t0 \<in> T" "x0 \<in> X"
	unfolding atomize_conj
	using solves_ode_domainD by blast
	show exivl: "K \<subseteq> existence_ivl t0 x0"
	by (rule existence_ivl_maximal_interval; rule assms)
	show "flow t0 x0 t = x t" if "t \<in> K" for t
	apply (rule sym)
	apply (rule equals_flowI[OF \<open>t0 \<in> K\<close> \<open>is_interval K\<close> exivl sol _ that])
	by (simp add: iv iv_defined)
	qed

	lemma maximal_existence_flowI:
	assumes "(x has_vderiv_on (\<lambda>t. f t (x t))) K"
	assumes "\<And>t. t \<in> K \<Longrightarrow> x t \<in> X"
	assumes "x t0 = x0"
	assumes K: "is_interval K" "t0 \<in> K" "K \<subseteq> T"
	shows "K \<subseteq> existence_ivl t0 x0" "\<And>t. t \<in> K \<Longrightarrow> flow t0 x0 t = x t"
	proof -
	from assms(1,2) have sol: "(x solves_ode f) K X" by (rule solves_odeI)
	from maximal_existence_flow[OF sol assms(3) K]
	show "K \<subseteq> existence_ivl t0 x0" "\<And>t. t \<in> K \<Longrightarrow> flow t0 x0 t = x t"
	by auto
	qed

	lemma flow_in_domain: "t \<in> existence_ivl t0 x0 \<Longrightarrow> flow t0 x0 t \<in> X"
	using flow_solves_ode solves_ode_domainD local.mem_existence_ivl_iv_defined
	by blast

	lemma (in ll_on_open)
	assumes "t \<in> existence_ivl s x"
	assumes "x \<in> X"
	assumes auto: "\<And>s t x. x \<in> X \<Longrightarrow> f s x = f t x"
	assumes "T = UNIV"
	shows mem_existence_ivl_shift_autonomous1: "t - s \<in> existence_ivl 0 x"
	and flow_shift_autonomous1: "flow s x t = flow 0 x (t - s)"
	proof -
	have na: "s \<in> T" "x \<in> X" and a: "0 \<in> T" "x \<in> X"
	by (auto simp: assms)

	have tI[simp]: "t \<in> T" for t by (simp add: assms)
	let ?T = "((+) (- s) ` existence_ivl s x)"
	have shifted: "is_interval ?T" "0 \<in> ?T"
	by (auto simp: \<open>x \<in> X\<close>)

	have "(\<lambda>t. t - s) = (+) (- s)" by auto
	with shift_autonomous_solution[OF flow_solves_ode[OF na], of s] flow_in_domain
	have sol: "((\<lambda>t. flow s x (t + s)) solves_ode f) ?T X"
	by (auto simp: auto \<open>x \<in> X\<close>)

	have "flow s x (0 + s) = x" using \<open>x \<in> X\<close> flow_initial_time by simp
	from maximal_existence_flow[OF sol this shifted]
	have *: "?T \<subseteq> existence_ivl 0 x"
	and **: "\<And>t. t \<in> ?T \<Longrightarrow> flow 0 x t = flow s x (t + s)"
	by (auto simp: subset_iff)

	have "t - s \<in> ?T"
	using \<open>t \<in> existence_ivl s x\<close>
	by auto
	also note *
	finally show "t - s \<in> existence_ivl 0 x" .

	show "flow s x t = flow 0 x (t - s)"
	using \<open>t \<in> existence_ivl s x\<close>
	by (auto simp: **)
	qed

	lemma (in ll_on_open)
	assumes "t - s \<in> existence_ivl 0 x"
	assumes "x \<in> X"
	assumes auto: "\<And>s t x. x \<in> X \<Longrightarrow> f s x = f t x"
	assumes "T = UNIV"
	shows mem_existence_ivl_shift_autonomous2: "t \<in> existence_ivl s x"
	and flow_shift_autonomous2: "flow s x t = flow 0 x (t - s)"
	proof -
	have na: "s \<in> T" "x \<in> X" and a: "0 \<in> T" "x \<in> X"
	by (auto simp: assms)

	let ?T = "((+) s ` existence_ivl 0 x)"
	have shifted: "is_interval ?T" "s \<in> ?T"
	by (auto simp: a)

	have "(\<lambda>t. t + s) = (+) s"
	- by (auto simp: )
	+ by auto
	with shift_autonomous_solution[OF flow_solves_ode[OF a], of "-s"]
	flow_in_domain
	have sol: "((\<lambda>t. flow 0 x (t - s)) solves_ode f) ?T X"
	by (auto simp: auto algebra_simps)

	have "flow 0 x (s - s) = x"
	by (auto simp: a)
	from maximal_existence_flow[OF sol this shifted]
	have *: "?T \<subseteq> existence_ivl s x"
	and **: "\<And>t. t \<in> ?T \<Longrightarrow> flow s x t = flow 0 x (t - s)"
	by (auto simp: subset_iff assms)

	have "t \<in> ?T"
	using \<open>t - s \<in> existence_ivl 0 x\<close>
	by force
	also note *
	finally show "t \<in> existence_ivl s x" .

	show "flow s x t = flow 0 x (t - s)"
	using \<open>t - s \<in> existence_ivl _ _\<close>
	by (subst **; force)
	qed

	lemma
	flow_eq_rev:
	assumes "t \<in> existence_ivl t0 x0"
	shows "preflect t0 t \<in> ll_on_open.existence_ivl (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0"
	"flow t0 x0 t = ll_on_open.flow (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0 (preflect t0 t)"
	proof -
	from mem_existence_ivl_iv_defined[OF assms] have mt0: "t0 \<in> preflect t0 ` existence_ivl t0 x0"
	by (auto simp: preflect_def)
	have subset: "preflect t0 ` existence_ivl t0 x0 \<subseteq> preflect t0 ` T"
	using existence_ivl_subset
	by (rule image_mono)
	from mt0 subset have "t0 \<in> preflect t0 ` T" by auto

	have sol: "((\<lambda>t. flow t0 x0 (preflect t0 t)) solves_ode (\<lambda>t. - f (preflect t0 t))) (preflect t0 ` existence_ivl t0 x0) X"
	using mt0
	by (rule preflect_solution) (auto simp: image_image flow_solves_ode mem_existence_ivl_iv_defined[OF assms])

	have flow0: "flow t0 x0 (preflect t0 t0) = x0" and ivl: "is_interval (preflect t0 ` existence_ivl t0 x0)"
	by (auto simp: preflect_def mem_existence_ivl_iv_defined[OF assms])

	interpret rev: ll_on_open "(preflect t0 ` T)" "(\<lambda>t. - f (preflect t0 t))" X ..
	from rev.maximal_existence_flow[OF sol flow0 ivl mt0 subset]
	show "preflect t0 t \<in> rev.existence_ivl t0 x0" "flow t0 x0 t = rev.flow t0 x0 (preflect t0 t)"
	using assms by (auto simp: preflect_def)
	qed

	lemma (in ll_on_open)
	shows rev_flow_eq: "t \<in> ll_on_open.existence_ivl (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0 \<Longrightarrow>
	ll_on_open.flow (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0 t = flow t0 x0 (preflect t0 t)"
	and mem_rev_existence_ivl_eq:
	"t \<in> ll_on_open.existence_ivl (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0 \<longleftrightarrow> preflect t0 t \<in> existence_ivl t0 x0"
	proof -
	interpret rev: ll_on_open "(preflect t0 ` T)" "(\<lambda>t. - f (preflect t0 t))" X ..
	from rev.flow_eq_rev[of _ t0 x0] flow_eq_rev[of "2 * t0 - t" t0 x0]
	show "t \<in> rev.existence_ivl t0 x0 \<Longrightarrow> rev.flow t0 x0 t = flow t0 x0 (preflect t0 t)"
	"(t \<in> rev.existence_ivl t0 x0) = (preflect t0 t \<in> existence_ivl t0 x0)"
	by (auto simp: preflect_def fun_Compl_def image_image dest: mem_existence_ivl_iv_defined
	rev.mem_existence_ivl_iv_defined)
	qed

	lemma
	shows rev_existence_ivl_eq: "ll_on_open.existence_ivl (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0 = preflect t0 ` existence_ivl t0 x0"
	and existence_ivl_eq_rev: "existence_ivl t0 x0 = preflect t0 ` ll_on_open.existence_ivl (preflect t0 ` T) (\<lambda>t. - f (preflect t0 t)) X t0 x0"
	apply safe
	subgoal by (force simp: mem_rev_existence_ivl_eq)
	subgoal by (force simp: mem_rev_existence_ivl_eq)
	subgoal for x by (force intro!: image_eqI[where x="preflect t0 x"] simp: mem_rev_existence_ivl_eq)
	subgoal by (force simp: mem_rev_existence_ivl_eq)
	done

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Poincare_Map.thy b/thys/Ordinary_Differential_Equations/IVP/Poincare_Map.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Poincare_Map.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Poincare_Map.thy
	@@ -1,2504 +1,2504 @@
	theory Poincare_Map
	imports
	Flow
	begin

	abbreviation "plane n c \<equiv> {x. x \<bullet> n = c}"

	lemma
	eventually_tendsto_compose_within:
	assumes "eventually P (at l within S)"
	assumes "P l"
	assumes "(f \<longlongrightarrow> l) (at x within T)"
	assumes "eventually (\<lambda>x. f x \<in> S) (at x within T)"
	shows "eventually (\<lambda>x. P (f x)) (at x within T)"
	proof -
	from assms(1) assms(2) obtain U where U:
	"open U" "l \<in> U" "\<And>x. x \<in> U \<Longrightarrow> x \<in> S \<Longrightarrow> P x"
	by (force simp: eventually_at_topological)
	from topological_tendstoD[OF assms(3) \<open>open U\<close> \<open>l \<in> U\<close>]
	have "\<forall>\<^sub>F x in at x within T. f x \<in> U" by auto
	then show ?thesis using assms(4)
	by eventually_elim (auto intro!: U)
	qed

	lemma
	eventually_eventually_withinI:\<comment> \<open>aha...\<close>
	assumes "\<forall>\<^sub>F x in at x within A. P x" "P x"
	shows "\<forall>\<^sub>F a in at x within S. \<forall>\<^sub>F x in at a within A. P x"
	using assms
	unfolding eventually_at_topological
	by force

	lemma eventually_not_in_closed:
	assumes "closed P"
	assumes "f t \<notin> P" "t \<in> T"
	assumes "continuous_on T f"
	shows "\<forall>\<^sub>F t in at t within T. f t \<notin> P"
	using assms
	unfolding Compl_iff[symmetric] closed_def continuous_on_topological eventually_at_topological
	by metis

	context ll_on_open_it begin

	lemma
	existence_ivl_trans':
	assumes "t + s \<in> existence_ivl t0 x0"
	"t \<in> existence_ivl t0 x0"
	shows "t + s \<in> existence_ivl t (flow t0 x0 t)"
	by (meson assms(1) assms(2) general.existence_ivl_reverse general.flow_solves_ode
	general.is_interval_existence_ivl general.maximal_existence_flow(1)
	general.mem_existence_ivl_iv_defined(2) general.mem_existence_ivl_subset
	local.existence_ivl_subset subsetD)

	end

	context auto_ll_on_open\<comment> \<open>TODO: generalize to continuous systems\<close>
	begin

	definition returns_to ::"'a set \<Rightarrow> 'a \<Rightarrow> bool"
	where "returns_to P x \<longleftrightarrow> (\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P) \<and> (\<exists>t>0. t \<in> existence_ivl0 x \<and> flow0 x t \<in> P)"

	definition return_time :: "'a set \<Rightarrow> 'a \<Rightarrow> real"
	where "return_time P x =
	(if returns_to P x then (SOME t.
	t > 0 \<and>
	t \<in> existence_ivl0 x \<and>
	flow0 x t \<in> P \<and>
	(\<forall>s \<in> {0<..<t}. flow0 x s \<notin> P)) else 0)"

	lemma returns_toI:
	assumes t: "t > 0" "t \<in> existence_ivl0 x" "flow0 x t \<in> P"
	assumes ev: "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	assumes "closed P"
	shows "returns_to P x"
	using assms
	by (auto simp: returns_to_def)

	lemma returns_to_outsideI:
	assumes t: "t \<ge> 0" "t \<in> existence_ivl0 x" "flow0 x t \<in> P"
	assumes ev: "x \<notin> P"
	assumes "closed P"
	shows "returns_to P x"
	proof cases
	assume "t > 0"
	moreover
	have "\<forall>\<^sub>F s in at 0 within {0 .. t}. flow0 x s \<notin> P"
	using assms mem_existence_ivl_iv_defined ivl_subset_existence_ivl[OF \<open>t \<in> _\<close>] \<open>0 < t\<close>
	by (auto intro!: eventually_not_in_closed flow_continuous_on continuous_intros
	simp: eventually_conj_iff)
	with order_tendstoD(2)[OF tendsto_ident_at \<open>0 < t\<close>, of "{0<..}"]
	have "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	unfolding eventually_at_filter
	by eventually_elim (use \<open>t > 0\<close> in auto)
	then show ?thesis
	by (auto intro!: returns_toI assms \<open>0 < t\<close>)
	qed (use assms in simp)

	lemma returns_toE:
	assumes "returns_to P x"
	obtains t0 t1 where
	"0 < t0"
	"t0 \<le> t1"
	"t1 \<in> existence_ivl0 x"
	"flow0 x t1 \<in> P"
	"\<And>t. 0 < t \<Longrightarrow> t < t0 \<Longrightarrow> flow0 x t \<notin> P"
	proof -
	obtain t0 t1 where t0: "t0 > 0" "\<And>t. 0 < t \<Longrightarrow> t < t0 \<Longrightarrow> flow0 x t \<notin> P"
	and t1: "t1 > 0" "t1 \<in> existence_ivl0 x" "flow0 x t1 \<in> P"
	using assms
	by (auto simp: returns_to_def eventually_at_right[OF zero_less_one])
	moreover
	have "t0 \<le> t1"
	using t0(2)[of t1] t1 t0(1)
	by force
	ultimately show ?thesis by (blast intro: that)
	qed

	lemma return_time_some:
	assumes "returns_to P x"
	shows "return_time P x =
	(SOME t. t > 0 \<and> t \<in> existence_ivl0 x \<and> flow0 x t \<in> P \<and> (\<forall>s \<in> {0<..<t}. flow0 x s \<notin> P))"
	using assms by (auto simp: return_time_def)

	lemma return_time_ex1:
	assumes "returns_to P x"
	assumes "closed P"
	shows "\<exists>!t. t > 0 \<and> t \<in> existence_ivl0 x \<and> flow0 x t \<in> P \<and> (\<forall>s \<in> {0<..<t}. flow0 x s \<notin> P)"
	proof -
	from returns_toE[OF \<open>returns_to P x\<close>]
	obtain t0 t1 where
	t1: "t1 \<ge> t0" "t1 \<in> existence_ivl0 x" "flow0 x t1 \<in> P"
	and t0: "t0 > 0" "\<And>t. 0 < t \<Longrightarrow> t < t0 \<Longrightarrow> flow0 x t \<notin> P"
	by metis
	from flow_continuous_on have cont: "continuous_on {0 .. t1} (flow0 x)"
	by (rule continuous_on_subset) (intro ivl_subset_existence_ivl t1)
	from cont have cont': "continuous_on {t0 .. t1} (flow0 x)"
	by (rule continuous_on_subset) (use \<open>0 < t0\<close> in auto)
	have "compact (flow0 x -` P \<inter> {t0 .. t1})"
	using \<open>closed P\<close> cont'
	by (auto simp: compact_eq_bounded_closed bounded_Int bounded_closed_interval
	intro!: closed_vimage_Int)

	have "flow0 x -` P \<inter> {t0..t1} \<noteq> {}"
	using t1 t0 by auto
	from compact_attains_inf[OF \<open>compact _\<close> this] t0 t1
	obtain rt where rt: "t0 \<le> rt" "rt \<le> t1" "flow0 x rt \<in> P"
	and least: "\<And>t'. flow0 x t' \<in> P \<Longrightarrow> t0 \<le> t' \<Longrightarrow> t' \<le> t1 \<Longrightarrow> rt \<le> t'"
	by auto
	have "0 < rt" "flow0 x rt \<in> P" "rt \<in> existence_ivl0 x"
	and "0 < t' \<Longrightarrow> t' < rt \<Longrightarrow> flow0 x t' \<notin> P" for t'
	using ivl_subset_existence_ivl[OF \<open>t1 \<in> existence_ivl0 x\<close>] t0 t1 rt least[of t']
	by force+
	then show ?thesis
	by (intro ex_ex1I) force+
	qed

	lemma
	return_time_pos_returns_to:
	"return_time P x > 0 \<Longrightarrow> returns_to P x"
	by (auto simp: return_time_def split: if_splits)

	lemma
	assumes ret: "returns_to P x"
	assumes "closed P"
	shows return_time_pos: "return_time P x > 0"
	using someI_ex[OF return_time_ex1[OF assms, THEN ex1_implies_ex]]
	unfolding return_time_some[OF ret, symmetric]
	by auto

	lemma returns_to_return_time_pos:
	assumes "closed P"
	shows "returns_to P x \<longleftrightarrow> return_time P x > 0"
	by (auto intro!: return_time_pos assms) (auto simp: return_time_def split: if_splits)

	lemma return_time:
	assumes ret: "returns_to P x"
	assumes "closed P"
	shows "return_time P x > 0"
	and return_time_exivl: "return_time P x \<in> existence_ivl0 x"
	and return_time_returns: "flow0 x (return_time P x) \<in> P"
	and return_time_least: "\<And>s. 0 < s \<Longrightarrow> s < return_time P x \<Longrightarrow> flow0 x s \<notin> P"
	using someI_ex[OF return_time_ex1[OF assms, THEN ex1_implies_ex]]
	unfolding return_time_some[OF ret, symmetric]
	by auto

	lemma returns_to_earlierI:
	assumes ret: "returns_to P (flow0 x t)" "closed P"
	assumes "t \<ge> 0" "t \<in> existence_ivl0 x"
	assumes ev: "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	shows "returns_to P x"
	proof -
	from return_time[OF ret]
	have rt: "0 < return_time P (flow0 x t)" "flow0 (flow0 x t) (return_time P (flow0 x t)) \<in> P"
	and "0 < s \<Longrightarrow> s < return_time P (flow0 x t) \<Longrightarrow> flow0 (flow0 x t) s \<notin> P" for s
	by auto
	let ?t = "t + return_time P (flow0 x t)"
	show ?thesis
	proof (rule returns_toI[of ?t])
	show "0 < ?t" by (auto intro!: add_nonneg_pos rt \<open>t \<ge> 0\<close>)
	show "?t \<in> existence_ivl0 x"
	by (intro existence_ivl_trans return_time_exivl assms)
	have "flow0 x (t + return_time P (flow0 x t)) = flow0 (flow0 x t) (return_time P (flow0 x t))"
	by (intro flow_trans assms return_time_exivl)
	also have "\<dots> \<in> P"
	by (rule return_time_returns[OF ret])
	finally show "flow0 x (t + return_time P (flow0 x t)) \<in> P" .
	show "closed P" by fact
	show "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P" by fact
	qed
	qed

	lemma return_time_gt:
	assumes ret: "returns_to P x" "closed P"
	assumes flow_not: "\<And>s. 0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> flow0 x s \<notin> P"
	shows "t < return_time P x"
	using flow_not[of "return_time P x"] return_time_pos[OF ret] return_time_returns[OF ret] by force

	lemma return_time_le:
	assumes ret: "returns_to P x" "closed P"
	assumes flow_not: "flow0 x t \<in> P" "t > 0"
	shows "return_time P x \<le> t"
	using return_time_least[OF assms(1,2), of t] flow_not
	by force

	lemma returns_to_laterI:
	assumes ret: "returns_to P x" "closed P"
	assumes t: "t > 0" "t \<in> existence_ivl0 x"
	assumes flow_not: "\<And>s. 0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> flow0 x s \<notin> P"
	shows "returns_to P (flow0 x t)"
	apply (rule returns_toI[of "return_time P x - t"])
	subgoal using flow_not by (auto intro!: return_time_gt ret)
	subgoal by (auto intro!: existence_ivl_trans' return_time_exivl ret t)
	subgoal by (subst flow_trans[symmetric])
	(auto intro!: existence_ivl_trans' return_time_exivl ret t return_time_returns)
	subgoal
	proof -
	have "\<forall>\<^sub>F y in nhds 0. y \<in> existence_ivl0 (flow0 x t)"
	apply (rule eventually_nhds_in_open[OF open_existence_ivl[of "flow0 x t"] existence_ivl_zero])
	apply (rule flow_in_domain)
	apply fact
	done
	then have "\<forall>\<^sub>F s in at_right 0. s \<in> existence_ivl0 (flow0 x t)"
	unfolding eventually_at_filter
	by eventually_elim auto
	moreover
	have "\<forall>\<^sub>F s in at_right 0. t + s < return_time P x"
	using return_time_gt[OF ret flow_not, of t]
	by (auto simp: eventually_at_right[OF zero_less_one] intro!: exI[of _ "return_time P x - t"])
	moreover
	have "\<forall>\<^sub>F s in at_right 0. 0 < t + s"
	by (metis (mono_tags) eventually_at_rightI greaterThanLessThan_iff pos_add_strict t(1))
	ultimately show ?thesis
	apply eventually_elim
	apply (subst flow_trans[symmetric])
	using return_time_least[OF ret]
	by (auto intro!: existence_ivl_trans' t)
	qed
	subgoal by fact
	done

	lemma never_returns:
	assumes "\<not>returns_to P x"
	assumes "closed P" "t \<ge> 0" "t \<in> existence_ivl0 x"
	assumes ev: "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	shows "\<not>returns_to P (flow0 x t)"
	using returns_to_earlierI[OF _ assms(2-5)] assms(1)
	by blast

	lemma return_time_eqI:
	assumes "closed P"
	and t_pos: "t > 0"
	and ex: "t \<in> existence_ivl0 x"
	and ret: "flow0 x t \<in> P"
	and least: "\<And>s. 0 < s \<Longrightarrow> s < t \<Longrightarrow> flow0 x s \<notin> P"
	shows "return_time P x = t"
	proof -
	from least t_pos have "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	by (auto simp: eventually_at_right[OF zero_less_one])
	then have "returns_to P x"
	by (auto intro!: returns_toI[of t] assms)
	then show ?thesis
	using least
	by (auto simp: return_time_def t_pos ex ret
	intro!: some1_equality[OF return_time_ex1[OF \<open>returns_to _ _\<close> \<open>closed _\<close>]])
	qed

	lemma return_time_step:
	assumes "returns_to P (flow0 x t)"
	assumes "closed P"
	assumes flow_not: "\<And>s. 0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> flow0 x s \<notin> P"
	assumes t: "t > 0" "t \<in> existence_ivl0 x"
	shows "return_time P (flow0 x t) = return_time P x - t"
	proof -
	from flow_not t have "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	by (auto simp: eventually_at_right[OF zero_less_one])
	from returns_to_earlierI[OF assms(1,2) less_imp_le, OF t this]
	have ret: "returns_to P x" .
	from return_time_gt[OF ret \<open>closed P\<close> flow_not]
	have "t < return_time P x" by simp
	moreover
	have "0 < s \<Longrightarrow> s < return_time P x - t \<Longrightarrow> flow0 (flow0 x t) s = flow0 x (t + s)" for s
	using ivl_subset_existence_ivl[OF return_time_exivl[OF ret \<open>closed _\<close>]] t
	by (subst flow_trans) (auto intro!: existence_ivl_trans')
	ultimately show ?thesis
	using flow_not assms(1) ret return_time_least t(1)
	by (auto intro!: return_time_eqI return_time_returns ret
	simp: flow_trans[symmetric] \<open>closed P\<close> t(2) existence_ivl_trans' return_time_exivl)
	qed

	definition "poincare_map P x = flow0 x (return_time P x)"

	lemma poincare_map_step_flow:
	assumes ret: "returns_to P x" "closed P"
	assumes flow_not: "\<And>s. 0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> flow0 x s \<notin> P"
	assumes t: "t > 0" "t \<in> existence_ivl0 x"
	shows "poincare_map P (flow0 x t) = poincare_map P x"
	unfolding poincare_map_def
	apply (subst flow_trans[symmetric])
	subgoal by fact
	subgoal using flow_not by (auto intro!: return_time_exivl returns_to_laterI t ret)
	subgoal
	using flow_not
	by (subst return_time_step) (auto intro!: return_time_exivl returns_to_laterI t ret)
	done

	lemma poincare_map_returns:
	assumes "returns_to P x" "closed P"
	shows "poincare_map P x \<in> P"
	by (auto intro!: return_time_returns assms simp: poincare_map_def)

	lemma poincare_map_onto:
	assumes "closed P"
	assumes "0 < t" "t \<in> existence_ivl0 x" "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> P"
	assumes "flow0 x t \<in> P"
	shows "poincare_map P x \<in> flow0 x ` {0 <.. t} \<inter> P"
	proof (rule IntI)
	have "returns_to P x"
	by (rule returns_toI) (rule assms)+
	then have "return_time P x \<in> {0<..t}"
	by (auto intro!: return_time_pos assms return_time_le)
	then show "poincare_map P x \<in> flow0 x ` {0<..t}"
	by (auto simp: poincare_map_def)
	show "poincare_map P x \<in> P"
	by (auto intro!: poincare_map_returns \<open>returns_to _ _\<close> \<open>closed _\<close>)
	qed

	end


	lemma isCont_blinfunD:
	fixes f'::"'a::metric_space \<Rightarrow> 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector"
	assumes "isCont f' a" "0 < e"
	shows "\<exists>d>0. \<forall>x. dist a x < d \<longrightarrow> onorm (\<lambda>v. blinfun_apply (f' x) v - blinfun_apply (f' a) v) < e"
	proof -
	have "\<forall>\<^sub>F x in at a. dist (f' x) (f' a) < e"
	using assms isCont_def tendsto_iff by blast
	then show ?thesis
	using \<open>e > 0\<close> norm_eq_zero
	by (force simp: eventually_at dist_commute dist_norm norm_blinfun.rep_eq
	simp flip: blinfun.bilinear_simps)
	qed

	proposition has_derivative_locally_injective_blinfun:
	fixes f :: "'n::euclidean_space \<Rightarrow> 'm::euclidean_space"
	and f'::"'n \<Rightarrow> 'n \<Rightarrow>\<^sub>L 'm"
	and g'::"'m \<Rightarrow>\<^sub>L 'n"
	assumes "a \<in> s"
	and "open s"
	and g': "g' o\<^sub>L (f' a) = 1\<^sub>L"
	and f': "\<And>x. x \<in> s \<Longrightarrow> (f has_derivative f' x) (at x)"
	and c: "isCont f' a"
	obtains r where "r > 0" "ball a r \<subseteq> s" "inj_on f (ball a r)"
	proof -
	have bl: "bounded_linear (blinfun_apply g')"
	by (auto simp: blinfun.bounded_linear_right)
	from g' have g': "blinfun_apply g' \<circ> blinfun_apply (f' a) = id"
	by transfer (simp add: id_def)
	from has_derivative_locally_injective[OF \<open>a \<in> s\<close> \<open>open s\<close> bl g' f' isCont_blinfunD[OF c]]
	obtain r where "0 < r" "ball a r \<subseteq> s" "inj_on f (ball a r)"
	by auto
	then show ?thesis ..
	qed

	lift_definition embed1_blinfun::"'a::real_normed_vector \<Rightarrow>\<^sub>L ('a*'b::real_normed_vector)" is "\<lambda>x. (x, 0)"
	by standard (auto intro!: exI[where x=1])
	lemma blinfun_apply_embed1_blinfun[simp]: "blinfun_apply embed1_blinfun x = (x, 0)"
	by transfer simp

	lift_definition embed2_blinfun::"'a::real_normed_vector \<Rightarrow>\<^sub>L ('b::real_normed_vector*'a)" is "\<lambda>x. (0, x)"
	by standard (auto intro!: exI[where x=1])
	lemma blinfun_apply_embed2_blinfun[simp]: "blinfun_apply embed2_blinfun x = (0, x)"
	by transfer simp

	lemma blinfun_inverseD: "f o\<^sub>L f' = 1\<^sub>L \<Longrightarrow> f (f' x) = x"
	apply transfer
	unfolding o_def
	by meson

	lemmas continuous_on_open_vimageI = continuous_on_open_vimage[THEN iffD1, rule_format]
	lemmas continuous_on_closed_vimageI = continuous_on_closed_vimage[THEN iffD1, rule_format]

	lemma ball_times_subset: "ball a (c/2) \<times> ball b (c/2) \<subseteq> ball (a, b) c"
	proof -
	{
	fix a' b'
	have "sqrt ((dist a a')\<^sup>2 + (dist b b')\<^sup>2) \<le> dist a a' + dist b b'"
	by (rule real_le_lsqrt) (auto simp: power2_eq_square algebra_simps)
	also assume "a' \<in> ball a (c / 2)"
	then have "dist a a' < c / 2" by (simp add:)
	also assume "b' \<in> ball b (c / 2)"
	then have "dist b b' < c / 2" by (simp add:)
	finally have "sqrt ((dist a a')\<^sup>2 + (dist b b')\<^sup>2) < c"
	by simp
	} thus ?thesis by (auto simp: dist_prod_def mem_cball)
	qed

	lemma linear_inverse_blinop_lemma:
	fixes w::"'a::{banach, perfect_space} blinop"
	assumes "norm w < 1"
	shows
	"summable (\<lambda>n. (-1)^n *\<^sub>R w^n)" (is ?C)
	"(\<Sum>n. (-1)^n \<^sub>R w^n) (1 + w) = 1" (is ?I1)
	"(1 + w) * (\<Sum>n. (-1)^n *\<^sub>R w^n) = 1" (is ?I2)
	"norm ((\<Sum>n. (-1)^n *\<^sub>R w^n) - 1 + w) \<le> (norm w)\<^sup>2/(1 - norm (w))" (is ?L)
	proof -
	have "summable (\<lambda>n. norm w ^ n)"
	apply (rule summable_geometric)
	using assms by auto
	then have "summable (\<lambda>n. norm (w ^ n))"
	by (rule summable_comparison_test'[where N=0]) (auto intro!: norm_power_ineq)
	then show ?C
	by (rule summable_comparison_test'[where N=0]) (auto simp: norm_power )
	{
	fix N
	have 1: "(1 + w) * sum (\<lambda>n. (-1)^n \<^sub>R w^n) {..<N} = sum (\<lambda>n. (-1)^n \<^sub>R w^n) {..<N} * (1 + w)"
	by (auto simp: algebra_simps sum_distrib_left sum_distrib_right sum.distrib power_commutes)
	also have "\<dots> = sum (\<lambda>n. (-1)^n \<^sub>R w^n - (-1)^Suc n \<^sub>R w^ Suc n) {..<N}"
	by (auto simp: algebra_simps sum_distrib_left sum_distrib_right sum.distrib power_commutes)
	also have "\<dots> = 1 - (-1)^N *\<^sub>R w^N"
	by (subst sum_lessThan_telescope') (auto simp: algebra_simps)
	finally have "(1 + w) * (\<Sum>n<N. (- 1) ^ n \<^sub>R w ^ n) = 1 - (- 1) ^ N \<^sub>R w ^ N" .
	note 1 this
	} note nu = this
	show "?I1"
	apply (subst suminf_mult2, fact)
	apply (subst suminf_eq_lim)
	apply (subst sum_distrib_right[symmetric])
	apply (rule limI)
	apply (subst nu(1)[symmetric])
	apply (subst nu(2))
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_norm_zero_cancel)
	apply auto
	apply (rule Lim_transform_bound[where g="\<lambda>i. norm w ^ i"])
	apply (rule eventuallyI)
	apply simp apply (rule norm_power_ineq)
	apply (auto intro!: LIMSEQ_power_zero assms)
	done
	show "?I2"
	apply (subst suminf_mult[symmetric], fact)
	apply (subst suminf_eq_lim)
	apply (subst sum_distrib_left[symmetric])
	apply (rule limI)
	apply (subst nu(2))
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_norm_zero_cancel)
	apply auto
	apply (rule Lim_transform_bound[where g="\<lambda>i. norm w ^ i"])
	apply (rule eventuallyI)
	apply simp apply (rule norm_power_ineq)
	apply (auto intro!: LIMSEQ_power_zero assms)
	done
	have : "(\<Sum>n. (- 1) ^ n \<^sub>R w ^ n) - 1 + w = (w\<^sup>2 * (\<Sum>n. (- 1) ^ n *\<^sub>R w ^ n))"
	apply (subst suminf_split_initial_segment[where k=2], fact)
	apply (subst suminf_mult[symmetric], fact)
	by (auto simp: power2_eq_square algebra_simps eval_nat_numeral)
	also have "norm \<dots> \<le> (norm w)\<^sup>2 / (1 - norm w)"
	proof -
	have \<section>: "norm (\<Sum>n. (- 1) ^ n *\<^sub>R w ^ n) \<le> 1 / (1 - norm w)"
	apply (rule order_trans[OF summable_norm])
	apply auto
	apply fact
	apply (rule order_trans[OF suminf_le])
	apply (rule norm_power_ineq)
	apply fact
	apply fact
	by (auto simp: suminf_geometric assms)
	show ?thesis
	apply (rule order_trans[OF norm_mult_ineq])
	apply (subst divide_inverse)
	apply (rule mult_mono)
	apply (auto simp: norm_power_ineq inverse_eq_divide assms \<section>)
	done
	qed
	finally show ?L .
	qed

	lemma linear_inverse_blinfun_lemma:
	fixes w::"'a \<Rightarrow>\<^sub>L 'a::{banach, perfect_space}"
	assumes "norm w < 1"
	obtains I where
	"I o\<^sub>L (1\<^sub>L + w) = 1\<^sub>L" "(1\<^sub>L + w) o\<^sub>L I = 1\<^sub>L"
	"norm (I - 1\<^sub>L + w) \<le> (norm w)\<^sup>2/(1 - norm (w))"
	proof -
	define v::"'a blinop" where "v = Blinop w"
	have "norm v = norm w"
	unfolding v_def
	apply transfer
	by (simp add: bounded_linear_Blinfun_apply norm_blinfun.rep_eq)
	with assms have "norm v < 1" by simp
	from linear_inverse_blinop_lemma[OF this]
	have v: "(\<Sum>n. (- 1) ^ n \<^sub>R v ^ n) (1 + v) = 1"
	"(1 + v) * (\<Sum>n. (- 1) ^ n *\<^sub>R v ^ n) = 1"
	"norm ((\<Sum>n. (- 1) ^ n *\<^sub>R v ^ n) - 1 + v) \<le> (norm v)\<^sup>2 / (1 - norm v)"
	by auto
	define J::"'a blinop" where "J = (\<Sum>n. (- 1) ^ n *\<^sub>R v ^ n)"
	define I::"'a \<Rightarrow>\<^sub>L 'a" where "I = Blinfun J"
	have "Blinfun (blinop_apply J) - 1\<^sub>L + w = Rep_blinop (J - 1 + Blinop (blinfun_apply w))"
	by transfer' (auto simp: blinfun_apply_inverse)
	then have ne: "norm (Blinfun (blinop_apply J) - 1\<^sub>L + w) =
	norm (J - 1 + Blinop (blinfun_apply w))"
	by (auto simp: norm_blinfun_def norm_blinop_def)
	from v have
	"I o\<^sub>L (1\<^sub>L + w) = 1\<^sub>L" "(1\<^sub>L + w) o\<^sub>L I = 1\<^sub>L"
	"norm (I - 1\<^sub>L + w) \<le> (norm w)\<^sup>2/(1 - norm (w))"
	apply (auto simp: I_def J_def[symmetric])
	unfolding v_def
	apply (auto simp: blinop.bounded_linear_right bounded_linear_Blinfun_apply
	intro!: blinfun_eqI)
	subgoal by transfer
	(auto simp: blinfun_ext blinfun.bilinear_simps bounded_linear_Blinfun_apply)
	subgoal
	by transfer (auto simp: Transfer.Rel_def
	blinfun_ext blinfun.bilinear_simps bounded_linear_Blinfun_apply)
	subgoal
	apply (auto simp: ne)
	apply transfer
	by (auto simp: norm_blinfun_def bounded_linear_Blinfun_apply)
	done
	then show ?thesis ..
	qed

	definition "invertibles_blinfun = {w. \<exists>wi. w o\<^sub>L wi = 1\<^sub>L \<and> wi o\<^sub>L w = 1\<^sub>L}"

	lemma blinfun_inverse_open:\<comment> \<open>8.3.2 in Dieudonne, TODO: add continuity and derivative\<close>
	shows "open (invertibles_blinfun::
	('a::{banach, perfect_space} \<Rightarrow>\<^sub>L 'b::banach) set)"
	proof (rule openI)
	fix u0::"'a \<Rightarrow>\<^sub>L 'b"
	assume "u0 \<in> invertibles_blinfun"
	then obtain u0i where u0i: "u0 o\<^sub>L u0i = 1\<^sub>L" "u0i o\<^sub>L u0 = 1\<^sub>L"
	by (auto simp: invertibles_blinfun_def)
	then have [simp]: "u0i \<noteq> 0"
	apply (auto)
	by (metis one_blinop.abs_eq zero_blinop.abs_eq zero_neq_one)
	let ?e = "inverse (norm u0i)"
	show "\<exists>e>0. ball u0 e \<subseteq> invertibles_blinfun"
	apply (clarsimp intro!: exI[where x = ?e] simp: invertibles_blinfun_def)
	subgoal premises prems for u0s
	proof -
	define s where "s = u0s - u0"
	have u0s: "u0s = u0 + s"
	by (auto simp: s_def)
	have "norm (u0i o\<^sub>L s) < 1"
	using prems by (auto simp: dist_norm u0s
	divide_simps ac_simps intro!: le_less_trans[OF norm_blinfun_compose])
	from linear_inverse_blinfun_lemma[OF this]
	obtain I where I:
	"I o\<^sub>L 1\<^sub>L + (u0i o\<^sub>L s) = 1\<^sub>L"
	"1\<^sub>L + (u0i o\<^sub>L s) o\<^sub>L I = 1\<^sub>L"
	"norm (I - 1\<^sub>L + (u0i o\<^sub>L s)) \<le> (norm (u0i o\<^sub>L s))\<^sup>2 / (1 - norm (u0i o\<^sub>L s))"
	by auto
	have u0s_eq: "u0s = u0 o\<^sub>L (1\<^sub>L + (u0i o\<^sub>L s))"
	using u0i
	by (auto simp: s_def blinfun.bilinear_simps blinfun_ext)
	show ?thesis
	apply (rule exI[where x="I o\<^sub>L u0i"])
	using I u0i
	apply (auto simp: u0s_eq)
	by (auto simp: algebra_simps blinfun_ext blinfun.bilinear_simps)
	qed
	done
	qed

	lemma blinfun_compose_assoc[ac_simps]: "a o\<^sub>L b o\<^sub>L c = a o\<^sub>L (b o\<^sub>L c)"
	by (auto intro!: blinfun_eqI)

	text \<open>TODO: move @{thm norm_minus_cancel} to class!\<close>
	lemma (in real_normed_vector) norm_minus_cancel [simp]: "norm (- x) = norm x"
	proof -
	have scaleR_minus_left: "- a \<^sub>R x = - (a \<^sub>R x)" for a x
	proof -
	have "\<forall>x1 x2. (x2::real) + x1 = x1 + x2"
	by auto
	then have f1: "\<forall>r ra a. (ra + r) \<^sub>R (a::'a) = r \<^sub>R a + ra *\<^sub>R a"
	using local.scaleR_add_left by presburger
	have f2: "a + a = 2 * a"
	by force
	have f3: "2 * a + - 1 * a = a"
	by auto
	have "- a = - 1 * a"
	by auto
	then show ?thesis
	using f3 f2 f1 by (metis local.add_minus_cancel local.add_right_imp_eq)
	qed
	have "norm (- x) = norm (scaleR (- 1) x)"
	by (simp only: scaleR_minus_left scaleR_one)
	also have "\<dots> = \<bar>- 1\<bar> * norm x"
	by (rule norm_scaleR)
	finally show ?thesis by simp
	qed

	text \<open>TODO: move @{thm norm_minus_commute} to class!\<close>
	lemma (in real_normed_vector) norm_minus_commute: "norm (a - b) = norm (b - a)"
	proof -
	have "norm (- (b - a)) = norm (b - a)"
	by (rule norm_minus_cancel)
	then show ?thesis by simp
	qed

	instance euclidean_space \<subseteq> banach
	by standard

	lemma blinfun_apply_Pair_split:
	"blinfun_apply g (a, b) = blinfun_apply g (a, 0) + blinfun_apply g (0, b)"
	unfolding blinfun.bilinear_simps[symmetric] by simp

	lemma blinfun_apply_Pair_add2: "blinfun_apply f (0, a + b) = blinfun_apply f (0, a) + blinfun_apply f (0, b)"
	unfolding blinfun.bilinear_simps[symmetric] by simp

	lemma blinfun_apply_Pair_add1: "blinfun_apply f (a + b, 0) = blinfun_apply f (a, 0) + blinfun_apply f (b, 0)"
	unfolding blinfun.bilinear_simps[symmetric] by simp

	lemma blinfun_apply_Pair_minus2: "blinfun_apply f (0, a - b) = blinfun_apply f (0, a) - blinfun_apply f (0, b)"
	unfolding blinfun.bilinear_simps[symmetric] by simp

	lemma blinfun_apply_Pair_minus1: "blinfun_apply f (a - b, 0) = blinfun_apply f (a, 0) - blinfun_apply f (b, 0)"
	unfolding blinfun.bilinear_simps[symmetric] by simp

	lemma implicit_function_theorem:
	fixes f::"'a::euclidean_space * 'b::euclidean_space \<Rightarrow> 'c::euclidean_space"\<comment> \<open>TODO: generalize?!\<close>
	assumes [derivative_intros]: "\<And>x. x \<in> S \<Longrightarrow> (f has_derivative blinfun_apply (f' x)) (at x)"
	assumes S: "(x, y) \<in> S" "open S"
	assumes "DIM('c) \<le> DIM('b)"
	assumes f'C: "isCont f' (x, y)"
	assumes "f (x, y) = 0"
	assumes T2: "T o\<^sub>L (f' (x, y) o\<^sub>L embed2_blinfun) = 1\<^sub>L"
	assumes T1: "(f' (x, y) o\<^sub>L embed2_blinfun) o\<^sub>L T = 1\<^sub>L"\<comment> \<open>TODO: reduce?!\<close>
	obtains u e r
	where "f (x, u x) = 0" "u x = y"
	"\<And>s. s \<in> cball x e \<Longrightarrow> f (s, u s) = 0"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> S"
	"e > 0"
	"(u has_derivative - T o\<^sub>L f' (x, y) o\<^sub>L embed1_blinfun) (at x)"

	"r > 0"
	"\<And>U v s. v x = y \<Longrightarrow> (\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0) \<Longrightarrow> U \<subseteq> cball x e \<Longrightarrow>
	continuous_on U v \<Longrightarrow> s \<in> U \<Longrightarrow> (s, v s) \<in> ball (x, y) r \<Longrightarrow> u s = v s"
	proof -
	define H where "H \<equiv> \<lambda>(x, y). (x, f (x, y))"
	define H' where "H' \<equiv> \<lambda>x. (embed1_blinfun o\<^sub>L fst_blinfun) + (embed2_blinfun o\<^sub>L (f' x))"
	have f'_inv: "f' (x, y) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	using T1 T2 by (auto simp: invertibles_blinfun_def ac_simps intro!: exI[where x=T])
	from openE[OF blinfun_inverse_open this]
	obtain d0 where e0: "0 < d0"
	"ball (f' (x, y) o\<^sub>L embed2_blinfun) d0 \<subseteq> invertibles_blinfun"
	by auto
	have "isCont (\<lambda>s. f' s o\<^sub>L embed2_blinfun) (x, y)"
	by (auto intro!: continuous_intros f'C)
	from this[unfolded isCont_def, THEN tendstoD, OF \<open>0 < d0\<close>]
	have "\<forall>\<^sub>F s in at (x, y). f' s o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	apply eventually_elim
	using e0 by (auto simp: subset_iff dist_commute)
	then obtain e0 where "e0 > 0"
	"xa \<noteq> (x, y) \<Longrightarrow> dist xa (x, y) < e0 \<Longrightarrow>
	f' xa o\<^sub>L embed2_blinfun \<in> invertibles_blinfun" for xa
	unfolding eventually_at
	by auto
	then have e0: "e0 > 0"
	"dist xa (x, y) < e0 \<Longrightarrow> f' xa o\<^sub>L embed2_blinfun \<in> invertibles_blinfun" for xa
	apply -
	subgoal by simp
	using f'_inv
	apply (cases "xa = (x, y)")
	by auto

	have H': "x \<in> S \<Longrightarrow> (H has_derivative H' x) (at x)" for x
	unfolding H_def H'_def
	by (auto intro!: derivative_eq_intros ext simp: blinfun.bilinear_simps)
	have cH': "isCont H' (x, y)"
	unfolding H'_def
	by (auto intro!: continuous_intros assms)
	have linear_H': "\<And>s. s \<in> S \<Longrightarrow> linear (H' s)"
	using H' assms(2) has_derivative_linear by blast
	have *: "blinfun_apply T (blinfun_apply (f' (x, y)) (0, b)) = b" for b
	using blinfun_inverseD[OF T2, of b]
	by simp
	have "inj (f' (x, y) o\<^sub>L embed2_blinfun)"
	by (metis (no_types, lifting) "*" blinfun_apply_blinfun_compose embed2_blinfun.rep_eq injI)
	then have [simp]: "blinfun_apply (f' (x, y)) (0, b) = 0 \<Longrightarrow> b = 0" for b
	apply (subst (asm) linear_injective_0)
	subgoal
	apply (rule bounded_linear.linear)
	apply (rule blinfun.bounded_linear_right)
	done
	subgoal by simp
	done
	have "inj (H' (x, y))"
	apply (subst linear_injective_0)
	apply (rule linear_H')
	apply fact
	apply (auto simp: H'_def blinfun.bilinear_simps zero_prod_def)
	done
	define Hi where "Hi = (embed1_blinfun o\<^sub>L fst_blinfun) + ((embed2_blinfun o\<^sub>L T o\<^sub>L (snd_blinfun - (f' (x, y) o\<^sub>L embed1_blinfun o\<^sub>L fst_blinfun))))"
	have Hi': "(\<lambda>u. snd (blinfun_apply Hi (u, 0))) = - T o\<^sub>L f' (x, y) o\<^sub>L embed1_blinfun"
	by (auto simp: Hi_def blinfun.bilinear_simps)
	have Hi: "Hi o\<^sub>L H' (x, y) = 1\<^sub>L"
	apply (auto simp: H'_def fun_eq_iff blinfun.bilinear_simps Hi_def
	intro!: ext blinfun_eqI)
	apply (subst blinfun_apply_Pair_split)
	by (auto simp: * blinfun.bilinear_simps)
	from has_derivative_locally_injective_blinfun[OF S this H' cH']
	obtain r0 where r0: "0 < r0" "ball (x, y) r0 \<subseteq> S" and inj: "inj_on H (ball (x, y) r0)"
	by auto
	define r where "r = min r0 e0"
	have r: "0 < r" "ball (x, y) r \<subseteq> S" and inj: "inj_on H (ball (x, y) r)"
	and r_inv: "\<And>s. s \<in> ball (x, y) r \<Longrightarrow> f' s o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	subgoal using e0 r0 by (auto simp: r_def)
	subgoal using e0 r0 by (auto simp: r_def)
	subgoal using inj apply (rule inj_on_subset)
	using e0 r0 by (auto simp: r_def)
	subgoal for s
	using e0 r0 by (auto simp: r_def dist_commute)
	done
	obtain i::'a where "i \<in> Basis"
	using nonempty_Basis by blast
	define undef where "undef \<equiv> (x, y) + r *\<^sub>R (i, 0)"\<comment> \<open>really??\<close>
	have ud: "\<not> dist (x, y) undef < r"
	using \<open>r > 0\<close> \<open>i \<in> Basis\<close> by (auto simp: undef_def dist_norm)
	define G where "G \<equiv> the_inv_into (ball (x, y) r) H"
	{
	fix u v
	assume [simp]: "(u, v) \<in> H ` ball (x, y) r"
	note [simp] = inj
	have "(u, v) = H (G (u, v))"
	unfolding G_def
	by (subst f_the_inv_into_f[where f=H]) auto
	moreover have "\<dots> = H (G (u, v))"
	by (auto simp: G_def)
	moreover have "\<dots> = (fst (G (u, v)), f (G (u, v)))"
	by (auto simp: H_def split_beta')
	ultimately have "u = fst (G (u, v))" "v = f (G (u, v))" by simp_all
	then have "f (u, snd (G(u, v))) = v" "u = fst (G (u, v))"
	by (metis prod.collapse)+
	} note uvs = this
	note uv = uvs(1)
	moreover
	have "f (x, snd (G (x, 0))) = 0"
	apply (rule uv)
	by (metis (mono_tags, lifting) H_def assms(6) case_prod_beta' centre_in_ball fst_conv image_iff r(1) snd_conv)
	moreover
	have cH: "continuous_on S H"
	apply (rule has_derivative_continuous_on)
	apply (subst at_within_open)
	apply (auto intro!: H' assms)
	done
	have inj2: "inj_on H (ball (x, y) (r / 2))"
	apply (rule inj_on_subset, rule inj)
	using r by auto
	have oH: "open (H ` ball (x, y) (r/2))"
	apply (rule invariance_of_domain_gen)
	apply (auto simp: assms inj)
	apply (rule continuous_on_subset)
	apply fact
	using r
	apply auto
	using inj2 apply simp
	done
	have "(x, f (x, y)) \<in> H ` ball (x, y) (r/2)"
	using \<open>r > 0\<close> by (auto simp: H_def)
	from open_contains_cball[THEN iffD1, OF oH, rule_format, OF this]
	obtain e' where e': "e' > 0" "cball (x, f (x, y)) e' \<subseteq> H ` ball (x, y) (r/2)"
	by auto

	have inv_subset: "the_inv_into (ball (x, y) r) H a = the_inv_into R H a"
	if "a \<in> H ` R" "R \<subseteq> (ball (x, y) r)"
	for a R
	apply (rule the_inv_into_f_eq[OF inj])
	apply (rule f_the_inv_into_f)
	apply (rule inj_on_subset[OF inj])
	apply fact
	apply fact
	apply (rule the_inv_into_into)
	apply (rule inj_on_subset[OF inj])
	apply fact
	apply fact
	apply (rule order_trans)
	apply fact
	using r apply auto
	done
	have GH: "G (H z) = z" if "dist (x, y) z < r" for z
	by (auto simp: G_def the_inv_into_f_f inj that)
	define e where "e = min (e' / 2) e0"
	define r2 where "r2 = r / 2"
	have r2: "r2 > 0" "r2 < r"
	using \<open>r > 0\<close> by (auto simp: r2_def)
	have "e > 0" using e' e0 by (auto simp: e_def)
	from cball_times_subset[of "x" e' "f (x, y)"] e'
	have "cball x e \<times> cball (f (x, y)) e \<subseteq> H ` ball (x, y) (r/2)"
	by (force simp: e_def)
	then have e_r_subset: "z \<in> cball x e \<Longrightarrow> (z, 0) \<in> H ` ball (x, y) (r/2)" for z
	using \<open>0 < e\<close> assms(6)
	by (auto simp: H_def subset_iff)
	have u0: "(u, 0) \<in> H ` ball (x, y) r" if "u \<in> cball x e" for u
	apply (rule rev_subsetD)
	apply (rule e_r_subset)
	apply fact
	unfolding r2_def using r2 by auto
	have G_r: "G (u, 0) \<in> ball (x, y) r" if "u \<in> cball x e" for u
	unfolding G_def
	apply (rule the_inv_into_into)
	apply fact
	apply (auto)
	apply (rule u0, fact)
	done
	note e_r_subset
	ultimately have G2:
	"f (x, snd (G (x, 0))) = 0" "snd (G (x, 0)) = y"
	"\<And>u. u \<in> cball x e \<Longrightarrow> f (u, snd (G (u, 0))) = 0"
	"continuous_on (cball x e) (\<lambda>u. snd (G (u, 0)))"
	"(\<lambda>t. (t, snd (G (t, 0)))) ` cball x e \<subseteq> S"
	"e > 0"
	"((\<lambda>u. snd (G (u, 0))) has_derivative (\<lambda>u. snd (Hi (u, 0)))) (at x)"
	apply (auto simp: G_def split_beta'
	intro!: continuous_intros continuous_on_compose2[OF cH])
	subgoal premises prems
	proof -
	have "the_inv_into (ball (x, y) r) H (x, 0) = (x, y)"
	apply (rule the_inv_into_f_eq)
	apply fact
	by (auto simp: H_def assms \<open>r > 0\<close>)
	then show ?thesis
	by auto
	qed
	using r2(2) r2_def apply fastforce
	apply (subst continuous_on_cong[OF refl])
	apply (rule inv_subset[where R="cball (x, y) r2"])
	subgoal
	using r2
	apply auto
	using r2_def by force
	subgoal using r2 by (force simp:)
	subgoal
	apply (rule continuous_on_compose2[OF continuous_on_inv_into])
	using r(2) r2(2)
	apply (auto simp: r2_def[symmetric]
	intro!: continuous_on_compose2[OF cH] continuous_intros)
	apply (rule inj_on_subset)
	apply (rule inj)
	using r(2) r2(2) apply force
	apply force
	done
	subgoal premises prems for u
	proof -
	from prems have u: "u \<in> cball x e" by auto
	note G_r[OF u]
	also have "ball (x, y) r \<subseteq> S"
	using r by simp
	finally have "(G (u, 0)) \<in> S" .
	then show ?thesis
	unfolding G_def[symmetric]
	using uvs(2)[OF u0, OF u]
	by (metis prod.collapse)
	qed
	subgoal using \<open>e > 0\<close> by simp
	subgoal premises prems
	proof -
	have "(x, y) \<in> cball (x, y) r2"
	using r2
	by auto
	moreover
	have "H (x, y) \<in> interior (H ` cball (x, y) r2)"
	apply (rule interiorI[OF oH])
	using r2 by (auto simp: r2_def)
	moreover
	have "cball (x, y) r2 \<subseteq> S"
	using r r2 by auto
	moreover have "\<And>z. z \<in> cball (x, y) r2 \<Longrightarrow> G (H z) = z"
	using r2 by (auto intro!: GH)
	ultimately have "(G has_derivative Hi) (at (H (x, y)))"
	proof (rule has_derivative_inverse[where g = G and f = H,
	OF compact_cball _ _ continuous_on_subset[OF cH] _ H' _ _])
	show "blinfun_apply Hi \<circ> blinfun_apply (H' (x, y)) = id"
	using Hi by transfer auto
	qed (use S blinfun.bounded_linear_right in auto)
	then have g': "(G has_derivative Hi) (at (x, 0))"
	by (auto simp: H_def assms)
	show ?thesis
	unfolding G_def[symmetric] H_def[symmetric]
	apply (auto intro!: derivative_eq_intros)
	apply (rule has_derivative_compose[where g=G and f="\<lambda>x. (x, 0)"])
	apply (auto intro!: g' derivative_eq_intros)
	done
	qed
	done
	moreover
	note \<open>r > 0\<close>
	moreover
	define u where "u \<equiv> \<lambda>x. snd (G (x, 0))"
	have local_unique: "u s = v s"
	if solves: "(\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0)"
	and i: "v x = y"
	and v: "continuous_on U v"
	and s: "s \<in> U"
	and s': "(s, v s) \<in> ball (x, y) r"
	and U: "U \<subseteq> cball x e"
	for U v s
	proof -
	have H_eq: "H (s, v s) = H (s, u s)"
	apply (auto simp: H_def solves[OF s])
	unfolding u_def
	apply (rule G2)
	apply (rule subsetD; fact)
	done
	have "(s, snd (G (s, 0))) = (G (s, 0))"
	using GH H_def s s' solves by fastforce
	also have "\<dots> \<in> ball (x, y) r"
	unfolding G_def
	apply (rule the_inv_into_into)
	apply fact
	apply (rule u0)
	apply (rule subsetD; fact)
	apply (rule order_refl)
	done
	finally have "(s, u s) \<in> ball (x, y) r" unfolding u_def .
	from inj_onD[OF inj H_eq s' this]
	show "u s = v s"
	by auto
	qed
	ultimately show ?thesis
	unfolding u_def Hi' ..
	qed

	lemma implicit_function_theorem_unique:
	fixes f::"'a::euclidean_space * 'b::euclidean_space \<Rightarrow> 'c::euclidean_space"\<comment> \<open>TODO: generalize?!\<close>
	assumes f'[derivative_intros]: "\<And>x. x \<in> S \<Longrightarrow> (f has_derivative blinfun_apply (f' x)) (at x)"
	assumes S: "(x, y) \<in> S" "open S"
	assumes D: "DIM('c) \<le> DIM('b)"
	assumes f'C: "continuous_on S f'"
	assumes z: "f (x, y) = 0"
	assumes T2: "T o\<^sub>L (f' (x, y) o\<^sub>L embed2_blinfun) = 1\<^sub>L"
	assumes T1: "(f' (x, y) o\<^sub>L embed2_blinfun) o\<^sub>L T = 1\<^sub>L"\<comment> \<open>TODO: reduce?!\<close>
	obtains u e
	where "f (x, u x) = 0" "u x = y"
	"\<And>s. s \<in> cball x e \<Longrightarrow> f (s, u s) = 0"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> S"
	"e > 0"
	"(u has_derivative (- T o\<^sub>L f' (x, y) o\<^sub>L embed1_blinfun)) (at x)"
	"\<And>s. s \<in> cball x e \<Longrightarrow> f' (s, u s) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	"\<And>U v s. (\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0) \<Longrightarrow>
	u x = v x \<Longrightarrow>
	continuous_on U v \<Longrightarrow> s \<in> U \<Longrightarrow> x \<in> U \<Longrightarrow> U \<subseteq> cball x e \<Longrightarrow> connected U \<Longrightarrow> open U \<Longrightarrow> u s = v s"
	proof -
	from T1 T2 have f'I: "f' (x, y) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	by (auto simp: invertibles_blinfun_def)
	from assms have f'Cg: "s \<in> S \<Longrightarrow> isCont f' s" for s
	by (auto simp: continuous_on_eq_continuous_at[OF \<open>open S\<close>])
	then have f'C: "isCont f' (x, y)" by (auto simp: S)
	obtain u e1 r
	where u: "f (x, u x) = 0" "u x = y"
	"\<And>s. s \<in> cball x e1 \<Longrightarrow> f (s, u s) = 0"
	"continuous_on (cball x e1) u"
	"(\<lambda>t. (t, u t)) ` cball x e1 \<subseteq> S"
	"e1 > 0"
	"(u has_derivative (- T o\<^sub>L f' (x, y) o\<^sub>L embed1_blinfun)) (at x)"
	and unique_u: "r > 0"
	"(\<And>v s U. v x = y \<Longrightarrow>
	(\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0) \<Longrightarrow>
	continuous_on U v \<Longrightarrow> s \<in> U \<Longrightarrow> U \<subseteq> cball x e1 \<Longrightarrow> (s, v s) \<in> ball (x, y) r \<Longrightarrow> u s = v s)"
	by (rule implicit_function_theorem[OF f' S D f'C z T2 T1]; blast)

	from openE[OF blinfun_inverse_open f'I] obtain d where d:
	"0 < d" "ball (f' (x, y) o\<^sub>L embed2_blinfun) d \<subseteq> invertibles_blinfun"
	by auto
	note [continuous_intros] = continuous_at_compose[OF _ f'Cg, unfolded o_def]
	from \<open>continuous_on _ u\<close>
	have "continuous_on (ball x e1) u" by (rule continuous_on_subset) auto
	then have "\<And>s. s \<in> ball x e1 \<Longrightarrow> isCont u s"
	unfolding continuous_on_eq_continuous_at[OF open_ball] by auto
	note [continuous_intros] = continuous_at_compose[OF _ this, unfolded o_def]
	from assms have f'Ce: "isCont (\<lambda>s. f' (s, u s) o\<^sub>L embed2_blinfun) x"
	by (auto simp: u intro!: continuous_intros)
	from f'Ce[unfolded isCont_def, THEN tendstoD, OF \<open>0 < d\<close>] d
	obtain e0 where "e0 > 0" "\<And>s. s \<noteq> x \<Longrightarrow> s \<in> ball x e0 \<Longrightarrow>
	(f' (s, u s) o\<^sub>L embed2_blinfun) \<in> invertibles_blinfun"
	by (auto simp: eventually_at dist_commute subset_iff u)
	then have e0: "s \<in> ball x e0 \<Longrightarrow> (f' (s, u s) o\<^sub>L embed2_blinfun) \<in> invertibles_blinfun" for s
	by (cases "s = x") (auto simp: f'I \<open>0 < d\<close> u)


	define e where "e = min (e0/2) (e1/2)"
	have e: "f (x, u x) = 0"
	"u x = y"
	"\<And>s. s \<in> cball x e \<Longrightarrow> f (s, u s) = 0"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> S"
	"e > 0"
	"(u has_derivative (- T o\<^sub>L f' (x, y) o\<^sub>L embed1_blinfun)) (at x)"
	"\<And>s. s \<in> cball x e \<Longrightarrow> f' (s, u s) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun"
	using e0 u \<open>e0 > 0\<close> by (auto simp: e_def intro: continuous_on_subset)

	from u(4) have "continuous_on (ball x e1) u"
	apply (rule continuous_on_subset)
	using \<open>e1 > 0\<close>
	by (auto simp: e_def)
	then have "\<And>s. s \<in> cball x e \<Longrightarrow> isCont u s"
	using \<open>e0 > 0\<close> \<open>e1 > 0\<close>
	unfolding continuous_on_eq_continuous_at[OF open_ball] by (auto simp: e_def Ball_def dist_commute)
	note [continuous_intros] = continuous_at_compose[OF _ this, unfolded o_def]

	have "u s = v s"
	if solves: "(\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0)"
	and i: "u x = v x"
	and v: "continuous_on U v"
	and s: "s \<in> U" and U: "x \<in> U" "U \<subseteq> cball x e" "connected U" "open U"
	for U v s
	proof -
	define M where "M = {s \<in> U. u s = v s}"
	have "x \<in> M" using i U by (auto simp: M_def)
	moreover
	have "continuous_on U (\<lambda>s. u s - v s)"
	by (auto intro!: continuous_intros v continuous_on_subset[OF e(4) U(2)])
	from continuous_closedin_preimage[OF this closed_singleton[where a=0]]
	have "closedin (top_of_set U) M"
	by (auto simp: M_def vimage_def Collect_conj_eq)
	moreover
	have "\<And>s. s \<in> U \<Longrightarrow> isCont v s"
	using v
	unfolding continuous_on_eq_continuous_at[OF \<open>open U\<close>] by auto
	note [continuous_intros] = continuous_at_compose[OF _ this, unfolded o_def]
	{
	fix a assume "a \<in> M"
	then have aU: "a \<in> U" and u_v: "u a = v a"
	by (auto simp: M_def)
	then have a_ball: "a \<in> cball x e" and a_dist: "dist x a \<le> e" using U by auto
	then have a_S: "(a, u a) \<in> S"
	using e by auto
	have fa_z: "f (a, u a) = 0"
	using \<open>a \<in> cball x e\<close> by (auto intro!: e)
	from e(8)[OF \<open>a \<in> cball _ _\<close>]
	obtain Ta where Ta: "Ta o\<^sub>L (f' (a, u a) o\<^sub>L embed2_blinfun) = 1\<^sub>L" "f' (a, u a) o\<^sub>L embed2_blinfun o\<^sub>L Ta = 1\<^sub>L"
	by (auto simp: invertibles_blinfun_def ac_simps)
	obtain u' e' r'
	where "r' > 0" "e' > 0"
	and u': "\<And>v s U. v a = u a \<Longrightarrow>
	(\<And>s. s \<in> U \<Longrightarrow> f (s, v s) = 0) \<Longrightarrow>
	continuous_on U v \<Longrightarrow> s \<in> U \<Longrightarrow> U \<subseteq> cball a e' \<Longrightarrow> (s, v s) \<in> ball (a, u a) r' \<Longrightarrow> u' s = v s"
	by (rule implicit_function_theorem[OF f' a_S \<open>open S\<close> D f'Cg[OF a_S] fa_z Ta]; blast)
	from openE[OF \<open>open U\<close> aU] obtain dU where dU: "dU > 0" "\<And>s. s \<in> ball a dU \<Longrightarrow> s \<in> U"
	by (auto simp: dist_commute subset_iff)

	have v_tendsto: "((\<lambda>s. (s, v s)) \<longlongrightarrow> (a, u a)) (at a)"
	unfolding u_v
	by (subst continuous_at[symmetric]) (auto intro!: continuous_intros aU)
	from tendstoD[OF v_tendsto \<open>0 < r'\<close>, unfolded eventually_at]
	obtain dv where "dv > 0" "s \<noteq> a \<Longrightarrow> dist s a < dv \<Longrightarrow> (s, v s) \<in> ball (a, u a) r'" for s
	by (auto simp: dist_commute)
	then have dv: "dist s a < dv \<Longrightarrow> (s, v s) \<in> ball (a, u a) r'" for s
	by (cases "s = a") (auto simp: u_v \<open>0 < r'\<close>)

	have v_tendsto: "((\<lambda>s. (s, u s)) \<longlongrightarrow> (a, u a)) (at a)"
	using a_dist
	by (subst continuous_at[symmetric]) (auto intro!: continuous_intros)
	from tendstoD[OF v_tendsto \<open>0 < r'\<close>, unfolded eventually_at]
	obtain du where "du > 0" "s \<noteq> a \<Longrightarrow> dist s a < du \<Longrightarrow> (s, u s) \<in> ball (a, u a) r'" for s
	by (auto simp: dist_commute)
	then have du: "dist s a < du \<Longrightarrow> (s, u s) \<in> ball (a, u a) r'" for s
	by (cases "s = a") (auto simp: u_v \<open>0 < r'\<close>)
	{
	fix s assume s: "s \<in> ball a (Min {dU, e', dv, du})"
	let ?U = "ball a (Min {dU, e', dv, du})"
	have balls: "ball a (Min {dU, e', dv, du}) \<subseteq> cball a e'" by auto
	have dsadv: "dist s a < dv"
	using s by (auto simp: dist_commute)
	have dsadu: "dist s a < du"
	using s by (auto simp: dist_commute)
	have U_U: "\<And>s. s \<in> ball a (Min {dU, e', dv, du}) \<Longrightarrow> s \<in> U"
	using dU by auto
	have U_e: "\<And>s. s \<in> ball a (Min {dU, e', dv, du}) \<Longrightarrow> s \<in> cball x e"
	using dU U by (auto simp: dist_commute subset_iff)
	have cv: "continuous_on ?U v"
	using v
	apply (rule continuous_on_subset)
	using dU
	by auto
	have cu: "continuous_on ?U u"
	using e(4)
	apply (rule continuous_on_subset)
	using dU U(2)
	by auto
	from u'[where v=v, OF u_v[symmetric] solves[OF U_U] cv s balls dv[OF dsadv]]
	u'[where v=u, OF refl e(3)[OF U_e] cu s balls du[OF dsadu]]
	have "v s = u s" by auto
	} then have "\<exists>dv>0. \<forall>s \<in> ball a dv. v s = u s"
	using \<open>0 < dU\<close> \<open>0 < e'\<close> \<open>0 < dv\<close> \<open>0 < du\<close>
	by (auto intro!: exI[where x="(Min {dU, e', dv, du})"])
	} note ex = this
	have "openin (top_of_set U) M"
	unfolding openin_contains_ball
	apply (rule conjI)
	subgoal using U by (auto simp: M_def)
	apply (auto simp:)
	apply (drule ex)
	apply auto
	subgoal for x d
	by (rule exI[where x=d]) (auto simp: M_def)
	done
	ultimately have "M = U"
	using \<open>connected U\<close>
	by (auto simp: connected_clopen)
	with \<open>s \<in> U\<close> show ?thesis by (auto simp: M_def)
	qed
	from e this
	show ?thesis ..
	qed

	lemma uniform_limit_compose:
	assumes ul: "uniform_limit T f l F"
	assumes uc: "uniformly_continuous_on S s"
	assumes ev: "\<forall>\<^sub>F x in F. f x ` T \<subseteq> S"
	assumes subs: "l ` T \<subseteq> S"
	shows "uniform_limit T (\<lambda>i x. s (f i x)) (\<lambda>x. s (l x)) F"
	proof (rule uniform_limitI)
	fix e::real assume "e > 0"
	from uniformly_continuous_onE[OF uc \<open>e > 0\<close>]
	obtain d where d: "0 < d" "\<And>t t'. t \<in> S \<Longrightarrow> t' \<in> S \<Longrightarrow> dist t' t < d \<Longrightarrow> dist (s t') (s t) < e"
	by auto
	from uniform_limitD[OF ul \<open>0 < d\<close>] have "\<forall>\<^sub>F n in F. \<forall>x\<in>T. dist (f n x) (l x) < d" .
	then show "\<forall>\<^sub>F n in F. \<forall>x\<in>T. dist (s (f n x)) (s (l x)) < e"
	using ev
	by eventually_elim (use d subs in force)
	qed

	lemma
	uniform_limit_in_open:
	fixes l::"'a::topological_space\<Rightarrow>'b::heine_borel"
	assumes ul: "uniform_limit T f l (at x)"
	assumes cont: "continuous_on T l"
	assumes compact: "compact T" and T_ne: "T \<noteq> {}"
	assumes B: "open B"
	assumes mem: "l ` T \<subseteq> B"
	shows "\<forall>\<^sub>F y in at x. \<forall>t \<in> T. f y t \<in> B"
	proof -
	have l_ne: "l ` T \<noteq> {}" using T_ne by auto
	have "compact (l ` T)"
	by (auto intro!: compact_continuous_image cont compact)
	from compact_in_open_separated[OF l_ne this B mem]
	obtain e where "e > 0" "{x. infdist x (l ` T) \<le> e} \<subseteq> B"
	by auto
	from uniform_limitD[OF ul \<open>0 < e\<close>]
	have "\<forall>\<^sub>F n in at x. \<forall>x\<in>T. dist (f n x) (l x) < e" .
	then show ?thesis
	proof eventually_elim
	case (elim y)
	show ?case
	proof safe
	fix t assume "t \<in> T"
	have "infdist (f y t) (l ` T) \<le> dist (f y t) (l t)"
	by (rule infdist_le) (use \<open>t \<in> T\<close> in auto)
	also have "\<dots> < e" using elim \<open>t \<in> T\<close> by auto
	finally have "infdist (f y t) (l ` T) \<le> e" by simp
	then have "(f y t) \<in> {x. infdist x (l ` T) \<le> e}"
	by (auto )
	also note \<open>\<dots> \<subseteq> B\<close>
	finally show "f y t \<in> B" .
	qed
	qed
	qed

	lemma
	order_uniform_limitD1:
	fixes l::"'a::topological_space\<Rightarrow>real"\<comment> \<open>TODO: generalize?!\<close>
	assumes ul: "uniform_limit T f l (at x)"
	assumes cont: "continuous_on T l"
	assumes compact: "compact T"
	assumes less: "\<And>t. t \<in> T \<Longrightarrow> l t < b"
	shows "\<forall>\<^sub>F y in at x. \<forall>t \<in> T. f y t < b"
	proof cases
	assume ne: "T \<noteq> {}"
	from compact_attains_sup[OF compact_continuous_image[OF cont compact], unfolded image_is_empty, OF ne]
	obtain tmax where tmax: "tmax \<in> T" "\<And>s. s \<in> T \<Longrightarrow> l s \<le> l tmax"
	by auto
	have "b - l tmax > 0"
	using ne tmax less by auto
	from uniform_limitD[OF ul this]
	have "\<forall>\<^sub>F n in at x. \<forall>x\<in>T. dist (f n x) (l x) < b - l tmax"
	by auto
	then show ?thesis
	apply eventually_elim
	using tmax
	by (force simp: dist_real_def abs_real_def split: if_splits)
	qed auto

	lemma
	order_uniform_limitD2:
	fixes l::"'a::topological_space\<Rightarrow>real"\<comment> \<open>TODO: generalize?!\<close>
	assumes ul: "uniform_limit T f l (at x)"
	assumes cont: "continuous_on T l"
	assumes compact: "compact T"
	assumes less: "\<And>t. t \<in> T \<Longrightarrow> l t > b"
	shows "\<forall>\<^sub>F y in at x. \<forall>t \<in> T. f y t > b"
	proof -
	have "\<forall>\<^sub>F y in at x. \<forall>t\<in>T. (- f) y t < - b"
	by (rule order_uniform_limitD1[of "- f" T "-l" x "- b"])
	(auto simp: assms fun_Compl_def intro!: uniform_limit_eq_intros continuous_intros)
	then show ?thesis by auto
	qed

	lemma continuous_on_avoid_cases:
	fixes l::"'b::topological_space \<Rightarrow> 'a::linear_continuum_topology"\<comment> \<open>TODO: generalize!\<close>
	assumes cont: "continuous_on T l" and conn: "connected T"
	assumes avoid: "\<And>t. t \<in> T \<Longrightarrow> l t \<noteq> b"
	obtains "\<And>t. t \<in> T \<Longrightarrow> l t < b" \| "\<And>t. t \<in> T \<Longrightarrow> l t > b"
	apply atomize_elim
	using connected_continuous_image[OF cont conn] using avoid
	unfolding connected_iff_interval
	apply (auto simp: image_iff)
	using leI by blast

	lemma
	order_uniform_limit_ne:
	fixes l::"'a::topological_space\<Rightarrow>real"\<comment> \<open>TODO: generalize?!\<close>
	assumes ul: "uniform_limit T f l (at x)"
	assumes cont: "continuous_on T l"
	assumes compact: "compact T" and conn: "connected T"
	assumes ne: "\<And>t. t \<in> T \<Longrightarrow> l t \<noteq> b"
	shows "\<forall>\<^sub>F y in at x. \<forall>t \<in> T. f y t \<noteq> b"
	proof -
	from continuous_on_avoid_cases[OF cont conn ne]
	consider "(\<And>t. t \<in> T \<Longrightarrow> l t < b)" \| "(\<And>t. t \<in> T \<Longrightarrow> l t > b)"
	by blast
	then show ?thesis
	proof cases
	case 1
	from order_uniform_limitD1[OF ul cont compact 1]
	have "\<forall>\<^sub>F y in at x. \<forall>t\<in>T. f y t < b" by simp
	then show ?thesis
	by eventually_elim auto
	next
	case 2
	from order_uniform_limitD2[OF ul cont compact 2]
	have "\<forall>\<^sub>F y in at x. \<forall>t\<in>T. f y t > b" by simp
	then show ?thesis
	by eventually_elim auto
	qed
	qed

	lemma open_cballE:
	assumes "open S" "x\<in>S"
	obtains e where "e>0" "cball x e \<subseteq> S"
	using assms unfolding open_contains_cball by auto

	lemma pos_half_less: fixes x::real shows "x > 0 \<Longrightarrow> x / 2 < x"
	by auto

	lemma closed_levelset: "closed {x. s x = (c::'a::t1_space)}" if "continuous_on UNIV s"
	proof -
	have "{x. s x = c} = s -` {c}" by auto
	also have "closed \<dots>"
	apply (rule closed_vimage)
	apply (rule closed_singleton)
	apply (rule that)
	done
	finally show ?thesis .
	qed

	lemma closed_levelset_within: "closed {x \<in> S. s x = (c::'a::t1_space)}" if "continuous_on S s" "closed S"
	proof -
	have "{x \<in> S. s x = c} = s -` {c} \<inter> S" by auto
	also have "closed \<dots>"
	apply (rule continuous_on_closed_vimageI)
	apply (rule that)
	apply (rule that)
	apply simp
	done
	finally show ?thesis .
	qed

	context c1_on_open_euclidean
	begin

	lemma open_existence_ivlE:
	assumes "t \<in> existence_ivl0 x" "t \<ge> 0"
	obtains e where "e > 0" "cball x e \<times> {0 .. t + e} \<subseteq> Sigma X existence_ivl0"
	proof -
	from assms have "(x, t) \<in> Sigma X existence_ivl0"
	by auto
	from open_cballE[OF open_state_space this]
	obtain e0' where e0: "0 < e0'" "cball (x, t) e0' \<subseteq> Sigma X existence_ivl0"
	by auto
	define e0 where "e0 = (e0' / 2)"
	from cball_times_subset[of x e0' t] pos_half_less[OF \<open>0 < e0'\<close>] half_gt_zero[OF \<open>0 < e0'\<close>] e0
	have "cball x e0 \<times> cball t e0 \<subseteq> Sigma X existence_ivl0" "0 < e0" "e0 < e0'"
	unfolding e0_def by auto
	then have "e0 > 0" "cball x e0 \<times> {0..t + e0} \<subseteq> Sigma X existence_ivl0"
	apply (auto simp: subset_iff dest!: spec[where x=t])
	subgoal for a b
	apply (rule in_existence_between_zeroI)
	apply (drule spec[where x=a])
	apply (drule spec[where x="t + e0"])
	apply (auto simp: dist_real_def closed_segment_eq_real_ivl)
	done
	done
	then show ?thesis ..
	qed

	lemmas [derivative_intros] = flow0_comp_has_derivative

	lemma flow_isCont_state_space_comp[continuous_intros]:
	"t x \<in> existence_ivl0 (s x) \<Longrightarrow> isCont s x \<Longrightarrow> isCont t x \<Longrightarrow> isCont (\<lambda>x. flow0 (s x) (t x)) x"
	using continuous_within_compose3[where g="\<lambda>(x, t). flow0 x t"
	and f="\<lambda>x. (s x, t x)" and x = x and s = UNIV]
	flow_isCont_state_space
	by auto

	lemma closed_plane[simp]: "closed {x. x \<bullet> i = c}"
	using closed_hyperplane[of i c] by (auto simp: inner_commute)

	lemma flow_tendsto_compose[tendsto_intros]:
	assumes "(x \<longlongrightarrow> xs) F" "(t \<longlongrightarrow> ts) F"
	assumes "ts \<in> existence_ivl0 xs"
	shows "((\<lambda>s. flow0 (x s) (t s)) \<longlongrightarrow> flow0 xs ts) F"
	proof -
	have ev: "\<forall>\<^sub>F s in F. (x s, t s) \<in> Sigma X existence_ivl0"
	using tendsto_Pair[OF assms(1,2), THEN topological_tendstoD, OF open_state_space]
	assms
	by auto
	show ?thesis
	by (rule continuous_on_tendsto_compose[OF flow_continuous_on_state_space tendsto_Pair, unfolded split_beta' fst_conv snd_conv])
	(use assms ev in auto)
	qed

	lemma returns_to_implicit_function:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P x")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "isCont Ds (poincare_map ?P x)"
	assumes nz: "Ds (poincare_map ?P x) (f (poincare_map ?P x)) \<noteq> 0"
	obtains u e
	where "s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>y. y \<in> cball x e \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> Sigma X existence_ivl0"
	"0 < e" "(u has_derivative (- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L flowderiv x (return_time ?P x)) o\<^sub>L embed1_blinfun)) (at x)"
	proof -
	note [derivative_intros] = has_derivative_compose[OF _ Ds]
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	note cls[simp, intro] = closed_levelset[OF cont_s]
	let ?t1 = "return_time ?P x"
	have cls[simp, intro]: "closed {x \<in> S. s x = 0}"
	by (rule closed_levelset_within) (auto intro!: cS continuous_on_subset[OF cont_s])
	then have xt1: "(x, ?t1) \<in> Sigma X existence_ivl0"
	by (auto intro!: return_time_exivl rt)
	have D: "(\<And>x. x \<in> Sigma X existence_ivl0 \<Longrightarrow>
	((\<lambda>(x, t). s (flow0 x t)) has_derivative
	blinfun_apply (Ds (flow0 (fst x) (snd x)) o\<^sub>L (flowderiv (fst x) (snd x))))
	(at x))"
	by (auto intro!: derivative_eq_intros)
	have C: "isCont (\<lambda>x. Ds (flow0 (fst x) (snd x)) o\<^sub>L flowderiv (fst x) (snd x))
	(x, ?t1)"
	using flowderiv_continuous_on[unfolded continuous_on_eq_continuous_within,
	rule_format, OF xt1]
	using at_within_open[OF xt1 open_state_space]
	by (auto intro!: continuous_intros tendsto_eq_intros return_time_exivl rt
	isCont_tendsto_compose[OF DsC, unfolded poincare_map_def]
	simp: split_beta' isCont_def)
	from return_time_returns[OF rt cls]
	have Z: "(case (x, ?t1) of (x, t) \<Rightarrow> s (flow0 x t)) = 0"
	- by (auto simp: )
	+ by auto
	have I1: "blinfun_scaleR_left (inverse (Ds (flow0 x (?t1))(f (flow0 x (?t1))))) o\<^sub>L
	((Ds (flow0 (fst (x, return_time {x \<in> S. s x = 0} x))
	(snd (x, return_time {x \<in> S. s x = 0} x))) o\<^sub>L
	flowderiv (fst (x, return_time {x \<in> S. s x = 0} x))
	(snd (x, return_time {x \<in> S. s x = 0} x))) o\<^sub>L
	embed2_blinfun)
	= 1\<^sub>L"
	using nz
	by (auto intro!: blinfun_eqI
	simp: rt flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	have I2: "((Ds (flow0 (fst (x, return_time {x \<in> S. s x = 0} x))
	(snd (x, return_time {x \<in> S. s x = 0} x))) o\<^sub>L
	flowderiv (fst (x, return_time {x \<in> S. s x = 0} x))
	(snd (x, return_time {x \<in> S. s x = 0} x))) o\<^sub>L
	embed2_blinfun) o\<^sub>L blinfun_scaleR_left (inverse (Ds (flow0 x (?t1))(f (flow0 x (?t1)))))
	= 1\<^sub>L"
	using nz
	by (auto intro!: blinfun_eqI
	simp: rt flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	show ?thesis
	apply (rule implicit_function_theorem[where f="\<lambda>(x, t). s (flow0 x t)"
	and S="Sigma X existence_ivl0", OF D xt1 open_state_space order_refl C Z I1 I2])
	apply blast
	unfolding split_beta' fst_conv snd_conv poincare_map_def[symmetric]
	..
	qed

	lemma (in auto_ll_on_open) f_tendsto[tendsto_intros]:
	assumes g1: "(g1 \<longlongrightarrow> b1) (at s within S)" and "b1 \<in> X"
	shows "((\<lambda>x. f (g1 x)) \<longlongrightarrow> f b1) (at s within S)"
	apply (rule continuous_on_tendsto_compose[OF continuous tendsto_Pair[OF tendsto_const],
	unfolded split_beta fst_conv snd_conv, OF g1])
	by (auto simp: \<open>b1 \<in> X\<close> intro!: topological_tendstoD[OF g1])

	lemma flow_avoids_surface_eventually_at_right_pos:
	assumes "s x > 0 \<or> s x = 0 \<and> blinfun_apply (Ds x) (f x) > 0"
	assumes x: "x \<in> X"
	assumes Ds: "\<And>x. (s has_derivative Ds x) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	shows "\<forall>\<^sub>F t in at_right 0. s (flow0 x t) > (0::real)"
	proof -
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	then have [THEN continuous_on_compose2, continuous_intros]: "continuous_on S s" for S by (rule continuous_on_subset) simp
	note [derivative_intros] = has_derivative_compose[OF _ Ds]
	note [tendsto_intros] = continuous_on_tendsto_compose[OF cont_s]
	isCont_tendsto_compose[OF DsC]
	from assms(1)
	consider "s x > 0" \| "s x = 0" "blinfun_apply (Ds x) (f x) > 0"
	by auto
	then show ?thesis
	proof cases
	assume s: "s x > 0"
	then have "((\<lambda>t. s (flow0 x t)) \<longlongrightarrow> s x) (at_right 0)"
	by (auto intro!: tendsto_eq_intros simp: split_beta' x)
	from order_tendstoD(1)[OF this s]
	show ?thesis .
	next
	assume sz: "s x = 0" and pos: "blinfun_apply (Ds x) (f x) > 0"
	from x have "0 \<in> existence_ivl0 x" "open (existence_ivl0 x)" by simp_all
	then have evex: "\<forall>\<^sub>F t in at_right 0. t \<in> existence_ivl0 x"
	using eventually_at_topological by blast
	moreover
	from evex have "\<forall>\<^sub>F xa in at_right 0. flow0 x xa \<in> X"
	by (eventually_elim) (auto intro!: )
	then have "((\<lambda>t. (Ds (flow0 x t)) (f (flow0 x t))) \<longlongrightarrow> blinfun_apply (Ds x) (f x)) (at_right 0)"
	by (auto intro!: tendsto_eq_intros simp: split_beta' x)
	from order_tendstoD(1)[OF this pos]
	have "\<forall>\<^sub>F z in at_right 0. blinfun_apply (Ds (flow0 x z)) (f (flow0 x z)) > 0" .
	then obtain t where t: "t > 0" "\<And>z. 0 < z \<Longrightarrow> z < t \<Longrightarrow> blinfun_apply (Ds (flow0 x z)) (f (flow0 x z)) > 0"
	by (auto simp: eventually_at)
	have "\<forall>\<^sub>F z in at_right 0. z < t" using \<open>t > 0\<close> order_tendstoD(2)[OF tendsto_ident_at \<open>0 < t\<close>] by auto
	moreover have "\<forall>\<^sub>F z in at_right 0. 0 < z" by (simp add: eventually_at_filter)
	ultimately show ?thesis
	proof eventually_elim
	case (elim z)
	from closed_segment_subset_existence_ivl[OF \<open>z \<in> existence_ivl0 x\<close>]
	have csi: "{0..z} \<subseteq> existence_ivl0 x" by (auto simp add: closed_segment_eq_real_ivl)
	then have cont: "continuous_on {0..z} (\<lambda>t. s (flow0 x t))"
	by (auto intro!: continuous_intros)
	have "\<And>u. \<lbrakk>0 < u; u < z\<rbrakk> \<Longrightarrow> ((\<lambda>t. s (flow0 x t)) has_derivative (\<lambda>t. t * blinfun_apply (Ds (flow0 x u)) (f (flow0 x u)))) (at u)"
	using csi
	by (auto intro!: derivative_eq_intros simp: flowderiv_def blinfun.bilinear_simps)
	from mvt[OF \<open>0 < z\<close> cont this]
	obtain w where w: "0 < w" "w < z" and sDs: "s (flow0 x z) = z * blinfun_apply (Ds (flow0 x w)) (f (flow0 x w))"
	using x sz
	by auto
	note sDs
	also have "\<dots> > 0"
	using elim t(2)[of w] w by simp
	finally show ?case .
	qed
	qed
	qed

	lemma flow_avoids_surface_eventually_at_right_neg:
	assumes "s x < 0 \<or> s x = 0 \<and> blinfun_apply (Ds x) (f x) < 0"
	assumes x: "x \<in> X"
	assumes Ds: "\<And>x. (s has_derivative Ds x) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	shows "\<forall>\<^sub>F t in at_right 0. s (flow0 x t) < (0::real)"
	apply (rule flow_avoids_surface_eventually_at_right_pos[of "-s" x "-Ds", simplified])
	using assms
	by (auto intro!: derivative_eq_intros simp: blinfun.bilinear_simps fun_Compl_def)

	lemma flow_avoids_surface_eventually_at_right:
	assumes "x \<notin> S \<or> s x \<noteq> 0 \<or> blinfun_apply (Ds x) (f x) \<noteq> 0"
	assumes x: "x \<in> X" and cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative Ds x) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	shows "\<forall>\<^sub>F t in at_right 0. (flow0 x t) \<notin> {x \<in> S. s x = (0::real)}"
	proof -
	from assms(1)
	consider
	"s x > 0 \<or> s x = 0 \<and> blinfun_apply (Ds x) (f x) > 0"
	\| "s x < 0 \<or> s x = 0 \<and> blinfun_apply (Ds x) (f x) < 0"
	\| "x \<notin> S"
	by arith
	then show ?thesis
	proof cases
	case 1
	from flow_avoids_surface_eventually_at_right_pos[of s x Ds, OF 1 x Ds DsC]
	show ?thesis by eventually_elim auto
	next
	case 2
	from flow_avoids_surface_eventually_at_right_neg[of s x Ds, OF 2 x Ds DsC]
	show ?thesis by eventually_elim auto
	next
	case 3
	then have nS: "open (- S)" "x \<in> - S" using cS by auto
	have "\<forall>\<^sub>F t in at_right 0. (flow0 x t) \<in> - S"
	by (rule topological_tendstoD[OF _ nS]) (auto intro!: tendsto_eq_intros simp: x)
	then show ?thesis by eventually_elim auto
	qed
	qed

	lemma eventually_returns_to:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P x")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	assumes nz: "Ds (poincare_map ?P x) (f (poincare_map ?P x)) \<noteq> 0"
	assumes nz0: "x \<notin> S \<or> s x \<noteq> 0 \<or> Ds x (f x) \<noteq> 0"
	shows "\<forall>\<^sub>F x in at x. returns_to ?P x"
	proof -
	let ?t1 = "return_time ?P x"
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	have cont_s': "continuous_on S s" for S by (rule continuous_on_subset[OF cont_s subset_UNIV])
	note s_tendsto[tendsto_intros] = continuous_on_tendsto_compose[OF cont_s, THEN tendsto_eq_rhs]
	note cls[simp, intro] = closed_levelset_within[OF cont_s' cS, of 0]
	note [tendsto_intros] = continuous_on_tendsto_compose[OF cont_s]
	isCont_tendsto_compose[OF DsC]
	obtain u e
	where "s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>y. y \<in> cball x e \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> Sigma X existence_ivl0"
	"0 < e"
	by (rule returns_to_implicit_function[OF rt cS Ds DsC nz]; blast)
	then have u:
	"s (flow0 x (u x)) = 0" "u x = ?t1"
	"(\<And>y. y \<in> cball x e \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x e) u"
	"\<And>z. z \<in> cball x e \<Longrightarrow> u z \<in> existence_ivl0 z"
	"e > 0"
	by (force simp: split_beta')+
	have "\<forall>\<^sub>F y in at x. y \<in> ball x e"
	using eventually_at_ball[OF \<open>0 < e\<close>]
	by eventually_elim auto
	then have ev_cball: "\<forall>\<^sub>F y in at x. y \<in> cball x e"
	by eventually_elim (use \<open>e > 0\<close> in auto)
	moreover
	have "continuous_on (ball x e) u"
	using u by (auto simp: continuous_on_subset)
	then have [tendsto_intros]: "(u \<longlongrightarrow> u x) (at x)"
	using \<open>e > 0\<close> at_within_open[of y "ball x e" for y]
	by (auto simp: continuous_on_def)
	then have flow0_u_tendsto: "(\<lambda>x. flow0 x (u x)) \<midarrow>x\<rightarrow> poincare_map ?P x"
	by (auto intro!: tendsto_eq_intros u return_time_exivl rt simp: poincare_map_def)
	have s_imp: "s (poincare_map {x \<in> S. s x = 0} x) = 0 \<longrightarrow> poincare_map {x \<in> S. s x = 0} x \<in> S"
	using poincare_map_returns[OF rt]
	by auto
	from eventually_tendsto_compose_within[OF eventually_inside s_imp flow0_u_tendsto]
	have "\<forall>\<^sub>F x in at x. s (flow0 x (u x)) = 0 \<longrightarrow> flow0 x (u x) \<in> S" by auto
	with ev_cball
	have "\<forall>\<^sub>F x in at x. flow0 x (u x) \<in> S"
	by eventually_elim (auto simp: u)
	moreover
	{
	have "x \<in> X"
	using u(5) u(6) by force
	from ev_cball
	have ev_X: "\<forall>\<^sub>F y in at x. y \<in> X"\<comment> \<open>eigentlich ist das \<open>open X\<close>\<close>
	apply eventually_elim
	apply (rule)
	by (rule u)
	moreover
	{
	{
	assume a: "x \<notin> S" then have "open (-S)" "x \<in> - S" using cS by auto
	from topological_tendstoD[OF tendsto_ident_at this]
	have "(\<forall>\<^sub>F y in at x. y \<notin> S)" by auto
	} moreover {
	assume a: "s x \<noteq> 0"
	have "(\<forall>\<^sub>F y in at x. s y \<noteq> 0)"
	by (rule tendsto_imp_eventually_ne[OF _ a]) (auto intro!: tendsto_eq_intros)
	} moreover {
	assume a: "(Ds x) (f x) \<noteq> 0"
	have "(\<forall>\<^sub>F y in at x. blinfun_apply (Ds y) (f y) \<noteq> 0)"
	by (rule tendsto_imp_eventually_ne[OF _ a]) (auto intro!: tendsto_eq_intros ev_X \<open>x \<in> X\<close>)
	} ultimately have "(\<forall>\<^sub>F y in at x. y \<notin> S) \<or> (\<forall>\<^sub>F y in at x. s y \<noteq> 0) \<or> (\<forall>\<^sub>F y in at x. blinfun_apply (Ds y) (f y) \<noteq> 0)"
	using nz0 by auto
	then have "\<forall>\<^sub>F y in at x. y \<notin> S \<or> s y \<noteq> 0 \<or> blinfun_apply (Ds y) (f y) \<noteq> 0"
	apply -
	apply (erule disjE)
	subgoal by (rule eventually_elim2, assumption, assumption, blast)
	subgoal
	apply (erule disjE)
	subgoal by (rule eventually_elim2, assumption, assumption, blast)
	subgoal by (rule eventually_elim2, assumption, assumption, blast)
	done
	done
	}
	ultimately
	have "\<forall>\<^sub>F y in at x. (y \<notin> S \<or> s y \<noteq> 0 \<or> blinfun_apply (Ds y) (f y) \<noteq> 0) \<and> y \<in> X"
	by eventually_elim auto
	}
	then have "\<forall>\<^sub>F y in at x. \<forall>\<^sub>F t in at_right 0. flow0 y t \<notin> {x \<in> S. s x = 0}"
	apply eventually_elim
	by (rule flow_avoids_surface_eventually_at_right[where Ds=Ds]) (auto intro!: Ds DsC cS)
	moreover
	have at_eq: "(at x within cball x e) = at x"
	apply (rule at_within_interior)
	apply (auto simp: \<open>e > 0\<close>)
	done
	have "u x > 0"
	using u(1) by (auto simp: u rt cont_s' intro!: return_time_pos closed_levelset_within cS)
	then have "\<forall>\<^sub>F y in at x. u y > 0"
	apply (rule order_tendstoD[rotated])
	using u(4)
	apply (auto simp: continuous_on_def)
	apply (drule bspec[where x=x])
	using \<open>e > 0\<close>
	by (auto simp: at_eq)
	ultimately
	show "\<forall>\<^sub>F y in at x. returns_to ?P y"
	apply eventually_elim
	subgoal premises prems for y
	apply (rule returns_toI[where t="u y"])
	subgoal using prems by auto
	subgoal apply (rule u) apply (rule prems) done
	subgoal using u(3)[of y] prems by auto
	subgoal using prems(3) by eventually_elim auto
	subgoal by simp
	done
	done
	qed

	lemma
	return_time_isCont_outside:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P x")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	assumes through: "(Ds (poincare_map ?P x)) (f (poincare_map ?P x)) \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> s x \<noteq> 0"
	shows "isCont (return_time ?P) x"
	unfolding isCont_def
	proof (rule tendstoI)
	fix e_orig::real assume "e_orig > 0"
	define e where "e = e_orig / 2"
	have "e > 0" using \<open>e_orig > 0\<close> by (simp add: e_def)

	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	then have s_tendsto: "(s \<longlongrightarrow> s x) (at x)" for x
	by (auto simp: continuous_on_def)
	have cont_s': "continuous_on S s" by (rule continuous_on_subset[OF cont_s subset_UNIV])
	note cls[simp, intro] = closed_levelset_within[OF cont_s' cS(1)]
	have "{x. s x = 0} = s -` {0}" by auto
	have ret_exivl: "return_time ?P x \<in> existence_ivl0 x"
	by (rule return_time_exivl; fact)
	then have [intro, simp]: "x \<in> X" by auto
	have isCont_Ds_f: "isCont (\<lambda>s. Ds s (f s)) (poincare_map ?P x)"
	apply (auto intro!: continuous_intros DsC)
	apply (rule has_derivative_continuous)
	apply (rule derivative_rhs)
	by (auto simp: poincare_map_def intro!: flow_in_domain return_time_exivl assms)

	obtain u eu where u:
	"s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>y. y \<in> cball x eu \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x eu) u"
	"(\<lambda>t. (t, u t)) ` cball x eu \<subseteq> Sigma X existence_ivl0"
	"0 < eu"
	by (rule returns_to_implicit_function[OF rt cS(1) Ds DsC through]; blast)
	have u_tendsto: "(u \<longlongrightarrow> u x) (at x)"
	unfolding isCont_def[symmetric]
	apply (rule continuous_on_interior[OF u(4)])
	using \<open>0 < eu\<close> by auto
	have "u x > 0" by (auto simp: u intro!: return_time_pos rt)
	from order_tendstoD(1)[OF u_tendsto this] have "\<forall>\<^sub>F x in at x. 0 < u x" .
	moreover have "\<forall>\<^sub>F y in at x. y \<in> cball x eu"
	using eventually_at_ball[OF \<open>0 < eu\<close>, of x]
	by eventually_elim auto
	moreover
	have "x \<notin> S \<or> s x \<noteq> 0 \<or> blinfun_apply (Ds x) (f x) \<noteq> 0" using outside by auto
	have returns: "\<forall>\<^sub>F y in at x. returns_to ?P y"
	by (rule eventually_returns_to; fact)
	moreover
	have "\<forall>\<^sub>F y in at x. y \<in> ball x eu"
	using eventually_at_ball[OF \<open>0 < eu\<close>]
	by eventually_elim simp
	then have ev_cball: "\<forall>\<^sub>F y in at x. y \<in> cball x eu"
	by eventually_elim (use \<open>e > 0\<close> in auto)
	have "continuous_on (ball x eu) u"
	using u by (auto simp: continuous_on_subset)
	then have [tendsto_intros]: "(u \<longlongrightarrow> u x) (at x)"
	using \<open>eu > 0\<close> at_within_open[of y "ball x eu" for y]
	by (auto simp: continuous_on_def)
	then have flow0_u_tendsto: "(\<lambda>x. flow0 x (u x)) \<midarrow>x\<rightarrow> poincare_map ?P x"
	by (auto intro!: tendsto_eq_intros u return_time_exivl rt simp: poincare_map_def)
	have s_imp: "s (poincare_map {x \<in> S. s x = 0} x) = 0 \<longrightarrow> poincare_map {x \<in> S. s x = 0} x \<in> S"
	using poincare_map_returns[OF rt]
	by auto
	from eventually_tendsto_compose_within[OF eventually_inside s_imp flow0_u_tendsto]
	have "\<forall>\<^sub>F x in at x. s (flow0 x (u x)) = 0 \<longrightarrow> flow0 x (u x) \<in> S" by auto
	with ev_cball
	have "\<forall>\<^sub>F x in at x. flow0 x (u x) \<in> S"
	by eventually_elim (auto simp: u)
	ultimately have u_returns_ge: "\<forall>\<^sub>F y in at x. returns_to ?P y \<and> return_time ?P y \<le> u y"
	proof eventually_elim
	case (elim y)
	then show ?case
	using u elim by (auto intro!: return_time_le[OF _ cls])
	qed
	moreover
	have "\<forall>\<^sub>F y in at x. u y - return_time ?P x < e"
	using tendstoD[OF u_tendsto \<open>0 < e\<close>, unfolded u] u_returns_ge
	by eventually_elim (auto simp: dist_real_def)
	moreover
	note 1 = outside
	define ml where "ml = max (return_time ?P x / 2) (return_time ?P x - e)"
	have [intro, simp, arith]: "0 < ml" "ml < return_time ?P x" "ml \<le> return_time ?P x"
	using return_time_pos[OF rt cls] \<open>0 < e\<close>
	by (auto simp: ml_def)
	have mt_in: "ml \<in> existence_ivl0 x"
	using \<open>0 < e\<close>
	by (auto intro!: mem_existence_ivl_iv_defined in_existence_between_zeroI[OF ret_exivl]
	simp: closed_segment_eq_real_ivl ml_def)
	from open_existence_ivlE[OF mt_in]
	obtain e0 where e0: "e0 > 0" "cball x e0 \<times> {0..ml + e0} \<subseteq> Sigma X existence_ivl0" (is "?D \<subseteq> _")
	by auto
	have uc: "uniformly_continuous_on ((\<lambda>(x, t). flow0 x t) ` ?D) s"
	apply (auto intro!: compact_uniformly_continuous continuous_on_subset[OF cont_s])
	apply (rule compact_continuous_image)
	apply (rule continuous_on_subset)
	apply (rule flow_continuous_on_state_space)
	apply (rule e0)
	apply (rule compact_Times)
	apply (rule compact_cball)
	apply (rule compact_Icc)
	done
	let ?T = "{0..ml}"
	have ul: "uniform_limit ?T flow0 (flow0 x) (at x)"
	using \<open>0 < e\<close>
	by (intro uniform_limit_flow)
	(auto intro!: mem_existence_ivl_iv_defined in_existence_between_zeroI[OF ret_exivl]
	simp: closed_segment_eq_real_ivl )
	have "\<forall>\<^sub>F y in at x. \<forall>t\<in>{0..ml}. flow0 y t \<in> - {x \<in> S. s x = 0}"
	apply (rule uniform_limit_in_open)
	apply (rule ul)
	apply (auto intro!: continuous_intros continuous_on_compose2[OF cont_s] simp:
	split: if_splits)
	apply (meson atLeastAtMost_iff contra_subsetD local.ivl_subset_existence_ivl mt_in)
	subgoal for t
	apply (cases "t = 0")
	subgoal using 1 by (simp)
	subgoal
	using return_time_least[OF rt cls, of t] \<open>ml < return_time {x \<in> S. s x = 0} x\<close>
	by auto
	done
	done
	then have "\<forall>\<^sub>F y in at x. return_time ?P y \<ge> return_time ?P x - e"
	using u_returns_ge
	proof eventually_elim
	case (elim y)
	have "return_time ?P x - e \<le> ml"
	by (auto simp: ml_def)
	also
	have ry: "returns_to ?P y" "return_time ?P y \<le> u y"
	using elim
	by auto
	have "ml < return_time ?P y"
	apply (rule return_time_gt[OF ry(1) cls])
	using elim
	by (auto simp: Ball_def)
	finally show ?case by simp
	qed
	ultimately
	have "\<forall>\<^sub>F y in at x. dist (return_time ?P y) (return_time ?P x) \<le> e"
	by eventually_elim (auto simp: dist_real_def abs_real_def algebra_simps)
	then show "\<forall>\<^sub>F y in at x. dist (return_time ?P y) (return_time ?P x) < e_orig"
	by eventually_elim (use \<open>e_orig > 0\<close> in \<open>auto simp: e_def\<close>)
	qed

	lemma isCont_poincare_map:
	assumes "isCont (return_time P) x"
	"returns_to P x" "closed P"
	shows "isCont (poincare_map P) x"
	unfolding poincare_map_def
	by (auto intro!: continuous_intros assms return_time_exivl)

	lemma poincare_map_tendsto:
	assumes "(return_time P \<longlongrightarrow> return_time P x) (at x within S)"
	"returns_to P x" "closed P"
	shows "(poincare_map P \<longlongrightarrow> poincare_map P x) (at x within S)"
	unfolding poincare_map_def
	by (rule tendsto_eq_intros refl assms return_time_exivl)+

	lemma
	return_time_continuous_below:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P x")
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes cS: "closed S"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	assumes DsC: "\<And>x. isCont Ds x"
	assumes through: "(Ds (poincare_map ?P x)) (f (poincare_map ?P x)) \<noteq> 0"
	assumes inside: "x \<in> S" "s x = 0" "Ds x (f x) < 0"
	shows "continuous (at x within {x. s x \<le> 0}) (return_time ?P)"
	unfolding continuous_within
	proof (rule tendstoI)
	fix e_orig::real assume "e_orig > 0"
	define e where "e = e_orig / 2"
	have "e > 0" using \<open>e_orig > 0\<close> by (simp add: e_def)

	note DsC_tendso[tendsto_intros] = isCont_tendsto_compose[OF DsC]
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	then have s_tendsto: "(s \<longlongrightarrow> s x) (at x)" for x
	by (auto simp: continuous_on_def)
	note [continuous_intros] = continuous_on_compose2[OF cont_s _ subset_UNIV]
	note [derivative_intros] = has_derivative_compose[OF _ Ds]
	have cont_s': "continuous_on S s" by (rule continuous_on_subset[OF cont_s subset_UNIV])
	note cls[simp, intro] = closed_levelset_within[OF cont_s' cS(1)]
	have "{x. s x = 0} = s -` {0}" by auto
	have ret_exivl: "return_time ?P x \<in> existence_ivl0 x"
	by (rule return_time_exivl; fact)
	then have [intro, simp]: "x \<in> X" by auto
	have isCont_Ds_f: "isCont (\<lambda>s. Ds s (f s)) (poincare_map ?P x)"
	apply (auto intro!: continuous_intros DsC)
	apply (rule has_derivative_continuous)
	apply (rule derivative_rhs)
	by (auto simp: poincare_map_def intro!: flow_in_domain return_time_exivl assms)

	have "\<forall>\<^sub>F yt in at (x, 0) within UNIV \<times> {0<..}. (Ds (flow0 (fst yt) (snd yt))) (f (flow0 (fst yt) (snd yt))) < 0"
	by (rule order_tendstoD) (auto intro!: tendsto_eq_intros inside)
	moreover
	have "(x, 0) \<in> Sigma X existence_ivl0" by auto
	from topological_tendstoD[OF tendsto_ident_at open_state_space this, of "UNIV \<times> {0<..}"]
	have "\<forall>\<^sub>F yt in at (x, 0) within UNIV \<times> {0<..}. snd yt \<in> existence_ivl0 (fst yt)"
	by eventually_elim auto
	moreover
	from topological_tendstoD[OF tendsto_ident_at open_Times[OF open_dom open_UNIV], of "(x, 0)" "UNIV \<times> {0<..}"]
	have "\<forall>\<^sub>F yt in at (x, 0) within UNIV \<times> {0<..}. fst yt \<in> X"
	by (auto simp: mem_Times_iff)
	ultimately
	have "\<forall>\<^sub>F yt in at (x, 0) within UNIV \<times> {0<..}. (Ds (flow0 (fst yt) (snd yt))) (f (flow0 (fst yt) (snd yt))) < 0 \<and>
	snd yt \<in> existence_ivl0 (fst yt) \<and>
	0 \<in> existence_ivl0 (fst yt)"
	by eventually_elim auto
	then obtain d2 where "0 < d2" and
	d2_neg: "\<And>y t. (y, t) \<in> cball (x, 0) d2 \<Longrightarrow> 0 < t \<Longrightarrow> (Ds (flow0 y t)) (f (flow0 y t)) < 0"
	and d2_ex: "\<And>y t. (y, t) \<in> cball (x, 0) d2 \<Longrightarrow> 0 < t \<Longrightarrow> t \<in> existence_ivl0 y"
	and d2_ex0: "\<And>y t. (y, t::real) \<in> cball (x, 0) d2 \<Longrightarrow> 0 < t \<Longrightarrow> y \<in> X"
	by (auto simp: eventually_at_le dist_commute)
	define d where "d \<equiv> d2 / 2"
	from \<open>0 < d2\<close> have "d > 0" by (simp add: d_def)
	have d_neg: "dist y x< d \<Longrightarrow> 0 < t \<Longrightarrow> t \<le> d \<Longrightarrow> (Ds (flow0 y t)) (f (flow0 y t)) < 0" for y t
	using d2_neg[of y t, OF subsetD[OF cball_times_subset[of x d2 0]]]
	by (auto simp: d_def dist_commute)
	have d_ex: "t \<in> existence_ivl0 y" if "dist y x< d" "0 \<le> t" "t \<le> d" for y t
	proof cases
	assume "t = 0"
	have "sqrt ((dist x y)\<^sup>2 + (d2 / 2)\<^sup>2) \<le> dist x y + d2/2"
	using \<open>0 < d2\<close>
	by (intro sqrt_sum_squares_le_sum) auto
	also have "dist x y \<le> d2 / 2"
	using that by (simp add: d_def dist_commute)
	finally have "sqrt ((dist x y)\<^sup>2 + (d2 / 2)\<^sup>2) \<le> d2" by simp
	with \<open>t = 0\<close> show ?thesis
	using d2_ex[of y t, OF subsetD[OF cball_times_subset[of x d2 0]]] d2_ex0[of y d] \<open>0 < d2\<close>
	by (auto simp: d_def dist_commute dist_prod_def)
	next
	assume "t \<noteq> 0"
	then show ?thesis
	using d2_ex[of y t, OF subsetD[OF cball_times_subset[of x d2 0]]] that
	by (auto simp: d_def dist_commute)
	qed
	have d_mvt: "s (flow0 y t) < s y" if "0 < t" "t \<le> d" "dist y x < d" for y t
	proof -
	have c: "continuous_on {0 .. t} (\<lambda>t. s (flow0 y t))"
	using that
	by (auto intro!: continuous_intros d_ex)
	have d: "\<And>x. \<lbrakk>0 < x; x < t\<rbrakk> \<Longrightarrow> ((\<lambda>t. s (flow0 y t)) has_derivative (\<lambda>t. t * blinfun_apply (Ds (flow0 y x)) (f (flow0 y x)))) (at x)"
	using that
	by (auto intro!: derivative_eq_intros d_ex simp: flowderiv_def blinfun.bilinear_simps)
	from mvt[OF \<open>0 < t\<close> c d]
	obtain xi where xi: "0 < xi" "xi < t" and "s (flow0 y t) - s (flow0 y 0) = t * blinfun_apply (Ds (flow0 y xi)) (f (flow0 y xi))"
	by auto
	note this(3)
	also have "\<dots> < 0"
	using \<open>0 < t\<close>
	apply (rule mult_pos_neg)
	apply (rule d_neg)
	using that xi by auto
	also have "flow0 y 0 = y"
	apply (rule flow_initial_time)
	apply auto
	using \<open>0 < d\<close> d_ex that(3) by fastforce
	finally show ?thesis
	- by (auto simp: )
	+ by auto
	qed
	obtain u eu where u:
	"s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>y. y \<in> cball x eu \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x eu) u"
	"(\<lambda>t. (t, u t)) ` cball x eu \<subseteq> Sigma X existence_ivl0"
	"0 < eu"
	by (rule returns_to_implicit_function[OF rt cS(1) Ds DsC through]; blast)
	have u_tendsto: "(u \<longlongrightarrow> u x) (at x)"
	unfolding isCont_def[symmetric]
	apply (rule continuous_on_interior[OF u(4)])
	using \<open>0 < eu\<close> by auto
	have "u x > 0" by (auto simp: u intro!: return_time_pos rt)
	from order_tendstoD(1)[OF u_tendsto this] have "\<forall>\<^sub>F x in at x. 0 < u x" .
	moreover have "\<forall>\<^sub>F y in at x. y \<in> cball x eu"
	using eventually_at_ball[OF \<open>0 < eu\<close>, of x]
	by eventually_elim auto
	moreover
	have "x \<notin> S \<or> s x \<noteq> 0 \<or> blinfun_apply (Ds x) (f x) \<noteq> 0" using inside by auto
	have returns: "\<forall>\<^sub>F y in at x. returns_to ?P y"
	by (rule eventually_returns_to; fact)
	moreover
	have "\<forall>\<^sub>F y in at x. y \<in> ball x eu"
	using eventually_at_ball[OF \<open>0 < eu\<close>]
	by eventually_elim simp
	then have ev_cball: "\<forall>\<^sub>F y in at x. y \<in> cball x eu"
	by eventually_elim (use \<open>e > 0\<close> in auto)
	have "continuous_on (ball x eu) u"
	using u by (auto simp: continuous_on_subset)
	then have [tendsto_intros]: "(u \<longlongrightarrow> u x) (at x)"
	using \<open>eu > 0\<close> at_within_open[of y "ball x eu" for y]
	by (auto simp: continuous_on_def)
	then have flow0_u_tendsto: "(\<lambda>x. flow0 x (u x)) \<midarrow>x\<rightarrow> poincare_map ?P x"
	by (auto intro!: tendsto_eq_intros u return_time_exivl rt simp: poincare_map_def)
	have s_imp: "s (poincare_map {x \<in> S. s x = 0} x) = 0 \<longrightarrow> poincare_map {x \<in> S. s x = 0} x \<in> S"
	using poincare_map_returns[OF rt]
	by auto
	from eventually_tendsto_compose_within[OF eventually_inside s_imp flow0_u_tendsto]
	have "\<forall>\<^sub>F x in at x. s (flow0 x (u x)) = 0 \<longrightarrow> flow0 x (u x) \<in> S" by auto
	with ev_cball
	have "\<forall>\<^sub>F x in at x. flow0 x (u x) \<in> S"
	by eventually_elim (auto simp: u)
	ultimately have u_returns_ge: "\<forall>\<^sub>F y in at x. returns_to ?P y \<and> return_time ?P y \<le> u y"
	proof eventually_elim
	case (elim y)
	then show ?case
	using u elim by (auto intro!: return_time_le[OF _ cls])
	qed
	moreover
	have "\<forall>\<^sub>F y in at x. u y - return_time ?P x < e"
	using tendstoD[OF u_tendsto \<open>0 < e\<close>, unfolded u] u_returns_ge
	by eventually_elim (auto simp: dist_real_def)
	moreover
	have d_less: "d < return_time ?P x"
	apply (rule return_time_gt)
	apply fact apply fact
	subgoal for t
	using d_mvt[of t x] \<open>s x = 0\<close> \<open>0 < d\<close>
	by auto
	done
	note 1 = inside
	define ml where "ml = Max {return_time ?P x / 2, return_time ?P x - e, d}"
	have [intro, simp, arith]: "0 < ml" "ml < return_time ?P x" "ml \<le> return_time ?P x" "d \<le> ml"
	using return_time_pos[OF rt cls] \<open>0 < e\<close> d_less
	by (auto simp: ml_def)
	have mt_in: "ml \<in> existence_ivl0 x"
	using \<open>0 < e\<close> \<open>0 < d\<close> d_less
	by (auto intro!: mem_existence_ivl_iv_defined in_existence_between_zeroI[OF ret_exivl]
	simp: closed_segment_eq_real_ivl ml_def)
	from open_existence_ivlE[OF mt_in]
	obtain e0 where e0: "e0 > 0" "cball x e0 \<times> {0..ml + e0} \<subseteq> Sigma X existence_ivl0" (is "?D \<subseteq> _")
	by auto
	have uc: "uniformly_continuous_on ((\<lambda>(x, t). flow0 x t) ` ?D) s"
	apply (auto intro!: compact_uniformly_continuous continuous_on_subset[OF cont_s])
	apply (rule compact_continuous_image)
	apply (rule continuous_on_subset)
	apply (rule flow_continuous_on_state_space)
	apply (rule e0)
	apply (rule compact_Times)
	apply (rule compact_cball)
	apply (rule compact_Icc)
	done
	let ?T = "{d..ml}"
	have ul: "uniform_limit ?T flow0 (flow0 x) (at x)"
	using \<open>0 < e\<close> \<open>0 < d\<close> d_less
	by (intro uniform_limit_flow)
	(auto intro!: mem_existence_ivl_iv_defined in_existence_between_zeroI[OF ret_exivl]
	simp: closed_segment_eq_real_ivl )
	{
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. y \<in> X"
	by (rule topological_tendstoD[OF tendsto_ident_at open_dom \<open>x \<in> X\<close>])
	moreover
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. s y \<le> 0"
	by (auto simp: eventually_at)
	moreover
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. Ds y (f y) < 0"
	by (rule order_tendstoD) (auto intro!: tendsto_eq_intros inside)
	moreover
	from tendstoD[OF tendsto_ident_at \<open>0 < d\<close>]
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. dist y x < d"
	- by (auto simp: )
	+ by auto
	moreover
	have "d \<in> existence_ivl0 x"
	using d_ex[of x d] \<open>0 < d\<close> by auto
	have dret: "returns_to {x\<in>S. s x = 0} (flow0 x d)"
	apply (rule returns_to_laterI)
	apply fact+
	subgoal for u
	using d_mvt[of u x] \<open>s x = 0\<close>
	by auto
	done
	have "\<forall>\<^sub>F y in at x. \<forall>t\<in>{d..ml}. flow0 y t \<in> - {x \<in> S. s x = 0}"
	apply (rule uniform_limit_in_open)
	apply (rule ul)
	apply (auto intro!: continuous_intros continuous_on_compose2[OF cont_s] simp:
	split: if_splits)
	using \<open>d \<in> existence_ivl0 x\<close> mem_is_interval_1_I mt_in apply blast
	subgoal for t
	using return_time_least[OF rt cls, of t] \<open>ml < return_time {x \<in> S. s x = 0} x\<close> \<open>0 < d\<close>
	by auto
	done
	then have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. \<forall>t\<in>{d .. ml}. flow0 y t \<in> - {x \<in> S. s x = 0}"
	by (auto simp add: eventually_at; force)
	ultimately
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. \<forall>t\<in>{0<..ml}. flow0 y t \<in> - {x \<in> S. s x = 0}"
	apply eventually_elim
	apply auto
	using d_mvt
	by fastforce
	moreover
	have "\<forall>\<^sub>F y in at x. returns_to ?P y"
	by fact
	then have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. returns_to ?P y"
	by (auto simp: eventually_at)
	ultimately
	have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. return_time ?P y > ml"
	apply eventually_elim
	apply (rule return_time_gt)
	by auto
	}
	then have "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. return_time ?P y \<ge> return_time ?P x - e"
	by eventually_elim (auto simp: ml_def)
	ultimately
	have "\<forall>\<^sub>F y in at x within {x . s x \<le> 0}. dist (return_time ?P y) (return_time ?P x) \<le> e"
	unfolding eventually_at_filter
	by eventually_elim (auto simp: dist_real_def abs_real_def algebra_simps)
	then show "\<forall>\<^sub>F y in at x within {x. s x \<le> 0}. dist (return_time ?P y) (return_time ?P x) < e_orig"
	by eventually_elim (use \<open>e_orig > 0\<close> in \<open>auto simp: e_def\<close>)
	qed

	lemma
	return_time_continuous_below_plane:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> R. x \<bullet> n = c} x" (is "returns_to ?P x")
	assumes cR: "closed R"
	assumes through: "f (poincare_map ?P x) \<bullet> n \<noteq> 0"
	assumes R: "x \<in> R"
	assumes inside: "x \<bullet> n = c" "f x \<bullet> n < 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). x \<bullet> n = c \<longrightarrow> x \<in> R"
	shows "continuous (at x within {x. x \<bullet> n \<le> c}) (return_time ?P)"
	apply (rule return_time_continuous_below[of R "\<lambda>x. x \<bullet> n - c", simplified])
	using through rt inside cR R eventually_inside
	by (auto intro!: derivative_eq_intros blinfun_inner_left.rep_eq[symmetric])

	lemma
	poincare_map_in_interior_eventually_return_time_equal:
	assumes RP: "R \<subseteq> P"
	assumes cP: "closed P"
	assumes cR: "closed R"
	assumes ret: "returns_to P x"
	assumes evret: "\<forall>\<^sub>F x in at x within S. returns_to P x"
	assumes evR: "\<forall>\<^sub>F x in at x within S. poincare_map P x \<in> R"
	shows "\<forall>\<^sub>F x in at x within S. returns_to R x \<and> return_time P x = return_time R x"
	proof -
	from evret evR
	show ?thesis
	proof eventually_elim
	case (elim x)
	from return_time_least[OF elim(1) cP] RP
	have rtl: "\<And>s. 0 < s \<Longrightarrow> s < return_time P x \<Longrightarrow> flow0 x s \<notin> R"
	by auto
	from elim(2) have pR: "poincare_map P x \<in> R"
	by auto
	have "\<forall>\<^sub>F t in at_right 0. 0 < t"
	by (simp add: eventually_at_filter)
	moreover have "\<forall>\<^sub>F t in at_right 0. t < return_time P x"
	using return_time_pos[OF elim(1) cP]
	by (rule order_tendstoD[OF tendsto_ident_at])
	ultimately have evR: "\<forall>\<^sub>F t in at_right 0. flow0 x t \<notin> R"
	proof eventually_elim
	case et: (elim t)
	from return_time_least[OF elim(1) cP et] show ?case using RP by auto
	qed
	have rtp: "0 < return_time P x" by (intro return_time_pos cP elim)
	have rtex: "return_time P x \<in> existence_ivl0 x" by (intro return_time_exivl elim cP)
	have frR: "flow0 x (return_time P x) \<in> R"
	unfolding poincare_map_def[symmetric] by (rule pR)
	have "returns_to R x"
	by (rule returns_toI[where t="return_time P x"]; fact)
	moreover have "return_time R x = return_time P x"
	by (rule return_time_eqI) fact+
	ultimately show ?case by auto
	qed
	qed

	lemma poincare_map_in_planeI:
	assumes "returns_to (plane n c) x0"
	shows "poincare_map (plane n c) x0 \<bullet> n = c"
	using poincare_map_returns[OF assms]
	by fastforce

	lemma less_return_time_imp_exivl:
	"h \<in> existence_ivl0 x'" if "h \<le> return_time P x'" "returns_to P x'" "closed P" "0 \<le> h"
	proof -
	from return_time_exivl[OF that(2,3)]
	have "return_time P x' \<in> existence_ivl0 x'" by auto
	from ivl_subset_existence_ivl[OF this] that show ?thesis
	by auto
	qed

	lemma eventually_returns_to_continuousI:
	assumes "returns_to P x"
	assumes "closed P"
	assumes "continuous (at x within S) (return_time P)"
	shows "\<forall>\<^sub>F x in at x within S. returns_to P x"
	proof -
	have "return_time P x > 0"
	using assms by (auto simp: return_time_pos)
	from order_tendstoD(1)[OF assms(3)[unfolded continuous_within] this]
	have "\<forall>\<^sub>F x in at x within S. 0 < return_time P x" .
	then show ?thesis
	by eventually_elim (auto simp: return_time_pos_returns_to)
	qed

	lemma return_time_implicit_functionE:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P _")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	assumes Ds_through: "(Ds (poincare_map ?P x)) (f (poincare_map ?P x)) \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> s x \<noteq> 0"
	obtains e' where
	"0 < e'"
	"\<And>y. y \<in> ball x e' \<Longrightarrow> returns_to ?P y"
	"\<And>y. y \<in> ball x e' \<Longrightarrow> s (flow0 y (return_time ?P y)) = 0"
	"continuous_on (ball x e') (return_time ?P)"
	"(\<And>y. y \<in> ball x e' \<Longrightarrow> Ds (poincare_map ?P y) o\<^sub>L flowderiv y (return_time ?P y) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun)"
	"(\<And>U v sa.
	(\<And>sa. sa \<in> U \<Longrightarrow> s (flow0 sa (v sa)) = 0) \<Longrightarrow>
	return_time ?P x = v x \<Longrightarrow>
	continuous_on U v \<Longrightarrow> sa \<in> U \<Longrightarrow> x \<in> U \<Longrightarrow> U \<subseteq> ball x e' \<Longrightarrow> connected U \<Longrightarrow> open U \<Longrightarrow> return_time ?P sa = v sa)"
	"(return_time ?P has_derivative
	- blinfun_scaleR_left (inverse ((Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L Dflow x (return_time ?P x)))
	(at x)"
	proof -
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	then have s_tendsto: "(s \<longlongrightarrow> s x) (at x)" for x
	by (auto simp: continuous_on_def)
	have cls[simp, intro]: "closed {x \<in> S. s x = 0}"
	by (rule closed_levelset_within) (auto intro!: cS continuous_on_subset[OF cont_s])

	have cont_Ds: "continuous_on UNIV Ds"
	using DsC by (auto simp: continuous_on_def isCont_def)
	note [tendsto_intros] = continuous_on_tendsto_compose[OF cont_Ds _ UNIV_I, simplified]
	note [continuous_intros] = continuous_on_compose2[OF cont_Ds _ subset_UNIV]

	have "\<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	using eventually_inside
	by auto
	then obtain U where "open U" "poincare_map ?P x \<in> U" "\<And>x. x \<in> U \<Longrightarrow> s x = 0 \<Longrightarrow> x \<in> S"
	using poincare_map_returns[OF rt cls]
	by (force simp: eventually_at_topological)
	have s_imp: "s (poincare_map ?P x) = 0 \<longrightarrow> poincare_map ?P x \<in> S"
	using poincare_map_returns[OF rt cls]
	by auto
	have outside_disj: "x \<notin> S \<or> s x \<noteq> 0 \<or> blinfun_apply (Ds x) (f x) \<noteq> 0"
	using outside by auto
	have pm_tendsto: "(poincare_map ?P \<longlongrightarrow> poincare_map ?P x) (at x)"
	apply (rule poincare_map_tendsto)
	unfolding isCont_def[symmetric]
	apply (rule return_time_isCont_outside)
	using assms
	by (auto intro!: cls )
	have evmemS: "\<forall>\<^sub>F x in at x. poincare_map ?P x \<in> S"
	using eventually_returns_to[OF rt cS Ds DsC eventually_inside Ds_through outside_disj]
	apply eventually_elim
	using poincare_map_returns
	by auto
	have "\<forall>\<^sub>F x in at x. \<forall>\<^sub>F x in at (poincare_map ?P x). s x = 0 \<longrightarrow> x \<in> S"
	apply (rule eventually_tendsto_compose_within[OF _ _ pm_tendsto])
	apply (rule eventually_eventually_withinI)
	apply (rule eventually_inside)
	apply (rule s_imp)
	apply (rule eventually_inside)
	apply (rule evmemS)
	done
	moreover
	have "eventually (\<lambda>x. x \<in> - ?P) (at x)"
	apply (rule topological_tendstoD)
	using outside
	by (auto intro!: )
	then have "eventually (\<lambda>x. x \<notin> S \<or> s x \<noteq> 0) (at x)"
	by auto
	moreover
	have "eventually (\<lambda>x. (Ds (poincare_map ?P x)) (f (poincare_map ?P x)) \<noteq> 0) (at x)"
	apply (rule tendsto_imp_eventually_ne)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	unfolding poincare_map_def
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (subst isCont_def[symmetric])
	apply (rule return_time_isCont_outside[OF rt cS Ds DsC Ds_through eventually_inside outside])
	apply (rule return_time_exivl[OF rt cls])
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (rule tendsto_intros)
	apply (subst isCont_def[symmetric])
	apply (rule return_time_isCont_outside[OF rt cS Ds DsC Ds_through eventually_inside outside])
	apply (rule return_time_exivl[OF rt cls])
	apply (rule flow_in_domain)
	apply (rule return_time_exivl[OF rt cls])
	unfolding poincare_map_def[symmetric]
	apply (rule Ds_through)
	done
	ultimately
	have "eventually (\<lambda>y. returns_to ?P y \<and> (\<forall>\<^sub>F x in at (poincare_map ?P y). s x = 0 \<longrightarrow> x \<in> S) \<and>
	(y \<notin> S \<or> s y \<noteq> 0) \<and> (Ds (poincare_map ?P y)) (f (poincare_map ?P y)) \<noteq> 0) (at x)"
	using eventually_returns_to[OF rt cS Ds DsC eventually_inside Ds_through outside_disj]
	by eventually_elim auto
	then obtain Y' where Y': "open Y'" "x \<in> Y'" "\<And>y. y \<in> Y' \<Longrightarrow> returns_to ?P y"
	"\<And>y. y \<in> Y' \<Longrightarrow> (\<forall>\<^sub>F x in at (poincare_map ?P y). s x = 0 \<longrightarrow> x \<in> S)"
	"\<And>y. y \<in> Y' \<Longrightarrow> y \<notin> S \<or> s y \<noteq> 0"
	"\<And>y. y \<in> Y' \<Longrightarrow> blinfun_apply (Ds (poincare_map ?P y)) (f (poincare_map ?P y)) \<noteq> 0"
	apply (subst (asm) (3) eventually_at_topological)
	using rt outside Ds_through eventually_inside
	by fastforce
	from openE[OF \<open>open Y'\<close> \<open>x \<in> Y'\<close>] obtain eY where eY: "0 < eY" "ball x eY \<subseteq> Y'" by auto
	define Y where "Y = ball x eY"
	then have Y: "open Y" and x: "x \<in> Y"
	and Yr: "\<And>y. y \<in> Y \<Longrightarrow> returns_to ?P y"
	and Y_mem: "\<And>y. y \<in> Y \<Longrightarrow> (\<forall>\<^sub>F x in at (poincare_map ?P y). s x = 0 \<longrightarrow> x \<in> S)"
	and Y_nz: "\<And>y. y \<in> Y \<Longrightarrow> y \<notin> S \<or> s y \<noteq> 0"
	and Y_fnz: "\<And>y. y \<in> Y \<Longrightarrow> Ds (poincare_map ?P y) (f (poincare_map ?P y)) \<noteq> 0"
	and Y_convex: "convex Y"
	using Y' eY
	by (auto simp: subset_iff dist_commute)
	have "isCont (return_time ?P) y" if "y \<in> Y" for y
	using return_time_isCont_outside[OF Yr[OF that] cS Ds DsC Y_fnz Y_mem Y_nz, OF that that that] .
	then have cY: "continuous_on Y (return_time ?P)"
	by (auto simp: continuous_on_def isCont_def Lim_at_imp_Lim_at_within)

	note [derivative_intros] = has_derivative_compose[OF _ Ds]
	let ?t1 = "return_time ?P x"
	have t1_exivl: "?t1 \<in> existence_ivl0 x"
	by (auto intro!: return_time_exivl rt)
	then have [simp]: "x \<in> X" by auto
	have xt1: "(x, ?t1) \<in> Sigma Y existence_ivl0"
	by (auto intro!: return_time_exivl rt x)
	have "Sigma Y existence_ivl0 = Sigma X existence_ivl0 \<inter> fst -` Y" by auto
	also have "open \<dots>"
	by (rule open_Int[OF open_state_space open_vimage_fst[OF \<open>open Y\<close>]])
	finally have "open (Sigma Y existence_ivl0)" .
	have D: "(\<And>x. x \<in> Sigma Y existence_ivl0 \<Longrightarrow>
	((\<lambda>(x, t). s (flow0 x t)) has_derivative
	blinfun_apply (Ds (flow0 (fst x) (snd x)) o\<^sub>L (flowderiv (fst x) (snd x))))
	(at x))"
	by (auto intro!: derivative_eq_intros)
	have C: "continuous_on (Sigma Y existence_ivl0) (\<lambda>x. Ds (flow0 (fst x) (snd x)) o\<^sub>L flowderiv (fst x) (snd x))"
	by (auto intro!: continuous_intros)
	from return_time_returns[OF rt cls]
	have Z: "(case (x, ?t1) of (x, t) \<Rightarrow> s (flow0 x t)) = 0"
	by (auto simp: x)
	have I1: "blinfun_scaleR_left (inverse (Ds (flow0 x (?t1))(f (flow0 x (?t1))))) o\<^sub>L
	((Ds (flow0 (fst (x, return_time ?P x))
	(snd (x, return_time ?P x))) o\<^sub>L
	flowderiv (fst (x, return_time ?P x))
	(snd (x, return_time ?P x))) o\<^sub>L
	embed2_blinfun)
	= 1\<^sub>L"
	using Ds_through
	by (auto intro!: blinfun_eqI
	simp: rt flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	have I2: "((Ds (flow0 (fst (x, return_time ?P x))
	(snd (x, return_time ?P x))) o\<^sub>L
	flowderiv (fst (x, return_time ?P x))
	(snd (x, return_time ?P x))) o\<^sub>L
	embed2_blinfun) o\<^sub>L blinfun_scaleR_left (inverse (Ds (flow0 x (?t1))(f (flow0 x (?t1)))))
	= 1\<^sub>L"
	using Ds_through
	by (auto intro!: blinfun_eqI
	simp: rt flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	obtain u e where u:
	"s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>sa. sa \<in> cball x e \<Longrightarrow> s (flow0 sa (u sa)) = 0)"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> Sigma Y existence_ivl0"
	"0 < e"
	"(u has_derivative
	blinfun_apply
	(- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L flowderiv x (return_time ?P x)) o\<^sub>L
	embed1_blinfun))
	(at x)"
	"(\<And>s. s \<in> cball x e \<Longrightarrow>
	Ds (flow0 s (u s)) o\<^sub>L flowderiv s (u s) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun)"
	and unique: "(\<And>U v sa.
	(\<And>sa. sa \<in> U \<Longrightarrow> s (flow0 sa (v sa)) = 0) \<Longrightarrow>
	u x = v x \<Longrightarrow>
	continuous_on U v \<Longrightarrow> sa \<in> U \<Longrightarrow> x \<in> U \<Longrightarrow> U \<subseteq> cball x e \<Longrightarrow> connected U \<Longrightarrow> open U \<Longrightarrow> u sa = v sa)"
	apply (rule implicit_function_theorem_unique[where f="\<lambda>(x, t). s (flow0 x t)"
	and S="Sigma Y existence_ivl0", OF D xt1 \<open>open (Sigma Y _)\<close> order_refl C Z I1 I2])
	apply blast
	unfolding split_beta' fst_conv snd_conv poincare_map_def[symmetric]
	apply (rule)
	by (assumption+, blast)
	have u_rt: "u y = return_time ?P y" if "y \<in> ball x e \<inter> Y" for y
	apply (rule unique[of "ball x e \<inter> Y" "return_time ?P"])
	subgoal for y
	unfolding poincare_map_def[symmetric]
	using poincare_map_returns[OF Yr cls]
	by auto
	subgoal by (auto simp: u)
	subgoal using cY by (rule continuous_on_subset) auto
	subgoal using that by auto
	subgoal using x \<open>0 < e\<close> by auto
	subgoal by auto
	subgoal
	apply (rule convex_connected)
	apply (rule convex_Int)
	apply simp
	apply fact
	done
	subgoal by (auto intro!: open_Int \<open>open Y\<close>)
	done

	have *: "(- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L flowderiv x (return_time ?P x)) o\<^sub>L
	embed1_blinfun) =
	- blinfun_scaleR_left (inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L Dflow x (return_time ?P x))"
	by (auto intro!: blinfun_eqI simp: flowderiv_def)
	define e' where "e' = min e eY"
	have e'_eq: "ball x e' = ball x e \<inter> Y" by (auto simp: e'_def Y_def)
	have
	"0 < e'"
	"\<And>y. y \<in> ball x e' \<Longrightarrow> returns_to ?P y"
	"\<And>y. y \<in> ball x e' \<Longrightarrow> s (flow0 y (return_time ?P y)) = 0"
	"continuous_on (ball x e') (return_time ?P)"
	"(\<And>y. y \<in> ball x e' \<Longrightarrow> Ds (poincare_map ?P y) o\<^sub>L flowderiv y (return_time ?P y) o\<^sub>L embed2_blinfun \<in> invertibles_blinfun)"
	"(\<And>U v sa.
	(\<And>sa. sa \<in> U \<Longrightarrow> s (flow0 sa (v sa)) = 0) \<Longrightarrow>
	return_time ?P x = v x \<Longrightarrow>
	continuous_on U v \<Longrightarrow> sa \<in> U \<Longrightarrow> x \<in> U \<Longrightarrow> U \<subseteq> ball x e' \<Longrightarrow> connected U \<Longrightarrow> open U \<Longrightarrow> return_time ?P sa = v sa)"
	"(return_time ?P has_derivative blinfun_apply
	(- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L flowderiv x (return_time ?P x)) o\<^sub>L
	embed1_blinfun))
	(at x)"
	unfolding e'_eq
	subgoal by (auto simp: e'_def \<open>0 < e\<close> \<open>0 < eY\<close>)
	subgoal by (rule Yr) auto
	subgoal for y
	unfolding poincare_map_def[symmetric]
	using poincare_map_returns[OF Yr cls]
	by auto
	subgoal using cY by (rule continuous_on_subset) auto
	subgoal premises prems for y
	unfolding poincare_map_def
	unfolding u_rt[OF prems, symmetric]
	apply (rule u)
	using prems by auto
	subgoal premises prems for U v t
	apply (subst u_rt[symmetric])
	subgoal using prems by force
	apply (rule unique[of U v])
	subgoal by fact
	subgoal by (auto simp: u prems)
	subgoal by fact
	subgoal by fact
	subgoal by fact
	subgoal using prems by auto
	subgoal by fact
	subgoal by fact
	done
	subgoal
	proof -
	have "\<forall>\<^sub>F x' in at x. x' \<in> ball x e'"
	using eventually_at_ball[OF \<open>0 < e'\<close>]
	by eventually_elim simp
	then have "\<forall>\<^sub>F x' in at x. u x' = return_time ?P x'"
	unfolding e'_eq
	by eventually_elim (rule u_rt, auto)
	from u(7) this
	show ?thesis
	by (rule has_derivative_transform_eventually) (auto simp: u)
	qed
	done
	then show ?thesis unfolding * ..
	qed

	lemma return_time_has_derivative:
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P _")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "\<And>x. isCont Ds x"
	assumes Ds_through: "(Ds (poincare_map ?P x)) (f (poincare_map ?P x)) \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map {x \<in> S. s x = 0} x). s x = 0 \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> s x \<noteq> 0"
	shows "(return_time ?P has_derivative
	- blinfun_scaleR_left (inverse ((Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L Dflow x (return_time ?P x)))
	(at x)"
	using return_time_implicit_functionE[OF assms] by blast

	lemma return_time_plane_has_derivative_blinfun:
	assumes rt: "returns_to {x \<in> S. x \<bullet> i = c} x" (is "returns_to ?P _")
	assumes cS: "closed S"
	assumes fnz: "f (poincare_map ?P x) \<bullet> i \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). x \<bullet> i = c \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> x \<bullet> i \<noteq> c"
	shows "(return_time ?P has_derivative
	(- blinfun_scaleR_left (inverse ((blinfun_inner_left i) (f (poincare_map ?P x)))) o\<^sub>L
	(blinfun_inner_left i o\<^sub>L Dflow x (return_time ?P x)))) (at x)"
	proof -
	have rt: "returns_to {x \<in> S. x \<bullet> i - c = 0} x"
	using rt by auto
	have D: "((\<lambda>x. x \<bullet> i - c) has_derivative blinfun_inner_left i) (at x)" for x
	by (auto intro!: derivative_eq_intros)
	have DC: "(\<And>x. isCont (\<lambda>x. blinfun_inner_left i) x)"
	by (auto intro!: continuous_intros)
	have nz: "blinfun_apply (blinfun_inner_left i) (f (poincare_map {x \<in> S. x \<bullet> i - c = 0} x)) \<noteq> 0"
	using fnz by (auto )
	from cS have cS: "closed S"by auto
	have out: "x \<notin> S \<or> x \<bullet> i - c \<noteq> 0" using outside by simp
	from eventually_inside
	have eventually_inside: "\<forall>\<^sub>F x in at (poincare_map {x \<in> S. x \<bullet> i - c = 0} x). x \<bullet> i - c = 0 \<longrightarrow> x \<in> S"
	by auto
	from return_time_has_derivative[OF rt cS D DC nz eventually_inside out]
	show ?thesis
	by auto
	qed

	lemma return_time_plane_has_derivative:
	assumes rt: "returns_to {x \<in> S. x \<bullet> i = c} x" (is "returns_to ?P _")
	assumes cS: "closed S"
	assumes fnz: "f (poincare_map ?P x) \<bullet> i \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). x \<bullet> i = c \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> x \<bullet> i \<noteq> c"
	shows "(return_time ?P has_derivative
	(\<lambda>h. - (Dflow x (return_time ?P x)) h \<bullet> i / (f (poincare_map ?P x) \<bullet> i))) (at x)"
	by (rule return_time_plane_has_derivative_blinfun[OF assms, THEN has_derivative_eq_rhs])
	(auto simp: blinfun.bilinear_simps flowderiv_def inverse_eq_divide intro!: ext)

	definition "Dpoincare_map i c S x =
	(\<lambda>h. (Dflow x (return_time {x \<in> S. x \<bullet> i = c} x)) h -
	((Dflow x (return_time {x \<in> S. x \<bullet> i = c} x)) h \<bullet> i /
	(f (poincare_map {x \<in> S. x \<bullet> i = c} x) \<bullet> i)) *\<^sub>R f (poincare_map {x \<in> S. x \<bullet> i = c} x))"

	definition "Dpoincare_map' i c S x =
	Dflow x (return_time {x \<in> S. x \<bullet> i - c = 0} x) -
	(blinfun_scaleR_left (f (poincare_map {x \<in> S. x \<bullet> i = c} x)) o\<^sub>L
	(blinfun_scaleR_left (inverse ((f (poincare_map {x \<in> S. x \<bullet> i = c} x) \<bullet> i))) o\<^sub>L
	(blinfun_inner_left i o\<^sub>L Dflow x (return_time {x \<in> S. x \<bullet> i - c = 0} x))))"

	theorem poincare_map_plane_has_derivative:
	assumes rt: "returns_to {x \<in> S. x \<bullet> i = c} x" (is "returns_to ?P _")
	assumes cS: "closed S"
	assumes fnz: "f (poincare_map ?P x) \<bullet> i \<noteq> 0"
	assumes eventually_inside: "\<forall>\<^sub>F x in at (poincare_map ?P x). x \<bullet> i = c \<longrightarrow> x \<in> S"
	assumes outside: "x \<notin> S \<or> x \<bullet> i \<noteq> c"
	notes [derivative_intros] = return_time_plane_has_derivative[OF rt cS fnz eventually_inside outside]
	shows "(poincare_map ?P has_derivative Dpoincare_map' i c S x) (at x)"
	unfolding poincare_map_def Dpoincare_map'_def
	using fnz outside
	by (auto intro!: derivative_eq_intros return_time_exivl assms ext closed_levelset_within
	continuous_intros
	simp: flowderiv_eq poincare_map_def blinfun.bilinear_simps inverse_eq_divide algebra_simps)

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/IVP/Upper_Lower_Solution.thy b/thys/Ordinary_Differential_Equations/IVP/Upper_Lower_Solution.thy
	--- a/thys/Ordinary_Differential_Equations/IVP/Upper_Lower_Solution.thy
	+++ b/thys/Ordinary_Differential_Equations/IVP/Upper_Lower_Solution.thy
	@@ -1,491 +1,491 @@
	section \<open>Upper and Lower Solutions\<close>
	theory Upper_Lower_Solution
	imports Flow
	begin

	text \<open>Following Walter~\cite{walter} in section 9\<close>

	lemma IVT_min:
	fixes f :: "real \<Rightarrow> 'b :: {linorder_topology,real_normed_vector,ordered_real_vector}"
	\<comment> \<open>generalize?\<close>
	assumes y: "f a \<le> y" "y \<le> f b" "a \<le> b"
	assumes *: "continuous_on {a .. b} f"
	notes [continuous_intros] = *[THEN continuous_on_subset]
	obtains x where "a \<le> x" "x \<le> b" "f x = y" "\<And>x'. a \<le> x' \<Longrightarrow> x' < x \<Longrightarrow> f x' < y"
	proof -
	let ?s = "((\<lambda>x. f x - y) -` {0..}) \<inter> {a..b}"
	have "?s \<noteq> {}"
	using assms
	by auto
	have "closed ?s"
	by (rule closed_vimage_Int) (auto intro!: continuous_intros)
	moreover have "bounded ?s"
	by (rule bounded_Int) (simp add: bounded_closed_interval)
	ultimately have "compact ?s"
	using compact_eq_bounded_closed by blast
	from compact_attains_inf[OF this \<open>?s \<noteq> {}\<close>]
	obtain x where x: "a \<le> x" "x \<le> b" "f x \<ge> y"
	and min: "\<And>z. a \<le> z \<Longrightarrow> z \<le> b \<Longrightarrow> f z \<ge> y \<Longrightarrow> x \<le> z"
	by auto
	have "f x \<le> y"
	proof (rule ccontr)
	assume n: "\<not> f x \<le> y"
	then have "\<exists>z\<ge>a. z \<le> x \<and> (\<lambda>x. f x - y) z = 0"
	using x by (intro IVT') (auto intro!: continuous_intros simp: assms)
	then obtain z where z: "a \<le> z" "z \<le> x" "f z = y" by auto
	then have "a \<le> z" "z \<le> b" "f z \<ge> y" using x by auto
	from min [OF this] z n
	show False by auto
	qed
	then have "a \<le> x" "x \<le> b" "f x = y"
	using x
	by (auto )
	moreover have "f x' < y" if "a \<le> x'" "x' < x" for x'
	apply (rule ccontr)
	using min[of x'] that x
	by (auto simp: not_less)
	ultimately show ?thesis ..
	qed

	lemma filtermap_at_left_shift: "filtermap (\<lambda>x. x - d) (at_left a) = at_left (a - d::real)"
	by (simp add: filter_eq_iff eventually_filtermap eventually_at_filter filtermap_nhds_shift[symmetric])

	context
	fixes v v' w w'::"real \<Rightarrow> real" and t0 t1 e::real
	assumes v': "(v has_vderiv_on v') {t0 <.. t1}"
	and w': "(w has_vderiv_on w') {t0 <.. t1}"
	assumes pos_ivl: "t0 < t1"
	assumes e_pos: "e > 0" and e_in: "t0 + e \<le> t1"
	assumes less: "\<And>t. t0 < t \<Longrightarrow> t < t0 + e \<Longrightarrow> v t < w t"
	begin

	lemma first_intersection_crossing_derivatives:
	assumes na: "t0 < tg" "tg \<le> t1" "v tg \<ge> w tg"
	notes [continuous_intros] =
	vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
	vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
	obtains x0 where
	"t0 < x0" "x0 \<le> tg"
	"v' x0 \<ge> w' x0"
	"v x0 = w x0"
	"\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
	proof -
	have "(v - w) (min tg (t0 + e / 2)) \<le> 0" "0 \<le> (v - w) tg"
	"min tg (t0 + e / 2) \<le> tg"
	"continuous_on {min tg (t0 + e / 2)..tg} (v - w)"
	using less[of "t0 + e / 2"]
	less[of tg]na \<open>e > 0\<close>
	by (auto simp: min_def intro!: continuous_intros)
	from IVT_min[OF this]
	obtain x0 where x0: "min tg (t0 + e / 2) \<le> x0" "x0 \<le> tg" "v x0 = w x0"
	"\<And>x'. min tg (t0 + e / 2) \<le> x' \<Longrightarrow> x' < x0 \<Longrightarrow> v x' < w x'"
	by auto
	then have x0_in: "t0 < x0" "x0 \<le> t1"
	using \<open>e > 0\<close> na(1,2)
	by (auto)
	note \<open>t0 < x0\<close> \<open>x0 \<le> tg\<close>
	moreover
	{
	from v' x0_in
	have "(v has_derivative (\<lambda>x. x * v' x0)) (at x0 within {t0<..<x0})"
	by (force intro: has_derivative_subset simp: has_vector_derivative_def has_vderiv_on_def)
	then have v: "((\<lambda>y. (v y - (v x0 + (y - x0) * v' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
	unfolding has_derivative_within
	by (simp add: ac_simps)
	from w' x0_in
	have "(w has_derivative (\<lambda>x. x * w' x0)) (at x0 within {t0<..<x0})"
	by (force intro: has_derivative_subset simp: has_vector_derivative_def has_vderiv_on_def)
	then have w: "((\<lambda>y. (w y - (w x0 + (y - x0) * w' x0)) / norm (y - x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
	unfolding has_derivative_within
	by (simp add: ac_simps)

	have evs: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. min tg (t0 + e / 2) < x"
	"\<forall>\<^sub>F x in at x0 within {t0<..<x0}. t0 < x \<and> x < x0"
	using less na(1) na(3) x0(3) x0_in(1)
	by (force simp: min_def eventually_at_filter intro!: order_tendstoD[OF tendsto_ident_at])+
	then have "\<forall>\<^sub>F x in at x0 within {t0<..<x0}.
	(v x - (v x0 + (x - x0) * v' x0)) / norm (x - x0) - (w x - (w x0 + (x - x0) * w' x0)) / norm (x - x0) =
	(v x - w x) / norm (x - x0) + (v' x0 - w' x0)"
	apply eventually_elim
	using x0_in x0 less na \<open>t0 < t1\<close> sum_sqs_eq
	by (auto simp: divide_simps algebra_simps min_def intro!: eventuallyI split: if_split_asm)
	from this tendsto_diff[OF v w]
	have 1: "((\<lambda>x. (v x - w x) / norm (x - x0) + (v' x0 - w' x0)) \<longlongrightarrow> 0) (at x0 within {t0<..<x0})"
	by (force intro: tendsto_eq_rhs Lim_transform_eventually)
	moreover
	from evs have 2: "\<forall>\<^sub>F x in at x0 within {t0<..<x0}. (v x - w x) / norm (x - x0) + (v' x0 - w' x0) \<le> (v' x0 - w' x0)"
	by eventually_elim (auto simp: divide_simps intro!: less_imp_le x0(4))

	moreover
	have "at x0 within {t0<..<x0} \<noteq> bot"
	by (simp add: \<open>t0 < x0\<close> at_within_eq_bot_iff less_imp_le)

	ultimately
	have "0 \<le> v' x0 - w' x0"
	by (rule tendsto_upperbound)
	then have "v' x0 \<ge> w' x0" by simp
	}
	moreover note \<open>v x0 = w x0\<close>
	moreover
	have "t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t" for t
	by (cases "min tg (t0 + e / 2) \<le> t") (auto intro: x0 less)
	ultimately show ?thesis ..
	qed

	lemma defect_less:
	assumes b: "\<And>t. t0 < t \<Longrightarrow> t \<le> t1 \<Longrightarrow> v' t - f t (v t) < w' t - f t (w t)"
	notes [continuous_intros] =
	vderiv_on_continuous_on[OF v', THEN continuous_on_subset]
	vderiv_on_continuous_on[OF w', THEN continuous_on_subset]
	shows "\<forall>t \<in> {t0 <.. t1}. v t < w t"
	proof (rule ccontr)
	assume " \<not> (\<forall>t\<in>{t0 <.. t1}. v t < w t)"
	then obtain tu where "t0 < tu" "tu \<le> t1" "v tu \<ge> w tu" by auto
	from first_intersection_crossing_derivatives[OF this]
	obtain x0 where "t0 < x0" "x0 \<le> tu" "w' x0 \<le> v' x0" "v x0 = w x0" "\<And>t. t0 < t \<Longrightarrow> t < x0 \<Longrightarrow> v t < w t"
	by metis
	with b[of x0] \<open>tu \<le> t1\<close>
	show False
	by simp
	qed

	end

	lemma has_derivatives_less_lemma:
	fixes v v' ::"real \<Rightarrow> real"
	assumes v': "(v has_vderiv_on v') T"
	assumes y': "(y has_vderiv_on y') T"
	assumes lu: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t - f t (v t) < y' t - f t (y t)"
	assumes lower: "v t0 \<le> y t0"
	assumes eq_imp: "v t0 = y t0 \<Longrightarrow> v' t0 < y' t0"
	assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
	shows "v t < y t"
	proof -
	have subset: "{t0 .. t} \<subseteq> T"
	by (rule atMostAtLeast_subset_convex) (auto simp: assms is_interval_convex)
	obtain d where "0 < d" "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
	proof cases
	assume "v t0 = y t0"
	from this[THEN eq_imp]
	have *: "0 < y' t0 - v' t0"
	- by (simp add: )
	+ by simp
	have "((\<lambda>t. y t - v t) has_vderiv_on (\<lambda>t0. y' t0 - v' t0)) {t0 .. t}"
	by (auto intro!: derivative_intros y' v' has_vderiv_on_subset[OF _ subset])
	with \<open>t0 < t\<close>
	have d: "((\<lambda>t. y t - v t) has_real_derivative y' t0 - v' t0) (at t0 within {t0 .. t})"
	by (auto simp: has_vderiv_on_def has_field_derivative_iff_has_vector_derivative)
	from has_real_derivative_pos_inc_right[OF d *] \<open>v t0 = y t0\<close>
	obtain d where "d > 0" and vy: "h > 0 \<Longrightarrow> t0 + h \<le> t \<Longrightarrow> h < d \<Longrightarrow> v (t0 + h) < y (t0 + h)" for h
	by auto
	have vy: "t0 < s \<Longrightarrow> s \<le> t \<Longrightarrow> s < t0 + d \<Longrightarrow> v s < y s" for s
	using vy[of "s - t0"] by simp
	with \<open>d > 0\<close> show ?thesis ..
	next
	assume "v t0 \<noteq> y t0"
	then have "v t0 < y t0" using lower by simp
	moreover
	have "continuous_on {t0 .. t} v" "continuous_on {t0 .. t} y"
	by (auto intro!: vderiv_on_continuous_on assms has_vderiv_on_subset[OF _ subset])
	then have "(v \<longlongrightarrow> v t0) (at t0 within {t0 .. t})" "(y \<longlongrightarrow> y t0) (at t0 within {t0 .. t})"
	by (auto simp: continuous_on)
	ultimately have "\<forall>\<^sub>F x in at t0 within {t0 .. t}. 0 < y x - v x"
	by (intro order_tendstoD) (auto intro!: tendsto_eq_intros)
	then obtain d where "d > 0" "\<And>x. t0 < x \<Longrightarrow> x \<le> t \<Longrightarrow> x < t0 + d \<Longrightarrow> v x < y x"
	by atomize_elim (auto simp: eventually_at algebra_simps dist_real_def)
	then show ?thesis ..
	qed
	with \<open>d > 0\<close> \<open>t0 < t\<close>
	obtain e where "e > 0" "t0 + e \<le> t" "t0 < s \<Longrightarrow> s < t0 + e \<Longrightarrow> v s < y s" for s
	by atomize_elim (auto simp: min_def divide_simps intro!: exI[where x="min (d/2) ((t - t0) / 2)"]
	split: if_split_asm)
	from defect_less[
	OF has_vderiv_on_subset[OF v']
	has_vderiv_on_subset[OF y']
	\<open>t0 < t\<close>
	this lu]
	show "v t < y t" using \<open>t0 < t\<close> subset
	by (auto simp: subset_iff assms)
	qed

	lemma strict_lower_solution:
	fixes v v' ::"real \<Rightarrow> real"
	assumes sol: "(y solves_ode f) T X"
	assumes v': "(v has_vderiv_on v') T"
	assumes lower: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
	assumes iv: "v t0 \<le> y t0" "v t0 = y t0 \<Longrightarrow> v' t0 < f t0 (y t0)"
	assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
	shows "v t < y t"
	proof -
	note v'
	moreover
	note solves_odeD(1)[OF sol]
	moreover
	have 3: "v' t - f t (v t) < f t (y t) - f t (y t)" if "t \<in> T" "t > t0" for t
	using lower(1)[OF that]
	by arith
	moreover note iv
	moreover note t
	ultimately
	show "v t < y t"
	by (rule has_derivatives_less_lemma)
	qed

	lemma strict_upper_solution:
	fixes w w'::"real \<Rightarrow> real"
	assumes sol: "(y solves_ode f) T X"
	assumes w': "(w has_vderiv_on w') T"
	and upper: "\<And>t. t \<in> T \<Longrightarrow> t > t0 \<Longrightarrow> f t (w t) < w' t"
	and iv: "y t0 \<le> w t0" "y t0 = w t0 \<Longrightarrow> f t0 (y t0) < w' t0"
	assumes t: "t0 < t" "t0 \<in> T" "t \<in> T" "is_interval T"
	shows "y t < w t"
	proof -
	note solves_odeD(1)[OF sol]
	moreover
	note w'
	moreover
	have "f t (y t) - f t (y t) < w' t - f t (w t)" if "t \<in> T" "t > t0" for t
	using upper(1)[OF that]
	by arith
	moreover note iv
	moreover note t
	ultimately
	show "y t < w t"
	by (rule has_derivatives_less_lemma)
	qed

	lemma uniform_limit_at_within_subset:
	assumes "uniform_limit S x l (at t within T)"
	assumes "U \<subseteq> T"
	shows "uniform_limit S x l (at t within U)"
	by (metis assms(1) assms(2) eventually_within_Un filterlim_iff subset_Un_eq)

	lemma uniform_limit_le:
	fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
	assumes I: "I \<noteq> bot"
	assumes u: "uniform_limit X f g I"
	assumes u': "uniform_limit X f' g' I"
	assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> f' i x"
	assumes "x \<in> X"
	shows "g x \<le> g' x"
	proof -
	have "\<forall>\<^sub>F i in I. f i x \<le> f' i x" using assms by (simp add: eventually_mono)
	with I tendsto_uniform_limitI[OF u' \<open>x \<in> X\<close>] tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>]
	show ?thesis by (rule tendsto_le)
	qed

	lemma uniform_limit_le_const:
	fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
	assumes I: "I \<noteq> bot"
	assumes u: "uniform_limit X f g I"
	assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. f i x \<le> h x"
	assumes "x \<in> X"
	shows "g x \<le> h x"
	proof -
	have "\<forall>\<^sub>F i in I. f i x \<le> h x" using assms by (simp add: eventually_mono)
	then show ?thesis by (metis tendsto_upperbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
	qed

	lemma uniform_limit_ge_const:
	fixes f::"'c \<Rightarrow> 'a \<Rightarrow> 'b::{metric_space, linorder_topology}"
	assumes I: "I \<noteq> bot"
	assumes u: "uniform_limit X f g I"
	assumes "\<forall>\<^sub>F i in I. \<forall>x \<in> X. h x \<le> f i x"
	assumes "x \<in> X"
	shows "h x \<le> g x"
	proof -
	have "\<forall>\<^sub>F i in I. h x \<le> f i x" using assms by (simp add: eventually_mono)
	then show ?thesis by (metis tendsto_lowerbound I tendsto_uniform_limitI[OF u \<open>x \<in> X\<close>])
	qed

	locale ll_on_open_real = ll_on_open T f X for T f and X::"real set"
	begin

	lemma lower_solution:
	fixes v v' ::"real \<Rightarrow> real"
	assumes sol: "(y solves_ode f) S X"
	assumes v': "(v has_vderiv_on v') S"
	assumes lower: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> v' t < f t (v t)"
	assumes iv: "v t0 \<le> y t0"
	assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
	shows "v t \<le> y t"
	proof cases
	assume "v t0 = y t0"
	have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
	with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
	moreover note refl
	moreover
	have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
	ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
	by (rule existence_ivl_maximal_segment)

	have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
	using in_existence_between_zeroI t_ex by blast
	have "t0 \<in> T" using assms(9) t(2) by blast

	from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
	have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
	then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_right (y t0))"
	by (rule uniform_limit_at_within_subset) simp
	moreover
	{
	have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
	by (rule eventually_mem_existence_ivl) fact
	then have "\<forall>\<^sub>F i in at_right (y t0). t \<in> existence_ivl t0 i"
	unfolding eventually_at_filter
	by eventually_elim simp
	moreover have "\<forall>\<^sub>F i in at_right (y t0). i \<in> X"
	proof -
	have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
	by (metis existence_ivl_reverse flow_in_domain flows_reverse)
	obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
	"\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
	(\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
	by (metis (no_types) eventually_mono)
	then show ?thesis
	using f1 calculation by meson
	qed
	moreover have "\<forall>\<^sub>F i in at_right (y t0). y t0 < i"
	by (simp add: eventually_at_filter)
	ultimately have "\<forall>\<^sub>F i in at_right (y t0). \<forall>x\<in>{t0..t}. v x \<le> flow t0 i x"
	proof eventually_elim
	case (elim y')
	show ?case
	proof safe
	fix s assume s: "s \<in> {t0..t}"
	show "v s \<le> flow t0 y' s"
	proof cases
	assume "s = t0" with elim iv show ?thesis
	by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
	next
	assume "s \<noteq> t0" with s have "t0 < s" by simp
	have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
	from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
	using ivl_subset_existence_ivl by blast
	with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
	by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
	have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
	with v' have v': "(v has_vderiv_on v') {t0 .. s}"
	by (rule has_vderiv_on_subset)
	from \<open>y t0 < y'\<close> \<open>v t0 = y t0\<close> have less_init: "v t0 < flow t0 y' t0"
	by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
	from strict_lower_solution[OF sol v' lower less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
	\<open>{t0 .. s} \<subseteq> S\<close>
	less_init \<open>t0 < s\<close>
	have "v s < flow t0 y' s" by (simp add: subset_iff is_interval_cc)
	then show ?thesis by simp
	qed
	qed
	qed
	}
	moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
	ultimately have "v t \<le> flow t0 (y t0) t"
	by (rule uniform_limit_ge_const[OF trivial_limit_at_right_real])
	also have "flow t0 (y t0) t = y t"
	using sol t
	by (intro maximal_existence_flow) auto
	finally show ?thesis .
	next
	assume "v t0 \<noteq> y t0" then have less: "v t0 < y t0" using iv by simp
	show ?thesis
	apply (cases "t0 = t")
	subgoal using iv by blast
	subgoal using strict_lower_solution[OF sol v' lower iv] less t by force
	done
	qed

	lemma upper_solution:
	fixes v v' ::"real \<Rightarrow> real"
	assumes sol: "(y solves_ode f) S X"
	assumes v': "(v has_vderiv_on v') S"
	assumes upper: "\<And>t. t \<in> S \<Longrightarrow> t > t0 \<Longrightarrow> f t (v t) < v' t"
	assumes iv: "y t0 \<le> v t0"
	assumes t: "t0 \<le> t" "t0 \<in> S" "t \<in> S" "is_interval S" "S \<subseteq> T"
	shows "y t \<le> v t"
	proof cases
	assume "v t0 = y t0"
	have "{t0 -- t} \<subseteq> S" using t by (simp add: closed_segment_subset is_interval_convex)
	with sol have "(y solves_ode f) {t0 -- t} X" using order_refl by (rule solves_ode_on_subset)
	moreover note refl
	moreover
	have "{t0 -- t} \<subseteq> T" using \<open>{t0 -- t} \<subseteq> S\<close> \<open>S \<subseteq> T\<close> by (rule order_trans)
	ultimately have t_ex: "t \<in> existence_ivl t0 (y t0)"
	by (rule existence_ivl_maximal_segment)

	have t0_ex: "t0 \<in> existence_ivl t0 (y t0)"
	using in_existence_between_zeroI t_ex by blast
	have "t0 \<in> T" using assms(9) t(2) by blast

	from uniform_limit_flow[OF t0_ex t_ex] \<open>t0 \<le> t\<close>
	have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at (y t0))" by simp
	then have "uniform_limit {t0..t} (flow t0) (flow t0 (y t0)) (at_left (y t0))"
	by (rule uniform_limit_at_within_subset) simp
	moreover
	{
	have "\<forall>\<^sub>F i in at (y t0). t \<in> existence_ivl t0 i"
	by (rule eventually_mem_existence_ivl) fact
	then have "\<forall>\<^sub>F i in at_left (y t0). t \<in> existence_ivl t0 i"
	unfolding eventually_at_filter
	by eventually_elim simp
	moreover have "\<forall>\<^sub>F i in at_left (y t0). i \<in> X"
	proof -
	have f1: "\<And>r ra rb. r \<notin> existence_ivl ra rb \<or> rb \<in> X"
	by (metis existence_ivl_reverse flow_in_domain flows_reverse)
	obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> (real \<Rightarrow> bool) \<Rightarrow> real" where
	"\<And>p f pa fa. (\<not> eventually p f \<or> eventually pa f \<or> p (rr p pa)) \<and>
	(\<not> eventually p fa \<or> \<not> pa (rr p pa) \<or> eventually pa fa)"
	by (metis (no_types) eventually_mono)
	then show ?thesis
	using f1 calculation by meson
	qed
	moreover have "\<forall>\<^sub>F i in at_left (y t0). i < y t0"
	by (simp add: eventually_at_filter)
	ultimately have "\<forall>\<^sub>F i in at_left (y t0). \<forall>x\<in>{t0..t}. flow t0 i x \<le> v x"
	proof eventually_elim
	case (elim y')
	show ?case
	proof safe
	fix s assume s: "s \<in> {t0..t}"
	show "flow t0 y' s \<le> v s"
	proof cases
	assume "s = t0" with elim iv show ?thesis
	by (simp add: \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
	next
	assume "s \<noteq> t0" with s have "t0 < s" by simp
	have "{t0 -- s} \<subseteq> S" using \<open>{t0--t} \<subseteq> S\<close> closed_segment_eq_real_ivl s by auto
	from s elim have "{t0..s} \<subseteq> existence_ivl t0 y'"
	using ivl_subset_existence_ivl by blast
	with flow_solves_ode have sol: "(flow t0 y' solves_ode f) {t0 .. s} X"
	by (rule solves_ode_on_subset) (auto intro!: \<open>y' \<in> X\<close> \<open>t0 \<in> T\<close>)
	have "{t0 .. s} \<subseteq> S" using \<open>{t0 -- s} \<subseteq> S\<close> by (simp add: closed_segment_eq_real_ivl split: if_splits)
	with v' have v': "(v has_vderiv_on v') {t0 .. s}"
	by (rule has_vderiv_on_subset)
	from \<open>y' < y t0\<close> \<open>v t0 = y t0\<close> have less_init: "flow t0 y' t0 < v t0"
	by (simp add: flow_initial_time_if \<open>t0 \<in> T\<close> \<open>y' \<in> X\<close>)
	from strict_upper_solution[OF sol v' upper less_imp_le[OF less_init] _ \<open>t0 < s\<close>]
	\<open>{t0 .. s} \<subseteq> S\<close>
	less_init \<open>t0 < s\<close>
	have "flow t0 y' s < v s" by (simp add: subset_iff is_interval_cc)
	then show ?thesis by simp
	qed
	qed
	qed
	}
	moreover have "t \<in> {t0 .. t}" using \<open>t0 \<le> t\<close> by simp
	ultimately have "flow t0 (y t0) t \<le> v t"
	by (rule uniform_limit_le_const[OF trivial_limit_at_left_real])
	also have "flow t0 (y t0) t = y t"
	using sol t
	by (intro maximal_existence_flow) auto
	finally show ?thesis .
	next
	assume "v t0 \<noteq> y t0" then have less: "y t0 < v t0" using iv by simp
	show ?thesis
	apply (cases "t0 = t")
	subgoal using iv by blast
	subgoal using strict_upper_solution[OF sol v' upper iv] less t by force
	done
	qed

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/Library/Linear_ODE.thy b/thys/Ordinary_Differential_Equations/Library/Linear_ODE.thy
	--- a/thys/Ordinary_Differential_Equations/Library/Linear_ODE.thy
	+++ b/thys/Ordinary_Differential_Equations/Library/Linear_ODE.thy
	@@ -1,67 +1,67 @@
	section \<open>Linear ODE\<close>
	theory Linear_ODE
	imports
	"../IVP/Flow"
	Bounded_Linear_Operator
	Multivariate_Taylor
	begin

	lemma
	exp_scaleR_has_derivative_right[derivative_intros]:
	fixes f::"real \<Rightarrow> real"
	assumes "(f has_derivative f') (at x within s)"
	shows "((\<lambda>x. exp (f x \<^sub>R A)) has_derivative (\<lambda>h. f' h \<^sub>R (exp (f x \<^sub>R A) A))) (at x within s)"
	proof -
	from assms have "bounded_linear f'" by auto
	with real_bounded_linear obtain m where f': "f' = (\<lambda>h. h * m)" by blast
	show ?thesis
	using vector_diff_chain_within[OF _ exp_scaleR_has_vector_derivative_right, of f m x s A] assms f'
	by (auto simp: has_vector_derivative_def o_def)
	qed

	context
	fixes A::"'a::{banach,perfect_space} blinop"
	begin

	definition "linode_solution t0 x0 = (\<lambda>t. exp ((t - t0) *\<^sub>R A) x0)"

	lemma linode_solution_solves_ode:
	"(linode_solution t0 x0 solves_ode (\<lambda>_. A)) UNIV UNIV" "linode_solution t0 x0 t0 = x0"
	by (auto intro!: solves_odeI derivative_eq_intros
	simp: has_vector_derivative_def blinop.bilinear_simps exp_times_scaleR_commute
	has_vderiv_on_def linode_solution_def)

	lemma "(linode_solution t0 x0 usolves_ode (\<lambda>_. A) from t0) UNIV UNIV"
	using linode_solution_solves_ode(1)
	proof (rule usolves_odeI)
	fix s t1
	assume s0: "s t0 = linode_solution t0 x0 t0"
	assume sol: "(s solves_ode (\<lambda>x. blinop_apply A)) {t0--t1} UNIV"

	then have [derivative_intros]:
	"(s has_derivative (\<lambda>h. h *\<^sub>R A (s t))) (at t within {t0 -- t1})" if "t \<in> {t0 -- t1}" for t
	using that
	by (auto dest!: solves_odeD(1) simp: has_vector_derivative_def has_vderiv_on_def)
	have "((\<lambda>t. exp (-(t - t0) *\<^sub>R A) (s t)) has_derivative (\<lambda>_. 0)) (at t within {t0 -- t1})"
	(is "(?es has_derivative _) _")
	if "t \<in> {t0 -- t1}" for t
	by (auto intro!: derivative_eq_intros that simp: has_vector_derivative_def
	blinop.bilinear_simps)
	from has_derivative_zero_constant[OF convex_closed_segment this]
	obtain c where c: "\<And>t. t \<in> {t0 -- t1} \<Longrightarrow> ?es t = c" by auto
	hence "(exp ((t - t0) \<^sub>R A) (exp (-((t - t0) \<^sub>R A)))) (s t) = exp ((t - t0) \<^sub>R A) c"
	if "t \<in> {t0 -- t1}" for t
	by (metis (no_types, opaque_lifting) blinop_apply_times_blinop real_vector.scale_minus_left that)
	then have s_def: "s t = exp ((t - t0) *\<^sub>R A) c" if "t \<in> {t0 -- t1}" for t
	by (simp add: exp_minus_inverse that)
	from s0 s_def
	have "exp ((t0 - t0) *\<^sub>R A) c = x0"
	by (simp add: linode_solution_solves_ode(2))
	- hence "c = x0" by (simp add: )
	+ hence "c = x0" by simp
	then show "s t1 = linode_solution t0 x0 t1"
	using s_def[of t1] by (simp add: linode_solution_def)
	qed auto

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis.thy b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis.thy
	@@ -1,594 +1,594 @@
	theory Concrete_Reachability_Analysis
	imports
	Concrete_Rigorous_Numerics
	Abstract_Reachability_Analysis
	begin

	abbreviation "num_optns_rel \<equiv> (Id::'b numeric_options rel)"

	consts i_flow1::interface
	consts i_appr1::interface

	abbreviation "float10_rel \<equiv> Id::(float10 \<times> float10) set"

	lemma inj_on_nat_add_square: "inj_on (\<lambda>a::nat. a + a * a) S"
	by (rule strict_mono_imp_inj_on) (auto intro!: strict_monoI add_strict_mono mult_strict_mono)

	lemma add_sq_eq[simp]: "a + a * a = b + b * b \<longleftrightarrow> a = b" for a b::nat
	using inj_on_nat_add_square[of UNIV, unfolded inj_on_def, rule_format, of a b]
	by auto

	context includes autoref_syntax begin
	lemma [autoref_rules]:
	"(precision, precision)\<in>num_optns_rel \<rightarrow> nat_rel"
	"(start_stepsize, start_stepsize)\<in>num_optns_rel \<rightarrow> rnv_rel"
	"(iterations, iterations)\<in> num_optns_rel\<rightarrow> nat_rel"
	"(halve_stepsizes, halve_stepsizes)\<in> (num_optns_rel) \<rightarrow> nat_rel"
	"(widening_mod, widening_mod)\<in> (num_optns_rel) \<rightarrow>nat_rel"
	"(rk2_param, rk2_param)\<in> (num_optns_rel) \<rightarrow> rnv_rel"
	"(method_id, method_id)\<in> (num_optns_rel) \<rightarrow> nat_rel"
	"(adaptive_atol, adaptive_atol)\<in> (num_optns_rel) \<rightarrow> rnv_rel"
	"(adaptive_rtol, adaptive_rtol)\<in> (num_optns_rel) \<rightarrow> rnv_rel"
	"(printing_fun, printing_fun)\<in> (num_optns_rel) \<rightarrow> bool_rel \<rightarrow> I \<rightarrow> unit_rel"
	"(tracing_fun, tracing_fun)\<in> (num_optns_rel) \<rightarrow> string_rel \<rightarrow> \<langle>I\<rangle>option_rel \<rightarrow> unit_rel"
	by auto

	end

	lemma [autoref_op_pat_def]:
	includes autoref_syntax
	shows
	"(\<lambda>xs. xs @ replicate D 0) ` X \<equiv> OP (pad_zeroes D) $ X"
	"pad_zeroes D X \<equiv> OP (pad_zeroes D) $ X"
	by simp_all

	subsection \<open>Relation Implementing \<open>ode_ops\<close>: Caching \<open>slp_of\<close>-Programs.\<close>

	definition "ode_slps_of ode_ops =
	(approximate_sets_ode.ode_slp ode_ops,
	approximate_sets_ode.euler_incr_slp ode_ops,
	approximate_sets_ode.euler_slp ode_ops,
	approximate_sets_ode.rk2_slp ode_ops,
	approximate_sets_ode.D ode_ops)"

	definition "init_ode_ops poincare c1 ode_ops =
	(ode_ops, ode_slps_of ode_ops,
	(if poincare then Some(approximate_sets_ode.solve_poincare_slp ode_ops) else None),
	(if c1 then Some(ode_slps_of (approximate_sets_ode'.var_ode_ops ode_ops)) else None))"

	definition "ode_ops_rel =
	{(init, ode_ops). init = init_ode_ops True True ode_ops
	\<or> init = init_ode_ops True False ode_ops
	\<or> init = init_ode_ops False False ode_ops }"

	consts i_ode_ops::interface
	lemmas [autoref_rel_intf] = REL_INTFI[of ode_ops_rel i_ode_ops]
	lemmas [autoref_tyrel] = TYRELI[of ode_ops_rel]


	context approximate_sets begin

	unbundle autoref_syntax

	lemma print_set_impl[autoref_rules]:
	shows "(printing_fun optns, print_set) \<in> bool_rel \<rightarrow> A \<rightarrow> Id"
	by auto

	lemma trace_set_impl[autoref_rules]:
	shows "(tracing_fun optns, trace_set) \<in> string_rel \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> Id"
	by auto

	definition "print_msg_impl s = tracing_fun optns s None"

	lemma print_msg_impl[autoref_rules]:
	shows "(print_msg_impl, print_msg) \<in> string_rel \<rightarrow> unit_rel"
	unfolding print_msg_def
	by auto

	definition "start_stepsize_impl = (if start_stepsize optns > 0 then start_stepsize optns else 1)"
	definition "rk2_param_impl = (let rk = rk2_param optns in if rk > 0 \<and> rk \<le> 1 then rk else 1)"

	lemma options_impl[autoref_rules]:
	"(RETURN (precision optns), precision_spec) \<in> \<langle>nat_rel\<rangle>nres_rel"
	"(RETURN (adaptive_atol optns), adaptive_atol_spec) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	"(RETURN (adaptive_rtol optns), adaptive_rtol_spec) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	"(RETURN (method_id optns), method_spec) \<in> \<langle>nat_rel\<rangle>nres_rel"
	"(RETURN start_stepsize_impl, start_stepsize_spec) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	"(RETURN (iterations optns), iterations_spec) \<in> \<langle>nat_rel\<rangle>nres_rel"
	"(RETURN (widening_mod optns), widening_mod_spec) \<in> \<langle>nat_rel\<rangle>nres_rel"
	"(RETURN (halve_stepsizes optns), halve_stepsizes_spec) \<in> \<langle>nat_rel\<rangle>nres_rel"
	"(RETURN (rk2_param_impl), rk2_param_spec) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	by (auto simp: nres_rel_def
	precision_spec_def
	adaptive_atol_spec_def
	adaptive_rtol_spec_def
	method_spec_def
	start_stepsize_spec_def start_stepsize_impl_def
	iterations_spec_def
	widening_mod_spec_def
	halve_stepsizes_spec_def
	rk2_param_spec_def rk2_param_impl_def Let_def)

	sublocale approximate_sets_ode where ode_ops = ode_ops for ode_ops :: ode_ops ..

	schematic_goal trace_sets_impl:
	assumes [autoref_rules]: "(si, s) \<in> string_rel" "(Xi, X) \<in> clw_rel appr_rel"
	shows "(RETURN ?f, trace_sets s X) \<in> \<langle>unit_rel\<rangle>nres_rel"
	unfolding trace_sets_def
	by (subst rel_ANNOT_eq[of X "clw_rel appr_rel"]) (autoref_monadic (plain))
	concrete_definition trace_sets_impl for si Xi uses trace_sets_impl
	lemmas [autoref_rules] = trace_sets_impl.refine[autoref_higher_order_rule]

	schematic_goal print_sets_impl:
	assumes [autoref_rules]: "(si, s) \<in> bool_rel" "(Xi, X) \<in> clw_rel appr_rel"
	shows "(RETURN ?f, print_sets s X) \<in> \<langle>unit_rel\<rangle>nres_rel"
	unfolding print_sets_def
	by (subst rel_ANNOT_eq[of X "clw_rel appr_rel"]) (autoref_monadic (plain))
	concrete_definition print_sets_impl for si Xi uses print_sets_impl
	lemmas [autoref_rules] = print_sets_impl.refine[autoref_higher_order_rule]

	definition "ode_slp_impl ode_ops = (case ode_ops of (_, (x, _, _, _, _), _, _) \<Rightarrow> x)"
	definition "euler_incr_slp_impl ode_ops = (case ode_ops of (_, (_, x, _, _, _), _, _) \<Rightarrow> x)"
	definition "euler_slp_impl ode_ops = (case ode_ops of (_, (_, _, x, _, _), _, _) \<Rightarrow> x)"
	definition "rk2_slp_impl ode_ops = (case ode_ops of (_, (_, _, _, x, _), _, _) \<Rightarrow> x)"
	definition "D_impl ode_ops = (case ode_ops of (_, (_, _, _, _, x), _, _) \<Rightarrow> x)"
	definition "poincare_slp_impl ode_ops = (case ode_ops of (ode_ops, (_, _, _, _, _), x, _) \<Rightarrow>
	(case x of
	None \<Rightarrow> let _ = print_msg_impl (''ODE solver not initialized: pslp missing'') in solve_poincare_slp ode_ops
	\| Some pslp \<Rightarrow> pslp))"

	lemma autoref_parameters[autoref_rules]:
	"(ode_slp_impl, ode_slp) \<in> ode_ops_rel \<rightarrow> slp_rel"
	"(euler_incr_slp_impl, euler_incr_slp) \<in> ode_ops_rel \<rightarrow> slp_rel"
	"(euler_slp_impl, euler_slp) \<in> ode_ops_rel \<rightarrow> slp_rel"
	"(rk2_slp_impl, rk2_slp) \<in> ode_ops_rel \<rightarrow> slp_rel"
	"(poincare_slp_impl, solve_poincare_slp) \<in> ode_ops_rel \<rightarrow> \<langle>slp_rel\<rangle>list_rel"
	"(D_impl, D) \<in> ode_ops_rel \<rightarrow> nat_rel"
	by (auto simp: ode_ops_rel_def ode_slp_impl_def euler_incr_slp_def D_impl_def init_ode_ops_def
	euler_incr_slp_impl_def euler_slp_impl_def rk2_slp_impl_def poincare_slp_impl_def
	ode_slps_of_def
	split: option.splits prod.splits)

	definition "ode_e_impl = (\<lambda>(ode_ops, _). ode_expression ode_ops)"
	lemma ode_e_impl[autoref_rules]: "(ode_e_impl, ode_e) \<in> ode_ops_rel \<rightarrow> fas_rel"
	by (auto simp: ode_e_impl_def ode_e_def ode_ops_rel_def init_ode_ops_def)

	definition "safe_form_impl = (\<lambda>(ode_ops, _). safe_form ode_ops)"
	lemma safe_form_impl[autoref_rules]: "(safe_form_impl, safe_form) \<in> ode_ops_rel \<rightarrow> Id"
	by (auto simp: safe_form_impl_def ode_ops_rel_def init_ode_ops_def)

	schematic_goal safe_set_appr:
	assumes [autoref_rules]: "(Xi, X::'a::executable_euclidean_space set) \<in> appr_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	notes [autoref_rules] = autoref_parameters
	shows "(nres_of ?f, safe_set odo X) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding safe_set_def
	including art
	by autoref_monadic
	concrete_definition safe_set_appr for odoi Xi uses safe_set_appr
	lemmas safe_set_appr_refine[autoref_rules] = safe_set_appr.refine[autoref_higher_order_rule]

	schematic_goal mk_safe_impl:
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(Ri, R) \<in> appr_rel"
	shows "(nres_of ?f, mk_safe odo (R::'a::executable_euclidean_space set)) \<in> \<langle>appr_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding mk_safe_def
	including art
	by autoref_monadic
	concrete_definition mk_safe_impl for odoi Ri uses mk_safe_impl
	lemmas mk_safe_impl_refine[autoref_rules] = mk_safe_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def mk_safe .

	schematic_goal mk_safe_coll_impl:
	assumes [autoref_rules]: "(ISi, IS) \<in> clw_rel appr_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of (?f), mk_safe_coll odo (IS::'a::executable_euclidean_space set)) \<in> \<langle>clw_rel appr_rel\<rangle>nres_rel"
	unfolding mk_safe_coll_def
	by autoref_monadic
	concrete_definition mk_safe_coll_impl for ISi uses mk_safe_coll_impl
	lemmas mk_safe_coll_impl_refine[autoref_rules] = mk_safe_coll_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def mk_safe_coll .

	schematic_goal ode_set_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	notes [autoref_rules] = autoref_parameters
	shows "(nres_of ?f, ode_set odo X::'a set nres) \<in> \<langle>appr_rel\<rangle>nres_rel"
	unfolding ode_set_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition ode_set_impl for E odoi Xi uses ode_set_impl
	lemmas ode_set_impl_refine[autoref_rules] = ode_set_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def ode_set .

	schematic_goal Picard_step_ivl_impl:
	fixes h::real
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(X0i,X0)\<in>appr_rel" "(hi, h) \<in> rnv_rel" "(t0i, t0) \<in> rnv_rel" "(PHIi,PHI)\<in>appr_rel"
	notes [autoref_rules] = autoref_parameters
	shows "(nres_of ?f, Picard_step_ivl odo X0 t0 h PHI::'a set option nres) \<in> \<langle>\<langle>appr_rel\<rangle>option_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding Picard_step_ivl_def
	including art
	by autoref_monadic
	concrete_definition Picard_step_ivl_impl for X0i t0i hi PHIi uses Picard_step_ivl_impl
	lemmas Picard_step_ivl_impl_refine[autoref_rules] =
	Picard_step_ivl_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def Picard_step_ivl .

	lemma [autoref_rules]:
	"(abs, abs:: 'a \<Rightarrow> 'a::executable_euclidean_space) \<in> rnv_rel \<rightarrow> rnv_rel"
	by simp_all

	lemma widening_spec[autoref_rules]:
	"(\<lambda>i. RETURN (widening_mod optns mod i = 0), do_widening_spec) \<in> nat_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	by (auto simp: do_widening_spec_def nres_rel_def)

	schematic_goal P_iter_impl:
	fixes h::real and i::nat
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(X0i,X0)\<in>appr_rel" "(PHIi,PHI)\<in>appr_rel"
	"(hi, h) \<in> Id" "(i_i, i) \<in> Id"
	notes [autoref_rules] = autoref_parameters
	shows "(nres_of (?f::?'r dres), P_iter odo X0 h i PHI::'a set option nres) \<in> ?R"
	unfolding P_iter_def uncurry_rec_nat APP_def
	including art
	by autoref_monadic

	concrete_definition P_iter_impl for E odoi X0i hi i_i PHIi uses P_iter_impl
	lemmas [autoref_rules] = P_iter_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def P_iter .

	schematic_goal cert_stepsize_impl_nres:
	fixes h::real and i n::nat
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]:
	"(mi, m)\<in>(appr_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel \<rightarrow> appr_rel \<rightarrow> \<langle>\<langle>appr_rel \<times>\<^sub>r R\<rangle> option_rel\<rangle>nres_rel)"
	"(X0i,X0)\<in>appr_rel" "(hi, h) \<in> rnv_rel" "(ni, n) \<in> nat_rel" "(i_i, i) \<in> nat_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(?f::?'r nres, cert_stepsize odo m (X0::'a set) h n i) \<in> ?R"
	unfolding cert_stepsize_def uncurry_rec_nat autoref_tag_defs
	by autoref
	concrete_definition cert_stepsize_impl_nres for mi X0i hi ni i_i uses cert_stepsize_impl_nres
	lemmas [autoref_rules] = cert_stepsize_impl_nres.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def cert_stepsize .

	schematic_goal cert_stepsize_impl_dres[refine_transfer]:
	assumes [refine_transfer]: "\<And>a b c d. nres_of (m a b c d) \<le> m' a b c d"
	shows "nres_of ?f \<le> cert_stepsize_impl_nres E odo m' x h n i"
	unfolding cert_stepsize_impl_nres_def
	by (refine_transfer)

	concrete_definition cert_stepsize_impl_dres for E m x h n i uses cert_stepsize_impl_dres
	lemmas [refine_transfer] = cert_stepsize_impl_dres.refine

	lemma DIM_obvious[autoref_rules_raw]: "DIM_precond TYPE('a) DIM('a::executable_euclidean_space)"
	- by (auto simp: )
	+ by auto

	lemma default_reduce_argument_spec_impl[autoref_rules]:
	"(RETURN (default_reduce optns), default_reduce_argument_spec) \<in> \<langle>reduce_argument_rel TYPE('b)\<rangle>nres_rel"
	by (auto simp: nres_rel_def default_reduce_argument_spec_def reduce_argument_rel_def
	intro!: RETURN_RES_refine)

	schematic_goal euler_step_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes ncc: "ncc_precond TYPE('a::executable_euclidean_space)"
	notes [simp] = ncc_precondD[OF ncc]
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(hi, h) \<in> Id"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of (?f::?'r dres), euler_step odo (X::'a set) h) \<in> ?R"
	unfolding one_step_def euler_step_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition euler_step_impl for odoi Xi hi uses euler_step_impl
	lemmas [autoref_rules] = euler_step_impl.refine[autoref_higher_order_rule(1 2)]
	sublocale autoref_op_pat_def euler_step .

	schematic_goal rk2_step_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes ncc: "ncc_precond TYPE('a::executable_euclidean_space)"
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(hi, h) \<in> Id"
	notes [simp] = ncc_precondD[OF ncc]
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of (?f::?'r dres), rk2_step odo (X::'a set) h) \<in> ?R"
	unfolding one_step_def rk2_step_def[abs_def]
	by autoref_monadic

	concrete_definition rk2_step_impl for odoi Xi hi uses rk2_step_impl
	lemmas [autoref_rules] = rk2_step_impl.refine[autoref_higher_order_rule (1 2)]
	sublocale autoref_op_pat_def rk2_step .

	schematic_goal choose_step_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('a)"
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(hi, h) \<in> rnv_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of (?f), choose_step odo (X::'a set) h) \<in> \<langle>rnv_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr_rel\<rangle>nres_rel"
	unfolding choose_step_def autoref_tag_defs if_distribR ncc_precond_def
	including art
	by autoref_monadic

	concrete_definition choose_step_impl for Xi hi uses choose_step_impl
	lemmas [autoref_rules] = choose_step_impl.refine[autoref_higher_order_rule (1 2)]
	sublocale autoref_op_pat_def choose_step .

	lemma [autoref_rules]: "(sgn, sgn) \<in> rnv_rel \<rightarrow> rnv_rel"
	by auto

	schematic_goal strongest_direction_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(xs, x) \<in> lv_rel"
	shows "(?f, strongest_direction (x::'a)) \<in> lv_rel \<times>\<^sub>r rnv_rel"
	unfolding strongest_direction_def
	including art
	by autoref
	concrete_definition strongest_direction_impl for xs uses strongest_direction_impl
	lemmas [autoref_rules] = strongest_direction_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def strongest_direction .

	lemma [autoref_rules]:
	"(real_divl, real_divl) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(truncate_down, truncate_down) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(eucl_truncate_down, eucl_truncate_down) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(truncate_up, truncate_up) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(eucl_truncate_up, eucl_truncate_up) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(max, max) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(min, min) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((/), (/)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(lfloat10, lfloat10) \<in> rnv_rel \<rightarrow> float10_rel"
	"(ufloat10, ufloat10) \<in> rnv_rel \<rightarrow> float10_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> int_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(shows_prec, shows_prec) \<in> nat_rel \<rightarrow> float10_rel \<rightarrow> string_rel \<rightarrow> string_rel"
	"(int, int) \<in> nat_rel \<rightarrow> int_rel"
	by (auto simp: string_rel_def)

	schematic_goal intersects_sctns_spec_impl:
	assumes [autoref_rules]: "(ai, a) \<in> appr_rel"
	assumes sctns[autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	notes [simp] = list_set_rel_finiteD[OF sctns]
	shows "(nres_of (?x::_ dres), intersects_sctns (a::'a::executable_euclidean_space set) sctns) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding intersects_sctns_def
	by autoref_monadic
	concrete_definition intersects_sctns_spec_impl for ai sctnsi uses intersects_sctns_spec_impl
	lemmas intersects_sctns_refine[autoref_rules] = intersects_sctns_spec_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def intersects_sctns .

	lemma
	assumes "GEN_OP ws width_spec (A \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel)"
	assumes "\<And>x. TRANSFER (RETURN (wsd x) \<le> ws x)"
	shows width_spec_invar_rel[autoref_rules]:
	"(\<lambda>(a, b). RETURN (wsd a), width_spec) \<in> \<langle>S, A\<rangle>invar_rel b \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	and width_spec_inter_rel[autoref_rules]:
	"(\<lambda>(a, b). RETURN (wsd a), width_spec) \<in> \<langle>S, A\<rangle>inter_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	using assms
	by (auto simp: nres_rel_def width_spec_def invar_rel_def dest!: fun_relD)

	lemma width_spec_coll[autoref_rules]:
	assumes "GEN_OP ws width_spec (A \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel)"
	assumes "\<And>x. TRANSFER (RETURN (wsd x) \<le> ws x)"
	shows "(\<lambda>xs. RETURN (sum_list (map wsd xs)), width_spec) \<in> clw_rel A \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	by (auto simp: nres_rel_def width_spec_def)

	schematic_goal intersects_sections_spec_clw[autoref_rules]:
	assumes [autoref_rules]: "(Ri, R) \<in> clw_rel appr_rel" "(sctnsi, sctns) \<in> sctns_rel"
	shows "(nres_of (?r::_ dres), intersects_sctns_spec_clw $ R $ sctns) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding intersects_sctns_spec_clw_def
	including art
	by autoref_monadic

	schematic_goal nonzero_component_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(ni, n) \<in> lv_rel" "(si, s) \<in> string_rel"
	shows "(nres_of ?f, nonzero_component s X n) \<in> \<langle>unit_rel\<rangle>nres_rel"
	unfolding nonzero_component_def autoref_tag_defs
	by autoref_monadic
	concrete_definition nonzero_component_impl for si Xi ni uses nonzero_component_impl
	lemmas nonzero_component_impl_refine[autoref_rules] = nonzero_component_impl.refine[autoref_higher_order_rule]
	lemma
	take_set_of_apprI:
	assumes "xs \<in> set_of_appr XS" "tXS = take d XS" "d < length xs"
	shows "take d xs \<in> set_of_appr tXS"
	using set_of_appr_project[OF assms(1), of "[0..<d]"]
	apply (auto simp: assms take_eq_map_nth length_set_of_appr)
	using assms(1) assms(3) length_set_of_appr take_eq_map_nth by fastforce


	lemma sv_appr_rell[relator_props]: "single_valued appr_rell"
	by (auto simp: appr_rell_internal)

	lemma single_valued_union:
	shows "single_valued X \<Longrightarrow> single_valued Y \<Longrightarrow> Domain X \<inter> Domain Y = {} \<Longrightarrow> single_valued (X \<union> Y)"
	by (auto simp: single_valued_def)

	lemma is_empty_ivl_rel[autoref_rules]:
	assumes le[THEN GEN_OP_D, param_fo]: "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(\<lambda>(x, y). \<not> le x y, is_empty) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> bool_rel"
	apply (auto simp: ivl_rel_def br_def set_of_ivl_def)
	subgoal premises prems for a b c d
	using le[OF prems(2, 3)] prems(1,4-) order_trans
	by auto
	subgoal premises prems for a b c d
	using le[OF prems(3,4)] prems(1,2) order_trans
	by auto
	done

	lemma real_autoref[autoref_rules]:
	"(real, real) \<in> nat_rel \<rightarrow> rnv_rel"
	by auto

	lemma map_option_autoref[autoref_rules]: "(map_option, map_option) \<in> (A \<rightarrow> B) \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> \<langle>B\<rangle>option_rel"
	by (rule map_option_param)

	lemma sv_plane_rel[relator_props]: "single_valued A \<Longrightarrow> single_valued (\<langle>A\<rangle>plane_rel)"
	by (auto simp: plane_rel_def intro!: relator_props)
	lemma sv_below_rel[relator_props]: "single_valued A \<Longrightarrow> single_valued (\<langle>A\<rangle>below_rel)"
	by (auto simp: below_rel_def intro!: relator_props)
	lemma sv_sbelow_rel[relator_props]: "single_valued A \<Longrightarrow> single_valued (\<langle>A\<rangle>sbelow_rel)"
	by (auto simp: sbelow_rel_def intro!: relator_props)
	lemma sv_sbelows_rel[relator_props]: "single_valued A \<Longrightarrow> single_valued (\<langle>A\<rangle>sbelows_rel)"
	by (auto simp: sbelows_rel_def intro!: relator_props)

	lemma closed_ivl_rel[intro, simp]: "(a, b) \<in> lvivl_rel \<Longrightarrow> closed b"
	by (auto simp: ivl_rel_def br_def set_of_ivl_def)

	lemma [autoref_rules]:
	"(float_of, float_of) \<in> rnv_rel \<rightarrow> Id"
	"(approx, approx) \<in> nat_rel \<rightarrow> Id \<rightarrow> \<langle>\<langle>Id\<rangle>option_rel\<rangle>list_rel \<rightarrow> \<langle>Id\<rangle>option_rel"
	by auto

	lemma uninfo_autoref[autoref_rules]:
	assumes "PREFER single_valued X"
	assumes "PREFER single_valued R"
	shows "(map snd, uninfo) \<in> clw_rel (\<langle>R, X\<rangle>info_rel) \<rightarrow> clw_rel X"
	using assms
	apply (auto simp: lw_rel_def Union_rel_br info_rel_def br_chain br_rel_prod elim!: single_valued_as_brE
	dest!: brD
	intro!: brI)
	apply force
	apply force
	apply force
	done

	lemma [autoref_op_pat]: "(\<subseteq>) \<equiv> OP op_subset_ivl"
	by (force intro!: eq_reflection)

	lemma op_subset_ivl:
	assumes le[THEN GEN_OP_D, autoref_rules, param_fo]: "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(\<lambda>(a, b) (c, d). le a b \<longrightarrow> le c a \<and> le b d, op_subset_ivl) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> bool_rel"
	apply (clarsimp dest!: brD simp: ivl_rel_def)
	subgoal for a b c d e f g h
	using le[of a c b d]
	using le[of e g a c]
	using le[of b d f h]
	by (auto simp: set_of_ivl_def)
	done
	concrete_definition op_subset_ivl_impl uses op_subset_ivl
	lemmas [autoref_rules] = op_subset_ivl_impl.refine

	lemma [autoref_op_pat]: "(=) \<equiv> OP op_eq_ivl"
	by (force intro!: eq_reflection)
	lemma eq_ivl_impl:
	assumes le[THEN GEN_OP_D, autoref_rules, param_fo]: "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(\<lambda>(a, b) (c, d). (le a b \<longrightarrow> le c a \<and> le b d) \<and> (le c d \<longrightarrow> le a c \<and> le d b), op_eq_ivl) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> bool_rel"
	apply (clarsimp dest!: brD simp: )
	subgoal premises prems for a b c d e f
	using op_subset_ivl[param_fo, OF assms prems(1,2)]
	op_subset_ivl[param_fo, OF assms prems(2,1)]
	- by (auto simp: )
	+ by auto
	done
	concrete_definition eq_ivl_impl uses eq_ivl_impl
	lemmas [autoref_rules] = eq_ivl_impl.refine

	lemma [autoref_rules]: "(RETURN, get_plane) \<in> \<langle>A\<rangle>plane_rel \<rightarrow> \<langle>\<langle>A\<rangle>sctn_rel\<rangle>nres_rel"
	by (auto simp: plane_rel_def get_plane_def nres_rel_def dest!: brD intro!: RETURN_SPEC_refine)

	lemma [autoref_op_pat_def del]: "get_inter p \<equiv> OP (get_inter p)" by auto

	lemma inform_autoref[autoref_rules]:
	"(\<lambda>x. Max (abs ` set x), (infnorm::'a::executable_euclidean_space\<Rightarrow>real)) \<in> lv_rel \<rightarrow> rnv_rel"
	apply (auto simp: lv_rel_def br_def infnorm_def eucl_of_list_inner
	intro!: Max_eqI le_cSup_finite)
	subgoal for a y
	apply (rule exI[where x="Basis_list ! index a y"])
	by (auto simp: eucl_of_list_inner)
	subgoal
	apply (rule rev_subsetD)
	apply (rule closed_contains_Sup)
	apply (auto intro!: finite_imp_closed)
	apply (rule imageI)
	apply (auto simp: eucl_of_list_inner)
	done
	done

	schematic_goal tolerate_error_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) dd"
	assumes [autoref_rules]: "(Yi, Y::'a::executable_euclidean_space set) \<in> appr_rel"
	assumes [autoref_rules]: "(Ei, E) \<in> appr_rel"
	shows "(nres_of ?r, tolerate_error Y E) \<in> \<langle>bool_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
	unfolding tolerate_error_def
	including art
	by autoref_monadic
	concrete_definition tolerate_error_impl for dd Yi Ei uses tolerate_error_impl
	lemmas tolerate_error_refine[autoref_rules] = tolerate_error_impl.refine[autoref_higher_order_rule (1)]

	lemma adapt_stepsize_fa_autoref[autoref_rules]:
	"(adapt_stepsize_fa, adapt_stepsize_fa) \<in> rnv_rel \<rightarrow> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel \<rightarrow> Id"
	by auto

	lemma
	list_wset_rel_finite:
	assumes "single_valued A"
	shows "(xs, X) \<in> \<langle>A\<rangle>list_wset_rel \<Longrightarrow> finite X"
	using assms
	by (auto simp: list_wset_rel_def set_rel_br dest!: brD elim!: single_valued_as_brE)

	lemma [autoref_rules_raw del]: "(norm2_slp, norm2_slp) \<in> nat_rel \<rightarrow> Id"
	and [autoref_itype del]: "norm2_slp ::\<^sub>i i_nat \<rightarrow>\<^sub>i i_of_rel (Id::(floatarith list \<times> floatarith list) set)"
	by auto

	lemma [autoref_rules]: "(norm2_slp, norm2_slp) \<in> nat_rel \<rightarrow> slp_rel"
	by auto

	lemma [autoref_rules_raw]: "DIM_precond TYPE(real) (Suc 0)"
	by auto
	lemma [autoref_rules]:
	"(real_divr, real_divr) \<in> nat_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	by auto

	lemma length_norm2_slp_ge: "length (norm2_slp E) \<ge> 1"
	unfolding norm2_slp_def
	by (auto simp: slp_of_fas_def split: prod.splits)

	lemma blinfun_of_vmatrix_scaleR: "blinfun_of_vmatrix (c \<^sub>R e) = c \<^sub>R blinfun_of_vmatrix e"
	including blinfun.lifting
	by transfer (vector sum_distrib_left algebra_simps matrix_vector_mult_def fun_eq_iff)

	lemma closed_clw_rel_iplane_rel:
	"(xi, x) \<in> clw_rel (iplane_rel lvivl_rel) \<Longrightarrow> closed x"
	unfolding lvivl_rel_br
	by (force simp: lv_rel_def plane_rel_br inter_rel_br clw_rel_br set_of_ivl_def
	dest!: brD)

	lemma closed_ivl_prod3_list_rel:
	assumes "(y, x') \<in> clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r A"
	assumes "(xa, x'a) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r B\<rangle>list_rel"
	shows "\<forall>(guard, ro)\<in>set (x' # x'a). closed guard"
	using assms closed_clw_rel_iplane_rel
	apply (auto simp: list_rel_def prod_rel_def in_set_conv_nth list_all2_conv_all_nth)
	apply (drule spec)
	by auto

	lemma
	rec_list_fun_eq1:
	assumes "\<And>x xs a. snd (h x xs a) = snd a"
	shows "rec_list z (\<lambda>x xs r xa. f x xs xa (r (h x xs xa))) xs ab =
	rec_list (\<lambda>a. z (a, snd ab)) (\<lambda>x xs r a. f x xs (a, snd ab) (r (fst (h x xs (a, snd ab))))) xs (fst ab)"
	using assms
	unfolding split_beta'
	by (induction xs arbitrary: ab) (auto simp: split_beta')

	lemma
	rec_list_fun_eq2:
	assumes "\<And>x xs a. fst (h x xs a) = fst a"
	shows "rec_list z (\<lambda>x xs r xa. f x xs xa (r (h x xs xa))) xs ab =
	rec_list (\<lambda>b. z (fst ab, b)) (\<lambda>x xs r b. f x xs (fst ab, b) (r (snd (h x xs (fst ab, b))))) xs (snd ab)"
	using assms
	unfolding split_beta'
	by (induction xs arbitrary: ab) (auto simp: split_beta')

	lemma [autoref_itype]: "compact ::\<^sub>i A \<rightarrow>\<^sub>i i_bool"
	by auto

	lemma lvivl_rel_compact[autoref_rules]:
	"(\<lambda>_::_\<times>_. True, compact) \<in> lvivl_rel \<rightarrow> bool_rel"
	"(\<lambda>_::(_\<times>_)list. True, compact) \<in> clw_rel lvivl_rel \<rightarrow> bool_rel"
	by (auto simp: lvivl_rel_br set_of_ivl_def lw_rel_def Union_rel_br dest!: brD)

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Reachability_Analysis_C1.thy
	@@ -1,1714 +1,1714 @@
	theory Concrete_Reachability_Analysis_C1
	imports
	Concrete_Reachability_Analysis
	Abstract_Reachability_Analysis_C1
	begin

	definition "op_card_vec TYPE('a) = CARD('a)"
	lemma op_card_vec_pat_def[autoref_op_pat_def]: "CARD('a) \<equiv> OP (op_card_vec TYPE('a))"
	by (auto simp: op_card_vec_def)
	lemma op_card_vec_impl[autoref_rules]:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
	shows "(E, op_card_vec TYPE('a)) \<in> nat_rel"
	using assms by (auto simp: op_card_vec_def)


	context approximate_sets
	begin

	sublocale approximate_sets_ode' where ode_ops = ode_ops for ode_ops ..\<comment> \<open>parametrized by \<open>ode_ops\<close>\<close>

	end

	context approximate_sets
	begin

	lemma nonneg_reals_autoref[autoref_rules]: "(None, nonneg_reals) \<in> \<langle>Id\<rangle>phantom_rel"
	and pos_reals_autoref[autoref_rules]: "(None, pos_reals) \<in> \<langle>Id\<rangle>phantom_rel"
	by (auto simp: phantom_rel_def)

	lemma appr1_relI:
	assumes "c1_info_invar DIM('n::executable_euclidean_space) X0i"
	shows "(X0i, (c1_info_of_appr X0i::'n c1_info set)) \<in> appr1_rel"
	using assms
	apply (cases "snd X0i")
	subgoal
	apply (simp add: c1_info_of_appr_def c1_info_invar_def)
	unfolding appr1_rel_internal
	apply (rule UnI1)
	apply auto
	apply (rule exI[where x="fst X0i"])
	apply safe
	subgoal by (auto simp: prod_eq_iff)
	subgoal
	apply (rule exI[where x="eucl_of_list ` set_of_appr (fst X0i)"])
	apply (auto simp: appr_rel_def)
	by (auto simp: appr_rell_internal lv_rel_def set_rel_br br_chain length_set_of_appr
	intro!: brI)
	done
	subgoal for D
	apply (simp add: c1_info_of_appr_def c1_info_invar_def)
	unfolding appr1_rel_internal
	apply (rule UnI2)
	apply (auto simp: set_rel_br)
	apply (rule exI[where x="fst X0i"])
	apply (rule exI[where x=D])
	apply safe
	subgoal by (auto simp: prod_eq_iff)
	subgoal
	by (auto simp: appr_rell_internal lv_rel_def set_rel_br br_chain length_set_of_appr
	intro!: brI) (auto simp: power2_eq_square)
	done
	done

	lemma appr1_rel_br: "appr1_rel = br (c1_info_of_appr::_\<Rightarrow>('n c1_info)set) (c1_info_invar DIM('n::executable_euclidean_space))"
	apply (auto simp: dest!: brD intro!: appr1_relI)
	apply (rule brI)
	subgoal by (auto simp: appr1_rel_internal c1_info_of_appr_def appr_rel_br set_rel_br dest!: brD)
	subgoal by (auto simp: c1_info_invar_def appr1_rel_internal appr_rel_br power2_eq_square dest!: brD)
	done

	lemma appr1_rel_aux:
	"{((xs, Some ys), X) \|xs ys X. (xs @ ys, X) \<in> appr_rel \<and> length ys = (length xs)\<^sup>2} O
	\<langle>br flow1_of_vec1 top\<rangle>set_rel =
	{((xs, Some ys), X::'n eucl1 set) \|xs ys X.
	X = (\<lambda>xs. flow1_of_vec1 (eucl_of_list xs)) ` set_of_appr (xs @ ys) \<and>
	length xs = DIM((real, 'n::enum) vec) \<and> length ys = DIM((real, 'n) vec) * DIM((real, 'n) vec)}"
	apply (auto simp: set_rel_br appr_rel_br power2_eq_square dest!: brD)
	apply (rule relcompI)
	apply simp
	apply (rule brI) apply (rule refl) apply simp
	apply (rule brI) defer apply simp
	apply auto
	done

	lemma flow1_of_list_def':
	shows "flow1_of_list xs = flow1_of_vec1 (eucl_of_list xs)"
	by (auto simp: flow1_of_list_def flow1_of_vec1_def eucl_of_list_prod
	blinfun_of_list_eq_blinfun_of_vmatrix)

	lemma appr1_rel_def:
	"appr1_rel =
	{((xs, None ), X \<times> UNIV)\| xs X. (xs, X) \<in> appr_rel} \<union>
	{((xs, Some ys), X)\| xs ys X. (xs @ ys, X) \<in> appr_rel \<and> length ys = (length xs)\<^sup>2} O \<langle>br flow1_of_vec1 top\<rangle>set_rel"
	unfolding appr1_rel_internal flow1_of_list_def'[abs_def] appr1_rel_aux ..

	lemmas [autoref_rel_intf] = REL_INTFI[of appr1_rel i_appr1]
	lemma [autoref_op_pat]: "(`) flow1_of_vec1 \<equiv> OP op_image_flow1_of_vec1"
	by auto

	lemma op_image_flow1_of_vec1[autoref_rules]:
	assumes "DIM_precond TYPE('a rvec) E"
	shows "(\<lambda>xs. (take E xs, Some (drop E xs)),
	op_image_flow1_of_vec1::('a::enum) vec1 set\<Rightarrow>_) \<in> appr_rel \<rightarrow> appr1_rel"
	using assms
	apply (auto simp: appr1_rel_def set_rel_br flow1_of_vec1_def[abs_def] intro!: brI elim!: notE
	split: option.splits list.splits)
	apply (rule relcompI[OF _ brI[OF refl]])
	apply (auto simp: power2_eq_square min_def appr_rel_br br_def)
	done

	lemma index_autoref[autoref_rules]:
	"(index, index) \<in> \<langle>lv_rel\<rangle>list_rel \<rightarrow> lv_rel \<rightarrow> nat_rel"
	unfolding index_def[abs_def] find_index_def
	apply parametricity
	apply (auto simp: lv_rel_def br_def list_rel_def)
	using list_of_eucl_eucl_of_list by force

	lemma [autoref_op_pat]: "(`) fst \<equiv> OP op_image_fst"
	by auto

	lemma op_image_fst_flow1[autoref_rules]:
	shows "(\<lambda>x. fst x, op_image_fst::_\<Rightarrow>'n::executable_euclidean_space set) \<in> appr1_rel \<rightarrow> appr_rel"
	apply (auto simp: appr1_rel_internal flow1_of_list_def set_rel_br image_image power2_eq_square dest!: brD)
	apply (auto simp: br_def appr_rel_br length_set_of_appr image_image eucl_of_list_prod
	dest!: set_of_appr_takeD)
	subgoal for xs ys a
	apply (rule image_eqI[where x="take DIM('n) a"])
	by (auto intro!: take_set_of_apprI dest: length_set_of_appr)
	subgoal for xs ys a
	apply (frule set_of_appr_ex_append2[where b=ys])
	apply auto
	subgoal for r
	apply (rule image_eqI[where x="a @ r"])
	apply (auto simp: length_set_of_appr )
	apply (rule eucl_of_list_eqI)
	by (auto dest!: length_set_of_appr)
	done
	done

	lemma op_image_fste_impl[autoref_rules]:
	"((\<lambda>(_, x, _). x), op_image_fste) \<in> appr1e_rel \<rightarrow> appr_rel"
	by (auto simp: image_image split_beta' scaleR2_rel_def
	dest!: op_image_fst_flow1[param_fo] brD)

	lemma DIM_precond_vec1I[autoref_rules_raw]:
	assumes "DIM_precond TYPE('n::enum rvec) E"
	shows "DIM_precond TYPE('n::enum vec1) (E + E*E)"
	using assms
	- by (auto simp: )
	+ by auto

	lemma vec1rep_impl[autoref_rules]:
	"(\<lambda>(a, bs). RETURN (map_option ((@) a) bs), vec1rep) \<in> appr1_rel \<rightarrow> \<langle>\<langle>appr_rel\<rangle>option_rel\<rangle>nres_rel"
	apply (auto simp: vec1rep_def appr1_rel_def set_rel_br appr_rel_def power2_eq_square nres_rel_def
	dest!: brD
	intro!: RETURN_SPEC_refine)
	subgoal for xs ys a b
	apply (rule exI[where x="Some (eucl_of_list ` set_of_appr (xs @ ys))"])
	apply (auto simp: appr_rell_internal image_image lv_rel_def set_rel_br length_set_of_appr
	intro!: brI dest!: brD)
	done
	done

	lemma [autoref_op_pat]: "X \<times> UNIV \<equiv> OP op_times_UNIV $ X" by simp

	lemma op_times_UNIV_impl[autoref_rules]: "(\<lambda>x. (x, None), op_times_UNIV) \<in> appr_rel \<rightarrow> appr1_rel"
	by (auto simp: appr1_rel_internal)

	schematic_goal solve_poincare_plane_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(ni, n) \<in> lv_rel" and CX[autoref_rules]: "(CXi, CX) \<in> appr1_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of (?R), solve_poincare_plane odo n (CX::'n eucl1 set)) \<in> \<langle>appr1_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding solve_poincare_plane_def
	including art
	by autoref_monadic
	concrete_definition solve_poincare_plane_impl for ni CXi uses solve_poincare_plane_impl
	lemmas solve_poincare_plane_impl_refine[autoref_rules] = solve_poincare_plane_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def solve_poincare_plane .

	lemma [autoref_rules_raw]:
	assumes "DIM_precond TYPE((real, 'n::enum) vec) K"
	shows "DIM_precond TYPE(((real, 'n) vec, 'n) vec) (K * K)"
	using assms by auto

	lemma embed1_impl[autoref_rules]:
	assumes "DIM_precond TYPE((real, 'n::enum) vec) E"
	shows "((\<lambda>x. x @ replicate (E * E) 0), embed1::'n rvec\<Rightarrow>_) \<in> lv_rel \<rightarrow> lv_rel"
	using assms
	by (auto simp: lv_rel_def br_def eucl_of_list_prod)

	definition "var_ode_ops_impl = (\<lambda>(ode_ops, _, _, vode_slps).
	(var_ode_ops ode_ops, (case vode_slps of None =>
	let _ = print_msg_impl ''ODE solver not properly initialized: vode_slps missing!'' in
	ode_slps_of (approximate_sets_ode'.var_ode_ops ode_ops)
	\| Some (vode_slps) => vode_slps), None, None))"

	lemma var_ode_ops[autoref_rules]: "(var_ode_ops_impl, var_ode_ops) \<in> ode_ops_rel \<rightarrow> ode_ops_rel"
	by (auto simp: var_ode_ops_impl_def ode_ops_rel_def init_ode_ops_def split: option.splits)

	schematic_goal choose_step1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	"ncc_precond TYPE('n vec1)"
	"ncc_precond TYPE('n rvec)"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel" "(hi, h) \<in> rnv_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	notes [autoref_post_simps] = fst_conv
	shows "(nres_of ?f, choose_step1 odo X h) \<in> \<langle>rnv_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
	unfolding choose_step1_def
	including art
	by autoref_monadic
	concrete_definition choose_step1_impl for Xi hi uses choose_step1_impl
	lemmas [autoref_rules] = choose_step1_impl.refine[autoref_higher_order_rule (1 2 3)]
	sublocale autoref_op_pat_def choose_step1 .

	lemma op_image_zerofst_impl[autoref_rules]:
	"(\<lambda>(_, x). (appr_of_ivl ops (replicate E 0) (replicate E 0), x), op_image_zerofst::'n c1_info set \<Rightarrow> _)
	\<in> appr1_rel \<rightarrow> appr1_rel"
	if "DIM_precond (TYPE('n::executable_euclidean_space)) E"
	using that
	apply (auto simp: appr1_rel_br dest!: brD intro!: brI)
	subgoal by (force simp: c1_info_of_appr_def image_image flow1_of_list_def
	set_of_appr_of_ivl_point_append eucl_of_list_prod c1_info_invar_def length_set_of_appr
	split: option.splits elim!: mem_set_of_appr_appendE cong del: image_cong_simp)
	subgoal for a b c d
	apply (auto simp: c1_info_of_appr_def
	split: option.splits)
	subgoal using set_of_appr_nonempty[of a]
	by (force simp del: set_of_appr_nonempty)
	subgoal
	supply [simp del] = eucl_of_list_take_DIM
	apply (auto simp: image_image set_of_appr_of_ivl_point_append
	flow1_of_list_def)
	apply (frule set_of_appr_ex_append1[where b=a])
	apply auto
	apply (rule image_eqI) prefer 2 apply assumption
	by (auto simp: eucl_of_list_prod c1_info_invar_def
	dest!: length_set_of_appr)
	done
	subgoal
	by (auto simp: c1_info_of_appr_def flow1_of_vec1_def image_image
	set_of_appr_of_ivl_point_append eucl_of_list_prod c1_info_invar_def length_set_of_appr
	split: option.splits elim!: mem_set_of_appr_appendE)
	done
	sublocale autoref_op_pat_def op_image_zerofst .

	lemma op_image_zerofst_vec_impl[autoref_rules]:
	"(\<lambda>x. (appr_of_ivl ops (replicate E 0) (replicate E 0) @ drop E x), op_image_zerofst_vec::'n vec1 set \<Rightarrow> _)
	\<in> appr_rel \<rightarrow> appr_rel"
	if "DIM_precond (TYPE('n::enum rvec)) E"
	using that
	apply (auto simp: appr_rel_br set_of_appr_of_ivl_point_append image_image eucl_of_list_prod
	dest!: brD intro!: brI
	dest: drop_set_of_apprD[where n="CARD('n)"] cong del: image_cong_simp)
	subgoal for a b
	apply (drule set_of_appr_dropD)
	apply safe
	apply (rule image_eqI) defer apply assumption
	apply (auto simp: eucl_of_list_prod)
	apply (rule eucl_of_list_eq_takeI)
	apply simp
	done
	done
	sublocale autoref_op_pat_def op_image_zerofst_vec .

	lemma [autoref_op_pat_def]: "embed1 ` X \<equiv> OP op_image_embed1 $ X"
	by auto

	lemma op_image_embed1_impl[autoref_rules]:
	assumes "DIM_precond TYPE((real, 'n::enum) vec) E"
	shows "(\<lambda>x. x@appr_of_ivl ops (replicate (EE) 0) (replicate (EE) 0), op_image_embed1::'n rvec set \<Rightarrow> _)
	\<in> appr_rel \<rightarrow> appr_rel"
	using assms
	by (force simp: appr_rel_br br_def set_of_appr_of_ivl_point_append set_of_appr_of_ivl_append_point
	image_image eucl_of_list_prod length_set_of_appr)
	sublocale autoref_op_pat_def op_image_embed1 .

	lemma sv_appr1_rel[relator_props]: "single_valued appr1_rel"
	apply (auto simp: appr1_rel_internal appr_rel_def intro!: relator_props single_valued_union)
	apply (auto simp: single_valued_def)
	apply (auto simp: lv_rel_def set_rel_br)
	apply (auto simp: br_def)
	apply (rule imageI)
	apply (metis single_valued_def sv_appr_rell)
	by (metis imageI single_valued_def sv_appr_rell)

	schematic_goal inter_sctn1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E" "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(Xi, (X::'n eucl1 set)) \<in> appr1_rel" "(hi, h) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(nres_of ?f, inter_sctn1_spec X h) \<in> \<langle>appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding inter_sctn1_spec_def
	including art
	by autoref_monadic
	concrete_definition inter_sctn1_impl for Xi hi uses inter_sctn1_impl
	lemmas [autoref_rules] = inter_sctn1_impl.refine[autoref_higher_order_rule (1 2)]
	sublocale autoref_op_pat_def inter_sctn1_spec .

	schematic_goal op_image_fst_coll_nres_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::executable_euclidean_space) E"
	assumes [autoref_rules]: "(XSi, (XS::'n c1_info set)) \<in> clw_rel appr1_rel"
	shows "(RETURN ?r, op_image_fst_coll_nres XS) \<in> \<langle>clw_rel appr_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding op_image_fst_coll_nres_def
	including art
	by (autoref_monadic (plain))
	concrete_definition op_image_fst_coll_nres_impl for XSi uses op_image_fst_coll_nres_impl
	lemmas [autoref_rules] = op_image_fst_coll_nres_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def op_image_fst_coll_nres .

	lemma [autoref_op_pat]: "(`) fst \<equiv> OP op_image_fst_coll"
	by auto
	lemma op_image_fst_coll_impl[autoref_rules]:
	assumes "DIM_precond TYPE('n::executable_euclidean_space) E"
	shows "(op_image_fst_coll_nres_impl, op_image_fst_coll::_\<Rightarrow>'n set) \<in> clw_rel appr1_rel \<rightarrow> clw_rel appr_rel"
	apply rule
	subgoal premises prems for x
	using nres_rel_trans2[OF op_image_fst_coll_nres_spec[OF order_refl]
	op_image_fst_coll_nres_impl.refine[OF assms, simplified, OF prems]]
	by (auto simp: nres_rel_def RETURN_RES_refine_iff)
	done

	schematic_goal fst_safe_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::executable_euclidean_space) E"
	assumes [autoref_rules]: "(XSi, (XS::'n c1_info set)) \<in> clw_rel appr1_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of ?r, fst_safe_coll odo XS) \<in> \<langle>clw_rel appr_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding fst_safe_coll_def
	including art
	by autoref_monadic
	concrete_definition fst_safe_coll_impl for XSi uses fst_safe_coll_impl
	lemmas [autoref_rules] = fst_safe_coll_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def fst_safe_coll_impl .

	lemma [autoref_op_pat]: "(`) flow1_of_vec1 \<equiv> OP op_image_flow1_of_vec1_coll"
	by auto

	lemma op_image_flow1_of_vec1_coll[autoref_rules]:
	"(map (\<lambda>x. (take E x, Some (drop E x))), op_image_flow1_of_vec1_coll::_\<Rightarrow>'n eucl1 set) \<in> clw_rel appr_rel \<rightarrow> clw_rel appr1_rel"
	if "DIM_precond TYPE('n::enum rvec) E"
	apply (rule lift_clw_rel_map)
	apply (rule relator_props)
	apply (rule relator_props)
	unfolding op_image_flow1_of_vec1_coll_def op_image_flow1_of_vec1_def[symmetric]
	apply (rule op_image_flow1_of_vec1)
	using that
	by auto
	sublocale autoref_op_pat_def op_image_flow1_of_vec1_coll .

	schematic_goal vec1reps_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> clw_rel appr1_rel"
	shows "(RETURN ?r, vec1reps X) \<in> \<langle>\<langle>clw_rel appr_rel\<rangle>option_rel\<rangle>nres_rel"
	unfolding vec1reps_def
	including art
	by (autoref_monadic (plain))
	concrete_definition vec1reps_impl for Xi uses vec1reps_impl
	lemma vec1reps_impl_refine[autoref_rules]:
	"(\<lambda>x. RETURN (vec1reps_impl x), vec1reps) \<in> clw_rel appr1_rel \<rightarrow> \<langle>\<langle>clw_rel appr_rel\<rangle>option_rel\<rangle>nres_rel"
	using vec1reps_impl.refine by force
	sublocale autoref_op_pat_def vec1reps .

	abbreviation "intersection_STATE_rel \<equiv>
	(appr1_rel \<times>\<^sub>r \<langle>Id\<rangle>phantom_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r
	clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r bool_rel \<times>\<^sub>r bool_rel)"

	lemma print_set_impl1[autoref_rules]:
	shows "(\<lambda>a s. printing_fun optns a (list_of_appr1 s), print_set1) \<in> bool_rel \<rightarrow> A \<rightarrow> Id"
	by auto
	sublocale autoref_op_pat_def print_set1 .

	lemma trace_set1_impl1[autoref_rules]:
	shows "(\<lambda>s a. tracing_fun optns s (map_option list_of_appr1 a), trace_set1) \<in> string_rel \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> Id"
	by auto
	sublocale autoref_op_pat_def trace_set1 .

	lemma print_set_impl1e[autoref_rules]:
	shows "(\<lambda>a s. printing_fun optns a (list_of_appr1e s), print_set1e) \<in> bool_rel \<rightarrow> A \<rightarrow> Id"
	by auto
	sublocale autoref_op_pat_def print_set1e .
	lemma trace_set1_impl1e[autoref_rules]:
	shows "(\<lambda>s a. tracing_fun optns s (map_option (list_of_appr1e) a), trace_set1e) \<in> string_rel \<rightarrow> \<langle>A\<rangle>option_rel \<rightarrow> Id"
	by auto
	sublocale autoref_op_pat_def trace_set1e .

	schematic_goal split_spec_param1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
	assumes [autoref_rules]: "(Xi, X) \<in> appr1_rel"
	notes [autoref_post_simps] = case_prod_eta
	shows "(nres_of (?f), split_spec_param1 (X::'a eucl1 set)) \<in> \<langle>appr1_rel \<times>\<^sub>r appr1_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_spec_param1_def
	including art
	by autoref_monadic
	concrete_definition split_spec_param1_impl for Xi uses split_spec_param1_impl
	lemmas split_spec_param1_refine[autoref_rules] =
	split_spec_param1_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def split_spec_param1 .

	lemma [autoref_op_pat del]: "{} \<equiv> OP op_empty_default" "{} \<equiv> OP op_empty_coll"
	and [autoref_op_pat_def del]: "get_inter p \<equiv> OP (get_inter p)"
	by simp_all

	lemma fst_image_c1_info_of_appr:
	"c1_info_invar (DIM('a)) X \<Longrightarrow>
	(fst ` c1_info_of_appr X::'a::executable_euclidean_space set) = eucl_of_list ` (set_of_appr (fst X))"
	apply (auto simp: c1_info_invar_def power2_eq_square image_image flow1_of_list_def
	c1_info_of_appr_def flow1_of_vec1_def eucl_of_list_prod split: option.splits)
	subgoal for a b
	by (rule image_eqI[where x="take DIM('a) b"]) (auto intro!: take_set_of_apprI simp: length_set_of_appr)
	subgoal for a b
	apply (frule set_of_appr_ex_append2[where b=a])
	apply auto
	subgoal for r
	by (rule image_eqI[where x="b@r"])
	(auto intro!: eucl_of_list_eqI dest!: length_set_of_appr)
	done
	done

	lemma op_image_fst_colle_impl[autoref_rules]:
	"(map (\<lambda>(_, x, _). x), op_image_fst_colle) \<in> clw_rel appr1e_rel \<rightarrow> clw_rel appr_rel"
	apply (rule fun_relI)
	unfolding appr_rel_br
	apply (rule map_mem_clw_rel_br)
	unfolding appr1_rel_br
	unfolding scaleR2_rel_br
	unfolding clw_rel_br
	apply (auto dest!: brD simp: image_Union split_beta')
	apply (drule bspec, assumption)
	apply auto
	apply (drule bspec, assumption)
	apply (auto simp: fst_image_c1_info_of_appr)
	apply (rule bexI) prefer 2 apply assumption
	apply (auto simp: scaleR2_rel_br scaleR2_def image_def c1_info_of_appr_def
	split: option.splits)
	subgoal for a b c d e f g h i
	apply (rule bexI[where x="take DIM('a) i"])
	by (auto intro!: take_set_of_apprI simp: flow1_of_list_def eucl_of_list_prod c1_info_invar_def
	length_set_of_appr)
	subgoal
	by (auto intro!: take_set_of_apprI simp: flow1_of_vec1_def eucl_of_list_prod
	length_set_of_appr c1_info_invar_def)
	done
	sublocale autoref_op_pat_def op_image_fst_colle .

	lemma is_empty_appr1_rel[autoref_rules]:
	"(\<lambda>_. False, is_empty) \<in> appr1_rel \<rightarrow> bool_rel"
	by (auto simp: appr1_rel_internal set_rel_br) (auto simp: appr_rel_br br_def)
	sublocale autoref_op_pat_def is_empty .

	schematic_goal split_spec_param1e_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::enum rvec) E"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>appr1_rel\<rangle>scaleR2_rel"
	notes [autoref_post_simps] = case_prod_eta
	shows "(nres_of (?f), split_spec_param1e (X::'a eucl1 set)) \<in>
	\<langle>\<langle>appr1_rel\<rangle>scaleR2_rel \<times>\<^sub>r \<langle>appr1_rel\<rangle>scaleR2_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_spec_param1e_def
	including art
	by autoref_monadic
	concrete_definition split_spec_param1e_impl for Xi uses split_spec_param1e_impl
	lemmas split_spec_param1e_refine[autoref_rules] =
	split_spec_param1e_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def split_spec_param1e .

	schematic_goal reduce_spec1_impl:
	"(nres_of ?r, reduce_spec1 C X) \<in> \<langle>appr1_rel\<rangle>nres_rel"
	if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	and [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel" "(Ci, C) \<in> reduce_argument_rel TYPE('b)"
	unfolding reduce_spec1_def
	including art
	by autoref_monadic
	concrete_definition reduce_spec1_impl for Ci Xi uses reduce_spec1_impl
	lemmas reduce_spec1_impl_refine[autoref_rules] = reduce_spec1_impl.refine[autoref_higher_order_rule (1)]
	sublocale autoref_op_pat_def reduce_spec1 .

	schematic_goal reduce_spec1e_impl:
	"(nres_of ?r, reduce_spec1e C X) \<in> \<langle>\<langle>appr1_rel\<rangle>scaleR2_rel\<rangle>nres_rel"
	if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	and [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> \<langle>appr1_rel\<rangle>scaleR2_rel" "(Ci, C) \<in> reduce_argument_rel TYPE('b)"
	unfolding reduce_spec1e_def
	including art
	by autoref_monadic
	concrete_definition reduce_spec1e_impl for Ci Xi uses reduce_spec1e_impl
	lemmas reduce_spec1e_impl_refine[autoref_rules] =
	reduce_spec1e_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def reduce_spec1e .

	lemma eq_spec_impl[autoref_rules]:
	"(\<lambda>a b. RETURN (a = b), eq_spec) \<in> A \<rightarrow> A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	if "PREFER single_valued A"
	using that by (auto simp: nres_rel_def single_valued_def)

	schematic_goal select_with_inter_impl:
	assumes [relator_props]: "single_valued A" "single_valued P"
	assumes [autoref_rules]: "(ci, c) \<in> clw_rel (\<langle>A, P\<rangle>inter_rel)" "(ai, a) \<in> clw_rel A"
	shows "(RETURN ?r, select_with_inter $ c $ a) \<in> \<langle>clw_rel (\<langle>A, P\<rangle>inter_rel)\<rangle>nres_rel"
	unfolding select_with_inter_def
	including art
	by (autoref_monadic (plain))
	concrete_definition select_with_inter_impl for ci ai uses select_with_inter_impl
	lemmas [autoref_rules] = select_with_inter_impl.refine[OF PREFER_sv_D PREFER_sv_D]
	sublocale autoref_op_pat_def select_with_inter .

	schematic_goal choose_step1e_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	"ncc_precond TYPE('n vec1)"
	"ncc_precond TYPE('n rvec)"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1e_rel" "(hi, h) \<in> rnv_rel"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of ?r, choose_step1e odo X h) \<in> \<langle>rnv_rel \<times>\<^sub>r appr1_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr1e_rel\<rangle>nres_rel"
	unfolding choose_step1e_def
	including art
	by autoref_monadic
	concrete_definition choose_step1e_impl for Xi hi uses choose_step1e_impl
	lemmas [autoref_rules] = choose_step1e_impl.refine[autoref_higher_order_rule (1 2 3)]
	sublocale autoref_op_pat_def choose_step1e .

	lemma pre_split_reduce_impl[autoref_rules]:
	"(\<lambda>ro. RETURN (pre_split_reduce ro), pre_split_reduce_spec) \<in> reach_optns_rel \<rightarrow> \<langle>reduce_argument_rel TYPE('b)\<rangle>nres_rel"
	by (auto simp: pre_split_reduce_spec_def nres_rel_def reduce_argument_rel_def RETURN_RES_refine)

	schematic_goal step_split_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1e_rel"
	and [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of (?f), step_split odo ro X)\<in>\<langle>clw_rel appr1e_rel\<rangle>nres_rel"
	using assms
	unfolding step_split_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition step_split_impl for odoi Xi uses step_split_impl
	lemmas [autoref_rules] = step_split_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def step_split .

	schematic_goal width_spec_appr1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> appr1_rel"
	shows "(?r, width_spec_appr1 X) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	unfolding width_spec_appr1_def
	by autoref_monadic
	concrete_definition width_spec_appr1_impl for Xi uses width_spec_appr1_impl
	lemmas width_spec_appr1_impl_refine[autoref_rules] =
	width_spec_appr1_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def width_spec_appr1 .

	schematic_goal split_under_threshold_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	assumes [autoref_rules]: "(thi, th) \<in> rnv_rel" "(Xi, X) \<in> clw_rel (\<langle>appr1_rel\<rangle>scaleR2_rel)"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of ?x, split_under_threshold ro th (X::'n eucl1 set)) \<in> \<langle>clw_rel (\<langle>appr1_rel\<rangle>scaleR2_rel)\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_under_threshold_def
	by autoref_monadic
	concrete_definition split_under_threshold_impl for thi Xi uses split_under_threshold_impl
	lemmas [autoref_rules] = split_under_threshold_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def split_under_threshold .

	schematic_goal pre_intersection_step_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]:
	"(Xi, X::'n eucl1 set) \<in> appr1e_rel"
	"(hi, (h::real)) \<in> rnv_rel"
	and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
	"(odoi, odo) \<in> ode_ops_rel"
	shows "(nres_of ?r, pre_intersection_step odo roptns X h) \<in>
	\<langle>clw_rel (iinfo_rel appr1e_rel) \<times>\<^sub>r clw_rel appr_rel \<times>\<^sub>r clw_rel (iinfo_rel appr1e_rel)\<rangle>nres_rel"
	unfolding pre_intersection_step_def
	including art
	by autoref_monadic
	concrete_definition pre_intersection_step_impl for roptnsi Xi hi uses pre_intersection_step_impl
	lemmas [autoref_rules] = pre_intersection_step_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def pre_intersection_step .

	schematic_goal subset_spec_plane_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a) E"
	assumes [autoref_rules]: "(Xi, X::'a::executable_euclidean_space set) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(nres_of ?R, subset_spec_plane X sctn) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subset_spec_plane_def
	by autoref_monadic
	concrete_definition subset_spec_plane_impl for Xi sctni uses subset_spec_plane_impl
	lemmas [autoref_rules] = subset_spec_plane_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def subset_spec_plane .

	schematic_goal op_eventually_within_sctn_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> appr_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel" "(Si, S) \<in> lvivl_rel"
	shows "(nres_of ?R, op_eventually_within_sctn X sctn S) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding op_eventually_within_sctn_def
	including art
	by autoref_monadic
	concrete_definition op_eventually_within_sctn_impl for Xi sctni Si uses op_eventually_within_sctn_impl
	lemmas [autoref_rules] = op_eventually_within_sctn_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def op_eventually_within_sctn .

	schematic_goal nonzero_component_within_impl:
	"(nres_of ?r, nonzero_component_within odo ivl sctn (PDP::'n eucl1 set)) \<in> \<langle>bool_rel\<rangle>nres_rel"
	if [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	and [autoref_rules]:
	"(ivli, ivl) \<in> lvivl_rel"
	"(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	"(PDPi, PDP) \<in> appr1_rel"
	"(odoi, odo) \<in> ode_ops_rel"
	unfolding nonzero_component_within_def
	including art
	by autoref_monadic
	concrete_definition nonzero_component_within_impl uses nonzero_component_within_impl
	lemmas [autoref_rules] = nonzero_component_within_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def nonzero_component_within .

	schematic_goal disjoints_spec_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(Xi, (X::'n::enum rvec set)) \<in> clw_rel appr_rel" "(Yi, (Y::'n rvec set)) \<in> clw_rel lvivl_rel"
	shows "(nres_of ?f, disjoints_spec X Y) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding disjoints_spec_def op_coll_is_empty_def[symmetric]
	including art
	by autoref_monadic
	concrete_definition disjoints_spec_impl for Xi Yi uses disjoints_spec_impl
	lemmas [autoref_rules] = disjoints_spec_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def disjoints_spec .

	schematic_goal do_intersection_body_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(hi, h) \<in> rnv_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel lvivl_rel"
	and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
	and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and [autoref_rules]: "(STATEi, STATE) \<in> intersection_STATE_rel"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl]
	shows "(nres_of ?f, do_intersection_body odo guards ivl sctn h STATE) \<in> \<langle>intersection_STATE_rel\<rangle>nres_rel"
	unfolding do_intersection_body_def
	by autoref_monadic
	concrete_definition do_intersection_body_impl for odoi guardsi ivli sctni hi STATEi uses do_intersection_body_impl
	lemmas do_intersection_body_impl_refine[autoref_rules] =
	do_intersection_body_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def do_intersection_body .

	schematic_goal do_intersection_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(Xi, X) \<in> appr1_rel" "(hi, h) \<in> rnv_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (\<langle>lvivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel)"
	and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
	and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl]
	shows "(nres_of ?f, do_intersection odo guards ivl sctn (X::'n eucl1 set) h)\<in>
	\<langle>bool_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r clw_rel appr1_rel \<times>\<^sub>r
	clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel)\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding do_intersection_def
	including art
	by autoref_monadic
	concrete_definition do_intersection_impl for odoi guardsi ivli sctni Xi hi uses do_intersection_impl
	lemmas do_intersection_impl_refine[autoref_rules] =
	do_intersection_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def do_intersection .

	schematic_goal tolerate_error1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) dd"
	assumes [autoref_rules]: "(Yi, Y::'n eucl1 set) \<in> appr1e_rel"
	assumes [autoref_rules]: "(Ei, E) \<in> appr1_rel"
	shows "(nres_of ?r, tolerate_error1 Y E) \<in> \<langle>bool_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
	unfolding tolerate_error1_def
	including art
	by autoref_monadic
	concrete_definition tolerate_error1_impl for dd Yi Ei uses tolerate_error1_impl
	lemmas tolerate_error1_refine[autoref_rules] = tolerate_error1_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def tolerate_error1 .

	lemma lower_impl[autoref_rules]: "(lower, lower) \<in> Id \<rightarrow> Id"
	and upper_impl[autoref_rules]: "(lower, lower) \<in> Id \<rightarrow> Id"
	by auto

	schematic_goal step_adapt_time_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(hi, h) \<in> rnv_rel"
	"(Xi, X::'n eucl1 set) \<in> (appr1e_rel)"
	shows "(nres_of ?f, step_adapt_time odo X h)\<in>\<langle>rnv_rel \<times>\<^sub>r appr_rel \<times>\<^sub>r appr1e_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
	unfolding step_adapt_time_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition step_adapt_time_impl for Xi hi uses step_adapt_time_impl
	lemmas [autoref_rules] = step_adapt_time_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def step_adapt_time .


	schematic_goal resolve_step_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(hi, h) \<in> rnv_rel"
	"(Xi, X::'n eucl1 set) \<in> (appr1e_rel)"
	"(roptnsi, roptns) \<in> reach_optns_rel"
	shows "(nres_of ?f, resolve_step odo roptns X h)\<in>\<langle>rnv_rel \<times>\<^sub>r clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r rnv_rel\<rangle>nres_rel"
	unfolding resolve_step_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition resolve_step_impl for roptnsi Xi hi uses resolve_step_impl
	lemmas [autoref_rules] = resolve_step_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def resolve_step .

	sublocale autoref_op_pat_def fst_safe_coll .

	schematic_goal reach_cont_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(XSi, XS) \<in> clw_rel appr1e_rel"
	"(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
	notes [relator_props, autoref_rules_raw] = sv_appr1_rel
	shows "(nres_of (?f::?'f dres), reach_cont odo roptns guards XS)\<in>?R"
	unfolding autoref_tag_defs
	unfolding reach_cont_def
	including art
	by autoref_monadic
	concrete_definition reach_cont_impl for guardsi XSi uses reach_cont_impl
	lemmas reach_cont_ho[autoref_rules] = reach_cont_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def reach_cont .

	schematic_goal reach_cont_par_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(XSi, XS) \<in> clw_rel appr1e_rel"
	"(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
	shows "(nres_of (?f::?'f dres), reach_cont_par odo roptns guards XS)\<in>?R"
	unfolding autoref_tag_defs
	unfolding reach_cont_par_def
	including art
	by autoref_monadic
	concrete_definition reach_cont_par_impl for roptnsi guardsi XSi uses reach_cont_par_impl
	lemmas reach_cont_par_impl_refine[autoref_rules] = reach_cont_par_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def reach_cont_par .

	schematic_goal subset_iplane_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(xi, x::'a set) \<in> iplane_rel lvivl_rel"
	assumes [autoref_rules]: "(icsi, ics) \<in> clw_rel (iplane_rel lvivl_rel)"
	shows "(nres_of ?r, subset_iplane_coll x ics) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subset_iplane_coll_def
	including art
	by autoref_monadic
	concrete_definition subset_iplane_coll_impl uses subset_iplane_coll_impl
	lemmas subset_iplane_coll_impl_refine[autoref_rules] = subset_iplane_coll_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def subset_iplane_coll .


	schematic_goal subsets_iplane_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(xi, x::'a set set) \<in> \<langle>iplane_rel lvivl_rel\<rangle>list_wset_rel"
	assumes [autoref_rules]: "(icsi, ics) \<in> clw_rel (iplane_rel lvivl_rel)"
	shows "(nres_of ?r, subsets_iplane_coll x ics) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subsets_iplane_coll_def
	including art
	by autoref_monadic
	concrete_definition subsets_iplane_coll_impl uses subsets_iplane_coll_impl
	lemmas [autoref_rules] = subsets_iplane_coll_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def subsets_iplane_coll .


	schematic_goal symstart_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	shows "(nres_of ?r, symstart_coll $ odo $ symstart $ XS) \<in> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding symstart_coll_def
	including art
	by autoref_monadic
	concrete_definition symstart_coll_impl for symstartd XSi uses symstart_coll_impl
	lemmas [autoref_rules] = symstart_coll_impl.refine
	sublocale autoref_op_pat_def symstart_coll .

	schematic_goal reach_cont_symstart_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	"(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
	"(roptnsi, roptns) \<in> reach_optns_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	shows "(nres_of (?r), reach_cont_symstart $ odo $ roptns $ symstart $ guards $ XS) \<in>
	\<langle>clw_rel appr_rel \<times>\<^sub>r
	clw_rel (\<langle>iplane_rel lvivl_rel::(_ \<times> 'n rvec set)set, iinfo_rel appr1e_rel\<rangle>info_rel)\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding reach_cont_symstart_def Let_def
	including art
	by autoref_monadic
	concrete_definition reach_cont_symstart_impl for roptnsi symstartd XSi uses reach_cont_symstart_impl
	lemmas [autoref_rules] = reach_cont_symstart_impl.refine
	sublocale autoref_op_pat_def reach_cont_symstart .

	lemma sv_reach_conts_impl_aux:
	"single_valued (clw_rel (iinfo_rel appr1e_rel))" by (auto intro!: relator_props)

	schematic_goal reach_conts_impl:
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(XSi, XS) \<in> clw_rel appr1e_rel"
	"(guardsi, guards::'n rvec set) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roptnsi, roptns) \<in> reach_optns_rel"
	notes [simp] = list_wset_rel_finite[OF sv_reach_conts_impl_aux]
	assumes "(trapi, trap) \<in> ghost_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	shows "(nres_of (?f::?'f dres), reach_conts $ odo $ roptns $ symstart $ trap $ guards $ XS)\<in>?R"
	unfolding autoref_tag_defs
	unfolding reach_conts_def
	including art
	by autoref_monadic
	concrete_definition reach_conts_impl for odoi guardsi XSi uses reach_conts_impl
	lemmas [autoref_rules] = reach_conts_impl.refine
	sublocale autoref_op_pat_def reach_conts .

	lemma get_sctns_autoref[autoref_rules]:
	"(\<lambda>x. RETURN x, get_sctns) \<in> \<langle>R\<rangle>halfspaces_rel \<rightarrow> \<langle>\<langle>\<langle>R\<rangle>sctn_rel\<rangle>list_set_rel\<rangle>nres_rel"
	by (auto simp: get_sctns_def nres_rel_def halfspaces_rel_def br_def intro!: RETURN_SPEC_refine)
	sublocale autoref_op_pat_def get_sctns .

	schematic_goal leaves_halfspace_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes nccp[autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	notes [simp] = ncc_precondD[OF nccp]
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
	assumes [autoref_rules]: "(Xi, X::'n rvec set) \<in> clw_rel appr_rel"
	shows "(nres_of ?r, leaves_halfspace $ odo $ S $ X) \<in> \<langle>\<langle>\<langle>lv_rel\<rangle>sctn_rel\<rangle>option_rel\<rangle>nres_rel"
	unfolding leaves_halfspace_def
	including art
	by autoref_monadic
	concrete_definition leaves_halfspace_impl for Si Xi uses leaves_halfspace_impl
	lemmas [autoref_rules] = leaves_halfspace_impl.refine
	sublocale autoref_op_pat_def leaves_halfspace .

	schematic_goal poincare_start_on_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes ncc2[autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
	assumes ncc2[autoref_rules_raw]: "ncc_precond TYPE('n::enum vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]:
	"(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	"(guardsi, guards) \<in> clw_rel lvivl_rel"
	"(X0i, X0::'n eucl1 set) \<in> clw_rel (appr1e_rel)"
	shows "(nres_of (?f), poincare_start_on $ odo $ guards $ sctn $ X0) \<in>
	\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_start_on_def
	including art
	by autoref_monadic
	concrete_definition poincare_start_on_impl for guardsi sctni X0i uses poincare_start_on_impl
	lemmas [autoref_rules] = poincare_start_on_impl.refine
	sublocale autoref_op_pat_def poincare_start_on .

	lemma isets_of_iivls[autoref_rules]:
	assumes "PREFER single_valued A"
	assumes le[THEN GEN_OP_D, param_fo]: "GEN_OP le (\<le>) ((lv_rel::(_ \<times> 'a::executable_euclidean_space)set) \<rightarrow> lv_rel \<rightarrow> bool_rel)"
	shows "(\<lambda>xs. map (\<lambda>((i, s), x). (appr_of_ivl ops i s, x)) [((i,s), x) \<leftarrow> xs. le i s], isets_of_iivls::_\<Rightarrow>'a set)
	\<in> clw_rel (\<langle>lvivl_rel, A\<rangle>inter_rel) \<rightarrow> clw_rel (\<langle>appr_rel, A\<rangle>inter_rel)"
	apply (rule fun_relI)
	using assms
	apply (auto elim!: single_valued_as_brE)
	unfolding appr_rel_br ivl_rel_br clw_rel_br lvivl_rel_br inter_rel_br
	apply (auto simp: br_def set_of_ivl_def)
	subgoal for a b c d e f g
	apply (rule exI[where x=e])
	apply (rule exI[where x=f])
	apply (rule exI[where x=g])
	apply (rule conjI)
	apply (assumption)
	apply (rule conjI)
	subgoal
	using transfer_operations1[where 'a='a, of "eucl_of_list e" "eucl_of_list f" e f]
	le[of e _ f _, OF lv_relI lv_relI]
	by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def)
	subgoal
	apply (drule bspec, assumption)
	using transfer_operations1[where 'a='a, of "eucl_of_list e" "eucl_of_list f" e f]
	le[of e _ f _, OF lv_relI lv_relI]
	apply (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def)
	using atLeastAtMost_iff apply blast
	done
	done
	subgoal for a b c d e f g
	apply (drule bspec, assumption)
	using transfer_operations1[where 'a='a, of "eucl_of_list d" "eucl_of_list e" d e]
	le[of d _ e _, OF lv_relI lv_relI]
	by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def intro!: bexI)
	subgoal for a b c d e f
	apply (drule bspec, assumption)
	using transfer_operations1[where 'a='a, of "eucl_of_list d" "eucl_of_list e" d e]
	le[of d _ e _, OF lv_relI lv_relI]
	by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def intro!: bexI)
	done
	sublocale autoref_op_pat_def isets_of_iivls .

	lemma [autoref_op_pat]: "X \<times> UNIV \<equiv> OP op_times_UNIV_coll $ X" by simp

	lemma op_times_UNIV_coll_impl[autoref_rules]: "(map (\<lambda>x. (x, None)), op_times_UNIV_coll) \<in> clw_rel appr_rel \<rightarrow> clw_rel appr1_rel"
	apply (rule lift_clw_rel_map)
	apply (rule relator_props)
	apply (rule relator_props)
	unfolding op_times_UNIV_coll_def op_times_UNIV_def[symmetric]
	apply (rule op_times_UNIV_impl)
	by auto
	sublocale autoref_op_pat_def op_times_UNIV_coll .

	schematic_goal do_intersection_core_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> iinfo_rel appr1e_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and csctns[autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and csctns[autoref_rules]: "(ivli, ivl) \<in> lvivl_rel"
	notes [simp] = list_set_rel_finiteD
	shows "(nres_of ?f, do_intersection_core odo guards ivl sctn X) \<in>
	\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding do_intersection_core_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition do_intersection_core_impl for guardsi ivli sctni Xi uses do_intersection_core_impl
	sublocale autoref_op_pat_def do_intersection_core .

	lemmas do_intersection_core_impl_refine[autoref_rules] =
	do_intersection_core_impl.refine[autoref_higher_order_rule(1 2 3)]

	lemma finite_ra1eicacacslsbicae1lw: "(xc, x'c) \<in> \<langle>\<langle>rnv_rel, appr1e_rel\<rangle>info_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel
	(\<langle>appr_rel,
	\<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r
	clw_rel appr1e_rel\<rangle>list_wset_rel \<Longrightarrow> finite x'c"
	for x'c::"('n::enum eucl1 set * 'n eucl1 set * 'n eucl1 set * 'n rvec set * 'n eucl1 set) set"
	apply (rule list_wset_rel_finite)
	by (auto intro!: relator_props)

	schematic_goal do_intersection_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE((real, 'n::enum) vec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(Xi, X::'n eucl1 set) \<in> clw_rel (iinfo_rel appr1e_rel)"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and csctns[autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and csctns[autoref_rules]: "(ivli, ivl) \<in> lvivl_rel"
	notes [simp] = finite_ra1eicacacslsbicae1lw[where 'n='n]
	shows "(nres_of ?f, do_intersection_coll odo guards ivl sctn X) \<in>
	\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding do_intersection_coll_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition do_intersection_coll_impl for guardsi ivli sctni Xi uses do_intersection_coll_impl
	lemmas [autoref_rules] = do_intersection_coll_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def do_intersection_coll .

	schematic_goal op_enlarge_ivl_sctn_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(ivli, ivl::'a set) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel" "(di, d) \<in> rnv_rel"
	shows "(nres_of ?R, op_enlarge_ivl_sctn $ ivl $ sctn $ d) \<in> \<langle>lvivl_rel\<rangle>nres_rel"
	unfolding op_enlarge_ivl_sctn_def
	including art
	by autoref_monadic
	concrete_definition op_enlarge_ivl_sctn_impl for ivli sctni di uses op_enlarge_ivl_sctn_impl
	lemmas [autoref_rules] = op_enlarge_ivl_sctn_impl.refine
	sublocale autoref_op_pat_def op_enlarge_ivl_sctn .

	schematic_goal resolve_ivlplanes_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS::('n rvec set \<times> 'n eucl1 set) set) \<in> \<langle>iplane_rel lvivl_rel \<times>\<^sub>r clw_rel (iinfo_rel appr1e_rel)\<rangle>list_wset_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
	notes [intro, simp] = list_set_rel_finiteD
	shows "(nres_of ?r, resolve_ivlplanes odo guards ivlplanes XS) \<in>
	\<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r clw_rel (isbelows_rel appr_rel)\<rangle>list_wset_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding resolve_ivlplanes_def
	including art
	by autoref_monadic
	concrete_definition resolve_ivlplanes_impl for guardsi ivlplanesi XSi uses resolve_ivlplanes_impl
	lemmas [autoref_rules] = resolve_ivlplanes_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def resolve_ivlplanes .

	schematic_goal poincare_onto_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \<in> clw_rel appr_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	assumes [autoref_rules]: "((), trap) \<in> ghost_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	notes [intro, simp] = list_set_rel_finiteD
	shows "(nres_of ?r, poincare_onto $ odo $ ro $ symstart $ trap $ guards $ ivlplanes $ XS $ CXS) \<in>
	\<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
	\<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_def
	including art
	by autoref_monadic
	concrete_definition poincare_onto_impl for odoi roi symstarti guardsi ivlplanesi XSi uses poincare_onto_impl
	lemmas [autoref_rules] = poincare_onto_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def poincare_onto .

	schematic_goal empty_remainders_impl:
	assumes [autoref_rules]:
	"(PSi, PS) \<in> \<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
	\<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
	shows "(nres_of ?r, empty_remainders PS) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding empty_remainders_def
	including art
	by autoref_monadic
	concrete_definition empty_remainders_impl uses empty_remainders_impl

	lemmas empty_remainders_impl_refine[autoref_rules] = empty_remainders_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def empty_remainders .

	lemma empty_trap_impl[autoref_rules]: "((), empty_trap) \<in> ghost_rel"
	by (auto intro!: ghost_relI)
	sublocale autoref_op_pat_def empty_trap .

	lemma empty_symstart_impl:\<comment> \<open>why this? \<close>
	"((\<lambda>x. nres_of (dRETURN ([], [x]))), empty_symstart) \<in>
	appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding empty_symstart_def
	using mk_coll[unfolded autoref_tag_defs, OF sv_appr1e_rel[OF sv_appr1_rel], param_fo]
	by (auto intro!: nres_relI simp:)
	lemma empty_symstart_nres_rel[autoref_rules]:
	"((\<lambda>x. RETURN ([], [x])), empty_symstart::'n::enum eucl1 set\<Rightarrow>_) \<in>
	appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	using mk_coll[OF PREFER_I[of single_valued, OF sv_appr1e_rel[OF sv_appr1_rel]], param_fo, of x y for x and y::"'n eucl1 set"]
	by (auto simp: mk_coll_def[abs_def] nres_rel_def)
	sublocale autoref_op_pat_def empty_symstart .
	lemma empty_symstart_dres_nres_rel:
	"((\<lambda>x. dRETURN ([], [x])), empty_symstart::'n::enum eucl1 set\<Rightarrow>_) \<in>
	(appr1e_rel) \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>dres_nres_rel"
	using mk_coll[OF PREFER_I[of single_valued, OF sv_appr1e_rel[OF sv_appr1_rel]], param_fo, of x y for x and y::"'n eucl1 set"]
	by (auto simp: mk_coll_def[abs_def] dres_nres_rel_def)


	schematic_goal poincare_onto_empty_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	assumes [autoref_rules]: "(CXSi, CXS::'n rvec set) \<in> clw_rel appr_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	notes [intro, simp] = list_set_rel_finiteD
	shows "(nres_of (?r), poincare_onto_empty odo ro guards ivlplanes XS CXS) \<in>
	\<langle>\<langle>clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel
	\<times>\<^sub>r clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_empty_def
	including art
	apply (rule autoref_monadicI)
	apply (autoref phases: id_op rel_inf fix_rel)\<comment> \<open>TODO: what is going wrong here?\<close>
	apply (simp only: autoref_tag_defs)
	apply (rule poincare_onto_impl.refine[unfolded autoref_tag_defs])
	apply fact+
	apply (rule ghost_relI)
	apply (rule empty_symstart_impl)
	apply refine_transfer
	apply refine_transfer
	done

	concrete_definition poincare_onto_empty_impl for guardsi XSi CXSi uses poincare_onto_empty_impl
	lemmas [autoref_rules] = poincare_onto_empty_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def poincare_onto_empty .

	lemma sv_thingy: "single_valued (clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	\<langle>lv_rel\<rangle>ivl_rel \<times>\<^sub>r
	\<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
	clw_rel
	(\<langle>appr_rel,
	\<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r
	clw_rel appr_rel)"
	by (intro relator_props)

	schematic_goal poincare_onto2_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> clw_rel (iplane_rel lvivl_rel)"
	and osctns[autoref_rules]: "(ivlplanesi, ivlplanes) \<in> clw_rel (iplane_rel lvivl_rel)"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	assumes [autoref_rules]: "((), trap) \<in> ghost_rel"
	notes [intro, simp] = list_set_rel_finiteD list_wset_rel_finite[OF sv_thingy]
	shows "(nres_of (?r), poincare_onto2 $ odo $ ro $ symstart $ trap $ guards $ ivlplanes $ XS) \<in>
	\<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
	clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto2_def
	including art
	by autoref_monadic
	concrete_definition poincare_onto2_impl for odoi guardsi XSi uses poincare_onto2_impl
	lemmas [autoref_rules] = poincare_onto2_impl.refine
	sublocale autoref_op_pat_def poincare_onto2 .

	schematic_goal width_spec_ivl_impl:
	assumes [autoref_rules]: "(Mi, M) \<in> nat_rel" "(xi, x) \<in> lvivl_rel"
	shows "(RETURN ?r, width_spec_ivl M x) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	unfolding width_spec_ivl_def
	including art
	by (autoref_monadic (plain))
	concrete_definition width_spec_ivl_impl for Mi xi uses width_spec_ivl_impl

	lemmas width_spec_ivl_impl_refine[autoref_rules]
	= width_spec_ivl_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def width_spec_ivl .

	schematic_goal partition_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(xsi, xs::'a set)\<in> clw_rel lvivl_rel" "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of (?f), partition_ivl ro xs)\<in>\<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding partition_ivl_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition partition_ivl_impl for roi xsi uses partition_ivl_impl
	lemmas [autoref_rules] = partition_ivl_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def partition_ivl .

	schematic_goal vec1repse_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> clw_rel appr1e_rel"
	shows "(nres_of ?r, vec1repse X) \<in> \<langle>\<langle>clw_rel appre_rel\<rangle>option_rel\<rangle>nres_rel"
	unfolding vec1repse_def
	including art
	by autoref_monadic
	concrete_definition vec1repse_impl for Xi uses vec1repse_impl
	lemmas vec1repse_impl_refine[autoref_rules] = vec1repse_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def vec1repse .

	schematic_goal scaleR2_rep1_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(Yi, Y::'n vec1 set) \<in> appre_rel"
	shows "(nres_of ?r, scaleR2_rep1 Y) \<in> \<langle>elvivl_rel\<rangle>nres_rel"
	unfolding scaleR2_rep1_def
	including art
	by autoref_monadic
	concrete_definition scaleR2_rep1_impl uses scaleR2_rep1_impl
	lemmas [autoref_rules] = scaleR2_rep1_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def scaleR2_rep1 .

	schematic_goal ivlse_of_setse_impl:
	"(nres_of ?r, ivlse_of_setse X) \<in> \<langle>clw_rel elvivl_rel\<rangle>nres_rel"
	if [autoref_rules_raw]:"DIM_precond TYPE('n::enum rvec) E"
	and [autoref_rules]: "(Xi, X::'n vec1 set) \<in> clw_rel (appre_rel)"
	unfolding ivlse_of_setse_def
	including art
	by autoref_monadic
	concrete_definition ivlse_of_setse_impl uses ivlse_of_setse_impl
	lemmas [autoref_rules] = ivlse_of_setse_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def ivlse_of_setse .

	schematic_goal setse_of_ivlse_impl:
	"(nres_of ?r, setse_of_ivlse X) \<in> \<langle>clw_rel (appre_rel)\<rangle>nres_rel"
	if [autoref_rules]: "(Xi, X) \<in> clw_rel elvivl_rel"
	unfolding setse_of_ivlse_def
	including art
	by autoref_monadic
	concrete_definition setse_of_ivlse_impl uses setse_of_ivlse_impl
	lemmas setse_of_ivlse_impl_refine[autoref_rules] =
	setse_of_ivlse_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def setse_of_ivlse .

	lemma op_image_flow1_of_vec1_colle[autoref_rules]:
	"(map (\<lambda>(lu, x). (lu, (take E x, Some (drop E x)))), op_image_flow1_of_vec1_colle::_\<Rightarrow>'n eucl1 set) \<in> clw_rel appre_rel \<rightarrow> clw_rel appr1e_rel"
	if "DIM_precond TYPE('n::enum rvec) E"
	apply (rule lift_clw_rel_map)
	apply (rule relator_props)
	apply (rule relator_props)
	apply (rule relator_props)
	apply (rule relator_props)
	apply (rule lift_scaleR2)
	unfolding op_image_flow1_of_vec1_colle_def op_image_flow1_of_vec1_coll_def op_image_flow1_of_vec1_def[symmetric]
	apply (rule op_image_flow1_of_vec1)
	using that
	subgoal by force
	subgoal for l u x
	unfolding op_image_flow1_of_vec1_def flow1_of_vec1_def scaleR2_def
	apply (auto simp: image_def vimage_def)
	subgoal for a b c d e
	apply (rule exI[where x="c *\<^sub>R e"])
	apply (auto simp: blinfun_of_vmatrix_scaleR)
	apply (rule exI[where x="c"])
	apply auto
	apply (rule bexI) prefer 2 apply assumption
	apply auto
	done
	subgoal for a b c d e
	apply (rule exI[where x="c"])
	apply (auto simp: blinfun_of_vmatrix_scaleR)
	apply (rule exI[where x="blinfun_of_vmatrix e"])
	apply auto
	apply (rule bexI) prefer 2 apply assumption
	apply auto
	done
	done
	subgoal by auto
	done
	sublocale autoref_op_pat_def op_image_flow1_of_vec1_colle .

	schematic_goal okay_granularity_impl:
	assumes [autoref_rules]: "(ivli,ivl::'n::enum vec1 set)\<in> lvivl_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of ?f, okay_granularity ro ivl) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding okay_granularity_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition okay_granularity_impl for roi ivli uses okay_granularity_impl
	lemmas [autoref_rules] = okay_granularity_impl.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def okay_granularity .

	lemma le_post_inter_granularity_op[autoref_rules]:
	"(\<lambda>roi (ls, us). RETURN (width_appr ops optns (appr_of_ivl ops ls us) \<le> post_inter_granularity roi),
	(le_post_inter_granularity_op::_\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_)) \<in>
	(reach_optns_rel \<rightarrow> lvivl_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel)"
	by (auto simp: nres_rel_def le_post_inter_granularity_op_def)
	sublocale autoref_op_pat_def le_post_inter_granularity_op .

	schematic_goal partition_set_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(xsi,xs::'n eucl1 set)\<in> clw_rel appr1e_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of (?f), partition_set ro xs) \<in> \<langle>clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding partition_set_def
	including art
	by autoref_monadic

	concrete_definition partition_set_impl for roi xsi uses partition_set_impl
	lemmas [autoref_rules] = partition_set_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def partition_set .

	schematic_goal partition_sets_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(xsi,xs::(bool \<times> 'n eucl1 set \<times> _)set)\<in>
	\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel
	\<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
	clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	shows "(nres_of (?f), partition_sets ro xs)\<in>\<langle>clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding partition_sets_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition partition_sets_impl for roi xsi uses partition_sets_impl
	lemmas [autoref_rules] = partition_sets_impl.refine[autoref_higher_order_rule(1)]
	sublocale autoref_op_pat_def partition_sets .

	lemma [autoref_rules]:
	assumes "PREFER single_valued A"
	shows "(\<lambda>xs. case xs of [x] \<Rightarrow> RETURN x \| _ \<Rightarrow> SUCCEED, singleton_spec) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
	using assms
	by (auto simp: nres_rel_def singleton_spec_def list_wset_rel_def set_rel_br
	split: list.splits elim!: single_valued_as_brE dest!: brD
	intro!: RETURN_SPEC_refine brI)
	sublocale autoref_op_pat_def singleton_spec .

	lemma closed_ivl_prod8_list_rel:
	assumes "(xl, x'l)
	\<in> \<langle>bool_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	clw_rel appr1e_rel \<times>\<^sub>r
	\<langle>lv_rel\<rangle>ivl_rel \<times>\<^sub>r
	\<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r clw_rel (\<langle>appr_rel, \<langle>lv_rel\<rangle>sbelows_rel\<rangle>inter_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel"
	shows "(\<forall>(b, X, PS1, PS2, R, ivl, sctn, CX, CXS)\<in>x'l. closed ivl)"
	using assms
	unfolding list_wset_rel_def set_rel_sv[OF single_valued_Id_arbitrary_interface]
	apply (subst (asm) set_rel_sv)
	subgoal
	by (auto simp: Id_arbitrary_interface_def intro!: relator_props intro: single_valuedI)
	by (auto simp: Id_arbitrary_interface_def)

	lemma
	poincare_onto_series_rec_list_eq:\<comment> \<open>TODO: here is a problem if interrupt gets uncurried, too\<close>
	"poincare_onto_series odo interrupt trap guards XS ivl sctn ro = rec_list
	(\<lambda>(((((trap), XS0), ivl), sctn), ro).
	let guard0 = mk_coll (mk_inter ivl (plane_of sctn))
	in ASSUME (closed guard0) \<bind>
	(\<lambda>_. (poincare_onto2 odo (ro ::: reach_optns_rel) (interrupt:::appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel) trap
	(op_empty_coll ::: clw_rel (\<langle>\<langle>lv_rel\<rangle>ivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel)) guard0 XS0 :::
	\<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
	clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel) \<bind>
	(\<lambda>(XS1).
	singleton_spec XS1 \<bind>
	(\<lambda>(b, X, PS1, PS2, R, ivl', sctn', CX, CXS). CHECKs ''poincare_onto_series: last return!'' (ivl' = ivl \<and> sctn' = sctn) \<bind> (\<lambda>_. RETURN PS2)))))
	(\<lambda>x xs rr (((((trap), XS0), ivl), sctn), ro0).
	case x of
	(guard, ro) \<Rightarrow>
	ASSUME (closed ivl) \<bind>
	(\<lambda>_. let guard0 = mk_coll (mk_inter ivl (plane_of sctn))
	in ASSUME (closed guard0) \<bind>
	(\<lambda>_. ASSUME (\<forall>(guard, ro)\<in>set (x # xs). closed guard) \<bind>
	(\<lambda>_. let guardset = \<Union>(guard, ro)\<in>set ((guard0, ro0) # xs). guard
	in (poincare_onto2 odo ro (interrupt:::appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel) trap (guardset ::: clw_rel (\<langle>\<langle>lv_rel\<rangle>ivl_rel, \<langle>lv_rel\<rangle>plane_rel\<rangle>inter_rel))
	guard XS0 :::
	\<langle>\<langle>bool_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r clw_rel appr1e_rel \<times>\<^sub>r lvivl_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>sctn_rel \<times>\<^sub>r
	clw_rel (isbelows_rel appr_rel) \<times>\<^sub>r clw_rel appr_rel\<rangle>list_wset_rel\<rangle>nres_rel) \<bind>
	(\<lambda>(XS1).
	ASSUME (\<forall>(b, X, PS, PS2, R, ivl, sctn, CX, CXS)\<in>XS1. closed ivl) \<bind>
	(\<lambda>_.
	partition_sets ro XS1 \<bind>
	(\<lambda>XS2. fst_safe_colle odo XS2 \<bind> (\<lambda>_. rr (((((trap), XS2), ivl), sctn), ro0 ::: reach_optns_rel) \<bind> RETURN))))))))
	guards (((((trap), XS), ivl), sctn), ro)"
	by (induction guards arbitrary: XS ivl sctn ro) (auto simp: split_beta' split: prod.splits)

	schematic_goal poincare_onto_series_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS::'n eucl1 set) \<in> clw_rel appr1e_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel" "(ivli, ivl) \<in> lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	and [autoref_rules]: "((), trap) \<in> ghost_rel"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_prod3_list_rel closed_clw_rel_iplane_rel
	closed_ivl_prod8_list_rel
	notes [autoref_rules_raw] = ghost_relI[of x for x::"'n eucl1 set"]
	shows "(nres_of ?r, poincare_onto_series $ odo $ symstart $ trap $ guards $ XS $ ivl $ sctn $ ro) \<in> \<langle>clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_series_rec_list_eq
	including art
	apply autoref_monadic
	apply (rule ghost_relI)
	apply (autoref phases: trans)
	apply (autoref phases: trans)
	apply (rule ghost_relI)
	apply (autoref phases: trans)
	apply (autoref phases: trans)
	apply simp
	apply (autoref phases: trans)
	apply (autoref phases: trans)
	apply simp
	apply (refine_transfer)
	done

	concrete_definition poincare_onto_series_impl for symstartd guardsi XSi ivli sctni roi uses poincare_onto_series_impl
	lemmas [autoref_rules] = poincare_onto_series_impl.refine
	sublocale autoref_op_pat_def poincare_onto_series .

	schematic_goal poincare_onto_from_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
	and [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
	and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
	and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	and [autoref_rules]: "((), trap) \<in> ghost_rel"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
	shows "(nres_of ?r, poincare_onto_from $ odo $ symstart $ trap $ S $ guards $ ivl $ sctn $ ro $ XS) \<in>
	\<langle>clw_rel appr1e_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_from_def
	including art
	by autoref_monadic

	concrete_definition poincare_onto_from_impl for symstartd Si guardsi ivli sctni roi XSi uses poincare_onto_from_impl
	lemmas [autoref_rules] = poincare_onto_from_impl.refine
	sublocale autoref_op_pat_def poincare_onto_from .

	schematic_goal subset_spec1_impl:
	"(nres_of ?r, subset_spec1 R P dP) \<in> \<langle>bool_rel\<rangle>nres_rel"
	if [autoref_rules]:
	"(Ri, R) \<in> appr1_rel"
	"(Pimpl, P) \<in> lvivl_rel"
	"(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
	unfolding subset_spec1_def
	including art
	by autoref_monadic
	lemmas [autoref_rules] = subset_spec1_impl[autoref_higher_order_rule]
	sublocale autoref_op_pat_def subset_spec1 .

	schematic_goal subset_spec1_collc:
	"(nres_of (?f), subset_spec1_coll R P dP) \<in> \<langle>bool_rel\<rangle>nres_rel"
	if [autoref_rules]:
	"(Ri, R) \<in> clw_rel appr1_rel"
	"(Pimpl, P) \<in> lvivl_rel"
	"(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
	unfolding subset_spec1_coll_def
	including art
	by autoref_monadic
	concrete_definition subset_spec1_collc for Ri Pimpl dPi uses subset_spec1_collc
	lemmas subset_spec1_collc_refine[autoref_rules] = subset_spec1_collc.refine[autoref_higher_order_rule]
	sublocale autoref_op_pat_def subset_spec1_coll .

	schematic_goal one_step_until_time_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
	assumes [autoref_rules]: "(phi, ph) \<in> bool_rel"
	assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
	notes [autoref_tyrel] = ty_REL[where 'a="real" and R="Id"]
	shows "(nres_of ?f, one_step_until_time odo X0 ph t1)\<in>\<langle>appr1e_rel \<times>\<^sub>r \<langle>clw_rel appr_rel\<rangle>phantom_rel\<rangle>nres_rel"
	unfolding one_step_until_time_def[abs_def]
	including art
	by autoref_monadic
	concrete_definition one_step_until_time_impl for odoi X0i phi t1i uses one_step_until_time_impl
	lemmas one_step_until_time_impl_refine[autoref_rules] = one_step_until_time_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def one_step_until_time .

	schematic_goal ivl_of_appr1_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules]: "(Xi, X::'n::enum rvec set) \<in> clw_rel appr_rel"
	shows "(nres_of ?r, ivl_of_eucl_coll X) \<in> \<langle>appr1_rel\<rangle>nres_rel"
	unfolding ivl_of_eucl_coll_def
	by autoref_monadic
	concrete_definition ivl_of_appr1_coll_impl uses ivl_of_appr1_coll_impl
	sublocale autoref_op_pat_def ivl_of_eucl_coll .
	lemmas ivl_of_appr1_coll_impl_refine[autoref_rules] =
	ivl_of_appr1_coll_impl.refine[autoref_higher_order_rule(1)]

	schematic_goal one_step_until_time_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
	assumes [autoref_rules]: "(phi, ph) \<in> bool_rel"
	assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
	assumes [autoref_rules]: "(t2i, t2) \<in> rnv_rel"
	shows "(nres_of ?r, one_step_until_time_ivl odo X0 ph t1 t2) \<in> \<langle>appr1e_rel \<times>\<^sub>r \<langle>clw_rel appr_rel\<rangle>phantom_rel\<rangle>nres_rel"
	unfolding one_step_until_time_ivl_def
	including art
	by autoref_monadic
	concrete_definition one_step_until_time_ivl_impl for X0i phi t1i t2i uses one_step_until_time_ivl_impl
	lemmas [autoref_rules] = one_step_until_time_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def one_step_until_time_ivl .


	schematic_goal poincare_onto_from_in_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
	and [autoref_rules]: "(Si, S) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
	and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
	and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	assumes [autoref_rules]: "(symstarti, symstart::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres)
	\<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	assumes [unfolded autoref_tag_defs, refine_transfer]: "\<And>X. TRANSFER (nres_of (symstartd X) \<le> symstarti X)"
	and [autoref_rules]: "((), trap) \<in> ghost_rel"
	"(Pimpl, P) \<in> lvivl_rel"
	"(dPi, dP) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
	shows "(nres_of ?r, poincare_onto_from_in_ivl
	$ odo $ symstart $ trap $ S $ guards $ ivl $ sctn $ ro $ XS $ P $ dP) \<in>
	\<langle>bool_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_from_in_ivl_def
	including art
	by autoref_monadic

	concrete_definition poincare_onto_from_in_ivl_impl for E odoi symstartd Si guardsi ivli sctni roi XSi Pimpl dPi uses poincare_onto_from_in_ivl_impl
	lemmas [autoref_rules] = poincare_onto_from_in_ivl_impl.refine
	sublocale autoref_op_pat_def poincare_onto_from_in_ivl .

	lemma TRANSFER_I: "x \<Longrightarrow> TRANSFER x"
	by simp

	lemma dres_nres_rel_nres_relD: "(symstartd, symstart) \<in> A \<rightarrow> \<langle>B\<rangle>dres_nres_rel \<Longrightarrow> (\<lambda>x. nres_of (symstartd x), symstart) \<in> A \<rightarrow> \<langle>B\<rangle>nres_rel"
	by (auto simp: dres_nres_rel_def nres_rel_def dest!: fun_relD)

	lemma c1_info_of_apprsI:
	assumes "(b, a) \<in> clw_rel appr1_rel"
	assumes "x \<in> a"
	shows "x \<in> c1_info_of_apprs b"
	using assms
	by (auto simp: appr1_rel_br clw_rel_br c1_info_of_apprs_def dest!: brD)

	lemma clw_rel_appr1_relI:
	assumes "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invar CARD('n::enum) X"
	shows "(XS, c1_info_of_apprs XS::('n rvec\<times>_)set) \<in> clw_rel appr1_rel"
	by (auto simp: appr1_rel_br clw_rel_br c1_info_of_apprs_def intro!: brI assms)

	lemma c1_info_of_appr'I:
	assumes "(b, a) \<in> \<langle>clw_rel appr1_rel\<rangle>phantom_rel"
	assumes "x \<in> a"
	shows "x \<in> c1_info_of_appr' b"
	using assms
	by (auto simp add: c1_info_of_appr'_def intro!: c1_info_of_apprsI split: option.splits)

	lemma appr1e_relI:
	assumes "c1_info_invare CARD('n::enum) X0i"
	shows "(X0i, c1_info_of_appre X0i::'n eucl1 set) \<in> appr1e_rel"
	using assms
	apply (cases X0i)
	apply (auto simp: scaleR2_rel_def c1_info_of_appre_def c1_info_invare_def)
	apply (rule relcompI)
	apply (rule prod_relI)
	apply (rule IdI)
	apply (rule appr1_relI)
	apply (auto simp: vimage_def intro!: brI)
	apply (metis ereal_dense2 less_imp_le)
	apply (rule relcompI)
	apply (rule prod_relI)
	apply (rule IdI)
	apply (rule appr1_relI)
	apply (auto simp: vimage_def intro!: brI)
	by (metis basic_trans_rules(23) ereal_cases ereal_less_eq(1) ereal_top order_eq_refl)

	lemma c1_info_of_apprI:
	assumes "(b, a) \<in> appr1_rel"
	assumes "x \<in> a"
	shows "x \<in> c1_info_of_appr b"
	using assms
	apply (auto simp add: c1_info_of_appr_def c1_info_invar_def appr1_rel_internal appr_rel_def lv_rel_def
	set_rel_br
	dest!: brD
	split: option.splits)
	apply (auto simp add: appr_rell_internal dest!: brD)
	done

	lemma c1_info_of_appreI:
	assumes "(lub, a) \<in> appr1e_rel"
	assumes "x \<in> a"
	shows "x \<in> c1_info_of_appre lub"
	using assms
	apply (auto simp add: scaleR2_def c1_info_of_appre_def image_def vimage_def scaleR2_rel_def
	dest!: brD
	intro!: c1_info_of_apprsI split: option.splits)
	subgoal for a b c d e f g h i
	apply (rule exI[where x=g])
	apply (rule conjI, assumption)+
	apply (rule bexI)
	prefer 2
	apply (rule c1_info_of_apprI) apply assumption
	apply assumption apply simp
	done
	done

	lemma c1_info_of_apprseI:
	assumes "(b, a) \<in> clw_rel appr1e_rel"
	assumes "x \<in> a"
	shows "x \<in> c1_info_of_apprse b"
	using assms
	by (force simp: appr1_rel_br scaleR2_rel_br clw_rel_br c1_info_of_appre_def c1_info_of_apprse_def
	dest!: brD)

	lemma clw_rel_appr1e_relI:
	assumes "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n::enum) X"
	shows "(XS, c1_info_of_apprse XS::('n rvec\<times>_)set) \<in> clw_rel appr1e_rel"
	using assms
	apply (auto simp: c1_info_of_apprse_def c1_info_of_appre_def c1_info_invare_def)
	unfolding appr1_rel_br scaleR2_rel_br clw_rel_br
	apply (rule brI)
	apply (auto simp: c1_info_invar_def vimage_def)
	subgoal premises prems for a b c d
	using prems(1)[OF prems(2)]
	by (cases a; cases b) auto
	done

	schematic_goal one_step_until_time_ivl_in_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(X0i, X0::'n eucl1 set) \<in> appr1e_rel"
	assumes [autoref_rules]: "(t1i, t1) \<in> rnv_rel"
	assumes [autoref_rules]: "(t2i, t2) \<in> rnv_rel"
	"(Ri, R) \<in> lvivl_rel"
	"(dRi, dR) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
	shows "(nres_of ?r, one_step_until_time_ivl_in_ivl odo X0 t1 t2 R dR) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding one_step_until_time_ivl_in_ivl_def
	including art
	by autoref_monadic
	concrete_definition one_step_until_time_ivl_in_ivl_impl for odoi X0i t1i t2i Ri dRi
	uses one_step_until_time_ivl_in_ivl_impl
	lemmas one_step_until_time_ivl_in_ivl_impl_refine[autoref_rules] =
	one_step_until_time_ivl_in_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]
	sublocale autoref_op_pat_def one_step_until_time_ivl_in_ivl .

	schematic_goal poincare_onto_in_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('n::enum rvec) E"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n::enum rvec)"
	assumes [autoref_rules_raw]: "ncc_precond TYPE('n vec1)"
	assumes [autoref_rules]: "(odoi, odo) \<in> ode_ops_rel"
	assumes [autoref_rules]: "(XSi, XS) \<in> clw_rel appr1e_rel"
	and osctns[autoref_rules]: "(guardsi, guards) \<in> \<langle>clw_rel (iplane_rel lvivl_rel)\<times>\<^sub>rreach_optns_rel\<rangle>list_rel"
	and civl[autoref_rules]: "(ivli, ivl::'n rvec set) \<in> lvivl_rel"
	and csctns[autoref_rules]: "(sctni, sctn::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	and [autoref_rules]: "(roi, ro) \<in> reach_optns_rel"
	"(Pimpl, P::'n rvec set) \<in> lvivl_rel"
	"(dPi, dP:: ((real, 'n) vec, 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>(default_rel UNIV)"
	notes [intro, simp] = list_set_rel_finiteD closed_ivl_rel[OF civl] closed_ivl_prod3_list_rel
	shows "(nres_of ?r,
	poincare_onto_in_ivl odo guards ivl sctn ro XS P dP) \<in>
	\<langle>bool_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding poincare_onto_in_ivl_def
	including art
	apply (rule autoref_monadicI)
	apply (autoref phases: id_op rel_inf fix_rel)
	apply (autoref_trans_step)
	apply (autoref_trans_step)
	apply (autoref_trans_step)
	apply (simp only: autoref_tag_defs)
	apply (rule poincare_onto_series_impl.refine[unfolded autoref_tag_defs])\<comment> \<open>TODO: why?\<close>
	apply fact+
	apply (rule empty_symstart_impl)
	apply refine_transfer
	apply (rule ghost_relI)
	apply (autoref phases: trans)
	unfolding autoref_tag_defs
	by refine_transfer

	concrete_definition poincare_onto_in_ivl_impl for E odoi guardsi ivli sctni roi XSi Pimpl dPi
	uses poincare_onto_in_ivl_impl
	lemmas [autoref_rules] = poincare_onto_in_ivl_impl.refine[autoref_higher_order_rule(1 2 3)]


	subsection \<open>Main (executable) interfaces to the ODE solver, with initialization\<close>

	definition "carries_c1 = Not o Option.is_none o (snd o snd)"

	definition "solves_poincare_map odo symstart S guards ivli sctni roi XS P dP \<longleftrightarrow>
	poincare_onto_from_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 (hd XS)) odo) symstart S guards ivli sctni
	roi XS P dP = dRETURN True"

	definition "solves_poincare_map' odo S = solves_poincare_map odo (\<lambda>x. dRETURN ([], [x])) [S]"

	definition "one_step_until_time_ivl_in_ivl_check odo X t0 t1 Ri dRi \<longleftrightarrow>
	one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 Ri dRi = dRETURN True"

	definition "solves_poincare_map_onto odo guards ivli sctni roi XS P dP \<longleftrightarrow>
	poincare_onto_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 (hd XS)) odo) guards ivli sctni roi XS P dP = dRETURN True"

	end

	context approximate_sets begin

	lemma c1_info_of_appre_c0_I:
	"(x, d) \<in> c1_info_of_appre ((1, 1), X0, None)"
	if "list_of_eucl x \<in> set_of_appr X0"
	using that
	by (force simp: c1_info_of_appre_def c1_info_of_appr_def)

	lemma lvivl'_invar_None[simp]: "lvivl'_invar n None"
	by (auto simp: lvivl'_invar_def)

	lemma c1_info_invar_None: "c1_info_invar n (u, None) \<longleftrightarrow> length u = n"
	by (auto simp: c1_info_invar_def)

	lemma c1_info_invare_None: "c1_info_invare n ((l, u), x, None) \<longleftrightarrow>((l < u \<or> -\<infinity> < l \<and> l \<le> u \<and> u < \<infinity>) \<and> length x = n)"
	by (auto simp: c1_info_invare_def Let_def c1_info_invar_None)

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Rigorous_Numerics.thy b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Rigorous_Numerics.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Concrete_Rigorous_Numerics.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Concrete_Rigorous_Numerics.thy
	@@ -1,899 +1,899 @@
	theory Concrete_Rigorous_Numerics
	imports
	Abstract_Rigorous_Numerics
	begin

	context includes autoref_syntax begin

	lemma [autoref_rules]:
	"(slp_of_fas, slp_of_fas) \<in> fas_rel \<rightarrow> slp_rel"
	"(Norm, Norm) \<in> fas_rel \<rightarrow> Id"
	by auto

	lemma [autoref_rules]: "(norm2_slp, norm2_slp) \<in> nat_rel \<rightarrow> Id"
	by auto

	lemma [autoref_rules]:
	"(floatarith.Var, floatarith.Var) \<in> nat_rel \<rightarrow> Id"
	"(slp_of_fas, slp_of_fas) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> \<langle>Id\<rangle>list_rel"
	"(fold_const_fa, fold_const_fa) \<in> Id \<rightarrow> Id"
	"(open_form, open_form) \<in> Id \<rightarrow> bool_rel"
	"(max_Var_floatariths, max_Var_floatariths) \<in> \<langle>Id\<rangle>list_rel \<rightarrow> nat_rel"
	"(max_Var_form, max_Var_form) \<in> Id \<rightarrow> nat_rel"
	"(length, length) \<in> \<langle>A\<rangle>list_rel \<rightarrow> nat_rel"
	by (auto simp: list_rel_imp_same_length)

	end

	context approximate_sets begin

	lemma prod_rel_relcomp_distr: "(R \<times>\<^sub>r S) O (T \<times>\<^sub>r U) = (R O T) \<times>\<^sub>r (S O U)"
	by (auto simp: prod_rel_def)

	lemma appr_relp_comp: "appr_rell O \<langle>lv_rel\<rangle>set_rel \<subseteq> appr_rel"
	"appr_rel \<subseteq> appr_rell O \<langle>lv_rel\<rangle>set_rel"
	by (auto simp: appr_rel_def)

	lemma rnv_rel_comp2:
	"rnv_rel \<subseteq> rnv_rel O rnv_rel"
	"rnv_rel O rnv_rel \<subseteq> rnv_rel"
	by auto

	lemma rl_comp_lv: "rl_rel O lv_rel \<subseteq> lv_rel"
	"lv_rel \<subseteq> rl_rel O lv_rel"
	by auto

	lemmas rel_lemmas =
	fun_rel_comp_dist[THEN order_trans]
	fun_rel_mono nres_rel_comp[THEN eq_refl, THEN order_trans]
	nres_rel_mono prod_rel_mono prod_rel_relcomp_distr[THEN eq_refl, THEN order_trans]
	appr_relp_comp
	rnv_rel_comp2
	rl_comp_lv
	sctn_rel

	lemma width_spec_width_spec: "(width_spec, width_spec) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	by (auto simp: width_spec_def nres_relI)

	lemma [autoref_itype]:
	"width_spec ::\<^sub>i A \<rightarrow>\<^sub>i \<langle>i_rnv\<rangle>\<^sub>ii_nres"
	"Inf_spec ::\<^sub>i A \<rightarrow>\<^sub>i \<langle>B\<rangle>\<^sub>ii_nres"
	"Sup_spec ::\<^sub>i A \<rightarrow>\<^sub>i \<langle>B\<rangle>\<^sub>ii_nres"
	"inter_sctn_spec ::\<^sub>i A \<rightarrow>\<^sub>i \<langle>B\<rangle>\<^sub>ii_sctn \<rightarrow>\<^sub>i \<langle>C\<rangle>\<^sub>ii_nres"
	"split_spec ::\<^sub>i A \<rightarrow>\<^sub>i \<langle>\<langle>B, B\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
	"split_spec_param ::\<^sub>i i_nat \<rightarrow>\<^sub>i A \<rightarrow>\<^sub>i \<langle>\<langle>B, B\<rangle>\<^sub>ii_prod\<rangle>\<^sub>ii_nres"
	"Inf_inner ::\<^sub>i A \<rightarrow>\<^sub>i B \<rightarrow>\<^sub>i \<langle>i_rnv\<rangle>\<^sub>ii_nres"
	"Sup_inner ::\<^sub>i A \<rightarrow>\<^sub>i B \<rightarrow>\<^sub>i \<langle>i_rnv\<rangle>\<^sub>ii_nres"
	by auto

	lemma transfer_operations[unfolded comps, autoref_rules]:
	"SIDE_PRECOND (list_all2 (\<le>) xrs yrs) \<Longrightarrow>
	(xri, xrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow>
	(yri, yrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow>
	(appr_of_ivl ops xri yri, lv_ivl $ xrs $ yrs) \<in> appr_rell"
	"(product_appr ops, product_listset) \<in> appr_rell \<rightarrow> appr_rell \<rightarrow> appr_rell"
	"(msum_appr ops, (+)) \<in> appr_rel \<rightarrow> appr_rel \<rightarrow> appr_rel"
	"(RETURN o inf_of_appr ops optns, Inf_spec) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
	"(RETURN o sup_of_appr ops optns, Sup_spec) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
	"(RETURN o2 split_appr ops, split_spec_param) \<in> nat_rel \<rightarrow> appr_rel \<rightarrow> \<langle>appr_rel \<times>\<^sub>r appr_rel\<rangle>nres_rel"
	"(RETURN o2 appr_inf_inner ops optns, Inf_inner) \<in> appr_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	"(RETURN o2 appr_sup_inner ops optns, Sup_inner) \<in> appr_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	"(nres_of o2 inter_appr_plane ops optns, inter_sctn_spec) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>appr_rel\<rangle>nres_rel"
	"(RETURN o2 reduce_appr ops optns, reduce_spec) \<in> reduce_argument_rel TYPE('b) \<rightarrow> appr_rel \<rightarrow> \<langle>appr_rel\<rangle>nres_rel"
	"(RETURN o width_appr ops optns, width_spec) \<in> appr_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	"(nres_of o3 approx_slp_dres ops optns, approx_slp_spec fas) \<in> nat_rel \<rightarrow> slp_rel \<rightarrow> appr_rell \<rightarrow> \<langle>\<langle>appr_rell\<rangle>option_rel\<rangle>nres_rel"
	subgoal premises prems using transfer_operations_rl(1)[OF prems] by simp
	subgoal premises prems using transfer_operations_rl(2)[OF prems] by simp
	subgoal premises prems using transfer_operations_rl(3)[OF prems]
	unfolding appr_rel_def set_plus_def
	apply auto
	apply (drule fun_relD, assumption, drule fun_relD, assumption, rule relcompI, assumption)
	apply (auto simp: set_rel_sv[OF lv_rel_sv])
	apply (rule ImageI)
	apply (rule lv_rel_add[param_fo], assumption, assumption)
	apply force
	subgoal for a b c d e f g
	apply (rule bexI[where x="eucl_of_list f"])
	apply (rule bexI[where x="eucl_of_list g"])
	using lv_rel_add[param_fo, of f "eucl_of_list f", of g "eucl_of_list g::'a"]
	by (auto simp: lv_rel_def br_def subset_iff)
	subgoal
	by (auto simp: lv_rel_def br_def subset_iff)
	done
	subgoal apply (auto simp: appr_rel_def)
	proof goal_cases
	case (1 x y z)
	from transfer_operations_rl(4)[OF 1(1) refl]
	have Is: "(RETURN (inf_of_appr ops optns x), Inf_specs (length x) y) \<in> \<langle>rl_rel\<rangle>nres_rel"
	by auto
	from 1 have "length x = DIM('c)"
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	from relcompI[OF _ Inf_specs_Inf_spec[param_fo], OF Is \<open>length x = _\<close> 1(2)]
	have "(RETURN (inf_of_appr ops optns x), Inf_spec z) \<in> \<langle>rl_rel\<rangle>nres_rel O \<langle>lv_rel\<rangle>nres_rel"
	by simp
	then show ?case
	by (simp add: nres_rel_comp)
	qed
	subgoal apply (auto simp: appr_rel_def)
	proof goal_cases
	case (1 x y z)
	from transfer_operations_rl(5)[OF 1(1) refl]
	have Is: "(RETURN (sup_of_appr ops optns x), Sup_specs (length x) y) \<in> \<langle>rl_rel\<rangle>nres_rel"
	by auto
	from 1 have "length x = DIM('d)"
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	from relcompI[OF _ Sup_specs_Sup_spec[param_fo], OF Is \<open>length x = _\<close> 1(2)]
	have "(RETURN (sup_of_appr ops optns x), Sup_spec z) \<in> \<langle>rl_rel\<rangle>nres_rel O \<langle>lv_rel\<rangle>nres_rel"
	by simp
	then show ?case
	by (simp add: nres_rel_comp)
	qed
	subgoal apply (auto simp: appr_rel_def)
	proof goal_cases
	case (1 n x y z)
	from transfer_operations_rl(6)[OF _ 1(1) refl]
	have Is: "(RETURN (split_appr ops n x), split_spec_params (length x) n y) \<in> \<langle>appr_rell \<times>\<^sub>r appr_rell\<rangle>nres_rel"
	by auto
	from 1 have "length x = DIM('e)"
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	from relcompI[OF _ split_spec_params_split_spec_param[param_fo], OF Is \<open>length x = _\<close> IdI 1(2)]
	have "(RETURN (split_appr ops n x), split_spec_param n z) \<in>
	\<langle>appr_rell \<times>\<^sub>r appr_rell\<rangle>nres_rel O \<langle>\<langle>lv_rel\<rangle>set_rel \<times>\<^sub>r \<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
	by simp
	then show ?case
	by (simp add: nres_rel_comp prod_rel_relcomp_distr comps)
	qed
	subgoal
	by (intro relcompI[OF transfer_operations_rl(7) Inf_inners_Inf_inner, THEN rev_subsetD] rel_lemmas)
	subgoal
	by (intro relcompI[OF transfer_operations_rl(8) Sup_inners_Sup_inner, THEN rev_subsetD] rel_lemmas)
	subgoal apply (auto simp: appr_rel_def)
	proof goal_cases
	case (1 r s x y z)
	from 1 have lens: "length (normal r) = length x"
	apply (cases r; cases s)
	apply (auto simp: sctn_rel_def)
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	have poslen: "0 < length x"
	using 1
	apply (cases r; cases s)
	apply (auto simp: sctn_rel_def)
	by (auto simp: lv_rel_def set_rel_def br_def appr_rell_internal)
	have rr: "(r, r) \<in> \<langle>rl_rel\<rangle>sctn_rel"
	by (cases r) (auto simp: sctn_rel_def)
	from transfer_operations_rl(9)[OF 1(2) refl lens poslen rr]
	have Is: "(nres_of (inter_appr_plane ops optns x r), inter_sctn_specs (length x) y r) \<in> \<langle>appr_rell\<rangle>nres_rel"
	by (auto dest!: fun_relD)
	from 1 have "length x = DIM('h)"
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	from relcompI[OF _ inter_sctn_specs_inter_sctn_spec[param_fo], OF Is, OF \<open>length x = _\<close> 1(3) 1(1)]
	have "(nres_of (inter_appr_plane ops optns x r), inter_sctn_spec z s) \<in> \<langle>appr_rell\<rangle>nres_rel O \<langle>\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
	by simp
	then show ?case
	by (simp add: nres_rel_comp prod_rel_relcomp_distr comps)
	qed
	subgoal apply (auto simp: appr_rel_def)
	proof goal_cases
	case (1 ro x y z)
	from transfer_operations_rl(10)[OF 1(2) refl 1(1)]
	have Is: "(RETURN (reduce_appr ops optns ro x), reduce_specs (length x) () y) \<in> \<langle>appr_rell\<rangle>nres_rel"
	by auto
	from 1 have "length x = DIM('i)"
	unfolding set_rel_sv[OF lv_rel_sv]
	by (auto simp: lv_rel_def br_def appr_rell_internal length_set_of_appr subset_iff)
	from relcompI[OF _ reduce_specs_reduce_spec[param_fo], OF Is \<open>length x = _\<close> IdI 1(3)]
	have "(RETURN (reduce_appr ops optns ro x), reduce_spec () z) \<in> \<langle>appr_rell\<rangle>nres_rel O \<langle>\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
	by simp
	then show ?case
	by (simp add: nres_rel_comp prod_rel_relcomp_distr comps)
	qed
	subgoal
	by (intro relcompI[OF transfer_operations_rl(11) width_spec_width_spec, THEN rev_subsetD] rel_lemmas)
	subgoal using transfer_operations_rl(12) by auto
	done

	lemma approx_slp_spec[autoref_op_pat_def]: "approx_slp_spec fas \<equiv> OP (approx_slp_spec fas)"
	by auto

	lemma
	concat_appr:
	assumes "(xsi, xs) \<in> \<langle>appr_rell\<rangle>list_rel"
	shows "(concat_appr ops xsi, concat ` listset xs) \<in> appr_rell"
	using assms
	apply (auto simp: appr_rell_internal br_def)
	subgoal premises prems for xi
	proof -
	have "length xi = length xs" "length xs = length xsi"
	using prems
	by (auto simp: list_rel_def list_all2_iff length_listset)
	then show ?thesis using prems
	proof (induction rule: list_induct3)
	case Nil
	then show ?case by simp
	next
	case (Cons x xs y ys z zs)
	have "(z, set_of_appr z) \<in> appr_rell"
	"(concat_appr ops zs, set_of_appr (concat_appr ops zs)) \<in> appr_rell"
	by (auto simp: appr_rell_internal br_def)
	from transfer_operations(2)[param_fo, OF this]
	have *: "set_of_appr (product_appr ops z (concat_appr ops zs)) =
	(\<lambda>(x, y). x @ y) ` (set_of_appr z \<times> set_of_appr (concat_appr ops zs))"
	by (simp add: appr_rell_internal br_def product_listset_def)
	show ?case
	using Cons
	apply (auto simp: appr_rell_internal *)
	apply (rule image_eqI[where x="(x, concat xs)"])
	by (auto simp: set_Cons_def)
	qed
	qed
	subgoal premises prems for z
	proof -
	have "length xsi = length xs"
	using prems
	by (auto simp: list_rel_def list_all2_iff)
	then show ?thesis
	using prems
	proof (induction arbitrary: z rule: list_induct2 )
	case Nil
	then show ?case by simp
	next
	case (Cons x xs y ys)
	have "(x, set_of_appr x) \<in> appr_rell" "(concat_appr ops xs, set_of_appr (concat_appr ops xs)) \<in> appr_rell"
	by (auto simp: appr_rell_internal br_def)
	from transfer_operations(2)[param_fo, OF this]
	have *: "set_of_appr (product_appr ops x (concat_appr ops xs)) =
	product_listset (set_of_appr x) (set_of_appr (concat_appr ops xs))"
	by (auto simp: appr_rell_internal br_def)
	show ?case using Cons
	apply (auto simp: * product_listset_def list_rel_def set_Cons_def)
	subgoal premises prems for a b
	using prems(2)[OF prems(7)] prems(6)
	apply (auto )
	subgoal for ya
	apply (rule image_eqI[where x="a#ya"])
	by (auto simp: set_Cons_def)
	done
	done
	qed
	qed
	done

	lemma op_concat_listset_autoref[autoref_rules]:
	"(concat_appr ops, op_concat_listset) \<in> \<langle>appr_rell\<rangle>list_rel \<rightarrow> appr_rell"
	using concat_appr by force

	lemma transfer_operations1[autoref_rules]:
	assumes "SIDE_PRECOND (x \<le> y)" "(xi, x) \<in> lv_rel" "(yi, y) \<in> lv_rel"
	shows "(appr_of_ivl ops xi yi, op_atLeastAtMost_appr $ x $ y) \<in> appr_rel"
	proof -
	have "(appr_of_ivl ops xi yi, lv_ivl (list_of_eucl x) (list_of_eucl y)) \<in> appr_rell"
	apply (rule transfer_operations_rl[unfolded autoref_tag_defs])
	using assms lv_rel_le[param_fo, of xi x yi y]
	by (auto simp: lv_rel_def br_def)
	then have "(appr_of_ivl ops xi yi, eucl_of_list ` lv_ivl (list_of_eucl x) (list_of_eucl y)::'a set) \<in> appr_rel"
	unfolding appr_rel_br
	using assms[unfolded lv_rel_def]
	using lv_rel_le[param_fo, of xi x yi y]
	by (auto simp: appr_rell_internal br_def appr_rel_br)
	(auto simp: lv_rel_def br_def)
	also have "eucl_of_list ` lv_ivl (list_of_eucl x) (list_of_eucl y) = {x .. y}"
	by (subst eucl_of_list_image_lv_ivl) auto
	finally show ?thesis by simp
	qed

	lemma appr_of_ivl_point_appr_rel:
	"(appr_of_ivl ops x x, {eucl_of_list x::'a::executable_euclidean_space}) \<in> appr_rel"
	if "length x = DIM('a)"
	using transfer_operations1[OF _ lv_relI lv_relI, OF _ that that]
	by auto

	lemmas [autoref_post_simps] = concat.simps append_Nil2 append.simps

	lemma is_empty_appr_rel[autoref_rules]:
	"(\<lambda>_. False, is_empty) \<in> appr_rel \<rightarrow> bool_rel"
	by (auto simp: appr_rel_br br_def)

	lemma appr_rel_nonempty: "(x, X) \<in> appr_rel \<Longrightarrow> X \<noteq> {}"
	by (auto simp: appr_rel_br br_def)

	lemma [autoref_rules]: "(ops, ops) \<in> Id"
	by simp

	lemma single_valued_appr_rel[relator_props]:
	"single_valued (appr_rel)"
	by (auto simp: appr_rel_br)

	schematic_goal ivl_rep_of_set_impl:
	fixes X::"'a::executable_euclidean_space set"
	assumes [autoref_rules]: "(ai, X) \<in> appr_rel"
	shows "(RETURN (?f::?'r), op_ivl_rep_of_set X) \<in> ?R"
	unfolding op_ivl_rep_of_set_def including art by (autoref_monadic (plain))
	concrete_definition ivl_rep_of_set_impl for ai uses ivl_rep_of_set_impl
	lemma ivl_rep_of_set_autoref[autoref_rules]:
	shows "(\<lambda>x. RETURN (ivl_rep_of_set_impl x), op_ivl_rep_of_set) \<in> appr_rel \<rightarrow> \<langle>lv_rel \<times>\<^sub>r lv_rel\<rangle>nres_rel"
	using ivl_rep_of_set_impl.refine
	by auto

	schematic_goal ivl_rep_of_sets_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) n"
	assumes [autoref_rules]: "(ai, a) \<in> \<langle>appr_rel\<rangle>list_wset_rel"
	notes [refine_transfer] = FORWEAK_LIST_plain.refine
	shows "(RETURN (?f), op_ivl_rep_of_sets a::('a \<times> 'a)nres) \<in> \<langle>lv_rel \<times>\<^sub>r lv_rel\<rangle>nres_rel"
	unfolding op_ivl_rep_of_sets_def
	by (autoref_monadic(plain))
	concrete_definition ivl_rep_of_sets_impl for n ai uses ivl_rep_of_sets_impl
	lemma ivl_rep_of_sets_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) n \<Longrightarrow>
	(\<lambda>ai. RETURN (ivl_rep_of_sets_impl n ai), op_ivl_rep_of_sets::_\<Rightarrow>('a \<times> 'a)nres) \<in> \<langle>appr_rel\<rangle>list_wset_rel \<rightarrow> \<langle>lv_rel \<times>\<^sub>r lv_rel\<rangle>nres_rel"
	using ivl_rep_of_sets_impl.refine by force

	schematic_goal ivl_rep_of_set_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) n"
	assumes [autoref_rules]: "(ai, a) \<in> clw_rel appr_rel"
	shows "(RETURN (?f), ivl_rep_of_set_coll a::('a\<times>'a) nres) \<in> \<langle>lv_rel \<times>\<^sub>r lv_rel\<rangle>nres_rel"
	unfolding ivl_rep_of_set_coll_def
	by (autoref_monadic (plain))
	concrete_definition ivl_rep_of_set_coll_impl for n ai uses ivl_rep_of_set_coll_impl
	lemma ivl_rep_of_set_coll_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) n \<Longrightarrow>
	(\<lambda>ai. RETURN (ivl_rep_of_set_coll_impl n ai), ivl_rep_of_set_coll::_\<Rightarrow>('a\<times>'a) nres) \<in> clw_rel appr_rel \<rightarrow> \<langle>lv_rel \<times>\<^sub>r lv_rel\<rangle>nres_rel"
	using ivl_rep_of_set_coll_impl.refine by force

	schematic_goal ivls_of_sets_impl:
	assumes [autoref_rules]: "(xsi, xs) \<in> clw_rel appr_rel"
	shows "(nres_of (?f), ivls_of_sets $ xs) \<in> \<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding ivls_of_sets_def
	by autoref_monadic
	concrete_definition ivls_of_sets_impl for xsi uses ivls_of_sets_impl
	lemma ivls_of_set_impl_refine[autoref_rules]:
	"(\<lambda>ai. nres_of (ivls_of_sets_impl ai), ivls_of_sets) \<in> clw_rel appr_rel \<rightarrow> \<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	using ivls_of_sets_impl.refine by force

	lemma card_info[autoref_rules]:
	"((\<lambda>x. RETURN (length x)), card_info) \<in> clw_rel R \<rightarrow> \<langle>nat_rel\<rangle>nres_rel"
	by (auto simp: card_info_def nres_rel_def)

	lemma ivl_to_set[autoref_rules]:
	"(\<lambda>(i, s). if list_all2 (\<le>) i s then [appr_of_ivl ops i s] else [], ivl_to_set::_\<Rightarrow>'a::executable_euclidean_space set) \<in> lvivl_rel \<rightarrow> clw_rel (appr_rel)"
	supply le = lv_rel_le[param_fo]
	apply (clarsimp simp add: ivl_rel_def)
	subgoal premises prems for ls us l u X
	using le[OF \<open>(_, l) \<in> _\<close> \<open>(_, u) \<in> _\<close>] prems transfer_operations1[of l u ls us]
	apply (auto simp: Cons_mem_clw_rel_iff single_valued_appr_rel ivl_rel_def[symmetric] intro!: exI[where x=X])
	subgoal by (auto simp: set_of_ivl_def br_def)
	subgoal using Union_rel_empty by (auto simp: set_of_ivl_def br_def )
	done
	done

	lemma sets_of_ivls[autoref_rules]:
	shows "(\<lambda>xs. map (\<lambda>(i, s). appr_of_ivl ops i s) [(i,s) \<leftarrow> xs. list_all2 (\<le>) i s], sets_of_ivls::_\<Rightarrow>'a::executable_euclidean_space set) \<in> clw_rel lvivl_rel \<rightarrow> clw_rel (appr_rel)"
	supply le = lv_rel_le[param_fo]
	apply (rule fun_relI)
	unfolding appr_rel_br ivl_rel_br clw_rel_br lvivl_rel_br
	apply (auto simp: br_def set_of_ivl_def)
	subgoal for a b c d
	apply (rule exI conjI le le[param_fo,THEN IdD, THEN iffD2] lv_relI\| assumption \| force)+
	using transfer_operations1[where 'a='a, of "eucl_of_list c" "eucl_of_list d" c d]
	apply (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def)
	by (metis (mono_tags, lifting) atLeastAtMost_iff atLeastatMost_empty_iff case_prodD empty_iff)
	subgoal for a b c d
	using transfer_operations1[where 'a='a, of "eucl_of_list b" "eucl_of_list c" b c]
	le[of b _ c _, OF lv_relI lv_relI]
	by (auto simp: appr_rel_br br_def lvivl_rel_br set_of_ivl_def lv_rel_def intro!: bexI)
	done

	schematic_goal above_sctn_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, above_sctn $ X $ sctn) \<in> ?R"
	unfolding autoref_tag_defs
	by (rule above_sctn_nres[THEN nres_rel_trans2]) autoref_monadic
	concrete_definition above_sctn_impl for Xi sctni uses above_sctn_impl
	lemma above_sctn_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (above_sctn_impl ai sctni), above_sctn) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using above_sctn_impl.refine by force

	schematic_goal below_sctn_impl:
	assumes [autoref_rules]: "(ai, a) \<in> appr_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, below_sctn $ a $ sctn) \<in> ?R"
	unfolding autoref_tag_defs
	by (rule below_sctn_nres[THEN nres_rel_trans2]) (autoref_monadic (plain))
	concrete_definition below_sctn_impl for ai sctni uses below_sctn_impl
	lemma below_sctn_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (below_sctn_impl ai sctni), below_sctn) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using below_sctn_impl.refine by force

	schematic_goal sbelow_sctn_impl:
	assumes [autoref_rules]: "(ai, a) \<in> appr_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, sbelow_sctn $ a $ sctn) \<in> ?R"
	unfolding autoref_tag_defs
	by (rule sbelow_sctn_nres[THEN nres_rel_trans2]) (autoref_monadic (plain))
	concrete_definition sbelow_sctn_impl for ai sctni uses sbelow_sctn_impl
	lemma sbelow_sctn_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (sbelow_sctn_impl ai sctni), sbelow_sctn) \<in>
	appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using sbelow_sctn_impl.refine by force

	schematic_goal sbelow_sctns_impl:
	assumes [autoref_rules]: "(ai, a) \<in> appr_rel"
	assumes [autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	shows "(?f::?'r, sbelow_sctns $ a $ sctns) \<in> ?R"
	unfolding autoref_tag_defs
	apply (rule sbelow_sctns_nres[THEN nres_rel_trans2])
	subgoal using list_set_rel_finiteD[of sctnsi sctns "\<langle>lv_rel\<rangle>sctn_rel"] \<open>(sctnsi, sctns) \<in> _\<close> by (simp add: relAPP_def)
	by (autoref_monadic (plain))
	concrete_definition sbelow_sctns_impl for ai sctnsi uses sbelow_sctns_impl
	lemma sbelow_sctns_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (sbelow_sctns_impl ai sctni), sbelow_sctns) \<in>
	appr_rel \<rightarrow> sctns_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using sbelow_sctns_impl.refine by force

	schematic_goal intersects_impl:
	assumes [autoref_rules]: "(ai, a) \<in> appr_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, op_intersects $ a $ sctn) \<in> ?R"
	unfolding autoref_tag_defs op_intersects_def
	by (autoref_monadic (plain))
	concrete_definition intersects_impl for ai sctni uses intersects_impl
	lemma intersects_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (intersects_impl ai sctni), op_intersects) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using intersects_impl.refine by force

	schematic_goal sbelow_sctns_coll_impl:
	assumes [autoref_rules]: "(ai, a) \<in> clw_rel appr_rel"
	assumes [autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	shows "(?f::?'r, sbelow_sctns_coll $ a $ sctns) \<in> ?R"
	unfolding sbelow_sctns_coll_def
	by autoref
	concrete_definition sbelow_sctns_coll_impl for ai sctnsi uses sbelow_sctns_coll_impl
	lemma sbelow_sctns_coll_impl_refine[autoref_rules]:
	"(sbelow_sctns_coll_impl, sbelow_sctns_coll) \<in> clw_rel appr_rel \<rightarrow> sctns_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using sbelow_sctns_coll_impl.refine by force

	schematic_goal sbelow_sctns_coll_dres:
	"nres_of ?r \<le> sbelow_sctns_coll_impl a sctns"
	unfolding sbelow_sctns_coll_impl_def
	by refine_transfer
	concrete_definition sbelow_sctns_coll_dres for a sctns uses sbelow_sctns_coll_dres
	lemmas [refine_transfer] = sbelow_sctns_coll_dres.refine

	schematic_goal below_sctn_coll_impl:
	assumes [autoref_rules]: "(ai, a) \<in> clw_rel appr_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, below_sctn_coll $ a $ sctn) \<in> ?R"
	unfolding below_sctn_coll_def by autoref
	concrete_definition below_sctn_coll_impl for ai sctni uses below_sctn_coll_impl
	lemma below_sctn_coll_impl_refine[autoref_rules]:
	"(below_sctn_coll_impl, below_sctn_coll) \<in> clw_rel appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using below_sctn_coll_impl.refine by force
	schematic_goal below_sctn_coll_dres:
	"nres_of ?r \<le> below_sctn_coll_impl a sctn"
	unfolding below_sctn_coll_impl_def
	by refine_transfer
	concrete_definition below_sctn_coll_dres for a sctn uses below_sctn_coll_dres
	lemmas [refine_transfer] = below_sctn_coll_dres.refine

	schematic_goal intersects_clw_impl:
	assumes [autoref_rules]: "(ai, a) \<in> clw_rel appr_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f::?'r, intersects_clw $ a $ sctn) \<in> ?R"
	unfolding intersects_clw_def autoref_tag_defs
	including art
	by (autoref_monadic (plain))
	concrete_definition intersects_clw_impl for ai sctni uses intersects_clw_impl
	lemma intersects_clw_impl_refine[autoref_rules]:
	"(\<lambda>ai sctni. RETURN (intersects_clw_impl ai sctni), intersects_clw) \<in> clw_rel appr_rel \<rightarrow> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using intersects_clw_impl.refine by force

	schematic_goal subset_spec_ivlc:
	assumes [autoref_rules]: "(Xi, X::'a::executable_euclidean_space set) \<in> appr_rel"
	"(ivli, ivl) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	notes [autoref_post_simps] = Let_def
	shows "(RETURN (?f), op_subset $ X $ ivl) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding op_subset_def
	by autoref_monadic
	concrete_definition subset_spec_ivlc for Xi ivli uses subset_spec_ivlc

	lemma subset_spec_ivl_refine[autoref_rules]:
	"(\<lambda>Xi Yi. RETURN (subset_spec_ivlc Xi Yi), op_subset) \<in> appr_rel \<rightarrow> \<langle>lv_rel\<rangle>ivl_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	for A::"(_ \<times> 'a::executable_euclidean_space set) set"
	using subset_spec_ivlc.refine
	by auto

	schematic_goal subset_spec_ivl_collc:
	assumes [autoref_rules]: "(Xi, X::'a::executable_euclidean_space set) \<in> clw_rel appr_rel"
	"(ivli, ivl) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	notes [autoref_post_simps] = Let_def
	shows "(RETURN (?f), subset_spec_coll $ X $ ivl) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subset_spec_coll_def
	by (autoref_monadic (plain))
	concrete_definition subset_spec_ivl_collc for Xi ivli uses subset_spec_ivl_collc
	lemma subset_spec_ivl_collc_refine[autoref_rules]:
	"(\<lambda>Xi Yi. RETURN (subset_spec_ivl_collc Xi Yi), subset_spec_coll) \<in> clw_rel appr_rel \<rightarrow> \<langle>lv_rel\<rangle>ivl_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using subset_spec_ivl_collc.refine by force

	schematic_goal project_set_appr:
	fixes b::"'a::executable_euclidean_space" and y
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel"
	assumes [autoref_rules]: "(bi, b) \<in> lv_rel"
	assumes [autoref_rules]: "(yi, y) \<in> rnv_rel"
	shows "(nres_of (?f::?'r dres), op_project_set X b y) \<in> ?R"
	unfolding op_project_set_def
	by autoref_monadic
	concrete_definition project_set_appr for Xi bi yi uses project_set_appr
	lemma project_set_appr_refine[autoref_rules]:
	"(\<lambda>Xi bi yi. nres_of (project_set_appr Xi bi yi), op_project_set) \<in> appr_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel \<rightarrow> \<langle>appr_rel\<rangle>nres_rel"
	using project_set_appr.refine by force

	schematic_goal project_set_clw_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> clw_rel appr_rel"
	assumes [autoref_rules]: "(bi, b) \<in> lv_rel"
	assumes [autoref_rules]: "(yi, y) \<in> rnv_rel"
	shows "(nres_of (?f::?'r dres), project_set_clw X b y) \<in> ?R"
	unfolding project_set_clw_def
	including art
	by autoref_monadic
	concrete_definition project_set_clw_impl for Xi bi yi uses project_set_clw_impl
	lemma project_set_clw_refine[autoref_rules]:
	"(\<lambda>Xi bi yi. nres_of (project_set_clw_impl Xi bi yi), project_set_clw) \<in>
	clw_rel appr_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel \<rightarrow> \<langle>clw_rel appr_rel\<rangle>nres_rel"
	using project_set_clw_impl.refine by force

	schematic_goal subset_spec_ivls_impl:
	assumes [autoref_rules]: "(Xi, X) \<in> appr_rel" "(Yi, Y) \<in> clw_rel lvivl_rel"
	shows "(RETURN ?f, subset_spec_ivls X Y) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subset_spec_ivls_def
	by (autoref_monadic (plain))
	concrete_definition subset_spec_ivls_impl for Xi Yi uses subset_spec_ivls_impl
	lemmas [autoref_rules] = subset_spec_ivls_impl.refine[autoref_higher_order_rule]

	schematic_goal subset_spec_ivls_clw_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> clw_rel lvivl_rel" "(Yi, Y) \<in> clw_rel lvivl_rel"
	"(Mi, M) \<in> nat_rel"
	shows "(nres_of ?f, subset_spec_ivls_clw M X Y) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding subset_spec_ivls_clw_def
	including art
	by (autoref_monadic)
	concrete_definition subset_spec_ivls_clw_impl for Mi Xi Yi uses subset_spec_ivls_clw_impl
	lemma [autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) D \<Longrightarrow>
	(\<lambda>Mi Xi Yi. nres_of (subset_spec_ivls_clw_impl D Mi Xi Yi),
	subset_spec_ivls_clw::nat \<Rightarrow> 'a set \<Rightarrow> _)
	\<in> nat_rel \<rightarrow> clw_rel (\<langle>lv_rel\<rangle>ivl_rel) \<rightarrow> clw_rel (\<langle>lv_rel\<rangle>ivl_rel) \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using subset_spec_ivls_clw_impl.refine by force

	lemma REMDUPS_impl[autoref_rules]: "(remdups, REMDUPS) \<in> clw_rel A \<rightarrow> clw_rel A"
	if "PREFER single_valued A"
	using that
	by (force simp: clw_rel_br dest!: brD intro!: brI elim!: single_valued_as_brE)

	schematic_goal split_along_ivls2_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> clw_rel lvivl_rel" "(ISi, IS) \<in> clw_rel lvivl_rel"
	"(Mi, M) \<in> nat_rel"
	shows "(nres_of ?f, split_along_ivls2 $ M $ X $ IS) \<in> \<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_along_ivls2_def
	by autoref_monadic
	concrete_definition split_along_ivls2_impl uses split_along_ivls2_impl
	lemmas [autoref_rules] = split_along_ivls2_impl.refine

	lemma op_list_of_eucl_image_autoref[autoref_rules]:
	shows "(\<lambda>xs. xs, op_list_of_eucl_image) \<in> appr_rel \<rightarrow> appr_rell"
	by (auto simp: length_set_of_appr appr_rel_def lv_rel_def image_image set_rel_br
	cong: image_cong
	dest!: brD)

	lemma op_eucl_of_list_image_autoref[autoref_rules]:
	includes autoref_syntax
	assumes "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes "(xsi, xs) \<in> appr_rell"
	assumes "SIDE_PRECOND (env_len xs D)"
	shows "(xsi, op_eucl_of_list_image $ (xs)::'a set) \<in> appr_rel"
	using assms
	unfolding appr_rel_br
	by (auto simp: length_set_of_appr appr_rel_br br_def image_image env_len_def appr_rell_internal)

	lemma take_set_of_apprD: "xs \<in> set_of_appr XS \<Longrightarrow> take n xs \<in> set_of_appr (take n XS)"
	apply (cases "n < length xs")
	apply (subst take_eq_map_nth)
	apply simp
	apply (subst take_eq_map_nth)
	apply (simp add: length_set_of_appr)
	apply (rule set_of_appr_project)
	by (auto simp: length_set_of_appr)

	lemma set_of_appr_ex_append1:
	"xrs \<in> set_of_appr xs \<Longrightarrow> \<exists>r. r @ xrs \<in> set_of_appr (b @ xs)"
	proof (induction b)
	case Nil
	then show ?case by (auto intro!: exI[where x=Nil])
	next
	case (Cons a b)
	then show ?case
	apply (auto)
	subgoal for r
	apply (drule set_of_apprs_ex_Cons[where b=a and xs="b@xs"])
	apply auto
	by (metis Cons_eq_appendI)
	done
	qed

	lemma set_of_appr_ex_append2:
	assumes "xrs \<in> set_of_appr xs" shows "\<exists>r. xrs @ r \<in> set_of_appr (xs @ b)"
	proof -
	from set_of_appr_ex_append1[OF assms, of b]
	obtain r where r: "r @ xrs \<in> set_of_appr (b @ xs)" by auto
	have "map ((!) (r @ xrs)) ([length b..<length b + length xs] @ [0..<length b])
	\<in> set_of_appr (map ((!) (b @ xs)) ([length b..<length b + length xs] @ [0..<length b]))"
	by (rule set_of_appr_project[OF r, of "[length b..<length b + length xs] @ [0..<length b]"])
	auto
	also have "map ((!) (b @ xs)) ([length b..<length b + length xs] @ [0..<length b]) = xs @ b"
	by (auto intro!: nth_equalityI simp: nth_append)
	also have "map ((!) (r @ xrs)) ([length b..<length b + length xs] @ [0..<length b]) = xrs @ r"
	using length_set_of_appr[OF r] assms length_set_of_appr
	by (auto intro!: nth_equalityI simp: nth_append)
	finally show ?thesis by rule
	qed

	lemma drop_all_conc: "drop (length a) (a@b) = b"
	by (simp)

	lemma set_of_appr_takeD: "xs \<in> set_of_appr (take n XS) \<Longrightarrow> xs \<in> take n ` set_of_appr XS"
	apply (frule set_of_appr_ex_append2[where b="map ((!) XS) [n..<length XS]"])
	apply (auto simp: take_append_take_minus_idem)
	apply (rule image_eqI)
	prefer 2 apply assumption
	by (metis append_eq_append_conv append_take_drop_id drop_all_conc length_drop length_set_of_appr)

	lemma op_take_image_autoref[autoref_rules]:
	shows "(\<lambda>ni xs. take ni xs, op_take_image) \<in> nat_rel \<rightarrow> appr_rell \<rightarrow> appr_rell"
	apply (auto simp: appr_rell_internal br_def )
	subgoal by (rule take_set_of_apprD)
	subgoal by (rule set_of_appr_takeD)
	done

	lemma drop_eq_map_nth: "drop n xs = map ((!) xs) [n..<length xs]"
	by (auto intro!: nth_equalityI simp: nth_append)

	lemma drop_set_of_apprD: "xs \<in> set_of_appr XS \<Longrightarrow> drop n xs \<in> set_of_appr (drop n XS)"
	apply (subst drop_eq_map_nth)
	apply (subst drop_eq_map_nth)
	apply (simp add: length_set_of_appr)
	apply (rule set_of_appr_project)
	by (auto simp: length_set_of_appr)

	lemma drop_append_drop_minus_idem: "n < length XS \<Longrightarrow> map ((!) XS) [0..<n] @ drop n XS = XS"
	by (auto intro!: nth_equalityI simp: nth_append)

	lemma set_of_appr_dropD: "xs \<in> set_of_appr (drop n XS) \<Longrightarrow> xs \<in> drop n ` set_of_appr XS"
	apply (cases "n < length XS")
	subgoal
	apply (frule set_of_appr_ex_append1[where b="map ((!) XS) [0..<n]"])
	apply (auto simp: drop_append_drop_minus_idem)
	apply (rule image_eqI)
	prefer 2 apply assumption
	by (metis (mono_tags, lifting) diff_add_inverse2 diff_diff_cancel drop_all_conc length_append
	length_drop length_set_of_appr less_imp_le)
	subgoal
	using set_of_appr_nonempty[of XS]
	by (auto simp: length_set_of_appr image_iff simp del: set_of_appr_nonempty)
	done

	lemma op_drop_image_autoref[autoref_rules]:
	shows "(\<lambda>ni xs. drop ni xs, op_drop_image) \<in> nat_rel \<rightarrow> appr_rell \<rightarrow> appr_rell"
	apply (auto simp: appr_rell_internal br_def )
	subgoal by (rule drop_set_of_apprD)
	subgoal by (rule set_of_appr_dropD)
	done

	lemma mem_set_of_appr_appendE:
	assumes "zs \<in> set_of_appr (XS @ YS)"
	obtains xs ys where "zs = xs @ ys" "xs \<in> set_of_appr XS" "ys \<in> set_of_appr YS"
	proof -
	have "zs = map ((!) zs) [0..<length XS] @ map ((!) zs) [length XS..<length XS + length YS]"
	using assms
	by (auto intro!: nth_equalityI simp: nth_append dest!: length_set_of_appr)
	moreover
	from
	set_of_appr_project[OF assms, of "[0..<length XS]"]
	set_of_appr_project[OF assms, of "[length XS..<length XS + length YS]"]
	have "map ((!) zs) [0..<length XS] \<in> set_of_appr XS"
	"map ((!) zs) [length XS..<length XS + length YS] \<in> set_of_appr YS"
	by (auto simp : map_nth_append2 map_nth_append1)
	ultimately show ?thesis ..
	qed

	lemma lv_ivl_self[simp]: "lv_ivl xs xs = {xs}" for xs::"'a::order list"
	by (force simp: lv_ivl_def list_all2_conv_all_nth
	intro!: nth_equalityI)

	lemma set_of_appr_of_ivl_point'[simp]:
	"set_of_appr (appr_of_ivl ops (replicate E 0) (replicate E 0)) = {replicate E (0::real)}"
	using transfer_operations_rl(1)[of "(replicate E (0::real))" "(replicate E (0::real))" "(replicate E (0::real))" "(replicate E 0)"]
	by (auto simp: appr_rell_internal br_def)

	lemma set_of_appr_of_ivl_point:
	"set_of_appr (appr_of_ivl ops xs xs) = {xs}"
	using transfer_operations_rl(1)[of xs xs xs xs]
	by (auto simp: appr_rell_internal br_def)

	lemma set_of_appr_of_ivl_append_point:
	"set_of_appr (xs @ appr_of_ivl ops p p) = (\<lambda>x. x @ p) ` set_of_appr xs"
	apply auto
	apply (frule length_set_of_appr)
	subgoal for x
	apply (rule image_eqI[where x="take (length xs) x"])
	apply (auto intro!: nth_equalityI simp: min_def)
	apply (simp add: nth_append)
	subgoal for i
	apply (frule set_of_appr_project[where ?is="[length xs..<length xs + length p]"])
	apply simp
	apply (auto simp: map_nth_append2 set_of_appr_of_ivl_point)
	subgoal premises prems
	proof -
	from prems
	have "map ((!) x) [length xs..<length xs + length p] ! (i - length xs) =
	p ! (i - length xs)"
	by simp
	also have "map ((!) x) [length xs..<length xs + length p] ! (i - length xs) = x ! i"
	using prems
	apply (auto simp: map_nth)
	by (metis add_diff_cancel_left' add_diff_inverse_nat add_less_cancel_left nth_map_upt)
	finally show ?thesis
	using prems by (simp add: min_def)
	qed
	done
	subgoal
	apply (frule set_of_appr_project[where ?is="[0..<length xs]"])
	apply (auto simp: map_nth_append1 take_eq_map_nth
	elim!: mem_set_of_appr_appendE
	dest: length_set_of_appr)
	done
	done
	subgoal premises prems for x
	proof -
	from set_of_appr_ex_append2[where b="appr_of_ivl ops p p", OF \<open>x \<in> set_of_appr xs\<close>]
	obtain r where r: "x @ r \<in> set_of_appr (xs @ appr_of_ivl ops p p)"
	by auto
	have "map ((!) (x @ r)) [length xs..<length xs + (length p)]
	\<in> set_of_appr
	(map ((!) (xs @ appr_of_ivl ops p p))
	[length xs..<length xs + (length p)])"
	by (rule set_of_appr_project[OF r, of "[length xs..<length xs+(length p)]"])
	auto
	also have "map ((!) (x @ r)) [length xs..<length xs + (length p)] = r"
	using length_set_of_appr prems r
	by (auto intro!: nth_equalityI simp: nth_append dest!: length_set_of_appr)
	also have "map ((!) (xs @ appr_of_ivl ops p p))
	[length xs..<length xs + (length p)] = appr_of_ivl ops p p"
	by (auto intro!: nth_equalityI)
	finally have "r = p"
	by (auto simp: set_of_appr_of_ivl_point)
	with r show ?thesis by simp
	qed
	done

	lemma nth_append_cond:
	"i < length xs \<Longrightarrow> (xs @ ys) ! i = xs ! i"
	"i \<ge> length xs \<Longrightarrow> (xs @ ys) ! i = ys ! (i - length xs)"
	by (auto simp: nth_append)

	lemma set_of_appr_of_ivl_point_append:
	"set_of_appr (appr_of_ivl ops p p @ xs) = (\<lambda>x. p @ x) ` set_of_appr xs"
	apply auto
	apply (frule length_set_of_appr)
	subgoal for x
	apply (rule image_eqI[where x="drop (length p) x"])
	apply (auto intro!: nth_equalityI simp: min_def)
	apply (simp add: nth_append)
	subgoal for i
	apply (frule set_of_appr_project[where ?is="[0..<(length p)]"])
	apply simp
	apply (auto simp: map_nth_append1 dest: length_set_of_appr)
	by (metis insertE mem_set_of_appr_appendE memb_imp_not_empty nth_append_cond(1) set_of_appr_of_ivl_point)
	by (metis add_right_imp_eq drop_all_conc drop_set_of_apprD length_append length_set_of_appr)
	subgoal premises prems for x
	proof -
	from set_of_appr_ex_append1[where b="appr_of_ivl ops p p",
	OF \<open>x \<in> set_of_appr xs\<close>]
	obtain r where r: "r @ x \<in> set_of_appr (appr_of_ivl ops p p @ xs)"
	by auto
	have "map ((!) (r @ x)) [0..<(length p)]
	\<in> set_of_appr
	(map ((!) (appr_of_ivl ops p p @ xs))
	[0..<(length p)])"
	by (rule set_of_appr_project[OF r, of "[0..<(length p)]"])
	- (auto simp: )
	+ auto
	also have "map ((!) (r @ x)) [0..<(length p)] = r"
	using length_set_of_appr prems r
	by (auto intro!: nth_equalityI simp: nth_append dest!: length_set_of_appr)
	also have "map ((!) (appr_of_ivl ops p p @ xs))
	[0..<(length p)] = appr_of_ivl ops p p"
	by (auto intro!: nth_equalityI simp: nth_append)
	finally have "r = p"
	by (auto simp: set_of_appr_of_ivl_point)
	with r show ?thesis by simp
	qed
	done

	lemma op_eucl_of_list_image_pad:
	includes autoref_syntax
	assumes "(xsi, xs) \<in> appr_rell" "DIM_precond TYPE('a::executable_euclidean_space) E"
	shows "(take E xsi @ (let z = replicate (E - length xsi) 0 in appr_of_ivl ops z z),
	op_eucl_of_list_image $ xs::'a set) \<in> appr_rel"
	using assms
	unfolding appr_rel_br
	apply (auto simp: length_set_of_appr appr_rel_br br_def image_image env_len_def appr_rell_internal)
	apply (auto simp: Let_def set_of_appr_of_ivl_append_point length_set_of_appr)
	apply (rule image_eqI)
	prefer 2
	apply (rule image_eqI)
	apply (rule refl)
	apply (rule take_set_of_apprD)
	apply assumption
	apply auto
	apply (drule set_of_appr_takeD)
	apply auto
	done
	concrete_definition op_eucl_of_list_image_pad for E xsi uses op_eucl_of_list_image_pad
	lemma op_eucl_of_list_image_pad_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) E \<Longrightarrow>
	(op_eucl_of_list_image_pad E, op_eucl_of_list_image::_\<Rightarrow>'a set) \<in> appr_rell \<rightarrow> appr_rel"
	using op_eucl_of_list_image_pad.refine
	by force

	lemma [autoref_op_pat_def]: "approx_slp_appr fas \<equiv> OP (approx_slp_appr fas)"
	by auto
	schematic_goal approx_slp_appr_impl:
	includes autoref_syntax
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) E"
	assumes [autoref_rules]: "(slpi, slp) \<in> slp_rel" "(Xi, X) \<in> appr_rell"
	notes [autoref_rules] = IdI[of E]
	shows "(nres_of ?r, approx_slp_appr fas $ slp $ X::'a set nres) \<in> \<langle>appr_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding approx_slp_appr_def assms(1)[unfolded DIM_eq_def]
	including art
	by autoref_monadic

	concrete_definition approx_slp_appr_impl for E slpi Xi uses approx_slp_appr_impl
	lemma approx_slp_appr_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) E \<Longrightarrow>
	(\<lambda>slpi Xi. nres_of (approx_slp_appr_impl E slpi Xi), approx_slp_appr fas::_\<Rightarrow>_\<Rightarrow>'a set nres) \<in>
	slp_rel \<rightarrow> appr_rell \<rightarrow> \<langle>appr_rel\<rangle>nres_rel"
	using approx_slp_appr_impl.refine[where 'a='a, of E]
	by force

	lemma DIM_precond_real[autoref_rules_raw]: "DIM_precond TYPE(real) 1" by simp

	schematic_goal mig_set_impl: "(nres_of ?r, mig_set $ D $ X) \<in> \<langle>rnv_rel\<rangle>nres_rel"
	if [autoref_rules]: "(Xi, X::'a set) \<in> appr_rel" "(Di, D) \<in> nat_rel"
	and [autoref_rules_raw, simplified, simp]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	unfolding autoref_tag_defs
	unfolding mig_set_def
	including art
	by autoref_monadic
	concrete_definition mig_set_impl for Di Xi uses mig_set_impl
	lemma mig_set_impl_refine[autoref_rules]:
	includes autoref_syntax
	assumes "DIM_precond TYPE('a::executable_euclidean_space) D" "(Di, D) \<in> nat_rel"
	shows "(\<lambda>x. nres_of (mig_set_impl D x), mig_set $ D::'a set\<Rightarrow>_) \<in> appr_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	using mig_set_impl.refine assms by force

	lemma ncc_precondD:
	assumes "ncc_precond TYPE('a::executable_euclidean_space)"
	shows"(Xi, X::'a set) \<in> appr_rel \<Longrightarrow> ncc X"
	using assms
	by (auto simp: ncc_precond_def split_beta' br_def appr_rel_br
	dest!: bspec[where x="(Xi, X)"])

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy b/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
	@@ -1,2708 +1,2708 @@
	theory Example_Utilities
	imports
	Init_ODE_Solver
	begin

	definition "true_form = Less (floatarith.Num 0) (floatarith.Num 1)"

	lemma open_true_form[intro, simp]: "open_form true_form"
	by (auto simp: true_form_def)

	lemma max_Var_form_true_form[simp]: "max_Var_form true_form = 0"
	by (auto simp: true_form_def)

	lemma interpret_form_true_form[simp]: "interpret_form true_form = (\<lambda>_. True)"
	by (auto simp: true_form_def)

	lemmas [simp] = length_aforms_of_ivls

	declare INF_cong_simp [cong] SUP_cong_simp [cong] image_cong_simp [cong del]

	declare [[ cd_patterns "_ = interpret_floatariths ?fas _" "_ = interpret_floatarith ?fa _"]]

	concrete_definition reify_example for i j k uses reify_example

	hide_const (open) Print.file_output
	definition "file_output s f =
	(if s = STR '''' then f (\<lambda>_. ())
	else if s = STR ''-'' then f print
	else Print.file_output s f)"

	definition "aforms_of_point xs = aforms_of_ivls xs xs"

	definition "unit_matrix_list D = concat (map (\<lambda>i. map (\<lambda>j. if i = j then 1 else 0::real) [0..<D]) [0..<D])"

	definition "with_unit_matrix D X = (fst X @ unit_matrix_list D, snd X @ unit_matrix_list D)"

	definition "list_interval l u = {x. list_all2 (\<le>) l x \<and> list_all2 (\<le>) x u}"

	context includes lifting_syntax begin
	lemma list_interval_transfer[transfer_rule]:
	"((list_all2 A) ===> (list_all2 A) ===> rel_set (list_all2 A))
	list_interval list_interval"
	if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A"
	unfolding list_interval_def
	by transfer_prover
	end

	lemma in_list_interval_lengthD: "x \<in> list_interval a b \<Longrightarrow> length x = length a"
	by (auto simp: list_interval_def list_all2_lengthD)

	context includes floatarith_notation begin

	definition "varvec_fas' D C = ((map Var [0..<D]) @
	concat (map (\<lambda>b.
	(map (\<lambda>i. (Num (C i)) +
	Var (D + D * D) * (mvmult_fa D D (map Var [D..<D + D * D]) (map Num ((replicate D 0)[i:=1])) ! b)) [0..<D])) [0..<D]))"

	definition "varvec_fas D C = ((map Var [0..<D]) @
	concat (map (\<lambda>i. (map (\<lambda>j. (Num (C i)) + Var (D + D * D) * Var (D + D * i + j)) [0..<D])) [0..<D]))"

	lemma \<comment> \<open>for illustration\<close>
	assumes[simp]: "D=3" "rf = real_of_float"
	shows "interpret_floatariths (varvec_fas D (\<lambda>i. [a, b, c] ! i))
	[a, b, c, d11, d12, d13,
	d21, d22, d23,
	d31, d32, d33, 2] =
	[rf a, rf b, rf c,
	rf a + 2 * rf d11, rf a + 2 * rf d12, rf a + 2 * rf d13,
	rf b + 2 * rf d21, rf b + 2 * rf d22, rf b + 2 * rf d23,
	rf c + 2 * rf d31, rf c + 2 * rf d32, rf c + 2 * rf d33]"
	by (simp add: varvec_fas_def mvmult_fa_def eval_nat_numeral)

	definition "vareq_projections
	n \<comment> \<open>dimension\<close>
	ps \<comment> \<open>pairs of coordinates to project onto\<close>
	ds \<comment> \<open>partial derivatives w.r.t. which variables\<close>
	cs \<comment> \<open>(color) coding for partial derivatives\<close>
	=
	[(i + n * (x + 1)::nat, i + n * (y + 1), c). (i, c) \<leftarrow> zip ds cs, (x, y) \<leftarrow> ps]"

	definition "varvec_aforms_line D X line =
	approx_floatariths
	30
	(varvec_fas D (\<lambda>i. float_of (fst (X ! i))))
	(take (D + D*D) X @ line)"

	definition "varvec_aforms_head D X s = varvec_aforms_line D X (aforms_of_point [s])"
	definition "varvec_aforms_vec D X s = varvec_aforms_line D (map (\<lambda>x. (fst x, zero_pdevs)) X) [aform_of_ivl 0 s]"

	definition
	"shows_aforms_vareq
	n \<comment> \<open>dimension\<close>
	ps \<comment> \<open>pairs of coordinates to project onto\<close>
	ds \<comment> \<open>partial derivatives w.r.t. which variables\<close>
	csl \<comment> \<open>color coding for partial derivatives ('arrow' heads)\<close>
	csh \<comment> \<open>color coding for partial derivatives (lines)\<close>
	s \<comment> \<open>scale vectors for partial derivatives\<close>
	(no_str::string) \<comment> \<open>default string if no C1 info is present\<close>
	X \<comment> \<open>affine form with C1 info\<close>
	=
	(case (varvec_aforms_head n X s, varvec_aforms_vec n X s) of (Some X, Some Y) \<Rightarrow>
	shows_sep (\<lambda>(x, y, c). shows_segments_of_aform x y X c) shows_nl (vareq_projections n ps ds csl) o shows_nl
	o shows_sep (\<lambda>(x, y, c). shows_segments_of_aform x y Y c) shows_nl (vareq_projections n ps ds csh) o shows_nl
	\| _ \<Rightarrow> shows_string no_str o shows_nl)"

	abbreviation "print_string s \<equiv> print (String.implode s)"
	abbreviation "print_show s \<equiv> print_string (s '''')"

	value [code] "print_show (shows_aforms_vareq 3 [(x, y). x \<leftarrow> [0..<3], y \<leftarrow> [0..<3], x < y]
	[0..<3] [''0x0000ff'', ''0x00ff00'', ''0xff0000''] [''0x0000ff'', ''0x00ff00'', ''0xff0000'']
	(FloatR 1 (-1)) ''# no C1 info''
	((((\<lambda>(a, b). aforms_of_ivls a b) (with_unit_matrix 3 ([10, 20, 30], [12, 22, 32]))))))"

	method_setup guess_rhs = \<open>
	let
	fun compute ctxt var lhs =
	let
	val lhs' = Code_Evaluation.dynamic_value_strict ctxt lhs;
	val clhs' = Thm.cterm_of ctxt lhs';
	val inst = Thm.instantiate (TVars.empty, Vars.make [(var, clhs')]);
	in PRIMITIVE inst end;
	fun eval_schematic_rhs ctxt t = (case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) t of
	SOME (lhs, Var var) => compute ctxt var lhs
	\| _ => no_tac);
	in
	Scan.succeed (fn ctxt =>
	SIMPLE_METHOD (HEADGOAL (SUBGOAL (fn (t, _) => eval_schematic_rhs ctxt t))))
	end
	\<close>

	lemma length_aforms_of_point[simp]: "length (aforms_of_point xs) = length xs"
	by (auto simp: aforms_of_point_def)

	definition "aform2d_plot_segments x y a = shows_segments_of_aform x y a ''0x000000''"

	lemma list_of_eucl_prod[simp]: "list_of_eucl (x, y) = list_of_eucl x @ list_of_eucl y"
	by (auto simp: list_of_eucl_def Basis_list_prod_def intro!: nth_equalityI)

	lemma list_of_eucl_real[simp]: "list_of_eucl (x::real) = [x]"
	by (auto simp: list_of_eucl_def Basis_list_real_def)

	lemma Joints_aforms_of_ivls_self[simp]: "xs \<in> Joints (aforms_of_ivls xs xs)"
	by (auto intro!: aforms_of_ivls)

	lemma Joints_aforms_of_ivls_self_eq[simp]: "Joints (aforms_of_ivls xs xs) = {xs}"
	apply (auto )
	by (auto simp: aforms_of_ivls_def Joints_def valuate_def aform_val_def
	intro!: nth_equalityI)

	lemma local_lipschitz_c1_euclideanI:
	fixes T::"real set" and X::"'a::euclidean_space set"
	and f::"real \<Rightarrow> 'a \<Rightarrow> 'a"
	assumes f': "\<And>t x. t \<in> T \<Longrightarrow> x \<in> X \<Longrightarrow> (f t has_derivative f' t x) (at x)"
	assumes cont_f': "\<And>i. i \<in> Basis \<Longrightarrow> continuous_on (T \<times> X) (\<lambda>(t, x). f' t x i)"
	assumes "open T"
	assumes "open X"
	shows "local_lipschitz T X f"
	using assms
	apply (intro c1_implies_local_lipschitz[where f'="\<lambda>(t, x). Blinfun (f' t x)"])
	apply (auto simp: bounded_linear_Blinfun_apply has_derivative_bounded_linear split_beta'
	intro!: has_derivative_Blinfun continuous_on_blinfun_componentwise)
	apply (subst continuous_on_cong[OF refl]) defer apply assumption
	apply auto
	apply (subst bounded_linear_Blinfun_apply)
	apply (rule has_derivative_bounded_linear)
	by auto

	definition "list_aform_of_aform (x::real aform) = (fst x, list_of_pdevs (snd x))"
	primrec split_aforms_list:: "(real aform) list list
	\<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (real aform) list list" where
	"split_aforms_list Xs i 0 = Xs"
	\| "split_aforms_list Xs i (Suc n) = split_aforms_list (concat (map (\<lambda>x. (let (a, b) = split_aforms x i in [a, b])) Xs)) i n"

	definition "shows_aforms x y c X = shows_lines (map (\<lambda>b. (shows_segments_of_aform x y b c ''\<newline>'')) X)"

	end

	definition "the_odo ode_fas safe_form = the(mk_ode_ops ode_fas safe_form)"

	locale ode_interpretation =
	fixes safe_form::form and safe_set::"'a::executable_euclidean_space set"
	and ode_fas::"floatarith list"
	and ode::"'a \<Rightarrow> 'a"
	and finite::"'n::enum"
	assumes dims: "DIM('a) = CARD('n)"
	assumes len: "length ode_fas = CARD('n)"
	assumes safe_set_form: "safe_set = {x. interpret_form safe_form (list_of_eucl x)}"
	assumes interpret_fas: "\<And>x. x \<in> safe_set \<Longrightarrow> einterpret ode_fas (list_of_eucl x) = ode x"
	assumes odo: "mk_ode_ops ode_fas safe_form \<noteq> None"
	assumes isFDERIV: "\<And>xs. interpret_form safe_form xs \<Longrightarrow>
	isFDERIV (length ode_fas) [0..<length ode_fas] ode_fas xs"
	begin

	abbreviation "odo \<equiv> the_odo ode_fas safe_form"
	lemmas odo_def = the_odo_def

	lemma odo_simps[simp]: "ode_expression odo = ode_fas" "safe_form_expr odo = safe_form"
	using odo
	by (auto simp: odo_def ode_expression_mk_ode_ops safe_form_expr_mk_ode_ops)

	lemma safe_set: "safe_set = aform.Csafe odo"
	using odo dims safe_set_form isFDERIV
	unfolding aform.Csafe_def aform.safe_def aform.safe_form_def aform.ode_e_def
	by (auto simp: mk_ode_ops_def safe_set_form len split: if_splits)

	lemma ode: "\<And>x. x \<in> safe_set \<Longrightarrow> ode x = aform.ode odo x"
	by (auto simp: aform.ode_def aform.ode_e_def interpret_fas)

	sublocale auto_ll_on_open ode safe_set
	by (rule aform.auto_ll_on_open_congI[OF safe_set[symmetric] ode[symmetric]])

	lemma ode_has_derivative_ode_d1: "(ode has_derivative blinfun_apply (aform.ode_d1 odo x)) (at x)"
	if "x \<in> safe_set" for x
	proof -
	from aform.fderiv[OF that[unfolded safe_set]]
	have "(aform.ode odo has_derivative blinfun_apply (aform.ode_d1 odo x)) (at x)"
	by simp
	moreover
	from topological_tendstoD[OF tendsto_ident_at open_domain(2) that]
	have "\<forall>\<^sub>F x' in at x. x' \<in> safe_set" .
	then have "\<forall>\<^sub>F x' in at x. aform.ode odo x' = ode x'"
	by eventually_elim (auto simp: ode)
	ultimately show ?thesis
	by (rule has_derivative_transform_eventually) (auto simp: ode that)
	qed

	sublocale c1_on_open_euclidean ode "aform.ode_d1 odo" safe_set
	apply unfold_locales
	subgoal by simp
	subgoal by (simp add: ode_has_derivative_ode_d1)
	subgoal by (rule aform.cont_fderiv') (auto intro!: continuous_intros simp: safe_set)
	done

	sublocale transfer_eucl_vec for a::'a and n::'n
	by unfold_locales (simp add: dims)

	lemma flow_eq: "t \<in> existence_ivl0 x \<Longrightarrow> aform.flow0 odo x t = flow0 x t"
	and Dflow_eq: "t \<in> existence_ivl0 x \<Longrightarrow> aform.Dflow odo x t = Dflow x t"
	and ex_ivl_eq: "t \<in> aform.existence_ivl0 odo x \<Longrightarrow> aform.existence_ivl0 odo x = existence_ivl0 x"
	and poincare_mapsto_eq: "closed a \<Longrightarrow> aform.poincare_mapsto odo a b c d e = poincare_mapsto a b c d e"
	and flowsto_eq: "aform.flowsto odo = flowsto"
	apply -
	subgoal by (rule flow0_cong[symmetric]) (auto simp: safe_set ode)
	subgoal by (rule Dflow_cong[symmetric]) (auto simp: safe_set ode)
	subgoal by (rule existence_ivl0_cong[symmetric]) (auto simp: safe_set ode)
	subgoal
	apply (subst aform.poincare_mapsto_cong[OF safe_set[symmetric]])
	by (auto simp: ode)
	subgoal
	apply (intro ext)
	apply (subst flowsto_congI[OF safe_set ode])
	by (auto simp: safe_set)
	done

	definition "avf \<equiv> \<lambda>x::'n rvec. cast (aform.ode odo (cast x)::'a)::'n rvec"

	context includes lifting_syntax begin
	lemma aform_ode_transfer[transfer_rule]: "((=) ===> rel_ve ===> rel_ve) aform.ode aform.ode"
	unfolding aform.ode_def
	by transfer_prover
	lemma cast_aform_ode: "cast (aform.ode odo (cast (x::'n rvec))::'a) = aform.ode odo x"
	by transfer simp

	lemma aform_safe_transfer[transfer_rule]: "((=) ===> rel_ve ===> (=)) aform.safe aform.safe"
	unfolding aform.safe_def
	by transfer_prover

	lemma aform_Csafe_transfer[transfer_rule]: "((=) ===> rel_set rel_ve) aform.Csafe aform.Csafe"
	unfolding aform.Csafe_def
	by transfer_prover

	lemma cast_safe_set: "(cast ` safe_set::'n rvec set) = aform.Csafe odo"
	unfolding safe_set
	by transfer simp

	lemma aform_ode_d_raw_transfer[transfer_rule]:
	"((=) ===> (=) ===> rel_ve ===> rel_ve ===> rel_ve ===> rel_ve) aform.ode_d_raw aform.ode_d_raw"
	unfolding aform.ode_d_raw_def
	by transfer_prover

	lemma
	aform_ode_d_raw_aux_transfer:
	"((=) ===> rel_ve ===> rel_ve ===> rel_ve)
	(\<lambda>x xb xa. if xb \<in> aform.Csafe x then aform.ode_d_raw x 0 xb 0 xa else 0)
	(\<lambda>x xb xa. if xb \<in> aform.Csafe x then aform.ode_d_raw x 0 xb 0 xa else 0)"
	by transfer_prover

	lemma aform_ode_d1_transfer[transfer_rule]:
	"((=) ===> rel_ve ===> rel_blinfun rel_ve rel_ve) aform.ode_d1 aform.ode_d1"
	apply (auto simp: rel_blinfun_def aform.ode_d1_def intro!: rel_funI)
	unfolding aform.ode_d.rep_eq
	using aform_ode_d_raw_aux_transfer
	apply -
	apply (drule rel_funD, rule refl)
	apply (drule rel_funD, assumption)
	apply (drule rel_funD; assumption)
	done

	lemma cast_bl_transfer[transfer_rule]:
	"(rel_blinfun (=) (=) ===> rel_blinfun rel_ve rel_ve) id_blinfun cast_bl"
	by (auto simp: rel_ve_cast rel_blinfun_def intro!: rel_funI dest!: rel_funD)
	lemma cast_bl_transfer'[transfer_rule]:
	"(rel_blinfun rel_ve rel_ve ===> rel_blinfun (=) (=)) id_blinfun cast_bl"
	apply (auto simp: rel_ve_cast rel_blinfun_def cast_cast intro!: rel_funI dest!: rel_funD)
	by (subst cast_cast) auto

	lemma rel_blinfun_eq[relator_eq]: "rel_blinfun (=) (=) = (=)"
	by (auto simp: Rel_def rel_blinfun_def blinfun_ext rel_fun_eq intro!: rel_funI ext)

	lemma cast_aform_ode_D1:
	"cast_bl (aform.ode_d1 odo (cast (x::'n rvec))::'a\<Rightarrow>\<^sub>L'a) =
	(aform.ode_d1 odo x::'n rvec \<Rightarrow>\<^sub>L 'n rvec)"
	by transfer simp

	end

	definition "vf \<equiv> \<lambda>x. cast (ode (cast x))"
	definition "vf' \<equiv> \<lambda>x::'n rvec. cast_bl (aform.ode_d1 odo (cast x::'a))
	::'n rvec \<Rightarrow>\<^sub>L 'n rvec"
	definition "vX \<equiv> cast ` safe_set"
	sublocale a?: transfer_c1_on_open_euclidean a n ode "aform.ode_d1 odo" safe_set vf vf' vX
	for a::'a and n::'n
	by unfold_locales
	(simp_all add: dims vf_def vf'_def vX_def)

	sublocale av: transfer_c1_on_open_euclidean a n "aform.ode odo" "aform.ode_d1 odo"
	"(aform.Csafe odo)" avf vf' vX
	for a::'a and n::'n
	apply unfold_locales
	unfolding vX_def
	by (simp_all add: dims avf_def safe_set)

	lemma vflow_eq: "t \<in> v.existence_ivl0 x \<Longrightarrow> aform.flow0 odo x t = v.flow0 x t"
	thm flow_eq[of t "cast x"] flow_eq[of t "cast x", untransferred]
	apply (subst flow_eq[of t "cast x", untransferred, symmetric])
	apply simp
	unfolding avf_def vX_def cast_aform_ode cast_safe_set
	..

	lemma vf'_eq: "vf' = aform.ode_d1 odo"
	unfolding vf'_def cast_aform_ode_D1 ..

	lemma vDflow_eq: "t \<in> v.existence_ivl0 x \<Longrightarrow> aform.Dflow odo x t = v.Dflow x t"
	apply (subst Dflow_eq[of t "cast x", untransferred, symmetric])
	apply simp
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	..

	lemma vex_ivl_eq: "t \<in> aform.existence_ivl0 odo x \<Longrightarrow> aform.existence_ivl0 odo x = v.existence_ivl0 x"
	apply (subst ex_ivl_eq[of t "cast x", untransferred, symmetric])
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	by auto

	context includes lifting_syntax begin
	lemma id_cast_eucl1_transfer_eq: "(\<lambda>x. x) = (\<lambda>x. (fst x, 1\<^sub>L o\<^sub>L snd x o\<^sub>L 1\<^sub>L))"
	by auto
	lemma cast_eucl1_transfer[transfer_rule]:
	"(rel_prod (=) (rel_blinfun (=) (=)) ===> rel_prod rel_ve (rel_blinfun rel_ve rel_ve)) (\<lambda>x. x) cast_eucl1"
	unfolding cast_eucl1_def id_cast_eucl1_transfer_eq
	apply transfer_prover_start
	apply (transfer_step)
	apply (transfer_step)
	apply (transfer_step)
	apply (transfer_step)
	apply (transfer_step)
	apply simp
	done

	end

	lemma avpoincare_mapsto_eq:
	"aform.poincare_mapsto odo a (b::'n eucl1 set) c d e = av.v.poincare_mapsto a b c d e"
	if "closed a"
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	by auto

	lemma vpoincare_mapsto_eq:
	"aform.poincare_mapsto odo a (b::'n eucl1 set) c d e = v.poincare_mapsto a b c d e"
	if "closed a"
	proof -
	have "closed (cast ` a::'a set)" using that
	by transfer auto
	from poincare_mapsto_eq[of "cast ` a::'a set"
	"cast_eucl1 ` b::('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set"
	"cast ` c::'a set" "cast ` d::'a set" "cast_eucl1 ` e::('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set", OF this, untransferred]
	have "v.poincare_mapsto a b c d e = av.v.poincare_mapsto a b c d e"
	by auto
	also have "\<dots> = aform.poincare_mapsto odo a (b::'n eucl1 set) c d e"
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	by auto
	finally show ?thesis by simp
	qed

	lemma avflowsto_eq: "aform.flowsto odo = (av.v.flowsto::'n eucl1 set \<Rightarrow> _)"
	proof (intro ext, goal_cases)
	case (1 a b c d)
	have "av.v.flowsto a b c d = aform.flowsto odo a b c d"
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	by auto
	then show ?case by simp
	qed

	lemma vflowsto_eq: "aform.flowsto odo = (v.flowsto::'n eucl1 set \<Rightarrow> _)"
	proof (intro ext, goal_cases)
	case (1 a b c d)
	have "aform.flowsto odo (cast_eucl1 ` a::'a c1_info set) b
	(cast_eucl1 ` c) (cast_eucl1 ` d) =
	flowsto (cast_eucl1 ` a::'a c1_info set) b (cast_eucl1 ` c) (cast_eucl1 ` d)"
	by (subst flowsto_eq) auto
	from this[untransferred] have "v.flowsto a b c d = av.v.flowsto a b c d" by auto
	also have "\<dots> = aform.flowsto odo a b c d"
	unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
	by auto
	finally show ?case by simp
	qed

	context includes lifting_syntax begin
	lemma flow1_of_list_transfer[transfer_rule]:
	"(list_all2 (=) ===> rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	flow1_of_list flow1_of_list"
	unfolding flow1_of_list_def blinfun_of_list_def o_def flow1_of_vec1_def
	by transfer_prover

	lemma c1_info_of_appr_transfer[transfer_rule]:
	"(rel_prod (list_all2 (=)) (rel_option (list_all2 (=))) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
	aform.c1_info_of_appr
	aform.c1_info_of_appr"
	unfolding aform.c1_info_of_appr_def
	by transfer_prover

	lemma c0_info_of_appr_transfer[transfer_rule]:
	"((list_all2 (=)) ===> rel_set rel_ve) aform.c0_info_of_appr aform.c0_info_of_appr"
	unfolding aform.c0_info_of_appr_def
	by transfer_prover

	lemma aform_scaleR2_transfer[transfer_rule]:
	"((=) ===> (=) ===> rel_set (rel_prod A B) ===> rel_set (rel_prod A B))
	scaleR2 scaleR2"
	if [unfolded Rel_def, transfer_rule]: "((=) ===> B ===> B) (\<^sub>R) (\<^sub>R)"
	unfolding scaleR2_def
	by transfer_prover
	lemma scaleR_rel_blinfun_transfer[transfer_rule]: "((=) ===> rel_blinfun rel_ve rel_ve ===> rel_blinfun rel_ve rel_ve) (\<^sub>R) (\<^sub>R)"
	apply (auto intro!: rel_funI simp: rel_blinfun_def blinfun.bilinear_simps)
	apply (drule rel_funD)
	apply assumption
	apply (rule scaleR_transfer[THEN rel_funD, THEN rel_funD])
	apply auto
	done
	lemma c1_info_of_appre_transfer[transfer_rule]:
	"(rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))) ===>
	rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
	aform.c1_info_of_appre
	aform.c1_info_of_appre"
	unfolding aform.c1_info_of_appre_def
	by transfer_prover

	lemma c1_info_of_apprs_transfer[transfer_rule]:
	"((=) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
	aform.c1_info_of_apprs
	aform.c1_info_of_apprs"
	unfolding aform.c1_info_of_apprs_def
	by transfer_prover
	lemma c1_info_of_appr'_transfer[transfer_rule]:
	"(rel_option (list_all2 (=)) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
	aform.c1_info_of_appr' aform.c1_info_of_appr'"
	unfolding aform.c1_info_of_appr'_def
	by transfer_prover

	lemma c0_info_of_apprs_transfer[transfer_rule]:
	"((=) ===> rel_set rel_ve)
	aform.c0_info_of_apprs
	aform.c0_info_of_apprs"
	unfolding aform.c0_info_of_apprs_def
	by transfer_prover
	lemma c0_info_of_appr'_transfer[transfer_rule]:
	"(rel_option (list_all2 (=)) ===> rel_set rel_ve)
	aform.c0_info_of_appr' aform.c0_info_of_appr'"
	unfolding aform.c0_info_of_appr'_def
	by transfer_prover

	lemma aform_Csafe_vX[simp]: "aform.Csafe odo = (vX::'n rvec set)"
	by (simp add: vX_def cast_safe_set)

	definition blinfuns_of_lvivl::"real list \<times> real list \<Rightarrow> ('b \<Rightarrow>\<^sub>L 'b::executable_euclidean_space) set"
	where "blinfuns_of_lvivl x = blinfun_of_list ` list_interval (fst x) (snd x)"

	lemma blinfun_of_list_transfer[transfer_rule]:
	"(list_all2 (=) ===> rel_blinfun rel_ve rel_ve) blinfun_of_list blinfun_of_list"
	unfolding blinfun_of_list_def
	by transfer_prover

	lemma blinfuns_of_lvivl_transfer[transfer_rule]:
	"(rel_prod (list_all2 (=)) (list_all2 (=)) ===> rel_set (rel_blinfun rel_ve rel_ve))
	blinfuns_of_lvivl
	blinfuns_of_lvivl"
	unfolding blinfuns_of_lvivl_def
	by transfer_prover

	definition "blinfuns_of_lvivl' x = (case x of None \<Rightarrow> UNIV \| Some x \<Rightarrow> blinfuns_of_lvivl x)"

	lemma blinfuns_of_lvivl'_transfer[transfer_rule]:
	"(rel_option (rel_prod (list_all2 (=)) (list_all2 (=))) ===> rel_set (rel_blinfun rel_ve rel_ve))
	blinfuns_of_lvivl'
	blinfuns_of_lvivl'"
	unfolding blinfuns_of_lvivl'_def
	by transfer_prover


	lemma atLeastAtMost_transfer[transfer_rule]:
	"(A ===> A ===> rel_set A) atLeastAtMost atLeastAtMost"
	if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A" "bi_unique A"
	unfolding atLeastAtMost_def atLeast_def atMost_def
	by transfer_prover

	lemma set_of_ivl_transfer[transfer_rule]:
	"(rel_prod A A ===> rel_set A) set_of_ivl set_of_ivl"
	if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A" "bi_unique A"
	unfolding set_of_ivl_def
	by transfer_prover

	lemma set_of_lvivl_transfer[transfer_rule]:
	"(rel_prod (list_all2 (=)) (list_all2 (=)) ===> rel_set rel_ve) set_of_lvivl set_of_lvivl"
	unfolding set_of_lvivl_def
	by transfer_prover

	lemma set_of_lvivl_eq: "set_of_lvivl I =
	(eucl_of_list ` list_interval (fst I) (snd I)::'b::executable_euclidean_space set)"
	if [simp]: "length (fst I) = DIM('b)" "length (snd I) = DIM('b)"
	proof (auto simp: set_of_lvivl_def list_interval_def set_of_ivl_def, goal_cases)
	case (1 x)
	with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "fst I" "list_of_eucl x"]
	lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "list_of_eucl x" "snd I"]
	show ?case by force
	next
	case (2 x)
	with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "fst I" "x"]
	show ?case by (auto simp: list_all2_lengthD)
	next
	case (3 x)
	with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "x" "snd I"]
	show ?case by (auto simp: list_all2_lengthD)
	qed

	lemma bounded_linear_matrix_vector_mul[THEN bounded_linear_compose, bounded_linear_intros]:
	"bounded_linear ((*v) x)" for x::"real^'x^'y"
	unfolding linear_linear
	by (rule matrix_vector_mul_linear)

	lemma blinfun_of_list_eq: "blinfun_of_list x = blinfun_of_vmatrix (eucl_of_list x::((real, 'b) vec, 'b) vec)"
	if "length x = CARD('b::enum)*CARD('b)"
	unfolding blinfun_of_list_def
	apply (transfer fixing: x)
	apply (rule linear_eq_stdbasis)
	unfolding linear_conv_bounded_linear
	apply (auto intro!: bounded_linear_intros)
	proof goal_cases
	case (1 b)
	have "(eucl_of_list x::((real, 'b) vec, 'b) vec) v b = (eucl_of_list x::((real, 'b) vec, 'b) vec) v eucl_of_list (list_of_eucl b)"
	by simp
	also have "\<dots> = (\<Sum>i<CARD('b).
	(\<Sum>j<CARD('b). x ! (i * CARD('b) + j) * (b \<bullet> Basis_list ! j)) *\<^sub>R Basis_list ! i)"
	by (subst eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list)
	(auto simp: that)
	also have "\<dots> = (\<Sum>i\<in>Basis.
	\<Sum>j\<in>Basis. (b \<bullet> j * x ! (index Basis_list i * CARD('b) + index Basis_list j)) *\<^sub>R i)"
	apply (subst sum_list_Basis_list[symmetric])+
	apply (subst sum_list_sum_nth)+
	by (auto simp add: atLeast0LessThan scaleR_sum_left intro!: sum.cong)
	finally show ?case by simp
	qed

	lemma blinfuns_of_lvivl_eq: "blinfuns_of_lvivl x =
	(blinfun_of_vmatrix ` set_of_lvivl x::((real, 'b) vec \<Rightarrow>\<^sub>L (real, 'b) vec) set)"
	if "length (fst x) = CARD('b::enum)CARD('b)" "length (snd x) = CARD('b)CARD('b)"
	apply (subst set_of_lvivl_eq)
	subgoal by (simp add: that)
	subgoal by (simp add: that)
	unfolding blinfuns_of_lvivl_def image_image
	by (auto simp: that blinfun_of_list_eq[symmetric] in_list_interval_lengthD cong: image_cong)

	lemma range_blinfun_of_vmatrix[simp]: "range blinfun_of_vmatrix = UNIV"
	apply auto
	apply transfer
	subgoal for x by (rule image_eqI[where x="matrix x"]) auto
	done

	lemma blinfun_of_vmatrix_image:
	"blinfun_of_vmatrix ` aform.set_of_lvivl' x =
	(blinfuns_of_lvivl' x::((real, 'b) vec \<Rightarrow>\<^sub>L (real, 'b) vec) set)"
	if "aform.lvivl'_invar (CARD('b)*CARD('b::enum)) x"
	using that
	by (auto simp: aform.set_of_lvivl'_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_eq
	aform.lvivl'_invar_def
	split: option.splits)

	lemma one_step_result123:
	"solves_one_step_until_time_aform optns odo X0i t1 t2 E dE \<Longrightarrow>
	(x0, d0) \<in> aform.c1_info_of_appre X0i \<Longrightarrow>
	t \<in> {t1 .. t2} \<Longrightarrow>
	set_of_lvivl E \<subseteq> S \<Longrightarrow>
	blinfuns_of_lvivl' dE \<subseteq> dS \<Longrightarrow>
	length (fst E) = CARD('n) \<Longrightarrow> length (snd E) = CARD('n) \<Longrightarrow>
	aform.lvivl'_invar (CARD('n) * CARD('n)) dE \<Longrightarrow>
	aform.c1_info_invare DIM('a) X0i \<Longrightarrow>
	aform.D odo = DIM('a) \<Longrightarrow>
	(t \<in> existence_ivl0 (x0::'a) \<and> flow0 x0 t \<in> S) \<and> Dflow x0 t o\<^sub>L d0 \<in> dS"
	apply (transfer fixing: optns X0i t1 t2 t E dE)
	subgoal premises prems for x0 d0 S dS
	proof -
	have "t \<in> aform.existence_ivl0 odo x0 \<and> aform.flow0 odo x0 t \<in> S \<and> aform.Dflow odo x0 t o\<^sub>L d0 \<in> dS"
	apply (rule one_step_in_ivl[of t t1 t2 x0 d0 X0i "fst E" "snd E" S dE dS odo optns])
	using prems
	by (auto simp: eucl_of_list_prod set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image aform.D_def
	solves_one_step_until_time_aform_def)
	with vflow_eq[of t x0] vDflow_eq[of t x0] vex_ivl_eq[symmetric, of t x0]
	show ?thesis
	by simp
	qed
	done

	lemmas one_step_result12 = one_step_result123[THEN conjunct1]
	and one_step_result3 = one_step_result123[THEN conjunct2]
	lemmas one_step_result1 = one_step_result12[THEN conjunct1]
	and one_step_result2 = one_step_result12[THEN conjunct2]

	lemma plane_of_transfer[transfer_rule]: "(rel_sctn A ===> rel_set A) plane_of plane_of"
	if [transfer_rule]: "(A ===> A ===> (=)) (\<bullet>) (\<bullet>)" "bi_total A"
	unfolding plane_of_def
	by transfer_prover

	lemma below_halfspace_transfer[transfer_rule]: "(rel_sctn A ===> rel_set A) below_halfspace below_halfspace"
	if [transfer_rule]: "(A ===> A ===> (=)) (\<bullet>) (\<bullet>)" "bi_total A"
	unfolding below_halfspace_def le_halfspace_def
	by transfer_prover

	definition "rel_nres A a b \<longleftrightarrow> (a, b) \<in> \<langle>{(a, b). A a b}\<rangle>nres_rel"

	lemma FAILi_transfer[transfer_rule]: "(rel_nres B) FAILi FAILi"
	by (auto simp: rel_nres_def nres_rel_def)

	lemma RES_transfer[transfer_rule]: "(rel_set B ===> rel_nres B) RES RES"
	by (auto simp: rel_nres_def nres_rel_def rel_set_def intro!: rel_funI RES_refine)

	context includes autoref_syntax begin
	lemma RETURN_dres_nres_relI:
	"(fi, f) \<in> A \<rightarrow> B \<Longrightarrow> (\<lambda>x. dRETURN (fi x), (\<lambda>x. RETURN (f x))) \<in> A \<rightarrow> \<langle>B\<rangle>dres_nres_rel"
	by (auto simp: dres_nres_rel_def dest: fun_relD)
	end

	lemma br_transfer[transfer_rule]:
	"((B ===> C) ===> (B ===> (=)) ===> rel_set (rel_prod B C)) br br"
	if [transfer_rule]: "bi_total B" "bi_unique C" "bi_total C"
	unfolding br_def
	by transfer_prover

	lemma aform_appr_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod (list_all2 (=)) (rel_set rel_ve))) aform.appr_rel aform.appr_rel"
	unfolding aform.appr_rel_br
	by (transfer_prover)

	lemma appr1_rel_transfer[transfer_rule]: "(rel_set (rel_prod
	(rel_prod (list_all2 (=)) (rel_option (list_all2 (=))))
	(rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))))) aform.appr1_rel aform.appr1_rel"
	unfolding aform.appr1_rel_internal
	by transfer_prover

	lemma relAPP_transfer[transfer_rule]:
	"((rel_set (rel_prod B C) ===> D) ===> rel_set (rel_prod B C) ===> D) Relators.relAPP Relators.relAPP"
	unfolding relAPP_def
	by transfer_prover

	lemma prod_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod B C) ===> rel_set (rel_prod D E) ===> rel_set (rel_prod (rel_prod B D) (rel_prod C E)))
	prod_rel prod_rel"
	if [transfer_rule]:
	"bi_total B" "bi_unique B"
	"bi_unique C" "bi_total C"
	"bi_unique D" "bi_total D"
	"bi_unique E" "bi_total E"
	unfolding prod_rel_def_internal
	by transfer_prover

	lemma Domain_transfer[transfer_rule]:
	"(rel_set (rel_prod A B) ===> rel_set A) Domain Domain"
	if [transfer_rule]:
	"bi_total A" "bi_unique A"
	"bi_total B" "bi_unique B"
	unfolding Domain_unfold
	by transfer_prover

	lemma set_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod B C) ===> rel_set (rel_prod (rel_set B) (rel_set C))) set_rel set_rel"
	if [transfer_rule]:
	"bi_total B" "bi_unique B"
	"bi_unique C" "bi_total C"
	unfolding set_rel_def_internal
	by transfer_prover

	lemma relcomp_transfer[transfer_rule]:
	"(rel_set (rel_prod B C) ===> rel_set (rel_prod C D) ===> rel_set (rel_prod B D)) relcomp relcomp"
	if [transfer_rule]:
	"bi_total B" "bi_unique B"
	"bi_unique C" "bi_total C"
	"bi_unique D" "bi_total D"
	unfolding relcomp_unfold
	by transfer_prover

	lemma Union_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod B (rel_set C)) ===> rel_set (rel_prod C (rel_set D)) ===> rel_set (rel_prod B (rel_set D)))
	Union_rel Union_rel"
	if [transfer_rule]:
	"bi_total B" "bi_unique B"
	"bi_unique C" "bi_total C"
	"bi_unique D" "bi_total D"
	unfolding Union_rel_internal top_fun_def top_bool_def
	by transfer_prover

	lemma fun_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod B C) ===> rel_set (rel_prod D E) ===> rel_set (rel_prod (B ===> D) (C ===> E))) Relators.fun_rel Relators.fun_rel"
	if [transfer_rule]:
	"bi_unique B"
	"bi_unique C"
	"bi_unique D" "bi_total D"
	"bi_unique E" "bi_total E"
	unfolding fun_rel_def_internal
	by transfer_prover

	lemma c1_info_of_apprse_transfer[transfer_rule]:
	"(list_all2 (rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))))
	===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
	aform.c1_info_of_apprse
	aform.c1_info_of_apprse"
	unfolding aform.c1_info_of_apprse_def
	by transfer_prover

	term scaleR2_rel
	(*
	"scaleR2_rel"
	::
	"('b \<times> ('c \<times> 'd) set) set
	\<Rightarrow> (((ereal \<times> ereal) \<times> 'b) \<times> ('c \<times> 'd) set) set"
	*)
	lemma scaleR2_rel_transfer[transfer_rule]:
	"(rel_set (rel_prod (=) (rel_set (rel_prod (=) (=)))) ===>
	rel_set (rel_prod (rel_prod (rel_prod (=) (=)) (=)) (rel_set (rel_prod (=) (=))))) scaleR2_rel scaleR2_rel"
	unfolding scaleR2_rel_internal
	by transfer_prover

	lemma appr1_rele_transfer[transfer_rule]:
	"(rel_set (rel_prod
	(rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))))
	(rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))))) aform.appr1e_rel aform.appr1e_rel"
	unfolding scaleR2_rel_internal
	by transfer_prover

	lemma flow1_of_vec1_times: "flow1_of_vec1 ` (A \<times> B) = A \<times> blinfun_of_vmatrix ` B"
	by (auto simp: flow1_of_vec1_def vec1_of_flow1_def)

	lemma stable_on_transfer[transfer_rule]:
	"(rel_set rel_ve ===> rel_set rel_ve ===> (=)) v.stable_on stable_on"
	unfolding stable_on_def v.stable_on_def
	by transfer_prover

	theorem solves_poincare_map_aform:
	"solves_poincare_map_aform optns odo (\<lambda>x. dRETURN (symstart x)) [S] guards ivl sctn roi XS RET dRET \<Longrightarrow>
	(symstart, symstarta) \<in> fun_rel (aform.appr1e_rel) (clw_rel aform.appr_rel \<times>\<^sub>r clw_rel aform.appr1e_rel) \<Longrightarrow>
	(\<And>X0. (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X) (symstarta X0)) \<Longrightarrow>
	stable_on (aform.Csafe odo - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn)) trap \<Longrightarrow>
	(\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
	aform.D odo = DIM('a) \<Longrightarrow>
	length (normal sctn) = DIM('a) \<Longrightarrow>
	length (fst ivl) = DIM('a) \<Longrightarrow>
	length (snd ivl) = DIM('a) \<Longrightarrow>
	length (normal S) = DIM('a) \<Longrightarrow>
	(\<And>a xs b ba ro.
	(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and>
	length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
	length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
	aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
	poincare_mapsto
	((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
	(aform.c1_info_of_apprse XS - trap \<times> UNIV)
	(below_halfspace (map_sctn eucl_of_list S))
	(aform.Csafe odo -
	set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
	(set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
	apply (transfer fixing: optns symstart S guards ivl sctn roi XS RET dRET)
	subgoal premises prems for symstarta trap
	proof -
	have "aform.poincare_mapsto odo (set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
	(aform.c1_info_of_apprse XS - trap \<times> UNIV) (below_halfspace (map_sctn eucl_of_list S))
	(aform.Csafe odo - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
	(flow1_of_vec1 ` ({eucl_of_list (fst RET)..eucl_of_list (snd RET)} \<times> aform.set_of_lvivl' dRET))"
	apply (rule solves_poincare_map[OF _ RETURN_dres_nres_relI RETURN_rule,
	of optns odo symstart S guards ivl sctn roi XS "fst RET" "snd RET" dRET symstarta trap])
	subgoal using prems(1) by (simp add: solves_poincare_map_aform_def)
	subgoal using prems(2) by (auto simp: fun_rel_def_internal)
	subgoal for X0
	using prems(3)[of X0] vflowsto_eq
	by auto
	subgoal
	unfolding aform.stable_on_def
	proof (safe, goal_cases)
	case (1 t x0)
	from 1 have a: "t \<in> v.existence_ivl0 x0" using vex_ivl_eq by blast
	with 1 have b: "v.flow0 x0 t \<in> trap" using vflow_eq by simp
	have c: "v.flow0 x0 s \<in> vX - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn)"
	if s: "s \<in> {0<..t}"
	for s
	using 1(4)[rule_format, OF s]
	apply (subst (asm) vflow_eq)
	unfolding aform_Csafe_vX[symmetric]
	using s a
	by (auto dest!: a.v.ivl_subset_existence_ivl)
	from a b c show ?case
	using prems(4)[unfolded v.stable_on_def, rule_format, OF b a 1(3) c]
	by simp
	qed
	subgoal using prems by auto
	subgoal using prems by (auto simp: aform.D_def)
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	subgoal using prems by auto
	done
	then show ?thesis
	using vflow_eq vex_ivl_eq vflowsto_eq prems
	apply (subst vpoincare_mapsto_eq[symmetric])
	by (auto simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image flow1_of_vec1_times)
	qed
	done

	theorem solves_poincare_map_aform':
	"solves_poincare_map_aform' optns odo S guards ivl sctn roi XS RET dRET\<Longrightarrow>
	(\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
	aform.D odo = DIM('a) \<Longrightarrow>
	length (normal sctn) = DIM('a) \<Longrightarrow>
	length (fst ivl) = DIM('a) \<Longrightarrow>
	length (snd ivl) = DIM('a) \<Longrightarrow>
	length (normal S) = DIM('a) \<Longrightarrow>
	(\<And>a xs b ba ro.
	(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and>
	length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
	length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
	aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
	poincare_mapsto
	((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
	(aform.c1_info_of_apprse XS)
	(below_halfspace (map_sctn eucl_of_list S))
	(aform.Csafe odo -
	set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
	(set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
	apply (transfer fixing: optns S guards ivl sctn roi XS RET dRET)
	subgoal
	using solves_poincare_map'[of optns odo S guards ivl sctn roi XS "fst RET" "snd RET" dRET]
	using vflow_eq vex_ivl_eq vflowsto_eq
	apply (subst vpoincare_mapsto_eq[symmetric])
	by (auto intro!: closed_Int simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image
	flow1_of_vec1_times aform.D_def solves_poincare_map_aform'_def)
	done

	theorem solves_poincare_map_onto_aform:
	"solves_poincare_map_onto_aform optns odo guards ivl sctn roi XS RET dRET\<Longrightarrow>
	(\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
	aform.D odo = DIM('a) \<Longrightarrow>
	length (normal sctn) = DIM('a) \<Longrightarrow>
	length (fst ivl) = DIM('a) \<Longrightarrow>
	length (snd ivl) = DIM('a) \<Longrightarrow>
	(\<And>a xs b ba ro.
	(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and>
	length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
	length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
	aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
	poincare_mapsto
	((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
	(aform.c1_info_of_apprse XS)
	UNIV
	(aform.Csafe odo -
	set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
	(set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
	apply (transfer fixing: optns guards ivl sctn roi XS RET dRET)
	subgoal
	using solves_poincare_map_onto[of optns odo guards ivl sctn roi XS "fst RET" "snd RET" dRET, where 'n='n,
	unfolded aform.poincare_maps_onto_def]
	using vflow_eq vex_ivl_eq vflowsto_eq
	apply (subst vpoincare_mapsto_eq[symmetric])
	by (auto intro!: closed_Int simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image
	flow1_of_vec1_times aform.D_def solves_poincare_map_onto_aform_def)
	done

	end

	end

	subsection \<open>Example Utilities!\<close>

	hide_const floatarith.Max floatarith.Min

	lemma degree_sum_pdevs_scaleR_Basis:
	"degree (sum_pdevs (\<lambda>i. pdevs_scaleR (a i) i) (Basis::'b::euclidean_space set)) = Max ((\<lambda>i. degree (a i)) ` Basis)"
	apply (rule antisym)
	subgoal apply (rule degree_le)
	by (auto )
	subgoal
	apply (rule Max.boundedI)
	apply simp
	apply simp
	apply (auto simp: intro!: degree_leI)
	by (auto simp: euclidean_eq_iff[where 'a='b])
	done

	lemma Inf_aform_eucl_of_list_aform:
	assumes "length a = DIM('b::executable_euclidean_space)"
	shows "Inf_aform (eucl_of_list_aform a::'b aform) = eucl_of_list (map Inf_aform a)"
	using assms
	apply (auto simp: eucl_of_list_aform_def Inf_aform_def[abs_def] algebra_simps
	eucl_of_list_inner inner_sum_left
	intro!: euclidean_eqI[where 'a='b])
	apply (auto simp: tdev_def inner_sum_left abs_inner inner_Basis if_distrib cong: if_cong)
	apply (rule sum.mono_neutral_cong_left)
	apply simp
	by (auto simp: degree_sum_pdevs_scaleR_Basis)

	lemma Sup_aform_eucl_of_list_aform:
	assumes "length a = DIM('b::executable_euclidean_space)"
	shows "Sup_aform (eucl_of_list_aform a::'b aform) = eucl_of_list (map Sup_aform a)"
	using assms
	apply (auto simp: eucl_of_list_aform_def Sup_aform_def[abs_def] algebra_simps
	eucl_of_list_inner inner_sum_left
	intro!: euclidean_eqI[where 'a='b])
	apply (auto simp: tdev_def inner_sum_left abs_inner inner_Basis if_distrib cong: if_cong)
	apply (rule sum.mono_neutral_cong_right)
	apply simp
	by (auto simp: degree_sum_pdevs_scaleR_Basis)

	lemma
	eucl_of_list_map_Inf_aform_leI:
	assumes "x \<in> Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)"
	assumes "length a = DIM('b)"
	shows "eucl_of_list (map Inf_aform a) \<le> x"
	using Inf_aform_le_Affine[OF assms(1)] assms(2)
	by (auto simp: Inf_aform_eucl_of_list_aform)

	lemma
	eucl_of_list_map_Sup_aform_geI:
	assumes "x \<in> Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)"
	assumes "length a = DIM('b)"
	shows "x \<le> eucl_of_list (map Sup_aform a)"
	using Sup_aform_ge_Affine[OF assms(1)] assms(2)
	by (auto simp: Sup_aform_eucl_of_list_aform)

	lemma
	mem_Joints_appendE:
	assumes "x \<in> Joints (xs @ ys)"
	obtains x1 x2 where "x = x1 @ x2" "x1 \<in> Joints xs" "x2 \<in> Joints ys"
	using assms
	by (auto simp: Joints_def valuate_def)

	lemma c1_info_of_appr_subsetI1:
	fixes X1::"'b::executable_euclidean_space set"
	assumes subset: "{eucl_of_list (map Inf_aform (fst R)) .. eucl_of_list (map Sup_aform (fst R))} \<subseteq> X1"
	assumes len: "length (fst R) = DIM('b)"
	shows "aform.c1_info_of_appr R \<subseteq> X1 \<times> UNIV"
	using len
	apply (auto simp: aform.c1_info_of_appr_def flow1_of_list_def
	split: option.splits
	intro!: subsetD[OF subset] elim!: mem_Joints_appendE)
	subgoal
	by (auto intro!: eucl_of_list_mem_eucl_of_list_aform eucl_of_list_map_Inf_aform_leI eucl_of_list_map_Sup_aform_geI)
	subgoal
	by (auto intro!: eucl_of_list_mem_eucl_of_list_aform eucl_of_list_map_Inf_aform_leI eucl_of_list_map_Sup_aform_geI)
	subgoal
	apply (subst (2) eucl_of_list_take_DIM[symmetric, OF refl])
	apply (auto simp: min_def)
	apply (simp add: Joints_imp_length_eq eucl_of_list_map_Inf_aform_leI eucl_of_list_mem_eucl_of_list_aform)
	apply (simp add: Joints_imp_length_eq eucl_of_list_map_Inf_aform_leI eucl_of_list_mem_eucl_of_list_aform)
	done
	subgoal
	apply (subst (2) eucl_of_list_take_DIM[symmetric, OF refl])
	apply (auto simp: min_def)
	by (simp add: Joints_imp_length_eq eucl_of_list_map_Sup_aform_geI eucl_of_list_mem_eucl_of_list_aform)
	done

	lemmas [simp] = compute_tdev

	syntax product_aforms::"(real aform) list \<Rightarrow> (real aform) list \<Rightarrow> (real aform) list"
	(infixr "\<times>\<^sub>a" 70)

	lemma matrix_inner_Basis_list:
	includes vec_syntax
	assumes "k < CARD('n) * CARD('m)"
	shows "(f::(('n::enum rvec, 'm::enum) vec)) \<bullet> Basis_list ! k =
	vec_nth (vec_nth f (enum_class.enum ! (k div CARD('n)))) (enum_class.enum ! (k mod CARD('n)))"
	proof -
	have "f \<bullet> Basis_list ! k =
	(\<Sum>x\<in>UNIV.
	\<Sum>xa\<in>UNIV.
	if enum_class.enum ! (k mod CARD('n)) = xa \<and> enum_class.enum ! (k div CARD('n)) = x then f $ x $ xa else 0)"
	using assms
	unfolding inner_vec_def
	apply (auto simp: Basis_list_vec_def concat_map_map_index)
	apply (subst (2) sum.cong[OF refl])
	apply (subst sum.cong[OF refl])
	apply (subst (2) vec_nth_Basis2)
	apply (force simp add: Basis_vec_def Basis_list_real_def)
	apply (rule refl)
	apply (rule refl)
	apply (auto simp: if_distribR if_distrib axis_eq_axis Basis_list_real_def cong: if_cong)
	done
	also have "\<dots> = f $ enum_class.enum ! (k div CARD('n)) $ enum_class.enum ! (k mod CARD('n))"
	apply (subst if_conn)
	apply (subst sum.delta')
	apply simp
	by (simp add: sum.delta')
	finally show ?thesis by simp
	qed

	lemma list_of_eucl_matrix:
	includes vec_syntax
	shows "(list_of_eucl (M::(('n::enum rvec, 'm::enum) vec))) =
	concat (map (\<lambda>i. map (\<lambda>j. M $ (enum_class.enum ! i)$ (enum_class.enum ! j) )
	[0..<CARD('n)]) [0..<CARD('m)])"
	by (auto intro!: nth_equalityI simp: length_concat o_def sum_list_distinct_conv_sum_set ac_simps
	concat_map_map_index matrix_inner_Basis_list)

	lemma axis_eq_eucl_of_list:
	"(axis i 1::'n::enum rvec) = eucl_of_list ((replicate CARD('n) 0)[index enum_class.enum i := 1])"
	apply (auto intro!: euclidean_eqI[where 'a="'n rvec"]
	simp: eucl_of_list_inner nth_list_update )
	apply (auto simp: index_Basis_list_axis1[symmetric])
	by (simp add: inner_axis inner_commute vec_nth_Basis)

	lemma eucl_of_list_012: "eucl_of_list [vec_nth A 0, vec_nth A 1, vec_nth A 2] = A" for A::"3 rvec"
	apply vector
	apply (auto simp: vec_nth_eucl_of_list_eq index_Basis_list_axis1)
	using exhaust_3 three_eq_zero by blast


	definition "ldec x = (case quotient_of x of (i, j) \<Rightarrow> real_of_float (lapprox_rat 20 i j))"
	definition "udec x = (case quotient_of x of (i, j) \<Rightarrow> real_of_float (rapprox_rat 20 i j))"

	lemma ldec: "ldec x \<le> real_of_rat x"
	and udec: "real_of_rat x \<le> udec x"
	apply (auto simp: ldec_def udec_def split: prod.splits
	intro!: lapprox_rat[le] rapprox_rat[ge])
	apply (metis Fract_of_int_quotient less_eq_real_def less_int_code(1) of_rat_rat
	quotient_of_denom_pos quotient_of_div)
	apply (metis Fract_of_int_quotient less_eq_real_def less_int_code(1) of_rat_rat
	quotient_of_denom_pos quotient_of_div)
	done

	context includes floatarith_notation begin

	definition "matrix_of_degrees\<^sub>e =
	(let
	ur = Rad_of (Var 0);
	vr = Rad_of (Var 1)
	in
	[Cos ur, Cos vr, 0,
	Sin ur, Sin vr, 0,
	0, 0, 0])"

	definition "matrix_of_degrees u v =
	approx_floatariths 30 matrix_of_degrees\<^sub>e (aforms_of_point ([u, v, 0]))"

	lemma interpret_floatariths_matrix_of_degrees:
	"interpret_floatariths matrix_of_degrees\<^sub>e
	(([u::real, v::real, 0]))
	=
	[cos (rad_of u), cos (rad_of v), 0,
	sin (rad_of u), sin (rad_of v), 0,
	0, 0, 0]"
	by (auto simp: matrix_of_degrees\<^sub>e_def Let_def inverse_eq_divide)

	definition "num_options p sstep m N a projs print_fun =
	\<lparr>
	precision = p,
	adaptive_atol = FloatR 1 (- a),
	adaptive_rtol = FloatR 1 (- a),
	method_id = 2,
	start_stepsize = FloatR 1 (- sstep),
	iterations = 40,
	halve_stepsizes = 40,
	widening_mod = 10,
	rk2_param = FloatR 1 0,
	default_reduce = correct_girard (p) (m) (N),
	printing_fun = (\<lambda>a b.
	let
	_ = fold (\<lambda>(x, y, c) _.
	print_fun (String.implode (shows_segments_of_aform (x) (y) b c ''\<newline>''))) projs ();
	_ = print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\<newline>''))
	in
	()
	),
	tracing_fun = (\<lambda>a b.
	let
	_ = print_fun (String.implode (''# '' @ a @ ''\<newline>''))
	in case b of Some b \<Rightarrow>
	(let
	_ = ()
	in print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\<newline>'')))
	\| None \<Rightarrow> ())
	\<rparr>"

	definition "num_options_c1 p sstep m N a projs dcolors print_fun =
	(let
	no = num_options p sstep m N a (map (\<lambda>(x, y, c, ds). (x, y, c)) projs) print_fun;
	D = length dcolors
	in no
	\<lparr>printing_fun:=
	(\<lambda>a b. let _ = printing_fun no a b
	in if a then ()
	else fold (\<lambda>(x, y, c, ds) _. print_fun
	(String.implode (shows_aforms_vareq D [(x, y)] ds
	dcolors
	dcolors
	(FloatR 1 (-1)) ''# no C1 info'' b ''''))) projs ()
	)
	\<rparr>)"

	definition "num_options_code p sstep m N a projs print_fun =
	num_options (nat_of_integer p) (int_of_integer sstep) (nat_of_integer m) (nat_of_integer N)
	(int_of_integer a) (map (\<lambda>(i, j, k). (nat_of_integer i, nat_of_integer j, k)) projs) print_fun"

	definition "ro s n M g0 g1 inter_step =
	\<lparr>max_tdev_thres = FloatR 1 s,
	pre_split_reduce = correct_girard 30 n M,
	pre_inter_granularity = FloatR 1 g0,
	post_inter_granularity = (FloatR 1 g1),
	pre_collect_granularity = FloatR 1 g0,
	max_intersection_step = FloatR 1 inter_step\<rparr>"

	definition "code_ro s n m g0 g1 inter_step =
	ro (int_of_integer s) (nat_of_integer n) (nat_of_integer m) (int_of_integer g0) (int_of_integer g1) (int_of_integer inter_step)"

	fun xsec:: "real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "xsec x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [1,0,0] x)"
	fun xsec':: "real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "xsec' x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [-1,0,0] (-x))"

	fun ysec:: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, 1,0] y)"
	fun ysec':: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec' (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, -1,0] (-y))"

	fun zsec:: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "zsec (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, 1] z)"
	fun zsec':: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "zsec' (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, -1] (-z))"


	fun xsec2:: "real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "xsec2 x (y0, y1) = (([x, y0], [x, y1]), Sctn [1,0] x)"
	fun xsec2':: "real \<Rightarrow> real \<times> real \<Rightarrow>(real list \<times> real list) \<times> real list sctn"
	where "xsec2' x (y0, y1) = (([x, y0], [x, y1]), Sctn [-1,0] (-x))"

	fun ysec2:: "real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec2 (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, 1] y)"
	fun ysec2':: "real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec2' (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, -1] (-y))"

	fun ysec4:: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec4 (x0, x1) y (z0, z1) (m0, m1) = (([x0, y, z0, m0], [x1, y, z1, m1]), Sctn [0, 1,0, 0] (y))"

	fun ysec4':: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
	where "ysec4' (x0, x1) y (z0, z1) (m0, m1) = (([x0, y, z0, m0], [x1, y, z1, m1]), Sctn [0, -1,0, 0] (-y))"

	definition "code_sctn N n c = Sctn ((replicate (nat_of_integer N) (0::real))[nat_of_integer n := 1]) c"
	definition "code_sctn' N n c = Sctn ((replicate (nat_of_integer N) (0::real))[nat_of_integer n := -1]) (-c)"

	definition "lrat i j = real_of_float (lapprox_rat 30 (int_of_integer i) (int_of_integer j))"
	definition "urat i j = real_of_float (lapprox_rat 30 (int_of_integer i) (int_of_integer j))"

	definition [simp]: "TAG_optns (optns::string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow> (real aform) numeric_options)) = True"
	lemma TAG_optns: "P \<Longrightarrow> (TAG_optns optns \<Longrightarrow> P)"
	- by (auto simp: )
	+ by auto

	definition [simp]: "TAG_reach_optns (roi::real aform reach_options) = True"
	lemma TAG_reach_optns: "P \<Longrightarrow> (TAG_reach_optns optns \<Longrightarrow> P)"
	- by (auto simp: )
	+ by auto

	definition [simp]: "TAG_sctn (b::bool) = True"
	lemma TAG_sctn: "P \<Longrightarrow> (TAG_sctn optns \<Longrightarrow> P)"
	- by (auto simp: )
	+ by auto

	subsection \<open>Integrals and Computation\<close>

	lemma has_vderiv_on_PairD:
	assumes "((\<lambda>t. (f t, g t)) has_vderiv_on fg') T"
	shows "(f has_vderiv_on (\<lambda>t. fst (fg' t))) T" "(g has_vderiv_on (\<lambda>t. snd (fg' t))) T"
	proof -
	from assms have "((\<lambda>x. (f x, g x)) has_derivative (\<lambda>xa. xa *\<^sub>R fg' t)) (at t within T)"
	if "t \<in> T" for t
	by (auto simp: has_vderiv_on_def has_vector_derivative_def that
	intro!: derivative_eq_intros)
	from diff_chain_within[OF this has_derivative_fst[OF has_derivative_ident]]
	diff_chain_within[OF this has_derivative_snd[OF has_derivative_ident]]
	show "(f has_vderiv_on (\<lambda>t. fst (fg' t))) T" "(g has_vderiv_on (\<lambda>t. snd (fg' t))) T"
	by (auto simp: has_vderiv_on_def has_vector_derivative_def o_def)
	qed

	lemma solves_autonomous_odeI:
	assumes "((\<lambda>t. (t, phi t)) solves_ode (\<lambda>t x. (1, f (fst x) (snd x)))) S (T \<times> X)"
	shows "(phi solves_ode f) S X"
	proof (rule solves_odeI)
	from solves_odeD[OF assms]
	have
	"((\<lambda>t. (t, phi t)) has_vderiv_on (\<lambda>t. (1, f (fst (t, phi t)) (snd (t, phi t))))) S"
	"\<And>t. t \<in> S \<Longrightarrow> (phi t) \<in> X"
	- by (auto simp: )
	+ by auto
	from has_vderiv_on_PairD(2)[OF this(1)] this(2)
	show "(phi has_vderiv_on (\<lambda>t. f t (phi t))) S" "\<And>t. t \<in> S \<Longrightarrow> phi t \<in> X"
	by auto
	qed

	lemma integral_solves_autonomous_odeI:
	fixes f::"real \<Rightarrow> 'a::executable_euclidean_space"
	assumes "(phi solves_ode (\<lambda>t _. f t)) {a .. b} X" "phi a = 0"
	assumes "a \<le> b"
	shows "(f has_integral phi b) {a .. b}"
	proof -
	have "(f has_integral phi b - phi a) {a..b}"
	apply (rule fundamental_theorem_of_calculus[of a b phi f])
	unfolding has_vderiv_on_def[symmetric]
	apply fact
	using solves_odeD[OF assms(1)]
	by (simp add: has_vderiv_on_def)
	then show ?thesis by (simp add: assms)
	qed

	lemma zero_eq_eucl_of_list_rep_DIM: "(0::'a::executable_euclidean_space) = eucl_of_list (replicate (DIM('a)) 0)"
	by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner)

	lemma zero_eq_eucl_of_list_rep: "(0::'a::executable_euclidean_space) = eucl_of_list (replicate D 0)"
	if "D \<ge> DIM('a)"
	proof -
	from that have "replicate D (0::real) = replicate (DIM('a)) 0 @ replicate (D - DIM('a)) 0"
	by (auto simp: replicate_add[symmetric])
	also have "eucl_of_list \<dots> = (eucl_of_list (replicate DIM('a) 0)::'a)"
	by (rule eucl_of_list_append_zeroes)
	also have "\<dots> = 0"
	by (rule zero_eq_eucl_of_list_rep_DIM[symmetric])
	finally show ?thesis by simp
	qed

	lemma one_has_ivl_integral: "((\<lambda>x. 1::real) has_ivl_integral b - a) a b"
	using has_integral_const_real[of "1::real" a b] has_integral_const_real[of "1::real" b a]
	by (auto simp: has_ivl_integral_def split: if_splits)

	lemma Joints_aforms_of_point_self[simp]: "xs \<in> Joints (aforms_of_point xs)"
	by (simp add: aforms_of_point_def)

	lemma bind_eq_dRETURN_conv:
	"(f \<bind> g = dRETURN S) \<longleftrightarrow> (\<exists>R. f = dRETURN R \<and> g R = dRETURN S)"
	by (cases f) auto

	end

	lemma list_of_eucl_memI: "list_of_eucl (x::'x::executable_euclidean_space) \<in> S"
	if "x \<in> eucl_of_list ` S" "\<And>x. x \<in> S \<Longrightarrow> length x = DIM('x)"
	using that
	by auto

	lemma Joints_aforms_of_ivls_append_point:
	"Joints (xs @ aforms_of_ivls p p) = (\<lambda>x. x @ p) ` Joints xs"
	using aform.set_of_appr_of_ivl_append_point[unfolded aform_ops_def approximate_set_ops.simps] .


	context ode_interpretation begin

	theorem solves_one_step_ivl:
	assumes T: "T \<subseteq> {t1 .. t2}"
	assumes X: "X \<subseteq> {eucl_of_list lx .. eucl_of_list ux}" "length lx = DIM('a)" "length ux = DIM('a)"
	assumes S: "{eucl_of_list ls::'a .. eucl_of_list us} \<subseteq> S"
	assumes lens: "length ls = DIM('a)" "length us = DIM('a)" \<comment> \<open>TODO: this could be verified\<close>
	assumes [simp]: "aform.D odo = DIM('a)"
	assumes r: "solves_one_step_until_time_aform optns odo ((1,1), aforms_of_ivls lx ux, None) t1 t2 (ls, us) None"
	shows "t \<in> T \<longrightarrow> x0 \<in> X \<longrightarrow> t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S"
	proof (intro impI)
	assume t: "t \<in> T" and x0: "x0 \<in> X"
	from S have S: "set_of_lvivl (ls, us) \<subseteq> S"
	by (auto simp: set_of_lvivl_def set_of_ivl_def)
	have lens: "length (fst (ls, us)) = CARD('n)" "length (snd (ls, us)) = CARD('n)"
	by (auto simp: lens)
	have x0: "list_of_eucl x0 \<in> Joints (aforms_of_ivls lx ux)"
	apply (rule aforms_of_ivls)
	subgoal by (simp add: X)
	subgoal by (simp add: X)
	using subsetD[OF X(1) x0]
	apply (auto simp: eucl_le[where 'a='a] X)
	apply (metis assms(3) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
	apply (metis assms(4) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
	done
	from t T have t: "t \<in> {t1 .. t2}" by auto
	show "t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S"
	by (rule one_step_result12[OF r aform.c1_info_of_appre_c0_I[OF x0] t S subset_UNIV lens])
	(auto simp: aform.c1_info_invare_None lens X)
	qed

	theorem solves_one_step_ivl':
	assumes T: "T \<subseteq> {t1 .. t2}"
	assumes X: "X \<subseteq> {eucl_of_list lx .. eucl_of_list ux}"
	"length lx = DIM('a)" "length ux = DIM('a)"
	assumes DS: "list_interval lds uds \<subseteq> list_interval ld ud"
	and lends: "length lds = DIM('a)DIM('a)" "length uds = DIM('a)DIM('a)"
	assumes S: "{eucl_of_list ls::'a .. eucl_of_list us} \<subseteq> S"
	assumes lens0: "length ls = DIM('a)" "length us = DIM('a)" \<comment> \<open>TODO: this could be verified\<close>
	"length dx0s = DIM('a)*DIM('a)"
	assumes [simp]: "aform.D odo = DIM('a)"
	assumes r: "solves_one_step_until_time_aform optns odo
	((1,1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s)) t1 t2 (ls, us) (Some (lds, uds))"
	shows "t \<in> T \<longrightarrow> x0 \<in> X \<longrightarrow> t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S \<and>
	Dflow x0 t o\<^sub>L blinfun_of_list dx0s \<in> blinfuns_of_lvivl (ld, ud)"
	proof (intro impI)
	assume t: "t \<in> T" and x0: "x0 \<in> X"
	from S have S: "set_of_lvivl (ls, us) \<subseteq> S"
	by (auto simp: set_of_lvivl_def set_of_ivl_def)
	have lens: "length (fst (ls, us)) = CARD('n)" "length (snd (ls, us)) = CARD('n)"
	by (auto simp: lens0)
	have x0: "list_of_eucl x0 \<in> Joints (aforms_of_ivls lx ux)"
	apply (rule aforms_of_ivls)
	subgoal by (simp add: X)
	subgoal by (simp add: X)
	using subsetD[OF X(1) x0]
	apply (auto simp: eucl_le[where 'a='a] X)
	apply (metis assms(3) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
	apply (metis assms(4) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
	done
	have x0dx0: "(x0, blinfun_of_list dx0s) \<in>
	aform.c1_info_of_appre ((1, 1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s))"
	apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def)
	apply (rule image_eqI[where x="list_of_eucl x0@dx0s"])
	using lens0
	apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
	apply (rule imageI)
	apply (rule x0)
	done
	from t T have t: "t \<in> {t1 .. t2}" by auto
	have DS: "blinfuns_of_lvivl' (Some (lds, uds)) \<subseteq> blinfun_of_list ` list_interval ld ud"
	using DS
	by (auto simp: blinfuns_of_lvivl'_def blinfuns_of_lvivl_def)
	have inv: "aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lds, uds))"
	"aform.c1_info_invare DIM('a) ((1::ereal, 1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s))"
	by (auto simp: aform.lvivl'_invar_def lends aform.c1_info_invare_def X lens0 power2_eq_square
	aform.c1_info_invar_def)
	from one_step_result123[OF r x0dx0 t S DS lens inv \<open>aform.D _ = _\<close>]
	show "t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S \<and> Dflow x0 t o\<^sub>L blinfun_of_list dx0s \<in> blinfuns_of_lvivl (ld, ud)"
	by (auto simp: blinfuns_of_lvivl_def)
	qed

	end

	definition "zero_aforms D = map (\<lambda>_. (0, zero_pdevs)) [0..<D]"

	definition "solves_one_step_until_time_aform_fo soptns a b c d e f =
	file_output (String.implode (fst soptns)) (\<lambda>pf. solves_one_step_until_time_aform (snd soptns pf) a b c d e f)"

	definition "solves_poincare_map_aform'_fo soptns a b c d e f g h i =
	file_output (String.implode (fst soptns)) (\<lambda>pf. solves_poincare_map_aform' (snd soptns pf) a b c d e f g h i)"

	definition "solves_poincare_map_onto_aform_fo soptns a b c d e f g h =
	file_output (String.implode (fst soptns)) (\<lambda>pf. solves_poincare_map_onto_aform (snd soptns pf) a b c d e f g h)"

	lemma solves_one_step_until_time_aform_foI:
	"solves_one_step_until_time_aform (snd optns (\<lambda>_. ())) a b c d e f"
	if "solves_one_step_until_time_aform_fo optns a b c d e f"
	using that
	by (auto simp: solves_one_step_until_time_aform_fo_def file_output_def Print.file_output_def
	print_def[abs_def]
	split: if_splits)

	lemma solves_poincare_map_aform'_foI:
	"solves_poincare_map_aform' (snd optns (\<lambda>_. ())) a b c d e f g h i"
	if "solves_poincare_map_aform'_fo optns a b c d e f g h i"
	using that
	by (auto simp: solves_poincare_map_aform'_fo_def file_output_def Print.file_output_def
	print_def[abs_def]
	split: if_splits)

	lemma solves_poincare_map_onto_aform_foI:
	"solves_poincare_map_onto_aform (snd optns (\<lambda>_. ())) a b c d e f g h"
	if "solves_poincare_map_onto_aform_fo optns a b c d e f g h"
	using that
	by (auto simp: solves_poincare_map_onto_aform_fo_def file_output_def Print.file_output_def
	print_def[abs_def]
	split: if_splits)

	definition "can_mk_ode_ops fas safe_form \<longleftrightarrow> mk_ode_ops fas safe_form \<noteq> None"

	theorem solve_one_step_until_time_aform_integral_bounds:
	fixes f::"real \<Rightarrow> 'a::executable_euclidean_space"
	assumes "a \<le> b"
	assumes ba: "b - a \<in> {t1 .. t2}"
	assumes a: "a \<in> {a1 .. a2}"
	assumes ls_us_subset: "{eucl_of_list ls .. eucl_of_list us} \<subseteq> {l .. u}"
	assumes fas: "\<And>xs::real list. length xs > 0 \<Longrightarrow> interpret_form safe_form xs \<Longrightarrow>
	(1::real, f (xs ! 0)) = einterpret fas xs"
	assumes D: "D = DIM('a) + 1" "D = CARD('i::enum)"
	assumes lenlu: "length ls + 1 = D" "length us + 1 = D"
	assumes lfas: "length fas = D"
	assumes mv: "can_mk_ode_ops fas safe_form"
	assumes FDERIV: "\<And>xs. interpret_form safe_form xs \<Longrightarrow> isFDERIV (length fas) [0..<length fas] fas xs"
	assumes sos[THEN solves_one_step_until_time_aform_foI]:
	"solves_one_step_until_time_aform_fo optns (the(mk_ode_ops fas safe_form))
	((1,1), (aforms_of_ivls (a1#replicate (D - 1) 0) (a2#replicate (D - 1) 0)), None) t1 t2 (0#ls, t2#us) None"
	shows "integral {a .. b} f \<in> {l .. u}"
	proof -
	have lens0: "length ((x::real) # replicate (D - 1) 0) = DIM(real \<times> 'a)" for x
	using assms
	by auto
	have a0: "(a, 0) \<in> {eucl_of_list (a1 # replicate (D - 1) 0)..eucl_of_list (a2 # replicate (D - 1) 0)}"
	using assms
	by (auto simp: eucl_of_list_prod)
	let ?U = "{x::real\<times>'a. interpret_form safe_form (list_of_eucl x)}"
	interpret ode_interpretation safe_form ?U fas "\<lambda>x. (1::real, f (fst x))" "undefined::'i"
	apply unfold_locales
	subgoal using assms by simp
	subgoal using assms by simp
	subgoal using mv by (simp add: D lfas)
	subgoal for x
	apply (cases x)
	by (rule HOL.trans[OF fas[symmetric]]) (auto simp: fas)
	subgoal using mv by (simp add: can_mk_ode_ops_def)
	subgoal by (rule FDERIV)
	done
	have lens: "length (0 # ls) = DIM(real \<times> 'a)" "length (t2 # us) = DIM(real \<times> 'a)" "aform.D odo = DIM(real \<times> 'a)"
	using lenlu
	by (simp_all add: lfas aform.D_def D aform.ode_e_def )
	have D_odo: "aform.D odo = DIM(real \<times> 'a)"
	by (auto simp: aform.D_def aform.ode_e_def lfas D)
	from solves_one_step_ivl[rule_format, OF order_refl order_refl lens0 lens0 order_refl lens(1,2) D_odo,
	unfolded odo_def,
	OF sos ba a0]
	have lsus: "flow0 (a, 0) (b - a) \<in> {eucl_of_list (0#ls)..eucl_of_list (t2#us)}"
	and exivl: "b - a \<in> existence_ivl0 (a, 0)"
	by auto
	have flow: "flow0 (a, 0) (b - a) \<in> UNIV \<times> {l..u}"
	using lsus
	apply (rule rev_subsetD)
	using ls_us_subset
	by (auto simp: eucl_of_list_prod)
	from ivl_subset_existence_ivl[OF exivl] \<open>a \<le> b\<close> exivl
	have "0 \<in> existence_ivl0 (a, 0)"
	by (auto simp del: existence_ivl_initial_time_iff)
	from mem_existence_ivl_iv_defined(2)[OF this]
	have safe: "(a, 0::'a) \<in> ?U" by simp
	from flow_solves_ode[OF UNIV_I this]
	have fs: "((\<lambda>t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) solves_ode (\<lambda>_ x. (1, f (fst x)))) (existence_ivl0 (a, 0)) ?U"
	by simp
	with solves_odeD[OF fs]
	have vdp: "((\<lambda>t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) has_vderiv_on (\<lambda>t. (1, f (fst (flow0 (a, 0) t))))) (existence_ivl0 (a, 0))"
	by simp
	have "fst (flow0 (a, 0) t) = a + t" if "t \<in> existence_ivl0 (a, 0)" for t
	proof -
	have "fst (flow0 (a, 0) 0) = a" using safe
	- by (auto simp: )
	+ by auto
	have "((\<lambda>t. fst (flow0 (a, 0) t)) has_vderiv_on (\<lambda>x. 1)) (existence_ivl0 (a, 0))"
	using has_vderiv_on_PairD[OF vdp] by auto
	then have "((\<lambda>t. fst (flow0 (a, 0) t)) has_vderiv_on (\<lambda>x. 1)) {0--t}"
	apply (rule has_vderiv_on_subset)
	using closed_segment_subset_existence_ivl[OF that]
	by auto
	from fundamental_theorem_of_calculus_ivl_integral[OF this, THEN ivl_integral_unique]
	one_has_ivl_integral[of t 0, THEN ivl_integral_unique] safe
	show ?thesis
	by auto
	qed
	with vdp have "((\<lambda>t. (t, snd (flow0 (a, 0) t))) solves_ode (\<lambda>t x. (1, f (a + fst x))))
	(existence_ivl0 (a, 0)) ((existence_ivl0 (a, 0)) \<times> UNIV)"
	apply (intro solves_odeI)
	apply auto
	apply (auto simp: has_vderiv_on_def has_vector_derivative_def)
	proof goal_cases
	case (1 x)
	have r: "((\<lambda>(x, y). (x - a, y::'a)) has_derivative (\<lambda>x. x)) (at x within t)" for x t
	by (auto intro!: derivative_eq_intros)
	from 1 have "((\<lambda>x. (a + x, snd (flow0 (a, 0) x))) has_derivative (\<lambda>xa. (xa, xa *\<^sub>R f (a + x))))
	(at x within existence_ivl0 (a, 0))"
	by auto
	from has_derivative_in_compose2[OF r subset_UNIV _ this, simplified] 1
	have "((\<lambda>x. (x, snd (flow0 (a, 0) x))) has_derivative (\<lambda>y. (y, y *\<^sub>R f (a + x)))) (at x within existence_ivl0 (a, 0))"
	by auto
	then show ?case
	by simp
	qed
	from solves_autonomous_odeI[OF this]
	have "((\<lambda>t. snd (flow0 (a, 0) t)) solves_ode (\<lambda>b c. f (a + b))) (existence_ivl0 (a, 0)) UNIV"
	by simp \<comment> \<open>TODO: do non-autonomous -- autonomous conversion automatically!\<close>
	then have "((\<lambda>t. snd (flow0 (a, 0) t)) solves_ode (\<lambda>b c. f (a + b))) {0 .. b - a} UNIV"
	apply (rule solves_ode_on_subset)
	using exivl
	by (rule ivl_subset_existence_ivl) (rule order_refl)
	from integral_solves_autonomous_odeI[OF this]
	have "((\<lambda>b. f (a + b)) has_integral snd (flow0 (a, 0) (b - a))) (cbox 0 (b - a))"
	using \<open>a \<le> b\<close> safe
	by auto
	from has_integral_affinity[OF this, where m=1 and c="-a"]
	have "(f has_integral snd (flow0 (a, 0) (b - a))) {a..b}"
	by auto
	then have "integral {a..b} f = snd (flow0 (a, 0) (b - a))" by blast
	also have "\<dots> \<in> {l .. u}"
	using flow
	by auto
	finally show ?thesis by simp
	qed

	lemma [code_computation_unfold]:
	"numeral x = real_of_int (Code_Target_Int.positive x)"
	by simp
	lemma [code_computation_unfold]: "numeral x \<equiv> Float (Code_Target_Int.positive x) 0"
	by (simp add: Float_def float_of_numeral)

	definition no_print::"String.literal \<Rightarrow> unit" where "no_print x = ()"

	lemmas [approximation_preproc] = list_of_eucl_real list_of_eucl_prod append.simps

	named_theorems DIM_simps
	lemmas [DIM_simps] =
	DIM_real DIM_prod length_nth_simps
	add_numeral_special
	add_numeral_special card_sum card_prod card_bit0 card_bit1 card_num0 card_num1
	numeral_times_numeral numeral_mult mult_1_right mult_1
	aform.D_def

	lemma numeral_refl: "numeral x = numeral x" by simp

	lemma plain_floatarith_approx_eq_SomeD:
	"approx prec fa [] = Some (the (approx prec fa []))"
	if "plain_floatarith 0 fa"
	using that
	by (auto dest!: plain_floatarith_approx_not_None[where p=prec and XS=Nil])

	definition [simp]: "approx1 p f xs = real_of_float (lower (the (approx p f xs)))"
	definition [simp]: "approx2 p f xs = real_of_float (upper (the (approx p f xs)))"
	definition [simp]: "approx_defined p f xs \<longleftrightarrow> approx p f xs \<noteq> None"

	definition "approxs p fs xs = those (map (\<lambda>f. approx p f xs) fs)"
	definition [simp]: "approxs1 p f xs =
	(case approxs p f xs of Some y \<Rightarrow> (map (real_of_float o lower) y) \| None \<Rightarrow> replicate (length f) 0)"
	definition [simp]: "approxs2 p f xs =
	(case approxs p f xs of Some y \<Rightarrow> (map (real_of_float o upper) y) \| None \<Rightarrow> replicate (length f) 0)"
	definition "approxs_defined p fs xs \<longleftrightarrow> (those (map (\<lambda>f. approx p f xs) fs) \<noteq> None)"

	lemma length_approxs:
	"length (approxs1 p f xs) = length f"
	"length (approxs2 p f xs) = length f"
	by (auto simp: approxs_def dest!: those_eq_SomeD split: option.splits)

	lemma real_in_approxI:
	"x \<in> {(approx1 prec fa []) .. (approx2 prec fa [])}"
	if "x = interpret_floatarith fa []"
	"approx_defined prec fa []"
	using that
	by (force dest: approx_emptyD simp: set_of_eq)

	lemma real_subset_approxI:
	"{a .. b} \<subseteq> {(approx1 prec fa []) .. (approx2 prec fb [])}"
	if "a = interpret_floatarith fa []"
	"b = interpret_floatarith fb []"
	"approx_defined prec fa []"
	"approx_defined prec fb []"
	using that
	by (force dest: approx_emptyD simp: set_of_eq)


	lemma approxs_eq_Some_lengthD: "length ys = length fas" if "approxs prec fas XS = Some ys"
	using that
	by (auto simp: approxs_def dest!: those_eq_SomeD)

	lemma approxs_pointwise:
	"interpret_floatarith (fas ! ia) xs \<in> {real_of_float (lower (ys ! ia)) .. (upper (ys ! ia))}"
	if "approxs prec fas XS = Some ys" "bounded_by xs XS" "ia < length fas"
	proof -
	from those_eq_SomeD[OF that(1)[unfolded approxs_def]]
	have ys: "ys = map (the \<circ> (\<lambda>f. approx prec f XS)) fas"
	and ex: "\<exists>y. i < length fas \<longrightarrow> approx prec (fas ! i) XS = Some y" for i
	by auto
	from ex[of ia] that obtain ivl where ivl: "approx prec (fas ! ia) XS = Some ivl" by auto
	from approx[OF that(2) this]
	have "interpret_floatarith (fas ! ia) xs \<in>\<^sub>r ivl"
	by auto
	moreover
	have "ys ! ia = ivl"
	unfolding ys
	apply (auto simp: o_def)
	apply (subst nth_map)
	apply (simp add: that)
	using ivl by simp
	ultimately show ?thesis
	using that
	by (auto simp: approxs_eq_Some_lengthD set_of_eq split: prod.splits)
	qed

	lemmas approxs_pointwise_le = approxs_pointwise[simplified, THEN conjunct1]
	and approxs_pointwise_ge = approxs_pointwise[simplified, THEN conjunct2]

	lemma approxs_eucl:
	"eucl_of_list (interpret_floatariths fas xs) \<in>
	{eucl_of_list (map lower ys) .. eucl_of_list (map upper ys)::'a::executable_euclidean_space}"
	if "approxs prec fas XS = Some ys"
	"length fas = DIM('a)"
	"bounded_by xs XS"
	using that
	by (auto simp: eucl_le[where 'a='a] eucl_of_list_inner o_def approxs_eq_Some_lengthD
	intro!: approxs_pointwise_le approxs_pointwise_ge)

	lemma plain_floatariths_approx_eq_SomeD:
	"approxs prec fas [] = Some (the (approxs prec fas []))"
	if "list_all (plain_floatarith 0) fas"
	using that
	apply (induction fas)
	apply (auto simp: approxs_def split: option.splits dest!: plain_floatarith_approx_eq_SomeD)
	subgoal for a fas aa
	apply (cases "those (map (\<lambda>f. approx prec f []) fas)")
	by auto
	done

	lemma approxs_definedD:
	"approxs prec fas xs = Some (the (approxs prec fas xs))"
	if "approxs_defined prec fas xs"
	using that
	by (auto simp: approxs_defined_def approxs_def)

	lemma approxs_defined_ne_None[simp]:
	"approxs prec fas xs \<noteq> None"
	if "approxs_defined prec fas xs"
	using that
	by (auto simp: approxs_defined_def approxs_def)

	lemma approx_subset_euclI:
	"{eucl_of_list (approxs2 prec fals [])::'a .. eucl_of_list (approxs1 prec faus [])} \<subseteq> {l .. u}"
	if "list_of_eucl l = interpret_floatariths fals []"
	and "list_of_eucl u = interpret_floatariths faus []"
	and "length fals = DIM('a::executable_euclidean_space)"
	and "length faus = DIM('a::executable_euclidean_space)"
	and "approxs_defined prec fals []"
	and "approxs_defined prec faus []"
	using that
	by (auto intro!: bounded_by_Nil
	dest!: approxs_eucl[where 'a='a] list_of_eucl_eqD plain_floatariths_approx_eq_SomeD[where prec=prec]
	split: option.splits)

	lemma eucl_subset_approxI:
	"{l .. u} \<subseteq> {eucl_of_list (approxs1 prec fals [])::'a .. eucl_of_list (approxs2 prec faus [])}"
	if "list_of_eucl l = interpret_floatariths fals []"
	and "list_of_eucl u = interpret_floatariths faus []"
	and "length fals = DIM('a::executable_euclidean_space)"
	and "length faus = DIM('a::executable_euclidean_space)"
	and "approxs_defined prec fals []"
	and "approxs_defined prec faus []"
	using that
	by (auto intro!: bounded_by_Nil
	dest!: approxs_eucl[where 'a='a] list_of_eucl_eqD plain_floatariths_approx_eq_SomeD[where prec=prec]
	split: option.splits)

	lemma approx_subset_listI:
	"list_interval (approxs2 prec fals []) (approxs1 prec faus []) \<subseteq> list_interval l u"
	if "l = interpret_floatariths fals []"
	and "u = interpret_floatariths faus []"
	and "length fals = length l"
	and "length faus = length u"
	and "approxs_defined prec fals []"
	and "approxs_defined prec faus []"
	using that
	apply (auto
	simp: list_interval_def list_all2_conv_all_nth
	dest: approxs_eq_Some_lengthD
	intro!: bounded_by_Nil
	dest!: plain_floatariths_approx_eq_SomeD[where prec=prec]
	split: option.splits)
	apply (rule order_trans)
	apply (rule approxs_pointwise_ge)
	apply assumption
	apply (rule bounded_by_Nil)
	apply (auto dest: approxs_eq_Some_lengthD)
	apply (subst interpret_floatariths_nth)
	apply (auto dest: approxs_eq_Some_lengthD)
	apply (rule approxs_pointwise_le[ge])
	apply assumption
	apply (rule bounded_by_Nil)
	apply (auto dest: approxs_eq_Some_lengthD)
	done


	definition "unit_list D n = (replicate D 0)[n:=1]"

	definition "mirror_sctn (sctn::real list sctn) = Sctn (map uminus (normal sctn)) (- pstn sctn)"
	definition "mirrored_sctn b (sctn::real list sctn) = (if b then mirror_sctn sctn else sctn)"

	lemma mirror_sctn_simps[simp]: "pstn (mirror_sctn sctn) = - pstn sctn"
	"normal (mirror_sctn sctn) = map uminus (normal sctn)"
	by (cases sctn) (auto simp: mirror_sctn_def)

	lemma length_unit_list[simp]: "length (unit_list D n) = D"
	by (auto simp: unit_list_def)

	lemma eucl_of_list_unit_list[simp]:
	"(eucl_of_list (unit_list D n)::'a::executable_euclidean_space) = Basis_list ! n"
	if "D = DIM('a)" "n < D"
	using that
	by (auto simp: unit_list_def eucl_of_list_inner inner_Basis nth_list_update'
	intro!: euclidean_eqI[where 'a='a])

	lemma le_eucl_of_list_iff: "(t::'a::executable_euclidean_space) \<le> eucl_of_list uX0 \<longleftrightarrow>
	(\<forall>i. i < DIM('a) \<longrightarrow> t \<bullet> Basis_list ! i \<le> uX0 ! i)"
	if "length uX0 = DIM('a)"
	using that
	apply (auto simp: eucl_le[where 'a='a] eucl_of_list_inner)
	using nth_Basis_list_in_Basis apply force
	by (metis Basis_list in_Basis_index_Basis_list index_less_size_conv length_Basis_list)

	lemma eucl_of_list_le_iff: "eucl_of_list uX0 \<le> (t::'a::executable_euclidean_space) \<longleftrightarrow>
	(\<forall>i. i < DIM('a) \<longrightarrow> uX0 ! i \<le> t \<bullet> Basis_list ! i)"
	if "length uX0 = DIM('a)"
	using that
	apply (auto simp: eucl_le[where 'a='a] eucl_of_list_inner)
	using nth_Basis_list_in_Basis apply force
	by (metis Basis_list in_Basis_index_Basis_list index_less_size_conv length_Basis_list)

	lemma Joints_aforms_of_ivls: "Joints (aforms_of_ivls lX0 uX0) = list_interval lX0 uX0"
	if "list_all2 (\<le>) lX0 uX0"
	using that
	apply (auto simp: list_interval_def dest: Joints_aforms_of_ivlsD1[OF _ that]
	Joints_aforms_of_ivlsD2[OF _ that] list_all2_lengthD
	intro!: aforms_of_ivls)
	by (auto simp: list_all2_conv_all_nth)

	lemma list_of_eucl_in_list_interval_iff:
	"list_of_eucl x0 \<in> list_interval lX0 uX0 \<longleftrightarrow> x0 \<in> {eucl_of_list lX0 .. eucl_of_list uX0::'a}"
	if "length lX0 = DIM('a::executable_euclidean_space)"
	"length uX0 = DIM('a::executable_euclidean_space)"
	using that
	by (auto simp: list_interval_def eucl_of_list_le_iff le_eucl_of_list_iff list_all2_conv_all_nth)


	text \<open>TODO: make a tactic out of this?!\<close>

	lemma file_output_iff: "file_output s f = f (\<lambda>_. ())"
	by (auto simp: file_output_def print_def[abs_def] Print.file_output_def)

	context ode_interpretation begin

	lemma poincare_mapsto_subset:
	"poincare_mapsto P X0 SS CX R"
	if "poincare_mapsto P' Y0 RR CZ S" "X0 \<subseteq> Y0" "CZ \<subseteq> CX" "S \<subseteq> R" "RR = SS" "P = P'"
	using that
	by (force simp: poincare_mapsto_def)

	theorem solves_poincare_map_aform'_derivI:
	assumes solves:
	"solves_poincare_map_aform'_fo optns odo
	(Sctn (unit_list D n) (lP ! n))
	guards
	(lP, uP)
	(Sctn (unit_list D n) (lP ! n))
	roi
	[((1,1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))]
	(lR, uR)
	(Some (lDR, uDR))"
	and D: "D = DIM('a)"
	assumes DS: "list_interval lDR uDR \<subseteq> list_interval lDS uDS"
	and dim: "aform.D odo = DIM('a)"
	and lens:
	"length (lP) = DIM('a)" "length (uP) = DIM('a)"
	"length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
	"length (lR) = DIM('a)" "length (uR) = DIM('a)"
	"length DX0 = DIM('a)*DIM('a)"
	"length lDR = CARD('n) * CARD('n)"
	"length uDR = CARD('n) * CARD('n)"
	and guards:
	"(\<And>a xs b ba ro.
	(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and> length b = DIM('a) \<and> length (normal ba) = DIM('a))"
	and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
	and plane: "uP ! n = lP ! n"
	and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
	and nD: "n < DIM('a)"
	and SS: "SS = {x::'a. x \<bullet> Basis_list ! n \<le> lP ! n}"
	and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
	shows "\<forall>x\<in>X0. returns_to P x \<and>
	return_time P differentiable at x within SS \<and>
	(\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
	poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
	proof (rule ballI)
	fix x assume "x \<in> X0"
	then have la2: "list_all2 (\<le>) lX0 uX0"
	using X0
	by (force simp: subset_iff eucl_of_list_le_iff le_eucl_of_list_iff lens list_all2_conv_all_nth)
	have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \<Longrightarrow>
	aform.c1_info_invare DIM('a) X"
	for X
	by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens power2_eq_square)
	have 2: "length (normal (Sctn (unit_list D n) (lP ! n))) = DIM('a)"
	by (auto simp: D)
	have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
	by (auto simp: lens)
	have 4: "length (normal (Sctn (unit_list D n) (lP ! n))) = DIM('a)"
	by (auto simp: D)
	have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
	"aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lDR, uDR))"
	by (auto simp: lens aform.lvivl'_invar_def)
	note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
	have "poincare_mapsto
	(set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
	(aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))])
	(below_halfspace
	(map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
	(aform.Csafe odo -
	set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
	(set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' (Some (lDR, uDR)))"
	by (rule solves_poincare_map_aform'[OF solves, OF 1 dim 2 3 4 guards 5])
	auto
	then have "poincare_mapsto P (X0 \<times> {blinfun_of_list DX0}::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) SS UNIV
	(R \<times> blinfuns_of_lvivl (lDS, uDS))"
	apply (rule poincare_mapsto_subset)
	subgoal using X0
	apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def
	aform.c1_info_of_apprse_def)
	subgoal for x0
	apply (rule image_eqI[where x="list_of_eucl x0@DX0"])
	using lens
	apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
	apply (rule imageI)
	using X0
	by (auto simp: Joints_aforms_of_ivls la2 list_of_eucl_in_list_interval_iff)
	done
	subgoal by simp
	subgoal using R DS
	by (auto simp: set_of_lvivl_def set_of_ivl_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_def
	lens)
	subgoal
	using assms
	by (simp add: below_halfspace_def le_halfspace_def[abs_def])
	subgoal
	using assms
	by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
	le_eucl_of_list_iff eucl_of_list_le_iff)
	done
	then show "returns_to P x \<and>
	return_time P differentiable at x within SS \<and>
	(\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
	poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
	using \<open>x \<in> X0\<close>
	by (auto simp: poincare_mapsto_def)
	qed

	definition guards_invar::"nat \<Rightarrow> (((real list \<times> real list) \<times> real list sctn) list \<times>
	(real \<times> real pdevs) reach_options) list \<Rightarrow> bool"
	where "guards_invar D guards = (\<forall>(xs, ro) \<in> set guards.
	\<forall>((a, b), ba) \<in> set xs. length a = D \<and> length b = D \<and> length (normal ba) = D)"

	theorem solves_poincare_map_aform'I:
	assumes "TAG_optns optns"
	assumes "TAG_reach_optns roi"
	assumes "TAG_sctn mirrored"
	assumes D: "D = DIM('a)"
	assumes guards: "guards_invar DIM('a) guards"
	and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
	and plane: "uP ! n = lP ! n"
	and dim: "aform.D odo = DIM('a)"
	and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
	and nD: "n < DIM('a)"
	and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
	and lens:
	"length (lP) = DIM('a)" "length (uP) = DIM('a)"
	"length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
	"length (lR) = DIM('a)" "length (uR) = DIM('a)"
	and solves:
	"solves_poincare_map_aform'_fo optns odo
	(Sctn (unit_list D n) (lP ! n))
	guards
	(lP, uP)
	(mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
	roi
	[((1,1), aforms_of_ivls lX0 uX0, None)]
	(lR, uR)
	None"
	shows "\<forall>x\<in>X0. returns_to P x \<and> poincare_map P x \<in> R"
	proof -
	note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
	have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \<Longrightarrow>
	aform.c1_info_invare DIM('a) X"
	for X
	by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens)
	have 2: "length (normal ((mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
	by (auto simp: D mirrored_sctn_def)
	have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
	by (auto simp: lens)
	have 4: "length (normal (((Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
	by (auto simp: D mirrored_sctn_def)
	from guards have guards: "(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and>
	length b = DIM('a) \<and> length (normal ba) = DIM('a)" for xs ro a b ba
	by (auto simp: guards_invar_def)
	have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
	"aform.lvivl'_invar (CARD('n) * CARD('n)) None"
	by (auto simp: lens)
	have "poincare_mapsto
	(set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, None)])
	(below_halfspace (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
	(aform.Csafe odo -
	set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' None)"
	by (rule solves_poincare_map_aform'[OF solves, OF 1 dim 2 3 4 guards 5])
	then have "poincare_mapsto P (X0 \<times> UNIV::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set)
	(below_halfspace (map_sctn eucl_of_list (((Sctn (unit_list D n) (lP ! n)))))) UNIV (R \<times> UNIV)"
	apply (rule poincare_mapsto_subset)
	subgoal using X0
	apply (auto simp: aform.c1_info_of_apprse_def aform.c1_info_of_appre_def
	aform.c1_info_of_appr_def)
	apply (rule image_eqI) apply (rule eucl_of_list_list_of_eucl[symmetric])
	apply (rule aforms_of_ivls)
	by (auto simp add: lens subset_iff le_eucl_of_list_iff eucl_of_list_le_iff)
	subgoal by simp
	subgoal using R by (auto simp: set_of_lvivl_def set_of_ivl_def)
	subgoal
	using assms
	by (simp add: below_halfspace_def le_halfspace_def[abs_def])
	subgoal
	using assms
	by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
	le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)
	done
	then show "\<forall>x\<in>X0. returns_to P x \<and> poincare_map P x \<in> R"
	by (auto simp: poincare_mapsto_def)
	qed

	definition "poincare_map_from_outside = poincare_map"

	theorem poincare_maps_onto_aformI:
	assumes "TAG_optns optns"
	assumes "TAG_reach_optns roi"
	assumes "TAG_sctn mirrored"
	assumes D: "D = DIM('a)"
	assumes guards: "guards_invar DIM('a) guards"
	and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
	and plane: "uP ! n = lP ! n"
	and dim: "aform.D odo = DIM('a)"
	and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
	and nD: "n < DIM('a)"
	and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
	and lens:
	"length (lP) = DIM('a)" "length (uP) = DIM('a)"
	"length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
	"length (lR) = DIM('a)" "length (uR) = DIM('a)"
	and solves:
	"solves_poincare_map_onto_aform_fo optns odo
	guards
	(lP, uP)
	(mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
	roi
	[((1,1), aforms_of_ivls lX0 uX0, None)]
	(lR, uR)
	None"
	shows "\<forall>x\<in>X0. returns_to P x \<and> poincare_map_from_outside P x \<in> R"
	proof -
	note solves = solves[unfolded solves_poincare_map_onto_aform_fo_def file_output_iff]
	have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \<Longrightarrow>
	aform.c1_info_invare DIM('a) X"
	for X
	by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens)
	have 2: "length (normal ((mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
	by (auto simp: D mirrored_sctn_def)
	have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
	by (auto simp: lens)
	from guards have guards: "(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = DIM('a) \<and>
	length b = DIM('a) \<and> length (normal ba) = DIM('a)" for xs ro a b ba
	by (auto simp: guards_invar_def)
	have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
	"aform.lvivl'_invar (CARD('n) * CARD('n)) None"
	by (auto simp: lens)
	have "poincare_mapsto
	(set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, None)])
	UNIV
	(aform.Csafe odo -
	set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' None)"
	by (rule solves_poincare_map_onto_aform[OF solves, OF 1 dim 2 3 guards 5])
	then have "poincare_mapsto P (X0 \<times> UNIV::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) UNIV UNIV (R \<times> UNIV)"
	apply (rule poincare_mapsto_subset)
	subgoal using X0
	apply (auto simp: aform.c1_info_of_apprse_def aform.c1_info_of_appre_def
	aform.c1_info_of_appr_def)
	apply (rule image_eqI) apply (rule eucl_of_list_list_of_eucl[symmetric])
	apply (rule aforms_of_ivls)
	by (auto simp add: lens subset_iff le_eucl_of_list_iff eucl_of_list_le_iff)
	subgoal by simp
	subgoal using R by (auto simp: set_of_lvivl_def set_of_ivl_def)
	subgoal by simp
	subgoal
	using assms
	by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
	le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)
	done
	then show "\<forall>x\<in>X0. returns_to P x \<and> poincare_map_from_outside P x \<in> R"
	by (auto simp: poincare_mapsto_def poincare_map_from_outside_def)
	qed

	end

	lemmas [simp] = length_approxs

	context includes ode_ops.lifting begin
	lift_definition empty_ode_ops::"ode_ops" is "([], true_form)"
	- by (auto simp: )
	+ by auto
	end

	ML \<open>val ode_numerics_conv = @{computation_check
	terms:
	Trueprop

	Not

	solves_one_step_until_time_aform_fo
	solves_poincare_map_aform'_fo
	solves_poincare_map_onto_aform_fo

	num_options
	num_options_c1
	ro

	(* nat *)
	Suc "0::nat" "1::nat" "(+)::nat \<Rightarrow> nat \<Rightarrow> nat" "(-) ::nat \<Rightarrow> nat \<Rightarrow> nat" "(=)::nat\<Rightarrow>nat\<Rightarrow>bool"
	"(^)::nat\<Rightarrow>nat\<Rightarrow>nat"

	(* int / integer*)
	"(=)::int\<Rightarrow>int\<Rightarrow>bool"
	"(+)::int\<Rightarrow>int\<Rightarrow>int"
	"uminus::_\<Rightarrow>int"
	"uminus::_\<Rightarrow>integer"
	int_of_integer integer_of_int
	"0::int"
	"1::int"
	"(^)::int\<Rightarrow>nat\<Rightarrow>int"

	(* real *)
	"(=)::real\<Rightarrow>real\<Rightarrow>bool"
	"real_of_float"
	"(/)::real\<Rightarrow>real\<Rightarrow>real"
	"(^)::real\<Rightarrow>nat\<Rightarrow>real"
	"uminus::real\<Rightarrow>_"
	"(+)::real\<Rightarrow>real\<Rightarrow>real" "(-)::real\<Rightarrow>real\<Rightarrow>real" "(*)::real\<Rightarrow>real\<Rightarrow>real"
	real_divl real_divr
	real_of_int
	"0::real"
	"1::real"

	(* rat *)
	Fract
	"0::rat"
	"1::rat"
	"(+)::rat\<Rightarrow>rat\<Rightarrow>rat"
	"(-)::rat\<Rightarrow>rat\<Rightarrow>rat"
	"(*)::rat\<Rightarrow>rat\<Rightarrow>rat"
	"uminus::rat\<Rightarrow>_"
	"(/)::rat\<Rightarrow>rat\<Rightarrow>rat"
	"(^)::rat\<Rightarrow>nat\<Rightarrow>rat"

	(* ereal *)
	"1::ereal"

	(* lists: *)
	"replicate::_\<Rightarrow>real\<Rightarrow>_"
	"unit_list::_\<Rightarrow>_\<Rightarrow>real list"
	"Nil::(nat \<times> nat \<times> string) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string) list"
	"Nil::(nat \<times> nat \<times> string \<times> nat list) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string \<times> nat list) list"
	"Nil::real list"
	"Cons::_\<Rightarrow>_\<Rightarrow>real list"
	"Nil::nat list"
	"Cons::_\<Rightarrow>_\<Rightarrow>nat list"
	"Nil::string list"
	"Cons::_\<Rightarrow>_\<Rightarrow>string list"
	"Nil::real aform list"
	"Cons::_\<Rightarrow>_\<Rightarrow>real aform list"
	"Nil::(float interval) option list"
	"Cons::_\<Rightarrow>_\<Rightarrow>(float interval) option list"

	"nth::_\<Rightarrow>_\<Rightarrow>real"
	"upt"

	(* products: *)
	"Pair::_\<Rightarrow>_\<Rightarrow>(nat \<times> string)"
	"Pair::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string)"

	"Pair::_\<Rightarrow>_\<Rightarrow>char list \<times> nat list"
	"Pair::_\<Rightarrow>_\<Rightarrow>nat \<times> char list \<times> nat list"
	"Pair::_\<Rightarrow>_\<Rightarrow>nat \<times> nat \<times> char list \<times> nat list"

	"Pair::_\<Rightarrow>_\<Rightarrow>char list \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow> (real \<times> real pdevs) numeric_options)"
	"Pair::_\<Rightarrow>_\<Rightarrow>ereal\<times>ereal"
	"Pair::_\<Rightarrow>_\<Rightarrow>real aform list \<times> real aform list option"
	"Pair::_\<Rightarrow>_\<Rightarrow>(ereal \<times> ereal) \<times> real aform list \<times> real aform list option"

	"Pair::_\<Rightarrow>_\<Rightarrow>real aform"
	"Pair::_\<Rightarrow>_\<Rightarrow>real list \<times> real list"

	"Nil::(((real list \<times> real list) \<times> real list sctn) list \<times> (real aform) reach_options) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>(((real list \<times> real list) \<times> real list sctn) list \<times> (real aform) reach_options) list"
	"Nil::((real list \<times> real list) \<times> real list sctn) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list"

	"Pair::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options"

	"Nil::((ereal \<times> ereal) \<times> (real aform) list \<times> (real aform) list option) list"
	"Cons::_\<Rightarrow>_\<Rightarrow>((ereal \<times> ereal) \<times> (real aform) list \<times> (real aform) list option) list"

	(* option *)
	"None::(real aform) list option"
	"Some::_\<Rightarrow>(real aform) list option"
	"None::(real list \<times> real list) option"
	"Some::_\<Rightarrow>(real list \<times> real list) option"

	(* aforms *)
	"aform_of_ivl::_\<Rightarrow>_\<Rightarrow>real aform"
	aforms_of_ivls
	aforms_of_point

	(* pdevs*)
	"zero_pdevs::real pdevs"
	"zero_aforms::_ \<Rightarrow> real aform list"

	(* ode_ops *)
	mk_ode_ops
	init_ode_ops
	empty_ode_ops
	can_mk_ode_ops
	"the::ode_ops option \<Rightarrow> ode_ops"
	the_odo

	(* Characters/Strings *)
	String.Char
	String.implode
	"Nil::string"
	"Cons::_\<Rightarrow>_\<Rightarrow>string"

	(* float *)
	"(=)::float\<Rightarrow>float\<Rightarrow>bool" "(+)::float\<Rightarrow>float\<Rightarrow>float" "uminus::_\<Rightarrow>float" "(-)::_\<Rightarrow>_\<Rightarrow>float"
	Float float_of_int float_of_nat

	(* approximation... *)
	approx
	approx1
	approx2
	approxs1
	approxs2
	approx_defined
	approxs_defined

	(* floatarith *)
	"0::floatarith"
	"1::floatarith"
	"(+)::_\<Rightarrow>_\<Rightarrow>floatarith"
	"(-)::_\<Rightarrow>_\<Rightarrow>floatarith"
	"(*)::_\<Rightarrow>_\<Rightarrow>floatarith"
	"(/)::_\<Rightarrow>_\<Rightarrow>floatarith"
	"inverse::_\<Rightarrow>floatarith"
	"uminus::_\<Rightarrow>floatarith"
	"Sum\<^sub>e::_\<Rightarrow>nat list\<Rightarrow>floatarith"
	Sin Half Tan
	R\<^sub>e Norm

	(* form *)
	true_form
	Half

	(* Printing *)
	print
	no_print

	(* sections *)
	xsec xsec' ysec ysec' zsec zsec'
	xsec2 xsec2' ysec2 ysec2'
	ysec4 ysec4'
	mirrored_sctn

	Code_Target_Nat.natural
	Code_Target_Int.positive
	Code_Target_Int.negative
	Code_Numeral.positive
	Code_Numeral.negative

	datatypes:
	bool
	num
	floatarith
	"floatarith list"
	form
	"real list sctn"
	"real \<times> real"
	}
	\<close>
	ML \<open>fun ode_numerics_tac ctxt =
	CONVERSION (ode_numerics_conv ctxt) THEN' (resolve_tac ctxt [TrueI])\<close>

	lemma eq_einterpretI:
	assumes "list_of_eucl (VS::'a::executable_euclidean_space) = interpret_floatariths fas xs"
	assumes "length fas = DIM('a)"
	shows "VS = eucl_of_list (interpret_floatariths fas xs)"
	using assms
	apply (subst (asm) list_of_eucl_eucl_of_list[symmetric])
	apply (auto intro!: )
	by (metis eucl_of_list_list_of_eucl)

	lemma one_add_square_ne_zero[simp]: "1 + t * t \<noteq> 0" for t::real
	by (metis semiring_normalization_rules(12) sum_squares_eq_zero_iff zero_neq_one)

	lemma abs_rat_bound:
	"abs (x - y) \<le> e / f" if "y \<in> {yl .. yu}" "x \<in> {yu - real_divl p e f.. yl + real_divl p e f}" for x y e::real
	proof -
	note \<open>x \<in> _\<close>
	also have "{yu - real_divl p e f.. yl + real_divl p e f} \<subseteq> {yu - e / f .. yl + e / f}"
	by (auto intro!: diff_mono real_divl)
	finally show ?thesis
	using that
	unfolding abs_diff_le_iff
	by auto
	qed

	lemma in_ivl_selfI: "a \<in> {a .. a}" for a::real by auto

	lemma pi4_bnds: "pi / 4 \<in> {real_divl 80 (lb_pi 80) 4 .. real_divr 80 (ub_pi 80) 4}"
	using pi_boundaries[of 80]
	unfolding atLeastAtMost_iff
	by (intro conjI real_divl[le] real_divr[ge] divide_right_mono) auto

	lemma abs_minus_leI: "\<bar>x - x'\<bar> \<le> e" if "x \<in> {x' - e .. x' + e}" for x e::real
	using that
	- by (auto simp: )
	+ by auto

	lemmas [DIM_simps] = Suc_numeral One_nat_def[symmetric] TrueI Suc_1 length_approxs arith_simps
	lemma (in ode_interpretation) length_ode_e[DIM_simps]: "length (ode_expression odo) = DIM('a)"
	by (auto simp: len)


	named_theorems solves_one_step_ivl_thms

	context ode_interpretation begin

	lemmas [solves_one_step_ivl_thms] =
	TAG_optns[OF solves_one_step_ivl[OF _ _ _ _ _ _ _ _ solves_one_step_until_time_aform_foI], rotated -1,
	of optns _ _ _ _ _ _ _ _ _ optns for optns]

	lemmas [solves_one_step_ivl_thms] =
	TAG_optns[OF solves_one_step_ivl'[OF _ _ _ _ _ _ _ _ _ _ _ _ solves_one_step_until_time_aform_foI], rotated -1,
	of optns _ _ _ _ _ _ _ _ _ _ _ _ _ _ optns for optns]

	lemmas [solves_one_step_ivl_thms] = solves_poincare_map_aform'I poincare_maps_onto_aformI

	end

	lemma TAG_optnsI: "TAG_optns optns" by simp

	named_theorems poincare_tac_theorems

	lemmas [DIM_simps] = one_less_numeral_iff rel_simps


	abbreviation "point_ivl a \<equiv> {a .. a}"

	lemma isFDERIV_compute: "isFDERIV D vs fas xs \<longleftrightarrow>
	(list_all (\<lambda>i. list_all (\<lambda>j. isDERIV (vs ! i) (fas ! j) xs) [0..<D]) [0..<D]) \<and> length fas = D \<and> length vs = D"
	unfolding isFDERIV_def
	by (auto simp: list.pred_set)


	theorem (in ode_interpretation) solves_poincare_map_aform'_derivI'[solves_one_step_ivl_thms]:
	\<comment> \<open>TODO: replace @{thm solves_poincare_map_aform'_derivI}\<close>
	assumes "TAG_optns optns"
	assumes "TAG_reach_optns roi"
	assumes "TAG_sctn mirrored"
	and D: "D = DIM('a)"
	assumes DS: "list_interval lDR uDR \<subseteq> list_interval lDS uDS"
	and ode_fas: "aform.D odo = DIM('a)"
	and guards: "guards_invar DIM('a) guards"
	and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
	and plane: "uP ! n = lP ! n"
	and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
	and nD: "n < DIM('a)"
	and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
	and lens:
	"length (lP) = DIM('a)" "length (uP) = DIM('a)"
	"length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
	"length (lR) = DIM('a)" "length (uR) = DIM('a)"
	"length DX0 = DIM('a)*DIM('a)"
	"length lDR = CARD('n) * CARD('n)"
	"length uDR = CARD('n) * CARD('n)"
	and SS: "SS = {x::'a. if mirrored then x \<bullet> Basis_list ! n \<le> lP ! n
	else x \<bullet> Basis_list ! n \<ge> lP ! n}"
	assumes solves:
	"solves_poincare_map_aform'_fo optns odo
	(mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))
	guards
	(lP, uP)
	(mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
	roi
	[((1,1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))]
	(lR, uR)
	(Some (lDR, uDR))"
	shows "\<forall>x\<in>X0. returns_to P x \<and>
	return_time P differentiable at x within SS \<and>
	(\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
	poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
	proof (rule ballI)
	fix x assume "x \<in> X0"
	then have la2: "list_all2 (\<le>) lX0 uX0"
	using X0
	by (force simp: subset_iff eucl_of_list_le_iff le_eucl_of_list_iff lens list_all2_conv_all_nth)
	have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \<Longrightarrow>
	aform.c1_info_invare DIM('a) X"
	for X
	by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens power2_eq_square)
	have 2: "length (normal (mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))) = DIM('a)"
	by (auto simp: D mirrored_sctn_def)
	have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
	by (auto simp: lens)
	have 4: "length (normal (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))) = DIM('a)"
	by (auto simp: D mirrored_sctn_def)
	have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
	"aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lDR, uDR))"
	by (auto simp: lens aform.lvivl'_invar_def)
	note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
	have "poincare_mapsto
	(set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))])
	(below_halfspace (map_sctn eucl_of_list (mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))))
	(aform.Csafe odo -
	set_of_lvivl (lP, uP) \<inter>
	plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
	(set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' (Some (lDR, uDR)))"
	by (rule solves_poincare_map_aform'[OF solves, OF 1 ode_fas 4 3 2 _ 5])
	(use guards in \<open>auto simp: guards_invar_def\<close>)
	then have "poincare_mapsto P (X0 \<times> {blinfun_of_list DX0}::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) SS UNIV
	(R \<times> blinfuns_of_lvivl (lDS, uDS))"
	apply (rule poincare_mapsto_subset)
	subgoal using X0
	apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def
	aform.c1_info_of_apprse_def)
	subgoal for x0
	apply (rule image_eqI[where x="list_of_eucl x0@DX0"])
	using lens
	apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
	apply (rule imageI)
	using X0
	by (auto simp: Joints_aforms_of_ivls la2 list_of_eucl_in_list_interval_iff)
	done
	subgoal by simp
	subgoal using R DS
	by (auto simp: set_of_lvivl_def set_of_ivl_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_def
	lens)
	subgoal
	using assms
	by (auto simp:
	below_halfspace_def le_halfspace_def[abs_def] mirrored_sctn_def mirror_sctn_def)
	subgoal
	using assms
	by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
	le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)
	done
	then show "returns_to P x \<and>
	return_time P differentiable at x within SS \<and>
	(\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
	poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
	using \<open>x \<in> X0\<close>
	by (auto simp: poincare_mapsto_def)
	qed

	lemmas [DIM_simps] = aform.ode_e_def

	ML \<open>
	structure ODE_Numerics_Tac = struct
	fun mk_nat n = HOLogic.mk_number @{typ nat} n
	fun mk_int n = HOLogic.mk_number @{typ int} n
	fun mk_integer n = @{term integer_of_int} $ (HOLogic.mk_number @{typ int} n)
	fun mk_bool b = if b then @{term True} else @{term False}

	fun mk_numeralT n =
	let
	fun mk_bit 0 ty = Type (@{type_name bit0}, [ty])
	\| mk_bit 1 ty = Type (@{type_name bit1}, [ty]);
	fun bin_of n =
	if n = 1 then @{typ num1}
	else if n = 0 then @{typ num0}
	else if n = ~1 then raise TERM ("negative type numeral", [])
	else
	let val (q, r) = Integer.div_mod n 2;
	in mk_bit r (bin_of q) end;
	in bin_of n end;

	fun print_tac' ctxt s = K (print_tac ctxt s)

	val using_master_directory =
	File.full_path o Resources.master_directory o Proof_Context.theory_of;

	fun using_master_directory_term ctxt s =
	(if s = "-" orelse s = ""
	then s
	else
	Path.explode s
	\|> using_master_directory ctxt
	\|> Path.implode)
	\|> HOLogic.mk_string

	fun real_in_approx_tac ctxt p =
	let
	val inst_approx =
	(TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p \|> Thm.cterm_of ctxt)])
	val approx_thm = Thm.instantiate inst_approx @{thm real_in_approxI}
	in
	resolve_tac ctxt [approx_thm]
	THEN' SOLVED' (reify_floatariths_tac ctxt)
	THEN' ode_numerics_tac ctxt
	end

	fun real_subset_approx_tac ctxt p =
	let
	val inst_approx =
	(TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p \|> Thm.cterm_of ctxt)])
	val approx_thm = Thm.instantiate inst_approx @{thm real_subset_approxI}
	in
	resolve_tac ctxt [approx_thm]
	THEN' SOLVED' (reify_floatariths_tac ctxt)
	THEN' SOLVED' (reify_floatariths_tac ctxt)
	THEN' ode_numerics_tac ctxt
	THEN' ode_numerics_tac ctxt
	end

	fun basic_nt_ss ctxt nt =
	put_simpset HOL_basic_ss ctxt addsimps Named_Theorems.get ctxt nt

	fun DIM_tac defs ctxt = (Simplifier.simp_tac (basic_nt_ss ctxt @{named_theorems DIM_simps} addsimps defs))

	fun subset_approx_preconds_tac ctxt p thm =
	let
	val inst_approx = (TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p \|> Thm.cterm_of ctxt)])
	in
	resolve_tac ctxt [Thm.instantiate inst_approx thm]
	THEN' SOLVED' (reify_floatariths_tac ctxt)
	THEN' SOLVED' (reify_floatariths_tac ctxt)
	THEN' SOLVED' (DIM_tac [] ctxt)
	THEN' SOLVED' (DIM_tac [] ctxt)
	THEN' SOLVED' (ode_numerics_tac ctxt)
	THEN' SOLVED' (ode_numerics_tac ctxt)
	end

	val cfg_trace = Attrib.setup_config_bool @{binding ode_numerics_trace} (K false)
	fun tracing_tac ctxt = if Config.get ctxt cfg_trace then print_tac ctxt else K all_tac
	fun tracing_tac' ctxt = fn s => K (tracing_tac ctxt s)

	fun eucl_subset_approx_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm eucl_subset_approxI}
	fun approx_subset_eucl_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm approx_subset_euclI}
	fun approx_subset_list_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm approx_subset_listI}

	val static_simpset = Simplifier.simpset_of @{context}

	fun nth_tac ctxt =
	Simplifier.simp_tac
	(put_simpset HOL_basic_ss ctxt addsimps @{thms nth_Cons_0 nth_Cons_Suc numeral_nat})
	fun nth_list_eq_tac ctxt n = Subgoal.FOCUS_PARAMS (fn {context, concl, ...} =>
	case try (Thm.term_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) concl
	of
	SOME (@{const List.nth(real)} $ xs $ Var _, @{const List.nth(real)} $ ys $ Var _) =>
	let
	val i = find_index (op=) (HOLogic.dest_list xs ~~ HOLogic.dest_list ys)
	val thm = Goal.prove context [] []
	(HOLogic.mk_eq (@{const List.nth(real)} $ xs $ HOLogic.mk_number @{typ nat} i,
	@{const List.nth(real)} $ ys $ HOLogic.mk_number @{typ nat} i) \|> HOLogic.mk_Trueprop)
	(fn {context, ...} => HEADGOAL (nth_tac context))
	in
	SOLVE (HEADGOAL (resolve_tac context [thm]))
	end
	\| _ => no_tac
	) ctxt n

	fun numeric_precond_step_tac defs thms p = Subgoal.FOCUS_PARAMS (fn {context, concl, ...} =>
	let
	val prems = Logic.strip_imp_prems (Thm.term_of concl)
	val conclusion = Logic.strip_imp_concl (Thm.term_of concl)
	in
	(case conclusion \|> HOLogic.dest_Trueprop of
	@{const Set.member(real)} $ _ $ _ =>
	tracing_tac context "numeric_precond_step: real in approx"
	THEN HEADGOAL (real_in_approx_tac context p)
	\| Const(@{const_name less_eq}, _) $
	(Const (@{const_name atLeastAtMost}, _) $ _ $ _) $
	(Const (@{const_name atLeastAtMost}, _) $ Var _ $ Var _) =>
	tracing_tac context "numeric_precond_step: approx subset eucl"
	THEN HEADGOAL (real_subset_approx_tac context p)
	\| Const (@{const_name less_eq}, _) $
	(Const (@{const_name atLeastAtMost}, _) $ (Const (@{const_name eucl_of_list}, _) $ Var _) $ _) $ _ =>
	tracing_tac context "numeric_precond_step: approx subset eucl"
	THEN HEADGOAL (approx_subset_eucl_tac context p)
	\| Const (@{const_name less_eq}, _) $ _ $
	(Const (@{const_name atLeastAtMost}, _) $ (Const (@{const_name eucl_of_list}, _) $ Var _) $ _) =>
	tracing_tac context "numeric_precond_step: eucl subset approx"
	THEN HEADGOAL (eucl_subset_approx_tac context p)
	\| Const (@{const_name less_eq}, _) $
	(@{const list_interval(real)} $ _ $ _) $
	(@{const list_interval(real)} $ _ $ _) =>
	tracing_tac context "numeric_precond_step: approx subset list"
	THEN HEADGOAL (approx_subset_list_tac context p)
	\| @{const HOL.eq(nat)} $ _ $ _ =>
	tracing_tac context "numeric_precond_step: DIM_tac"
	THEN HEADGOAL (SOLVED' (DIM_tac [] context))
	\| @{const less(nat)} $ _ $ _ =>
	tracing_tac context "numeric_precond_step: DIM_tac"
	THEN HEADGOAL (SOLVED' (DIM_tac [] context))
	\| @{const HOL.eq(real)} $ (@{const nth(real)} $ _ $ _) $ (@{const nth(real)} $ _ $ _) =>
	tracing_tac context "numeric_precond_step: nth_list_eq_tac"
	THEN HEADGOAL (SOLVED' (nth_list_eq_tac context))
	\| Const (@{const_name "HOL.eq"}, _) $ _ $
	(Const (@{const_name eucl_of_list}, _) $ (@{const interpret_floatariths} $ _ $ _)) =>
	tracing_tac context "numeric_precond_step: reify floatariths"
	THEN HEADGOAL (resolve_tac context @{thms eq_einterpretI} THEN' reify_floatariths_tac context)
	\| t as _ $ _ =>
	let
	val (c, args) = strip_comb t
	in
	if member (op=)
	[@{const "solves_one_step_until_time_aform_fo"},
	@{const "solves_poincare_map_aform'_fo"},
	@{const "solves_poincare_map_onto_aform_fo"},
	@{const "can_mk_ode_ops"}
	] c
	then
	tracing_tac context "numeric_precond_step: ode_numerics_tac"
	THEN HEADGOAL (
	CONVERSION (Simplifier.rewrite (put_simpset HOL_basic_ss context addsimps defs))
	THEN' tracing_tac' context "numeric_precond_step: ode_numerics_tac (unfolded)"
	THEN' ode_numerics_tac context)
	else if member (op=)
	[@{const "isFDERIV"}] c
	then
	tracing_tac context "numeric_precond_step: isFDERIV"
	THEN HEADGOAL (SOLVED'(Simplifier.asm_full_simp_tac
	(put_simpset static_simpset context addsimps (@{thms isFDERIV_def less_Suc_eq_0_disj isDERIV_Power_iff} @ thms @ defs))
	THEN' tracing_tac' context "numeric_precond_step: simplified isFDERIV"
	))
	else
	tracing_tac context "numeric_precond_step: boolean, try thms"
	THEN HEADGOAL (SOLVED' (resolve_tac context thms))
	end
	\| _ =>
	tracing_tac context "numeric_precond_step: boolean constant"
	THEN no_tac
	)
	end)

	fun integral_bnds_tac_gen_start sstep d p m N atol filename ctxt i =
	let
	val insts =
	(TVars.make [((("'i", 0), @{sort "{enum}"}), mk_numeralT (d + 1) \|> Thm.ctyp_of ctxt)],
	Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
	HOLogic.mk_prod
	(using_master_directory_term ctxt filename,
	(@{term num_options} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $
	@{term "[(0::nat, 1::nat, ''0x000000'')]"}))
	\|> Thm.cterm_of ctxt),
	((("safe_form", 0), @{typ form}), @{cterm true_form})
	])
	in
	resolve_tac ctxt [Thm.instantiate insts @{thm solve_one_step_until_time_aform_integral_bounds}] i
	THEN (Lin_Arith.tac ctxt i ORELSE Simplifier.simp_tac ctxt i)
	end
	fun integral_bnds_tac_gen sstep d p m N atol filename thms ctxt =
	integral_bnds_tac_gen_start sstep d p m N atol filename ctxt
	THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac [] thms p ctxt)

	val integral_bnds_tac = integral_bnds_tac_gen 5

	fun mk_proj (m, n, s) = HOLogic.mk_tuple [mk_nat m, mk_nat n, HOLogic.mk_string s]
	fun mk_projs projs = HOLogic.mk_list @{typ "nat \<times> nat \<times> string"} (map mk_proj projs)

	fun mk_string_list ds = HOLogic.mk_list @{typ "string"} (map HOLogic.mk_string ds)
	fun mk_nat_list ds = HOLogic.mk_list @{typ "nat"} (map mk_nat ds)
	fun mk_proj_c1 (m, n, s, ds) = HOLogic.mk_tuple [mk_nat m, mk_nat n, HOLogic.mk_string s, mk_nat_list ds]
	fun mk_projs_c1 projs = HOLogic.mk_list @{typ "nat \<times> nat \<times> string \<times> nat list"} (map mk_proj_c1 projs)

	fun TAG_optns_thm p sstep m N atol projs filename ctxt =
	Thm.instantiate (TVars.empty,
	Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
	HOLogic.mk_prod
	(using_master_directory_term ctxt filename,
	@{term num_options} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $ mk_projs projs)
	\|> Thm.cterm_of ctxt)]) @{thm TAG_optnsI}

	fun TAG_optns_c1_thm p sstep m N atol projs ds filename ctxt =
	Thm.instantiate (TVars.empty,
	Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
	HOLogic.mk_prod
	(using_master_directory_term ctxt filename,
	@{term num_options_c1} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $ mk_projs_c1 projs $
	mk_string_list ds)
	\|> Thm.cterm_of ctxt)]) @{thm TAG_optnsI}

	fun ode_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
	tracing_tac' ctxt "solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
	THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]

	fun ode_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
	ode_bnds_tac_gen_start sstep p m N atol projs filename ctxt
	THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac ode_defs [] p ctxt)
	val ode_bnds_tac = ode_bnds_tac_gen 5

	fun ode'_bnds_tac_gen_start sstep p m N atol projs ds filename ctxt =
	tracing_tac' ctxt "solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
	THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt [TAG_optns_c1_thm p sstep m N atol projs ds filename ctxt]
	fun ode'_bnds_tac_gen sstep ode_defs p m N atol projs ds filename ctxt =
	ode'_bnds_tac_gen_start sstep p m N atol projs ds filename ctxt
	THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac ode_defs [] p ctxt)

	val ode'_bnds_tac = ode'_bnds_tac_gen 5

	fun poincare_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
	tracing_tac' ctxt "solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
	THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
	THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]
	fun poincare_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
	poincare_bnds_tac_gen_start sstep p m N atol projs filename ctxt
	THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (
	numeric_precond_step_tac ode_defs
	(Named_Theorems.get ctxt @{named_theorems poincare_tac_theorems})
	p
	ctxt)

	val poincare_bnds_tac = poincare_bnds_tac_gen 5

	fun poincare'_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
	resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
	THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]
	fun poincare'_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
	poincare'_bnds_tac_gen_start sstep p m N atol projs filename ctxt
	THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (
	numeric_precond_step_tac ode_defs
	(Named_Theorems.get ctxt @{named_theorems poincare_tac_theorems})
	p
	ctxt)
	val poincare'_bnds_tac = poincare'_bnds_tac_gen 5
	end
	\<close>

	lemma (in auto_ll_on_open) Poincare_Banach_fixed_pointI:
	assumes "convex S" and c: "complete S" "S \<noteq> {}" and "S \<subseteq> T"
	assumes derivative_bounded: "\<forall>x\<in>S.
	poincare_map \<Sigma> x \<in> S \<and> (\<exists>D. (poincare_map \<Sigma> has_derivative D) (at x within T) \<and> onorm D \<le> B)"
	assumes B: "B < 1"
	shows "\<exists>!x. x \<in> S \<and> poincare_map \<Sigma> x = x"
	using c _ B
	proof (rule banach_fix)
	from derivative_bounded c show "0 \<le> B"
	by (auto dest!: has_derivative_bounded_linear onorm_pos_le)
	from derivative_bounded show "poincare_map \<Sigma> ` S \<subseteq> S" by auto
	obtain D where D:
	"\<forall>x \<in> S. (poincare_map \<Sigma> has_derivative D x) (at x within T) \<and>
	onorm (D x) \<le> B"
	apply atomize_elim
	apply (rule bchoice)
	using derivative_bounded
	by auto
	with \<open>S \<subseteq> T\<close> have "(\<And>x. x \<in> S \<Longrightarrow> (poincare_map \<Sigma> has_derivative D x) (at x within S))"
	by (auto intro: has_derivative_subset)
	from bounded_derivative_imp_lipschitz[of S "poincare_map \<Sigma>" D B, OF this] \<open>convex S\<close> D c
	\<open>0 \<le> B\<close>
	have "B-lipschitz_on S (poincare_map \<Sigma>)" by auto
	then show "\<forall>x\<in>S. \<forall>y\<in>S. dist (poincare_map \<Sigma> x) (poincare_map \<Sigma> y) \<le> B * dist x y"
	by (auto simp: lipschitz_on_def)
	qed

	ML \<open>open ODE_Numerics_Tac\<close>

	lemma isFDERIV_product: "isFDERIV n xs fas vs \<longleftrightarrow>
	length fas = n \<and> length xs = n \<and>
	list_all (\<lambda>(x, f). isDERIV x f vs) (List.product xs fas)"
	apply (auto simp: isFDERIV_def list_all2_iff in_set_zip list_all_length product_nth)
	apply auto
	apply (metis gr_implies_not_zero gr_zeroI less_mult_imp_div_less pos_mod_bound)
	done

	end
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Init_ODE_Solver.thy b/thys/Ordinary_Differential_Equations/Numerics/Init_ODE_Solver.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Init_ODE_Solver.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Init_ODE_Solver.thy
	@@ -1,383 +1,383 @@
	theory Init_ODE_Solver
	imports
	Concrete_Reachability_Analysis_C1
	Refine_Reachability_Analysis_C1
	Refine_Rigorous_Numerics_Aform
	begin

	subsection \<open>``Final'' Theorems, stated outside of refinement framework.\<close>

	lemma br_Times_Univ: "br a I \<times>\<^sub>r (UNIV::(_ \<times> unit) set) = br (\<lambda>(x, _). (a x, ())) (\<lambda>(x, _). I x)"
	by (auto simp: br_def)

	-lemma TRANSFER_refl: "TRANSFER (x \<le> (x::_nres))" by (auto simp: )
	+lemma TRANSFER_refl: "TRANSFER (x \<le> (x::_nres))" by auto
	lemma init_ode_ops: "(y \<Longrightarrow> x) \<Longrightarrow> (init_ode_ops x y odo, odo) \<in> ode_ops_rel"
	by (auto simp: ode_ops_rel_def init_ode_ops_def)

	context approximate_sets begin

	context includes autoref_syntax begin

	theorem solves_poincare_map_ncc:
	fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0 S trap
	defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
	defines "Sa \<equiv> below_halfspace (map_sctn eucl_of_list S)::'n::enum rvec set"
	defines "X0 \<equiv> c1_info_of_apprse XS"
	defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
	assumes ncc: "ncc_precond TYPE('n rvec)" "ncc_precond TYPE('n vec1)"
	assumes ret: "solves_poincare_map odo symstart [S] guards ivli sctni roi XS (rl, ru) dRi"
	assumes symstart: "(symstart, symstarta::'n eucl1 set \<Rightarrow> ('n rvec set \<times> 'n eucl1 set)nres) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>dres_nres_rel"
	assumes symstart_spec: "\<And>X0. X0 \<subseteq> Csafe odo \<times> UNIV \<Longrightarrow> symstarta X0 \<le> SPEC (\<lambda>(CX, X). flowsto odo (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	assumes trapprop: "stable_on odo (Csafe odo - P) trap"
	assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
	assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
	"length (normal S) = CARD('n)" "length rl = CARD('n)" "length ru = CARD('n)"
	"lvivl'_invar (CARD('n)*CARD('n)) dRi"
	"\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
	shows "poincare_mapsto odo P (X0 - trap \<times> UNIV) Sa (Csafe odo - P) X1"
	proof -
	define guardsa::"('n rvec set \<times> unit) list" where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
	define roa where "roa = ()"
	have spm:
	"(XS, X0) \<in> clw_rel (appr1e_rel)"
	"([S], Sa) \<in> \<langle>lv_rel\<rangle>halfspaces_rel"
	"(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
	"(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
	"(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	"(roi, roa) \<in> reach_optns_rel"
	"(\<lambda>x. nres_of (symstart x), symstarta) \<in> appr1e_rel \<rightarrow> \<langle>clw_rel appr_rel \<times>\<^sub>r clw_rel appr1e_rel\<rangle>nres_rel"
	"((), trap) \<in> ghost_rel"
	using lens symstart[THEN dres_nres_rel_nres_relD]
	by (auto simp: X0_def X1_def Sa_def P_def appr_rel_br set_rel_br
	br_chain o_def clw_rel_br lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
	halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
	br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
	roa_def br_Times_Univ reach_options_rel_def
	split: sctn.splits
	intro!: brI list_allI clw_rel_appr1e_relI assms)

	have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
	"(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
	by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
	split: option.splits)

	from lens(1) have wd: "wd odo TYPE('n rvec)" by (auto simp: wd_def)
	from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
	by (auto simp: D_def)
	have pmspec: "poincare_onto_from_in_ivl $ odo $ symstarta $ trap $ S $ guards $ ivl $ sctn $ ro $ XS0 $ IVL $ dIVL
	\<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe odo - ivl \<inter> plane_of sctn)
	(flow1_of_vec1 ` (IVL \<times> dIVL)))"
	if trapprop: "stable_on odo (Csafe odo - ivl \<inter> plane_of sctn) trap"
	for ivl sctn XS0 S guards ro IVL dIVL
	using poincare_onto_from_in_ivl[OF wd symstart_spec trapprop order_refl,
	of S guards ro XS0 IVL dIVL]
	by auto

	have odo_init: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
	by (auto simp: intro!: init_ode_ops)
	from nres_rel_trans2[OF
	pmspec
	poincare_onto_from_in_ivl_impl.refine[OF DIM_precond ncc odo_init spm(1-7) TRANSFER_refl spm(8) ivls]
	] ret trapprop
	show ?thesis
	by (auto simp: solves_poincare_map_def nres_rel_def P_def X1_def)
	qed

	lemma solves_poincare_map'_ncc:
	"ncc_precond TYPE('n::enum rvec) \<Longrightarrow>
	ncc_precond TYPE('n vec1) \<Longrightarrow>
	solves_poincare_map' odo S guards ivli sctni roi XS (rl, ru) dRi \<Longrightarrow>
	(\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X) \<Longrightarrow>
	length (ode_e odo) = CARD('n) \<Longrightarrow>
	length (normal sctni) = CARD('n) \<Longrightarrow>
	length (fst ivli) = CARD('n) \<Longrightarrow>
	length (snd ivli) = CARD('n) \<Longrightarrow>
	length (normal S) = CARD('n) \<Longrightarrow>
	length (rl) = CARD('n) \<Longrightarrow>
	length (ru) = CARD('n) \<Longrightarrow>
	lvivl'_invar (CARD('n)*CARD('n)) dRi \<Longrightarrow>
	(\<And>a xs b ba ro.
	(xs, ro) \<in> set guards \<Longrightarrow>
	((a, b), ba) \<in> set xs \<Longrightarrow>
	length a = CARD('n) \<and>
	length b = CARD('n) \<and> length (normal ba) = CARD('n)) \<Longrightarrow>
	poincare_mapsto odo
	(set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)::'n rvec set)
	(c1_info_of_apprse XS) (below_halfspace (map_sctn eucl_of_list S))
	(Csafe odo - set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni))
	(flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi))"
	by (rule solves_poincare_map_ncc[OF _ _ _
	empty_symstart_dres_nres_rel[unfolded empty_symstart_def op_empty_coll_def mk_coll_def]
	empty_symstart_flowsto,
	folded solves_poincare_map'_def, simplified])
	auto


	lemma one_step_until_time_ivl_in_ivl_spec[le, refine_vcg]:
	"one_step_until_time_ivl_in_ivl odo (X0::'n::enum eucl1 set) t1 t2 R dR \<le> SPEC (\<lambda>b. b \<longrightarrow>
	(\<forall>(x0, d0) \<in> X0. {t1 .. t2} \<subseteq> existence_ivl0 odo x0 \<and>
	(\<forall>t \<in> {t1 .. t2}. (flow0 odo x0 t, Dflow odo x0 t o\<^sub>L d0) \<in> flow1_of_vec1 ` (R \<times> dR))))"
	if [simp]: "length (ode_e odo) = CARD('n::enum)"
	proof -
	have wd[refine_vcg]: "wd odo TYPE((real, 'n) vec)" by (simp add: wd_def)
	show ?thesis
	unfolding one_step_until_time_ivl_in_ivl_def
	apply (refine_vcg, clarsimp_all)
	subgoal for X CX Y CY CY' x0 d0
	apply (drule bspec, assumption, clarsimp)
	subgoal for t
	apply (drule bspec[where x=t], force)
	by (simp add: subset_iff )
	done
	done
	qed

	theorem one_step_in_ivl_ncc:
	"t \<in> existence_ivl0 odo x0 \<and> (flow0 odo x0 t::'n rvec) \<in> R \<and> Dflow odo x0 t o\<^sub>L d0 \<in> dR"
	if ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
	and t: "t \<in> {t0 .. t1}"
	and x0: "(x0, d0) \<in> c1_info_of_appre X"
	and invar: "c1_info_invare CARD('n) X"
	and R: "{eucl_of_list rl .. eucl_of_list ru} \<subseteq> R"
	and lens: "length rl = CARD('n)" "length ru = CARD('n)"
	and dRinvar: "lvivl'_invar (CARD('n)*CARD('n)) dRi"
	and dR: "blinfun_of_vmatrix ` set_of_lvivl' dRi \<subseteq> dR"
	and len_ode: "length (ode_e odo) = CARD('n)"
	and chk: "one_step_until_time_ivl_in_ivl_check odo X t0 t1 (rl, ru) dRi"
	proof -
	have ivl: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	apply (rule lv_relivl_relI)
	using lens
	by auto
	from dRinvar have "lvivl'_invar DIM(((real, 'n) vec, 'n) vec) dRi" by simp
	note dRi = lvivl_default_relI[OF this]
	from len_ode have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
	by (auto simp: D_def)
	have odo: "(init_ode_ops True (carries_c1 X) odo, odo) \<in> ode_ops_rel"
	by (auto intro!: init_ode_ops)
	from one_step_until_time_ivl_in_ivl_impl_refine[param_fo, OF DIM_precond ncc odo appr1e_relI[OF invar] IdI IdI ivl dRi, of t0 t1]
	have "nres_of (one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi)
	\<le> one_step_until_time_ivl_in_ivl odo (c1_info_of_appre X) t0 t1 {eucl_of_list rl::'n rvec..eucl_of_list ru} (set_of_lvivl' dRi)"
	by (auto simp: nres_rel_def)
	also note one_step_until_time_ivl_in_ivl_spec[OF len_ode order_refl]
	also have "one_step_until_time_ivl_in_ivl_impl (D odo) (init_ode_ops True (carries_c1 X) odo) X t0 t1 (rl, ru) dRi = dRETURN True"
	unfolding one_step_until_time_ivl_in_ivl_check_def[symmetric]
	using chk .
	finally show ?thesis
	using t R dR
	by (auto dest!: bspec[OF _ x0] bspec[where x=t] simp: vec1_of_flow1_def)
	qed

	subsection \<open>Poincare onto (from the outside)\<close>

	theorem solves_poincare_map_onto_ncc:
	fixes sctni pos ivli ssc XS ph rl ru dRi CXS X0
	defines "P \<equiv> set_of_lvivl ivli \<inter> plane_of (map_sctn eucl_of_list sctni)"
	defines "X0 \<equiv> c1_info_of_apprse XS"
	defines "X1 \<equiv> flow1_of_vec1 ` ({eucl_of_list rl .. eucl_of_list ru} \<times> set_of_lvivl' dRi)"
	assumes ncc: "ncc_precond TYPE('n::enum rvec)" "ncc_precond TYPE('n vec1)"
	assumes ret: "solves_poincare_map_onto odo guards ivli sctni roi XS (rl, ru) dRi"
	assumes invar: "\<And>X. X \<in> set XS \<Longrightarrow> c1_info_invare CARD('n) X"
	assumes lens: "length (ode_e odo) = CARD('n)" "length (normal sctni) = CARD('n)" "length (fst ivli) = CARD('n)" "length (snd ivli) = CARD('n)"
	"length rl = CARD('n)" "length ru = CARD('n)"
	"lvivl'_invar (CARD('n)*CARD('n)) dRi"
	"\<And>a xs b ba ro. (xs, ro) \<in> set guards \<Longrightarrow> ((a, b), ba) \<in> set xs \<Longrightarrow> length a = CARD('n) \<and> length b = CARD('n) \<and> length (normal ba) = CARD('n)"
	shows "poincare_maps_onto odo P (X0::('n rvec \<times> _)set) X1"
	proof -
	define guardsa::"('n rvec set \<times> unit) list" where "guardsa \<equiv> map (\<lambda>(x, y). (\<Union>x\<in>set x. case x of (x, y) \<Rightarrow> (case x of (x, y) \<Rightarrow> set_of_ivl (eucl_of_list x, eucl_of_list y)) \<inter> plane_of (map_sctn eucl_of_list y), ())) guards"
	define roa where "roa = ()"
	have spm:
	"(XS, X0) \<in> clw_rel (appr1e_rel)"
	"(guards, guardsa) \<in> \<langle>clw_rel (iplane_rel lvivl_rel) \<times>\<^sub>r reach_optns_rel\<rangle>list_rel"
	"(ivli, set_of_lvivl ivli::'n rvec set) \<in> lvivl_rel"
	"(sctni, map_sctn eucl_of_list sctni::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	"(roi, roa) \<in> reach_optns_rel"
	using lens
	by (auto simp: X0_def X1_def P_def appr_rel_br set_rel_br
	br_chain o_def clw_rel_br lv_rel_def sctn_rel_br ivl_rel_br set_of_lvivl_def
	halfspaces_rel_def list_set_rel_brp below_halfspaces_def ghost_relI
	br_rel_prod br_list_rel guardsa_def Id_br inter_rel_br plane_rel_br
	reach_options_rel_def br_Times_Univ
	split: sctn.splits
	intro!: brI list_allI clw_rel_appr1e_relI assms)

	have ivls: "((rl, ru), {eucl_of_list rl .. eucl_of_list ru::'n rvec}) \<in> lvivl_rel"
	"(dRi, set_of_lvivl' dRi::(('n rvec), 'n) vec set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
	by (auto intro!: lvivl_relI lvivl_default_relI lens simp: lens set_of_lvivl_def set_of_ivl_def
	split: option.splits)

	have pmspec: "poincare_onto_in_ivl odo guards ivl sctn ro XS0 IVL dIVL
	\<le> SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto odo (ivl \<inter> plane_of sctn) (XS0) UNIV (Csafe odo - ivl \<inter> plane_of sctn)
	(flow1_of_vec1 ` (IVL \<times> dIVL)))"
	for ivl::"'n rvec set" and sctn XS0 guards ro IVL dIVL
	using poincare_onto_in_ivl[OF lens(1) order_refl, of guards ivl sctn ro XS0 IVL dIVL]
	by auto
	from lens(1) have DIM_precond: "DIM_precond TYPE('n rvec) (D odo)"
	by (auto simp: D_def)
	have odo: "(init_ode_ops True (carries_c1 (hd XS)) odo, odo) \<in> ode_ops_rel"
	by (auto intro!: init_ode_ops)
	from nres_rel_trans2[OF
	pmspec
	poincare_onto_in_ivl_impl.refine[OF DIM_precond ncc odo spm(1-5) ivls]
	] ret
	show ?thesis
	by (auto simp: poincare_maps_onto_def solves_poincare_map_onto_def nres_rel_def P_def X1_def)
	qed

	end
	end

	subsection \<open>Executable definitions for ODE solver based on affine arithmetic\<close>

	global_interpretation aform: approximate_sets aform_ops Joints aforms_rel optns for optns
	defines solves_poincare_map_aform = aform.solves_poincare_map
	and solves_poincare_map_aform' = aform.solves_poincare_map'
	and solves_poincare_map_onto_aform = aform.solves_poincare_map_onto
	and solves_one_step_until_time_aform = aform.one_step_until_time_ivl_in_ivl_check
	and solve_poincare_map_aform = aform.poincare_onto_from_impl
	and one_step_until_time_ivl_in_ivl_impl_aform = aform.one_step_until_time_ivl_in_ivl_impl
	and poincare_onto_from_in_ivl_impl_aform = aform.poincare_onto_from_in_ivl_impl
	and poincare_onto_in_ivl_impl_aform = aform.poincare_onto_in_ivl_impl
	and solve_poincare_onto_aform = aform.poincare_onto_impl
	and solve_one_step_until_time_aform = aform.one_step_until_time_ivl
	and one_step_until_time_impl_aform = aform.one_step_until_time_impl
	and op_image_fst_coll_nres_impl_aform = aform.op_image_fst_coll_nres_impl
	and poincare_onto_series_impl_aform = aform.poincare_onto_series_impl
	and poincare_start_on_impl_aform = aform.poincare_start_on_impl
	and leaves_halfspace_impl_aform = aform.leaves_halfspace_impl
	and approximate_sets_aform = aform.subset_spec_ivl_collc
	and subset_spec_plane_impl_aform = aform.subset_spec_plane_impl
	and disjoints_spec_impl_aform = aform.disjoints_spec_impl
	and partition_set_impl_aform = aform.partition_set_impl
	and fst_safe_coll_impl_aform = aform.fst_safe_coll_impl
	and choose_step1_impl_aform = aform.choose_step1_impl
	and ivl_rep_of_set_coll_impl_aform = aform.ivl_rep_of_set_coll_impl
	and ode_set_impl_aform = aform.ode_set_impl
	and mk_safe_impl_aform = aform.mk_safe_impl
	and subset_spec_ivlc_aform = aform.subset_spec_ivlc
	and sbelow_sctn_impl_aform = aform.sbelow_sctn_impl
	and below_sctn_impl_aform = aform.below_sctn_impl
	and split_under_threshold_impl_aform = aform.split_under_threshold_impl
	and do_intersection_coll_impl_aform = aform.do_intersection_coll_impl
	and partition_ivl_impl_aform = aform.partition_ivl_impl
	and mk_safe_coll_impl_aform = aform.mk_safe_coll_impl
	and choose_step_impl_aform = aform.choose_step_impl
	and reach_cont_impl_aform = aform.reach_cont_impl
	and vec1reps_impl_aform = aform.vec1reps_impl
	and ivl_rep_of_sets_impl_aform = aform.ivl_rep_of_sets_impl
	and ivl_rep_of_set_impl_aform = aform.ivl_rep_of_set_impl
	and ivls_of_sets_impl_aform = aform.ivls_of_sets_impl
	and tolerate_error_impl_aform = aform.tolerate_error_impl
	and tolerate_error1_impl_aform = aform.tolerate_error1_impl
	and pre_intersection_step_impl_aform = aform.pre_intersection_step_impl
	and split_spec_param1_impl_aform = aform.split_spec_param1_impl
	and do_intersection_impl_aform = aform.do_intersection_impl
	and resolve_step_impl_aform = aform.resolve_step_impl
	and euler_step_impl_aform = aform.euler_step_impl
	and rk2_step_impl_aform = aform.rk2_step_impl
	and op_eventually_within_sctn_impl_aform = aform.op_eventually_within_sctn_impl
	and solve_poincare_plane_impl_aform = aform.solve_poincare_plane_impl
	and cert_stepsize_impl_dres_aform = aform.cert_stepsize_impl_dres
	and step_adapt_time_impl_aform = aform.step_adapt_time_impl
	and inter_sctn1_impl_aform = aform.inter_sctn1_impl
	and step_split_impl_aform = aform.step_split_impl
	and intersects_impl_aform = aform.intersects_impl
	and above_sctn_impl_aform = aform.above_sctn_impl
	and nonzero_component_impl_aform = aform.nonzero_component_impl
	and P_iter_impl_aform = aform.P_iter_impl
	and partition_sets_impl_aform = aform.partition_sets_impl
	and reach_conts_impl_aform = aform.reach_conts_impl
	and subsets_iplane_coll_impl_aform = aform.subsets_iplane_coll_impl
	and reach_cont_symstart_impl_aform = aform.reach_cont_symstart_impl
	and subset_iplane_coll_impl_aform = aform.subset_iplane_coll_impl
	and symstart_coll_impl_aform = aform.symstart_coll_impl
	and subset_spec_ivls_clw_impl_aform = aform.subset_spec_ivls_clw_impl
	and poincare_onto2_impl_aform = aform.poincare_onto2_impl
	and poincare_onto_empty_impl_aform = aform.poincare_onto_empty_impl
	and resolve_ivlplanes_impl_aform = aform.resolve_ivlplanes_impl
	and empty_remainders_impl_aform = aform.empty_remainders_impl
	and adapt_stepsize_fa_aform = aform.adapt_stepsize_fa
	and split_spec_param1e_impl_aform = aform.split_spec_param1e_impl
	and setse_of_ivlse_impl_aform = aform.setse_of_ivlse_impl
	and ivlse_of_setse_impl_aform = aform.ivlse_of_setse_impl
	and choose_step1e_impl_aform = aform.choose_step1e_impl
	and vec1repse_impl_aform = aform.vec1repse_impl
	and scaleR2_rep1_impl_aform = aform.scaleR2_rep1_impl
	and list_of_appr1e_aform = aform.list_of_appr1e
	and list_of_appr1_aform = aform.list_of_appr1
	and nonzero_component_within_impl_aform = aform.nonzero_component_within_impl
	and approx_fas_impl_aform = aform.approx_slp_appr_impl
	and mig_set_impl_aform = aform.mig_set_impl
	and op_eucl_of_list_image_pad_aform = aform.op_eucl_of_list_image_pad
	and reach_cont_par_impl_aform = aform.reach_cont_par_impl
	and do_intersection_core_impl_aform = aform.do_intersection_core_impl
	and reduce_spec1e_impl_aform = aform.reduce_spec1e_impl
	and reduce_spec1_impl_aform = aform.reduce_spec1_impl
	and one_step_until_time_ivl_impl_aform = aform.one_step_until_time_ivl_impl
	and subset_spec1_collc_aform = aform.subset_spec1_collc
	and ivl_of_appr1_coll_impl_aform = aform.ivl_of_appr1_coll_impl
	and do_intersection_body_impl_aform = aform.do_intersection_body_impl
	and ode_slp_impl_aform = aform.ode_slp_impl
	and print_msg_impl_aform = aform.print_msg_impl
	and ode_e_impl_aform = aform.ode_e_impl
	and safe_form_impl_aform = aform.safe_form_impl
	and D_impl_aform = aform.D_impl
	and safe_set_appr_aform = aform.safe_set_appr
	and var_ode_ops_impl = aform.var_ode_ops_impl
	and start_stepsize_impl_aform = aform.start_stepsize_impl
	and poincare_slp_impl_aform = aform.poincare_slp_impl
	and rk2_param_impl_aform = aform.rk2_param_impl

	unfolding aform_approximate_sets_def[symmetric]
	by (rule aform_approximate_sets)

	lemma aform_ncc[autoref_rules_raw]: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
	using aform.appr_rel_nonempty
	by (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_br br_def compact_Affine
	convex_Affine
	eucl_of_list_image_Joints)

	fun parts::"nat\<Rightarrow>'a list\<Rightarrow>'a list list"
	where
	"parts n [] = []"
	\| "parts 0 xs = [xs]"
	\| "parts n xs = take n xs # parts n (drop n xs)"


	lemma Joints_in_lv_rel_set_relD:
	"(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
	- apply (auto simp: )
	+ apply auto
	apply (subst eucl_of_list_image_Joints[symmetric])
	unfolding lv_rel_def set_rel_br
	apply (auto simp: br_def )
	using aform.length_set_of_appr apply auto[1]
	apply (subst (asm) eucl_of_list_image_Joints[symmetric])
	unfolding lv_rel_def set_rel_br
	apply (auto simp: br_def )
	using aform.length_set_of_appr apply auto[1]
	done

	lemma ncc_precond: "aform.ncc_precond TYPE('a::executable_euclidean_space)"
	apply (auto simp: aform.ncc_precond_def aform.ncc_def aform.appr_rel_def)
	apply (auto simp: aforms_rel_def br_def)
	subgoal by (auto simp: compact_Affine dest!: Joints_in_lv_rel_set_relD)
	subgoal by (auto simp: convex_Affine dest!: Joints_in_lv_rel_set_relD)
	done

	lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
	fst (eucl_of_list_aform x)"
	by (auto simp: eucl_of_list_aform_def o_def)

	lemma
	Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
	"Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
	by (auto simp: Affine_def valuate_def aform_val_def
	elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
	pdevs_val_of_list_of_pdevs[where X = "snd x"])

	lemmas one_step_in_ivl = aform.one_step_in_ivl_ncc[OF ncc_precond ncc_precond]
	lemmas solves_poincare_map = aform.solves_poincare_map_ncc[OF ncc_precond ncc_precond]
	lemmas solves_poincare_map' = aform.solves_poincare_map'_ncc[OF ncc_precond ncc_precond]
	lemmas solves_poincare_map_onto = aform.solves_poincare_map_onto_ncc[OF ncc_precond ncc_precond]

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis.thy
	@@ -1,1701 +1,1701 @@
	theory Refine_Reachability_Analysis
	imports
	Abstract_Reachability_Analysis
	Refine_Rigorous_Numerics
	begin

	lemma isDERIV_simps[simp]:
	"isDERIV i 1 xs" "isDERIV i 0 xs"
	"isDERIV i (a + b) xs \<longleftrightarrow> isDERIV i a xs \<and> isDERIV i b xs"
	"isDERIV i (a - b) xs \<longleftrightarrow> isDERIV i a xs \<and> isDERIV i b xs"
	"isDERIV i (a * b) xs \<longleftrightarrow> isDERIV i a xs \<and> isDERIV i b xs"
	"isDERIV i (a / b) xs \<longleftrightarrow> isDERIV i a xs \<and> isDERIV i b xs \<and> interpret_floatarith b xs \<noteq> 0"
	"isDERIV i (-a) xs = isDERIV i a xs"
	by (auto simp: one_floatarith_def zero_floatarith_def plus_floatarith_def minus_floatarith_def
	times_floatarith_def divide_floatarith_def uminus_floatarith_def)

	lemma list_of_eucl_of_env:
	assumes [simp]: "length xs = DIM('a)"
	shows "(list_of_eucl (eucl_of_env xs vs::'a)) = (map (\<lambda>i. vs ! (xs ! i)) [0..<DIM('a::executable_euclidean_space)])"
	by (auto intro!: nth_equalityI simp: eucl_of_env_def eucl_of_list_inner)

	context approximate_sets_ode
	begin

	lemma interpret_ode_fa[simp]:
	assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "length vs \<ge> DIM('a)" "length ode_e = DIM('a)"
	and mV: "max_Var_floatariths ode_e \<le> DIM('a)"
	shows "(eucl_of_list (interpret_floatariths (ode_fa xs) vs)::'a) = ode (eucl_of_list (interpret_floatariths xs vs))"
	unfolding ode_fa_def
	apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner ode_def)
	apply (subst interpret_floatarith_subst_floatarith[where D="length vs"])
	apply (auto intro!: max_Var_floatarith_le_max_Var_floatariths_nth[le]
	mV[le])
	apply (rule interpret_floatarith_max_Var_cong)
	apply (drule max_Var_floatariths_lessI) apply simp
	apply (drule less_le_trans[OF _ mV])
	apply auto
	apply (subst nth_map)
	apply simp using assms(2) order.strict_trans2 apply blast
	apply (subst nth_upt) apply simp
	apply (rule less_le_trans, assumption, simp)
	apply auto
	done

	lemma length_ode_fa[simp]: "length (ode_fa xs) = length ode_e"
	by (auto simp: ode_fa_def)

	lemma max_Var_ode_fa[le]:
	assumes "max_Var_floatariths ode_e \<le> length xs"
	shows "max_Var_floatariths (ode_fa xs) \<le> max_Var_floatariths xs"
	by (auto simp: ode_fa_def intro!: assms max_Var_floatariths_subst_floatarith_le)

	lemma max_Var_floatariths_ode_d_expr[le]:
	"max_Var_floatariths ode_e \<le> d \<Longrightarrow> d > 0 \<Longrightarrow>
	max_Var_floatariths (ode_d_expr d m) \<le> 3 * d"
	by (auto simp: ode_d_expr_def
	intro!: max_Var_floatarith_FDERIV_n_floatariths[le]
	max_Var_floatarith_FDERIV_floatariths[le])

	lemma interpret_ode_d_fa:
	assumes FDERIV: "(eucl_of_list (interpret_floatariths xs vs)::'a::executable_euclidean_space) \<in> Csafe"
	assumes [simp]: "length ds = DIM('a)" "length xs = DIM('a)"
	notes [simp] = safe_length[OF FDERIV]
	shows "(eucl_of_list (interpret_floatariths (ode_d_fa n xs ds) vs)::'a) =
	ode_d n (eucl_of_list (interpret_floatariths xs vs)) (eucl_of_list (interpret_floatariths ds vs))
	(eucl_of_list (interpret_floatariths ds vs))"
	apply (transfer fixing: xs ds vs n)
	using FDERIV apply (auto simp del: isnFDERIV.simps simp: interpret_floatariths_append)
	apply (auto simp add: list_of_eucl_of_env ode_def
	ode_d_raw_def eucl_of_list_inner
	intro!: euclidean_eqI[where 'a='a])
	apply (auto simp: ode_d_fa_def )
	apply (subst interpret_floatarith_subst_floatarith[OF max_Var_floatarith_le_max_Var_floatariths_nth], simp)
	apply (rule interpret_floatarith_max_Var_cong)
	subgoal premises prems for b i
	proof -
	from prems have i: "i < max_Var_floatariths (ode_d_expr DIM('a) n)"
	by (auto dest!: max_Var_floatariths_lessI)
	also have "\<dots> \<le> 3 * DIM('a)"
	by (auto intro!: max_Var_floatariths_ode_d_expr safe_max_Var[OF FDERIV])
	finally have "i < 3 * DIM('a)" .
	then show ?thesis
	using prems i
	by (auto simp: nth_append)
	qed
	done

	lemma safe_at_within: "x \<in> Csafe \<Longrightarrow> at x = at x within Csafe"
	by (subst (2) at_within_open) (auto simp: open_safe)

	lemma ivlflowsD:
	assumes "ivlflows stops stopcont trap rsctn" "ivl \<subseteq> \<Union>(plane_of ` stops) \<times> UNIV "
	shows "ivl \<subseteq> (snd (stopcont ivl))"
	"(fst (stopcont ivl)) \<subseteq> sbelow_halfspace rsctn \<times> UNIV"
	"fst (stopcont ivl) \<subseteq> snd (stopcont ivl)"
	"(snd (stopcont ivl)) \<subseteq> sbelow_halfspace rsctn \<times> UNIV"
	"flowsto (ivl) {0..} ((snd (stopcont ivl))) ((fst (stopcont ivl)) \<union> trap)"
	using assms(1)[unfolded ivlflows_def, rule_format, OF assms(2)]
	by auto

	lemma ivlflows_flowsto:
	assumes "ivlflows stops stopcont trap rsctn" "ivl \<subseteq> \<Union>(plane_of ` stops) \<times> UNIV"
	assumes "stopcont ivl = (x, y)"
	shows "flowsto (ivl) {0..} y (x \<union> trap)"
	using ivlflowsD[OF assms(1,2)] assms(3)
	by auto

	lemma ivlflows_emptyI: "ivlflows {} (\<lambda>x. (x, x)) J K"
	by (auto simp: ivlflows_def set_of_ivl_def)

	lemma plane_of_neg[simp]: "plane_of (Sctn (- normal sctn) (- pstn sctn)) = plane_of sctn"
	by (auto simp: plane_of_def)

	lemmas safe_max_Var_le[intro] = safe_max_Var[le]

	lemmas [simp] = safe_length

	lemma continuous_on_ode_d2: "continuous_on (Csafe) ode_d2"
	proof -
	have isn: "isnFDERIV DIM('a) ode_e [0..<DIM('a)] [DIM('a)..<2 * DIM('a)] (list_of_eucl x @ list_of_eucl i)
	(Suc (Suc 0))"
	if "x \<in> Csafe"
	for x i::'a
	by (rule safe_isnFDERIV) fact
	have "continuous_on (Csafe::'a set) (\<lambda>x. ode_d_raw (Suc 0) x i j)"
	if "i \<in> Basis" "j \<in> Basis" for i j
	apply (rule has_derivative_continuous_on)
	apply (auto simp: ode_d_raw_def at_within_open[OF _ open_safe])
	apply (rule interpret_floatarith_FDERIV_floatariths_append)
	apply (auto simp: ode_d_expr_def
	intro!: isDERIV_FDERIV_floatariths safe_isFDERIV_append that isFDERIV_map_Var
	safe_max_Var_le
	max_Var_floatarith_FDERIV_floatariths[le])
	apply assumption
	apply arith
	done
	then show ?thesis
	apply (auto intro!: continuous_on_blinfun_componentwise)
	subgoal for i j
	apply (rule continuous_on_eq[where f="(\<lambda>x. ode_d_raw (Suc 0) x i j)"])
	apply force
	apply (subst ode_d2.rep_eq)
	apply simp
	apply (subst ode_d.rep_eq)
	apply (split if_splits)
	apply (rule conjI) apply simp
	using isn apply force
	done
	done
	qed

	lemmas continuous_on_ode_d2_comp[continuous_intros] = continuous_on_compose2[OF continuous_on_ode_d2]


	lemma map_ode_fa_nth[simp]:
	"d \<le> length ode_e \<Longrightarrow> map (ode_fa_nth CX) [0..<d] = map ((!) (ode_fa CX)) [0..<d]"
	by (auto simp: ode_fa_nth cong: map_cong)

	lemma map_ode_d_fa_nth[simp]:
	"d \<le> length ode_e \<Longrightarrow> map (ode_d_fa_nth i CX X) [0..<d] = map ((!) (ode_d_fa i CX X)) [0..<d]"
	by (auto simp: ode_d_fa_nth cong: map_cong)

	lemma einterpret_euler_incr_fas:
	assumes "length ode_e = DIM('a)" "length X0 = DIM('a)" "length CX = DIM('a)"
	"DIM('a) \<le> length vs" "max_Var_floatariths ode_e \<le> DIM('a)"
	shows "(einterpret (euler_incr_fas X0 h CX) vs::'a::executable_euclidean_space) =
	einterpret X0 vs + (interpret_floatarith h vs) *\<^sub>R ode (einterpret CX vs)"
	by (simp add: euler_incr_fas_def euler_incr_fas_nth_def assms ode_fa_nth cong: map_cong)

	lemma einterpret_euler_err_fas:
	assumes safe: "(einterpret CX vs::'a) \<in> Csafe"
	assumes [simp]: "length X0 = DIM('a)" "length CX = DIM('a)" "DIM('a) \<le> length vs"
	shows "(einterpret (euler_err_fas X0 h CX) vs::'a::executable_euclidean_space) =
	(((interpret_floatarith h vs))\<^sup>2/2) *\<^sub>R ode_d 0 (einterpret CX vs) (ode (einterpret CX vs)) (ode (einterpret CX vs))"
	using safe_length[OF safe] safe_max_Var[OF safe]
	apply (simp add: euler_err_fas_def euler_err_fas_nth_def[abs_def] euler_incr_fas_def)
	apply (subst interpret_ode_d_fa)
	by (auto simp: safe)

	lemma einterpret_euler_fas1:
	assumes safe[simp]: "(einterpret CX vs::'a) \<in> Csafe"
	assumes [simp]: "length X0 = DIM('a)" "length CX = DIM('a)" "DIM('a) \<le> length vs"
	shows "(einterpret (take DIM('a) (euler_fas X0 h CX)) vs::'a::executable_euclidean_space) =
	einterpret X0 vs + (interpret_floatarith h vs) *\<^sub>R ode (einterpret X0 vs) +
	(((interpret_floatarith h vs))\<^sup>2/2) *\<^sub>R ode_d 0 (einterpret CX vs) (ode (einterpret CX vs)) (ode (einterpret CX vs))"
	using safe_length[OF safe] safe_max_Var[OF safe]
	by (simp add: euler_fas_def euler_incr_fas_def euler_incr_fas_nth_def[abs_def]
	einterpret_euler_err_fas euler_err_fas_nth_def[abs_def] interpret_ode_d_fa)

	lemma einterpret_euler_fas2:
	assumes [simp]: "(einterpret CX vs::'a) \<in> Csafe"
	assumes [simp]: "length X0 = DIM('a)" "length CX = DIM('a)" "DIM('a) \<le> length vs"
	shows "(einterpret (drop DIM('a) (euler_fas X0 h CX)) vs::'a::executable_euclidean_space) =
	(((interpret_floatarith h vs))\<^sup>2/2) *\<^sub>R ode_d 0 (einterpret CX vs) (ode (einterpret CX vs)) (ode (einterpret CX vs))"
	by (simp add: euler_fas_def euler_incr_fas_def einterpret_euler_err_fas)

	lemma ode_d_Suc_0_eq_ode_d2: "x \<in> Csafe \<Longrightarrow> ode_d (Suc 0) x = ode_d2 x"
	unfolding ode_d2.rep_eq by auto

	lemma rk2_increment_rk2_fas_err:
	fixes h s1 s2 rkp x0 cx vs
	defines "h' \<equiv> interpret_floatarith h vs"
	defines "s2' \<equiv> interpret_floatarith s2 vs"
	defines "rkp' \<equiv> interpret_floatarith rkp vs"
	defines "x0' \<equiv> einterpret x0 vs"
	defines "cx' \<equiv> einterpret cx vs"
	assumes cx_flow: "cx' = flow0 x0' (h' * s1')"
	assumes [simp]: "length x0 = DIM('a)" "length cx = DIM('a)" "DIM('a) \<le> length vs"
	assumes safes: "x0' \<in> Csafe" "cx' \<in> Csafe" "(x0' + (s2' * h' * rkp') *\<^sub>R ode x0')\<in> Csafe"
	shows "(einterpret (rk2_fas_err rkp x0 h cx s2) vs::'a::executable_euclidean_space) =
	heun_remainder1 (flow0 x0') ode_na ode_d_na ode_d2_na 0 h' s1' -
	heun_remainder2 rkp' (flow0 x0') ode_na ode_d2_na 0 h' s2'"
	using safes
	using safe_length[OF safes(1)] safe_max_Var[OF safes(1)]
	apply (auto simp: heun_remainder1_def heun_remainder2_def discrete_evolution_def
	ode_na_def ode_d_na_def ode_d2_na_def rk2_increment x0'_def rkp'_def h'_def s2'_def
	cx'_def euler_incr_fas_def rk2_fas_err_def rk2_fas_err_nth_def[abs_def]
	euler_incr_fas_nth_def[abs_def]
	interpret_ode_d_fa)
	apply (simp add: ode_d1_eq[symmetric] ode_d_Suc_0_eq_ode_d2 inverse_eq_divide)
	apply (simp add: algebra_simps field_simps divide_simps)
	unfolding cx'_def[symmetric] cx_flow x0'_def h'_def
	apply (simp add: algebra_simps)
	done

	lemma map_rk2_fas_err_nth[simp]:
	"d = length ode_e \<Longrightarrow> length b = length ode_e \<Longrightarrow> map (rk2_fas_err_nth a b c e f) [0..<d] = map ((!) (rk2_fas_err a b c e f)) [0..<d]"
	unfolding rk2_fas_err_nth_def rk2_fas_err_def
	by (rule map_cong) auto

	lemma rk2_increment_rk2_fas1:
	fixes h s1 s2 rkp x0 cx vs
	defines "h' \<equiv> interpret_floatarith h vs"
	defines "s2' \<equiv> interpret_floatarith s2 vs"
	defines "rkp' \<equiv> interpret_floatarith rkp vs"
	defines "x0' \<equiv> einterpret x0 vs"
	defines "cx' \<equiv> einterpret cx vs"
	assumes cx_flow: "cx' = flow0 x0' (h' * s1')"
	assumes [simp]: "length x0 = DIM('a)" "length cx = DIM('a)" "DIM('a) \<le> length vs"
	assumes safes: "(x0'::'a)\<in> Csafe" "(cx'::'a)\<in> Csafe" "(x0' + (s2' * h' * rkp') *\<^sub>R ode x0'::'a)\<in> Csafe"
	shows "(einterpret (take DIM('a) (rk2_fas rkp x0 h cx s2)) vs::'a::executable_euclidean_space) =
	discrete_evolution (rk2_increment rkp' (\<lambda>_. ode)) h' 0 x0' + (heun_remainder1 (flow0 x0') ode_na ode_d_na ode_d2_na 0 h' s1' -
	heun_remainder2 rkp' (flow0 x0') ode_na ode_d2_na 0 h' s2')"
	using safes using safe_length[OF safes(1)] safe_max_Var[OF safes(1)]
	apply (auto simp: discrete_evolution_def rk2_fas_def)
	apply (subst rk2_increment_rk2_fas_err[OF cx_flow[unfolded cx'_def x0'_def h'_def]])
	subgoal by simp
	subgoal by simp
	subgoal by simp
	subgoal by (simp add: x0'_def)
	subgoal by (simp add: cx'_def)
	subgoal by (simp add: x0'_def s2'_def h'_def rkp'_def)
	subgoal using [[show_consts, show_sorts, show_types]]
	by (auto simp: x0'_def s2'_def h'_def rkp'_def rk2_increment euler_incr_fas_def
	euler_incr_fas_nth_def[abs_def] inverse_eq_divide)
	done

	lemma rk2_increment_rk2_fas2:
	fixes h s1 s2 rkp x0 cx vs
	defines "h' \<equiv> interpret_floatarith h vs"
	defines "s2' \<equiv> interpret_floatarith s2 vs"
	defines "rkp' \<equiv> interpret_floatarith rkp vs"
	defines "x0' \<equiv> einterpret x0 vs"
	defines "cx' \<equiv> einterpret cx vs"
	assumes cx_flow: "cx' = flow0 x0' (h' * s1')"
	assumes [simp]: "length x0 = DIM('a)" "length cx = DIM('a)" "DIM('a) \<le> length vs"
	assumes safes: "x0'\<in> Csafe" "cx'\<in> Csafe" "(x0' + (s2' * h' * rkp') *\<^sub>R ode x0')\<in> Csafe"
	shows "(einterpret (drop DIM('a) (rk2_fas rkp x0 h cx s2)) vs::'a::executable_euclidean_space) =
	(heun_remainder1 (flow0 x0') ode_na ode_d_na ode_d2_na 0 h' s1' -
	heun_remainder2 rkp' (flow0 x0') ode_na ode_d2_na 0 h' s2')"
	using safes
	apply (auto simp: discrete_evolution_def rk2_fas_def)
	apply (subst rk2_increment_rk2_fas_err[OF cx_flow[unfolded cx'_def x0'_def h'_def]])
	subgoal by simp
	subgoal by simp
	subgoal by simp
	subgoal by (simp add: x0'_def)
	subgoal by (simp add: cx'_def)
	subgoal by (simp add: x0'_def s2'_def h'_def rkp'_def)
	subgoal by (auto simp: x0'_def s2'_def h'_def rkp'_def rk2_increment euler_incr_fas_def inverse_eq_divide)
	done

	subsubsection \<open>safe set relation\<close>

	lemma mk_safe[le, refine_vcg]: "wd TYPE('a::executable_euclidean_space)\<Longrightarrow>
	mk_safe X \<le> SPEC (\<lambda>R::'a set. R = X \<and> X \<subseteq> Csafe)"
	unfolding mk_safe_def
	by refine_vcg

	lemma mk_safe_coll[le, refine_vcg]: "wd TYPE('a::executable_euclidean_space) \<Longrightarrow>
	mk_safe_coll X \<le> SPEC (\<lambda>R::'a set. R = X \<and> X \<subseteq> Csafe)"
	unfolding mk_safe_coll_def autoref_tag_defs
	by (refine_vcg FORWEAK_invarI[where I="\<lambda>a b. X = \<Union>b \<union> a \<and> a \<subseteq> Csafe"]) auto


	lemma ode_set_spec[THEN order.trans, refine_vcg]:
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "ode_set X \<le> SPEC (\<lambda>r. ode ` X \<subseteq> (r::'a set))"
	using assms wdD[OF assms(1)]
	unfolding ode_set_def
	apply (refine_vcg)
	subgoal by (auto simp: env_len_def ode_slp_def)
	subgoal premises prems
	using prems(1,2,4-)
	by (auto simp: env_len_def eucl_of_list_prod ode_def)
	done

	lemmas fderiv[derivative_intros] = ode_has_derivative_safeI

	lemma fderiv2[derivative_intros]:
	"x \<in> Csafe \<Longrightarrow> (ode_d1 has_derivative ode_d2 x) (at x)"
	by (frule ode_d1_has_derivative_safeI)
	(simp add: ode_d_Suc_0_eq_ode_d2)

	lemma derivative_within_safe[derivative_intros]:
	"(g has_derivative h) (at x) \<Longrightarrow> (g has_derivative h) (at x within Csafe)"
	by (rule has_derivative_at_withinI)

	lemma cont_fderiv: "continuous_on (Csafe) ode_d1"
	by (rule has_derivative_continuous_on) (auto intro!: derivative_intros)

	lemmas cont_fderiv'[continuous_intros] = continuous_on_compose2[OF cont_fderiv]

	lemma continuous_on_ode1:
	"continuous_on (Csafe) (ode)"
	using fderiv
	by (auto intro!: has_derivative_continuous_on derivative_intros)

	lemma continuous_on_ode[continuous_intros]:
	"continuous_on s g \<Longrightarrow> (\<And>x. x \<in> s \<Longrightarrow> (g x) \<in> Csafe) \<Longrightarrow> continuous_on s (\<lambda>x. ode (g x))"
	using continuous_on_ode1
	by (rule continuous_on_compose2) auto

	lemma fderiv'[derivative_intros]:
	assumes "(g has_derivative g' y) (at y within X)"
	assumes "(g y) \<in> Csafe"
	shows "((\<lambda>y. ode (g y)) has_derivative
	(blinfun_apply (ode_d1 (g y)) \<circ>\<circ> g') y) (at y within X)"
	using diff_chain_within[OF assms(1) has_derivative_subset[OF fderiv]] assms(2)
	by (simp add: o_def)

	lemma fderiv2'[derivative_intros]:
	assumes "(g has_derivative g' y) (at y within X)"
	assumes "(g y) \<in> Csafe"
	shows "((\<lambda>y. ode_d1 (g y)) has_derivative
	(blinfun_apply (ode_d2 (g y)) \<circ>\<circ> g') y) (at y within X)"
	using diff_chain_within[OF assms(1) has_derivative_subset[OF fderiv2]] assms(2)
	by (simp add: o_def)


	subsubsection \<open>step of Picard iteration\<close>

	lemma ncc_interval: "ncc {a .. b::'a::executable_euclidean_space} \<longleftrightarrow> a \<le> b"
	by (auto simp: ncc_def)
	lemma nonempty_interval: "nonempty {a .. b::'a::executable_euclidean_space} \<longleftrightarrow> a \<le> b"
	by (auto simp: nonempty_def)

	lemmas [refine_vcg] = Picard_step_def[THEN eq_refl, THEN order.trans]

	lemma Basis_list_zero_mem_Basis[simp]:
	"Basis_list ! 0 \<in> Basis"
	unfolding Basis_list[symmetric]
	apply (rule nth_mem)
	apply (rule length_Basis_list_pos)
	done

	lemma cfuncset_empty_iff:
	fixes l u::"'d::ordered_euclidean_space"
	shows "l \<le> u \<Longrightarrow> cfuncset l u X = {} \<longleftrightarrow> X = {}"
	unfolding cfuncset_def Pi_def
	proof (safe, goal_cases)
	case hyps: (1 x)
	from \<open>x \<in> X\<close>
	have "(\<lambda>_. x) \<in> {f. \<forall>x. x \<in> {l..u} \<longrightarrow> f x \<in> X} \<inter> Collect (continuous_on {l..u})"
	by (auto intro!: continuous_on_const)
	then show ?case using hyps by auto
	qed auto

	lemma lv_ivl_sings: "lv_ivl [x] [y] = (\<lambda>x. [x]) ` {x .. y}"
	apply (auto simp: lv_ivl_def)
	subgoal for x by (cases x) auto
	done

	lemma Picard_step_ivl_refine[le, refine_vcg]:
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	assumes "(X::'a set) \<subseteq> Csafe"
	assumes "0 \<le> h"
	shows "Picard_step_ivl X0 t0 h X \<le> Picard_step X0 t0 h X"
	proof -
	have "h' \<in> {t0..t0 + h} \<Longrightarrow> t0 \<le> h'" for h' by simp
	then show ?thesis
	unfolding Picard_step_ivl_def Picard_step_def
	apply (refine_vcg, clarsimp_all simp del: atLeastAtMost_iff)
	subgoal using \<open>0 \<le> h\<close> by simp
	subgoal by (auto simp: euler_incr_slp_def wdD)
	subgoal by (auto simp: euler_incr_fas'_def)
	subgoal for XS l u
	apply (auto simp: lv_ivl_sings nonempty_interval
	simp del: atLeastAtMost_iff
	intro!: add_integral_ivl_bound)
	subgoal for x0 h' phi x h''
	apply (drule bspec, assumption)
	apply (drule bspec[where x="h'' - t0"], force)
	proof goal_cases
	case (1)
	have *: "map ((!) (list_of_eucl b)) [0..<DIM('a) - Suc 0] @ [b \<bullet> Basis_list ! (DIM('a) - Suc 0)]
	= list_of_eucl b" for b::'a
	apply (auto intro!: nth_equalityI simp: nth_append not_less)
	using Intersection.le_less_Suc_eq by blast
	have "phi x \<in> X" if "x \<in> {t0 .. h''}" for x
	using 1 that by (auto simp: cfuncset_iff)
	have "x0 + (h'' - t0) *\<^sub>R ode b \<in> {l .. u}" if "b \<in> X" for b
	proof -
	from 1(17)[rule_format, OF that] assms(1)
	have "einterpret (euler_incr_fas' D) (list_of_eucl x0 @ (h'' - t0) # list_of_eucl b) \<in> eucl_of_list ` XS"
	by (auto simp: wdD)
	also have "eucl_of_list ` XS \<subseteq> {l .. u}" by fact
	finally show ?thesis
	by (simp add: euler_incr_fas'_def einterpret_euler_incr_fas map_nth_append1 nth_append wdD[OF \<open>wd _\<close>] *)
	qed
	then have : "(h'' - t0) \<^sub>R ode b \<in> {l - x0..u - x0}" if "b \<in> X" for b using that
	by (auto simp: algebra_simps)
	show ?case
	apply (rule *)
	using 1 by (auto simp: cfuncset_iff)
	qed
	subgoal
	using assms(2)
	by (auto intro!: integrable_continuous_real continuous_intros
	simp: cfuncset_iff)
	done
	done
	qed

	subsubsection \<open>Picard iteration\<close>

	lemma inf_le_supI[simp]:
	fixes a b c d::"'d::ordered_euclidean_space"
	shows
	"a \<le> c \<Longrightarrow> inf a b \<le> sup c d"
	"a \<le> d \<Longrightarrow> inf a b \<le> sup c d"
	"b \<le> c \<Longrightarrow> inf a b \<le> sup c d"
	"b \<le> d \<Longrightarrow> inf a b \<le> sup c d"
	by (auto simp: eucl_le[where 'a='d] eucl_inf[where 'a='d] eucl_sup[where 'a='d] inf_real_def sup_real_def
	intro!: sum_mono scaleR_right_mono)

	lemmas [refine_vcg_def] = do_widening_spec_def

	lemma P_iter_spec[le, refine_vcg]:
	assumes "PHI \<subseteq> Csafe"
	assumes "0 \<le> h"
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "P_iter X0 h i PHI \<le>
	SPEC (\<lambda>r. case r of
	None \<Rightarrow> True
	\| Some (PHI'::'a set) \<Rightarrow> nonempty PHI' \<and> compact PHI' \<and> (\<exists>PHI'' \<subseteq> PHI'. RETURN (Some PHI'') \<le> Picard_step X0 0 h PHI'))"
	using assms[unfolded autoref_tag_defs]
	proof (induction i arbitrary: PHI)
	case 0 then show ?case
	unfolding P_iter.simps
	by refine_vcg
	next
	case (Suc i)
	show ?case
	unfolding P_iter.simps
	apply (refine_vcg Suc)
	subgoal by (auto simp: cfuncset_iff Picard_step_def algebra_simps add_increasing2)
	subgoal for lu l u b CX CX' lu' l' u' b'
	apply (simp add: nonempty_interval Picard_step_def)
	apply (safe intro!: exI[where x="{l .. u}"] compact_interval)
	subgoal by (auto simp: nonempty_interval)
	apply (rule subsetD[of CX' "{l .. u}"])
	subgoal
	apply (rule order_trans, assumption)
	unfolding atLeastatMost_subset_iff
	apply (rule disjI2)
	apply (rule conjI)
	subgoal
	apply (rule order_trans[where y="inf l' l - (if b' then \<bar>l' - l\<bar> else 0)"])
	by (simp_all split: if_split_asm add: algebra_simps add_increasing2)
	subgoal
	apply (split if_split_asm)
	apply (rule order_trans[where y="sup u' u + \<bar>u' - u\<bar>"])
	by (auto split: if_split_asm simp add: algebra_simps add_increasing2)
	done
	subgoal by force
	done
	done
	qed


	subsubsection \<open>iterate step size\<close>
	lemma Ball_cfuncset_continuous_on:
	"\<forall>f\<in>cfuncset a b X. continuous_on {a..b} f"
	by (simp add: cfuncset_iff)

	lemmas one_step_methodD = one_step_method_def[THEN iffD1, rule_format, le]
	lemmas one_step_methodI = one_step_method_def[THEN iffD2, rule_format]

	lemma cert_stepsize_lemma:
	assumes prems: " 0 < h"
	"X0 \<subseteq> {l..u}"
	"Res \<subseteq> Csafe"
	"Res_ivl \<subseteq> Csafe"
	"{l..u} \<subseteq> Csafe"
	"nonempty PHI'"
	"nonempty Res"
	"\<forall>x0\<in>X0.
	x0 \<in> Csafe \<longrightarrow>
	h \<in> existence_ivl0 x0 \<longrightarrow>
	(\<forall>h'\<in>{0..h}. flow0 x0 h' \<in> PHI') \<longrightarrow>
	x0 + h *\<^sub>R ode x0 \<in> PHI' \<longrightarrow> flow0 x0 h \<in> Res"
	"nonempty Res_ivl"
	"\<forall>x0\<in>X0.
	x0 \<in> Csafe \<longrightarrow>
	(\<forall>h\<in>{0..h}.
	h \<in> existence_ivl0 x0 \<longrightarrow>
	(\<forall>h'\<in>{0..h}. flow0 x0 h' \<in> PHI') \<longrightarrow>
	x0 + h *\<^sub>R ode x0 \<in> PHI' \<longrightarrow> flow0 x0 h \<in> Res_ivl)"
	"compact PHI'"
	"PHI'' \<subseteq> PHI'"
	"RETURN (Some PHI'') \<le> Picard_step X0 0 h PHI'"
	shows "flowpipe0 X0 h h Res_ivl Res"
	proof -
	from prems
	have Ps: "RETURN (Some PHI'') \<le> Picard_step X0 0 h PHI'"
	by simp
	from Ps have PHI':
	"compact PHI''" "PHI'' \<subseteq> Csafe"
	"\<forall>x\<in>PHI''. x \<in> Csafe"
	"\<And>x0 h'' phi. x0 \<in> X0 \<Longrightarrow> 0 \<le> h'' \<Longrightarrow> h'' \<le> h \<Longrightarrow> phi \<in> cfuncset 0 h'' PHI' \<Longrightarrow>
	x0 + integral {0..h''} (\<lambda>t. ode (phi t)) \<in> PHI''"
	by (auto simp: Picard_step_def)
	then obtain cx where cx: "(\<lambda>t::real. cx) \<in> cfuncset 0 0 PHI'"
	using \<open>PHI'' \<subseteq> PHI'\<close> \<open>nonempty PHI'\<close> by (auto simp: cfuncset_def continuous_on_const nonempty_def)
	show "flowpipe0 X0 h h Res_ivl Res"
	unfolding flowpipe0_def atLeastAtMost_singleton
	proof safe
	show "0 \<le> h" using \<open>0 < h\<close> by simp
	show safe_X0: "x \<in> Csafe" if "x \<in> X0" for x using that \<open>{l..u} \<subseteq> Csafe\<close> \<open>X0 \<subseteq> {l..u}\<close> by blast
	show "x \<in> Csafe" if "x \<in> Res_ivl" for x using prems that
	- by (auto simp: )
	+ by auto
	show "x \<in> Csafe" if "x \<in> Res" for x using prems that by (auto simp:)
	fix x0 assume "x0 \<in> X0"
	from PHI'(4)[OF \<open>x0 \<in> X0\<close> order_refl \<open>0 \<le> h\<close> cx]
	have "x0 \<in> PHI''" by simp
	have *: "h \<in> existence_ivl0 x0" "s \<in> {0 .. h} \<Longrightarrow> flow0 x0 s \<in> PHI''" for s
	using \<open>x0 \<in> X0\<close> \<open>PHI'' \<subseteq> PHI'\<close> \<open>0 \<le> h\<close> PHI'(3) \<open>x0 \<in> PHI''\<close>
	by (auto
	simp: cfuncset_def Pi_iff closed_segment_eq_real_ivl ivl_integral_def
	intro!: Picard_iterate_mem_existence_ivlI[OF UNIV_I _ UNIV_I \<open>compact PHI''\<close>
	\<open>x0 \<in> PHI''\<close> \<open>PHI'' \<subseteq> Csafe\<close>] PHI'(4)) force+
	show h_ex: "h \<in> existence_ivl0 x0" by fact
	have cf: "(\<lambda>t::real. x0) \<in> cfuncset 0 h PHI'" for h
	using \<open>x0 \<in> PHI''\<close> \<open>PHI'' \<subseteq> PHI'\<close>
	by (auto simp: cfuncset_def continuous_intros)
	have mem_PHI': "x0 + h' *\<^sub>R ode x0 \<in> PHI'" if "0 \<le> h'" "h' \<le> h" for h'
	using that \<open>PHI'' \<subseteq> PHI'\<close> PHI'(4)[OF \<open>x0 \<in> X0\<close> that cf]
	by auto
	from this prems safe_X0
	show "flow0 x0 h \<in> Res"
	using \<open>0 \<le> h\<close> h_ex * \<open>PHI'' \<subseteq> PHI'\<close> \<open>x0 \<in> X0\<close>
	by (auto simp: subset_iff dest!: bspec[where x=x0])
	fix h' assume h': "h' \<in> {0..h}"
	then have "h' \<in> existence_ivl0 x0"
	by (meson atLeastAtMost_iff existence_ivl_zero h_ex is_interval_1
	local.is_interval_existence_ivl local.mem_existence_ivl_iv_defined(2))
	from h' this prems safe_X0
	show "flow0 x0 h' \<in> Res_ivl"
	using \<open>0 < h\<close> h_ex * \<open>PHI'' \<subseteq> PHI'\<close> \<open>x0 \<in> X0\<close> mem_PHI' \<open>x0 \<in> PHI''\<close>
	by (auto simp: subset_iff dest!: bspec[where x=x0])
	qed
	qed

	lemma cert_stepsize_spec[le,refine_vcg]:
	assumes "h > 0"
	assumes "one_step_method m"
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "cert_stepsize m X0 h i n \<le> SPEC (\<lambda>(h', RES::'a set, RES_ivl, _). nonempty RES \<and> nonempty RES_ivl \<and> 0 < h' \<and> h' \<le> h \<and> flowpipe0 X0 h' h' RES_ivl RES)"
	using assms(1)[unfolded autoref_tag_defs]
	proof (induction n arbitrary: h)
	case 0 then show ?case by simp
	next
	case (Suc n)
	note [refine_vcg] = Suc.IH[of "h/2", le]
	show ?case
	unfolding cert_stepsize.simps
	using Suc.prems
	by (refine_vcg Ball_cfuncset_continuous_on one_step_methodD[OF assms(2)])
	(clarsimp_all simp: cert_stepsize_lemma)
	qed


	subsubsection \<open>Euler step\<close>

	lemma embed_real_ivl_iff[simp]:
	"(\<forall>x \<in> {0 .. h *\<^sub>R (One::'a::executable_euclidean_space)}. P (x \<bullet> hd Basis_list)) \<longleftrightarrow> (\<forall>x \<in> {0 .. h}. P x)"
	proof (auto simp: eucl_le[where 'a='a], goal_cases)
	case hyps: (1 x)
	have "x = x *\<^sub>R (One::'a) \<bullet> hd Basis_list"
	by auto
	also have "P \<dots>"
	apply (rule hyps[rule_format])
	using hyps
	by (auto simp: eucl_le[where 'a='a])
	finally show ?case .
	qed

	lemma convex_on_segmentI:
	assumes mem_convex: "convex C" "a \<in> C" "a + j *\<^sub>R b \<in> C"
	assumes "0 \<le> i" "i \<le> j"
	shows "a + i *\<^sub>R b \<in> C"
	proof -
	have "a + i \<^sub>R b = (1 - i / j) \<^sub>R a + (i / j) \<^sub>R (a + j \<^sub>R b)"
	using assms
	by (auto simp: algebra_simps diff_divide_distrib)
	also have "\<dots> \<in> C"
	using assms
	by (auto simp: divide_simps intro!: convexD[OF mem_convex])
	finally show ?thesis .
	qed

	lemma one_step_flowpipe:
	assumes [THEN one_step_methodD, refine_vcg]: "one_step_method m"
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "one_step X0 h m \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'a set). 0 < h' \<and> h' \<le> h \<and> flowpipe0 X0 h' h' RES_ivl RES)"
	using assms
	unfolding one_step_def
	by refine_vcg

	lemma ncc_imageD:
	assumes "ncc ((\<lambda>x. x ! i) ` env)"
	assumes "nth_image_precond env i"
	shows "compact ((\<lambda>x. x ! i) ` env::real set)" "closed ((\<lambda>x. x ! i) ` env)" "bounded ((\<lambda>x. x ! i) ` env)"
	"((\<lambda>x. x ! i) ` env) \<noteq> {}" "convex ((\<lambda>x. x ! i) ` env)"
	using assms
	by (auto simp: ncc_def nth_image_precond_def compact_eq_bounded_closed)

	lemma max_Var_floatariths_ode_d_fa[le]:
	assumes [simp]: "length ode_e > 0" "max_Var_floatariths ode_e \<le> length ode_e"
	"length cxs = length ode_e" "length ys = length ode_e"
	shows "max_Var_floatariths (ode_d_fa i cxs ys) \<le> max (max_Var_floatariths (cxs)) (max_Var_floatariths ys)"
	apply (auto simp: ode_d_fa_def max_Var_floatariths_Max )
	using assms apply auto[1]
	apply (auto intro!: max_Var_floatarith_subst_floatarith_le max_Var_floatariths_ode_d_expr
	max_Var_floatarith_le_max_Var_floatariths_nthI max_Var_ode_fa
	simp: in_set_conv_nth)
	apply (auto simp: max_Var_floatariths_Max in_set_conv_nth)
	done

	lemma max_Var_floatariths_euler_err_fas[le]:
	assumes nz: "0 < length ode_e"
	and [simp]: "max_Var_floatariths ode_e \<le> length ode_e"
	"length xs = length ode_e"
	"length cxs = length ode_e"
	shows "max_Var_floatariths (euler_err_fas xs h cxs)
	\<le> max (max_Var_floatariths xs) (max (max_Var_floatarith h) (max_Var_floatariths cxs))"
	using nz
	by (auto simp: euler_err_fas_def[abs_def] euler_err_fas_nth_def[abs_def] map_nth_eq_self simp del: length_0_conv
	intro!: max_Var_floatariths_ode_d_fa max_Var_floatariths_map_times
	max_Var_floatariths_map_const max_Var_ode_fa; arith)

	lemma max_Var_floatariths_euler_incr_fas[le]:
	assumes [simp]: "max_Var_floatariths ode_e \<le> length ode_e"
	"length xs = length ode_e"
	"length cxs = length ode_e"
	shows "max_Var_floatariths (euler_incr_fas xs h cxs)
	\<le> max (max_Var_floatariths xs) (max (max_Var_floatarith h) (max_Var_floatariths cxs))"
	using length_ode_fa
	by (auto simp: euler_incr_fas_def euler_incr_fas_nth_def[abs_def] simp del: length_ode_fa
	intro!: max_Var_floatariths_ode_d_fa max_Var_floatariths_map_plus max_Var_floatariths_map_times
	max_Var_floatariths_map_const max_Var_ode_fa)

	lemma map_euler_incr_fas_nth: "length X0 = d \<Longrightarrow> map (euler_incr_fas_nth X0 h CX) [0..<d] = euler_incr_fas X0 h CX"
	by (auto simp: euler_incr_fas_def)

	lemma map_euler_err_fas_nth: "length X0 = d \<Longrightarrow> map (euler_err_fas_nth X0 h CX) [0..<d] = euler_err_fas X0 h CX"
	by (auto simp: euler_err_fas_def)

	lemma max_Var_floatariths_euler_fas[le]:
	assumes [simp]: "max_Var_floatariths ode_e \<le> length ode_e"
	"length xs = length ode_e"
	"length cxs = length ode_e"
	assumes nz: "0 < length ode_e"
	shows "max_Var_floatariths (euler_fas xs h cxs) \<le> Max {max_Var_floatariths xs, max_Var_floatarith h, max_Var_floatariths cxs}"
	using nz
	by (auto simp: euler_fas_def map_euler_incr_fas_nth map_euler_err_fas_nth
	intro!: max_Var_floatariths_map_plus max_Var_floatariths_euler_incr_fas
	max_Var_floatariths_euler_err_fas)

	lemma take_interpret_floatariths:
	"d < length fas \<Longrightarrow> take d (interpret_floatariths fas vs) = interpret_floatariths (take d fas) vs"
	by (auto intro!: nth_equalityI)

	lemma length_euler_slp_le: "2 * D \<le> length euler_slp"
	by (auto simp: euler_fas'_def euler_slp_def intro!: order_trans[OF _ length_slp_of_fas_le])

	lemma ncc_nonempty[simp]: "ncc x \<Longrightarrow> nonempty x"
	by (simp add: ncc_def nonempty_def)

	lemma nccD:
	assumes "ncc X"
	shows "compact X" "closed X" "bounded X" "X \<noteq> {}" "convex X"
	using assms
	by (auto simp: ncc_def nth_image_precond_def compact_eq_bounded_closed)

	lemma D_DIM_wdD[simp]: "wd TYPE('a::executable_euclidean_space) \<Longrightarrow> D = DIM('a)"
	by (auto simp: wdD)

	lemma euler_step_flowpipe:
	includes floatarith_notation
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "euler_step X0 h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'a set). 0 < h' \<and> h' \<le> h \<and> flowpipe0 X0 h' h' RES_ivl RES)"
	unfolding euler_step_def THE_NRES_def
	apply (intro SPEC_rule_conjI one_step_flowpipe one_step_methodI)
	apply (refine_vcg, clarsimp_all)
	subgoal using assms by (auto simp: euler_slp_def euler_fas'_def)
	subgoal by (auto simp: euler_slp_def euler_fas'_def)
	subgoal using length_euler_slp_le assms by (auto simp: env_len_def wdD[OF \<open>wd _\<close>])
	subgoal using length_euler_slp_le assms by (auto simp: env_len_def wdD[OF \<open>wd _\<close>])
	proof (goal_cases)
	case hyps: (1 X0 CX hl hu env res b x0 enve h)
	then interpret derivative_on_prod "{0 .. h}" CX "\<lambda>_. ode" "\<lambda>(t, x). ode_d1 x o\<^sub>L snd_blinfun"
	by unfold_locales (auto intro!: continuous_intros derivative_eq_intros
	simp: split_beta' subset_iff wdD[OF \<open>wd _\<close>])
	from \<open>h \<in> existence_ivl0 x0\<close> have s_ex: "s \<in> existence_ivl0 x0" if "0 \<le> s" "s \<le> h" for s
	by (metis (no_types, lifting) atLeastAtMost_iff ivl_subset_existence_ivl subset_iff that)
	have "flow0 x0 (h) = flow0 x0 (0 + (h))" by simp
	also have "\<dots> \<in> eucl_of_list ` take D ` env"
	using hyps
	apply (intro euler_consistent_traj_set[where x="flow0 x0" and u = "h"])
	apply (auto intro!: \<open>0 \<le> h\<close> flow_has_vector_derivative[THEN has_vector_derivative_at_within]
	simp: nccD discrete_evolution_def euler_increment subset_iff wdD[OF \<open>wd _\<close>]
	Let_def s_ex min_def max_def lv_ivl_sings)
	subgoal premises prems for s
	proof -
	have "interpret_floatariths (euler_fas' DIM('a)) (list_of_eucl x0 @ list_of_eucl (flow0 x0 s) @ [h]) \<in> env"
	using prems
	by (auto intro!: prems(1)[rule_format])
	then have "eucl_of_list (take D (interpret_floatariths (euler_fas' DIM('a)) (list_of_eucl x0 @ list_of_eucl (flow0 x0 s) @ [h])))
	\<in> eucl_of_list ` take D ` env"
	(is "eucl_of_list (take _ (interpret_floatariths _ ?vs)) \<in> _")
	by auto
	also
	have "take (2 * D) (interpret_floatariths (euler_fas' DIM('a)) ?vs) =
	interpret_floatariths (map fold_const_fa (euler_fas (map floatarith.Var [0..<D]) (Var (2 * D)) (map floatarith.Var [D..<2 * D]))) ?vs"
	unfolding euler_fas'_def
	by (auto simp: euler_fas_def wdD[OF \<open>wd _\<close>] simp del: map_map
	intro!: max_Var_floatariths_map_plus max_Var_floatariths_euler_incr_fas
	max_Var_floatariths_euler_err_fas \<open>wd _\<close>
	max_Var_floatariths_fold_const_fa[le])
	then have "take D (take (2 * D) (interpret_floatariths (euler_fas' DIM('a)) ?vs)) =
	take D (interpret_floatariths (euler_fas (map floatarith.Var [0..<D]) (Var(2 * D)) (map floatarith.Var [D..<2 * D])) ?vs)"
	by simp
	then have "take D (interpret_floatariths (euler_fas' DIM('a)) ?vs) =
	take DIM('a) (interpret_floatariths (euler_fas (map floatarith.Var [0..<D]) (Var(2 * D)) (map floatarith.Var [D..<2 * D])) ?vs)"
	by (simp add: wdD[OF \<open>wd _\<close>])
	also have "eucl_of_list \<dots> =
	x0 + h \<^sub>R ode x0 + (h\<^sup>2 / 2) \<^sub>R (ode_d 0 (flow0 x0 s) (ode (flow0 x0 s))) (ode (flow0 x0 s))"
	by (auto simp: take_interpret_floatariths einterpret_euler_fas1 map_nth_append1 prems nth_append
	wdD[OF \<open>wd _\<close>])
	finally show ?thesis
	by (simp add: prems(10) prems(13) prems(14) prems(5) ode_d1_eq[symmetric] wdD[OF \<open>wd _\<close>])
	qed
	done
	also have "\<dots> \<subseteq> res" using assms hyps by auto
	finally show ?case by simp
	qed (auto simp: assms)

	lemma length_rk2_slp_le: "2 * D \<le> length rk2_slp"
	by (auto simp: rk2_slp_def rk2_fas'_def intro!: order_trans[OF _ length_slp_of_fas_le])

	lemma max_Var_floatarith_R\<^sub>e[simp]: "max_Var_floatarith (R\<^sub>e x) = 0"
	by (auto simp: R\<^sub>e_def split: prod.splits)

	lemma max_Var_floatariths_rk2_fas_err[le]:
	assumes nz: "0 < length ode_e"
	and [simp]: "max_Var_floatariths ode_e \<le> length ode_e" "length x0 = length ode_e" "length cx = length ode_e"
	shows "max_Var_floatariths (rk2_fas_err rkp x0 h cx s2) \<le>
	Max {max_Var_floatarith rkp, max_Var_floatariths x0, max_Var_floatarith h, max_Var_floatariths cx,
	max_Var_floatarith s2}"
	using nz
	unfolding rk2_fas_err_def rk2_fas_err_nth_def
	by (auto simp: rk2_fas_err_def
	intro!: max_Var_floatariths_append max_Var_floatariths_map_plus max_Var_floatariths_map_times
	max_Var_floatariths_map_const max_Var_ode_fa max_Var_floatariths_euler_incr_fas
	max_Var_floatariths_ode_d_fa; arith)

	lemma max_Var_floatarith_one[simp]: "max_Var_floatarith 1 = 0"
	and max_Var_floatarith_zero[simp]: "max_Var_floatarith 0 = 0"
	by (auto simp: one_floatarith_def zero_floatarith_def)

	lemma max_Var_floatariths_rk2_fas[le]:
	assumes nz: "0 < length ode_e"
	and [simp]: "max_Var_floatariths ode_e \<le> length ode_e" "length x0 = length ode_e" "length cx = length ode_e"
	shows "max_Var_floatariths (rk2_fas rkp x0 h cx s2) \<le>
	Max {max_Var_floatarith rkp, max_Var_floatariths x0, max_Var_floatarith h, max_Var_floatariths cx,
	max_Var_floatarith s2}"
	using nz
	by (auto simp: rk2_fas_def
	intro!: max_Var_floatariths_append max_Var_floatariths_map_plus max_Var_floatariths_map_times
	max_Var_floatariths_map_const max_Var_ode_fa max_Var_floatariths_euler_incr_fas
	max_Var_floatariths_rk2_fas_err)

	lemma rk2_step_flowpipe:
	includes floatarith_notation
	assumes [refine_vcg]: "wd TYPE('a::executable_euclidean_space)"
	shows "rk2_step X0 h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'a set).
	0 < h' \<and> h' \<le> h \<and> flowpipe0 X0 h' h' RES_ivl RES)"
	unfolding rk2_step_def THE_NRES_def
	apply (intro one_step_flowpipe assms one_step_methodI)
	apply (refine_vcg, clarsimp_all)
	subgoal using assms by (auto simp: rk2_slp_def rk2_fas'_def)
	subgoal by (auto simp: rk2_slp_def rk2_fas'_def)
	subgoal using length_rk2_slp_le by (auto simp: env_len_def wdD[OF \<open>wd _\<close>])
	subgoal using length_rk2_slp_le by (auto simp: env_len_def wdD[OF \<open>wd _\<close>])
	proof (goal_cases)
	case hyps: (1 X0 CX hl hu rk2_param env res b x0 el h)
	from assms have "D = DIM('a)" by simp
	have aux: "ode (flow0 x0 s) = ode (snd (s, flow0 x0 s))" for s
	by simp
	from hyps interpret derivative_on_prod "{0 .. h}" CX "\<lambda>_ x. ode x" "\<lambda>(t, x). ode_d1 x o\<^sub>L snd_blinfun"
	by unfold_locales
	(auto intro!: continuous_intros derivative_eq_intros simp: split_beta' subset_iff)

	have aux2: "blinfun_apply (ode_d1 (snd tx)) \<circ> snd = blinfun_apply (ode_d1 (snd tx) o\<^sub>L snd_blinfun)"
	for tx::"real\<times>'a"
	by (auto intro!: blinfun_eqI)

	have aux3: "blinfun_apply (ode_d2 (snd tx)) (snd h) o\<^sub>L snd_blinfun =
	(flip_blinfun (flip_blinfun (ode_d2 (snd tx) o\<^sub>L snd_blinfun) o\<^sub>L snd_blinfun)) h"
	for tx h::"real\<times>'a"
	by (auto intro!: blinfun_eqI)


	have "flow0 x0 (h) = flow0 x0 (0 + (h))" by simp
	also have "\<dots> \<in> eucl_of_list ` take D ` env"
	using hyps assms
	apply (intro rk2_consistent_traj_set[where
	x="flow0 x0" and u = "h" and T="{0..h}" and X="CX" and p="rk2_param"
	and f = "ode_na" and f' = ode_d_na and g' = ode_d_na and f'' = ode_d2_na and g'' = ode_d2_na])
	subgoal by (simp add: \<open>0 \<le> h\<close>)
	subgoal by simp
	subgoal by simp
	subgoal by auto
	subgoal by (auto simp add: ncc_def nonempty_def)
	subgoal
	apply (rule flow_has_vector_derivative[THEN has_vector_derivative_at_within, THEN has_vector_derivative_eq_rhs])
	subgoal by (metis (no_types, lifting) ivl_subset_existence_ivl subset_iff)
	subgoal by (force simp: ode_na_def[abs_def] ode_d_na_def[abs_def] ode_d2_na_def[abs_def])
	done
	subgoal
	unfolding ode_na_def ode_d_na_def ode_d2_na_def
	apply (rule derivative_eq_intros)
	apply (rule derivative_intros)
	apply (rule derivative_intros)
	subgoal by (auto simp: ncc_def nonempty_def)
	subgoal by force
	done
	subgoal
	unfolding ode_na_def ode_d_na_def ode_d2_na_def
	apply (rule derivative_eq_intros)
	apply (rule derivative_intros)
	apply (rule derivative_intros)
	apply (rule derivative_intros)
	subgoal by (force simp: nonempty_def)
	apply (rule derivative_intros)
	subgoal by (auto intro!: aux3)
	done
	subgoal by (rule refl)
	subgoal by (rule refl)
	subgoal
	apply (rule compact_imp_bounded)
	apply (rule compact_continuous_image)
	subgoal
	by (auto intro!: continuous_intros simp: ode_na_def ode_d_na_def ode_d2_na_def)
	subgoal by (auto simp: ncc_def intro!: compact_Times)
	done
	subgoal by auto
	subgoal by simp
	subgoal by simp
	subgoal
	apply (rule convex_on_segmentI[where j=h])
	using mult_left_le_one_le[of h "rk2_param"]
	by (auto simp: ncc_def mult_left_le_one_le mult_le_one ac_simps ode_na_def
	ode_d_na_def ode_d2_na_def dest: bspec[where x=0])
	subgoal by (simp add: ncc_def)
	subgoal by (simp add: ncc_def compact_imp_closed)
	subgoal for s1 s2
	apply (clarsimp simp add: lv_ivl_sings)
	subgoal premises prems
	proof -
	have "s2 * rk2_param * h \<le> h"
	apply (rule mult_left_le_one_le)
	using assms prems
	by (auto intro!: mult_le_one)
	then have s2: "(s2 * h * rk2_param) \<in> {0 .. h}"
	using prems assms by (auto simp: ac_simps)
	have s1: "h * s1 \<in> {0 .. h}" using prems
	by (auto intro!: mult_right_le_one_le)
	then have
	"interpret_floatariths (rk2_fas' D)
	(list_of_eucl x0 @ list_of_eucl (flow0 x0 (h * s1)) @ [rk2_param, h, s2]) \<in> env"
	unfolding \<open>D = _\<close> using prems
	by (intro prems(17)[rule_format]) auto
	then have "take (2 * D) (interpret_floatariths (rk2_fas' D)
	(list_of_eucl x0 @ list_of_eucl (flow0 x0 (h * s1)) @ [rk2_param, h, s2])) \<in> take (2 * D) ` env"
	(is "?l \<in> _")
	by auto
	also have "?l = interpret_floatariths
	(map fold_const_fa (rk2_fas (Var (2 * D)) (map floatarith.Var [0..<D]) (Var (2 * D + 1))
	(map floatarith.Var [D..<2 * D])
	(Var (2 * D + 2))))
	(list_of_eucl x0 @ list_of_eucl (flow0 x0 (h * s1)) @ [rk2_param, h, s2])"
	(is "_ = interpret_floatariths (map fold_const_fa ?fas) ?xs")
	unfolding rk2_fas'_def
	by (auto intro!: max_Var_floatariths_rk2_fas max_Var_floatariths_fold_const_fa[le] simp: wdD[OF \<open>wd _\<close>])
	finally have "take D (interpret_floatariths ?fas ?xs) \<in> take D ` take (2 * D) ` env"
	by auto
	also have "\<dots> = take D ` env" by (auto simp: image_image wdD[OF \<open>wd _\<close>])
	finally have "eucl_of_list (take D (interpret_floatariths ?fas ?xs)) \<in> eucl_of_list ` take D ` env"
	by simp
	then have "einterpret (take D ?fas) ?xs \<in> eucl_of_list ` take D ` env"
	by (simp add: take_interpret_floatariths wdD[OF \<open>wd _\<close>])
	also have "einterpret (take D ?fas) ?xs =
	discrete_evolution (rk2_increment (rk2_param) (\<lambda>t x. ode_na (t, x))) h 0 x0 +
	heun_remainder1 (flow0 x0) ode_na ode_d_na ode_d2_na 0 h s1 -
	heun_remainder2 (rk2_param) (flow0 x0) ode_na ode_d2_na 0 h s2"
	apply (simp add: wdD[OF \<open>wd _\<close>])
	apply (subst rk2_increment_rk2_fas1[where ?s1'.0 = s1])
	subgoal by (auto simp: nth_append map_nth_append1)
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by (auto simp: nth_append map_nth_append1 \<open>x0 \<in> Csafe\<close>)
	subgoal
	apply (auto simp: nth_append map_nth_append1 \<open>x0 \<in> Csafe\<close>)
	by (meson connectedD_interval existence_ivl_zero flow0_defined hyps
	mult_right_le_one_le mult_sign_intros(1) mvar.connected prems)
	subgoal
	proof -
	have "x0 + ((rk2_param * s2) * h) *\<^sub>R ode x0 \<in> CX"
	by (rule convex_on_segmentI[where j=h])
	(use prems in \<open>auto simp: ncc_def mult_left_le_one_le mult_le_one
	dest: bspec[where x=0]\<close>)
	also note \<open>\<dots> \<subseteq> Csafe\<close>
	finally show ?thesis
	by (auto simp: nth_append map_nth_append1 \<open>x0 \<in> Csafe\<close> ac_simps)
	qed
	subgoal by (auto simp: nth_append map_nth_append1 ode_na_def)
	done
	finally show ?thesis by (simp add: \<open>D = _\<close>)
	qed
	done
	done
	also have "\<dots> \<subseteq> res" using hyps(6) by (simp add: \<open>D = _\<close>)
	finally show ?case by (simp add: \<open>D = _\<close>)
	qed

	lemma interpret_adapt_stepsize_fa:
	"interpret_floatarith (adapt_stepsize_fa rtol m_id e h') []
	= float_of h' * (float_of(rtol) / float_of e) powr (1 / (float_of (m_id) + 1))"
	by (auto simp: inverse_eq_divide adapt_stepsize_fa_def)

	lemma choose_step_flowpipe[le, refine_vcg]:
	assumes "wd TYPE('a::executable_euclidean_space)"
	shows "choose_step X0 h \<le> SPEC (\<lambda>(h', _, RES_ivl, (RES::'a set)). 0 < h' \<and> h' \<le> h \<and> flowpipe0 X0 h' h' RES_ivl RES)"
	using assms
	unfolding choose_step_def
	by (refine_vcg rk2_step_flowpipe euler_step_flowpipe)

	lemma CsafeI: "t \<in> existence_ivl0 x \<Longrightarrow> x \<in> Csafe"
	using local.mem_existence_ivl_iv_defined(2) by blast

	lemma apply_vareq: "blinfun_apply (vareq x t) = ode_d1 (flow0 x t)"
	by (auto simp: vareq_def)

	lemma Dflow_has_derivative:
	"t \<in> existence_ivl0 x \<Longrightarrow> (Dflow x has_derivative blinfun_scaleR_left (ode_d1 (flow0 x t) o\<^sub>L Dflow x t)) (at t)"
	by (auto simp: Dflow_def blinfun.bilinear_simps scaleR_blinfun_compose_left apply_vareq CsafeI
	intro!: derivative_eq_intros mvar.flow_has_derivative[THEN has_derivative_eq_rhs] ext
	blinfun_eqI)

	lemma matrix_scaleR: "matrix (blinfun_apply (h \<^sub>R X)) = h \<^sub>R matrix X"
	by (vector matrix_def blinfun.bilinear_simps)

	lemma blinfun_of_vmatrix_matrix_matrix_mult[simp]:
	"blinfun_of_vmatrix (A ** B) = blinfun_of_vmatrix A o\<^sub>L blinfun_of_vmatrix B"
	including blinfun.lifting
	by transfer (auto simp: o_def matrix_vector_mul_assoc)

	lemma blinfun_of_vmatrix_mat_1[simp]: "blinfun_of_vmatrix (mat 1) = 1\<^sub>L"
	including blinfun.lifting
	by transfer (auto simp: matrix_vector_mul_lid)

	lemma blinfun_of_vmatrix_matrix[simp]:
	"blinfun_of_vmatrix (matrix (blinfun_apply A)) = A"
	including blinfun.lifting
	by transfer (auto simp: bounded_linear.linear matrix_works)

	lemma inner_Basis_eq_vec_nth: "b \<in> Basis \<Longrightarrow> v \<bullet> b = vec_nth v (enum_class.enum ! index Basis_list b)"
	by (auto simp: inner_vec_def vec_nth_Basis if_distrib Basis_vec_def axis_eq_axis
	index_Basis_list_axis1
	cong: if_cong)

	lemma intersects_sctns_spec_nres[le, refine_vcg]:
	"intersects_sctns X' sctns \<le> intersects_sctns_spec X' sctns"
	unfolding intersects_sctns_spec_def intersects_sctns_def
	by refine_vcg auto

	lemma intersects_sections_spec_clw_ref[le, refine_vcg]:
	"intersects_sctns_spec_clw R sctns \<le> intersects_sctns_spec R sctns"
	unfolding intersects_sctns_spec_def intersects_sctns_spec_clw_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>S b. \<not>b \<longrightarrow> \<Union>S \<inter> \<Union>(plane_of ` sctns) = {}"]) auto

	lemma eq_nth_iff_index:
	"distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> i = xs ! n \<longleftrightarrow> index xs i = n"
	using index_nth_id by fastforce

	lemma
	max_Var_floatariths_ode_e_wd:
	assumes wd: "wd (TYPE('n::enum rvec))"
	assumes "CARD('n) \<le> K"
	shows "max_Var_floatariths ode_e \<le> K"
	using wdD[OF wd] assms by auto

	lemma nonzero_component[le, refine_vcg]: "nonzero_component s X n \<le> SPEC (\<lambda>_. \<forall>b\<in>X. b \<bullet> n \<noteq> 0)"
	unfolding nonzero_component_def
	by refine_vcg auto

	lemma
	interpret_slp_env_lenD:
	assumes "\<forall>cx\<in>CX. interpret_slp (slp_of_fas (fas)) (env cx) \<in> R"
	assumes "cx \<in> CX"
	shows "interpret_floatariths fas (env cx) \<in> take (length fas) ` R"
	proof -
	from slp_of_fas
	have "take (length fas) (interpret_slp (slp_of_fas fas) (env cx)) = interpret_floatariths fas (env cx)"
	by auto
	moreover
	from assms(1)[rule_format, OF \<open>cx \<in> CX\<close>]
	have "interpret_slp (slp_of_fas fas) (env cx) \<in> R" by auto
	ultimately show ?thesis by force
	qed

	lemma flowpipe0_imp_flowpipe:
	assumes "flowpipe0 (fst ` X0) x1 x1 aba bba"
	shows "flowpipe X0 x1 x1 (aba \<times> UNIV) (bba \<times> UNIV)"
	using assms
	by (auto simp: flowpipe0_def flowpipe_def)

	lemma disjoints_spec[le, refine_vcg]:
	"disjoints_spec X Y \<le> SPEC (\<lambda>b. b \<longrightarrow> (X \<inter> Y = {}))"
	unfolding disjoints_spec_def autoref_tag_defs
	by refine_vcg auto

	lemma inner_eq_zero_abs_BasisI:
	"\<bar>y\<bar> \<in> Basis \<Longrightarrow> b \<in> Basis \<Longrightarrow> \<bar>y\<bar> \<noteq> b \<Longrightarrow> y \<bullet> b = 0"
	for b y::"'a::executable_euclidean_space"
	by (metis abs_inner inner_Basis linorder_not_le order_refl zero_less_abs_iff)

	lemma abs_in_Basis_absE:
	fixes x y::"'a::executable_euclidean_space"
	assumes "abs y \<in> Basis"
	obtains "abs y = y" \| "abs y = -y"
	proof -
	have "abs y = (\<Sum>i\<in>Basis. (abs (y \<bullet> i)) *\<^sub>R i)"
	by (simp add: euclidean_representation abs_inner[symmetric] assms)
	also have "Basis = insert (abs y) (Basis - {abs y})" using assms by auto
	also have "(\<Sum>i\<in>insert \<bar>y\<bar> (Basis - {\<bar>y\<bar>}). \<bar>y \<bullet> i\<bar> \<^sub>R i) = \<bar>y \<bullet> \<bar>y\<bar>\<bar> \<^sub>R \<bar>y\<bar>"
	apply (subst sum.insert)
	using assms
	by (auto simp: abs_inner[symmetric] inner_Basis if_distribR if_distrib
	cong: if_cong)
	finally have "\<bar>y\<bar> = \<bar>y \<bullet> \<bar>y\<bar>\<bar> *\<^sub>R \<bar>y\<bar>" by simp
	moreover have "\<dots> = y \<or> \<dots> = - y"
	using assms
	by (auto simp: abs_real_def algebra_simps intro!: euclidean_eqI[where 'a='a]
	simp: inner_Basis inner_eq_zero_abs_BasisI split: if_splits)
	ultimately consider "\<bar>y\<bar> = y" \| "\<bar>y\<bar> = - y" by auto
	then show ?thesis
	by (cases; rule that)
	qed

	lemma abs_in_BasisE:
	fixes x y::"'a::executable_euclidean_space"
	assumes "abs y \<in> Basis"
	obtains i where "i \<in> Basis" "y = i" \| i where "i \<in> Basis" "y = -i"
	proof -
	from abs_in_Basis_absE[OF assms]
	consider "\<bar>y\<bar> = y" \| "\<bar>y\<bar> = - y"
	by auto
	then show ?thesis
	proof cases
	case 1 with assms have "abs y \<in> Basis" "y = abs y" by auto
	then show ?thesis ..
	next
	case 2
	with assms have "abs y \<in> Basis" "y = - abs y" by auto
	then show ?thesis ..
	qed
	qed

	lemma subset_spec_plane[le, refine_vcg]:
	"subset_spec_plane X sctn \<le> SPEC (\<lambda>b. b \<longrightarrow> X \<subseteq> plane_of sctn)"
	unfolding subset_spec_plane_def
	by (refine_vcg) (auto simp: plane_of_def eucl_le[where 'a='a] dest!: bspec elim!: abs_in_BasisE)

	lemma subset_spec_coll_refine[le, refine_vcg]: "subset_spec_coll X Y \<le> subset_spec X Y"
	unfolding subset_spec_coll_def autoref_tag_defs subset_spec_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X b. b \<longrightarrow> \<Union>X \<subseteq> Y"]) auto

	lemma
	eventually_in_planerectI:
	fixes n::"'a::executable_euclidean_space"
	assumes "abs n \<in> Basis"
	assumes "{l .. u} \<subseteq> plane n c" "l \<le> u"
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> i \<noteq> abs n \<Longrightarrow> l \<bullet> i < x \<bullet> i"
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> i \<noteq> abs n \<Longrightarrow> x \<bullet> i < u \<bullet> i"
	shows "\<forall>\<^sub>F x in at x within plane n c. x \<in> {l .. u}"
	proof -
	have "\<forall>\<^sub>F x in at x within plane n c. x \<in> plane n c"
	unfolding eventually_at_filter
	by simp
	then have "\<forall>\<^sub>F x in at x within plane n c. l \<bullet> abs n \<le> x \<bullet> abs n \<and> x \<bullet> abs n \<le> u \<bullet> abs n"
	apply eventually_elim
	using assms(1,2,3)
	by (auto simp: elim!: abs_in_BasisE)
	moreover
	{
	fix i assume that: "i \<in> Basis" "i \<noteq> abs n"
	have "\<forall>\<^sub>F x in at x within plane n c. l \<bullet> i < x \<bullet> i" "\<forall>\<^sub>F x in at x within plane n c. x \<bullet> i < u \<bullet> i"
	by (auto intro!: order_tendstoD assms tendsto_eq_intros that)
	then have "\<forall>\<^sub>F x in at x within plane n c. l \<bullet> i < x \<bullet> i \<and> x \<bullet> i < u \<bullet> i"
	by eventually_elim auto
	} then have "\<forall>\<^sub>F x in at x within plane n c. \<forall>i \<in> Basis - {abs n}. l \<bullet> i < x \<bullet> i \<and> x \<bullet> i < u \<bullet> i"
	by (auto intro!: eventually_ball_finite)
	then have "\<forall>\<^sub>F x in at x within plane n c. \<forall>i \<in> Basis - {abs n}. l \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> u \<bullet> i"
	by eventually_elim (auto intro!: less_imp_le)
	ultimately
	have "\<forall>\<^sub>F x in at x within plane n c. \<forall>i\<in>Basis. l \<bullet> i \<le> x \<bullet> i \<and> x \<bullet> i \<le> u \<bullet> i"
	by eventually_elim auto
	then show ?thesis
	by eventually_elim (auto simp: eucl_le[where 'a='a])
	qed

	lemma mem_ivl_euclI: "k \<in> {c..d::'x::ordered_euclidean_space}" if "\<And>i. i \<in> Basis \<Longrightarrow> c \<bullet> i \<le> k \<bullet> i" "\<And>i. i \<in> Basis \<Longrightarrow> k \<bullet> i \<le> d \<bullet> i"
	using that
	by (auto simp: eucl_le[where 'a='x])

	lemma op_eventually_within_sctn[le, refine_vcg]:
	"op_eventually_within_sctn X sctn S \<le>
	SPEC (\<lambda>b. b \<longrightarrow> (\<forall>x \<in> X. x \<in> S \<and> (\<forall>\<^sub>F x in at x within plane_of sctn. x \<in> S)))"
	unfolding op_eventually_within_sctn_def
	apply refine_vcg
	unfolding plane_of_def autoref_tag_defs
	apply (safe intro!: eventually_in_planerectI mem_ivl_euclI)
	subgoal premises prems for a b c d e f g h i j k B
	proof cases
	assume "B = \<bar>normal sctn\<bar>"
	moreover
	have "c \<in> plane (normal sctn) (pstn sctn)" "k \<in> plane (normal sctn) (pstn sctn)"
	using prems by auto
	ultimately show "c \<bullet> B \<le> k \<bullet> B" using \<open>\<bar>normal sctn\<bar> \<in> set Basis_list\<close>
	by (auto simp: elim!: abs_in_Basis_absE)
	next
	assume B: "B \<noteq> \<bar>normal sctn\<bar>"
	have "k \<bullet> B \<in> {g \<bullet> B .. h \<bullet> B}"
	using \<open>k \<in> X\<close> \<open>X \<subseteq> {g..h}\<close> \<open>B \<in> Basis\<close> by (auto simp: eucl_le[where 'a='a])
	with B prems show ?thesis by (auto dest!: bspec elim!: abs_in_Basis_absE)
	qed
	subgoal premises prems for a b c d e f g h i j k B
	proof cases
	assume "B = \<bar>normal sctn\<bar>"
	moreover
	have "d \<in> plane (normal sctn) (pstn sctn)" "k \<in> plane (normal sctn) (pstn sctn)"
	using prems by auto
	ultimately show "d \<bullet> B \<ge> k \<bullet> B" using \<open>\<bar>normal sctn\<bar> \<in> set Basis_list\<close>
	by (auto simp: elim!: abs_in_Basis_absE)
	qed (use prems in \<open>auto elim!: abs_in_BasisE simp: eucl_le[where 'a='a] dest!: bspec subsetD\<close>)
	subgoal by simp
	subgoal using [[simproc del: defined_all]] by (auto elim!: abs_in_BasisE simp: eucl_le[where 'a='a] dest!: bspec subsetD cong del: image_cong_simp)
	subgoal using [[simproc del: defined_all]] by (auto elim!: abs_in_BasisE simp: eucl_le[where 'a='a] dest!: bspec subsetD cong del: image_cong_simp)
	done

	lemma Let_unit: "Let (x::unit) f = f ()"
	by auto
	lemma CHECK_no_text: "CHECKs (x#ys) a = CHECKs [] a"
	by auto

	lemma frontier_above_halfspace:
	"normal sctn \<noteq> 0 \<Longrightarrow> frontier (above_halfspace sctn) = plane_of sctn"
	using frontier_halfspace_ge[of "normal sctn" "pstn sctn"]
	by (auto simp: halfspace_simps plane_of_def inner_commute)

	lemma
	flowpipe_subset:
	assumes "flowpipe X0 hl hu CX X1"
	and subs: "Y0 \<subseteq> X0" "hl \<le> il" "il \<le> iu" "iu \<le> hu" "CX \<subseteq> CY" "X1 \<subseteq> Y1"
	and safe: "fst ` CY \<union> fst ` Y1 \<subseteq> Csafe"
	shows "flowpipe Y0 il iu CY Y1"
	proof -
	from assms(1) have fp: "0 \<le> hl" "hl \<le> hu" "fst ` X0 \<subseteq> Csafe" "fst ` CX \<subseteq> Csafe" "fst ` X1 \<subseteq> Csafe"
	"\<forall>(x0, d0)\<in>X0. \<forall>h\<in>{hl..hu}. h \<in> existence_ivl0 x0 \<and> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> X1 \<and> (\<forall>h'\<in>{0..h}. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX)"
	by (auto simp: flowpipe_def)
	then show ?thesis
	unfolding flowpipe_def
	apply safe
	subgoal using subs by auto
	subgoal using subs by auto
	subgoal using subs by fastforce
	subgoal using safe by auto
	subgoal using safe by auto
	subgoal using subs by fastforce
	subgoal using subs fp by fastforce
	subgoal for x0 d0 h h'
	using subs fp
	apply -
	apply (rule subsetD, assumption)
	apply (drule bspec)
	apply (rule subsetD; assumption)
	apply safe
	apply (drule bspec[where x=h], force)
	apply auto
	done
	done
	qed

	lemma poincare_mapsto_unionI:
	assumes "poincare_mapsto P r U t d"
	assumes "poincare_mapsto P s U u e"
	shows "poincare_mapsto P (r \<union> s) U (t \<union> u) (d \<union> e)"
	using assms
	apply (auto simp: poincare_mapsto_def)
	subgoal
	apply (drule bspec, assumption)
	by auto
	subgoal by fastforce
	done

	lemma sabove_not_le_halfspace:
	"x \<in> sabove_halfspace sctn \<longleftrightarrow> \<not> le_halfspace sctn x"
	by (auto simp: sabove_halfspace_def le_halfspace_def gt_halfspace_def)

	lemma (in c1_on_open_euclidean) flowsto_self:\<comment> \<open>TODO: move!\<close>
	"0 \<in> T \<Longrightarrow> X0 \<subseteq> Z \<Longrightarrow> fst ` X0 \<subseteq> X \<Longrightarrow> flowsto X0 T Y Z"
	by (force simp: flowsto_def intro!: bexI[where x=0])

	lemma (in c1_on_open_euclidean) flowpipe_imp_flowsto:\<comment> \<open>TODO: move!\<close>
	assumes "flowpipe X0 hl hu CX Y" "hl > 0"
	shows "flowsto X0 {0<..hl} CX Y"
	using assms
	by (fastforce simp: flowsto_def flowpipe_def open_segment_eq_real_ivl
	dest: bspec[where x=hl]
	intro!: bexI[where x=hl])

	lemma flowsto_source_unionI:
	"flowsto X0 T A B \<Longrightarrow> flowsto Z T A B \<Longrightarrow> flowsto (X0 \<union> Z) T A B"
	by (fastforce simp: flowsto_def dest: bspec)

	lemma poincare_mapsto_subset:
	"poincare_mapsto P X0 U CX1 X1 \<Longrightarrow> X0' \<subseteq> X0 \<Longrightarrow> X1 \<subseteq> X2 \<Longrightarrow> CX1 \<subseteq> CX2 \<Longrightarrow> fst ` X2 \<subseteq> Csafe
	\<Longrightarrow> poincare_mapsto P X0' U CX2 X2"
	by (force simp: poincare_mapsto_def)

	lemma PDP_abs_lemma:
	fixes n::"'a::executable_euclidean_space"
	assumes "abs n \<in> Basis"
	shows
	"(x, d - (blinfun_scaleR_left (f (x)) o\<^sub>L (blinfun_scaleR_left (inverse (f x \<bullet> n)) o\<^sub>L (blinfun_inner_left n o\<^sub>L d)))) =
	(x, d - (blinfun_scaleR_left (f (x)) o\<^sub>L (blinfun_scaleR_left (inverse (f x \<bullet> (abs n))) o\<^sub>L (blinfun_inner_left (abs n) o\<^sub>L d))))"
	proof -
	consider "n \<in> Basis" \| "- n \<in> Basis"
	using abs_in_Basis_absE[OF assms] assms by metis
	then show ?thesis
	proof cases
	case 1
	then show ?thesis by simp
	next
	case 2
	define i where "i = -n"
	with 2 have "i \<in> Basis" "n = -i"
	- by (auto simp: )
	+ by auto
	then show ?thesis
	by (auto simp: inverse_eq_divide intro!: blinfun_eqI blinfun.bilinear_simps euclidean_eqI[where 'a='a])
	qed
	qed

	lemma abs_in_BasisI:
	"\<bar>n\<bar> \<in> Basis" if n: "n \<in> Basis \<or> - n \<in> Basis" for n::"'a::executable_euclidean_space"
	proof -
	consider "n \<in> Basis" \| "- n \<in> Basis"
	using n by auto
	then show ?thesis
	proof cases
	case 1
	then show ?thesis by simp
	next
	case 2
	define i where "i = -n"
	with 2 have "i \<in> Basis" "n = -i"
	- by (auto simp: )
	+ by auto
	then show ?thesis
	by (auto simp: inverse_eq_divide intro!: blinfun_eqI blinfun.bilinear_simps euclidean_eqI[where 'a='a])
	qed
	qed

	lemma flowsto_poincareD:
	assumes f: "flowsto X0 T CX X1"
	assumes X1: "fst ` X1 \<subseteq> P"
	assumes P: "(P \<times> UNIV) \<inter> CX = {}" "closed P"
	assumes pos: "\<And>t. t \<in> T \<Longrightarrow> t > 0"
	assumes x0: "x0 \<in> fst ` X0"
	assumes "fst ` X1 \<subseteq> K"
	shows returns_to_flowstoI: "returns_to P x0"
	and poincare_map_mem_flowstoI: "poincare_map P x0 \<in> K"
	proof -
	from x0 obtain d where x0d: "(x0, d) \<in> X0" by auto
	from flowstoE[OF f x0d] obtain h
	where h:
	"h \<in> T"
	"h \<in> existence_ivl0 x0"
	"(flow0 x0 h, Dflow x0 h o\<^sub>L d) \<in> X1"
	and CX: "\<And>h'. h' \<in> {0<--<h} \<Longrightarrow> (flow0 x0 h', Dflow x0 h' o\<^sub>L d) \<in> CX"
	by auto
	have "h > 0" by (auto intro!: pos h)
	have "flow0 x0 h \<in> P" using X1 h by auto
	have "\<forall>\<^sub>F t in at_right 0. t \<in> {0<..<h}"
	using order_tendstoD(2)[OF tendsto_ident_at \<open>0 < h\<close>, of "{0<..}"]
	by (auto simp: eventually_at_filter)
	then have "\<forall>\<^sub>F t in at_right 0. flow0 x0 t \<in> fst ` CX"
	by eventually_elim (use CX \<open>0 < h\<close> open_segment_eq_real_ivl in auto)
	then have evnP: "\<forall>\<^sub>F t in at_right 0. flow0 x0 t \<notin> P"
	by eventually_elim (use P in force)
	from \<open>h > 0\<close> h(2) \<open>flow0 x0 h \<in> P\<close> evnP P(2) show "returns_to P x0"
	by (rule returns_toI)
	have nin_P: "0 < s \<Longrightarrow> s < h \<Longrightarrow> flow0 x0 s \<notin> P" for s
	using CX[of s] P by (auto simp: open_segment_eq_real_ivl)
	have "return_time P x0 = h"
	using h X1
	by (auto intro!: return_time_eqI \<open>0 < h\<close> h assms simp: nin_P)
	then have "poincare_map P x0 = flow0 x0 h" by (auto simp: poincare_map_def)
	also have "\<dots> \<in> fst ` X1" using h by auto
	also note \<open>_ \<subseteq> K\<close>
	finally show "poincare_map P x0 \<in> K" .
	qed

	lemma
	inner_abs_Basis_eq_zero_iff:
	"abs n \<in> Basis \<Longrightarrow> x \<bullet> \<bar>n\<bar> = 0 \<longleftrightarrow> x \<bullet> n = 0" for n::"'a::executable_euclidean_space"
	by (auto simp: elim!: abs_in_BasisE)

	lemmas [simp] = sbelow_halfspaces_insert

	lemma Int_Un_eq_emptyI: "a \<inter> (b \<union> c) = {}" if "a \<inter> b = {}" "a \<inter> c = {}"
	using that by auto

	lemma cancel_times_UNIV_subset: "A \<times> UNIV \<subseteq> B \<times> UNIV \<longleftrightarrow> A \<subseteq> B"
	by auto

	lemma split_spec_coll_spec[le,refine_vcg]:
	"split_spec_coll X \<le> SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
	unfolding split_spec_coll_def
	by (refine_vcg)

	lemma Un_snd_sing_Pair_eq:
	"(e, f) \<in> a \<Longrightarrow> f \<union> (\<Union>x\<in>a - {(e, f)}. snd x) = (\<Union>x\<in>a. snd x)"
	by force

	lemma let_unit: "Let X y = y ()" by simp

	lemma (in c1_on_open_euclidean) flowpipe_imp_flowsto_nonneg:\<comment> \<open>TODO: move!\<close>
	assumes "flowpipe X0 hl hu CX Y"
	shows "flowsto X0 {0..} CX Y"
	using assms
	by (fastforce simp: flowsto_def flowpipe_def open_segment_eq_real_ivl
	dest: bspec[where x=hl]
	intro!: bexI[where x=hl])

	lemma subset_DiffI: "A \<subseteq> B \<Longrightarrow> A \<inter> C = {} \<Longrightarrow> A \<subseteq> B - C"
	by auto

	lemma flowsto_source_Union: "flowsto (\<Union>x\<in>R. X0 x) T CX X1"
	if "\<And>x. x \<in> R \<Longrightarrow> flowsto (X0 x) T CX X1"
	using that
	by (auto simp: flowsto_def)

	lemma times_subset_iff: "A \<times> B \<subseteq> C \<times> E \<longleftrightarrow> A = {} \<or> B = {} \<or> A \<subseteq> C \<and> B \<subseteq> E"
	by auto

	lemma
	flowsto_UnionE:
	assumes "finite Gs"
	assumes "flowsto X T CX (\<Union>Gs)"
	obtains XGs where "\<And>X G. (X, G) \<in> XGs \<Longrightarrow> flowsto X T CX G" "Gs = snd ` XGs" "X = \<Union>(fst ` XGs)"
	apply atomize_elim
	using assms
	proof (induction arbitrary: X)
	case empty
	then show ?case by auto
	next
	case (insert x F)
	from insert.prems obtain X1 X2 where X: "X = X1 \<union> X2" and X1: "flowsto X1 T CX x" and X2: "flowsto X2 T CX (\<Union>F)"
	by (auto elim!: flowsto_unionE)
	from insert.IH[OF X2] obtain XGs where XGs:
	"\<And>X G. (X, G) \<in> XGs \<Longrightarrow> flowsto X T CX G" "F = snd ` XGs" "X2 = (\<Union>a\<in>XGs. fst a)"
	by auto
	then show ?case
	using X X1 X2
	by (intro exI[where x="insert (X1, x) XGs"]) auto
	qed

	lemma flowsto_Union_funE:
	assumes "finite Gs"
	assumes "flowsto X T CX (\<Union>Gs)"
	obtains f where "\<And>G. G \<in> Gs \<Longrightarrow> flowsto (f G) T CX G" "X = \<Union>(f ` Gs)"
	apply atomize_elim
	using assms
	proof (induction arbitrary: X)
	case empty
	then show ?case by auto
	next
	case (insert x F)
	from insert.prems obtain X1 X2 where X: "X = X1 \<union> X2" and X1: "flowsto X1 T CX x" and X2: "flowsto X2 T CX (\<Union>F)"
	by (auto elim!: flowsto_unionE)
	from insert.IH[OF X2] obtain f where f:
	"\<And>G. G \<in> F \<Longrightarrow> flowsto (f G) T CX G" "X2 = (\<Union>a\<in>F. f a)"
	by auto
	then show ?case
	using X X1 X2 insert.hyps
	by (intro exI[where x="f (x:=X1)"]) (auto split: if_splits)
	qed

	lemma flowsto_Union_Un_funE:
	assumes "flowsto X T CX (\<Union>Gs \<union> trap)"
	assumes "finite Gs" "Gs \<noteq> {}"
	obtains f where "\<And>G. G \<in> Gs \<Longrightarrow> flowsto (f G) T CX (G \<union> trap)" "X = \<Union>(f ` Gs)"
	proof -
	from assms have "flowsto X T CX (\<Union>g \<in> Gs. g \<union> trap)" by auto
	from flowsto_Union_funE[OF finite_imageI[OF \<open>finite Gs\<close>] this]
	obtain f where f: "\<And>G. G \<in> (\<lambda>g. g \<union> trap) ` Gs \<Longrightarrow> flowsto (f G) T CX G"
	"X = \<Union> (f ` ((\<lambda>g. g \<union> trap) ` Gs))"
	by auto
	define f' where "f' g = f (g \<union> trap)" for g
	have "G \<in> Gs \<Longrightarrow> flowsto (f' G) T CX (G \<union> trap)" for G
	using f(1)[of "G \<union> trap"]
	by (auto simp: f'_def)
	moreover
	have "X = \<Union>(f' ` Gs)"
	using f by (auto simp: f'_def)
	ultimately show ?thesis ..
	qed

	lemma flowsto_Diff_to_Union_funE:
	assumes "flowsto (X - trap) T CX (\<Union>Gs)"
	assumes "finite Gs"
	obtains f where "\<And>G. G \<in> Gs \<Longrightarrow> flowsto (f G - trap) T CX G" "Gs \<noteq> {} \<Longrightarrow> X = \<Union>(f ` Gs)"
	apply atomize_elim
	using assms(2,1)
	proof (induction arbitrary: X)
	case empty then show ?case by simp
	next
	case (insert x F)
	from insert.prems obtain X1 X2 where X: "X - trap = X1 \<union> X2" and X1: "flowsto (X1) T CX x" and X2: "flowsto X2 T CX (\<Union>F)"
	by (auto elim!: flowsto_unionE)
	then have "X1 = X1 - trap" "X2 = X2 - trap" by auto
	then have X1': "flowsto (X1 - trap) T CX x" and X2': "flowsto (X2 - trap) T CX (\<Union>F)"
	using X1 X2 by auto
	from insert.IH[OF X2'] obtain f where f: "\<And>G. G \<in> F \<Longrightarrow> flowsto (f G - trap) T CX G" "F \<noteq> {} \<Longrightarrow> X2 = (\<Union>a\<in>F. f a)"
	by auto
	show ?case
	apply (cases "F = {}")
	subgoal using f X X1 X2 X1' X2' insert.hyps insert.prems by auto
	subgoal
	apply (rule exI[where x="f (x:=X1 \<union> (trap \<inter> X))"])
	apply auto
	subgoal
	using X1
	by (rule flowsto_subset) auto
	subgoal using X X1 X2 insert.hyps by auto
	subgoal using f X X1 X2 insert.hyps by auto
	subgoal using f X X1 X2 insert.hyps by auto
	subgoal using f X X1 X2 X1' X2' insert.hyps insert.prems by auto
	subgoal using f X X1 X2 X1' X2' insert.hyps insert.prems insert by auto
	subgoal using f X X1 X2 insert.hyps by (auto split: if_splits)
	done
	done
	qed

	lemma refine_case_list[refine_vcg]:
	assumes "xs = [] \<Longrightarrow> f \<le> SPEC P"
	assumes "\<And>y ys. xs = y # ys \<Longrightarrow> g y ys \<le> SPEC P"
	shows "(case xs of [] \<Rightarrow> f \| (x#xs) \<Rightarrow> g x xs) \<le> SPEC P"
	using assms
	by (auto split: list.splits)

	lemma flowsto_stays_sbelow:
	assumes "flowsto X0 {0<..} CXS X1"
	assumes "fst ` X0 \<subseteq> below_halfspace sctn"
	assumes "\<And>x d. (x, d) \<in> CXS \<Longrightarrow> ode x \<bullet> normal sctn < 0"
	shows "flowsto X0 {0<..} (CXS \<inter> sbelow_halfspace sctn \<times> UNIV) X1"
	unfolding flowsto_def
	proof safe
	fix x d assume "(x, d) \<in> X0"
	with assms obtain t where
	"t>0" "t \<in> existence_ivl0 x" "(\<forall>s\<in>{0<..<t}. (flow0 x s, Dflow x s o\<^sub>L d) \<in> CXS)"
	"(flow0 x t, Dflow x t o\<^sub>L d) \<in> X1"
	by (auto simp: flowsto_def subset_iff open_segment_eq_real_ivl)
	moreover
	have "\<forall>s\<in>{0<..<t}. flow0 x s \<in> sbelow_halfspace sctn"
	proof (rule ccontr, clarsimp)
	fix s assume s: "flow0 x s \<notin> sbelow_halfspace sctn" "0 < s" "s < t"
	let ?f = "\<lambda>t. flow0 x t \<bullet> normal sctn - pstn sctn"
	let ?f' = "\<lambda>t dx. dx * (ode (flow0 x t) \<bullet> normal sctn)"
	have "\<exists>xa\<in>{0<..<s}. ?f s - ?f 0 = ?f' xa (s - 0)"
	by (rule mvt[OF \<open>0 < s\<close>, of ?f ?f'])
	(use ivl_subset_existence_ivl[OF \<open>t \<in> existence_ivl0 x\<close>] \<open>0 < s\<close> \<open>s < t\<close> in
	\<open>auto intro!: continuous_intros derivative_eq_intros flow_has_derivative
	simp: flowderiv_def blinfun.bilinear_simps\<close>)
	then obtain s' where "?f s - ?f 0 = ?f' s' (s - 0)" "0 < s'" "s' < s"
	by (auto simp: algebra_simps)
	note this(1)
	also
	have "(flow0 x s', Dflow x s' o\<^sub>L d )\<in> CXS"
	using \<open>0 < s'\<close> \<open>\<forall>s\<in>{0<..<t}. _ \<in> CXS\<close> \<open>s < t\<close> \<open>s' < s\<close> by auto
	then have "?f' s' (s - 0) < 0"
	using assms \<open>(x, d) \<in> X0\<close> \<open>0 < s\<close>
	by (auto simp: flowsto_def halfspace_simps algebra_simps subset_iff intro!: mult_pos_neg)
	finally have 1: "?f s < ?f 0"
	by simp
	also have "?f 0 \<le> 0"
	using \<open>(x, d) \<in> X0\<close> assms mem_existence_ivl_iv_defined[OF \<open>t \<in> existence_ivl0 _\<close>]
	by (auto simp: halfspace_simps subset_iff)
	finally have "?f s < 0" .
	moreover from s have "0 \<le> ?f s"
	by (auto simp: halfspace_simps not_less)
	ultimately show False by simp
	qed
	ultimately
	show "\<exists>t\<in>{0<..}. t \<in> existence_ivl0 x \<and> (flow0 x t, Dflow x t o\<^sub>L d) \<in> X1 \<and>
	(\<forall>s\<in>{0<--<t}. (flow0 x s, Dflow x s o\<^sub>L d) \<in> CXS \<inter> sbelow_halfspace sctn \<times> UNIV)"
	by (auto intro!: simp: open_segment_eq_real_ivl)
	qed

	lemma poincare_mapsto_Union: "poincare_mapsto P (\<Union>xa) S CXS PS"
	if "\<And>x. x \<in> xa \<Longrightarrow> poincare_mapsto P x S CXS PS"
	by (force simp: poincare_mapsto_def dest!: that)

	lemma diff_subset: "(\<Union>x\<in>xa. f x) - (\<Union>x\<in>xa. g x) \<subseteq> (\<Union>x\<in>xa. f x - g x)"
	by auto

	lemma poincare_mapsto_imp_flowsto:
	assumes "poincare_mapsto P X0 S CX X1"
	assumes "closed P"
	shows "flowsto X0 {0<..} (CX \<times> UNIV) (fst ` X1 \<times> UNIV)"
	unfolding flowsto_def
	proof safe
	fix x0 d0 assume "(x0, d0) \<in> X0"
	with assms obtain D where D:
	"returns_to P x0"
	"fst ` X0 \<subseteq> S"
	"return_time P differentiable at x0 within S"
	"(poincare_map P has_derivative blinfun_apply D) (at x0 within S)"
	"(flow0 x0 (return_time P x0), D o\<^sub>L d0) \<in> X1"
	"\<And>t. 0 < t \<Longrightarrow> t < return_time P x0 \<Longrightarrow> flow0 x0 t \<in> CX"
	by (auto simp: poincare_mapsto_def poincare_map_def)
	show "\<exists>h\<in>{0<..}.
	h \<in> existence_ivl0 x0 \<and> (flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> fst ` X1 \<times> UNIV \<and>
	(\<forall>h'\<in>{0<--<h}. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX \<times> UNIV)"
	by (auto intro!: bexI[where x="return_time P x0"] return_time_exivl D assms return_time_pos
	simp: open_segment_eq_real_ivl)
	qed

	lemma flowsto_poincare_mapsto_trans_flowsto:
	assumes "flowsto X0 T CX X1'"
	assumes "poincare_mapsto P X1 S CY X2"
	assumes "closed P"
	assumes "fst ` X1' \<subseteq> fst ` X1"
	assumes "X1' \<union> CX \<union> CY \<times> UNIV \<subseteq> CZ"
	assumes "\<And>t. t \<in> T \<Longrightarrow> t \<ge> 0"
	shows "flowsto X0 {0<..} CZ (fst ` X2 \<times> UNIV)"
	proof -
	have X1D: "(a, b) \<in> X1' \<Longrightarrow> \<exists>c. (a, c) \<in> X1" for a b using assms(4) by force
	from poincare_mapsto_imp_flowsto[OF assms(2,3)]
	have "flowsto X1 {0<..} (CY \<times> UNIV) (fst ` X2 \<times> UNIV)" .
	then have "flowsto X1' {0<..} (CY \<times> UNIV) (fst ` X2 \<times> UNIV)"
	by (auto simp: flowsto_def dest!: X1D)
	from flowsto_trans[OF assms(1) this]
	show ?thesis
	apply (rule flowsto_subset)
	using assms
	by (auto intro!: add_nonneg_pos)
	qed

	lemma eq_blinfun_inner_left[intro]:
	"(\<lambda>x. x \<bullet> n) = blinfun_apply (blinfun_inner_left n)"
	by force

	lemma flowsto_union_DiffE:
	assumes "flowsto X0 T CX (Y \<union> Z)"
	obtains X1 where "X1 \<subseteq> X0" "flowsto X1 T CX Y" "flowsto (X0 - X1) T CX Z"
	proof -
	let ?X1 = "{x\<in>X0. flowsto {x} T CX Y}"
	from assms have "?X1 \<subseteq> X0" "flowsto ?X1 T CX Y" "flowsto (X0 - ?X1) T CX Z"
	by (auto simp: flowsto_def)
	thus ?thesis ..
	qed

	lemma eucl_less_le_trans:
	fixes a b::"'a::executable_euclidean_space"
	shows "eucl_less a b \<Longrightarrow> b \<le> c \<Longrightarrow> eucl_less a c"
	by (force simp: eucl_less_def[where 'a='a] eucl_le[where 'a='a])

	lemma le_eucl_less_trans:
	fixes a b::"'a::executable_euclidean_space"
	shows "a \<le> b \<Longrightarrow> eucl_less b c \<Longrightarrow> eucl_less a c"
	by (force simp: eucl_less_def[where 'a='a] eucl_le[where 'a='a])

	lemma flowsto_source_UnionI:
	assumes "\<And>i. i \<in> I \<Longrightarrow> flowsto i T CXS (f i)"
	shows "flowsto (\<Union>I) T CXS (\<Union>(f ` I))"
	apply (auto simp: flowsto_def)
	subgoal premises prems for y a b
	using assms[unfolded flowsto_def, OF \<open>y \<in> I\<close>, rule_format, OF \<open>_ \<in> y\<close>] prems
	by auto
	done

	lemma poincare_mapsto_UnionI:
	assumes pm[unfolded poincare_mapsto_def, rule_format]: "\<And>i. i \<in> I \<Longrightarrow> poincare_mapsto p (X0 i) S (CX i) (X1 i)"
	assumes R: "\<And>i x. i \<in> I \<Longrightarrow> x \<in> X1 i \<Longrightarrow> x \<in> R"
	shows "poincare_mapsto p (\<Union>x\<in>I. X0 x) S ((\<Union>x\<in>I. CX x)) R"
	unfolding poincare_mapsto_def
	proof (safe del: conjI, goal_cases)
	case (1 x0 d0 i)
	moreover
	have "fst ` \<Union>(X0 ` I) \<subseteq> S"
	proof (safe, goal_cases)
	case (1 _ x0 d0 i)
	from this pm[OF 1]
	show ?case by auto
	qed
	ultimately show ?case using pm[OF 1]
	by (auto intro!: R)
	qed

	lemma tendsto_at_top_translateI:
	assumes "(f \<longlongrightarrow> l) (at_top::real filter)"
	shows "((\<lambda>x. f (x + t)::'a::topological_space) \<longlongrightarrow> l) at_top"
	proof (rule topological_tendstoI)
	fix S::"'a set" assume "open S" "l \<in> S"
	from topological_tendstoD[OF assms this]
	obtain N where "\<And>n. n \<ge> N \<Longrightarrow> f n \<in> S" by (auto simp: eventually_at_top_linorder)
	then have "\<And>n. n \<ge> N - t \<Longrightarrow> f (n + t) \<in> S" by auto
	then show "\<forall>\<^sub>F x in at_top. f (x + t) \<in> S"
	unfolding eventually_at_top_linorder
	by blast
	qed

	lemma tendsto_at_top_translate_iff:
	"((\<lambda>x. f (x + t)::'a::topological_space) \<longlongrightarrow> l) at_top \<longleftrightarrow> (f \<longlongrightarrow> l) (at_top::real filter)"
	using tendsto_at_top_translateI[of f l t]
	tendsto_at_top_translateI[of "\<lambda>x. f (x + t)" l "- t"]
	by auto

	lemma stable_on_mono:
	"stable_on A B" if "stable_on C B" "A \<subseteq> C"
	using that
	unfolding stable_on_def
	by fastforce

	lemma
	flowsto_mapsto_avoid_trap:
	assumes "flowsto (X0 - trap \<times> UNIV) {0<..} CX P"
	assumes trapprop: "stable_on (fst ` (CX \<union> P)) trap"
	shows "flowsto (X0 - trap \<times> UNIV) {0<..} CX (P - trap \<times> UNIV)"
	unfolding flowsto_def
	proof (rule, goal_cases)
	case (1 xd)
	from assms(1)[unfolded flowsto_def, rule_format, OF this] obtain h x0 d0 where
	"xd = (x0, d0)" "0 < h"
	"h \<in> existence_ivl0 (x0)"
	"(flow0 x0 h, Dflow x0 h o\<^sub>L d0) \<in> P"
	"(\<forall>h'\<in>{0<--<h}. (flow0 x0 h', Dflow x0 h' o\<^sub>L d0) \<in> CX)"
	by auto
	then show ?case
	using 1 trapprop
	apply (auto intro!: bexI[where x=h] dest!: stable_onD simp: open_segment_eq_real_ivl image_Un)
	subgoal for s by (cases "s = h") auto
	done
	qed

	end

	lemma map_prod_def': "map_prod f g x = (f (fst x), g (snd x))"
	by (cases x) auto

	lemmas rel_prod_br = br_rel_prod

	lemmas lvivl_relI = lv_relivl_relI

	end
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Reachability_Analysis_C1.thy
	@@ -1,2892 +1,2892 @@
	theory Refine_Reachability_Analysis_C1
	imports
	Abstract_Reachability_Analysis_C1
	Refine_Reachability_Analysis
	begin

	lemma fst_flow1_of_vec1[simp]: "fst (flow1_of_vec1 x) = fst x"
	by (auto simp: flow1_of_vec1_def)

	lemma fst_vec1_of_flow[simp]: "fst (vec1_of_flow1 x) = fst x"
	by (auto simp: vec1_of_flow1_def)

	context approximate_sets_ode'
	begin

	lemma poincare_mapsto_scaleR2I:
	"poincare_mapsto P (scaleR2 x1 x2 baa) UNIV x1b (scaleR2 x1 x2 aca)"
	if "poincare_mapsto P (baa) UNIV x1b (aca)"
	using that
	apply (auto simp: poincare_mapsto_def scaleR2_def image_def vimage_def)
	apply (drule bspec, assumption)
	apply auto
	apply (rule exI, rule conjI, assumption)
	apply (rule exI, rule conjI, assumption, rule conjI, assumption)
	apply (rule bexI) prefer 2 apply assumption
	apply (auto simp: scaleR_blinfun_compose_right)
	done

	context includes ode_ops.lifting begin
	lemma var_safe_form_eq[simp]: "var.safe_form = safe_form"
	unfolding var.safe_form_def
	by transfer (auto simp: var_ode_ops_def safe_form_def)

	lemma var_ode_e: "var.ode_e = ode_e'"
	unfolding var.ode_e_def
	by transfer (auto simp: var_ode_ops_def)
	end

	lemma wd_imp_var_wd[refine_vcg, intro]: "wd (TYPE('n rvec)) \<Longrightarrow> var.wd (TYPE('n::enum vec1))"
	unfolding var.wd_def
	by (auto simp: wd_def length_concat o_def sum_list_distinct_conv_sum_set
	concat_map_map_index var_ode_e D_def ode_e'_def
	intro!: max_Var_floatariths_mmult_fa[le] max_Var_floatariths_mapI
	max_Var_floatarith_FDERIV_floatarith[le]
	max_Var_floatariths_fold_const_fa[le]
	max_Var_floatarith_le_max_Var_floatariths_nthI
	max_Var_floatariths_list_updateI max_Var_floatariths_replicateI)

	lemma safe_eq:
	assumes "wd TYPE('n::enum rvec)"
	shows "var.Csafe = ((Csafe \<times> UNIV)::'n vec1 set)"
	using assms var.wdD[OF wd_imp_var_wd[OF assms]] wdD[OF assms]
	unfolding var.safe_def safe_def var.wd_def wd_def var.Csafe_def Csafe_def
	unfolding ode_e'_def var_ode_e
	apply (auto simp: D_def)
	subgoal
	apply (subst interpret_form_max_Var_cong) prefer 2 apply assumption
	by (auto simp: nth_Basis_list_prod)
	subgoal for a b
	apply (drule isFDERIV_appendD1)
	apply simp apply simp apply (auto intro!: max_Var_floatariths_fold_const_fa[le])[]
	apply (rule isFDERIV_max_Var_congI, assumption)
	by (auto simp: nth_Basis_list_prod)
	subgoal
	apply (subst interpret_form_max_Var_cong) prefer 2 apply assumption
	by (auto simp: nth_Basis_list_prod)
	subgoal for a b
	apply (rule isFDERIV_appendI1)
	apply (rule isFDERIV_max_Var_congI, assumption)
	apply (auto simp: nth_Basis_list_prod)
	apply (auto simp: isFDERIV_def FDERIV_floatariths_def in_set_conv_nth isDERIV_inner_iff
	length_concat o_def sum_list_distinct_conv_sum_set concat_map_map_index
	intro!: isDERIV_FDERIV_floatarith isDERIV_mmult_fa_nth)
	apply (rule isDERIV_max_Var_floatarithI[where ys="list_of_eucl a"])
	subgoal for i j k
	apply (cases "i < CARD('n)")
	subgoal by auto
	subgoal apply (rule isDERIV_max_VarI)
	apply (rule max_Var_floatarith_le_max_Var_floatariths_nthI)
	apply force
	apply auto
	done
	done
	subgoal for i j k l by (auto dest!: max_Var_floatariths_lessI simp: nth_Basis_list_prod)
	subgoal by (auto simp: nth_list_update)
	done
	done

	lemma
	var_ode_eq:
	fixes x::"'n::enum vec1"
	assumes "wd TYPE('n rvec)" and [simp]: "(fst x) \<in> Csafe"
	shows "var.ode x = (ode (fst x), matrix (ode_d1 (fst x)) ** snd x)"
	proof -
	have "interpret_floatariths ode_e (list_of_eucl x) =
	interpret_floatariths ode_e (list_of_eucl (fst x))"
	apply (rule interpret_floatariths_max_Var_cong)
	using wdD[OF \<open>wd _\<close>]
	by (auto simp: list_of_eucl_nth_if nth_Basis_list_prod inner_prod_def)
	moreover
	have "eucl_of_list
	(interpret_floatariths
	(mmult_fa D D D
	(concat (map (\<lambda>j. map (\<lambda>i. FDERIV_floatarith (ode_e ! j) [0..<D] ((replicate D 0)[i := 1])) [0..<D]) [0..<D]))
	(map floatarith.Var [D..<D + D * D])) (list_of_eucl x)) =
	matrix (blinfun_apply (ode_d 0 (fst x) 0)) ** snd x"
	unfolding matrix_eq
	apply auto
	apply (subst matrix_vector_mul_assoc[symmetric])
	apply (subst matrix_works)
	subgoal by (auto simp: linear_matrix_vector_mul_eq
	intro!: bounded_linear.linear blinfun.bounded_linear_right)
	apply (subst einterpret_mmult_fa[where 'n='n and 'm = 'n and 'l='n])
	subgoal by (simp add: wdD[OF \<open>wd _\<close>])
	subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
	subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
	subgoal for v
	proof -
	have v: "einterpret (map floatarith.Var [D..<D + D * D]) (list_of_eucl x) v v = snd x v v"
	apply (vector matrix_vector_mult_def)
	apply (simp add: vec_nth_eq_list_of_eucl2 wdD[OF \<open>wd _\<close>])
	apply (auto simp: vec_nth_eq_list_of_eucl1 sum_index_enum_eq)
	apply (subst sum_index_enum_eq)+
	apply (rule sum.cong)
	by (auto simp: nth_Basis_list_prod prod_eq_iff inner_prod_def)
	show ?thesis
	unfolding matrix_vector_mul_assoc[symmetric]
	apply (subst v)
	apply (auto simp: concat_map_map_index vec_nth_eq_list_of_eucl2)
	apply (subst eucl_of_list_list_of_eucl[of "snd x *v v", symmetric])
	apply (subst (2) eucl_of_list_list_of_eucl[of "snd x *v v", symmetric])
	apply (subst eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list)
	subgoal by (simp add: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF \<open>wd _\<close>])
	subgoal by simp
	apply (subst blinfun_apply_eq_sum)
	apply (auto simp: vec_nth_eq_list_of_eucl1 sum_index_enum_eq)
	apply (auto simp: scaleR_sum_left ode_d.rep_eq intro!: sum.cong[OF refl])
	apply (auto simp: ode_d_raw_def wdD[OF \<open>wd _\<close>] eucl_of_list_inner )
	apply (auto simp: ode_d_expr_def FDERIV_floatariths_def wdD[OF \<open>wd _\<close>] )
	apply (rule interpret_floatarith_FDERIV_floatarith_cong)
	subgoal for x y i
	using wdD[OF \<open>wd _\<close>]
	by (auto simp add: nth_append inner_prod_def
	nth_Basis_list_prod dest!: max_Var_floatariths_lessI)
	subgoal by auto
	subgoal by auto
	subgoal
	apply (auto simp: wdD[OF \<open>wd _\<close>] nth_list_update inner_Basis intro!: nth_equalityI)
	by (metis \<open>length (list_of_eucl (snd x *v v)) = CARD('n)\<close> index_Basis_list_nth length_list_of_eucl)
	done
	qed
	done
	ultimately show ?thesis
	unfolding var.ode_def ode_def
	unfolding ode_e'_def var_ode_e
	by (auto simp: wdD[OF \<open>wd _\<close>] ode_d1_def intro!: euclidean_eqI[where 'a="'n vec1"])
	qed

	lemma var_existence_ivl_imp_existence_ivl:
	fixes x::"'n::enum vec1"
	assumes wd: "wd TYPE('n rvec)"
	assumes t: "t \<in> var.existence_ivl0 x"
	shows "t \<in> existence_ivl0 (fst x)"
	proof (rule existence_ivl_maximal_segment)
	from var.flow_solves_ode[OF UNIV_I var.mem_existence_ivl_iv_defined(2), OF t]
	have D: "(var.flow0 x solves_ode (\<lambda>_. var.ode)) {0--t} (var.Csafe)"
	apply (rule solves_ode_on_subset)
	apply (rule var.closed_segment_subset_existence_ivl)
	apply (rule t)
	apply simp
	done
	show "((\<lambda>t. fst (var.flow0 x t)) solves_ode (\<lambda>_. ode)) {0--t} (Csafe)"
	using var.closed_segment_subset_existence_ivl[OF t]
	apply (auto simp: has_vderiv_on_def has_vector_derivative_def subset_iff
	intro!: solves_odeI derivative_eq_intros)
	apply (rule refl)
	apply (rule refl)
	apply (rule refl)
	apply (auto simp: var.flowderiv_def )
	apply (subst var_ode_eq[OF wd(1)])
	apply (auto simp: blinfun.bilinear_simps)
	subgoal for s
	using solves_odeD(2)[OF D, of s]
	by (subst(asm) (3) safe_eq[OF wd]) (auto )
	subgoal for s
	using solves_odeD(2)[OF D, of s]
	by (subst(asm) (3) safe_eq[OF wd]) (auto )
	done
	next
	show "fst (var.flow0 x 0) = fst x"
	apply (subst var.flow_initial_time)
	apply simp
	apply (rule var.mem_existence_ivl_iv_defined[OF t])
	apply auto
	done
	qed simp

	lemma existence_ivl_imp_var_existence_ivl:
	fixes x::"'n::enum rvec"
	assumes wd: "wd TYPE('n rvec)"
	assumes t: "t \<in> existence_ivl0 x"
	shows "t \<in> var.existence_ivl0 ((x, W)::'n vec1)"
	proof (rule var.existence_ivl_maximal_segment)
	from flow_solves_ode[OF UNIV_I mem_existence_ivl_iv_defined(2), OF t]
	have D: "(flow0 x solves_ode (\<lambda>_. ode)) {0--t} (Csafe)"
	apply (rule solves_ode_on_subset)
	apply (rule closed_segment_subset_existence_ivl)
	apply (rule t)
	apply simp
	done
	show "((\<lambda>t. (flow0 x t, matrix (Dflow x t) ** W)) solves_ode (\<lambda>_. var.ode)) {0--t} (var.Csafe)"
	using closed_segment_subset_existence_ivl[OF t]
	apply (auto simp: has_vderiv_on_def has_vector_derivative_def subset_iff
	intro!: solves_odeI derivative_eq_intros)
	apply (rule refl)
	apply (rule refl)
	apply (rule refl)
	apply (rule has_derivative_at_withinI)
	apply (rule Dflow_has_derivative)
	apply force
	apply (rule refl)
	apply (auto simp: flowderiv_def )
	apply (subst var_ode_eq)
	apply (auto simp: blinfun.bilinear_simps matrix_blinfun_compose wd
	intro!: ext)
	subgoal for s h
	unfolding matrix_scaleR matrix_blinfun_compose matrix_mul_assoc matrix_scaleR_right ..
	subgoal for s
	using solves_odeD(2)[OF D, of s] safe_eq[OF wd]
	by auto
	done
	next
	have "x \<in> Csafe" by rule fact
	then show "(flow0 x 0, matrix (blinfun_apply (Dflow x 0)) ** W) = (x, W)"
	apply (auto )
	apply (vector matrix_def matrix_matrix_mult_def axis_def)
	by (auto simp: if_distrib if_distribR cong: if_cong)
	qed auto

	theorem var_existence_ivl0_eq_existence_ivl0:
	fixes x::"'n::enum vec1"
	assumes wd: "wd TYPE('n rvec)"
	shows "var.existence_ivl0 (x::'n vec1) = existence_ivl0 (fst x)"
	apply safe
	subgoal by (rule var_existence_ivl_imp_existence_ivl[OF wd, of _ "x", simplified], simp)
	subgoal
	by (rule existence_ivl_imp_var_existence_ivl[OF wd, of _ "fst x" "snd x", unfolded prod.collapse])
	done

	theorem var_flow_eq_flow_Dflow:
	fixes x::"'n::enum vec1"
	assumes wd: "wd TYPE('n rvec)"
	assumes t: "t \<in> var.existence_ivl0 x"
	shows "var.flow0 x t = vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)) "
	proof -
	have x: "x \<in> var.Csafe"
	by (rule var.mem_existence_ivl_iv_defined[OF t])
	then have "fst x \<in> Csafe"
	by (subst (asm) safe_eq[OF wd]) auto
	then have sx[simp]: "(fst x) \<in> Csafe" by simp
	show ?thesis
	proof (rule var.flow_unique_on[OF t])
	show "vec1_of_flow1 (flow0 (fst x) 0, Dflow (fst x) 0 o\<^sub>L blinfun_of_vmatrix (snd x)) = x"
	by (auto simp: vec1_of_flow1_def x)
	show "((\<lambda>a. vec1_of_flow1 (flow0 (fst x) a, Dflow (fst x) a o\<^sub>L blinfun_of_vmatrix (snd x))) has_vderiv_on
	(\<lambda>t. var.ode (vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)))))
	(var.existence_ivl0 x)"
	apply (auto simp: has_vderiv_on_def has_vector_derivative_def vec1_of_flow1_def
	at_within_open[OF _ var.open_existence_ivl] flowderiv_def
	intro!: derivative_eq_intros var_existence_ivl_imp_existence_ivl[OF wd]
	Dflow_has_derivative ext)
	apply (subst var_ode_eq[OF wd(1)])
	apply (auto simp: blinfun.bilinear_simps)
	subgoal for t
	using flow_in_domain[of t "fst x"]
	by (simp add: var_existence_ivl_imp_existence_ivl[OF wd])
	subgoal for t h
	by (simp add: matrix_blinfun_compose matrix_scaleR matrix_mul_assoc matrix_scaleR_right)
	done
	fix t
	assume "t \<in> var.existence_ivl0 x"
	then show "vec1_of_flow1 (flow0 (fst x) t, Dflow (fst x) t o\<^sub>L blinfun_of_vmatrix (snd x)) \<in> var.Csafe"
	by (subst safe_eq[OF wd])
	(auto simp: vec1_of_flow1_def dest!: var_existence_ivl_imp_existence_ivl[OF wd]
	flow_in_domain)
	qed
	qed

	theorem flow_Dflow_eq_var_flow:
	fixes x::"'n::enum rvec"
	assumes wd: "wd TYPE('n rvec)"
	assumes t: "t \<in> existence_ivl0 x"
	shows "(flow0 x t, Dflow x t o\<^sub>L W) = flow1_of_vec1 (var.flow0 (x, matrix W) t::'n vec1)"
	using var_flow_eq_flow_Dflow[OF wd existence_ivl_imp_var_existence_ivl[OF wd t]]
	unfolding var_flow_eq_flow_Dflow[OF wd existence_ivl_imp_var_existence_ivl[OF wd t]]
	by (auto simp: flow1_of_vec1_def vec1_of_flow1_def)

	context includes blinfun.lifting begin
	lemma flow1_of_vec1_vec1_of_flow1[simp]:
	"flow1_of_vec1 (vec1_of_flow1 X) = X"
	unfolding vec1_of_flow1_def flow1_of_vec1_def
	by (transfer) auto
	end

	lemma
	var_flowpipe0_flowpipe:
	assumes wd: "wd TYPE('n::enum rvec)"
	assumes "var.flowpipe0 X0 hl hu (CX) X1"
	assumes "fst ` X0 \<subseteq> Csafe"
	assumes "fst ` CX \<subseteq> Csafe"
	assumes "fst ` X1 \<subseteq> Csafe"
	shows "flowpipe (flow1_of_vec1 ` X0) hl hu (flow1_of_vec1 ` (CX::'n vec1 set)) (flow1_of_vec1 ` X1)"
	using assms
	unfolding flowpipe_def var.flowpipe0_def
	apply safe
	subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
	subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
	subgoal by (auto simp add: flow1_of_vec1_def vec1_of_flow1_def safe_eq[OF wd])
	subgoal for x W y V h
	apply (drule bspec[where x="(y, V)"], force)
	apply (drule bspec, assumption)
	by (simp add: var_existence_ivl0_eq_existence_ivl0[OF wd] flow1_of_vec1_def)
	subgoal for x W y V h
	apply (drule bspec[where x="(y, V)"], force)
	apply (drule bspec, assumption)
	apply (subst flow_Dflow_eq_var_flow[OF wd],
	force simp: var_existence_ivl0_eq_existence_ivl0[OF wd] flow1_of_vec1_def)
	apply (rule imageI)
	by (simp add: vec1_of_flow1_def flow1_of_vec1_def)
	subgoal for x W y V h h'
	apply (drule bspec[where x="vec1_of_flow1 (x, W)"], force)
	apply (drule bspec, assumption)
	apply (subst flow_Dflow_eq_var_flow[OF wd])
	apply (subst (asm) var_existence_ivl0_eq_existence_ivl0[OF wd])
	apply (simp add: flow1_of_vec1_def)
	subgoal
	by (meson local.existence_ivl_initial_time local.mem_existence_ivl_iv_defined(1)
	local.mem_existence_ivl_iv_defined(2) mem_is_interval_1_I mvar.interval)
	subgoal
	apply (rule imageI)
	by (simp add: vec1_of_flow1_def flow1_of_vec1_def)
	done
	done

	theorem einterpret_solve_poincare_fas:
	assumes wd: "wd TYPE('n rvec)"
	assumes "length CXs = D + D*D" "n < D"
	assumes nz: "ode (fst (eucl_of_list CXs::'n vec1)) \<bullet> Basis_list ! n \<noteq> 0"
	shows
	"flow1_of_vec1 (einterpret (solve_poincare_fas n) CXs::'n::enum vec1) =
	(let (x, d) = flow1_of_vec1 (eucl_of_list CXs::'n vec1) in (x,
	d - (blinfun_scaleR_left (ode (x)) o\<^sub>L
	(blinfun_scaleR_left (inverse (ode x \<bullet> Basis_list ! n)) o\<^sub>L (blinfun_inner_left (Basis_list ! n) o\<^sub>L d)))))"
	using assms
	apply (auto intro!: simp: flow1_of_vec1_def solve_poincare_fas_def)
	subgoal
	apply (auto intro!: euclidean_eqI[where 'a="'n rvec"])
	apply (subst eucl_of_list_prod)
	by (auto simp: eucl_of_list_prod length_concat o_def sum_list_distinct_conv_sum_set D_def Let_def
	wdD[OF wd] take_eq_map_nth)
	subgoal premises prems
	proof -
	have ode_e_eq: "interpret_floatarith (ode_e ! i) (map ((!) CXs) [0..<CARD('n)]) = interpret_floatarith (ode_e ! i) CXs"
	if "i < D"
	for i
	apply (rule interpret_floatarith_max_Var_cong)
	apply (drule max_Var_floatariths_lessI)
	using that apply (simp add: wdD[OF wd])
	apply (subst nth_map)
	apply auto
	using wdD[OF wd]
	- apply (simp add: )
	+ apply simp
	using wdD[OF wd]
	- apply (simp add: )
	+ apply simp
	done
	define z where "z = (0::float)"
	show ?thesis
	supply [simp] = snd_eucl_of_list_prod fst_eucl_of_list_prod
	supply [simp del] = eucl_of_list_take_DIM
	using prems unfolding z_def[symmetric] D_def Let_def
	including blinfun.lifting
	apply (transfer fixing: CXs n z)
	unfolding z_def
	apply (auto simp: o_def ode_def intro!: ext)
	apply (vector matrix_vector_mult_def )
	apply (auto intro!: blinfun_euclidean_eqI simp: inner_Basis_eq_vec_nth wdD[OF wd])
	apply (auto simp: length_concat o_def sum_list_distinct_conv_sum_set wdD[OF wd] take_eq_map_nth)
	apply (auto simp: concat_map_map_index)
	apply (vector )
	apply (subst vec_nth_eq_list_of_eucl2 vec_nth_eq_list_of_eucl1)+
	apply (subst (asm) vec_nth_eq_list_of_eucl2 vec_nth_eq_list_of_eucl1)+
	apply (simp add: less_imp_le wdD[OF wd] index_nth_id )
	apply (auto simp: algebra_simps ode_e_eq wdD[OF wd] divide_simps)
	done
	qed
	done

	lemma choose_step'_flowpipe:
	assumes wd[refine_vcg]: "wd TYPE('n::enum rvec)"
	assumes safe: "fst ` X0 \<subseteq> Csafe"
	shows "var.choose_step (X0::'n vec1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n vec1 set).
	0 < h' \<and> h' \<le> h \<and> flowpipe (flow1_of_vec1 ` X0) h' h' (flow1_of_vec1 ` RES_ivl) (flow1_of_vec1 ` RES))"
	apply refine_vcg
	- apply (auto simp: )
	+ apply auto
	apply (frule var.flowpipe0_safeD)
	apply (drule var_flowpipe0_flowpipe[rotated])
	by (auto simp: safe_eq wd)

	lemma max_Var_floatariths_solve_poincare_fas[le]:
	assumes wd: "wd (TYPE('n::enum rvec))"
	shows "i < D \<Longrightarrow> max_Var_floatariths (solve_poincare_fas i) \<le> D + D * D"
	by (auto simp: solve_poincare_fas_def concat_map_map_index Let_def
	intro!: max_Var_floatariths_leI Suc_leI)
	(auto intro!: max_Var_floatarith_le_max_Var_floatariths_nthI max_Var_floatariths_ode_e_wd[OF wd]
	simp: wdD[OF wd])

	lemma length_solve_poincare_fas[simp]: "length (solve_poincare_fas n) = D + D * D"
	by (auto simp: solve_poincare_fas_def length_concat o_def sum_list_distinct_conv_sum_set D_def Let_def)

	theorem interpret_floatariths_solve_poincare_fas:
	assumes wd: "wd TYPE('n::enum rvec)"
	assumes "length CXs = D + D*D" "n < D"
	assumes nz: "ode (fst (eucl_of_list CXs::'n vec1)) \<bullet> Basis_list ! n \<noteq> 0"
	shows
	"interpret_floatariths (solve_poincare_fas n) CXs =
	list_of_eucl (vec1_of_flow1 (let (x, d) = flow1_of_vec1 (eucl_of_list CXs::'n vec1) in (x,
	d - (blinfun_scaleR_left (ode (x)) o\<^sub>L
	(blinfun_scaleR_left (inverse (ode x \<bullet> Basis_list ! n)) o\<^sub>L (blinfun_inner_left (Basis_list ! n) o\<^sub>L d))))))"
	using arg_cong[where f="list_of_eucl::'n vec1 \<Rightarrow> _", OF arg_cong[where f=vec1_of_flow1, OF einterpret_solve_poincare_fas[OF assms]]]
	- apply (auto simp: )
	+ apply auto
	apply (subst (asm) list_of_eucl_eucl_of_list)
	- apply (auto simp: )
	+ apply auto
	apply (auto simp: wdD[OF wd])
	done

	lemma length_solve_poincare_slp[simp]: "length solve_poincare_slp = D"
	by (auto simp: solve_poincare_slp_def)

	lemma ne_zero_lemma:
	assumes
	"ode ` fst ` CX \<subseteq> FC"
	"\<forall>b\<in>FC. b \<bullet> n \<noteq> 0"
	"(a, b) \<in> CX"
	"ode a \<bullet> n = 0"
	shows "False"
	proof -
	have "(a, b) \<in> CX" by fact
	then have "ode (fst (a, b)) \<in> ode ` fst ` CX" by blast
	also have "\<dots> \<subseteq> FC"
	by fact
	finally have "ode a \<in> FC" by simp
	with assms show False
	by auto
	qed

	lemma ne_zero_lemma2:
	assumes
	"ode ` fst ` flow1_of_vec1 ` env \<subseteq> F"
	"\<forall>x\<in>F. x \<bullet> n \<noteq> 0"
	"(a, b) \<in> env"
	"flow1_of_vec1 (a, b) = (a', b')"
	"ode a' \<bullet> n = 0"
	shows False
	proof -
	have "(a', b') \<in> flow1_of_vec1 ` env"
	apply (rule image_eqI)
	using assms by auto
	then have "ode (fst (a', b')) \<in> ode ` fst ` \<dots>" by blast
	also from assms have "\<dots> \<subseteq> F" by simp
	finally have "ode a' \<in> F" by simp
	with assms have "ode a' \<bullet> n \<noteq> 0" by auto
	with assms show False by simp
	qed

	lemma solve_poincare_plane[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	assumes "n \<in> Basis"
	shows "solve_poincare_plane (n::'n::enum rvec) CX \<le> SPEC (\<lambda>PDP.
	fst ` PDP \<subseteq> Csafe \<and>
	(\<forall>(x, d) \<in> CX. (x, d - (blinfun_scaleR_left (ode x) o\<^sub>L
	(blinfun_scaleR_left (inverse (ode x \<bullet> n)) o\<^sub>L (blinfun_inner_left n o\<^sub>L d)))) \<in> PDP) \<and>
	(\<forall>(x, d) \<in> PDP. ode x \<bullet> n \<noteq> 0))"
	unfolding solve_poincare_plane_def
	apply (refine_vcg)
	subgoal using assms by auto
	subgoal using assms by auto
	subgoal using assms by auto
	subgoal using assms by (auto simp: solve_poincare_slp_def)
	subgoal using assms by auto
	subgoal for C1 FC _ CX' CX'' P P1 FP _
	apply auto
	apply (drule bspec, assumption)
	apply (rule image_eqI)
	prefer 2 apply assumption
	apply (subst einterpret_solve_poincare_fas)
	subgoal using wd by auto
	subgoal using wd by auto
	subgoal using wd by auto
	subgoal using wd assms by (auto elim!: ne_zero_lemma)
	- subgoal using wd assms by (auto simp: )
	+ subgoal using wd assms by auto
	done
	subgoal by (auto elim!: ne_zero_lemma2)
	done

	lemma choose_step1_flowpipe[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('n::enum rvec)"
	shows "choose_step1 (X0::'n eucl1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n eucl1 set).
	0 < h' \<and> h' \<le> h \<and> flowpipe X0 h' h' RES_ivl RES)"
	using assms
	unfolding choose_step1_def
	by (refine_vcg choose_step'_flowpipe[le] wd)
	(auto simp: image_image,
	auto simp: safe_eq vec1_of_flow1_def flowpipe0_imp_flowpipe env_len_def)

	lemma image_flow1_of_vec1I:
	"vec1_of_flow1 x \<in> X \<Longrightarrow> x \<in> flow1_of_vec1 ` X"
	by (rule image_eqI) (rule flow1_of_vec1_vec1_of_flow1[symmetric])

	lemma inter_sctn1_spec[le, refine_vcg]:
	"inter_sctn1_spec X sctn \<le> SPEC (\<lambda>(R, S). X \<inter> plane_of sctn \<times> UNIV \<subseteq> R \<and> fst ` R \<subseteq> plane_of sctn
	\<and> X \<inter> plane_of sctn \<times> UNIV \<subseteq> S \<and> fst ` S \<subseteq> plane_of sctn)"
	unfolding inter_sctn1_spec_def
	apply (refine_vcg, auto)
	subgoal by (rule image_flow1_of_vec1I) (auto simp: plane_of_def inner_prod_def)
	subgoal by (auto simp: plane_of_def inner_prod_def)
	subgoal by (rule image_flow1_of_vec1I)
	(force simp: set_plus_def plane_of_def inner_prod_def vec1_of_flow1_def)
	subgoal by (force simp: set_plus_def)
	done

	lemma fst_safe_coll[le, refine_vcg]:
	"wd TYPE('a) \<Longrightarrow>
	fst_safe_coll (X::('a::executable_euclidean_space*'c) set) \<le> SPEC (\<lambda>R. R = fst ` X \<and> fst ` X \<subseteq> Csafe)"
	unfolding fst_safe_coll_def
	by refine_vcg

	lemma vec1reps[THEN order_trans, refine_vcg]: "vec1reps CX \<le> SPEC (\<lambda>R. case R of None \<Rightarrow> True \| Some X \<Rightarrow> X = vec1_of_flow1 ` CX)"
	unfolding vec1reps_def
	apply (refine_vcg FORWEAK_mono_rule[where
	I="\<lambda>XS R. case R of None \<Rightarrow> True \| Some R \<Rightarrow> vec1_of_flow1 ` (\<Union>XS) \<subseteq> R \<and> R \<subseteq> vec1_of_flow1 ` CX"])
	by (auto simp: split: option.splits) force+

	lemma nonzero_component_within[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "nonzero_component_within ivl sctn (PDP::'n eucl1 set) \<le> SPEC (\<lambda>b.
	(b \<longrightarrow> (\<forall>x\<in>PDP. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl))) \<and>
	fst ` PDP \<subseteq> Csafe \<and>
	(\<forall>x\<in>PDP. ode (fst x) \<bullet> normal sctn \<noteq> 0))"
	unfolding nonzero_component_within_def
	by refine_vcg auto

	lemma do_intersection_invar_inside:
	"do_intersection_invar guards b ivl sctn X (e, f, m, n, p, q, True) \<Longrightarrow>
	fst ` e \<subseteq> sabove_halfspace sctn \<Longrightarrow>
	fst ` mn \<subseteq> ivl \<Longrightarrow>
	mn = m \<or> mn = n \<Longrightarrow>
	do_intersection_spec UNIV guards ivl sctn X (mn, p)"
	subgoal premises prems
	proof -
	from prems have e: "e \<inter> sbelow_halfspace sctn \<times> UNIV = {}"
	by (auto simp: halfspace_simps plane_of_def)
	with prems(1) have
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X UNIV p m"
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X UNIV p n"
	"e \<inter> sbelow_halfspace sctn \<times> UNIV = {}"
	"fst ` X \<inter> b = {}"
	"fst ` X \<subseteq> sbelow_halfspace sctn"
	"ivl \<subseteq> plane (normal sctn) (pstn sctn)"
	"fst ` X \<subseteq> p"
	"fst ` m \<subseteq> Csafe"
	"fst ` n \<subseteq> Csafe"
	"p \<subseteq> Csafe"
	"fst ` e \<subseteq> Csafe"
	"f \<subseteq> {0..}"
	"p \<subseteq> sbelow_halfspace sctn - guards"
	"e \<subseteq> (- guards) \<times> UNIV"
	"fst ` (m \<union> n) \<inter> guards = {}"
	"0 \<notin> (\<lambda>x. ode x \<bullet> normal sctn) ` fst ` (m \<union> n)"
	"\<forall>x\<in>m \<union> n. \<forall>\<^sub>F x in at (fst x) within plane (normal sctn) (pstn sctn). x \<in> ivl"
	by (auto simp: do_intersection_invar_def do_intersection_spec_def plane_of_def)
	then show ?thesis
	using prems(2-)
	by (auto simp: do_intersection_spec_def plane_of_def halfspace_simps)
	qed
	done

	lemma do_intersection_body_lemma:
	assumes "flowsto A T (i \<times> UNIV) (X' \<inter> sbelow_halfspace sctn \<times> UNIV)"
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS "
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS2"
	"T \<subseteq> {0..}"
	"i \<subseteq> sbelow_halfspace sctn - guards"
	"fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn"
	"fst ` PS \<subseteq> Csafe "
	"fst ` PS2 \<subseteq> Csafe "
	\<open>X = A \<union> B\<close>
	assumes ivl: "closed ivl" "ivl \<subseteq> plane_of sctn"
	assumes normal_Basis: "\<bar>normal sctn\<bar> \<in> Basis"
	and inter_empties: "fst ` Y \<inter> GUARDS = {}" "fst ` CX' \<inter> GUARDS = {}"
	"fst ` PDP' \<inter> GUARDS = {}" "fst ` PDP'' \<inter> GUARDS = {}"
	and h': "0 < h'" "h' \<le> h"
	and safe: "fst ` PDP \<subseteq> Csafe" "fst ` CX' \<subseteq> Csafe"
	"fst ` PDP' \<subseteq> Csafe"
	"fst ` PDP'' \<subseteq> Csafe"
	and PDP:
	"\<forall>(x,d)\<in>CX'. (x,
	d - (blinfun_scaleR_left (ode x) o\<^sub>L
	(blinfun_scaleR_left (inverse (ode x \<bullet> \<bar>normal sctn\<bar>)) o\<^sub>L
	(blinfun_inner_left \<bar>normal sctn\<bar> o\<^sub>L d))))
	\<in> PDP"
	and PDP': "PDP \<inter> plane_of sctn \<times> UNIV \<subseteq> PDP'"
	and PDP'': "PDP \<inter> plane_of sctn \<times> UNIV \<subseteq> PDP''"
	and evin:
	"\<forall>x\<in>PDP'. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)"
	"\<forall>x\<in>PDP''. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)"
	and through: "\<forall>(x, d)\<in>PDP. ode x \<bullet> \<bar>normal sctn\<bar> \<noteq> 0"
	"\<forall>x\<in>PDP'. ode (fst x) \<bullet> normal sctn \<noteq> 0"
	"\<forall>x\<in>PDP''. ode (fst x) \<bullet> normal sctn \<noteq> 0"
	and plane:
	"fst ` PDP' \<subseteq> plane_of sctn"
	"fst ` PDP'' \<subseteq> plane_of sctn"
	and flowpipe: "flowpipe X' h' h' CX' Y"
	shows "\<exists>A B. X = A \<union> B \<and>
	flowsto A {0<..} ((fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) \<times> UNIV) (Y \<inter> sbelow_halfspace sctn \<times> UNIV) \<and>
	poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP' \<union> PS) \<and>
	poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP'' \<union> PS2)"
	proof -
	from flowpipe
	have 1: "flowpipe (X' \<inter> (sbelow_halfspace sctn) \<times> UNIV) h' h' CX' Y"
	by (rule flowpipe_subset) (use flowpipe in \<open>auto dest!: flowpipe_safeD\<close>)
	have 2: "fst ` (X' \<inter> (sbelow_halfspace sctn) \<times> UNIV) \<inter> {x. pstn sctn \<le> x \<bullet> normal sctn} = {}"
	by (auto simp: halfspace_simps plane_of_def)
	from normal_Basis have 3: "normal sctn \<noteq> 0"
	- by (auto simp: )
	+ by auto
	note 4 = \<open>closed ivl\<close>
	from \<open>ivl \<subseteq> plane_of sctn\<close> have 5: "ivl \<subseteq> plane (normal sctn) (pstn sctn)"
	by (auto simp: plane_of_def)
	have 6: "(x, d) \<in> CX' \<Longrightarrow> x \<in> plane (normal sctn) (pstn sctn) \<Longrightarrow>
	(x, d - (blinfun_scaleR_left (ode x) o\<^sub>L
	(blinfun_scaleR_left (inverse (ode x \<bullet> normal sctn)) o\<^sub>L (blinfun_inner_left (normal sctn) o\<^sub>L d))))
	\<in> PDP' \<inter> PDP''" for x d
	unfolding PDP_abs_lemma[OF normal_Basis]
	apply (drule PDP[rule_format, of "(x, d)", unfolded split_beta' fst_conv snd_conv])
	using PDP' PDP''
	by (auto simp: plane_of_def)
	from normal_Basis through
	have 7: "(x, d) \<in> PDP' \<Longrightarrow> ode x \<bullet> normal sctn \<noteq> 0" for x d
	by (auto elim!: abs_in_BasisE)
	have 8: "(x, d) \<in> PDP' \<Longrightarrow> x \<in> ivl" for x d
	using evin by auto
	have 9: "(x, d) \<in> PDP' \<Longrightarrow> \<forall>\<^sub>F x in at x within plane (normal sctn) (pstn sctn). x \<in> ivl" for x d
	using evin by (auto simp add: plane_of_def)
	obtain X1 X2
	where X1X2: "X' \<inter> sbelow_halfspace sctn \<times> UNIV = X1 \<union> X2"
	and X1: "flowsto X1 {0<..h'} (CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)
	(CX' \<inter> {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV)"
	and X2: "flowsto X2 {h'..h'} (CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)
	(Y \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV)"
	and P: "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} X1 UNIV
	(fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) (PDP' \<inter> PDP'')"
	by (rule flowpipe_split_at_above_halfspace[OF 1 2 3 4 5 6 7 8 9]) (auto simp: Ball_def)
	from \<open>flowsto A _ _ _\<close>[unfolded X1X2]
	obtain p1 p2 where p1p2: "A = p1 \<union> p2" and p1: "flowsto p1 T (i \<times> UNIV) X1" and p2: "flowsto p2 T (i \<times> UNIV) X2"
	by (rule flowsto_unionE)
	have "A \<union> B = p2 \<union> (p1 \<union> B)" using \<open>A = p1 \<union> p2\<close>
	by auto
	moreover
	from flowsto_trans[OF p2 X2]
	have "flowsto p2 {0<..} ((fst ` CX' \<inter> (sbelow_halfspace sctn) \<union> i) \<times> UNIV)
	(Y \<inter> (sbelow_halfspace sctn) \<times> UNIV)"
	apply (rule flowsto_subset)
	subgoal by (auto simp: halfspace_simps)
	subgoal using h' \<open>T \<subseteq> _\<close> by (auto simp: halfspace_simps intro!: add_nonneg_pos)
	subgoal
	using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2
	apply auto
	by (auto simp: halfspace_simps)
	subgoal by (auto simp: halfspace_simps)
	done
	moreover
	have cls: "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
	by (rule closed_levelset_within continuous_intros \<open>closed ivl\<close>)+
	from flowsto_trans[OF p1 X1]
	have ftt: "flowsto p1 ({s + t \|s t. s \<in> T \<and> t \<in> {0<..h'}})
	(i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1 \<inter> X1)
	(X1 - X1 \<union> CX' \<inter> {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV)"
	by auto
	from X1X2 have X1_sb: "X1 \<subseteq> sbelow_halfspace sctn \<times> UNIV" by auto
	have "{x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV \<inter> (i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1) = {}"
	apply (intro Int_Un_eq_emptyI)
	subgoal using \<open>i \<subseteq> sbelow_halfspace sctn - guards\<close> by (auto simp: halfspace_simps)
	subgoal by (auto simp: halfspace_simps)
	subgoal using X1_sb by (auto simp: halfspace_simps)
	done
	then have inter_empty:
	"{x \<in> ivl. x \<bullet> normal sctn = pstn sctn} \<times> UNIV \<inter> (i \<times> UNIV \<union> CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn} \<times> UNIV \<union> X1 \<inter> X1) = {}"
	by auto
	have p1ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x"
	and p1pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` (PDP' \<inter> PDP'')"
	if "(x, d) \<in> p1" for x d
	apply (rule flowsto_poincareD[OF ftt _ inter_empty _ _ _ order_refl])
	subgoal by auto
	subgoal by fact
	subgoal using \<open>T \<subseteq> _\<close> by auto
	subgoal using that by auto
	subgoal
	apply (rule flowsto_poincareD[OF ftt _ inter_empty])
	subgoal by auto
	subgoal by fact
	subgoal using \<open>T \<subseteq> _\<close> by auto
	subgoal using that by auto
	subgoal using 6 by force
	done
	done
	have crt: "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x" if "(x, d) \<in> p1" for x d
	apply (rule return_time_isCont_outside[where Ds="\<lambda>_. blinfun_inner_left (normal sctn)"])
	subgoal by (simp add: p1ret[OF that])
	subgoal by fact
	subgoal by (auto intro!: derivative_eq_intros)
	subgoal by simp
	subgoal apply simp
	using p1pm[OF that]
	by (auto dest!: 7)
	subgoal
	using p1pm[OF that]
	by (auto dest!: 9 simp: eventually_at_filter)
	subgoal
	using \<open>fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn\<close> that p1p2
	by (auto simp: halfspace_simps)
	done
	have pmij: "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV
	(fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) (PDP' \<inter> PDP'')"
	apply (rule flowsto_poincare_trans[OF \<open>flowsto _ _ _ X1\<close> P])
	subgoal using \<open>T \<subseteq> {0..}\<close> by auto
	subgoal by auto
	subgoal
	using \<open>i \<subseteq> sbelow_halfspace sctn - guards\<close> X1X2
	by (force simp: halfspace_simps)
	subgoal by fact
	subgoal for x d using crt by simp
	subgoal by auto
	done
	from pmij have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV (fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) PDP'"
	apply (rule poincare_mapsto_subset)
	using \<open>fst ` PDP' \<subseteq> Csafe\<close>
	by auto
	from this \<open>poincare_mapsto _ _ _ i PS\<close>
	have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV
	((fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) \<union> i) (PDP' \<union> PS)"
	by (intro poincare_mapsto_unionI) (auto simp: plane_of_def)
	then have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP' \<union> PS)"
	apply (rule poincare_mapsto_subset)
	subgoal by auto
	subgoal by auto
	subgoal
	using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2
	apply (auto simp: halfspace_simps subset_iff)
	done
	subgoal using safe \<open>fst ` PS \<subseteq> Csafe\<close> by auto
	done
	moreover
	from pmij have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} p1 UNIV (fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) PDP''"
	apply (rule poincare_mapsto_subset)
	using \<open>fst ` PDP'' \<subseteq> Csafe\<close>
	by auto
	from this \<open>poincare_mapsto _ _ _ i PS2\<close>
	have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV
	((fst ` (i \<times> UNIV \<union> X1) \<union> fst ` CX' \<inter> {x. x \<bullet> normal sctn < pstn sctn}) \<union> i) (PDP'' \<union> PS2)"
	by (intro poincare_mapsto_unionI) (auto simp: plane_of_def)
	then have "poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} (p1 \<union> B) UNIV (fst ` CX' \<inter> sbelow_halfspace sctn \<union> i) (PDP'' \<union> PS2)"
	apply (rule poincare_mapsto_subset)
	subgoal by auto
	subgoal by auto
	subgoal
	using flowpipe_source_subset[OF 1, unfolded X1X2] X1X2
	apply (auto simp: halfspace_simps subset_iff)
	done
	subgoal using safe \<open>fst ` PS2 \<subseteq> Csafe\<close> by auto
	done
	ultimately
	show ?thesis
	unfolding \<open>X = A \<union> B\<close> by blast
	qed

	lemma do_intersection_body_spec:
	fixes guards::"'n::enum rvec set"
	assumes invar: "do_intersection_invar guards GUARDS ivl sctn X (X', T, PS, PS2, i, True, True)"
	and wdp[refine_vcg]: "wd TYPE('n rvec)"
	and X: "fst ` X \<subseteq> Csafe"
	and ivl: "closed ivl" and GUARDS: "guards \<subseteq> GUARDS"
	shows "do_intersection_body GUARDS ivl sctn h (X', T, PS, PS2, i, True, True) \<le>
	SPEC (do_intersection_invar guards GUARDS ivl sctn X)"
	proof -
	from invar
	obtain A B where AB: "fst ` (A \<union> B) \<inter> GUARDS = {} "
	"fst ` (A \<union> B) \<subseteq> sbelow_halfspace sctn "
	"ivl \<subseteq> plane_of sctn "
	"fst ` (A \<union> B) \<subseteq> i "
	"fst ` PS \<subseteq> Csafe "
	"fst ` PS2 \<subseteq> Csafe "
	"i \<subseteq> Csafe "
	"fst ` X' \<subseteq> Csafe "
	"T \<subseteq> {0..}"
	"i \<subseteq> sbelow_halfspace sctn - guards "
	"X' \<subseteq> (- guards) \<times> UNIV "
	"fst ` (PS \<union> PS2) \<inter> guards = {} "
	"0 \<notin> (\<lambda>x. ode x \<bullet> normal sctn) ` fst ` (PS \<union> PS2) "
	"\<forall>x\<in>PS \<union> PS2. \<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl "
	"X = A \<union> B "
	"flowsto A T (i \<times> UNIV) (X' \<inter> sbelow_halfspace sctn \<times> UNIV)"
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS "
	"poincare_mapsto {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} B UNIV i PS2"
	by (auto simp: do_intersection_invar_def)

	have ev_in_ivl: "\<forall>\<^sub>F x in at p within plane_of sctn. x \<in> ivl" if
	\<open>\<forall>x\<in>d. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)\<close>
	\<open>\<forall>x\<in>e. fst x \<in> ivl \<and> (\<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl)\<close>
	\<open>(p, q) \<in> d \<or> (p, q) \<in> PS \<or> (p, q) \<in> e \<or> (p, q) \<in> PS2\<close>
	for p q d e
	using \<open>\<forall>x\<in>PS \<union> PS2. \<forall>\<^sub>F x in at (fst x) within plane_of sctn. x \<in> ivl\<close>
	using that
	by (auto dest!: bspec[where x="(p, q)"])

	show ?thesis
	unfolding do_intersection_body_def do_intersection_invar_def
	apply simp
	apply (refine_vcg, clarsimp_all)
	- subgoal using AB by (auto simp: )
	- subgoal using AB by (auto simp: )
	- subgoal using AB by (auto simp: )
	+ subgoal using AB by auto
	+ subgoal using AB by auto
	+ subgoal using AB by auto
	subgoal
	apply (rule conjI)
	subgoal using AB by auto\<comment> \<open>unnecessarily slow\<close>
	subgoal using AB by fastforce
	done
	- subgoal using AB by (auto simp: )
	- subgoal using AB by (auto simp: )
	- subgoal using AB by (auto simp: )
	+ subgoal using AB by auto
	+ subgoal using AB by auto
	+ subgoal using AB by auto
	subgoal by (auto dest!: flowpipe_safeD)
	subgoal
	apply safe
	subgoal using AB GUARDS by auto
	subgoal using AB by auto
	subgoal using AB by auto
	subgoal using AB GUARDS by auto
	subgoal using AB by auto
	subgoal using AB by auto
	done
	subgoal using AB GUARDS by auto
	subgoal using AB GUARDS by auto\<comment> \<open>unnecessarily slow\<close>
	subgoal using AB GUARDS by auto
	subgoal using AB assms by (auto intro: ev_in_ivl)
	subgoal using AB assms apply - by (rule do_intersection_body_lemma)
	done
	qed

	lemma
	do_intersection_spec[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "do_intersection guards ivl sctn (X::'n eucl1 set) h \<le>
	SPEC (\<lambda>(inside, P, P2, CX). (inside \<longrightarrow>
	(do_intersection_spec UNIV guards ivl sctn X (P, CX) \<and>
	do_intersection_spec UNIV guards ivl sctn X (P2, CX)) \<and> fst ` X \<subseteq> CX))"
	using assms
	unfolding do_intersection_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal
	unfolding do_intersection_invar_def
	apply clarsimp
	apply (intro conjI)
	apply force
	apply force
	apply force
	apply (rule exI[where x=X])
	apply (rule exI[where x="{}"])
	by (auto intro!: flowsto_self)
	subgoal by (rule do_intersection_body_spec)
	subgoal by (rule do_intersection_invar_inside, assumption) auto
	subgoal by (rule do_intersection_invar_inside, assumption) auto
	subgoal by (auto simp: plane_of_def halfspace_simps do_intersection_invar_def)
	done

	lemma mem_flow1_of_vec1_image_iff[simp]:
	"(c, d) \<in> flow1_of_vec1 ` a \<longleftrightarrow> vec1_of_flow1 (c, d) \<in> a"
	by force

	lemma mem_vec1_of_flow1_image_iff[simp]:
	"(c, d) \<in> vec1_of_flow1 ` a \<longleftrightarrow> flow1_of_vec1 (c, d) \<in> a"
	by force

	lemma split_spec_param1[le, refine_vcg]: "split_spec_param1 X \<le> SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
	unfolding split_spec_param1_def
	apply (refine_vcg)
	apply (auto simp add: subset_iff split: option.splits)
	by (metis flow1_of_vec1_vec1_of_flow1 surjective_pairing)

	lemma do_intersection_spec_empty:
	"X = {} \<Longrightarrow> Y = {} \<Longrightarrow> do_intersection_spec S sctns ivl sctn X ({}, Y)"
	by (auto simp: do_intersection_spec_def halfspaces_union)

	lemma do_intersection_spec_subset:
	"do_intersection_spec S osctns ivl csctns Y (a, b) \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> do_intersection_spec S osctns ivl csctns X (a, b)"
	by (auto simp: do_intersection_spec_def halfspaces_union intro: flowsto_subset poincare_mapsto_subset)

	lemma do_intersection_spec_union:
	"do_intersection_spec S osctns ivl csctns a (b, c) \<Longrightarrow>
	do_intersection_spec S osctns ivl csctns f (g, h) \<Longrightarrow>
	do_intersection_spec S osctns ivl csctns (a \<union> f) (b \<union> g, c \<union> h)"
	by (auto simp: do_intersection_spec_def intro!: poincare_mapsto_unionI)

	lemma scaleR2_rep_of_coll[le, refine_vcg]:
	"scaleR2_rep_coll X \<le> SPEC (\<lambda>((l, u), Y). X \<subseteq> scaleR2 l u Y)"
	unfolding scaleR2_rep_coll_def
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs ((l, u), Y). \<Union>Xs \<subseteq> scaleR2 l u Y"])
	subgoal by (auto intro: scaleR2_subset)
	subgoal
	apply clarsimp
	apply safe
	subgoal by (auto elim: scaleR2_subset)
	subgoal
	apply (rule set_rev_mp, assumption)
	apply (rule order_trans)
	apply (rule Union_upper, assumption)
	apply (rule order_trans, assumption)
	apply (rule subsetI)
	apply (erule scaleR2_subset)
	by (auto )
	done
	done

	lemma split_spec_param1e[le, refine_vcg]: "split_spec_param1e X \<le> SPEC (\<lambda>(A, B). X \<subseteq> A \<union> B)"
	unfolding split_spec_param1e_def
	apply (refine_vcg)
	apply clarsimp
	apply (thin_tac "_ \<noteq> {}")
	apply (auto simp: scaleR2_def vimage_def image_def)
	apply (rule exI, rule conjI, assumption, rule conjI, assumption)
	apply (auto simp: split_beta')
	apply (drule_tac x = x in spec)
	apply auto
	by (metis (no_types, lifting) UnE prod.sel(1) prod.sel(2) subset_eq)

	lemma reduce_spec1[le, refine_vcg]: "reduce_spec1 ro X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding reduce_spec1_def
	by refine_vcg auto

	lemma reduce_spec1e[le, refine_vcg]: "reduce_spec1e ro X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding reduce_spec1e_def
	by refine_vcg (auto simp: scaleR2_def image_def vimage_def, force)

	lemma split_under_threshold[le, refine_vcg]:
	"split_under_threshold ro th X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding split_under_threshold_def autoref_tag_defs
	by (refine_vcg) auto

	lemma step_split[le, refine_vcg]:
	"wd TYPE((real, 'n::enum) vec) \<Longrightarrow> step_split ro (X::'n eucl1 set) \<le> SPEC (\<lambda>Y. X \<subseteq> Y \<and> fst ` Y \<subseteq> Csafe)"
	unfolding step_split_def
	by (refine_vcg refine_vcg) auto

	lemma tolerate_error_SPEC[THEN order_trans, refine_vcg]:
	"tolerate_error Y E \<le> SPEC (\<lambda>b. True)"
	unfolding tolerate_error_def
	by refine_vcg

	lemma flowpipe_scaleR2I: "flowpipe (scaleR2 x1 x2 bc) x1a x1a (fst ` aca \<times> UNIV) (scaleR2 x1 x2 bca)"
	if "flowpipe (bc) x1a x1a (fst ` aca \<times> UNIV) (bca)"
	using that
	apply (auto simp: flowpipe_def scaleR2_def)
	apply (drule bspec, assumption)
	apply (auto simp: image_def vimage_def )
	apply (rule exI, rule conjI, assumption, rule conjI, assumption)
	apply (rule bexI) prefer 2 apply assumption
	by (auto simp: scaleR_blinfun_compose_right)

	lemma choose_step1e_flowpipe[le, refine_vcg]:
	assumes vwd[refine_vcg]: "wd TYPE('n::enum rvec)"
	shows "choose_step1e (X0::'n eucl1 set) h \<le> SPEC (\<lambda>(h', _, RES_ivl, RES::'n eucl1 set).
	0 < h' \<and> h' \<le> h \<and> flowpipe X0 h' h' (RES_ivl \<times> UNIV) RES)"
	unfolding choose_step1e_def
	apply (refine_vcg)
	apply (auto intro: flowpipe_scaleR2I)
	apply (erule contrapos_np)
	apply (auto intro!: flowpipe_scaleR2I)
	apply (rule flowpipe_subset)
	apply assumption
	apply (auto dest!: flowpipe_safeD)
	done

	lemma width_spec_appr1[THEN order_trans, refine_vcg]: "width_spec_appr1 X \<le> SPEC (\<lambda>_. True)"
	unfolding width_spec_appr1_def
	by refine_vcg

	lemma tolerate_error1_SPEC[THEN order_trans, refine_vcg]:
	"tolerate_error1 Y E \<le> SPEC (\<lambda>b. True)"
	unfolding tolerate_error1_def
	by refine_vcg

	lemma
	step_adapt_time[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "step_adapt_time (X::'n eucl1 set) h \<le> SPEC (\<lambda>(t, CX, X1, h). flowpipe X t t (CX \<times> UNIV) X1)"
	unfolding step_adapt_time_def autoref_tag_defs
	apply (refine_vcg refine_vcg, clarsimp)
	apply (auto simp: flowpipe_def)
	apply force
	done

	lemma
	resolve_step[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "resolve_step roptns (X::'n::enum eucl1 set) h \<le> SPEC (\<lambda>(_, CX, X1, _).
	flowsto X {0..} (CX \<times> UNIV) X1 \<and> X \<union> X1 \<subseteq> CX \<times> UNIV \<and> X1 \<union> CX \<times> UNIV \<subseteq> Csafe \<times> UNIV)"
	unfolding resolve_step_def autoref_tag_defs
	apply (refine_vcg refine_vcg)
	subgoal by (rule flowsto_self) auto
	subgoal by auto
	subgoal by auto
	subgoal
	apply clarsimp
	apply (frule flowpipe_imp_flowsto_nonneg)
	apply (rule flowsto_subset, assumption)
	by auto
	subgoal
	by (auto dest: flowpipe_source_subset)
	subgoal
	by (auto dest!: flowpipe_safeD)
	done

	lemma pre_intersection_step[THEN order_trans, refine_vcg]:
	"pre_intersection_step ro (X::'n eucl1 set) h \<le> SPEC (\<lambda>(X', CX, G). X \<subseteq> X' \<union> G \<and> X \<union> X' \<union> G \<subseteq> CX \<times> UNIV)"
	if [refine_vcg]: "wd TYPE('n::enum rvec)"
	unfolding pre_intersection_step_def autoref_tag_defs
	by (refine_vcg) auto

	lemma [THEN order_trans, refine_vcg]: "select_with_inter ci a \<le> SPEC (\<lambda>_. True)"
	unfolding select_with_inter_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>_ _. True"])

	lemmas [refine_vcg del] = scaleR2_rep_of_coll

	lemma fst_scaleR2_image[simp]: "ad \<le> ereal r \<Longrightarrow> ereal r \<le> bd \<Longrightarrow> fst ` scaleR2 ad bd be = fst ` be"
	by (cases ad; cases bd; force simp: scaleR2_def image_image split_beta' vimage_def)

	lemma scaleR2_rep_of_coll2[le, refine_vcg]:
	"scaleR2_rep_coll X \<le> SPEC (\<lambda>((l, u), Y). X \<subseteq> scaleR2 l u Y \<and> fst ` X = fst ` Y)"
	unfolding scaleR2_rep_coll_def
	supply [simp del] = mem_scaleR2_union
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs ((l, u), Y).
	\<Union>Xs \<subseteq> scaleR2 l u Y \<and> fst ` \<Union>Xs \<subseteq> fst ` Y \<and> fst ` Y \<subseteq> fst ` X"])
	apply (auto intro: scaleR2_subset)
	subgoal by (auto simp: scaleR2_def)
	subgoal by (auto simp: scaleR2_def image_def vimage_def, fastforce)
	subgoal
	apply (rule scaleR2_subset)
	apply (rule subsetD)
	apply assumption
	apply auto
	done
	subgoal by force
	subgoal for a b c d e f g h i j k l
	apply (rule scaleR2_subset)
	apply (rule subsetD)
	apply assumption
	by auto
	subgoal by (auto simp: scaleR2_def)
	subgoal by (auto simp: scaleR2_def)
	subgoal by (auto simp: scaleR2_def image_def vimage_def, fastforce)
	done

	lemma reach_cont[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "reach_cont roptns guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
	G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
	X \<union> G \<subseteq> CX \<times> UNIV \<and>
	flowsto X {0..} (CX \<times> UNIV) G)"
	using [[simproc del: defined_all]]
	unfolding reach_cont_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all simp add: cancel_times_UNIV_subset)
	- subgoal by (rule flowsto_self) (auto simp: )
	+ subgoal by (rule flowsto_self) auto
	subgoal by (force simp: scaleR2_def)
	subgoal by (fastforce simp: scaleR2_def vimage_def image_def)
	subgoal premises prems for _ _ _ _ _ _ _ g
	using \<open>flowsto X _ _ (g \<union> _ \<union> _)\<close> \<open>flowsto g _ _ _\<close>
	apply (rule flowsto_stepI)
	using prems
	by auto
	subgoal
	apply safe
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	done
	subgoal by auto
	subgoal
	by (rule flowsto_subset, assumption) auto
	subgoal
	apply safe
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by fastforce
	subgoal by auto
	subgoal by auto
	subgoal
	by (metis (mono_tags, lifting) Diff_eq_empty_iff Diff_iff IntI)
	done
	subgoal
	apply safe
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	subgoal by auto
	done
	subgoal by auto
	done

	lemma reach_cont_par[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "reach_cont_par roptns guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
	G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
	X \<union> G \<subseteq> CX \<times> UNIV \<and>
	flowsto X {0..} (CX \<times> UNIV) G)"
	unfolding reach_cont_par_def
	apply refine_vcg
	apply auto
	apply force
	apply force
	apply force
	apply force
	subgoal
	apply (rule bexI)
	prefer 2 apply assumption
	by auto
	subgoal
	apply (rule bexI)
	prefer 2 apply assumption
	by auto
	subgoal for R
	apply (rule flowsto_source_Union)
	apply (drule bspec, assumption)
	apply auto
	apply (rule flowsto_subset, assumption)
	apply auto
	done
	done

	lemma subset_iplane_coll[THEN order_trans, refine_vcg]:
	"subset_iplane_coll x ics \<le> SPEC (\<lambda>b. b \<longrightarrow> x \<subseteq> ics)"
	unfolding subset_iplane_coll_def
	apply refine_vcg
	subgoal for X icss
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>ic b. b \<longrightarrow> X \<subseteq> \<Union>(icss)"]) auto
	done

	lemma subsets_iplane_coll[THEN order_trans, refine_vcg]:
	"subsets_iplane_coll x ics \<le> SPEC (\<lambda>b. b \<longrightarrow> \<Union>x \<subseteq> ics)"
	unfolding subsets_iplane_coll_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>x b. (b \<longrightarrow> \<Union>x \<subseteq> ics)"]) auto

	lemma symstart_coll[THEN order_trans, refine_vcg]:
	assumes [refine_vcg]: "wd (TYPE('n::enum rvec))"
	assumes [le, refine_vcg]:
	"\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	shows "symstart_coll symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto ((X0::'n eucl1 set) - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
	unfolding symstart_coll_def autoref_tag_defs
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X (CY, Y). flowsto (\<Union>X - trap \<times> UNIV) {0..} (CY \<times> UNIV) Y"], clarsimp_all)
	subgoal by force
	subgoal for a b c d e by (rule flowsto_subset, assumption) auto
	subgoal by force
	subgoal for a b c d e f g
	unfolding Un_Diff
	apply (rule flowsto_source_unionI)
	subgoal by (rule flowsto_subset, assumption) auto
	subgoal by (rule flowsto_subset, assumption) auto
	done
	done

	lemma reach_cont_symstart[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	assumes [le, refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	shows "reach_cont_symstart roptns symstart guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, G).
	G \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
	X \<subseteq> CX \<times> UNIV \<and>
	G \<subseteq> CX \<times> UNIV \<and>
	flowsto (X - trap \<times> UNIV) {0..} (CX \<times> UNIV) (G))"
	unfolding reach_cont_symstart_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal by (auto simp: times_subset_iff)
	subgoal by auto
	subgoal by auto
	subgoal for a b c d e f g
	apply (rule flowsto_stepI[OF _ _ order_refl])
	apply assumption
	by assumption auto
	done

	lemma reach_conts[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
	shows "reach_conts roptns symstart trap guards (X::'n eucl1 set) \<le> SPEC (\<lambda>(CX, IGs, X0).
	\<Union>(snd ` IGs) \<union> (CX \<times> UNIV) \<subseteq> (Csafe - guards) \<times> UNIV \<and>
	X \<subseteq> CX \<times> UNIV \<and>
	\<Union>(snd ` IGs) \<subseteq> CX \<times> UNIV \<and>
	\<Union>(fst ` IGs) \<subseteq> guards \<and>
	X = \<Union>(X0 ` (snd ` IGs)) \<and>
	(\<forall>(I, G) \<in> IGs. flowsto (X0 G - trap \<times> UNIV) {0..} (CX \<times> UNIV) G))"
	unfolding reach_conts_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal for a b
	apply (erule flowsto_Diff_to_Union_funE)
	apply (force simp: split_beta')
	subgoal for f
	apply (rule exI[where x=f])
	by (auto simp: split_beta')
	done
	subgoal by (auto)
	subgoal by (auto)
	subgoal by (auto)
	done

	lemma leaves_halfspace[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "leaves_halfspace S (X::'n::enum rvec set) \<le>
	SPEC (\<lambda>b. case b of None \<Rightarrow> S = UNIV
	\| Some sctn \<Rightarrow>
	(S = below_halfspace sctn \<and> X \<subseteq> plane_of sctn \<and> (\<forall>x \<in> X. ode x \<bullet> normal sctn < 0)))"
	unfolding leaves_halfspace_def autoref_tag_defs op_set_to_list_def
	apply (refine_vcg, clarsimp_all)
	subgoal by (force simp add: halfspace_simps plane_of_def)
	done

	lemma poincare_start_on[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "poincare_start_on guards sctn (X0::'n eucl1 set) \<le> SPEC (\<lambda>(X1S, CX1S).
	fst ` (X1S \<union> (CX1S \<times> UNIV)) \<subseteq> Csafe \<and>
	fst ` X1S \<subseteq> sbelow_halfspace sctn \<and>
	fst ` (X1S \<union> (CX1S \<times> UNIV)) \<inter> guards = {} \<and>
	(X0 \<subseteq> (CX1S \<times> UNIV)) \<and>
	(\<forall>(x, d) \<in> CX1S \<times> UNIV. ode x \<bullet> normal sctn < 0) \<and>
	flowsto X0 pos_reals ((CX1S \<times> UNIV) \<inter> (sbelow_halfspace sctn \<times> UNIV)) X1S)"
	unfolding poincare_start_on_def autoref_tag_defs
	apply refine_vcg
	apply (rule FORWEAK_mono_rule[where I="\<lambda>X0S (X1S, CX1S).
	flowsto (\<Union>X0S) pos_reals ((CX1S \<times> UNIV) \<inter> sbelow_halfspace sctn \<times> UNIV) X1S \<and>
	fst ` (X1S \<union> (CX1S \<times> UNIV)) \<subseteq> Csafe \<and>
	(\<Union>X0S) \<subseteq> X0 \<and>
	(\<Union>X0S) \<subseteq> (CX1S \<times> UNIV) \<and>
	fst ` (X1S \<union> (CX1S \<times> UNIV)) \<inter> guards = {} \<and>
	(\<forall>(x, d) \<in> (CX1S \<times> UNIV). ode x \<bullet> normal sctn < 0) \<and>
	fst ` X1S \<subseteq> sbelow_halfspace sctn"])
	subgoal by (refine_vcg)
	subgoal for A B
	apply (refine_vcg)
	subgoal
	apply (auto simp: dest!: flowpipe_imp_flowsto)
	apply (rule flowsto_subset)
	apply (rule flowsto_stays_sbelow[where sctn=sctn])
	apply (rule flowsto_subset) apply assumption
	apply (rule order_refl)
	apply force
	apply (rule order_refl)
	apply (rule order_refl)
	apply (auto simp: halfspace_simps)
	apply (rule le_less_trans)
	prefer 2 apply assumption
	apply (drule bspec)
	apply (rule subsetD, assumption)
	prefer 2 apply assumption
	apply auto
	done
	subgoal by auto
	subgoal by force
	subgoal by (auto simp: dest!: flowpipe_source_subset)
	subgoal by auto
	subgoal
	apply (auto simp: halfspace_simps subset_iff)
	apply (rule le_less_trans[rotated], assumption)
	by fastforce
	done
	subgoal by (auto intro: flowsto_subset) force
	subgoal for a b c d
	using assms
	apply (refine_vcg, clarsimp_all)
	subgoal for e f g h i j k l m n
	apply (rule flowsto_source_unionI)
	subgoal
	apply (drule flowpipe_imp_flowsto, assumption)
	apply (rule flowsto_subset[OF flowsto_stays_sbelow[where sctn=sctn] order_refl])
	apply (rule flowsto_subset[OF _ order_refl], assumption)
	apply force
	apply (rule order_refl)
	apply (rule order_refl)
	apply (auto simp: halfspace_simps)
	apply (rule le_less_trans)
	prefer 2 apply assumption
	apply (drule bspec)
	apply (rule subsetD, assumption)
	prefer 2 apply assumption
	apply auto
	done
	by (auto intro!: flowsto_source_unionI dest!: flowpipe_imp_flowsto intro: flowsto_subset[OF _ order_refl])
	subgoal
	apply (auto simp: subset_iff)
	apply (auto simp: image_Un)
	done
	subgoal by auto
	subgoal by (auto dest!: flowpipe_source_subset)
	subgoal by auto
	subgoal
	apply (auto simp: halfspace_simps subset_iff)
	apply (rule le_less_trans[rotated], assumption)
	by fastforce
	subgoal by auto
	done
	subgoal by auto
	done

	lemma op_inter_fst_coll[le, refine_vcg]: "op_inter_fst_coll X Y \<le> SPEC (\<lambda>R. R = X \<inter> Y \<times> UNIV)"
	unfolding op_inter_fst_coll_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<inter> Y \<times> UNIV \<subseteq> R \<and> R \<subseteq> X \<inter> Y \<times> UNIV"])
	auto

	lemma scaleRe_ivl_coll_spec[le, refine_vcg]: "scaleRe_ivl_coll_spec l u X \<le> SPEC (\<lambda>Y. Y = scaleR2 l u X)"
	unfolding scaleRe_ivl_coll_spec_def
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. scaleR2 l u (\<Union>Xs) \<subseteq> R \<and> R \<subseteq> scaleR2 l u X"])
	apply (auto simp: intro: scaleR2_subset)
	subgoal
	by (force simp: intro: scaleR2_subset)
	done

	lemma do_intersection_spec_scaleR2I:
	"do_intersection_spec UNIV sctns ivl sctn (scaleR2 x1 x2 baa) (scaleR2 x1 x2 aca, x1b)"
	if "do_intersection_spec UNIV sctns ivl sctn (baa) (aca, x1b)"
	using that
	by (auto simp: do_intersection_spec_def intro!: poincare_mapsto_scaleR2I)
	(auto simp: scaleR2_def image_def vimage_def)

	lemma do_intersection_core[refine_vcg, le]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "do_intersection_core sctns ivl sctn (X::'n eucl1 set) \<le>
	SPEC (\<lambda>(P1, P2, CX, X0s).
	do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P1, CX) \<and>
	do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P2, CX)
	\<and> fst ` (X - X0s) \<subseteq> CX
	\<and> X0s \<subseteq> X)"
	unfolding do_intersection_core_def autoref_tag_defs
	apply (refine_vcg assms, clarsimp_all)
	subgoal by (rule do_intersection_spec_scaleR2I) (auto simp: do_intersection_spec_def intro!: )
	subgoal by (rule do_intersection_spec_scaleR2I) (auto simp: do_intersection_spec_def intro!: )
	subgoal by (fastforce simp: scaleR2_def)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	done

	lemma do_intersection_spec_Union:
	"do_intersection_spec S sctns ivl sctn (\<Union>X) A"
	if "\<And>x. x \<in> X \<Longrightarrow> do_intersection_spec S sctns ivl sctn x A"
	"X \<noteq> {}"
	using that(2)
	unfolding do_intersection_spec_def
	apply clarsimp
	apply safe
	subgoal by (rule poincare_mapsto_Union) (auto simp: do_intersection_spec_def dest!: that(1))
	subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
	subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
	subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
	subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
	subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
	subgoal by (force simp: do_intersection_spec_def dest!: that(1))
	subgoal by (auto simp: do_intersection_spec_def dest!: that(1))
	subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
	subgoal by (fastforce simp: do_intersection_spec_def dest!: that(1))
	done

	lemma do_intersection_spec_subset2:
	"do_intersection_spec S p ivl sctn X1 (ab, CY) \<Longrightarrow> CY \<subseteq> CX \<Longrightarrow> CX \<subseteq> Csafe \<Longrightarrow>
	CX \<inter> p = {} \<Longrightarrow> CX \<inter> ivl \<inter> plane_of sctn = {} \<Longrightarrow> X0 \<subseteq> X1 \<Longrightarrow>
	do_intersection_spec S p ivl sctn X0 (ab, CX)"
	by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset)

	lemma do_intersection_spec_Union3:
	"do_intersection_spec S osctns ivl csctns (\<Union>x\<in>X. a x) ((\<Union>x\<in>X. b x), (\<Union>x\<in>X. c x))"
	if "finite X" "X \<noteq> {}" "\<And>x. x \<in> X \<Longrightarrow> do_intersection_spec S osctns ivl csctns (a x) (b x, c x)"
	using that
	proof induction
	case empty
	- then show ?case by (auto simp: )
	+ then show ?case by auto
	next
	case (insert x F)
	show ?case
	apply (cases "F = {}")
	subgoal using insert by simp
	subgoal
	apply simp
	apply (rule do_intersection_spec_union)
	apply (rule insert.prems) apply simp
	apply (rule insert.IH)
	apply (assumption)
	apply (rule insert.prems) apply simp
	done
	done
	qed

	lemma do_intersection_coll[le]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "do_intersection_coll sctns ivl sctn (X::'n eucl1 set) \<le>
	SPEC (\<lambda>(P1, P2, CX, X0s).
	do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P1, CX) \<and>
	do_intersection_spec UNIV sctns ivl sctn (X - X0s) (P2, CX)
	\<and> fst ` (X - X0s) \<subseteq> CX
	\<and> X0s \<subseteq> X)"
	unfolding do_intersection_coll_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal
	apply (rule do_intersection_spec_subset[OF _ diff_subset])
	apply (rule do_intersection_spec_Union3)
	subgoal by auto
	subgoal by auto
	subgoal by auto
	done
	subgoal
	apply (rule do_intersection_spec_subset[OF _ diff_subset])
	apply (rule do_intersection_spec_Union3)
	subgoal by auto
	subgoal by auto
	subgoal by auto
	done
	subgoal by fastforce
	subgoal by fastforce
	done

	lemma
	do_intersection_flowsto_trans_outside:
	assumes "flowsto XS0 {0..} (CX \<times> UNIV) X1"
	assumes "do_intersection_spec UNIV guards ivl sctn X1 (P, CP)"
	assumes "fst ` X1 \<subseteq> CP"
	assumes "{x \<in> ivl. x \<in> plane_of sctn} \<inter> CX = {}"
	assumes "guards \<inter> (CX \<union> CP) = {}"
	assumes "XS0 \<subseteq> CX \<times> UNIV"
	assumes "closed ivl"
	assumes "CX \<subseteq> Csafe"
	shows "do_intersection_spec UNIV guards ivl sctn XS0 (P, CX \<union> CP)"
	using assms
	apply (auto simp: do_intersection_spec_def)
	subgoal
	apply (rule flowsto_poincare_trans, assumption, assumption)
	subgoal by simp
	subgoal by auto
	subgoal using assms(3) by auto
	subgoal by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def)
	subgoal premises prems for x d
	proof -
	have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
	by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
	from flowsto_poincare_mapsto_trans_flowsto[OF \<open>flowsto _ _ _ _\<close> \<open>poincare_mapsto _ _ _ _ _\<close> _ _ order_refl]
	have ft: "flowsto XS0 {0<..} (X1 \<union> CX \<times> UNIV \<union> CP \<times> UNIV) (fst ` P \<times> UNIV)"
	- by (auto simp: )
	+ by auto
	then have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
	apply (rule returns_to_flowstoI[OF _ _ _ _ _ _ order_refl])
	using prems by (auto simp: plane_of_def)
	have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
	apply (rule poincare_map_mem_flowstoI[OF ft])
	using prems by (auto simp: plane_of_def)
	from pm prems have "\<forall>\<^sub>F x in at (poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x) within
	plane_of sctn. x \<in> ivl"
	by auto
	from ret have "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x"
	apply (rule return_time_isCont_outside)
	using prems pm
	by (auto simp: eventually_at_filter plane_of_def intro!: assms derivative_eq_intros)
	then show "isCont (return_time {x \<in> ivl. x \<in> plane_of sctn}) x" by (simp add: plane_of_def)
	qed
	subgoal by simp
	done
	done

	lemma do_intersection_coll_flowsto[le]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	assumes ft: "flowsto X0 {0..} (CX0 \<times> UNIV) X"
	assumes X_subset: "X \<subseteq> CX0 \<times> UNIV"
	assumes X0_subset: "X0 \<subseteq> CX0 \<times> UNIV" and CX0_safe: "CX0 \<subseteq> Csafe"
	assumes ci: "closed ivl"
	assumes disj: "ivl \<inter> plane_of sctn \<inter> CX0 = {}" "sctns \<inter> CX0 = {}"
	shows "do_intersection_coll sctns ivl sctn (X::'n eucl1 set) \<le>
	SPEC (\<lambda>(P1, P2, CX, X0s).
	\<exists>A.
	do_intersection_spec UNIV sctns ivl sctn A (P1, CX0 \<union> CX) \<and>
	do_intersection_spec UNIV sctns ivl sctn A (P2, CX0 \<union> CX) \<and>
	flowsto (X0 - A) {0..} (CX0 \<times> UNIV) X0s \<and>
	A \<subseteq> X0 \<and>
	P1 \<inter> X0s = {} \<and>
	P2 \<inter> X0s = {})"
	apply (rule do_intersection_coll)
	apply (rule wd)
	proof (clarsimp, goal_cases)
	case (1 P1 P2 CX R)
	from ft have "flowsto X0 {0..} (CX0 \<times> UNIV) (X - R \<union> R)"
	by (rule flowsto_subset) auto
	from flowsto_union_DiffE[OF this]
	obtain A where AB: "A \<subseteq> X0"
	and A: "flowsto A {0..} (CX0 \<times> UNIV) (X - R)"
	and B: "flowsto (X0 - A) {0..} (CX0 \<times> UNIV) (R)"
	by auto
	have di: "do_intersection_spec UNIV sctns ivl sctn A (P1, CX0 \<union> CX)"
	apply (rule do_intersection_flowsto_trans_outside[OF A 1(1)])
	subgoal using 1 by simp
	subgoal using disj by auto
	subgoal using 1 disj by (auto simp: do_intersection_spec_def)
	subgoal using X0_subset AB by (auto simp: do_intersection_spec_def)
	subgoal using ci by simp
	subgoal using CX0_safe .
	done
	then have "P1 \<subseteq> (ivl \<inter> plane_of sctn) \<times> UNIV"
	by (auto simp: do_intersection_spec_def)
	then have disjoint: "P1 \<inter> R = {}"
	using \<open>R \<subseteq> X\<close> disj X_subset
	apply (auto simp: subset_iff)
	by (metis (no_types, lifting) Int_iff disjoint_iff_not_equal)

	have di2: "do_intersection_spec UNIV sctns ivl sctn A (P2, CX0 \<union> CX)"
	apply (rule do_intersection_flowsto_trans_outside[OF A 1(2)])
	subgoal using 1 by simp
	subgoal using disj by auto
	subgoal using 1 disj by (auto simp: do_intersection_spec_def)
	subgoal using X0_subset AB by (auto simp: do_intersection_spec_def)
	subgoal using ci by simp
	subgoal using CX0_safe .
	done
	then have "P2 \<subseteq> (ivl \<inter> plane_of sctn) \<times> UNIV"
	by (auto simp: do_intersection_spec_def)
	then have "P2 \<inter> R = {}"
	using \<open>R \<subseteq> X\<close> disj X_subset
	apply (auto simp: subset_iff)
	by (metis (no_types, lifting) Int_iff disjoint_iff_not_equal)
	from AB this disjoint di di2 B show ?case
	by (auto simp:)
	qed

	lemma op_enlarge_ivl_sctn[le, refine_vcg]:
	"op_enlarge_ivl_sctn ivl sctn d \<le> SPEC (\<lambda>ivl'. ivl \<subseteq> ivl')"
	unfolding op_enlarge_ivl_sctn_def
	apply refine_vcg
	unfolding plane_of_def
	apply (safe intro!: eventually_in_planerectI)
	apply (auto intro!: simp: eucl_le[where 'a='a] inner_sum_left inner_Basis if_distrib
	algebra_simps cong: if_cong)
	done

	lemma resolve_ivlplanes[le]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes
	"\<forall>x\<in>Xg. case x of (I, G) \<Rightarrow> flowsto (XSf G) {0..} (CXS \<times> UNIV) G"
	"(\<Union>x\<in>Xg. snd x) \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV"
	"CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV"
	"(\<Union>a\<in>Xg. XSf (snd a)) \<subseteq> (CXS::'a rvec set) \<times> UNIV"
	"(\<Union>x\<in>Xg. snd x) \<subseteq> CXS \<times> UNIV"
	"(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards"
	shows "resolve_ivlplanes guards ivlplanes Xg \<le> SPEC (\<lambda>PS.
	CXS \<inter> (guards \<union> ivlplanes) = {} \<and>
	CXS \<subseteq> Csafe \<and>
	(\<exists>R0 P0. (\<Union>x\<in>PS. P0 x) \<union> (\<Union>x\<in>PS. R0 x) = (\<Union>a\<in>Xg. XSf (snd a))\<and>
	(\<forall>x\<in>PS. case x of (X, P1, P2, R, ivl, sctn, CX) \<Rightarrow>
	ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl \<and>
	P0 (X, P1, P2, R, ivl, sctn, CX) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX) = {} \<and>
	R0 (X, P1, P2, R, ivl, sctn, CX) \<subseteq> (CXS \<times> UNIV) \<and>
	flowsto (R0 (X, P1, P2, R, ivl, sctn, CX)) {0..} (CXS \<times> UNIV) R \<and>
	do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P1, CXS \<union> CX) \<and>
	do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P2, CXS \<union> CX))))"
	using assms
	unfolding resolve_ivlplanes_def
	apply clarsimp_all
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xgs PS.
	(\<exists>R0 P0.
	snd ` Xgs \<subseteq> fst ` PS \<and> fst ` PS \<subseteq> snd ` Xg \<and>
	(\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> PS.
	P0 (X, P1, P2, R, ivl, sctn, CX) \<union> R0 (X, P1, P2, R, ivl, sctn, CX) = XSf X
	\<and> ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
	\<and> P0 (X, P1, P2, R, ivl, sctn, CX) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX) = {}
	\<and> R0 (X, P1, P2, R, ivl, sctn, CX) \<subseteq> (CXS \<times> UNIV)
	\<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX)) {0..} (CXS \<times> UNIV) R
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P1, CXS \<union> CX)
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX)) (P2, CXS \<union> CX)))"],
	clarsimp_all)
	using [[goals_limit=1]]
	subgoal by auto
	subgoal by auto
	subgoal for a b c
	apply (frule bspec, assumption, clarsimp)
	apply (rule do_intersection_coll_flowsto)
	apply (rule wd)
	apply assumption
	apply force
	apply force
	apply blast
	apply assumption
	subgoal premises prems
	proof -
	have "(b \<inter> plane_of c, a) \<in> Xg" using prems by simp
	with \<open>(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards\<close>
	have "b \<inter> plane_of c \<subseteq> ivlplanes \<union> guards"
	by (force simp: subset_iff)
	then show ?thesis
	using \<open>CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV\<close>
	by auto
	qed
	subgoal by (auto simp: subset_iff)
	subgoal apply (refine_vcg, clarsimp_all) apply force
	apply (intro exI conjI)defer defer defer apply assumption+
	apply simp
	apply force
	apply force
	apply force
	done
	done
	subgoal by (auto simp: subset_iff) blast
	subgoal for a b c d e f R0 P0
	apply (frule bspec, assumption, clarsimp)
	apply (rule do_intersection_coll_flowsto)
	apply (rule wd)
	apply assumption
	subgoal
	apply (rule order_trans[where y="(\<Union>x\<in>Xg. snd x)"])
	by auto
	subgoal
	apply (rule order_trans) defer apply assumption
	by auto
	subgoal by blast
	subgoal by simp
	subgoal premises prems
	proof -
	have "(d \<inter> plane_of e, c) \<in> Xg" using prems by simp
	with \<open>(\<Union>x\<in>Xg. fst x) \<subseteq> ivlplanes \<union> guards\<close>
	have "d \<inter> plane_of e \<subseteq> ivlplanes \<union> guards"
	by (force simp: subset_iff)
	then show ?thesis
	using \<open>CXS \<times> UNIV \<subseteq> (Csafe - (ivlplanes \<union> guards)) \<times> UNIV\<close>
	by auto
	qed
	subgoal by (auto simp: subset_iff)
	subgoal
	apply (refine_vcg, clarsimp_all)
	subgoal by (auto simp: subset_iff)
	- subgoal by (auto simp: )
	+ subgoal by auto
	subgoal for x1 x1' x2 x3 A
	apply (rule exI[where x="R0((c, x1, x1', x3, d, e, x2):=(XSf c - A))"])
	apply (rule exI[where x="P0((c, x1, x1', x3, d, e, x2):=A)"])
	apply clarsimp
	apply (rule conjI)
	subgoal by auto
	apply (rule conjI)
	subgoal premises prems
	using prems
	apply (auto simp: subset_iff)
	by fastforce
	apply clarsimp
	subgoal
	apply (drule bspec, assumption)
	apply (drule bspec, assumption)
	by force
	done
	done
	done
	subgoal by (auto simp: subset_iff)
	subgoal by (auto simp: subset_iff)
	subgoal for a R0 P0
	apply (rule exI[where x=R0])
	apply (rule exI[where x=P0])
	apply (rule conjI)
	subgoal premises prems
	proof -
	note prems
	show ?thesis
	using prems(9,8)
	by fastforce
	qed
	by auto
	done


	lemma poincare_onto[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le>
	SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
	assumes CXS0: "CXS0 \<inter> (guards \<union> ivlplanes) = {}"
	shows "poincare_onto ro symstart trap guards ivlplanes (XS0::'a eucl1 set) CXS0 \<le>
	SPEC (\<lambda>PS.
	(\<exists>R0 P0.
	\<Union>(P0 ` PS \<union> R0 ` PS) = XS0 - trap \<times> UNIV \<and>
	(\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
	ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
	\<and> XS0 \<subseteq> CXS \<times> UNIV \<and> CXS0 \<subseteq> CXS \<and> CXS \<inter> (guards \<union> ivlplanes) = {}
	\<and> P0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) = {}
	\<and> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV
	\<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX, CXS)) {0..} (CXS \<times> UNIV) R
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))
	))"
	unfolding poincare_onto_def autoref_tag_defs
	using [[goals_limit=1]]
	apply (refine_vcg, clarsimp_all)
	apply (refine_vcg resolve_ivlplanes[OF wd])
	subgoal by force
	apply clarsimp
	subgoal for a b c d R0 P0
	apply (rule exI[where x="\<lambda>(X, P1, P2, R, ivl, sctn, CX, CXS). R0 (X, P1, P2, R, ivl, sctn, CX)"])
	apply (rule exI[where x="\<lambda>(X, P1, P2, R, ivl, sctn, CX, CXS). P0 (X, P1, P2, R, ivl, sctn, CX)"])
	apply (rule conjI)
	subgoal premises prems
	using \<open>(\<Union>x\<in>d. P0 x) \<union> (\<Union>x\<in>d. R0 x) = (\<Union>x\<in>b. c (snd x)) - trap \<times> UNIV\<close>
	by auto
	subgoal
	apply clarsimp
	apply (drule bspec, assumption)+
	apply (rule conjI, force)
	apply (rule conjI, force)
	apply (rule conjI, force)
	apply (rule conjI)
	- subgoal using CXS0 by (auto simp: )
	+ subgoal using CXS0 by auto
	apply (rule conjI, force)
	apply (rule conjI, force)
	apply (rule conjI)
	subgoal by (auto intro: flowsto_subset)
	subgoal
	apply clarsimp
	apply (rule conjI)
	subgoal
	apply (rule do_intersection_spec_subset2, assumption)
	subgoal by force
	subgoal by (force simp: do_intersection_spec_def)
	subgoal using CXS0 by (auto simp: do_intersection_spec_def)
	subgoal using CXS0 by (auto simp: do_intersection_spec_def)
	subgoal by auto
	done
	subgoal
	apply (rule do_intersection_spec_subset2, assumption)
	subgoal by force
	subgoal by (force simp: do_intersection_spec_def)
	subgoal using CXS0 by (auto simp: do_intersection_spec_def)
	subgoal using CXS0 by (auto simp: do_intersection_spec_def)
	subgoal by auto
	done
	done
	done
	done
	done

	lemma empty_remainders[le, refine_vcg]:
	"empty_remainders PS \<le> SPEC (\<lambda>b. b \<longrightarrow> (\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> PS. R = {}))"
	unfolding empty_remainders_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs b. b \<longrightarrow> (\<forall>(X, P1, P2, R, ivl, sctn, CX) \<in> Xs. R = {})"])
	auto

	lemma poincare_onto_empty[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes CXS0: "CXS0 \<inter> (guards \<union> ivlplanes) = {}"
	shows "poincare_onto_empty ro guards ivlplanes (XS0::'a eucl1 set) CXS0 \<le>
	SPEC (\<lambda>(PS).
	(\<exists>R0 P0.
	\<Union>(P0 ` PS \<union> R0 ` PS) = XS0 \<and>
	(\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
	ivl \<inter> plane_of sctn \<subseteq> ivlplanes \<and> closed ivl
	\<and> XS0 \<subseteq> CXS \<times> UNIV \<and> CXS0 \<subseteq> CXS \<and> CXS \<inter> (guards \<union> ivlplanes) = {}
	\<and> P0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<inter> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) = {}
	\<and> R0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV
	\<and> flowsto (R0 (X, P1, P2, R, ivl, sctn, CX, CXS)) {0..} (CXS \<times> UNIV) R
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)
	\<and> do_intersection_spec UNIV guards ivl sctn (P0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))
	))"
	using CXS0
	unfolding poincare_onto_empty_def autoref_tag_defs
	by (refine_vcg) (auto intro!: flowsto_self)

	lemma do_intersection_spec_union2:
	assumes "do_intersection_spec S osctns ivl csctns a (b, c)"
	"do_intersection_spec S osctns ivl csctns f (b, c)"
	shows "do_intersection_spec S osctns ivl csctns (a \<union> f) (b, c)"
	using do_intersection_spec_union[OF assms]
	by auto

	lemma poincare_onto2[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le>
	SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X)"
	notes [refine_vcg_def] = op_set_ndelete_spec
	shows "poincare_onto2 ro symstart trap guards ivlplanes (XS0::'a eucl1 set) \<le>
	SPEC (\<lambda>(PS).
	(\<exists>P0. \<Union>(P0 ` PS) = XS0 - trap \<times> UNIV \<and>
	(\<forall>(s, X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS.
	XS0 \<subseteq> CXS \<times> UNIV \<and>
	do_intersection_spec UNIV guards ivl sctn (P0 (s, X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
	do_intersection_spec UNIV guards ivl sctn (P0 (s, X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX))))"
	unfolding poincare_onto2_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal for PS R0 P0
	apply (rule FORWEAK_mono_rule_empty[where I="\<lambda>PS1 PS2.
	(\<exists>X0.
	\<Union>(R0 ` PS1) \<subseteq> \<Union>(X0 ` PS2) \<and>
	(\<forall>(X, P1, P2, R, ivl, sctn, CX, CXS) \<in> PS2.
	XS0 \<subseteq> CXS \<times> UNIV \<and>
	do_intersection_spec UNIV guards ivl sctn (X0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
	do_intersection_spec UNIV guards ivl sctn (X0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)))"])
	subgoal by refine_vcg
	subgoal by auto
	subgoal by auto
	subgoal
	apply clarsimp
	subgoal for c
	apply (rule exI[where x=c])
	apply (rule conjI)
	apply (rule order_trans) prefer 2 apply assumption
	apply (rule UN_mono) apply assumption apply (rule order_refl) apply assumption
	done
	done
	subgoal for \<sigma>
	apply (clarsimp)
	subgoal for X0
	apply (rule exI[where x="\<lambda>(b, x). (if b then X0 x else P0 x) \<inter> XS0 - trap \<times> UNIV "])
	apply (rule conjI)
	subgoal premises prems
	using \<open>(\<Union>x\<in>PS. P0 x) \<union> (\<Union>x\<in>PS. R0 x) = XS0 - trap \<times> UNIV\<close>
	\<open>(\<Union>x\<in>PS. R0 x) \<subseteq> (\<Union>x\<in>\<sigma>. X0 x)\<close>
	by auto
	subgoal by (auto intro: do_intersection_spec_subset)
	done
	done
	apply clarsimp
	subgoal for a b b' c d e f g h i j
	apply (cases "c = {}")
	subgoal by (auto intro!: exI[where x="j"])
	subgoal
	using [[goals_limit=1]]
	apply clarsimp
	apply refine_vcg
	subgoal premises prems for k l
	proof -
	note prems
	then show ?thesis
	apply -
	apply (drule bspec, assumption)+
	apply clarsimp
	subgoal premises prems
	using \<open>g \<inter> (guards \<union> \<Union>k) = {}\<close> \<open>l = k - {d \<inter> plane_of e} \<or> l = k\<close> \<open>d \<inter> plane_of e \<subseteq> \<Union>k\<close>
	by auto
	done
	qed
	apply simp
	apply (drule bspec, assumption)
	apply simp
	apply (erule exE conjE)+
	subgoal for k l m n p q
	apply (subgoal_tac "\<And>x. x \<in> m \<Longrightarrow> p x = {}")
	defer
	subgoal for x
	proof goal_cases
	case 1
	from 1(10,15,24)
	show ?case
	by (auto dest!: bspec[where x=x])
	qed
	apply simp
	subgoal premises prems
	proof -
	note prems
	from prems have "finite (q ` m)" "flowsto (R0 (a, b, b', c, d, e, f, g)) {0..} (g \<times> UNIV) (\<Union>(q ` m))"
	by auto
	from flowsto_Union_funE[OF this]
	obtain XGs where
	XGs: "\<And>G. G \<in> q ` m \<Longrightarrow> flowsto (XGs G) {0..} (g \<times> UNIV) G"
	"R0 (a, b, b', c, d, e, f, g) = \<Union>(XGs ` (q ` m))"
	by metis
	define q0 where "q0 = XGs o q"
	have "case x of (X, P1, P2, R, ivl, sctn, CX, CXS) \<Rightarrow>
	do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX) \<and>
	do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)"
	if "x \<in> m"
	for x
	proof (clarsimp, goal_cases)
	case (1 X P1 P2 R ivl sctn CX CXS)
	with prems(10)[rule_format, OF \<open>x \<in> m\<close>] prems(15)[rule_format, OF \<open>x \<in> m\<close>] \<open>_ = c\<close>
	have *: "R = {}"
	"x = (X, P1, P2, {}, ivl, sctn, CX, CXS)"
	"ivl \<inter> plane_of sctn \<subseteq> \<Union>l"
	"closed ivl"
	"c \<subseteq> CXS \<times> UNIV"
	"g \<subseteq> CXS"
	"\<Union>(q ` m) \<subseteq> CXS \<times> UNIV"
	"CXS \<inter> (guards \<union> \<Union>l) = {}"
	"p (X, P1, P2, {}, ivl, sctn, CX, CXS) = {}"
	"p (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> CXS \<times> UNIV"
	"do_intersection_spec UNIV guards ivl sctn (q (X, P1, P2, {}, ivl, sctn, CX, CXS)) (P1, CXS \<union> CX)"
	"do_intersection_spec UNIV guards ivl sctn (q (X, P1, P2, {}, ivl, sctn, CX, CXS)) (P2, CXS \<union> CX)"
	by auto
	have "do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P1, (CXS \<union> CX) \<union> (CXS \<union> CX))"
	apply (rule do_intersection_flowsto_trans_outside)
	apply (simp add: q0_def)
	apply (rule flowsto_subset)
	apply (rule XGs)
	using \<open>x \<in> m\<close> apply (rule imageI)
	using 1 apply force
	apply force
	using * apply force
	apply (rule order_refl)
	using * apply (auto intro!: *)[]
	subgoal
	using * \<open>x \<in> m\<close>
	by (auto simp add: )
	subgoal using * by (auto simp: do_intersection_spec_def)
	subgoal using * by (auto simp: do_intersection_spec_def)
	subgoal
	proof -
	have "q0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> XGs (q x)"
	by (auto simp: q0_def 1)
	also have "\<dots> \<subseteq> R0 (a, b, b', c, d, e, f, g)" using \<open>x \<in>m\<close> XGs by auto
	also have "\<dots> \<subseteq> (CXS \<union> CX) \<times> UNIV"
	using prems(20) \<open>g \<subseteq> CXS\<close> by auto
	finally show ?thesis by simp
	qed
	subgoal by fact
	subgoal using * by (auto simp: do_intersection_spec_def)
	done
	moreover have "do_intersection_spec UNIV guards ivl sctn (q0 (X, P1, P2, R, ivl, sctn, CX, CXS)) (P2, (CXS \<union> CX) \<union> (CXS \<union> CX))"
	apply (rule do_intersection_flowsto_trans_outside)
	apply (simp add: q0_def)
	apply (rule flowsto_subset)
	apply (rule XGs)
	using \<open>x \<in> m\<close> apply (rule imageI)
	using 1 apply force
	apply force
	using * apply force
	apply (rule order_refl)
	using * apply (auto intro!: *)[]
	subgoal
	using * \<open>x \<in> m\<close>
	by (auto simp add: )
	subgoal using * by (auto simp: do_intersection_spec_def)
	subgoal using * by (auto simp: do_intersection_spec_def)
	subgoal
	proof -
	have "q0 (X, P1, P2, R, ivl, sctn, CX, CXS) \<subseteq> XGs (q x)"
	by (auto simp: q0_def 1)
	also have "\<dots> \<subseteq> R0 (a, b, b', c, d, e, f, g)" using \<open>x \<in>m\<close> XGs by auto
	also have "\<dots> \<subseteq> (CXS \<union> CX) \<times> UNIV"
	using prems(20) \<open>g \<subseteq> CXS\<close> by auto
	finally show ?thesis by simp
	qed
	subgoal by fact
	subgoal using * by (auto simp: do_intersection_spec_def)
	done
	ultimately show ?case
	- by (simp add: )
	+ by simp
	qed note q0 = this
	have q0': "(a, aa, aa', ab, ac, ad, ae, b) \<in> m \<Longrightarrow> XS0 \<subseteq> b \<times> UNIV" for a aa aa' ab ac ad ae b
	apply (drule prems(15)[rule_format])
	using \<open>XS0 \<subseteq> g \<times> UNIV\<close>
	by auto
	from prems
	show ?thesis
	apply (intro exI[where x="\<lambda>x. if x \<in> i \<inter> m then j x \<union> q0 x else if x \<in> i then j x else q0 x"] conjI)
	subgoal 1 premises prems
	unfolding XGs
	apply simp
	by (auto simp: q0_def)
	subgoal premises _
	by (rule order_trans[OF \<open>(\<Union>x\<in>h. R0 x) \<subseteq> (\<Union>x\<in>i. j x)\<close>]) auto
	subgoal premises _ using prems(6)[rule_format] q0
	apply auto
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	subgoal by (auto intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0' intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	subgoal by (auto dest!: prems(6)[rule_format] q0 intro!: do_intersection_spec_union2)
	done
	done
	qed
	done
	done
	done
	done
	done

	lemma width_spec_ivl[THEN order_trans, refine_vcg]: "width_spec_ivl M X \<le> SPEC (\<lambda>x. True)"
	unfolding width_spec_ivl_def
	by (refine_vcg)

	lemma partition_ivl_spec[le, refine_vcg]:
	shows "partition_ivl cg XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
	using [[simproc del: defined_all]]
	unfolding partition_ivl_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all)
	subgoal by fastforce
	subgoal by fastforce
	subgoal by fastforce
	subgoal by fastforce
	subgoal premises prems for a b c d e f ws g h i j k l m n
	proof -
	note prems
	have disj: "\<And>A Aa. n \<notin> A \<or> \<not> XS \<inter> A \<subseteq> Aa \<or> n \<in> Aa"
	using prems by blast
	then have "n \<in> g"
	using prems by (metis (no_types) Un_iff atLeastAtMost_iff subset_iff)
	then show ?thesis
	using disj prems by (meson atLeastAtMost_iff)
	qed
	done

	lemma op_inter_fst_ivl_scaleR2[le,refine_vcg]:
	"op_inter_fst_ivl_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) = R)"
	unfolding op_inter_fst_ivl_scaleR2_def
	apply refine_vcg
	apply (auto simp: scaleR2_def)
	subgoal for a b c d e f g h i j k
	by (rule image_eqI[where x="(i, (j, k))"]; fastforce)
	subgoal for a b c d e f g h i j k
	by (rule image_eqI[where x="(i, (j, k))"]; fastforce)
	done

	lemma op_inter_fst_ivl_coll_scaleR2[le,refine_vcg]:
	"op_inter_fst_ivl_coll_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) = R)"
	unfolding op_inter_fst_ivl_coll_scaleR2_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. (\<Union>Xs) \<inter> (Y \<times> UNIV) \<subseteq> R \<and> R \<subseteq> X \<inter> (Y \<times> UNIV)"])
	auto

	lemma op_inter_ivl_co[le, refine_vcg]: "op_ivl_of_ivl_coll X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding op_ivl_of_ivl_coll_def
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>R (l, u). \<Union>R \<subseteq> {l .. u}"])
	apply auto
	apply (metis Set.basic_monos(7) Sup_le_iff atLeastAtMost_iff inf.coboundedI2 inf_sup_aci(1))
	by (meson Set.basic_monos(7) UnionI atLeastAtMost_iff le_supI1)

	lemma op_inter_ivl_coll_scaleR2[le,refine_vcg]:
	"op_inter_ivl_coll_scaleR2 X Y \<le> SPEC (\<lambda>R. X \<inter> (Y \<times> UNIV) \<subseteq> R)"
	unfolding op_inter_ivl_coll_scaleR2_def
	apply refine_vcg
	subgoal for _ _ _ A l u
	by (auto, rule scaleR2_subset[where i'=l and j'=u and k'=A], auto)
	done

	lemma [le, refine_vcg]: "op_image_fst_ivl_coll X \<le> SPEC (\<lambda>R. R = fst ` X)"
	unfolding op_image_fst_ivl_coll_def
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. fst ` (\<Union>Xs) \<subseteq> R \<and> R \<subseteq> fst ` X"])
	apply auto
	apply force+
	done

	lemma op_single_inter_ivl[le, refine_vcg]: "op_single_inter_ivl a fxs \<le> SPEC (\<lambda>R. a \<inter> fxs \<subseteq> R)"
	unfolding op_single_inter_ivl_def
	by refine_vcg auto

	lemma partition_ivle_spec[le, refine_vcg]:
	shows "partition_ivle cg XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
	unfolding partition_ivle_def autoref_tag_defs
	supply [refine_vcg del] = scaleR2_rep_of_coll2
	and [refine_vcg] = scaleR2_rep_of_coll
	apply (refine_vcg)
	subgoal by (fastforce simp: scaleR2_def)
	subgoal by auto
	apply clarsimp
	subgoal by (fastforce simp: scaleR2_def)
	done


	lemma vec1repse[THEN order_trans, refine_vcg]:
	"vec1repse CX \<le> SPEC (\<lambda>R. case R of None \<Rightarrow> True \| Some X \<Rightarrow> X = vec1_of_flow1 ` CX)"
	unfolding vec1repse_def
	apply (refine_vcg FORWEAK_mono_rule[where
	I="\<lambda>XS R. case R of None \<Rightarrow> True \| Some R \<Rightarrow> vec1_of_flow1 ` (\<Union>XS) \<subseteq> R \<and> R \<subseteq> vec1_of_flow1 ` CX"])
	apply (auto simp: scaleR2_def split: option.splits)
	subgoal for a b c d e f g h i j
	apply (auto simp: vimage_def image_def)
	apply (rule exI[where x="h"])
	apply auto
	apply (rule exI[where x=f])
	apply (rule exI[where x="matrix j"])
	apply auto
	apply (rule bexI)
	by (auto simp: vec1_of_flow1_def matrix_scaleR)
	subgoal for a b c d e f g h i j
	apply (rule bexI)
	defer apply assumption
	apply (rule image_eqI[where x="(f, g, j)"])
	by (auto simp: flow1_of_vec1_def vec1_of_flow1_def matrix_scaleR[symmetric])
	subgoal by fastforce
	subgoal for a b c d e f g h i j k l
	apply (auto simp: vimage_def image_def)
	apply (rule exI[where x="j"])
	apply auto
	apply (rule exI[where x=h])
	apply (rule exI[where x="matrix l"])
	apply auto
	apply (rule bexI)
	by (auto simp: vec1_of_flow1_def matrix_scaleR)
	subgoal by fastforce
	subgoal for a b c d e f g h i j k l
	apply (rule bexI)
	defer apply assumption
	apply (rule image_eqI[where x="(h, i, l)"])
	by (auto simp: flow1_of_vec1_def vec1_of_flow1_def matrix_scaleR[symmetric])
	done

	lemma scaleR2_rep1[le, refine_vcg]: "scaleR2_rep1 Y \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
	unfolding scaleR2_rep1_def
	apply refine_vcg
	subgoal by (auto simp: norm2_slp_def)
	subgoal for a b c d e y z f g h i j prec k l m n p q r s
	apply (auto simp: scaleR2_def image_def vimage_def)
	subgoal premises prems for B C D E
	proof -
	define ij where "ij = (i + j) / 2"
	from prems
	have "ij > 0"
	by (auto simp: ij_def)
	show ?thesis
	unfolding ij_def[symmetric]
	apply (rule exI[where x="1 / ij * B"])
	apply (intro conjI) prefer 3
	apply (rule bexI[where x="(D, ij *\<^sub>R E)"])
	subgoal using \<open>ij > 0\<close> by auto
	subgoal
	using prems
	using \<open>(D, E) \<in> c\<close> \<open>c \<subseteq> {(n, p)..(q, r)}\<close> \<open>ij > 0\<close>
	by (auto simp: ij_def[symmetric] intro!: scaleR_left_mono)
	subgoal
	using \<open>d \<le> ereal B\<close> \<open>0 < ij\<close> \<open>0 < d\<close>
	apply (cases d)
	apply (simp only: times_ereal.simps ereal_less_eq)
	apply (rule mult_mono)
	apply (rule real_divl)
	by auto
	subgoal
	using \<open>0 < d\<close> \<open>d \<le> ereal B\<close> \<open>ereal B \<le> e\<close> \<open>0 < ij\<close> \<open>0 < e\<close>
	\<open>0 < real_divr prec 1 ((i + j) / 2)\<close>
	unfolding ij_def[symmetric]
	apply (cases e; cases d)
	apply (simp only: times_ereal.simps ereal_less_eq)
	apply (rule mult_mono)
	apply (rule real_divr)
	by auto
	done
	qed
	done
	done

	lemma reduce_ivl[le, refine_vcg]: "reduce_ivl Y b \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
	unfolding reduce_ivl_def
	apply refine_vcg
	apply (auto simp add: scaleR2_def image_def vimage_def plane_of_def )
	proof goal_cases
	case (1 i0 i1 s0 s1 y0 y1)
	from 1 have le: "1 \<le> (y1 \<bullet> b) / (i1 \<bullet> b)"
	by (auto simp: min_def dest!: inner_Basis_mono[OF _ \<open>b \<in> Basis\<close>])
	show ?case
	apply (rule exI[where x="(y1 \<bullet> b) / (i1 \<bullet> b)"])
	apply (rule conjI) apply fact
	apply (rule bexI[where x="(y0, ((i1 \<bullet> b) / (y1 \<bullet> b)) *\<^sub>R y1)"])
	subgoal using 1 le by simp
	subgoal using 1 le apply simp
	apply (rule conjI)
	subgoal
	apply (auto simp: eucl_le[where 'a="'c"])
	apply (auto simp: divide_simps)
	apply (subst mult.commute)
	subgoal for i
	apply (cases " y1 \<bullet> b \<le> i1 \<bullet> b")
	apply (rule order_trans)
	apply (rule mult_left_mono[where b="y1 \<bullet> i"])
	apply (auto simp: mult_le_cancel_right)
	apply (cases "i1 \<bullet> i \<le> 0")
	apply (rule order_trans)
	apply (rule mult_right_mono_neg[where b="i1 \<bullet> b"])
	apply auto
	by (auto simp: not_le inner_Basis split: if_splits dest!: bspec[where x=i])
	done
	subgoal
	apply (auto simp: eucl_le[where 'a="'c"])
	subgoal for i
	apply (cases "i = b")
	apply (auto simp: divide_simps)
	subgoal by (auto simp: divide_simps algebra_simps)
	subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
	apply (subst mult.commute)
	apply (rule order_trans)
	apply (rule mult_right_mono[where b="s1 \<bullet> i"]) apply simp
	apply simp
	apply (rule mult_left_mono)
	by auto
	done
	done
	done
	done
	next
	case (2 i0 i1 s0 s1 y0 y1)
	from 2 have le: "1 \<le> (y1 \<bullet> b) / (s1 \<bullet> b)"
	by (auto simp: min_def abs_real_def divide_simps dest!: inner_Basis_mono[OF _ \<open>b \<in> Basis\<close>])
	show ?case
	apply (rule exI[where x="(y1 \<bullet> b) / (s1 \<bullet> b)"])
	apply (rule conjI) apply fact
	apply (rule bexI[where x="(y0, ((s1 \<bullet> b) / (y1 \<bullet> b)) *\<^sub>R y1)"])
	subgoal using 2 le by simp
	subgoal using 2 le apply simp
	apply (rule conjI)
	subgoal
	apply (auto simp: eucl_le[where 'a="'c"])
	subgoal for i
	apply (cases "i = b")
	apply (auto simp: divide_simps)
	subgoal by (auto simp: divide_simps algebra_simps)
	subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
	apply (subst mult.commute)
	apply (cases "y1 \<bullet> i \<le> 0")
	apply (rule order_trans)
	apply (rule mult_left_mono_neg[where b="y1 \<bullet> b"])
	apply (auto simp: mult_le_cancel_right not_le)
	apply (rule order_trans)
	apply (rule mult_right_mono_neg[where b="i1 \<bullet> i"])
	apply (auto intro!: mult_left_mono_neg)
	done
	done
	done
	subgoal
	apply (auto simp: eucl_le[where 'a="'c"])
	subgoal for i
	apply (cases "i = b")
	subgoal by (auto simp: divide_simps algebra_simps)
	subgoal apply (auto simp: divide_simps algebra_simps inner_Basis)
	apply (subst mult.commute)
	apply (cases "y1 \<bullet> i \<ge> 0")
	apply (rule order_trans)
	apply (rule mult_left_mono_neg[where b="y1 \<bullet> i"]) apply simp
	apply simp
	apply (rule mult_right_mono) apply force
	apply force
	proof -
	assume a1: "\<forall>i\<in>Basis. s1 \<bullet> b * (if b = i then 1 else 0) \<le> s1 \<bullet> i"
	assume a2: "i \<in> Basis"
	assume a3: "i \<noteq> b"
	assume a4: "y1 \<bullet> b < 0"
	assume a5: "s1 \<bullet> b < 0"
	assume a6: "\<not> 0 \<le> y1 \<bullet> i"
	have "s1 \<bullet> b * (if b = i then 1 else 0) \<le> s1 \<bullet> i"
	using a2 a1 by metis
	then have f7: "0 \<le> s1 \<bullet> i"
	using a3 by (metis (full_types) mult_zero_right)
	have f8: "y1 \<bullet> b \<le> 0"
	using a4 by (metis eucl_less_le_not_le)
	have "s1 \<bullet> b \<le> 0"
	using a5 by (metis eucl_less_le_not_le)
	then show "y1 \<bullet> b * (s1 \<bullet> i) \<le> s1 \<bullet> b * (y1 \<bullet> i)"
	using f8 f7 a6 by (metis mult_right_mono_le mult_zero_left zero_le_mult_iff zero_le_square)
	qed
	done
	done
	done
	done
	qed

	lemma reduce_ivle[le, refine_vcg]:
	"reduce_ivle Y b \<le> SPEC (\<lambda>R. Y \<subseteq> R)"
	using [[simproc del: defined_all]]
	unfolding reduce_ivle_def
	apply refine_vcg
	apply (auto simp: scaleR2_def image_def vimage_def)
	subgoal for a b c d e f g h i j k
	apply (drule subsetD, assumption)
	apply auto
	subgoal for l m
	apply (rule exI[where x="l * g"])
	apply (intro conjI)
	subgoal
	unfolding times_ereal.simps[symmetric]
	apply (rule ereal_mult_mono)
	subgoal by (cases e) auto
	subgoal by (cases b) auto
	subgoal by (cases b) auto
	subgoal by (cases e) auto
	done
	subgoal
	unfolding times_ereal.simps[symmetric]
	apply (rule ereal_mult_mono)
	subgoal by (cases b) auto
	subgoal by (cases b) auto
	subgoal by (cases b) auto
	subgoal by (cases e) auto
	done
	subgoal by force
	done
	done
	done


	lemma reduces_ivle[le, refine_vcg]:
	"reduces_ivle X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding reduces_ivle_def
	by refine_vcg auto

	lemma ivlse_of_setse[le, refine_vcg]: "ivlse_of_setse X \<le> SPEC (\<lambda>R. X \<subseteq> R)"
	unfolding ivlse_of_setse_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<subseteq> R"])
	(auto simp: scaleR2_def image_def vimage_def)

	lemma setse_of_ivlse[le, refine_vcg]:
	"setse_of_ivlse X \<le> SPEC (\<lambda>R. R = X)"
	unfolding setse_of_ivlse_def
	apply (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xs R. \<Union>Xs \<subseteq> R \<and> R \<subseteq> X"])
	apply clarsimp_all
	subgoal by (rule bexI)
	subgoal by auto
	subgoal by auto
	subgoal by auto
	done

	lemma partition_set_spec[le, refine_vcg]:
	shows "partition_set ro XS \<le> SPEC (\<lambda>YS. XS \<subseteq> YS)"
	unfolding partition_set_def autoref_tag_defs
	apply (refine_vcg)
	subgoal by (fastforce simp: scaleR2_def vimage_def image_def)
	subgoal by fastforce
	done

	lemma partition_sets_spec[le, refine_vcg]:
	shows "partition_sets ro XS \<le> SPEC (\<lambda>YS. (\<Union>(_, _, PS, _, _, _, _, _) \<in> XS. PS) \<subseteq> YS)"
	unfolding partition_sets_def autoref_tag_defs
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>X Y. (\<Union>(_, _, PS, _, _, _, _, _) \<in> X. PS) \<subseteq> Y"]) auto

	lemma
	do_intersection_poincare_mapstos_trans:
	assumes pm: "\<And>i. i \<in> I \<Longrightarrow> poincare_mapsto (p i) (X0 i) UNIV (CX i) (X1 i)"
	assumes di: "do_intersection_spec UNIV guards ivl sctn (\<Union>i\<in>I. X1 i) (P, CP)"
	assumes "\<And>i. i \<in> I \<Longrightarrow> fst ` (X1 i) \<subseteq> CP"
	assumes "\<And>i. i \<in> I \<Longrightarrow> {x \<in> ivl. x \<in> plane_of sctn} \<inter> CX i = {}"
	assumes "\<And>i. i \<in> I \<Longrightarrow> guards \<inter> (CX i \<union> CP) = {}"
	assumes "\<And>i. i \<in> I \<Longrightarrow> X0 i \<subseteq> CX i \<times> UNIV"
	assumes "\<And>i. i \<in> I \<Longrightarrow> closed (p i)"
	assumes "closed ivl"
	assumes "\<And>i. i \<in> I \<Longrightarrow> CX i \<subseteq> Csafe"
	shows "do_intersection_spec UNIV guards ivl sctn (\<Union>i\<in>I. X0 i) (P, (\<Union>i\<in>I. CX i) \<union> CP)"
	apply (auto simp: do_intersection_spec_def)
	subgoal
	apply (simp del: UN_simps add: UN_extend_simps)
	apply (rule impI)
	apply (thin_tac "I \<noteq> {}")
	subgoal
	proof -
	from di have pmi: "poincare_mapsto {x \<in> ivl. x \<in> plane_of sctn} (X1 i) UNIV CP P" if "i \<in> I" for i
	by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset that)
	show ?thesis
	apply (rule poincare_mapsto_UnionI)
	apply (rule poincare_mapsto_trans[OF pm pmi])
	apply clarsimp_all
	subgoal s1 using assms by (auto simp: do_intersection_spec_def)
	subgoal using assms apply (auto simp: do_intersection_spec_def)
	apply blast
	by (metis (mono_tags, lifting) s1 mem_Collect_eq mem_simps(2) mem_simps(4))
	subgoal using assms by auto
	subgoal using assms by auto
	subgoal premises prems for i x d
	proof -
	note prems
	have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
	by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
	have set_eq: "(CX i \<union> CP) \<times> UNIV = (fst ` X1 i \<times> UNIV \<union> CX i \<times> UNIV \<union> CP \<times> UNIV)"
	using assms prems
	by auto
	have empty_inter: "{x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} \<times> UNIV \<inter> (CX i \<union> CP) \<times> UNIV = {}"
	apply safe
	subgoal
	using assms(4)[of i] \<open>i \<in> I\<close>
	by (auto simp: plane_of_def )
	subgoal
	using assms(4)[of i]
	using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	done
	have ft: "flowsto (X0 i) {0<..} ((CX i \<union> CP) \<times> UNIV) (fst ` P \<times> UNIV)"
	unfolding set_eq
	apply (rule flowsto_poincare_mapsto_trans_flowsto[OF poincare_mapsto_imp_flowsto[OF pm[OF \<open>i \<in> I\<close>]]
	pmi[OF \<open>i \<in> I\<close>] _ _ order_refl])
	using assms prems by (auto)
	then have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
	apply (rule returns_to_flowstoI[OF _ _ _ _ _ _ order_refl])
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal by (rule empty_inter)
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	done
	have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
	apply (rule poincare_map_mem_flowstoI[OF ft])
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using empty_inter by simp
	subgoal by auto
	subgoal by auto
	subgoal using prems assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal by auto
	done
	from ret have "isCont (return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0}) x"
	apply (rule return_time_isCont_outside)
	subgoal by fact
	apply (force intro!: derivative_eq_intros)
	subgoal by (auto intro!: continuous_intros)
	subgoal using prems pm assms by (auto simp: do_intersection_spec_def)
	subgoal using prems pm assms
	by (auto simp: eventually_at_filter plane_of_def do_intersection_spec_def)
	subgoal
	proof -
	have "x \<in> CX i" using \<open>_ \<in> I \<Longrightarrow> X0 _ \<subseteq> CX _ \<times> UNIV\<close>[OF \<open>i \<in> I\<close>] \<open>(x, _) \<in> _\<close>
	by auto
	with assms(4)[OF \<open>i \<in> I\<close>] show ?thesis
	by (auto simp: plane_of_def)
	qed
	done
	then show "isCont (return_time {x \<in> ivl. x \<in> plane_of sctn}) x" by (simp add: plane_of_def)
	qed
	done
	qed
	done
	subgoal using assms by (fastforce simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (fastforce simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms(9) by (fastforce simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	subgoal using assms by (auto simp: plane_of_def do_intersection_spec_def)
	done

	lemma flow_in_stable_setD:
	"flow0 x0 t \<in> stable_set trap \<Longrightarrow> t \<in> existence_ivl0 x0 \<Longrightarrow> x0 \<in> stable_set trap"
	apply (auto simp: stable_set_def)
	proof goal_cases
	case (1 s)
	then show ?case
	apply (cases "s \<le> t")
	apply (meson atLeastAtMost_iff contra_subsetD local.ivl_subset_existence_ivl)
	using contra_subsetD local.existence_ivl_reverse local.existence_ivl_trans' local.flows_reverse by fastforce
	next
	case (2)
	have "((\<lambda>s. flow0 x0 (t + s)) \<longlongrightarrow> trap) (at_top)"
	proof (rule Lim_transform_eventually)
	have "\<forall>\<^sub>F x in at_top. x > max t 0"
	by (simp add: max_def)
	then show "\<forall>\<^sub>F x in at_top. flow0 (flow0 x0 t) x = flow0 x0 (t + x)"
	apply eventually_elim
	apply (subst flow_trans)
	using 2
	by auto
	qed (use 2 in auto)
	then show ?case by (simp add: tendsto_at_top_translate_iff ac_simps)
	qed

	lemma
	poincare_mapsto_avoid_trap:
	assumes "poincare_mapsto p (X0 - trap \<times> UNIV) S CX P"
	assumes "closed p"
	assumes trapprop[THEN stable_onD]: "stable_on (CX \<union> fst ` P) trap"
	shows "poincare_mapsto p (X0 - trap \<times> UNIV) S CX (P - trap \<times> UNIV)"
	using assms(1,2)
	apply (auto simp: poincare_mapsto_def)
	apply (drule bspec, force)
	apply auto
	subgoal for x0 d0 D
	apply (rule exI[where x=D])
	apply (auto dest!: trapprop simp: poincare_map_def intro!: return_time_exivl assms(1,2) return_time_pos)
	subgoal for s
	- by (cases "s = return_time p x0") (auto simp: )
	+ by (cases "s = return_time p x0") auto
	done
	done

	lemma poincare_onto_series[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
	shows "poincare_onto_series symstart trap guards (X0::'a eucl1 set) ivl sctn ro \<le>
	SPEC (\<lambda>XS. do_intersection_spec UNIV {} ivl sctn (X0 - trap \<times> UNIV)
	(XS, Csafe - (ivl \<inter> plane_of sctn)) \<and>
	fst ` X0 - trap \<subseteq> Csafe - (ivl \<inter> plane_of sctn))"
	proof (induction guards arbitrary: X0)
	case Nil
	then show ?case
	apply (simp add:)
	apply refine_vcg
	apply (clarsimp simp add: ivlsctn_to_set_def)
	apply (rule do_intersection_spec_subset2, assumption)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	subgoal by (auto simp: do_intersection_spec_def)
	done
	next
	case (Cons a guards)
	note Cons.IH[simplified, le, refine_vcg]
	show ?case
	supply [[simproc del: defined_all]]
	apply auto
	apply refine_vcg
	apply clarsimp_all
	defer
	subgoal premises prems for b c d e f g h
	proof -
	from prems have "(f, g) \<in> (\<Union>x\<in>c. h x)"
	by auto
	then obtain x where "x \<in> c" "(f, g) \<in> (h x)"
	by auto
	then show ?thesis
	using prems(14)[rule_format, OF \<open>x \<in> c\<close>] prems(5-7)
	by (cases x) (auto simp: do_intersection_spec_def)
	qed
	subgoal premises prems for c ro d e f
	proof -
	let ?s = "trap \<times> UNIV"
	note prems
	from \<open>do_intersection_spec _ _ _ _ _ _ \<close>
	have disro: "do_intersection_spec UNIV {} ivl sctn ((\<Union>i\<in>ro. case i of (_, _, PS, _, _, _, _, _, _) \<Rightarrow> PS - ?s))
	(e, Csafe - ivl \<inter> plane_of sctn)"
	apply (rule do_intersection_spec_subset)
	using prems by auto
	have subset: "(Csafe - ivl \<inter> plane (normal sctn) (pstn sctn)) \<supseteq>
	(snd (snd (snd (snd (snd (snd (snd (snd i))))))) \<union>
	fst (snd (snd (snd (snd (snd (snd (snd i))))))) \<union> fst ` fst (snd (snd i)))" if "i \<in> ro" for i
	using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
	apply (clarsimp )
	subgoal for s X P1 P2 R ivla sctna CX CXS
	apply (rule conjI)
	subgoal by (auto simp: plane_of_def)
	subgoal by (auto simp: plane_of_def)
	done
	done
	have pmro: "poincare_mapsto
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> {x \<in> ivla. x \<in> plane_of sctna})
	(f i - ?s) UNIV
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX)
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> P1)"
	if "i \<in> ro"
	for i
	using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
	by (auto intro: poincare_mapsto_subset)
	then have pmro: "poincare_mapsto
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> {x \<in> ivla. x \<in> plane_of sctna})
	(f i - ?s) UNIV
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX)
	(case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> P1 - ?s)"
	if "i \<in> ro"
	for i
	unfolding split_beta'
	apply (rule poincare_mapsto_avoid_trap)
	using that prems assms
	by (auto intro!: closed_levelset_within continuous_intros
	stable_on_mono[OF _ subset]
	simp: plane_of_def)
	have "do_intersection_spec UNIV {} ivl sctn (\<Union>i\<in>ro. f i - ?s)
	(e, (\<Union>i\<in>ro. case i of (s, X, P1, P2, R, ivla, sctna, CX, CXS) \<Rightarrow> CXS \<union> CX) \<union>
	(Csafe - ivl \<inter> plane_of sctn))"
	apply (rule do_intersection_poincare_mapstos_trans[OF pmro disro])
	subgoal by auto
	subgoal premises that for i
	using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that] using [[simproc del: defined_all]]
	by (auto simp: do_intersection_spec_def)
	subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
	subgoal by auto
	subgoal premises that for i
	using prems(12)[rule_format, unfolded do_intersection_spec_def, OF that]
	prems(11) that
	by (auto simp: do_intersection_spec_def)
	subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
	subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
	subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
	done
	then show ?thesis
	unfolding \<open>(\<Union>x\<in>ro. f x) = X0 - trap \<times> UNIV\<close>
	apply (rule do_intersection_spec_subset2)
	subgoal using assms(1,2) prems by (auto simp: do_intersection_spec_def)
	using prems
	by (auto simp: do_intersection_spec_def intro: poincare_mapsto_subset)
	qed
	done
	qed

	lemma
	do_intersection_flowsto_trans_return:
	assumes "flowsto XS0 {0<..} (CX \<times> UNIV) X1"
	assumes "do_intersection_spec UNIV guards ivl sctn X1 (P, CP)"
	assumes "fst ` X1 \<subseteq> CP"
	assumes "{x \<in> ivl. x \<in> plane_of sctn} \<inter> CX = {}"
	assumes "guards \<inter> (CX \<union> CP) = {}"
	assumes "closed ivl"
	assumes "CX \<subseteq> sbelow_halfspace sctn \<inter> Csafe"
	assumes subset_plane: "fst ` XS0 \<subseteq> plane_of sctn \<inter> ivl"
	assumes down: "\<And>x d. (x, d) \<in> XS0 \<Longrightarrow> ode x \<bullet> normal sctn < 0" "\<And>x. x \<in> CX \<Longrightarrow> ode x \<bullet> normal sctn < 0"
	shows "do_intersection_spec (below_halfspace sctn) guards ivl sctn XS0 (P, CX \<union> CP)"
	using assms
	apply (auto simp: do_intersection_spec_def)
	subgoal
	apply (rule flowsto_poincare_trans, assumption, assumption)
	subgoal by simp
	subgoal by auto
	subgoal using assms(3) by auto
	subgoal by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def)
	prefer 2
	subgoal by (auto simp add: plane_of_def halfspace_simps)
	subgoal premises prems for x d
	proof -
	have [intro, simp]: "closed {x \<in> ivl. x \<in> plane_of sctn} " "closed {x \<in> ivl. x \<bullet> normal sctn = pstn sctn}"
	by (auto intro!: closed_levelset_within continuous_intros simp: plane_of_def assms)
	- from subset_plane have "fst ` XS0 \<subseteq> below_halfspace sctn" by (auto simp: )
	+ from subset_plane have "fst ` XS0 \<subseteq> below_halfspace sctn" by auto
	from flowsto_stays_sbelow[OF \<open>flowsto _ _ _ _\<close> this down(2)]
	have ft_below: "flowsto XS0 pos_reals (CX \<times> UNIV \<inter> sbelow_halfspace sctn \<times> UNIV) X1"
	by auto
	from flowsto_poincare_mapsto_trans_flowsto[OF ft_below \<open>poincare_mapsto _ _ _ _ _\<close> _ _ order_refl]
	have ft: "flowsto XS0 {0<..} (X1 \<union> CX \<times> UNIV \<inter> sbelow_halfspace sctn \<times> UNIV \<union> CP \<times> UNIV) (fst ` P \<times> UNIV)"
	- by (auto simp: )
	+ by auto
	have ret: "returns_to {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0} x"
	apply (rule returns_to_flowstoI[OF ft])
	using prems by (auto simp: plane_of_def halfspace_simps)
	have pm: "poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x \<in> fst ` P"
	apply (rule poincare_map_mem_flowstoI[OF ft])
	using prems by (auto simp: plane_of_def halfspace_simps)
	from pm prems have evmem: "\<forall>\<^sub>F x in at (poincare_map {x \<in> ivl. x \<bullet> normal sctn = pstn sctn} x) within
	plane_of sctn. x \<in> ivl"
	by auto
	from ret have "continuous (at x within {x. x \<bullet> normal sctn - pstn sctn \<le> 0})
	(return_time {x \<in> ivl. x \<bullet> normal sctn - pstn sctn = 0})"
	apply (rule return_time_continuous_below)
	apply (rule derivative_eq_intros refl)+
	apply force
	subgoal using \<open>closed ivl\<close> by auto
	subgoal using prems pm by (auto simp: plane_of_def eventually_at_filter)
	subgoal by (auto intro!: )
	subgoal using prems pm by auto
	subgoal using prems by auto
	subgoal using prems pm by (auto intro!: assms simp: plane_of_def)
	subgoal using prems pm by auto
	done
	then show "continuous (at x within below_halfspace sctn) (return_time {x \<in> ivl. x \<in> plane_of sctn})"
	by (simp add: plane_of_def halfspace_simps)
	qed
	done
	done

	lemma do_intersection_spec_sctn_cong:
	assumes "sctn = sctn' \<or> (normal sctn = - normal sctn' \<and> pstn sctn = - pstn sctn')"
	shows "do_intersection_spec a b c sctn d e = do_intersection_spec a b c sctn' d e"
	using assms
	by (auto simp: do_intersection_spec_def plane_of_def set_eq_iff intro!: )

	lemma poincare_onto_from[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd TYPE('a::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
	shows "poincare_onto_from symstart trap S guards ivl sctn ro (XS0::'a eucl1 set) \<le>
	SPEC (poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn))"
	unfolding poincare_onto_from_def autoref_tag_defs
	apply (refine_vcg, clarsimp_all simp: trapprop)
	subgoal by (auto simp: do_intersection_spec_def Int_def intro: poincare_mapsto_subset)
	subgoal premises prems for a b c d e f
	proof -
	note prems
	from trapprop
	have stable: "stable_on (fst ` (e \<times> UNIV \<inter> sbelow_halfspace a \<times> UNIV \<union> d)) trap"
	apply (rule stable_on_mono)
	using \<open>fst ` (d \<union> e \<times> UNIV) \<subseteq> Csafe\<close> \<open>a = sctn \<or> normal a = - normal sctn \<and> pstn a = - pstn sctn\<close>
	\<open>fst ` d \<subseteq> sbelow_halfspace a\<close>
	by (auto simp: halfspace_simps plane_of_def image_Un)
	from prems(16) have "flowsto (XS0 - trap \<times> UNIV) {0<..} (e \<times> UNIV \<inter> sbelow_halfspace a \<times> UNIV) d"
	by (rule flowsto_subset) auto
	then have ft: "flowsto (XS0 - trap \<times> UNIV) {0<..} ((e \<inter> sbelow_halfspace a) \<times> UNIV) (d - trap \<times> UNIV)"
	by (auto intro!: flowsto_mapsto_avoid_trap stable simp: Times_Int_distrib1)
	from prems(8) have di: "do_intersection_spec UNIV {} ivl a (d - trap \<times> UNIV) (f, Csafe - ivl \<inter> plane_of sctn)"
	apply (subst do_intersection_spec_sctn_cong)
	defer apply assumption
	using prems(2)
	by auto
	have "do_intersection_spec (below_halfspace a) {} ivl a (XS0 - trap \<times> UNIV)
	(f, e \<inter> sbelow_halfspace a \<union> (Csafe - ivl \<inter> plane_of sctn))"
	apply (rule do_intersection_flowsto_trans_return[OF ft di])
	subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
	subgoal by (auto simp: halfspace_simps plane_of_def)
	subgoal using prems by (auto simp: halfspace_simps plane_of_def)
	subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
	subgoal using prems by (auto simp: image_Un)
	subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
	subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
	subgoal using prems by (auto simp: do_intersection_spec_def halfspace_simps plane_of_def)
	done
	moreover have "plane_of a = plane_of sctn"
	using prems(2) by (auto simp: plane_of_def)
	ultimately show ?thesis
	apply (auto simp add: do_intersection_spec_def Int_def)
	apply (rule poincare_mapsto_subset, assumption)
	by auto
	qed
	done

	lemma subset_spec1[refine_vcg]: "subset_spec1 R P dP \<le> SPEC (\<lambda>b. b \<longrightarrow> R \<subseteq> flow1_of_vec1 ` (P \<times> dP))"
	unfolding subset_spec1_def
	by refine_vcg (auto simp: vec1_of_flow1_def)


	lemma subset_spec1_coll[le, refine_vcg]:
	"subset_spec1_coll R P dP \<le> subset_spec R (flow1_of_vec1 ` (P \<times> dP))"
	unfolding autoref_tag_defs subset_spec_def subset_spec1_coll_def
	by (refine_vcg) (auto simp: subset_iff set_of_ivl_def)

	lemma one_step_until_time_spec[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "one_step_until_time (X0::'n eucl1 set) CX t1 \<le> SPEC (\<lambda>(R, CX).
	(\<forall>(x0, d0) \<in> X0. t1 \<in> existence_ivl0 x0 \<and>
	(flow0 x0 t1, Dflow x0 t1 o\<^sub>L d0) \<in> R \<and>
	(\<forall>t \<in> {0 .. t1}. flow0 x0 t \<in> CX)) \<and>
	fst ` R \<union> CX \<subseteq> Csafe)"
	using [[simproc del: defined_all]]
	unfolding one_step_until_time_def autoref_tag_defs
	apply (refine_vcg WHILE_rule[where I="\<lambda>(t, h, X, CX). fst ` X \<subseteq> Csafe \<and> CX \<subseteq> Csafe \<and> 0 \<le> h \<and> 0 \<le> t \<and> t \<le> t1 \<and>
	(\<forall>(x0, d0) \<in> X0. t \<in> existence_ivl0 x0 \<and>
	(flow0 x0 t, Dflow x0 t o\<^sub>L d0) \<in> X \<and>
	(\<forall>s \<in> {0 .. t}. flow0 x0 s \<in> CX))"])
	subgoal by auto
	subgoal by (force simp: flowpipe_def existence_ivl_trans flow_trans)
	subgoal by (auto simp: flowpipe_def existence_ivl_trans flow_trans)
	apply clarsimp subgoal for startstep rk2_param a b c d e f g h i j
	apply (safe)
	subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
	subgoal
	apply (subst flow_trans, force)
	subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
	apply (subst Dflow_trans, force)
	subgoal by (auto simp: flowpipe_def intro!: existence_ivl_trans flow_trans)
	by (auto simp: blinfun_compose_assoc flowpipe_def)
	subgoal for s
	apply (drule bspec[where x="(i, j)"], assumption)
	apply auto
	apply (cases "s \<le> a")
	subgoal by auto
	subgoal
	apply (auto simp: blinfun_compose_assoc flowpipe_def)
	apply (drule bspec, assumption)
	apply auto
	proof goal_cases
	case 1
	have a: "a \<in> existence_ivl0 i" using 1 by auto
	have sa: "s - a \<in> existence_ivl0 (flow0 i a)"
	using "1"(15) "1"(19) "1"(20) local.ivl_subset_existence_ivl by fastforce
	have "flow0 i s = flow0 (flow0 i a) (s - a)"
	by (auto simp: a sa flow_trans[symmetric])
	also have "\<dots> \<in> f"
	using 1 by auto
	finally show ?case
	using 1 by simp
	qed
	done
	done
	subgoal by auto
	done

	text \<open>solve ODE until the time interval \<open>{t1 .. t2}\<close>\<close>

	lemma ivl_of_eucl1_coll[THEN order_trans, refine_vcg]: "ivl_of_eucl_coll X \<le> SPEC (\<lambda>R. X \<times> UNIV \<subseteq> R)"
	unfolding ivl_of_eucl_coll_def
	by refine_vcg auto

	lemma one_step_until_time_ivl_spec[le, refine_vcg]:
	assumes wd[refine_vcg]: "wd (TYPE('n::enum rvec))"
	shows "one_step_until_time_ivl (X0::'n eucl1 set) CX t1 t2 \<le> SPEC (\<lambda>(R, CX).
	(\<forall>(x0, d0) \<in> X0. {t1 .. t2} \<subseteq> existence_ivl0 x0 \<and>
	(\<forall>t \<in> {t1 .. t2}. (flow0 x0 t, Dflow x0 t o\<^sub>L d0) \<in> R) \<and>
	(\<forall>t \<in> {0 .. t1}. (flow0 x0 t) \<in> CX)) \<and>
	fst ` R \<union> CX \<subseteq> Csafe)"
	unfolding one_step_until_time_ivl_def
	apply (refine_vcg, clarsimp_all)
	subgoal for X CX Y CY CY' x0 d0
	apply (drule bspec, assumption, clarsimp)
	apply (drule bspec, assumption, clarsimp simp add: nonneg_interval_mem_existence_ivlI)
	apply (rule subsetD, assumption)
	subgoal for t
	apply (drule bspec[where x=0], force)
	apply (drule bspec[where x="t - t1"], force)
	using interval_subset_existence_ivl[of t1 x0 t2]
	by (auto simp: flow_trans')
	done
	done

	lemma empty_symstart_flowsto:
	"X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow>
	RETURN ({}, X0) \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - {} \<times> UNIV) {0..} (CX \<times> UNIV) X)"
	by (auto intro!: flowsto_self)

	subsection \<open>Poincare map returning to\<close>

	lemma poincare_onto_from_ivla[le, refine_vcg]:
	assumes [refine_vcg]: "wd TYPE('n::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	assumes trapprop[refine_vcg]: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
	shows "poincare_onto_from symstart trap S guards ivl sctn ro (XS0::'n eucl1 set) \<le> SPEC
	(\<lambda>P.
	wd TYPE((real, 'n) vec) \<and>
	poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn) P)"
	by (refine_vcg)

	subsection \<open>Poincare map onto (from outside of target)\<close>

	subsection \<open>One step method (reachability in time)\<close>

	lemma c0_info_of_apprsI:
	assumes "(b, a) \<in> clw_rel appr_rel"
	assumes "x \<in> a"
	shows "x \<in> c0_info_of_apprs b"
	using assms
	by (auto simp: appr_rel_br clw_rel_br c0_info_of_apprs_def c0_info_of_appr_def dest!: brD)

	lemma c0_info_of_appr'I:
	assumes "(b, a) \<in> \<langle>clw_rel appr_rel\<rangle>phantom_rel"
	assumes "x \<in> a"
	shows "x \<in> c0_info_of_appr' b"
	using assms
	by (auto simp add: c0_info_of_appr'_def intro!: c0_info_of_apprsI split: option.splits)

	lemma poincare_onto_from_in_ivl[le, refine_vcg]:
	assumes [refine_vcg]: "wd TYPE('n::enum rvec)"
	assumes [refine_vcg]: "\<And>X0. X0 \<subseteq> Csafe \<times> UNIV \<Longrightarrow> symstart X0 \<le> SPEC (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) (X))"
	assumes trapprop: "stable_on (Csafe - (ivl \<inter> plane_of sctn)) trap"
	shows "poincare_onto_from_in_ivl symstart trap S guards ivl sctn ro (XS0::'n::enum eucl1 set) P dP \<le>
	SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto (ivl \<inter> plane_of sctn) (XS0 - trap \<times> UNIV) S (Csafe - ivl \<inter> plane_of sctn) (flow1_of_vec1 ` (P \<times> dP)))"
	unfolding poincare_onto_from_in_ivl_def
	apply (refine_vcg, clarsimp_all)
	apply (rule trapprop)
	apply (rule poincare_mapsto_subset)
	apply assumption
	- by (auto simp: )
	+ by auto

	lemma lvivl_default_relI:
	"(dRi, set_of_lvivl' dRi::'e::executable_euclidean_space set) \<in> \<langle>lvivl_rel\<rangle>default_rel UNIV"
	if "lvivl'_invar DIM('e) dRi"
	using that
	by (auto simp: set_of_lvivl'_def set_of_lvivl_def set_of_ivl_def lvivl'_invar_def
	intro!: mem_default_relI lvivl_relI)

	lemma stable_on_empty[simp]: "stable_on A {}"
	by (auto simp: stable_on_def)

	lemma poincare_onto_in_ivl[le, refine_vcg]:
	assumes [simp]: "length (ode_e) = CARD('n::enum)"
	shows "poincare_onto_in_ivl guards ivl sctn ro (XS0::'n::enum eucl1 set) P dP \<le>
	SPEC (\<lambda>b. b \<longrightarrow> poincare_mapsto (ivl \<inter> plane_of sctn) (XS0) UNIV (Csafe - ivl \<inter> plane_of sctn) (flow1_of_vec1 ` (P \<times> dP)))"
	proof -
	have wd[refine_vcg]: "wd TYPE((real, 'n) vec)" by (simp add: wd_def)
	show ?thesis
	unfolding poincare_onto_in_ivl_def
	apply (refine_vcg)
	subgoal by (auto intro!: flowsto_self)
	subgoal
	apply (clarsimp simp add: do_intersection_spec_def Int_def[symmetric])
	apply (rule poincare_mapsto_subset)
	apply assumption
	by auto
	done
	qed


	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
	@@ -1,1744 +1,1744 @@
	theory Refine_Rigorous_Numerics_Aform
	imports
	Refine_Rigorous_Numerics
	"HOL-Types_To_Sets.Types_To_Sets"
	begin

	lemma Joints_ne_empty[simp]: "Joints xs \<noteq> {}" "{} \<noteq> Joints xs"
	by (auto simp: Joints_def valuate_def)

	lemma Inf_aform_le_Affine: "x \<in> Affine X \<Longrightarrow> Inf_aform X \<le> x"
	by (auto simp: Affine_def valuate_def intro!: Inf_aform)
	lemma Sup_aform_ge_Affine: "x \<in> Affine X \<Longrightarrow> x \<le> Sup_aform X"
	by (auto simp: Affine_def valuate_def intro!: Sup_aform)

	lemmas Inf_aform'_Affine_le = order_trans[OF Inf_aform' Inf_aform_le_Affine]
	lemmas Sup_aform'_Affine_ge = order_trans[OF Sup_aform_ge_Affine Sup_aform']

	fun approx_form_aform :: "nat \<Rightarrow> form \<Rightarrow> real aform list \<Rightarrow> bool" where
	"approx_form_aform prec (Less a b) bs =
	(case (approx_floatariths prec [a - b] bs)
	of Some [r] \<Rightarrow> Sup_aform' prec r < 0
	\| _ \<Rightarrow> False)"
	\| "approx_form_aform prec (LessEqual a b) bs =
	(case (approx_floatariths prec [a - b] bs)
	of Some [r] \<Rightarrow> Sup_aform' prec r \<le> 0
	\| _ \<Rightarrow> False)"
	\| "approx_form_aform prec (AtLeastAtMost a b c) bs =
	(case (approx_floatariths prec [a - b, a - c] bs)
	of Some [r, s] \<Rightarrow> 0 \<le> Inf_aform' prec r \<and> Sup_aform' prec s \<le> 0
	\| _ \<Rightarrow> False)"
	\| "approx_form_aform prec (Bound a b c d) bs = False"
	\| "approx_form_aform prec (Assign a b c) bs = False"
	\| "approx_form_aform prec (Conj a b) bs \<longleftrightarrow>
	approx_form_aform prec a bs \<and> approx_form_aform prec b bs"
	\| "approx_form_aform prec (Disj a b) bs \<longleftrightarrow>
	approx_form_aform prec a bs \<or> approx_form_aform prec b bs"

	lemma in_Joints_intervalD:
	"x \<in> {Inf_aform' p X .. Sup_aform' p X} \<and> xs \<in> Joints XS"
	if "x#xs \<in> Joints (X#XS)"
	using that
	by (auto simp: Joints_def valuate_def Affine_def
	intro!: Inf_aform'_Affine_le Sup_aform'_Affine_ge)

	lemma approx_form_aform:
	"interpret_form f vs"
	if "approx_form_aform p f VS" "vs \<in> Joints VS"
	using that
	by (induction f)
	(auto split: option.splits list.splits simp: algebra_simps
	dest!: approx_floatariths_outer
	dest!: in_Joints_intervalD[where p=p])

	fun msum_aforms::"nat \<Rightarrow> real aform list \<Rightarrow> real aform list \<Rightarrow> real aform list" where
	"msum_aforms d (x#xs) (y#ys) = msum_aform d x y#msum_aforms d xs ys"
	\| "msum_aforms d _ _ = []"

	definition [simp]: "degree_aforms_real = (degree_aforms::real aform list \<Rightarrow> nat)"

	abbreviation "msum_aforms' \<equiv> \<lambda>X Y. msum_aforms (degree_aforms_real (X @ Y)) X Y"

	lemma aform_val_msum_aforms:
	assumes "degree_aforms xs \<le> d"
	shows "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
	using assms
	proof (induction xs ys rule: msum_aforms.induct)
	case (1 d x xs y ys)
	from 1 have "degree_aforms xs \<le> d"
	by (auto simp: degrees_def)
	from 1(1)[OF this] 1
	have "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
	by simp
	then show ?case
	using 1
	by (simp add: aform_vals_def aform_val_msum_aform degrees_def)
	qed (auto simp: aform_vals_def)

	lemma Joints_msum_aforms:
	assumes "degree_aforms xs \<le> d"
	assumes "degree_aforms ys \<le> d"
	shows "Joints (msum_aforms d xs ys) = {List.map2 (+) a b \|a b. a \<in> Joints xs \<and> b \<in> Joints ys}"
	apply (auto simp: Joints_def valuate_def aform_vals_def[symmetric]
	aform_val_msum_aforms assms)
	apply force
	subgoal for e e'
	apply (rule image_eqI[where x="\<lambda>i. if i < d then e i else e' (i - d)"])
	apply (auto simp: Pi_iff)
	proof goal_cases
	case 1
	have "(aform_vals e xs) = aform_vals (\<lambda>i. if i < d then e i else e' (i - d)) xs"
	using assms
	by (auto intro!: simp: aform_vals_def aform_val_def degrees_def intro!: pdevs_val_degree_cong)
	then show ?case
	by simp
	qed
	done

	definition "split_aforms_largest_uncond_take n X =
	(let (i, x) = max_pdev (abssum_of_pdevs_list (map snd (take n X))) in split_aforms X i)"

	text \<open>intersection with plane\<close>

	definition
	"project_coord x b n = (\<Sum>i\<leftarrow>Basis_list. (if i = b then n else if i = -b then -n else x \<bullet> i) *\<^sub>R i)"

	lemma inner_eq_abs_times_sgn:
	"u \<bullet> b = abs u \<bullet> b * sgn (u \<bullet> b)" if "b \<in> Basis" for b::"'a::ordered_euclidean_space"
	by (subst sgn_mult_abs[symmetric]) (auto simp: that abs_inner )

	lemma inner_Basis_eq_zero_absI: "x \<in> Basis \<Longrightarrow> abs u \<in> Basis \<Longrightarrow> x \<noteq> \<bar>u\<bar> \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> u \<bullet> x = 0"
	for x::"'a::ordered_euclidean_space"
	apply (subst euclidean_inner)
	apply (auto simp: inner_Basis if_distribR if_distrib cong: if_cong)
	apply (subst inner_eq_abs_times_sgn)
	by (auto simp: inner_Basis)

	lemma abs_in_BasisE:
	fixes u::"'a::ordered_euclidean_space"
	assumes "abs u \<in> Basis"
	obtains "abs u = u" \| "abs u = - u"
	proof (cases "u \<bullet> abs u = 1")
	case True
	have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
	using assms
	- by (auto simp: )
	+ by auto
	also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (u \<bullet> i) *\<^sub>R i else 0))"
	by (rule sum.cong) (auto simp: True)
	also have "\<dots> = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
	by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
	also have "\<dots> = u" by (simp add: euclidean_representation)
	finally show ?thesis ..
	next
	case False
	then have F: "u \<bullet> \<bar>u\<bar> = -1"
	apply (subst inner_eq_abs_times_sgn[OF assms])
	apply (subst (asm) inner_eq_abs_times_sgn[OF assms])
	using assms
	apply (auto simp: inner_Basis sgn_if)
	by (metis (full_types) abs_0_eq euclidean_all_zero_iff inner_Basis_eq_zero_absI nonzero_Basis)
	have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
	using assms
	- by (auto simp: )
	+ by auto
	also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (- u \<bullet> i) *\<^sub>R i else 0))"
	by (rule sum.cong) (auto simp: F)
	also have "\<dots> = (\<Sum>i\<in>Basis. (- u \<bullet> i) *\<^sub>R i)"
	by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
	also have "\<dots> = - u" by (subst euclidean_representation) simp
	finally show ?thesis ..
	qed

	lemma abs_in_Basis_iff:
	fixes u::"'a::ordered_euclidean_space"
	shows "abs u \<in> Basis \<longleftrightarrow> u \<in> Basis \<or> - u \<in> Basis"
	proof -
	have u: "u = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
	by (simp add: euclidean_representation)
	have u': "- u = (\<Sum>i\<in>Basis. (- (u \<bullet> i)) *\<^sub>R i)"
	by (subst u) (simp add: sum_negf)
	have au: "abs u = (\<Sum>i\<in>Basis. \<bar>u \<bullet> i\<bar> *\<^sub>R i)"
	by (simp add: eucl_abs[where 'a='a])
	have "(u \<in> Basis \<or> - u \<in> Basis)" if "(\<bar>u\<bar> \<in> Basis)"
	apply (rule abs_in_BasisE[OF that])
	using that
	by auto
	show ?thesis
	apply safe
	subgoal premises prems
	using prems(1)
	apply (rule abs_in_BasisE)
	using prems
	by simp_all
	subgoal
	apply (subst au)
	apply (subst (asm) u)
	apply (subst sum.cong[OF refl])
	apply (subst abs_inner[symmetric]) apply auto
	using u apply auto[1]
	done
	subgoal
	apply (subst au)
	apply (subst (asm) u')
	apply (subst sum.cong[OF refl])
	apply (subst abs_inner[symmetric]) apply auto
	using u' apply auto
	by (metis Basis_nonneg abs_of_nonpos inner_minus_left neg_0_le_iff_le scaleR_left.minus)
	done
	qed

	lemma abs_inner_Basis:
	fixes u v::"'a::ordered_euclidean_space"
	assumes "abs u \<in> Basis" "abs v \<in> Basis"
	shows "inner u v = (if u = v then 1 else if u = -v then -1 else 0)"
	proof -
	define i where "i \<equiv> if u \<in> Basis then u else -u"
	define j where "j \<equiv> if v \<in> Basis then v else -v"
	have u: "u = (if u \<in> Basis then i else - i)"
	and v: "v = (if v \<in> Basis then j else - j)"
	by (auto simp: i_def j_def)
	have "i \<in> Basis" "j \<in> Basis"
	using assms
	by (auto simp: i_def j_def abs_in_Basis_iff)
	then show ?thesis
	apply (subst u)
	apply (subst v)
	apply (auto simp: inner_Basis)
	apply (auto simp: j_def i_def split: if_splits)
	using Basis_nonneg abs_of_nonpos by fastforce
	qed

	lemma
	project_coord_inner_Basis:
	assumes "i \<in> Basis"
	shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
	proof -
	have "project_coord x b n \<bullet> i =
	(\<Sum>j\<in>Basis. (if j = b then n else if j = -b then -n else x \<bullet> j) * (if j = i then 1 else 0))"
	using assms
	by (auto simp: project_coord_def inner_sum_left inner_Basis)
	also have "\<dots> = (\<Sum>j\<in>Basis. (if j = i then (if j = b then n else if j = -b then -n else x \<bullet> j) else 0))"
	by (rule sum.cong) auto
	also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
	using assms
	by (subst sum.delta) auto
	finally show ?thesis by simp
	qed

	lemma
	project_coord_inner:
	assumes "abs i \<in> Basis"
	shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
	proof -
	consider "i \<in> Basis" \| "- i \<in> Basis"
	using assms
	by (auto simp: abs_in_Basis_iff)
	then show ?thesis
	proof cases
	case 1
	then show ?thesis by (simp add: project_coord_inner_Basis)
	next
	case 2
	have "project_coord x b n \<bullet> i = - (project_coord x b n \<bullet> - i)"
	by simp
	also have "\<dots> = - (if - i = b then n else if - i = -b then -n else x \<bullet> - i)"
	using 2
	by (subst project_coord_inner_Basis) simp_all
	also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
	using 2 by auto (metis Basis_nonneg abs_le_zero_iff abs_of_nonneg neg_le_0_iff_le nonzero_Basis)
	finally show ?thesis .
	qed
	qed

	lift_definition project_coord_pdevs::"'a::executable_euclidean_space sctn \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs" is
	"\<lambda>sctn xs i. project_coord (xs i) (normal sctn) 0"
	by (rule finite_subset) (auto simp: project_coord_def cong: if_cong)

	definition "project_coord_aform sctn cxs =
	(project_coord (fst cxs) (normal sctn) (pstn sctn), project_coord_pdevs sctn (snd cxs))"

	definition project_coord_aform_lv :: "real aform list \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> real aform list"
	where "project_coord_aform_lv xs b n = xs[b:=(n, zero_pdevs)]"

	definition "project_ncoord_aform x b n = project_coord_aform (Sctn (Basis_list ! b) n) x"

	lemma
	finite_sum_subset_aux_lemma:
	assumes "finite s"
	shows " {i. (\<Sum>x\<in>s. f x i) \<noteq> 0} \<subseteq> {i. \<exists>x\<in>s. f x i \<noteq> 0}"
	proof -
	have "{i. (\<Sum>x\<in>s. f x i) \<noteq> 0} = - {i. (\<Sum>x\<in>s. f x i) = 0}"
	by auto
	also have "\<dots> \<subseteq> - {i. \<forall>x \<in> s. f x i = 0}"
	by auto
	also have "\<dots> = {i. \<exists>x \<in> s. f x i \<noteq> 0}"
	by auto
	finally show ?thesis by simp
	qed

	lift_definition sum_pdevs::"('i \<Rightarrow> 'a::comm_monoid_add pdevs) \<Rightarrow> 'i set \<Rightarrow> 'a pdevs"
	is "\<lambda>f X. if finite X then (\<lambda>i. \<Sum>x\<in>X. f x i) else (\<lambda>_. 0)"
	apply auto
	apply (rule finite_subset)
	apply (rule finite_sum_subset_aux_lemma)
	apply auto
	done

	lemma pdevs_apply_sum_pdevs[simp]:
	"pdevs_apply (sum_pdevs f X) i = (\<Sum>x\<in>X. pdevs_apply (f x) i)"
	by transfer auto

	lemma sum_pdevs_empty[simp]: "sum_pdevs f {} = zero_pdevs"
	by transfer auto

	lemma sum_pdevs_insert[simp]:
	"finite xs \<Longrightarrow> sum_pdevs f (insert a xs) =
	(if a \<in> xs then sum_pdevs f xs else add_pdevs (f a) (sum_pdevs f xs))"
	by (auto simp: insert_absorb intro!: pdevs_eqI)

	lemma sum_pdevs_infinite[simp]: "infinite X \<Longrightarrow> sum_pdevs f X = zero_pdevs"
	by transfer auto

	lemma compute_sum_pdevs[code]:
	"sum_pdevs f (set XS) = foldr (\<lambda>a b. add_pdevs (f a) b) (remdups XS) zero_pdevs"
	- by (induction XS) (auto simp: )
	+ by (induction XS) auto

	lemma degree_sum_pdevs_le:
	"degree (sum_pdevs f X) \<le> Max (degree ` f ` X)"
	apply (rule degree_le)
	apply auto
	apply (cases "X = {}")
	- subgoal by (simp add: )
	+ subgoal by simp
	subgoal by (cases "finite X") simp_all
	done

	lemma pdevs_val_sum_pdevs:
	"pdevs_val e (sum_pdevs f X) = (\<Sum>x\<in>X. pdevs_val e (f x))"
	apply (cases "finite X")
	subgoal
	apply (subst pdevs_val_sum_le)
	apply (rule degree_sum_pdevs_le)
	apply (auto simp: scaleR_sum_right)
	apply (subst sum.swap)
	apply (rule sum.cong[OF refl])
	apply (subst pdevs_val_sum_le[where d="Max (degree ` f ` X)"])
	apply (auto simp: Max_ge_iff)
	done
	subgoal by simp
	done

	definition eucl_of_list_aform :: "(real \<times> real pdevs) list \<Rightarrow> 'a::executable_euclidean_space aform"
	where "eucl_of_list_aform xs =
	(eucl_of_list (map fst xs), sum_pdevs (\<lambda>i. pdevs_scaleR (snd (xs ! index Basis_list i)) i) Basis)"

	definition lv_aforms_rel::"(((real \<times> real pdevs) list) \<times> ('a::executable_euclidean_space aform)) set"
	where "lv_aforms_rel = br eucl_of_list_aform (\<lambda>xs. length xs = DIM('a))"


	definition "inner_aforms' p X Y =
	(let fas = [inner_floatariths (map floatarith.Var [0..<length X])
	(map floatarith.Var[length X..<length X + length Y])]
	in
	approx_slp_outer p (length fas) fas (X@Y)
	)"

	lemma
	affine_extension_AffineD:
	assumes "affine_extension2 (\<lambda>d x y. Some (F d x y)) f"
	assumes "[x, y] \<in> Joints [X, Y]"
	assumes "d \<ge> degree_aform X"
	assumes "d \<ge> degree_aform Y"
	shows "f x y \<in> Affine (F d X Y)"
	proof -
	from assms(2) obtain e where e:
	"e \<in> funcset UNIV {-1 .. 1}"
	"x = aform_val e X"
	"y = aform_val e Y"
	by (auto simp: Joints_def valuate_def)
	from affine_extension2E[OF assms(1) refl e(1) assms(3) assms(4)]
	obtain e' where "e' \<in> funcset UNIV {- 1..1}" "f (aform_val e X) (aform_val e Y) = aform_val e' (F d X Y)"
	"\<And>n. n < d \<Longrightarrow> e' n = e n" "aform_val e X = aform_val e' X" "aform_val e Y = aform_val e' Y"
	by auto
	then show ?thesis by (auto simp: Affine_def valuate_def e)
	qed

	lemma aform_val_zero_pdevs[simp]: "aform_val e (x, zero_pdevs) = x"
	by (auto simp: aform_val_def)

	lemma neg_equal_zero_eucl[simp]: "-a = a \<longleftrightarrow> a = 0" for a::"'a::euclidean_space"
	by (auto simp: algebra_simps euclidean_eq_iff[where 'a='a])

	context includes autoref_syntax begin

	lemma Option_bind_param[param, autoref_rules]:
	"((\<bind>), (\<bind>)) \<in> \<langle>S\<rangle>option_rel \<rightarrow> (S \<rightarrow> \<langle>R\<rangle>option_rel) \<rightarrow> \<langle>R\<rangle>option_rel"
	unfolding Option.bind_def
	by parametricity

	lemma zip_Basis_list_pat[autoref_op_pat_def]: "\<Sum>(b, m)\<leftarrow>zip Basis_list ms. m *\<^sub>R b \<equiv> OP eucl_of_list $ ms"
	proof (rule eq_reflection)
	have z: "zip ms (Basis_list::'a list) = map (\<lambda>(x, y). (y, x)) (zip Basis_list ms)"
	by (subst zip_commute) simp
	show "(\<Sum>(b, m)\<leftarrow>zip (Basis_list::'a list) ms. m *\<^sub>R b) = OP eucl_of_list $ ms"
	unfolding eucl_of_list_def autoref_tag_defs
	apply (subst z)
	apply (subst map_map)
	apply (auto cong: map_cong simp: split_beta')
	done
	qed

	lemma length_aforms_of_ivls: "length (aforms_of_ivls a b) = min (length a) (length b)"
	by (auto simp: aforms_of_ivls_def)

	lemma length_lv_rel:
	"(ys, y::'a) \<in> lv_rel \<Longrightarrow> length ys = DIM('a::executable_euclidean_space)"
	by (auto simp: lv_rel_def br_def)

	lemma lv_rel_nth[simp]: "(xs, x::'a::executable_euclidean_space) \<in> lv_rel \<Longrightarrow> b \<in> Basis \<Longrightarrow>
	xs ! index (Basis_list) b = x \<bullet> b"
	unfolding lv_rel_def
	by (auto simp: br_def eucl_of_list_inner)

	lemma aform_of_ivl_autoref[autoref_rules]:
	"(aforms_of_ivls, aform_of_ivl) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_aforms_rel"
	apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def length_aforms_of_ivls length_lv_rel)
	subgoal for xs x ys y
	apply (auto simp: aform_of_ivl_def aforms_of_ivls_def o_def eucl_of_list_inner inner_simps
	pdevs_apply_pdevs_of_ivl length_lv_rel
	intro!: euclidean_eqI[where 'a='a] pdevs_eqI)
	by (metis index_Basis_list_nth inner_not_same_Basis length_Basis_list nth_Basis_list_in_Basis)
	done

	lemma bound_intersect_2d_ud[autoref_rules]:
	shows "(bound_intersect_2d_ud, bound_intersect_2d_ud) \<in> nat_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel) \<times>\<^sub>r Id) \<rightarrow> rnv_rel \<rightarrow> \<langle>rnv_rel \<times>\<^sub>r rnv_rel\<rangle>option_rel"
	by auto

	lemma eucl_of_list_autoref[autoref_rules]:
	includes autoref_syntax
	assumes "SIDE_PRECOND (length xs = DIM('a::executable_euclidean_space))"
	assumes "(xsi, xs) \<in> \<langle>rnv_rel\<rangle>list_rel"
	shows "(xsi, eucl_of_list $ xs::'a) \<in> lv_rel"
	using assms
	unfolding lv_rel_def
	by (auto simp: br_def)

	definition "inner2s x b c = (inner_lv_rel x b, inner_lv_rel x c)"

	lemma inner_lv_rel_autoref[autoref_rules]:
	"(inner_lv_rel, (\<bullet>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel"
	using lv_rel_inner[unfolded inner_lv_rel_def[symmetric]]
	by auto

	lemma inner_lv_rel_eq:
	"\<lbrakk>length xs = DIM('a::executable_euclidean_space); (xa, x'a) \<in> lv_rel\<rbrakk> \<Longrightarrow>
	inner_lv_rel xs xa = eucl_of_list xs \<bullet> (x'a::'a)"
	using inner_lv_rel_autoref[param_fo, of "xs" "eucl_of_list xs" xa x'a]
	unfolding lv_rel_def
	by (auto simp: br_def)

	definition "inner_pdevs xs ys = sum_pdevs (\<lambda>i. scaleR_pdevs (ys ! i) (xs ! i)) {..<length xs}"

	definition "pdevs_inner2s xs a b = prod_of_pdevs (inner_pdevs xs a) (inner_pdevs xs b)"

	lemma inner2_aform_autoref[autoref_rules]:
	shows "((\<lambda>xs a b. (inner2s (map fst xs) a b, pdevs_inner2s (map snd xs) a b)), inner2_aform) \<in> lv_aforms_rel \<rightarrow> lv_rel \<rightarrow> lv_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel)\<times>\<^sub>rId)"
	unfolding inner2_aform_def
	apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def inner2_aform_def )
	apply (auto simp: inner2s_def inner2_def inner_lv_rel_eq pdevs_inner2s_def inner_pdevs_def
	sum_Basis_sum_nth_Basis_list inner_sum_left inner_Basis mult.commute
	intro!: pdevs_eqI)
	subgoal for a b c d e f
	apply (rule sum.cong)
	apply force
	subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
	done
	subgoal for a b c d e f
	apply (rule sum.cong)
	apply force
	subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
	done
	done

	lemma RETURN_inter_aform_plane_ortho_annot:
	"RETURN (inter_aform_plane_ortho p (Z::'a aform) n g) =
	(case those (map (\<lambda>b. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list) of
	Some mMs \<Rightarrow>
	do {
	ASSERT (length mMs = DIM('a::executable_euclidean_space));
	let l = (\<Sum>(b, m)\<leftarrow>zip Basis_list (map fst mMs). m *\<^sub>R b);
	let u = (\<Sum>(b, M)\<leftarrow>zip Basis_list (map snd mMs). M *\<^sub>R b);
	RETURN (Some (aform_of_ivl l u))
	}
	\| None \<Rightarrow> RETURN None)"
	apply (auto simp: inter_aform_plane_ortho_def split: option.splits)
	subgoal premises prems for x2
	proof -
	have "length x2 = DIM('a)" using prems
	using map_eq_imp_length_eq by (force simp: those_eq_Some_map_Some_iff)
	then show ?thesis using prems by auto
	qed
	done

	definition "inter_aform_plane_ortho_nres p Z n g = RETURN (inter_aform_plane_ortho p Z n g)"

	schematic_goal inter_aform_plane_ortho_lv:
	fixes Z::"'a::executable_euclidean_space aform"
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
	assumes [autoref_rules]: "(pp, p) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
	"(ni, n) \<in> lv_rel" "(gi, g) \<in> rnv_rel"
	notes [autoref_rules] = those_param param_map
	shows "(nres_of (?f::?'a dres), inter_aform_plane_ortho_nres $ p $ Z $ n $ g) \<in> ?R"
	unfolding autoref_tag_defs
	unfolding RETURN_inter_aform_plane_ortho_annot inter_aform_plane_ortho_nres_def
	including art
	by autoref_monadic
	concrete_definition inter_aform_plane_ortho_lv for pp Zi ni gi uses inter_aform_plane_ortho_lv
	lemmas [autoref_rules] = inter_aform_plane_ortho_lv.refine

	lemma project_coord_lv[autoref_rules]:
	assumes "(xs, x::'a::executable_euclidean_space aform) \<in> lv_aforms_rel" "(ni, n) \<in> nat_rel"
	assumes "SIDE_PRECOND (n < DIM('a))"
	shows "(project_coord_aform_lv xs ni, project_ncoord_aform $ x $ n) \<in> rnv_rel \<rightarrow> lv_aforms_rel"
	using assms
	apply (auto simp: project_coord_aform_lv_def project_ncoord_aform_def lv_rel_def
	project_coord_aform_def eucl_of_list_aform_def
	lv_aforms_rel_def br_def)
	subgoal
	apply (auto intro!: euclidean_eqI[where 'a='a])
	apply (subst project_coord_inner_Basis)
	apply (auto simp: eucl_of_list_inner )
	apply (subst nth_list_update)
	- apply (auto simp: )
	+ apply auto
	using in_Basis_index_Basis_list apply force
	using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
	apply (auto simp: nth_list_update)
	done
	subgoal for i
	apply (auto intro!: pdevs_eqI simp: project_coord_pdevs.rep_eq)
	apply (auto intro!: euclidean_eqI[where 'a='a])
	apply (subst project_coord_inner_Basis)
	apply (auto simp: eucl_of_list_inner )
	apply (subst nth_list_update)
	- apply (auto simp: )
	+ apply auto
	using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
	apply (auto simp: nth_list_update)
	done
	done

	definition inter_aform_plane
	where "inter_aform_plane prec Xs (sctn::'a sctn) =
	do {
	cxs \<leftarrow> inter_aform_plane_ortho_nres (prec) (Xs) (normal sctn) (pstn sctn);
	case cxs of
	Some cxs \<Rightarrow>
	(if normal sctn \<in> set Basis_list
	then do {
	ASSERT (index Basis_list (normal sctn) < DIM('a::executable_euclidean_space));
	RETURN ((project_ncoord_aform cxs (index Basis_list (normal sctn)) (pstn sctn)))
	}
	else if - normal sctn \<in> set Basis_list
	then do {
	ASSERT (index Basis_list (-normal sctn) < DIM('a));
	RETURN ((project_ncoord_aform cxs (index Basis_list (-normal sctn)) (- pstn sctn)))
	}
	else SUCCEED)
	\| None \<Rightarrow> SUCCEED
	}"

	lemma [autoref_rules]:
	assumes [THEN GEN_OP_D, param]: "GEN_OP (=) (=) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(index, index) \<in> \<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> nat_rel"
	unfolding index_def find_index_def
	by parametricity

	schematic_goal inter_aform_plane_lv:
	fixes Z::"'a::executable_euclidean_space aform"
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
	assumes [autoref_rules]: "(preci, prec) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
	"(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	notes [autoref_rules] = those_param param_map
	shows "(nres_of (?f::?'a dres), inter_aform_plane prec Z sctn) \<in> ?R"
	unfolding autoref_tag_defs
	unfolding inter_aform_plane_def
	including art
	by (autoref_monadic )

	concrete_definition inter_aform_plane_lv for preci Zi sctni uses inter_aform_plane_lv
	lemmas [autoref_rules] = inter_aform_plane_lv.refine[autoref_higher_order_rule(1)]

	end


	lemma Basis_not_uminus:
	fixes i::"'a::euclidean_space"
	shows "i \<in> Basis \<Longrightarrow> - i \<notin> Basis"
	by (metis inner_Basis inner_minus_left one_neq_neg_one zero_neq_neg_one)

	lemma
	pdevs_apply_project_coord_pdevs:
	assumes "normal sctn \<in> Basis \<or> - normal sctn \<in> Basis"
	assumes "i \<in> Basis"
	shows "pdevs_apply (project_coord_pdevs sctn cxs) x \<bullet> i =
	(if i = abs (normal sctn) then 0 else pdevs_apply cxs x \<bullet> i)"
	using assms[unfolded abs_in_Basis_iff[symmetric]]
	apply (transfer fixing: sctn)
	apply (auto simp: project_coord_inner Basis_not_uminus)
	using Basis_nonneg apply force
	using Basis_nonneg assms(1) by force

	lemma pdevs_domain_project_coord_pdevs_subset:
	"pdevs_domain (project_coord_pdevs sctn X) \<subseteq> pdevs_domain X"
	- apply (auto simp: )
	+ apply auto
	apply (auto simp: euclidean_eq_iff[where 'a='a] )
	by (metis add.inverse_neutral project_coord_inner_Basis project_coord_pdevs.rep_eq)

	lemma pdevs_val_project_coord_pdevs_inner_Basis:
	assumes "b \<in> Basis"
	shows "pdevs_val e (project_coord_pdevs sctn X) \<bullet> b =
	(if b = abs (normal sctn) then 0 else pdevs_val e X \<bullet> b)"
	using assms
	- apply (auto simp: )
	+ apply auto
	apply (simp add: pdevs_val_pdevs_domain inner_sum_left )
	apply (subst sum.cong[OF refl])
	apply (subst pdevs_apply_project_coord_pdevs)
	apply (simp add: abs_in_Basis_iff)
	apply simp
	apply (rule refl)
	apply auto
	unfolding pdevs_val_pdevs_domain inner_sum_left
	apply (rule sum.mono_neutral_cong_left)
	apply simp
	apply (rule pdevs_domain_project_coord_pdevs_subset)
	apply auto
	apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg euclidean_all_zero_iff
	project_coord_inner_Basis project_coord_pdevs.rep_eq)
	apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg
	project_coord_inner_Basis project_coord_pdevs.rep_eq)
	done

	lemma inner_in_Sum: "b \<in> Basis \<Longrightarrow> x \<bullet> b = (\<Sum>i\<in>Basis. x \<bullet> i * (i \<bullet> b))"
	apply (subst euclidean_representation[of x, symmetric])
	unfolding inner_sum_left
	by (auto simp: intro!: )

	lemma aform_val_project_coord_aform:
	"aform_val e (project_coord_aform sctn X) = project_coord (aform_val e X) (normal sctn) (pstn sctn)"
	apply (auto simp: aform_val_def project_coord_def project_coord_aform_def)
	apply (rule euclidean_eqI)
	unfolding inner_add_left inner_sum_left
	apply (subst pdevs_val_project_coord_pdevs_inner_Basis)
	- apply (auto simp: )
	+ apply auto
	apply (rule sum.cong)
	apply auto
	apply (metis abs_in_Basis_iff abs_inner abs_inner_Basis abs_zero inner_commute)
	apply (subst inner_in_Sum[where x="pdevs_val e (snd X)"], force)
	unfolding sum.distrib[symmetric]
	apply (rule sum.cong)
	apply auto
	apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos inner_commute neg_0_le_iff_le)
	apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos neg_0_le_iff_le)
	apply (auto simp: inner_Basis)
	done

	lemma project_coord_on_plane:
	assumes "x \<in> plane_of (Sctn n c)"
	shows "project_coord x n c = x"
	using assms
	by (auto simp: project_coord_def plane_of_def intro!: euclidean_eqI[where 'a='a])

	lemma
	mem_Affine_project_coord_aformI:
	assumes "x \<in> Affine X"
	assumes "x \<in> plane_of sctn"
	shows "x \<in> Affine (project_coord_aform sctn X)"
	proof -
	have "x = project_coord x (normal sctn) (pstn sctn)"
	using assms by (intro project_coord_on_plane[symmetric]) auto
	also
	from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "x = aform_val e X"
	by (auto simp: Affine_def valuate_def)
	note this(2)
	also have "project_coord (aform_val e X) (normal sctn) (pstn sctn) =
	aform_val e (project_coord_aform sctn X)"
	by (simp add: aform_val_project_coord_aform)
	finally have "x = aform_val e (project_coord_aform sctn X)" unfolding \<open>x = aform_val e X\<close> .
	then show ?thesis using \<open>e \<in> _\<close>
	by (auto simp: Affine_def valuate_def)
	qed

	lemma
	mem_Affine_project_coord_aformD:
	assumes "x \<in> Affine (project_coord_aform sctn X)"
	assumes "abs (normal sctn) \<in> Basis"
	shows "x \<in> plane_of sctn"
	using assms
	by (auto simp: Affine_def valuate_def aform_val_project_coord_aform plane_of_def
	project_coord_inner)

	definition "reduce_aform prec t X =
	summarize_aforms (prec) (collect_threshold (prec) 0 t) (degree_aforms X) X"

	definition "correct_girard p m N (X::real aform list) =
	(let
	Xs = map snd X;
	M = pdevs_mapping Xs;
	D = domain_pdevs Xs;
	diff = m - card D
	in if 0 < diff then (\<lambda>_ _. True) else
	let
	Ds = sorted_list_of_set D;
	ortho_indices = map fst (take (diff + N) (sort_key (\<lambda>(i, r). r) (map (\<lambda>i. let xs = M i in (i, sum_list' p (map abs xs) - fold max (map abs xs) 0)) Ds)));
	_ = ()
	in (\<lambda>i (xs::real list). i \<notin> set ortho_indices))"

	definition "reduce_aforms prec C X = summarize_aforms (prec) C (degree_aforms X) X"

	definition "pdevs_of_real x = (x, zero_pdevs)"

	definition aform_inf_inner where "aform_inf_inner prec X n =
	(case inner_aforms' (prec) X (map pdevs_of_real n) of
	Some Xn \<Rightarrow> Inf_aform' (prec) (hd Xn))"
	definition aform_sup_inner where "aform_sup_inner prec X n =
	(case inner_aforms' (prec) X (map pdevs_of_real n) of
	Some Xn \<Rightarrow> Sup_aform' (prec) (hd Xn))"

	text \<open>cannot fail\<close>

	lemma approx_un_ne_None: "approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) \<noteq> None"
	by (auto simp: approx_un_def split_beta')

	lemma approx_un_eq_Some:
	"approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) = Some s \<longleftrightarrow>
	s = ivl_err (real_interval (f (ivl_of_aform_err p r)))"
	using approx_un_ne_None
	by (auto simp: approx_un_def split_beta')

	lemma is_float_uminus:
	"is_float aa \<Longrightarrow> is_float (- aa)"
	by (auto simp: is_float_def)

	lemma is_float_uminus_iff[simp]:
	"is_float (- aa) = is_float aa"
	using is_float_uminus[of aa] is_float_uminus[of "-aa"]
	by (auto simp: is_float_def)

	lemma is_float_simps[simp]:
	"is_float 0"
	"is_float 1"
	"is_float (real_of_float x)"
	"is_float (truncate_down p X)"
	"is_float (truncate_up p X)"
	"is_float (eucl_truncate_down p X)"
	"is_float (eucl_truncate_up p X)"
	by (auto simp: is_float_def eucl_truncate_down_def eucl_truncate_up_def truncate_down_def truncate_up_def)

	lemma is_float_sum_list'[simp]:
	"is_float (sum_list' p xs)"
	by (induction xs) (auto simp: is_float_def)

	lemma is_float_inverse_aform': "is_float (fst (fst (inverse_aform' p X)))"
	unfolding inverse_aform'_def
	by (simp add: Let_def trunc_bound_eucl_def)

	lemma is_float_min_range:
	"min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
	"min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
	"min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
	"min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
	by (auto simp: min_range_antimono_def min_range_mono_def Let_def bind_eq_Some_conv
	prod_eq_iff trunc_bound_eucl_def
	mid_err_def affine_unop_def split: prod.splits)

	lemma is_float_ivl_err:
	assumes "ivl_err x = ((a, b), c)" "is_float (lower x)" "is_float (upper x)"
	shows "is_float a" "is_float c"
	proof -
	define x1 where "x1 = lower x"
	define x2 where "x2 = upper x"
	have "a = (x1 + x2) / 2" "c = (x2 - x1) / 2"
	using assms by (auto simp: ivl_err_def x1_def x2_def)
	moreover have "(x1 + x2) / 2 \<in> float" "(x2 - x1) / 2 \<in> float"
	using assms
	by (auto simp: is_float_def x1_def x2_def)
	ultimately show "is_float a" "is_float c"
	unfolding is_float_def by blast+
	qed

	lemma is_float_trunc_bound_eucl[simp]:
	"is_float (fst (trunc_bound_eucl p X))"
	by (auto simp: trunc_bound_eucl_def Let_def)

	lemma add_eq_times_2_in_float: "a + b = c * 2 \<Longrightarrow> is_float a \<Longrightarrow> is_float b \<Longrightarrow> is_float c"
	proof goal_cases
	case 1
	then have "c = (a + b) / 2"
	by simp
	also have "\<dots> \<in> float" using 1(3,2) by (simp add: is_float_def)
	finally show ?case by (simp add: is_float_def)
	qed


	lemma approx_floatarith_Some_is_float:
	"approx_floatarith p fa XS = Some ((a, b), ba) \<Longrightarrow>
	list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS \<Longrightarrow>
	is_float a \<and> is_float ba"
	apply (induction fa arbitrary: a b ba)
	subgoal by (auto simp: bind_eq_Some_conv add_aform'_def Let_def )
	subgoal by (auto simp: bind_eq_Some_conv uminus_aform_def Let_def)
	subgoal by (auto simp: bind_eq_Some_conv mult_aform'_def Let_def )
	subgoal by (auto simp: bind_eq_Some_conv inverse_aform_err_def map_aform_err_def
	prod_eq_iff is_float_inverse_aform'
	acc_err_def aform_to_aform_err_def aform_err_to_aform_def inverse_aform_def
	Let_def split: if_splits)
	subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal apply (auto simp: bind_eq_Some_conv uminus_aform_def Let_def is_float_min_range
	is_float_ivl_err set_of_eq real_interval_abs
	split: if_splits prod.splits)
	apply (metis is_float_ivl_err(1) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
	by (metis is_float_ivl_err(2) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
	subgoal by (auto simp: bind_eq_Some_conv max_aform_err_def Let_def is_float_min_range
	is_float_ivl_err max_def
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv min_aform_err_def Let_def is_float_min_range
	is_float_ivl_err min_def
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv sqrt_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv exp_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv powr_aform_err_def approx_bin_def
	exp_aform_err_def Let_def is_float_min_range
	is_float_ivl_err mult_aform'_def
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv ln_aform_err_def Let_def is_float_min_range
	is_float_ivl_err
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv power_aform_err_def Let_def is_float_min_range
	is_float_ivl_err mid_err_def dest!: add_eq_times_2_in_float
	split: if_splits prod.splits)
	subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
	approx_un_def is_float_ivl_err
	split: if_splits)
	subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
	list_all_length
	split: if_splits)
	subgoal by (auto simp: bind_eq_Some_conv num_aform_def Let_def)
	done

	lemma plain_floatarith_not_None:
	assumes "plain_floatarith N fa" "N \<le> length XS"
	"list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
	shows "approx_floatarith p fa XS \<noteq> None"
	using assms
	by (induction fa)
	(auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
	approx_floatarith_Some_is_float)

	lemma plain_floatarith_slp_not_None:
	assumes "\<And>fa. fa \<in> set fas \<Longrightarrow> plain_floatarith N fa" "N \<le> length XS"
	"list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
	shows "approx_slp p fas XS \<noteq> None"
	using assms
	apply (induction fas arbitrary: XS)
	subgoal by simp
	subgoal for fa fas XS
	using plain_floatarith_not_None[of N fa XS p]
	by (auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
	bind_eq_Some_conv approx_floatarith_Some_is_float)
	done

	lemma plain_floatarithE:
	assumes "plain_floatarith N fa" "N \<le> length XS"
	"list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
	obtains R where "approx_floatarith p fa XS = Some R"
	using plain_floatarith_not_None[OF assms]
	by force

	lemma approx_slp_outer_eq_None_iff:
	"approx_slp_outer p a b XS = None \<longleftrightarrow>
	approx_slp p b ((map (\<lambda>x. (x, 0)) XS)) = None"
	by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)

	lemma approx_slp_sing_eq_None_iff:
	"approx_slp p [b] xs = None \<longleftrightarrow> approx_floatarith p b xs = None"
	by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)

	lemma plain_inner_floatariths:
	"plain_floatarith N (inner_floatariths xs ys)"
	if "list_all (plain_floatarith N) xs" "list_all (plain_floatarith N) ys"
	using that
	by (induction xs ys rule: inner_floatariths.induct) auto

	lemma aiN: "approx_floatarith p (inner_floatariths xs ys) zs \<noteq> None"
	if "\<And>x. x \<in> set xs \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
	and "\<And>x. x \<in> set ys \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
	using that
	apply (induction xs ys rule: inner_floatariths.induct)
	apply (auto simp: Let_def bind_eq_Some_conv)
	by (metis old.prod.exhaust)

	lemma aiVN: "approx_floatarith p
	(inner_floatariths (map floatarith.Var [0..<length a])
	(map floatarith.Var [length a..<length a + length b]))
	(map (\<lambda>x. (x, 0)) a @ map (\<lambda>x. (x, 0)) b) \<noteq> None"
	by (rule aiN) (auto simp: nth_append)

	lemma iaN: "inner_aforms' p a b \<noteq> None"
	unfolding inner_aforms'_def Let_def approx_slp_outer_def
	using aiVN[of p a b]
	by (auto simp: Let_def bind_eq_Some_conv)

	definition "support_aform prec b X = (let ia = inner_aform X b in fst X \<bullet> b + tdev' (prec) (snd ia))"

	definition "width_aforms prec X =
	(let t = tdev' (prec) ((abssum_of_pdevs_list (map snd X))) in t)"

	definition "inf_aforms prec xs = map (Inf_aform' (prec)) xs"
	definition "sup_aforms prec xs = map (Sup_aform' (prec)) xs"

	definition "fresh_index_aforms xs = Max (insert 0 (degree_aform ` set xs))"

	definition "independent_aforms x env = (msum_aform (fresh_index_aforms env) (0, zero_pdevs) x#env)"

	definition "aform_form_ivl prec form xs =
	dRETURN (approx_form prec form (ivls_of_aforms prec xs) [])"
	definition "aform_form prec form xs =
	dRETURN (approx_form_aform prec form xs)"
	definition "aform_slp prec n slp xs =
	dRETURN (approx_slp_outer prec n slp xs)"
	definition
	"aform_isFDERIV prec n ns fas xs =
	dRETURN (isFDERIV_approx prec n ns fas (ivls_of_aforms prec xs))"

	definition aform_rel_internal: "aform_rel R = br Affine top O \<langle>R\<rangle>set_rel"
	lemma aform_rel_def: "\<langle>rnv_rel\<rangle>aform_rel = br Affine top"
	unfolding relAPP_def
	by (auto simp: aform_rel_internal)
	definition "aforms_rel = br Joints top"

	definition aform_rell :: "((real \<times> real pdevs) list \<times> real list set) set"
	where "aform_rell = aforms_rel"

	definition aforms_relp_internal: "aforms_relp R = aforms_rel O \<langle>R\<rangle>set_rel"
	lemma aforms_relp_def: "\<langle>R\<rangle>aforms_relp = aforms_rel O \<langle>R\<rangle>set_rel"
	by (auto simp: aforms_relp_internal relAPP_def)

	definition "product_aforms x y = x @ msum_aforms (degree_aforms (x)) (replicate (length y) (0, zero_pdevs)) y"

	lemma
	eucl_of_list_mem_eucl_of_list_aform:
	assumes "x \<in> Joints a"
	assumes "length a = DIM('a::executable_euclidean_space)"
	shows "eucl_of_list x \<in> Affine (eucl_of_list_aform a::'a aform)"
	using assms
	by (auto simp: Joints_def Affine_def valuate_def eucl_of_list_aform_def
	aform_val_def pdevs_val_sum_pdevs inner_simps eucl_of_list_inner
	intro!: euclidean_eqI[where 'a='a])

	lemma
	in_image_eucl_of_list_eucl_of_list_aform:
	assumes "length x = DIM('a::executable_euclidean_space)" "xa \<in> Affine (eucl_of_list_aform x::'a aform)"
	shows "xa \<in> eucl_of_list ` Joints x"
	using assms
	by (auto intro!: nth_equalityI image_eqI[where x="list_of_eucl xa"]
	simp: aform_val_def eucl_of_list_aform_def Affine_def valuate_def Joints_def
	inner_simps pdevs_val_sum_pdevs eucl_of_list_inner)

	lemma
	eucl_of_list_image_Joints:
	assumes "length x = DIM('a::executable_euclidean_space)"
	shows "eucl_of_list ` Joints x = Affine (eucl_of_list_aform x::'a aform)"
	using assms
	by (auto intro!: eucl_of_list_mem_eucl_of_list_aform
	in_image_eucl_of_list_eucl_of_list_aform)

	definition "aform_ops =
	\<lparr>
	appr_of_ivl = aforms_of_ivls,
	product_appr = product_aforms,
	msum_appr = msum_aforms',
	inf_of_appr = \<lambda>optns. inf_aforms (precision optns),
	sup_of_appr = \<lambda>optns. sup_aforms (precision optns),
	split_appr = split_aforms_largest_uncond_take,
	appr_inf_inner = \<lambda>optns. aform_inf_inner (precision optns),
	appr_sup_inner = \<lambda>optns. aform_sup_inner (precision optns),
	inter_appr_plane = \<lambda>optns xs sctn. inter_aform_plane_lv (length xs) (precision optns) xs sctn,
	reduce_appr = \<lambda>optns. reduce_aforms (precision optns),
	width_appr = \<lambda>optns. width_aforms (precision optns),
	approx_slp_dres = \<lambda>optns. aform_slp (precision optns),
	approx_euclarithform = \<lambda>optns. aform_form (precision optns),
	approx_isFDERIV = \<lambda>optns. aform_isFDERIV (precision optns)
	\<rparr>"

	lemma Affine_eq_permI:
	assumes "fst X = fst Y"
	assumes "map snd (list_of_pdevs (snd X)) <~~> map snd (list_of_pdevs (snd Y))" (is "?perm X Y")
	shows "Affine X = Affine Y"
	proof -
	{
	fix X Y and e::"nat \<Rightarrow> real"
	assume perm: "?perm X Y" and e: "e \<in> funcset UNIV {- 1..1}"
	from pdevs_val_of_list_of_pdevs2[OF e, of "snd X"]
	obtain e' where e':
	"pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X))))"
	"e' \<in> funcset UNIV {- 1..1}"
	by auto
	note e'(1)
	also from pdevs_val_perm[OF perm e'(2)]
	obtain e'' where e'':
	"e'' \<in> funcset UNIV {- 1..1}"
	"pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X)))) =
	pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y))))"
	by auto
	note e''(2)
	also from pdevs_val_of_list_of_pdevs[OF e''(1), of "snd Y", simplified]
	obtain e''' where e''':
	"pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y)))) = pdevs_val e''' (snd Y)"
	"e''' \<in> funcset UNIV {- 1..1}"
	by auto
	note e'''(1)
	finally have "\<exists>e' \<in> funcset UNIV {-1 .. 1}. pdevs_val e (snd X) = pdevs_val e' (snd Y)"
	using e'''(2) by auto
	} note E = this
	note e1 = E[OF assms(2)]
	and e2 = E[OF perm_sym[OF assms(2)]]
	show ?thesis
	by (auto simp: Affine_def valuate_def aform_val_def assms dest: e1 e2)
	qed

	context includes autoref_syntax begin

	lemma aform_of_ivl_refine: "x \<le> y \<Longrightarrow> (aform_of_ivl x y, atLeastAtMost x y) \<in> \<langle>rnv_rel\<rangle>aform_rel"
	by (auto simp: aform_rel_def br_def Affine_aform_of_ivl)

	lemma aforms_of_ivl_leI1:
	fixes en::real
	assumes "-1 \<le> en" "xsn \<le> ysn"
	shows "xsn \<le> (xsn + ysn) / 2 + (ysn - xsn) * en / 2"
	proof -
	have "xsn * (1 + en) \<le> ysn * (1 + en)"
	using assms mult_right_mono by force
	then show ?thesis
	by (auto simp: algebra_simps divide_simps)
	qed

	lemma aforms_of_ivl_leI2:
	fixes en::real
	assumes "1 \<ge> en" "xsn \<le> ysn"
	shows "(xsn + ysn) / 2 + (ysn - xsn) * en / 2 \<le> ysn"
	proof -
	have "xsn * (1 - en) \<le> ysn * (1 - en)"
	using assms mult_right_mono by force
	then show ?thesis
	by (auto simp: algebra_simps divide_simps)
	qed

	lemma Joints_aforms_of_ivlsD1:
	"zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) xs zs"
	by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
	list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI1)

	lemma Joints_aforms_of_ivlsD2:
	"zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) zs ys"
	by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
	list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI2)

	lemma aforms_of_ivls_refine:
	"list_all2 (\<le>) xrs yrs \<Longrightarrow>
	(xri, xrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow>
	(yri, yrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow> (aforms_of_ivls xri yri, lv_ivl xrs yrs) \<in> aforms_rel"
	apply (auto simp: aforms_rel_def br_def list_all2_lengthD lv_ivl_def
	Joints_aforms_of_ivlsD1 Joints_aforms_of_ivlsD2 intro!: aforms_of_ivls)
	subgoal by (simp add: list_all2_conv_all_nth)
	subgoal by (simp add: list_all2_conv_all_nth)
	done

	lemma degrees_zero_pdevs[simp]: "degrees (replicate n zero_pdevs) = 0"
	by (auto simp: degrees_def intro!: Max_eqI)

	lemma Joints_product_aforms:
	"Joints (product_aforms a b) = product_listset (Joints a) (Joints b)"
	apply (auto simp: Joints_def valuate_def product_listset_def product_aforms_def
	aform_vals_def[symmetric] aform_val_msum_aforms)
	subgoal for e
	apply (rule image_eqI[where
	x="(aform_vals e a,
	List.map2 (+) (aform_vals e (replicate (length b) (0, zero_pdevs))) (aform_vals (\<lambda>i. e (i + degree_aforms a)) b))"])
	apply (auto simp: split_beta')
	apply (auto simp: aform_vals_def intro!: nth_equalityI image_eqI[where x="\<lambda>i. e (i + degree_aforms a)"])
	done
	subgoal for e1 e2
	apply (rule image_eqI[where x="\<lambda>i. if i < degree_aforms a then e1 i else e2 (i - degree_aforms a)"])
	apply (auto simp: aform_vals_def aform_val_def Pi_iff
	intro!: nth_equalityI pdevs_val_degree_cong)
	subgoal premises prems for x xs k
	proof -
	from prems
	have "degree xs \<le> degree_aforms a"
	by (auto simp: degrees_def Max_gr_iff)
	then show ?thesis using prems by auto
	qed
	done
	done

	lemma product_aforms_refine:
	"(product_aforms, product_listset) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
	by (auto simp: aforms_rel_def br_def Joints_product_aforms)

	lemma mem_lv_rel_set_rel_iff:
	fixes z::"'a::executable_euclidean_space set"
	shows "(y, z) \<in> \<langle>lv_rel\<rangle>set_rel \<longleftrightarrow> (z = eucl_of_list ` y \<and> (\<forall>x \<in> y. length x = DIM('a)))"
	unfolding lv_rel_def
	by (auto simp: set_rel_def br_def)

	lemma eucl_of_list_mem_lv_rel: "length x = DIM('a::executable_euclidean_space) \<Longrightarrow>
	(x, eucl_of_list x::'a) \<in> lv_rel"
	unfolding lv_rel_def
	by (auto simp: br_def)

	lemma
	mem_Joints_msum_aforms'I:
	"a \<in> Joints x \<Longrightarrow> b \<in> Joints y \<Longrightarrow> List.map2 (+) a b \<in> Joints (msum_aforms' x y)"
	by (auto simp: Joints_msum_aforms degrees_def)

	lemma
	mem_Joints_msum_aforms'E:
	assumes "xa \<in> Joints (msum_aforms' x y)"
	obtains a b where "xa = List.map2 (+) a b" "a \<in> Joints x" "b \<in> Joints y"
	using assms
	by (auto simp: Joints_msum_aforms degrees_def)

	lemma msum_aforms'_refine_raw:
	shows "(msum_aforms' x y, {List.map2 (+) a b\|a b. a \<in> Joints x \<and> b \<in> Joints y}) \<in> aforms_rel"
	unfolding aforms_rel_def br_def
	by (safe elim!: mem_Joints_msum_aforms'E intro!: mem_Joints_msum_aforms'I) (auto simp: Joints_imp_length_eq)

	lemma aforms_relD: "(a, b) \<in> aforms_rel \<Longrightarrow> b = Joints a"
	by (auto simp: aforms_rel_def br_def)

	lemma msum_aforms'_refine:
	"(msum_aforms', \<lambda>xs ys. {List.map2 (+) x y \|x y. x \<in> xs \<and> y \<in> ys}) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
	by (safe dest!: aforms_relD intro!: msum_aforms'_refine_raw)

	lemma length_inf_aforms[simp]: "length (inf_aforms optns x) = length x"
	and length_sup_aforms[simp]: "length (sup_aforms optns x) = length x"
	by (auto simp: inf_aforms_def sup_aforms_def)

	lemma inf_aforms_refine:
	"(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (inf_aforms optns xi), Inf_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
	unfolding o_def
	apply (auto simp: br_def aforms_rel_def mem_lv_rel_set_rel_iff nres_rel_def Inf_specs_def
	intro!: RETURN_SPEC_refine)
	unfolding lv_rel_def
	by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
	eucl_of_list_inner inf_aforms_def nth_in_AffineI
	intro!: Inf_aform'_Affine_le list_all2_all_nthI)

	lemma sup_aforms_refine:
	"(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (sup_aforms optns xi), Sup_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
	unfolding o_def
	apply (auto simp: aforms_relp_def mem_lv_rel_set_rel_iff nres_rel_def Sup_specs_def
	intro!: RETURN_SPEC_refine)
	unfolding lv_rel_def
	by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
	eucl_of_list_inner sup_aforms_def nth_in_AffineI
	intro!: Sup_aform'_Affine_ge list_all2_all_nthI)

	lemma nres_of_THE_DRES_le:
	assumes "\<And>v. x = Some v \<Longrightarrow> RETURN v \<le> y"
	shows "nres_of (THE_DRES x) \<le> y"
	using assms by (auto simp: THE_DRES_def split: option.split)

	lemma degree_le_fresh_index: "a \<in> set A \<Longrightarrow> degree_aform a \<le> fresh_index_aforms A"
	by (auto simp: fresh_index_aforms_def intro!: Max_ge)

	lemma zero_in_JointsI: "xs \<in> Joints XS \<Longrightarrow> z = (0, zero_pdevs) \<Longrightarrow> 0 # xs \<in> Joints (z # XS)"
	by (auto simp: Joints_def valuate_def)

	lemma cancel_nonneg_pos_add_multI: "0 \<le> c + c * x"
	if "c \<ge> 0" "1 + x \<ge> 0"
	for c x::real
	proof -
	have "0 \<le> c + c * x \<longleftrightarrow> 0 \<le> c * (1 + x)" by (auto simp: algebra_simps)
	also have "\<dots> \<longleftrightarrow> 0 \<le> 1 + x"
	using that
	by (auto simp: zero_le_mult_iff)
	finally show ?thesis
	using that by simp
	qed

	lemma Joints_map_split_aform:
	fixes x::"real aform list"
	shows "Joints x \<subseteq> Joints (map (\<lambda>a. fst (split_aform a i)) x) \<union> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
	unfolding subset_iff
	apply (intro allI impI)
	proof goal_cases
	case (1 xs)
	then obtain e where e: "e \<in> funcset UNIV {-1 .. 1}" "xs = map (aform_val e) x"
	by (auto simp: Joints_def valuate_def)
	consider "e i \<ge> 0" \| "e i \<le> 0" by arith
	then show ?case
	proof cases
	case 1
	let ?e = "e(i:= 2 * e i - 1)"
	note e(2)
	also
	have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. snd (split_aform b i)) x)"
	by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
	also have "\<dots> \<in> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
	using e \<open>0 \<le> e i\<close>
	by (auto simp: Joints_def valuate_def Pi_iff intro!: image_eqI[where x = ?e])
	finally show ?thesis by simp
	next
	case 2
	let ?e = "e(i:= 2 * e i + 1)"
	note e(2)
	also
	have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. fst (split_aform b i)) x)"
	by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
	also have "\<dots> \<in> Joints (map (\<lambda>b. fst (split_aform b i)) x)"
	using e \<open>0 \<ge> e i\<close>
	by (auto simp: Joints_def valuate_def Pi_iff real_0_le_add_iff
	intro!: image_eqI[where x = ?e] cancel_nonneg_pos_add_multI)
	finally show ?thesis by simp
	qed
	qed


	lemma split_aforms_lemma:
	fixes x::"real aform list"
	assumes "(x, y) \<in> aforms_rel"
	assumes "z \<subseteq> y"
	assumes "l = (length x)"
	shows "\<exists>a b. (split_aforms x i, a, b)
	\<in> aforms_rel \<times>\<^sub>r aforms_rel \<and> env_len a l \<and> env_len b l \<and> z \<subseteq> a \<union> b"
	using assms
	apply (auto simp: split_aforms_def o_def)
	apply (rule exI[where x="Joints (map (\<lambda>x. fst (split_aform x i)) x)"])
	apply auto
	subgoal by (auto intro!: brI simp: aforms_rel_def)
	apply (rule exI[where x="Joints (map (\<lambda>x. snd (split_aform x i)) x)"])
	apply (rule conjI)
	subgoal by (auto intro!: brI simp: aforms_rel_def)
	subgoal
	using Joints_map_split_aform[of x i]
	by (auto simp: br_def aforms_rel_def env_len_def Joints_imp_length_eq)
	done

	lemma length_summarize_pdevs_list[simp]:
	"length (summarize_pdevs_list a b c d) = length d"
	by (auto simp: summarize_pdevs_list_def)

	lemma length_summarize_aforms[simp]:
	"length (summarize_aforms a b e d) = length d"
	by (auto simp: summarize_aforms_def Let_def)

	lemma
	split_aform_largest_take_refine:
	"(ni, n) \<in> nat_rel \<Longrightarrow>
	(xi::real aform list, x) \<in> aforms_rel \<Longrightarrow>
	length xi = d \<Longrightarrow> (RETURN (split_aforms_largest_uncond_take ni xi), split_spec_params d n x) \<in> \<langle>aforms_rel \<times>\<^sub>r aforms_rel\<rangle>nres_rel"
	apply (auto simp: split_spec_params_def nres_rel_def aforms_relp_def mem_lv_rel_set_rel_iff
	split_aforms_largest_uncond_take_def Let_def comps
	split: prod.splits
	intro!: RETURN_SPEC_refine)
	apply (rule split_aforms_lemma)
	by (auto simp add: aforms_rel_def)

	lemma aform_val_pdevs_of_real[simp]: "aform_val e (pdevs_of_real x) = x"
	by (auto simp: pdevs_of_real_def)

	lemma degree_aform_pdevs_of_real[simp]: "degree_aform (pdevs_of_real x) = 0"
	by (auto simp: pdevs_of_real_def)

	lemma interpret_floatarith_inner_eq:
	shows "interpret_floatarith (inner_floatariths xs ys) vs =
	(\<Sum>(x, y) \<leftarrow> (zip xs ys). (interpret_floatarith x vs) * (interpret_floatarith y vs))"
	by (induction xs ys rule: inner_floatariths.induct) auto

	lemma approx_slp_outer_sing:
	"approx_slp_outer p (Suc 0) [fa] XS = Some R \<longleftrightarrow> (\<exists>Y.
	approx_floatarith p fa (map (\<lambda>x. (x, 0)) XS) = Some Y \<and>
	[aform_err_to_aform Y (max (degree_aforms XS) (degree_aform_err Y))] = R)"
	by (auto simp: approx_slp_outer_def bind_eq_Some_conv degrees_def)

	lemma aforms_err_aform_valsI:
	assumes "vs = aform_vals e XS"
	shows "vs \<in> aforms_err e (map (\<lambda>x. (x, 0)) (XS))"
	by (auto simp: assms aforms_err_def o_def aform_err_def aform_vals_def)


	lemma aform_val_degree_cong:
	"b = d \<Longrightarrow> (\<And>i. i < degree_aform d \<Longrightarrow> a i = c i) \<Longrightarrow> aform_val a b = aform_val c d"
	by (auto simp: aform_val_def intro!: pdevs_val_degree_cong)

	lemma mem_degree_aformD: "x \<in> set XS \<Longrightarrow> degree_aform x \<le> degree_aforms XS"
	by (auto simp: degrees_def)
	lemma degrees_append_leD1: "(degrees xs) \<le> degrees (xs @ ys)"
	unfolding degrees_def
	by (rule Max_mono) (auto simp: degrees_def min_def max_def Max_ge_iff image_Un Max_gr_iff)

	lemma inner_aforms':
	assumes "xs \<in> Joints XS"
	assumes "inner_aforms' p XS (map pdevs_of_real rs) = Some R"
	shows "(\<Sum>(x, y) \<leftarrow> (zip xs rs). x * y) \<in> Affine (hd R)" (is ?th1) "length R = 1" (is ?th2)
	proof -
	from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "xs = aform_vals e XS"
	by (auto simp: Joints_def valuate_def aform_vals_def)
	then have e: "xs @ rs = aform_vals e (XS @ map pdevs_of_real rs)"
	"xs @ rs \<in> Joints (XS @ map pdevs_of_real rs)"
	"length xs = length XS"
	"e \<in> funcset UNIV {- 1..1}"
	by (auto simp: aform_vals_def o_def degrees_def Joints_def valuate_def)
	have "approx_slp_outer p (Suc 0)
	([inner_floatariths (map floatarith.Var [0..<length XS])
	(map floatarith.Var [length XS..<length XS + length rs])])
	(XS @ map pdevs_of_real rs) =
	Some R"
	using assms(2)
	by (auto simp: inner_aforms'_def)
	then obtain Y where Y:
	"approx_floatarith p
	(inner_floatariths (map floatarith.Var [0..<length XS])
	(map floatarith.Var [length XS..<length XS + length rs]))
	(map (\<lambda>x. (x, 0)) (XS @ map pdevs_of_real rs)) =
	Some Y"
	"R = [aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))]"
	unfolding approx_slp_outer_sing by auto
	let ?m = "(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))"
	from approx_floatarith_Elem[OF Y(1) e(4) aforms_err_aform_valsI[OF e(1)]]
	have "interpret_floatarith
	(inner_floatariths (map floatarith.Var [0..<length XS]) (map floatarith.Var [length XS..<length XS + length rs]))
	(xs @ rs)
	\<in> aform_err e Y" "degree_aform_err Y \<le> max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)"
	by auto
	from aform_err_to_aformE[OF this] obtain err where err:
	"interpret_floatarith
	(inner_floatariths (map floatarith.Var [0..<length XS])
	(map floatarith.Var [length XS..<length XS + length rs]))
	(xs @ rs) =
	aform_val (e(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y) := err))
	(aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)))"
	"- 1 \<le> err" "err \<le> 1"
	by auto
	let ?e' = "(e(max (degrees (map snd XS @ map (snd \<circ> pdevs_of_real) rs)) (degree_aform_err Y) := err))"
	from e(1) have e': "xs @ rs = aform_vals ?e' (XS @ map pdevs_of_real rs)"
	apply (auto simp: aform_vals_def intro!: aform_val_degree_cong)
	apply (frule mem_degree_aformD)
	apply (frule le_less_trans[OF degrees_append_leD1])
	apply (auto simp: o_def)
	done
	from err have "interpret_floatarith
	(inner_floatariths (map floatarith.Var [0..<length XS])
	(map floatarith.Var [length XS..<length XS + length rs]))
	(xs @ rs)#xs@rs \<in> Joints (R @ XS @ map pdevs_of_real rs)"
	using e(1,3,4) e'
	apply (auto simp: valuate_def Joints_def
	intro!: nth_equalityI
	image_eqI[where x="?e'"])
	apply (simp add: Y aform_vals_def; fail)
	apply (simp add: Y o_def)
	apply (simp add: nth_append nth_Cons)
	apply (auto split: nat.splits simp: nth_append nth_Cons aform_vals_def)
	done
	then have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
	(map floatarith.Var
	[length XS..<
	length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) #
	xs @ rs
	\<in> Joints (R @ XS @ map pdevs_of_real rs)"
	apply (subst (asm)interpret_floatarith_inner_eq )
	apply (auto simp: )
	done
	also have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
	(map floatarith.Var
	[length XS..<
	length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) =
	(\<Sum>(x, y)\<leftarrow>zip xs rs. x * y)"
	by (auto simp: sum_list_sum_nth assms e(3) nth_append intro!: sum.cong)
	finally show ?th1 ?th2
	by (auto simp: Affine_def valuate_def Joints_def Y)
	qed

	lemma inner_aforms'_inner_lv_rel:
	"(a, a') \<in> aforms_rel \<Longrightarrow>
	inner_aforms' prec a (map pdevs_of_real a'a) = Some R \<Longrightarrow>
	x \<in> a' \<Longrightarrow> inner_lv_rel x a'a \<in> Affine (hd R)"
	unfolding mem_lv_rel_set_rel_iff
	unfolding lv_rel_def aforms_rel_def
	apply (auto simp: br_def)
	apply (subst arg_cong2[where f="(\<in>)", OF _ refl])
	defer
	apply (rule inner_aforms')
	apply (auto simp: br_def Joints_imp_length_eq inner_lv_rel_def)
	done

	lemma aform_inf_inner_refine:
	"(RETURN o2 aform_inf_inner optns, Inf_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	by (auto simp: aforms_relp_def nres_rel_def Inf_inners_def aform_inf_inner_def[abs_def] comp2_def
	iaN
	intro!: Inf_aform'_Affine_le inner_aforms'_inner_lv_rel
	split: option.splits list.splits)

	lemma aform_sup_inner_refine:
	"(RETURN o2 aform_sup_inner optns, Sup_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	by (auto simp: aforms_relp_def nres_rel_def Sup_inners_def aform_sup_inner_def[abs_def] comp2_def
	iaN
	intro!: Sup_aform'_Affine_ge inner_aforms'_inner_lv_rel
	split: option.splits list.splits)

	lemma lv_aforms_rel_comp_br_Affine_le: "lv_aforms_rel O br Affine top \<subseteq> \<langle>lv_rel\<rangle>aforms_relp"
	apply (auto simp: lv_aforms_rel_def aforms_relp_def br_def)
	apply (rule relcompI)
	apply (auto simp: aforms_rel_def intro!: brI )
	by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
	intro!: eucl_of_list_mem_eucl_of_list_aform intro!: in_image_eucl_of_list_eucl_of_list_aform)

	lemma bijective_lv_rel[relator_props]: "bijective lv_rel"
	unfolding lv_rel_def bijective_def
	apply (auto simp: br_def)
	by (metis eucl_of_list_inj)

	lemma sv_lv_rel_inverse[relator_props]: "single_valued (lv_rel\<inverse>)"
	using bijective_lv_rel
	by (rule bijective_imp_sv)

	lemma list_of_eucl_image_lv_rel_inverse:
	"(x, list_of_eucl ` x) \<in> \<langle>lv_rel\<inverse>\<rangle>set_rel"
	unfolding set_rel_sv[OF sv_lv_rel_inverse]
	- apply (auto simp: )
	+ apply auto
	apply (rule ImageI)
	apply (rule converseI)
	apply (rule lv_relI)
	apply auto
	apply (rule image_eqI)
	prefer 2 apply assumption
	unfolding lv_rel_def
	apply (auto simp: br_def)
	subgoal for y
	apply (rule exI[where x="list_of_eucl y"])
	apply auto
	done
	done

	lemma lv_rel_comp_lv_rel_inverse:
	"((lv_rel::(_\<times>'a::executable_euclidean_space) set) O lv_rel\<inverse>) = {(x, y). x = y \<and> length x = DIM('a)}"
	apply (auto simp: intro!: lv_relI)
	unfolding lv_rel_def
	by (auto simp: br_def intro!: eucl_of_list_inj)

	lemma inter_aform_plane_refine_aux:
	"d = CARD('n::enum) \<Longrightarrow>
	(xi, x) \<in> aforms_rel \<Longrightarrow> (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
	length xi = d \<Longrightarrow>
	length (normal si) = d \<Longrightarrow>
	(nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
	\<in> \<langle>aforms_rel\<rangle>nres_rel"
	proof (goal_cases)
	case 1
	from 1 have sis: "si = s"
	by (cases si; cases s) (auto simp: sctn_rel_def)
	have Dp: "DIM_precond TYPE('n rvec) CARD('n)"
	by auto
	have a: "(xi, eucl_of_list_aform xi::'n rvec aform) \<in> lv_aforms_rel"
	by (auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff 1
	Joints_imp_length_eq)
	have b: "(si, (Sctn (eucl_of_list (normal si)) (pstn si))::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	using 1
	by (cases si)
	(auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff
	Joints_imp_length_eq sctn_rel_def intro!: lv_relI)
	have a: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
	inter_aform_plane optns (eucl_of_list_aform xi::'n rvec aform) (Sctn (eucl_of_list (normal si)) (pstn si)))
	\<in> \<langle>lv_aforms_rel\<rangle>nres_rel"
	(is "(_, inter_aform_plane _ ?ea ?se) \<in> _")
	using inter_aform_plane_lv.refine[OF Dp IdI a b, of optns]
	by simp
	have b: "(inter_aform_plane optns ?ea ?se, inter_sctn_spec (Affine ?ea) ?se) \<in> \<langle>br Affine top\<rangle>nres_rel"
	using 1
	apply (auto simp: inter_sctn_spec_def nres_rel_def inter_aform_plane_def project_ncoord_aform_def
	inter_aform_plane_ortho_nres_def
	split: option.splits
	intro!: RETURN_SPEC_refine
	dest!: inter_inter_aform_plane_ortho)
	apply (auto simp: aform_rel_def br_def nres_rel_def comps bind_eq_Some_conv
	inter_sctn_spec_def inter_aform_plane_def plane_of_def aforms_relp_def aforms_rel_def
	mem_lv_rel_set_rel_iff
	intro!: RETURN_SPEC_refine nres_of_THE_DRES_le mem_Affine_project_coord_aformI
	dest!: inter_inter_aform_plane_ortho
	split: if_splits)
	apply (auto dest!: mem_Affine_project_coord_aformD simp: abs_in_Basis_iff plane_of_def)
	done
	from relcompI[OF a b]
	have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_spec (Affine ?ea) ?se) \<in>
	\<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel"
	by auto
	also have "\<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel \<subseteq> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
	unfolding nres_rel_comp
	apply (rule nres_rel_mono)
	apply (rule lv_aforms_rel_comp_br_Affine_le)
	done
	finally
	have step1: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
	inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)))
	\<in> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
	by simp
	have step2: "(inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)),
	inter_sctn_specs CARD('n) (Joints xi) si) \<in> \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel"
	apply (auto simp: inter_sctn_specs_def inter_sctn_spec_def simp: nres_rel_def intro!: SPEC_refine)
	subgoal for x
	apply (rule exI[where x="list_of_eucl ` x"])
	apply (auto simp: env_len_def plane_ofs_def intro: list_of_eucl_image_lv_rel_inverse)
	subgoal for y
	apply (rule image_eqI[where x="eucl_of_list y"])
	apply (subst list_of_eucl_eucl_of_list)
	apply (auto simp: 1 Joints_imp_length_eq)
	apply (rule subsetD, assumption)
	apply (auto simp: intro!: eucl_of_list_mem_eucl_of_list_aform 1)
	using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of y "normal si"]
	by (auto simp: plane_of_def 1 Joints_imp_length_eq)
	subgoal for y
	apply (drule subsetD, assumption)
	using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of "list_of_eucl y" "normal si"]
	by (auto simp: plane_of_def 1 Joints_imp_length_eq)
	done
	done
	from relcompI[OF step1 step2]
	have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_specs CARD('n) (Joints xi) si)
	\<in> \<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel" by simp
	also have "\<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel \<subseteq>
	\<langle>aforms_rel O Id\<rangle>nres_rel"
	unfolding nres_rel_comp O_assoc aforms_relp_def
	apply (rule nres_rel_mono)
	apply (rule relcomp_mono[OF order_refl])
	unfolding set_rel_sv[OF sv_lv_rel_inverse] set_rel_sv[OF lv_rel_sv]
	apply (auto simp: length_lv_rel)
	unfolding relcomp_Image[symmetric] lv_rel_comp_lv_rel_inverse
	apply (auto simp: Basis_not_uminus length_lv_rel)
	unfolding lv_rel_def
	subgoal for a b c d
	apply (auto dest!: brD simp: length_lv_rel)
	using eucl_of_list_inj[where 'a="'n rvec", of d b]
	by auto
	done
	finally show ?case using 1 by (simp add: aforms_rel_def br_def sis)
	qed

	end

	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a list"})\<close>
	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>

	lemmas inter_aform_plane_refine_unoverloaded0 =
	inter_aform_plane_refine_aux[internalize_sort "'n::enum",
	unoverload enum_class.enum,
	unoverload enum_class.enum_all,
	unoverload enum_class.enum_ex]

	theorem
	inter_aform_plane_refine_unoverloaded:
	"class.enum (enum::'a list) enum_all enum_ex \<and> d = CARD('a) \<Longrightarrow>
	(xi, x) \<in> aforms_rel \<Longrightarrow>
	(si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
	length xi = d \<Longrightarrow>
	length (normal si) = d \<Longrightarrow>
	(nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
	\<in> \<langle>aforms_rel\<rangle>nres_rel"
	by (rule inter_aform_plane_refine_unoverloaded0) auto

	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a::enum list"})\<close>
	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
	setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>

	context includes autoref_syntax begin

	text \<open>TODO: this is a special case of \<open>Cancel_Card_Constraint\<close> from \<open>AFP/Perron_Frobenius\<close>!\<close>
	lemma type_impl_card_n_enum:
	assumes "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< n :: nat}"
	obtains enum enum_all enum_ex
	where "class.enum (enum::'a list) enum_all enum_ex \<and> n = CARD('a)"
	proof -
	from assms obtain rep :: "'a \<Rightarrow> nat" and abs :: "nat \<Rightarrow> 'a"
	where t: "type_definition rep abs {0 ..<n}" by auto
	then interpret type_definition rep abs \<open>{0 ..<n}\<close> .
	have "card (UNIV :: 'a set) = card {0 ..< n}"
	by (rule card)
	also have "\<dots> = n" by auto
	finally have bn: "CARD ('a) = n" .

	let ?enum = "(map abs [0..<n])"
	have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum))"
	by standard (auto simp: distinct_map univ Abs_inject intro: inj_onI)
	with bn have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum)) \<and> n = CARD('a)"
	by simp
	then show ?thesis ..
	qed


	lemma inter_aform_plane_refine_ex_typedef:
	"(xi, x) \<in> aforms_rel \<Longrightarrow>
	(si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
	length xi = d \<Longrightarrow>
	length (normal si) = d \<Longrightarrow>
	(nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
	\<in> \<langle>aforms_rel\<rangle>nres_rel"
	if "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< d :: nat}"
	by (rule type_impl_card_n_enum[OF that]) (rule inter_aform_plane_refine_unoverloaded; assumption)

	lemma inter_aform_plane_refine:
	"0 < d \<Longrightarrow>
	(xi, x) \<in> aforms_rel \<Longrightarrow>
	(si, s) \<in> \<langle>Id\<rangle>sctn_rel \<Longrightarrow>
	length xi = d \<Longrightarrow>
	length (normal si) = d \<Longrightarrow>
	(nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
	\<in> \<langle>aforms_rel\<rangle>nres_rel"
	by (rule inter_aform_plane_refine_ex_typedef[cancel_type_definition, simplified])

	lemma Joints_reduce_aforms: "x \<in> Joints X \<Longrightarrow> x \<in> Joints (reduce_aforms prec t X)"
	proof (auto simp: reduce_aforms_def summarize_threshold_def[abs_def] Joints_def valuate_def aform_val_def, goal_cases)
	case (1 e)
	from summarize_aformsE[OF \<open>e \<in> _\<close> order_refl]
	obtain e' where
	"aform_vals e X = aform_vals e' (summarize_aforms prec t (degree_aforms X) X)"
	"\<And>i. i < degree_aforms X \<Longrightarrow> e i = e' i"
	"e' \<in> funcset UNIV {- 1..1}"
	by blast
	thus ?case
	by (auto intro!: image_eqI[where x=e'] simp: aform_vals_def)
	qed

	lemma length_reduce_aform[simp]: "length (reduce_aforms optns a x) = length x"
	by (auto simp: reduce_aforms_def)

	lemma reduce_aform_refine:
	"(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow>
	(RETURN (reduce_aforms prec C xi), reduce_specs d r x) \<in> \<langle>aforms_rel\<rangle>nres_rel"
	apply (auto simp: reduce_specs_def nres_rel_def comps aforms_relp_def mem_lv_rel_set_rel_iff
	aforms_rel_def env_len_def
	intro!: RETURN_SPEC_refine)
	apply (auto simp: br_def env_len_def)
	by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
	intro!: in_image_eucl_of_list_eucl_of_list_aform Joints_reduce_aforms
	eucl_of_list_mem_eucl_of_list_aform)

	lemma aform_euclarithform_refine:
	"(nres_of o2 aform_form optns, approx_form_spec) \<in> Id \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	by (auto simp: approx_form_spec_def nres_rel_def comps aform_form_def
	aforms_rel_def br_def approx_form_aform
	dest!: approx_form_aux
	intro!: ivls_of_aforms)

	lemma aform_isFDERIV:
	"(\<lambda>N xs fas vs. nres_of (aform_isFDERIV optns N xs fas vs), isFDERIV_spec)
	\<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel \<rightarrow> \<langle>Id\<rangle>list_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	by (auto simp: isFDERIV_spec_def nres_rel_def comps aform_isFDERIV_def
	aforms_rel_def br_def
	dest!: approx_form_aux
	intro!: ivls_of_aforms isFDERIV_approx)

	lemma approx_slp_lengthD: "approx_slp p slp a = Some xs \<Longrightarrow>
	length xs = length slp + length a"
	by (induction slp arbitrary: xs a) (auto simp: bind_eq_Some_conv)

	lemma approx_slp_outer_lengthD: "approx_slp_outer p d slp a = Some xs \<Longrightarrow>
	length xs = min d (length slp + length a)"
	by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv o_def
	aforms_err_to_aforms_def aform_err_to_aform_def dest!: approx_slp_lengthD)

	lemma approx_slp_refine:
	"(nres_of o3 aform_slp prec, approx_slp_spec fas) \<in>
	nat_rel \<rightarrow> fas_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>\<langle>aforms_rel\<rangle>option_rel\<rangle>nres_rel"
	apply (auto simp: approx_slp_spec_def comps aform_slp_def nres_rel_def
	intro!: RETURN_SPEC_refine ASSERT_refine_right)
	subgoal for a b
	apply (rule exI[where x = "map_option Joints (approx_slp_outer prec (length fas) (slp_of_fas fas) a)"])
	apply (auto simp: option.splits aforms_rel_def br_def env_len_def Joints_imp_length_eq)
	apply (auto dest!: approx_slp_outer_lengthD)[]
	using length_slp_of_fas_le trans_le_add1 approx_slp_outer_lengthD apply blast
	using approx_slp_outer_plain by blast
	done

	lemma fresh_index_aforms_Nil[simp]: "fresh_index_aforms [] = 0"
	by (auto simp: fresh_index_aforms_def)

	lemma independent_aforms_Nil[simp]:
	"independent_aforms x [] = [x]"
	by (auto simp: independent_aforms_def)

	lemma mem_Joints_zero_iff[simp]: "x # xs \<in> Joints ((0, zero_pdevs) # XS) \<longleftrightarrow> (x = 0 \<and> xs \<in> Joints XS)"
	by (auto simp: Joints_def valuate_def)

	lemma Joints_independent_aforms_eq: "Joints (independent_aforms x xs) = set_Cons (Affine x) (Joints xs)"
	by (simp add: independent_aforms_def Joints_msum_aform degree_le_fresh_index set_Cons_def)

	lemma independent_aforms_refine: "(independent_aforms, set_Cons) \<in> \<langle>rnv_rel\<rangle>aform_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
	by (auto simp: aforms_rel_def br_def aform_rel_def Joints_independent_aforms_eq)

	end


	locale aform_approximate_sets = approximate_sets
	aform_ops
	Joints
	aforms_rel
	begin

	lemma Joints_in_lv_rel_set_relD:
	"(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
	unfolding lv_rel_def set_rel_br
	by (auto simp: br_def Joints_imp_length_eq eucl_of_list_image_Joints[symmetric])

	lemma ncc_precond: "ncc_precond TYPE('a::executable_euclidean_space)"
	unfolding ncc_precond_def ncc_def appr_rel_def
	by (auto simp: aforms_rel_def compact_Affine convex_Affine dest!: Joints_in_lv_rel_set_relD brD)

	lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
	fst (eucl_of_list_aform x)"
	by (auto simp: eucl_of_list_aform_def o_def)

	lemma
	Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
	"Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
	by (auto simp: Affine_def valuate_def aform_val_def
	elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
	pdevs_val_of_list_of_pdevs[where X = "snd x"])

	end

	lemma aform_approximate_sets: "aform_approximate_sets prec"
	apply (unfold_locales)
	unfolding aform_ops_def approximate_set_ops.simps
	subgoal unfolding relAPP_def aforms_rel_def .
	subgoal by (force simp: aforms_of_ivls_refine)
	subgoal by (rule product_aforms_refine)
	subgoal by (rule msum_aforms'_refine)
	subgoal by (rule inf_aforms_refine)
	subgoal by (rule sup_aforms_refine)
	subgoal by (rule split_aform_largest_take_refine)
	subgoal by (rule aform_inf_inner_refine)
	subgoal by (rule aform_sup_inner_refine)
	subgoal by (rule inter_aform_plane_refine) simp_all
	subgoal by (auto split: option.splits intro!: reduce_aform_refine)
	subgoal by (force simp: width_spec_def nres_rel_def)
	subgoal by (rule approx_slp_refine)
	subgoal by (rule aform_euclarithform_refine)
	subgoal by (rule aform_isFDERIV)
	subgoal by simp
	subgoal by (auto simp: Joints_imp_length_eq)
	subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
	subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
	subgoal by (auto simp: Joints_imp_length_eq)
	done

	end
	diff --git a/thys/Ordinary_Differential_Equations/Numerics/Transfer_Euclidean_Space_Vector.thy b/thys/Ordinary_Differential_Equations/Numerics/Transfer_Euclidean_Space_Vector.thy
	--- a/thys/Ordinary_Differential_Equations/Numerics/Transfer_Euclidean_Space_Vector.thy
	+++ b/thys/Ordinary_Differential_Equations/Numerics/Transfer_Euclidean_Space_Vector.thy
	@@ -1,685 +1,685 @@
	theory Transfer_Euclidean_Space_Vector
	imports
	"../Refinement/Refine_Vector_List"
	Transfer_ODE
	begin

	type_synonym 'n rvec = "(real, 'n) vec"
	type_synonym 'n vec1 = "(real, 'n) vec \<times> ((real, 'n) vec, 'n) vec" \<comment> \<open>vector with C1 information\<close>
	type_synonym 'a c1_info = "'a \<times> ('a \<Rightarrow>\<^sub>L 'a)"
	type_synonym 'n eucl1 = "'n rvec c1_info" \<comment> \<open>abstract C1 information\<close>

	subsection \<open>Casting function\<close>

	definition "cast = eucl_of_list o list_of_eucl"

	lemma cast_eqI: "cast x = y" if "list_of_eucl x = list_of_eucl y"
	using that by (auto simp: cast_def)

	lemma cast_eqI2: "cast (x::'a) = (y::'b)"
	if "x = cast y" and "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	apply (rule cast_eqI)
	using that
	by (auto intro!: nth_equalityI simp: cast_def)

	lemma cast_Basis_list_nth[simp]: "cast (Basis_list ! i::'a) = (Basis_list ! i::'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "i < DIM('b)"
	apply (rule cast_eqI)
	using that
	by (auto simp: inner_Basis nth_eq_iff_index_eq intro!: nth_equalityI)

	lemma cast_inner[simp]:
	"cast x \<bullet> (cast y::'b) = x \<bullet> (y::'a)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	using that
	by (subst (2) euclidean_inner)
	(auto simp: cast_def eucl_of_list_inner_eq inner_lv_rel_def sum_Basis_sum_nth_Basis_list
	sum_list_sum_nth atLeast0LessThan)

	lemma cast_inner_Basis_list_nth[simp]:
	"cast x \<bullet> (Basis_list::'a list) ! i = x \<bullet> (Basis_list::'b list) ! i"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "i < DIM('b)"
	using that
	by (auto simp: cast_def eucl_of_list_inner)

	lemma cast_eucl_of_list[simp]:
	"cast (eucl_of_list xs::'a) = (eucl_of_list xs::'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)" "length xs = DIM('b)"
	using that
	by (auto simp: intro!: euclidean_eqI[where 'a='b])
	(auto simp: cast_def eucl_of_list_inner dest!: in_Basis_index_Basis_list)

	lemma norm_cast[simp]: "norm (cast x::'a) = norm (x::'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	unfolding norm_conv_dist
	apply (subst (1 2) euclidean_dist_l2)
	using that
	apply (auto simp: L2_set_def sum_Basis_sum_nth_Basis_list cong: sum.cong)
	apply (subst sum.cong[OF refl])
	apply (subst cast_inner_Basis_list_nth)
	apply auto
	done

	lemma linear_cast: "linear (cast::'a\<Rightarrow>'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	apply standard
	using that
	by (auto simp: inner_simps intro!: cast_eqI nth_equalityI exI[where x=1])

	lemma bounded_linear_cast: "bounded_linear (cast::'a\<Rightarrow>'b)"
	if "DIM('a::executable_euclidean_space) = DIM('b::executable_euclidean_space)"
	apply standard
	using that
	by (auto simp: inner_simps intro!: cast_eqI nth_equalityI exI[where x=1])

	lemmas [bounded_linear_intros] = bounded_linear_compose[OF bounded_linear_cast]

	lemma cast_id[simp]: "cast i = i"
	by (simp add: cast_eqI)

	definition cast_bl where "cast_bl f = Blinfun (cast o blinfun_apply f o cast)"

	lemma cast_bl_rep: "cast_bl (f::'a \<Rightarrow>\<^sub>L 'b) x = (cast (f (cast (x::'c)))::'d)"
	if [bounded_linear_intros]:
	"DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	unfolding cast_bl_def o_def
	apply (subst bounded_linear_Blinfun_apply)
	apply (rule bounded_linear_intros)+
	apply auto
	done

	definition "cast_eucl1 x = (cast (fst x), cast_bl (snd x))"

	definition [simp]: "op_cast_image = (`) cast"
	definition [simp]: "op_cast_eucl1_image = (`) cast_eucl1"
	context includes autoref_syntax begin
	lemma [autoref_op_pat_def]:
	"(`) cast \<equiv> OP op_cast_image"
	"(`) cast_eucl1 \<equiv> OP op_cast_eucl1_image"
	by auto
	end

	lemma cast_idem[simp]:
	"cast (cast (x::'c)::'b) = (cast x::'a)"
	if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('c)"
	using that
	by (auto simp: cast_def intro!: )

	lemma cast_bl_idem[simp]:
	"cast_bl (cast_bl (x::'c\<Rightarrow>\<^sub>L'c)::'b\<Rightarrow>\<^sub>L'b) = (cast_bl x::'a\<Rightarrow>\<^sub>L'a)"
	if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('c)"
	using that
	by (auto simp: cast_bl_rep o_def intro!: blinfun_eqI)

	lemma cast_eucl1_idem[simp]:
	"cast_eucl1 (cast_eucl1 (x::'c c1_info)::'b c1_info) = (cast_eucl1 x::'a c1_info)"
	if "DIM('a::executable_euclidean_space) = DIM('c::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('c)"
	using that
	by (auto simp: cast_def cast_eucl1_def intro!: )

	lemma linear_cast_bl:
	"linear (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd))"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	by standard
	(auto intro!: blinfun_eqI
	simp: cast_bl_rep that blinfun.bilinear_simps linear_cast linear_add linear.scaleR)
	lemma norm_cast_bl_le: "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) \<le> norm x"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	apply (rule norm_blinfun_bound)
	using that
	apply (auto simp: cast_bl_rep)
	apply (rule norm_blinfun[THEN order_trans])
	apply auto
	done

	lemma norm_cast_bl_idem[simp]: "cast_bl ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) = x"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	by (auto intro!: blinfun_eqI simp: that cast_bl_rep)

	lemma norm_cast_bl[simp]: "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) = norm x"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	proof (rule antisym)
	show "norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x) \<le> norm x"
	by (rule norm_cast_bl_le; fact)
	have "norm x = norm ((cast_bl::('c \<Rightarrow>\<^sub>L'd) \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)) ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x))"
	by (simp add: that)
	also note norm_cast_bl_le[OF that, of "cast_bl x"]
	finally show "norm x \<le> norm ((cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) x)"
	apply (rule order_trans)
	defer
	apply (rule norm_cast_bl_le)
	using that by auto
	qed

	lemma bounded_linear_cast_bl:
	"bounded_linear (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd))"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	by standard
	(auto intro!: blinfun_eqI exI[where x=1]
	simp: cast_bl_rep that blinfun.bilinear_simps linear_cast linear_add linear.scaleR)

	lemma cast_bl_has_derivative[derivative_intros]:
	"((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_derivative (\<lambda>x. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g' x))) (at x within X)"
	if "(g has_derivative g') (at x within X)"
	"DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	apply (rule has_derivative_compose[of g _ _ _ cast_bl, THEN has_derivative_eq_rhs])
	defer apply (rule bounded_linear_imp_has_derivative)
	apply (rule bounded_linear_cast_bl)
	using that
	apply auto
	done

	lemma cast_bl_has_vector_derivative[derivative_intros]:
	"((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_vector_derivative cast_bl g') (at x within X)"
	if "(g has_vector_derivative g') (at x within X)"
	"DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	using that
	by (auto simp: has_vector_derivative_def blinfun.bilinear_simps cast_bl_rep linear.scaleR
	linear_cast_bl
	intro!: cast_bl_has_derivative derivative_eq_intros ext blinfun_eqI)

	lemma cast_bl_has_vderiv_on:
	"((\<lambda>a. (cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g a)) has_vderiv_on vd) X"
	if "(g has_vderiv_on g') X" "\<And>t. t \<in> X \<Longrightarrow> vd t = cast_bl (g' t)"
	"DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	using that
	by (auto simp: has_vderiv_on_def intro!: derivative_eq_intros)

	lemma cast_bl_compose:
	"(cast_bl::('a \<Rightarrow>\<^sub>L'b) \<Rightarrow> ('c \<Rightarrow>\<^sub>L 'd)) (g o\<^sub>L h) =
	((cast_bl:: 'e \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'f \<Rightarrow>\<^sub>L 'd) g o\<^sub>L (cast_bl:: 'a \<Rightarrow>\<^sub>L 'e \<Rightarrow> 'c \<Rightarrow>\<^sub>L 'f) h)"
	if "DIM('c::executable_euclidean_space) = DIM('a::executable_euclidean_space)"
	"DIM('b::executable_euclidean_space) = DIM('d::executable_euclidean_space)"
	"DIM('e::executable_euclidean_space) = DIM('f::executable_euclidean_space)"
	by (auto intro!: blinfun_eqI simp: cast_bl_rep that)

	locale transfer_eucl_vec =
	fixes a::"'a::executable_euclidean_space" and n::"'n::enum"
	assumes dim[simp]: "DIM('a) = CARD('n)"
	begin

	context includes lifting_syntax begin

	subsection \<open>Transfer from euclidean space to vector\<close>

	definition "rel_ve (x::(real, 'n)vec) (y::'a) \<longleftrightarrow> list_of_eucl x = list_of_eucl y"

	lemma [transfer_rule]: "bi_total rel_ve"
	apply (auto intro!: bi_totalI left_totalI right_totalI simp: rel_ve_def intro!: )
	subgoal for x by (auto intro!: exI[where x="eucl_of_list (list_of_eucl x)"] nth_equalityI simp: dim)
	subgoal for x by (auto intro!: exI[where x="eucl_of_list (list_of_eucl x)"] nth_equalityI simp: dim)
	done

	lemma [transfer_rule]: "bi_unique rel_ve"
	by (auto intro!: bi_uniqueI left_uniqueI right_uniqueI simp: rel_ve_def )
	(metis eucl_of_list_list_of_eucl)+

	text \<open>@{const Inf} is underspecified\<close>
	text \<open>@{const Sup} is underspecified\<close>

	lemma inf_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> rel_ve) inf inf"
	by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_inf_left
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma sup_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> rel_ve) sup sup"
	by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_sup_left
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma abs_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve) abs abs"
	by (auto simp: rel_ve_def nth_eq_iff_index inner_Basis_sup_left abs_inner
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma less_eq_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> (=)) less_eq less_eq"
	by (auto simp: rel_ve_def nth_eq_iff_index eucl_le_Basis_list_iff[where 'a='a]
	eucl_le_Basis_list_iff[where 'a="'n rvec"]
	list_of_eucl_eq_iff intro!: rel_funI )

	lemma scaleR_transfer[transfer_rule]:
	"((=) ===> rel_ve ===> rel_ve) scaleR scaleR"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma Basis_transfer[transfer_rule]:
	"(rel_set rel_ve) Basis Basis"
	apply (rule rel_setI)
	subgoal for x by (auto simp: rel_ve_def list_of_eucl_eq_iff inner_Basis nth_eq_iff_index
	intro!: bexI[where x="Basis_list ! index Basis_list x"])
	subgoal for x by (auto simp: rel_ve_def list_of_eucl_eq_iff inner_Basis nth_eq_iff_index
	intro!: bexI[where x="Basis_list ! index Basis_list x"])
	done

	lemma zero_transfer[transfer_rule]:
	"rel_ve 0 0"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma uminus_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve) uminus uminus"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma plus_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> rel_ve) (+) (+)"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma minus_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> rel_ve) (-) (-)"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma Basis_list_transfer[transfer_rule]:
	"(list_all2 rel_ve) Basis_list Basis_list"
	by (auto simp: list_all2_iff in_set_zip rel_ve_def inner_Basis
	nth_eq_iff_index intro!: nth_equalityI)

	lemma eucl_down_transfer[transfer_rule]:
	"((=) ===> rel_ve ===> rel_ve) eucl_down eucl_down"
	unfolding eucl_down_def
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma eucl_truncate_up_transfer[transfer_rule]:
	"((=) ===> rel_ve ===> rel_ve) eucl_truncate_up eucl_truncate_up"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma eucl_truncate_down_transfer[transfer_rule]:
	"((=) ===> rel_ve ===> rel_ve) eucl_truncate_down eucl_truncate_down"
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index
	list_of_eucl_eq_iff intro!: rel_funI)

	lemma inner_transfer[transfer_rule]:
	"(rel_ve ===> rel_ve ===> (=)) inner inner"
	apply (subst euclidean_inner[where 'a="'a", abs_def])
	apply (subst euclidean_inner[where 'a="'n rvec", abs_def])
	by (auto simp: rel_ve_def algebra_simps nth_eq_iff_index inner_simps nth_eq_iff_index
	sum_Basis_sum_nth_Basis_list list_of_eucl_eq_iff intro!: rel_funI)

	lemma rel_ve_cast: "rel_ve (x::'n rvec) (y::'a) \<longleftrightarrow> x = cast y"
	apply (auto simp: rel_ve_def cast_def intro!: rel_funI)
	by (metis eucl_of_list_list_of_eucl)

	lemma rel_ve_cast': "rel_ve (x::'n rvec) (y::'a) \<longleftrightarrow> cast x = y"
	by (auto simp: rel_ve_def cast_def)

	lemma cast_transfer[transfer_rule]: "(rel_ve ===> (=)) (\<lambda>x. x) cast"
	by (auto simp: rel_ve_cast)

	lemma cast_transfer'[transfer_rule]: "((=) ===> rel_ve) (\<lambda>x. x) cast"
	by (auto simp: rel_ve_cast')

	lemma bounded_linear_cast: "bounded_linear (cast::'a \<Rightarrow> 'n rvec)"
	by transfer (rule bounded_linear_ident)

	lemma bounded_linear_cast': "bounded_linear (cast::'n rvec \<Rightarrow> 'a)"
	by transfer (rule bounded_linear_ident)

	context includes blinfun.lifting begin

	lemmas [simp] = cast_bl_rep

	lemma eucl_of_list_transfer[transfer_rule]: "(list_all2 (=) ===> rel_ve) eucl_of_list eucl_of_list"
	unfolding eucl_of_list_def
	by transfer_prover

	lemma list_of_eucl_transfer[transfer_rule]: "(rel_ve ===> list_all2 (=)) list_of_eucl list_of_eucl"
	unfolding list_of_eucl_def
	by transfer_prover

	lemma blinfun_of_matrix_transfer[transfer_rule]:
	"((rel_ve ===> rel_ve ===> (=)) ===> (rel_blinfun rel_ve rel_ve)) blinfun_of_matrix blinfun_of_matrix"
	apply (rule rel_funI)
	apply transfer
	apply (rule rel_funI)
	unfolding rel_blinfun_def
	unfolding sum_Basis_sum_nth_Basis_list
	apply simp
	unfolding rel_ve_def list_of_eucl_eq_iff inner_sum_left
	apply simp
	apply (intro allI impI sum.cong refl)
	apply (rule arg_cong2[where f="(*)"])
	subgoal for a b c d e f g
	apply (rule arg_cong2[where f="(*)"])
	subgoal by simp
	apply (drule rel_funD[where x="Basis_list ! f"]) defer
	apply (drule rel_funD[where x="Basis_list ! g"]) defer
	apply assumption
	subgoal
	by (clarsimp simp: inner_Basis)
	(metis Basis_list_transfer dim index_Basis_list_nth length_Basis_list list_all2_lengthD)
	subgoal
	by (clarsimp simp: inner_Basis)
	(metis Basis_list_transfer dim index_Basis_list_nth length_Basis_list list_all2_lengthD)
	done
	subgoal for a b c d e f g
	apply (clarsimp simp: inner_Basis)
	by (metis (full_types, opaque_lifting) Basis_list_transfer dim index_Basis_list_nth length_Basis_list
	list_all2_conv_all_nth)
	done

	lemma transfer_cast[transfer_rule]: "(rel_ve ===> rel_ve) (\<lambda>x. x) cast"
	by (auto simp:)

	end

	end

	end

	lemma
	assumes [simp]: "DIM('a::executable_euclidean_space) = CARD('n::enum)"
	shows cast_cast[simp]: "cast (cast x::'n rvec) = (x::'a)" "cast (cast y::'a) = (y::'n rvec)"
	by (auto simp: cast_def cast_def)

	lifting_update blinfun.lifting
	lifting_forget blinfun.lifting

	locale transfer_eucl_vec_ll_on_open = transfer_eucl_vec a n + ll_on_open T f X
	for a::"'a::executable_euclidean_space" and n::"'n::enum" and T f and X::"'a set" +
	fixes vf vX
	defines "vf \<equiv> \<lambda>t x::'n rvec. cast (f t (cast x))::'n rvec"
	defines "vX \<equiv> cast ` X::'n rvec set"
	begin

	lemma transfer_X[transfer_rule]: "rel_set rel_ve vX X"
	and transfer_f[transfer_rule]: "(rel_fun (=) (rel_fun rel_ve rel_ve)) vf f"
	by (auto simp: rel_ve_cast cast_eqI vX_def vf_def intro!: rel_setI rel_funI)

	sublocale v: ll_on_open T vf vX
	by (rule ll_on_open_axioms[untransferred])

	context includes lifting_syntax begin

	lemma transfer_csols[transfer_rule]:
	"((=) ===> rel_ve ===> rel_set (rel_prod ((=) ===> rel_ve) (=))) v.csols csols"
	unfolding csols_def v.csols_def
	by transfer_prover

	lemma transfer_existence_ivl[transfer_rule]:
	"((=) ===> rel_ve ===> rel_set (=)) v.existence_ivl existence_ivl"
	unfolding existence_ivl_def v.existence_ivl_def
	by transfer_prover

	lemma cast_v_flow_cast_eq:
	assumes "t \<in> existence_ivl t0 x0"
	shows "cast (v.flow t0 (cast x0) t) = flow t0 x0 t"
	apply (rule equals_flowI[OF _ _ order_refl])
	subgoal
	apply (rule existence_ivl_initial_time)
	using assms mem_existence_ivl_iv_defined(1) apply blast
	using assms mem_existence_ivl_iv_defined(2) by blast
	subgoal by (rule is_interval_existence_ivl)
	subgoal
	apply (rule solves_odeI)
	subgoal using assms
	by (transfer) (rule v.flow_has_vderiv_on[OF v.mem_existence_ivl_iv_defined])
	subgoal using assms
	by transfer (rule v.flow_in_domain)
	done
	subgoal
	using mem_existence_ivl_iv_defined[OF assms]
	- apply (auto simp: )
	+ apply auto
	apply (subst v.flow_initial_time)
	subgoal by simp
	subgoal by transfer
	subgoal by transfer simp
	done
	subgoal by fact
	done

	lemma transfer_flow[transfer_rule]:
	"((=) ===> rel_ve ===> (=) ===> rel_ve) v.flow flow"
	apply (auto intro!: rel_funI simp: rel_ve_cast)
	subgoal for t0 x0 t
	apply (cases "t \<in> existence_ivl t0 (cast x0)")
	subgoal by (simp add: cast_eqI cast_v_flow_cast_eq[symmetric])
	subgoal
	apply (subst v.flow_def) apply (subst flow_def)
	apply (auto simp: cast_eqI)
	subgoal by transfer simp
	subgoal by transfer simp
	done
	done
	done

	end

	end


	locale transfer_c1_on_open_euclidean = transfer_eucl_vec a n + c1_on_open_euclidean f f' X
	for a::"'a::executable_euclidean_space" and n::"'n::enum" and f f' and X::"'a set" +
	fixes vf and vf'::"'n rvec \<Rightarrow> 'n rvec \<Rightarrow>\<^sub>L 'n rvec" and vX
	defines "vf \<equiv> \<lambda>x::'n rvec. cast (f (cast x))::'n rvec"
	defines vf'_def: "vf' \<equiv> \<lambda>x. cast_bl (f' (cast x))"
	defines "vX \<equiv> cast ` X::'n rvec set"
	begin

	context includes lifting_syntax begin

	lemma transfer_X[transfer_rule]: "rel_set rel_ve vX X"
	and transfer_f[transfer_rule]: "(rel_fun rel_ve rel_ve) vf f"
	by (auto simp: rel_ve_cast vX_def vf_def cast_eqI intro!: rel_setI rel_funI)

	lemma transfer_f'[transfer_rule]: "(rel_ve ===> (rel_blinfun rel_ve rel_ve)) vf' f'"
	by (auto intro!: rel_funI simp: cast_eqI rel_blinfun_def rel_ve_cast vf'_def)

	end

	sublocale v: c1_on_open_euclidean vf vf' vX
	unfolding c1_on_open_euclidean_def
	by (rule c1_on_open_axioms[unfolded c1_on_open_euclidean_def, untransferred])

	context includes lifting_syntax begin

	lemma transfer_csols[transfer_rule]:
	"((=) ===> rel_ve ===> rel_set (rel_prod ((=) ===> rel_ve) (=))) v.csols csols"
	unfolding csols_def v.csols_def
	by transfer_prover

	lemma transfer_existence_ivl[transfer_rule]:
	"((=) ===> rel_ve ===> rel_set (=)) v.existence_ivl existence_ivl"
	unfolding existence_ivl_def v.existence_ivl_def
	by transfer_prover

	lemma transfer_existence_ivl0[transfer_rule]:
	"(rel_ve ===> rel_set (=)) v.existence_ivl0 existence_ivl0"
	proof -
	interpret ll: transfer_eucl_vec_ll_on_open a n UNIV "\<lambda>_. f" X "\<lambda>_. vf" vX
	by unfold_locales (auto simp: vf_def)
	show ?thesis
	unfolding existence_ivl0_def v.existence_ivl0_def
	by transfer_prover
	qed

	lemma transfer_flow0[transfer_rule]:
	"(rel_ve ===> (=) ===> rel_ve) v.flow0 flow0"
	proof -
	interpret ll: transfer_eucl_vec_ll_on_open a n UNIV "\<lambda>_. f" X "\<lambda>_. vf" vX
	by unfold_locales (auto simp: vf_def)
	show ?thesis
	unfolding flow0_def v.flow0_def
	by transfer_prover
	qed

	lemma cast_v_Dflow_cast_eq:
	assumes "t \<in> existence_ivl0 x0"
	shows "cast_bl (v.Dflow (cast x0) t) = Dflow x0 t"
	proof -
	have "x0 \<in> X"
	using assms mem_existence_ivl_iv_defined(1) by blast
	have "0 \<in> existence_ivl0 x0"
	apply (rule existence_ivl_initial_time)
	apply simp
	apply fact
	done
	show ?thesis
	unfolding Dflow_def
	apply (rule mvar.equals_flowI[OF _ _ order_refl])
	subgoal
	apply (rule mvar.existence_ivl_initial_time)
	apply fact
	apply blast
	done
	subgoal by (rule mvar.is_interval_existence_ivl)
	subgoal
	apply (rule solves_odeI)
	subgoal
	proof -
	have *: "mvar.existence_ivl x0 0 1\<^sub>L = (v.mvar.existence_ivl (cast x0) 0 1\<^sub>L)"
	apply (subst mvar_existence_ivl_eq_existence_ivl, fact)
	apply (subst v.mvar_existence_ivl_eq_existence_ivl)
	subgoal using \<open>0 \<in> existence_ivl0 x0\<close> by (transfer)
	subgoal by transfer simp
	done
	have D: "(v.Dflow (cast x0) has_vderiv_on (\<lambda>t. v.vareq (cast x0) t o\<^sub>L v.mvar.flow (cast x0) 0 1\<^sub>L t))
	(mvar.existence_ivl x0 0 1\<^sub>L)"
	unfolding * v.Dflow_def
	apply (rule v.mvar.flow_has_vderiv_on[of 0 "cast x0" "1\<^sub>L"])
	subgoal using \<open>0 \<in> existence_ivl0 x0\<close> by (transfer)
	subgoal by transfer simp
	done
	have vareq_transfer: "vareq x0 x = cast_bl (v.vareq (cast x0) x)"
	if "x \<in> mvar.existence_ivl x0 0 1\<^sub>L"
	for x
	using that
	apply (subst (asm) mvar_existence_ivl_eq_existence_ivl)
	using \<open>0 \<in> existence_ivl0 x0\<close> apply simp
	unfolding vareq_def v.vareq_def
	apply (auto simp: blinfun_ext)
	apply transfer
	apply simp
	done
	show ?thesis
	apply (rule cast_bl_has_vderiv_on)
	apply (rule D)
	apply (simp_all add: v.Dflow_def blinfun_compose_assoc vareq_transfer)
	apply (subst cast_bl_compose)
	apply (auto simp: cast_bl_compose)
	done
	qed
	subgoal by simp
	done
	subgoal
	unfolding Dflow_def[symmetric]
	apply (subst Dflow_zero)
	apply fact
	apply (subst v.Dflow_zero)
	subgoal using \<open>x0 \<in> X\<close> by transfer simp
	subgoal by (auto simp: blinfun_ext)
	done
	subgoal
	by (subst mvar_existence_ivl_eq_existence_ivl; fact)
	done
	qed

	lemma transfer_Dflow[transfer_rule]:
	"(rel_ve ===> (=) ===> rel_blinfun rel_ve rel_ve) v.Dflow Dflow"
	apply (auto intro!: rel_funI simp: rel_ve_cast rel_blinfun_def)
	subgoal for x0 t d
	apply (cases "t \<in> mvar.existence_ivl (cast x0) 0 1\<^sub>L")
	subgoal
	apply (subst cast_v_Dflow_cast_eq[symmetric])
	using mvar.existence_ivl_subset[of "cast x0" 0 id_blinfun]
	by auto
	subgoal premises prems
	proof -
	have x0: "x0 \<notin> X \<longleftrightarrow> cast x0 \<notin> vX"
	by transfer simp
	have mvars: "mvar.existence_ivl x0 0 1\<^sub>L = v.mvar.existence_ivl (cast x0) 0 1\<^sub>L"
	apply (cases "cast x0 \<in> X")
	subgoal
	apply (subst mvar_existence_ivl_eq_existence_ivl)
	apply simp
	apply (subst v.mvar_existence_ivl_eq_existence_ivl)
	apply simp
	apply transfer apply simp
	apply transfer apply simp
	done
	subgoal premises prems
	proof -
	have "mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}"
	apply (subst mvar.existence_ivl_empty_iff)
	using prems
	by simp
	moreover have "v.mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}"
	apply (subst v.mvar.existence_ivl_empty_iff)
	using prems
	apply simp
	apply transfer apply simp
	done
	ultimately show ?thesis
	apply simp
	using \<open>mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}\<close> \<open>v.mvar.existence_ivl (cast x0) 0 1\<^sub>L = {}\<close> by auto
	qed
	done
	show ?thesis
	using prems
	apply (subst v.Dflow_def) apply (subst Dflow_def)
	apply (subst v.mvar.flow_def) apply (subst mvar.flow_def)
	unfolding mvars
	apply (auto simp: blinfun.bilinear_simps)
	using mvars apply blast
	subgoal premises apply transfer by simp
	done
	qed
	done
	done

	lemma returns_to_transfer[transfer_rule]:
	"(rel_set rel_ve ===> rel_ve ===> (=)) v.returns_to returns_to"
	unfolding returns_to_def v.returns_to_def
	by transfer_prover

	lemma return_time_transfer[transfer_rule]:
	"(rel_set rel_ve ===> rel_ve ===> (=)) v.return_time return_time"
	unfolding return_time_def v.return_time_def
	by transfer_prover

	lemma poincare_map_transfer[transfer_rule]:
	"(rel_set rel_ve ===> rel_ve ===> rel_ve) v.poincare_map poincare_map"
	unfolding v.poincare_map_def poincare_map_def
	by transfer_prover

	lemma poincare_mapsto_transfer[transfer_rule]:
	"(rel_set rel_ve
	===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	===> rel_set rel_ve
	===> rel_set rel_ve
	===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	===> (=)) v.poincare_mapsto poincare_mapsto"
	unfolding poincare_mapsto_def v.poincare_mapsto_def
	has_derivative_within differentiable_def
	by transfer_prover

	lemma flowsto_transfer[transfer_rule]:
	"(rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	===> rel_set (=)
	===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
	===> (=)) v.flowsto flowsto"
	unfolding flowsto_def v.flowsto_def
	by transfer_prover

	end

	end

	end
	diff --git a/thys/Ordinary_Differential_Equations/ODE_Auxiliarities.thy b/thys/Ordinary_Differential_Equations/ODE_Auxiliarities.thy
	--- a/thys/Ordinary_Differential_Equations/ODE_Auxiliarities.thy
	+++ b/thys/Ordinary_Differential_Equations/ODE_Auxiliarities.thy
	@@ -1,620 +1,620 @@
	section \<open>Auxiliary Lemmas\<close>
	theory ODE_Auxiliarities
	imports
	"HOL-Analysis.Analysis"
	"HOL-Library.Float"
	"List-Index.List_Index"
	Affine_Arithmetic.Affine_Arithmetic_Auxiliarities
	Affine_Arithmetic.Executable_Euclidean_Space
	begin

	instantiation prod :: (zero_neq_one, zero_neq_one) zero_neq_one
	begin

	definition "1 = (1, 1)"

	instance by standard (simp add: zero_prod_def one_prod_def)
	end

	subsection \<open>there is no inner product for type @{typ "'a \<Rightarrow>\<^sub>L 'b"}\<close>

	lemma (in real_inner) parallelogram_law: "(norm (x + y))\<^sup>2 + (norm (x - y))\<^sup>2 = 2 * (norm x)\<^sup>2 + 2 * (norm y)\<^sup>2"
	proof -
	have "(norm (x + y))\<^sup>2 + (norm (x - y))\<^sup>2 = inner (x + y) (x + y) + inner (x - y) (x - y)"
	by (simp add: norm_eq_sqrt_inner)
	also have "\<dots> = 2 * (norm x)\<^sup>2 + 2 * (norm y)\<^sup>2"
	by (simp add: algebra_simps norm_eq_sqrt_inner)
	finally show ?thesis .
	qed

	locale no_real_inner
	begin

	lift_definition fstzero::"(realreal) \<Rightarrow>\<^sub>L (realreal)" is "\<lambda>(x, y). (x, 0)"
	by (auto intro!: bounded_linearI')

	lemma [simp]: "fstzero (a, b) = (a, 0)"
	by transfer simp

	lift_definition zerosnd::"(realreal) \<Rightarrow>\<^sub>L (realreal)" is "\<lambda>(x, y). (0, y)"
	by (auto intro!: bounded_linearI')

	lemma [simp]: "zerosnd (a, b) = (0, b)"
	by transfer simp

	lemma fstzero_add_zerosnd: "fstzero + zerosnd = id_blinfun"
	by transfer auto

	lemma norm_fstzero_zerosnd: "norm fstzero = 1" "norm zerosnd = 1" "norm (fstzero - zerosnd) = 1"
	by (rule norm_blinfun_eqI[where x="(1, 0)"]) (auto simp: norm_Pair blinfun.bilinear_simps
	intro: norm_blinfun_eqI[where x="(0, 1)"] norm_blinfun_eqI[where x="(1, 0)"])

	text \<open>compare with @{thm parallelogram_law}\<close>

	lemma "(norm (fstzero + zerosnd))\<^sup>2 + (norm (fstzero - zerosnd))\<^sup>2 \<noteq>
	2 * (norm fstzero)\<^sup>2 + 2 * (norm zerosnd)\<^sup>2"
	by (simp add: fstzero_add_zerosnd norm_fstzero_zerosnd)

	end

	subsection \<open>Topology\<close>

	subsection \<open>Vector Spaces\<close>

	lemma ex_norm_eq_1: "\<exists>x. norm (x::'a::{real_normed_vector, perfect_space}) = 1"
	by (metis vector_choose_size zero_le_one)

	subsection \<open>Reals\<close>

	subsection \<open>Balls\<close>

	text \<open>sometimes @{thm mem_ball} etc. are not good \<open>[simp]\<close> rules (although they are often useful):
	not sure that inequalities are ``simpler'' than set membership (distorts automatic reasoning
	when only sets are involved)\<close>
	lemmas [simp del] = mem_ball mem_cball mem_sphere mem_ball_0 mem_cball_0


	subsection \<open>Boundedness\<close>

	lemma bounded_subset_cboxE:
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> bounded ((\<lambda>x. x \<bullet> i) ` X)"
	obtains a b where "X \<subseteq> cbox a b"
	proof -
	have "\<And>i. i \<in> Basis \<Longrightarrow> \<exists>a b. ((\<lambda>x. x \<bullet> i) ` X) \<subseteq> {a..b}"
	by (metis box_real(2) box_subset_cbox subset_trans bounded_subset_box_symmetric[OF assms] )
	then obtain a b where bnds: "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. x \<bullet> i) ` X) \<subseteq> {a i .. b i}"
	by metis
	then have "X \<subseteq> {x. \<forall>i\<in>Basis. x \<bullet> i \<in> {a i .. b i}}"
	by force
	also have "\<dots> = cbox (\<Sum>i\<in>Basis. a i \<^sub>R i) (\<Sum>i\<in>Basis. b i \<^sub>R i)"
	by (auto simp: cbox_def)
	finally show ?thesis ..
	qed

	lemma
	bounded_euclideanI:
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> bounded ((\<lambda>x. x \<bullet> i) ` X)"
	shows "bounded X"
	proof -
	from bounded_subset_cboxE[OF assms] obtain a b where "X \<subseteq> cbox a b" .
	with bounded_cbox show ?thesis by (rule bounded_subset)
	qed

	subsection \<open>Intervals\<close>

	notation closed_segment ("(1{_--_})")
	notation open_segment ("(1{_<--<_})")

	lemma min_zero_mult_nonneg_le: "0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> min 0 (h * k::real) \<le> h' * k"
	by (metis dual_order.antisym le_cases min_le_iff_disj mult_eq_0_iff mult_le_0_iff
	mult_right_mono_neg)

	lemma max_zero_mult_nonneg_le: "0 \<le> h' \<Longrightarrow> h' \<le> h \<Longrightarrow> h' * k \<le> max 0 (h * k::real)"
	by (metis dual_order.antisym le_cases le_max_iff_disj mult_eq_0_iff mult_right_mono
	zero_le_mult_iff)

	lemmas closed_segment_eq_real_ivl = closed_segment_eq_real_ivl

	lemma bdd_above_is_intervalI: "bdd_above I" if "is_interval I" "a \<le> b" "a \<in> I" "b \<notin> I" for I::"real set"
	by (meson bdd_above_def is_interval_1 le_cases that)

	lemma bdd_below_is_intervalI: "bdd_below I" if "is_interval I" "a \<le> b" "a \<notin> I" "b \<in> I" for I::"real set"
	by (meson bdd_below_def is_interval_1 le_cases that)


	subsection \<open>Extended Real Intervals\<close>

	subsection \<open>Euclidean Components\<close>

	subsection \<open>Operator Norm\<close>

	subsection \<open>Limits\<close>

	lemma eventually_open_cball:
	assumes "open X"
	assumes "x \<in> X"
	shows "eventually (\<lambda>e. cball x e \<subseteq> X) (at_right 0)"
	proof -
	from open_contains_cball_eq[OF assms(1)] assms(2)
	obtain e where "e > 0" "cball x e \<subseteq> X" by auto
	thus ?thesis
	by (auto simp: eventually_at dist_real_def mem_cball intro!: exI[where x=e])
	qed

	subsection \<open>Continuity\<close>

	subsection \<open>Derivatives\<close>

	lemma
	if_eventually_has_derivative:
	assumes "(f has_derivative F') (at x within S)"
	assumes "\<forall>\<^sub>F x in at x within S. P x" "P x" "x \<in> S"
	shows "((\<lambda>x. if P x then f x else g x) has_derivative F') (at x within S)"
	using assms(1)
	apply (rule has_derivative_transform_eventually)
	subgoal using assms(2) by eventually_elim auto
	by (auto simp: assms)


	lemma norm_le_in_cubeI: "norm x \<le> norm y"
	if "\<And>i. i \<in> Basis \<Longrightarrow> abs (x \<bullet> i) \<le> abs (y \<bullet> i)" for x y
	unfolding norm_eq_sqrt_inner
	apply (subst euclidean_inner)
	apply (subst (3) euclidean_inner)
	using that
	by (auto intro!: sum_mono simp: abs_le_square_iff power2_eq_square[symmetric])

	lemma has_derivative_partials_euclidean_convexI:
	fixes f::"'a::euclidean_space \<Rightarrow> 'b::real_normed_vector"
	assumes f': "\<And>i x xi. i \<in> Basis \<Longrightarrow> (\<forall>j\<in>Basis. x \<bullet> j \<in> X j) \<Longrightarrow> xi = x \<bullet> i \<Longrightarrow>
	((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i)) has_vector_derivative f' i x) (at xi within X i)"
	assumes df_cont: "\<And>i. i \<in> Basis \<Longrightarrow> (f' i \<longlongrightarrow> (f' i x)) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> x \<bullet> i \<in> X i"
	assumes "\<And>i. i \<in> Basis \<Longrightarrow> convex (X i)"
	shows "(f has_derivative (\<lambda>h. \<Sum>j\<in>Basis. (h \<bullet> j) *\<^sub>R f' j x)) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
	(is "_ (at x within ?S)")
	proof (rule has_derivativeI)
	show "bounded_linear (\<lambda>h. \<Sum>j\<in>Basis. (h \<bullet> j) *\<^sub>R f' j x)"
	by (auto intro!: bounded_linear_intros)

	obtain E where [simp]: "set E = (Basis::'a set)" "distinct E"
	using finite_distinct_list[OF finite_Basis] by blast

	have [simp]: "length E = DIM('a)"
	using \<open>distinct E\<close> distinct_card by fastforce
	have [simp]: "E ! j \<in> Basis" if "j < DIM('a)" for j
	by (metis \<open>length E = DIM('a)\<close> \<open>set E = Basis\<close> nth_mem that)
	have "convex ?S"
	by (rule convex_prod) (use assms in auto)

	have sum_Basis_E: "sum g Basis = (\<Sum>j<DIM('a). g (E ! j))" for g
	apply (rule sum.reindex_cong[OF _ _ refl])
	apply (auto simp: inj_on_nth)
	by (metis \<open>distinct E\<close> \<open>length E = DIM('a)\<close> \<open>set E = Basis\<close> bij_betw_def bij_betw_nth)

	have segment: "\<forall>\<^sub>F x' in at x within ?S. x' \<in> ?S" "\<forall>\<^sub>F x' in at x within ?S. x' \<noteq> x"
	unfolding eventually_at_filter by auto


	show "((\<lambda>y. (f y - f x - (\<Sum>j\<in>Basis. ((y - x) \<bullet> j) *\<^sub>R f' j x)) /\<^sub>R norm (y - x)) \<longlongrightarrow> 0) (at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j})"
	apply (rule tendstoI)
	unfolding norm_conv_dist[symmetric]
	proof -
	fix e::real
	assume "e > 0"
	define B where "B = e / norm (2*DIM('a) + 1)"
	with \<open>e > 0\<close> have B_thms: "B > 0" "2 * DIM('a) * B < e" "B \<ge> 0"
	by (auto simp: divide_simps algebra_simps B_def)
	define B' where "B' = B / 2"
	have "B' > 0" by (simp add: B'_def \<open>0 < B\<close>)
	have "\<forall>i \<in> Basis. \<forall>\<^sub>F xa in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. dist (f' i xa) (f' i x) < B'"
	apply (rule ballI)
	subgoal premises prems using df_cont[OF prems, THEN tendstoD, OF \<open>0 < B'\<close>] .
	done
	from eventually_ball_finite[OF finite_Basis this]
	have "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. \<forall>j\<in>Basis. dist (f' j x') (f' j x) < B'" .
	then obtain d where "d > 0"
	and "\<And>x' j. x' \<in> {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j} \<Longrightarrow> x' \<noteq> x \<Longrightarrow> dist x' x < d \<Longrightarrow> j \<in> Basis \<Longrightarrow> dist (f' j x') (f' j x) < B'"
	using \<open>0 < B'\<close>
	by (auto simp: eventually_at)
	then have B': "x' \<in> {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j} \<Longrightarrow> dist x' x < d \<Longrightarrow> j \<in> Basis \<Longrightarrow> dist (f' j x') (f' j x) < B'" for x' j
	by (cases "x' = x", auto simp add: \<open>0 < B'\<close>)
	then have B: "norm (f' j x' - f' j y) < B" if
	"(\<And>j. j \<in> Basis \<Longrightarrow> x' \<bullet> j \<in> X j)"
	"(\<And>j. j \<in> Basis \<Longrightarrow> y \<bullet> j \<in> X j)"
	"dist x' x < d"
	"dist y x < d"
	"j \<in> Basis"
	for x' y j
	proof -
	have "dist (f' j x') (f' j x) < B'" "dist (f' j y) (f' j x) < B'"
	using that
	by (auto intro!: B')
	then have "dist (f' j x') (f' j y) < B' + B'" by norm
	also have "\<dots> = B" by (simp add: B'_def)
	finally show ?thesis by (simp add: dist_norm)
	qed
	have "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}. dist x' x < d"
	by (rule tendstoD[OF tendsto_ident_at \<open>d > 0\<close>])
	with segment
	show "\<forall>\<^sub>F x' in at x within {x. \<forall>j\<in>Basis. x \<bullet> j \<in> X j}.
	norm ((f x' - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) /\<^sub>R norm (x' - x)) < e"
	proof eventually_elim
	case (elim x')
	then have os_subset: "open_segment x x' \<subseteq> ?S"
	using \<open>convex ?S\<close> assms(3)
	unfolding convex_contains_open_segment
	by auto
	then have cs_subset: "closed_segment x x' \<subseteq> ?S"
	using elim assms(3) by (auto simp add: open_segment_def)
	have csc_subset: "closed_segment (x' \<bullet> i) (x \<bullet> i) \<subseteq> X i" if i: "i \<in> Basis" for i
	apply (rule closed_segment_subset)
	using cs_subset elim assms(3,4) that
	by (auto )
	have osc_subset: "open_segment (x' \<bullet> i) (x \<bullet> i) \<subseteq> X i" if i: "i \<in> Basis" for i
	using segment_open_subset_closed csc_subset[OF i]
	by (rule order_trans)

	define h where "h = x' - x"
	define z where "z j = (\<Sum>k<j. (h \<bullet> E ! k) *\<^sub>R (E ! k))" for j
	define g where "g j t = (f (x + z j + (t - x \<bullet> E ! j) *\<^sub>R E ! j))" for j t
	have z: "z j \<bullet> E ! j = 0" if "j < DIM('a)" for j
	using that
	by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
	nth_eq_iff_index_eq
	sum.delta
	intro!: euclidean_eqI[where 'a='a]
	cong: if_cong)
	from distinct_Ex1[OF \<open>distinct E\<close>, unfolded \<open>set E = Basis\<close> Ex1_def \<open>length E = _\<close>]
	obtain index where
	index: "\<And>i. i \<in> Basis \<Longrightarrow> i = E ! index i" "\<And>i. i \<in> Basis \<Longrightarrow> index i < DIM('a)"
	and unique: "\<And>i j. i \<in> Basis \<Longrightarrow> j < DIM('a) \<Longrightarrow> E ! j = i \<Longrightarrow> j = index i"
	by metis
	have nth_eq_iff_index: "E ! k = i \<longleftrightarrow> index i = k" if "i \<in> Basis" "k < DIM('a)" for k i
	using unique[OF that] index[OF \<open>i \<in> Basis\<close>]
	by auto
	have z_inner: "z j \<bullet> i = (if j \<le> index i then 0 else h \<bullet> i)" if "j < DIM('a)" "i \<in> Basis" for j i
	using that index[of i]
	by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
	sum.delta nth_eq_iff_index
	intro!: euclidean_eqI[where 'a='a]
	cong: if_cong)
	have z_mem: "j < DIM('a) \<Longrightarrow> ja \<in> Basis \<Longrightarrow> x \<bullet> ja + z j \<bullet> ja \<in> X ja" for j ja
	using csc_subset
	by (auto simp: z_inner h_def algebra_simps)
	have "norm (x' - x) < d"
	using elim by (simp add: dist_norm)
	have norm_z': "y \<in> closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j) \<Longrightarrow> norm (z j + y \<^sub>R E ! j - (x \<bullet> E ! j) \<^sub>R E ! j) < d"
	if "j < DIM('a)"
	for j y
	apply (rule le_less_trans[OF _ \<open>norm (x' - x) < d\<close>])
	apply (rule norm_le_in_cubeI)
	apply (auto simp: inner_diff_left inner_add_left inner_Basis that z)
	subgoal by (auto simp: closed_segment_eq_real_ivl split: if_splits)
	subgoal for i
	using that
	by (auto simp: z_inner h_def algebra_simps)
	done
	have norm_z: "norm (z j) < d" if "j < DIM('a)" for j
	using norm_z'[OF that ends_in_segment(1)]
	by (auto simp: z_def)
	{
	fix j
	assume j: "j < DIM('a)"
	have eq: "(x + z j + ((y - (x + z j)) \<bullet> E ! j) *\<^sub>R E ! j +
	(p - (x + z j + ((y - (x + z j)) \<bullet> E ! j) \<^sub>R E ! j) \<bullet> E ! j) \<^sub>R
	E ! j) = (x + z j + (p - (x \<bullet> E ! j)) *\<^sub>R E ! j)" for y p
	by (auto simp: algebra_simps j z)
	have f_has_derivative: "((\<lambda>p. f (x + z j + (p - x \<bullet> E ! j) \<^sub>R E ! j)) has_derivative (\<lambda>xa. xa \<^sub>R f' (E ! j) (x + z j + ((y \<^sub>R E ! j - (x + z j)) \<bullet> E ! j) \<^sub>R E ! j)))
	(at y within closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j))"
	if "y \<in> closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j)"
	for y
	apply (rule has_derivative_subset)
	apply (rule f'[unfolded has_vector_derivative_def,
	where x= "x + z j + ((y \<^sub>R E!j - (x + z j))\<bullet> E!j) \<^sub>R E ! j" and i="E ! j", unfolded eq])
	subgoal by (simp add: j)
	subgoal
	using that
	apply (auto simp: algebra_simps z j inner_Basis)
	using closed_segment_commute \<open>E ! j \<in> Basis\<close> csc_subset apply blast
	by (simp add: z_mem j)
	subgoal by (auto simp: algebra_simps z j inner_Basis)
	subgoal
	apply (auto simp: algebra_simps z j inner_Basis)
	using closed_segment_commute \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> csc_subset j apply blast
	done
	done
	have : "((xa \<^sub>R E ! j - (x + z j)) \<bullet> E ! j) = xa - x \<bullet> E ! j" for xa
	by (auto simp: algebra_simps z j)
	have g': "(g j has_vector_derivative (f' (E ! j) (x + z j + (xa - x \<bullet> E ! j) *\<^sub>R E ! j)))
	(at xa within (closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)))"
	(is "(_ has_vector_derivative ?g' j xa) _")
	if "xa \<in> closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)" for xa
	using that
	by (auto simp: has_vector_derivative_def g_def[abs_def] *
	intro!: derivative_eq_intros f_has_derivative[THEN has_derivative_eq_rhs])
	define g' where "g' j = ?g' j" for j
	with g' have g': "(g j has_vector_derivative g' j t) (at t within closed_segment (x\<bullet>E!j) (x'\<bullet>E!j))"
	if "t \<in> closed_segment (x\<bullet>E!j) (x'\<bullet>E!j)"
	for t
	by (simp add: that)
	have cont_bound: "\<And>y. y\<in>closed_segment (x \<bullet> E ! j) (x' \<bullet> E ! j) \<Longrightarrow> norm (g' j y - g' j (x \<bullet> E ! j)) \<le> B"
	apply (auto simp add: g'_def j algebra_simps inner_Basis z dist_norm
	intro!: less_imp_le B z_mem norm_z norm_z')
	using closed_segment_commute \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> csc_subset j apply blast
	done
	from vector_differentiable_bound_linearization[OF g' order_refl cont_bound ends_in_segment(1)]
	have n: "norm (g j (x' \<bullet> E ! j) - g j (x \<bullet> E ! j) - (x' \<bullet> E ! j - x \<bullet> E ! j) \<^sub>R g' j (x \<bullet> E ! j)) \<le> norm (x' \<bullet> E ! j - x \<bullet> E ! j) B"
	.
	have "z (Suc j) = z j + (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R E ! j"
	by (auto simp: z_def h_def algebra_simps)
	then have "f (x + z (Suc j)) = f (x + z j + (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R E ! j) "
	by (simp add: ac_simps)
	with n have "norm (f (x + z (Suc j)) - f (x + z j) - (x' \<bullet> E ! j - x \<bullet> E ! j) \<^sub>R f' (E ! j) (x + z j)) \<le> \<bar>x' \<bullet> E ! j - x \<bullet> E ! j\<bar> B"
	by (simp add: g_def g'_def)
	} note B_le = this
	have B': "norm (f' (E ! j) (x + z j) - f' (E ! j) x) \<le> B" if "j < DIM('a)" for j
	using that assms(3)
	by (auto simp add: algebra_simps inner_Basis z dist_norm \<open>0 < d\<close>
	intro!: less_imp_le B z_mem norm_z)
	have "(\<Sum>j\<le>DIM('a) - 1. f (x + z j) - f (x + z (Suc j))) = f (x + z 0) - f (x + z (Suc (DIM('a) - 1)))"
	by (rule sum_telescope)
	moreover have "z DIM('a) = h"
	using index
	by (auto simp: z_def h_def algebra_simps inner_sum_left inner_Basis if_distrib
	nth_eq_iff_index
	sum.delta
	intro!: euclidean_eqI[where 'a='a]
	cong: if_cong)
	moreover have "z 0 = 0"
	by (auto simp: z_def)
	moreover have "{..DIM('a) - 1} = {..<DIM('a)}"
	using le_imp_less_Suc by fastforce
	ultimately have "f x - f (x + h) = (\<Sum>j<DIM('a). f (x + z j) - f (x + z (Suc j)))"
	- by (auto simp: )
	+ by auto
	then have "norm (f (x + h) - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) =
	norm(
	(\<Sum>j<DIM('a). f (x + z (Suc j)) - f (x + z j) - (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R f' (E ! j) (x + z j)) +
	(\<Sum>j<DIM('a). (x' \<bullet> E ! j - x \<bullet> E ! j) *\<^sub>R (f' (E ! j) (x + z j) - f' (E ! j) x)))"
	(is "_ = norm (sum ?a ?E + sum ?b ?E)")
	by (intro arg_cong[where f=norm]) (simp add: sum_negf sum_subtractf sum.distrib algebra_simps sum_Basis_E)
	also have "\<dots> \<le> norm (sum ?a ?E) + norm (sum ?b ?E)" by (norm)
	also have "norm (sum ?a ?E) \<le> sum (\<lambda>x. norm (?a x)) ?E"
	by (rule norm_sum)
	also have "\<dots> \<le> sum (\<lambda>j. norm \<bar>x' \<bullet> E ! j - x \<bullet> E ! j\<bar> * B) ?E"
	by (auto intro!: sum_mono B_le)
	also have "\<dots> \<le> sum (\<lambda>j. norm (x' - x) * B) ?E"
	apply (rule sum_mono)
	apply (auto intro!: mult_right_mono \<open>0 \<le> B\<close>)
	by (metis (full_types) \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> inner_diff_left norm_bound_Basis_le order_refl)
	also have "\<dots> = norm (x' - x) * DIM('a) * B"
	by simp
	also have "norm (sum ?b ?E) \<le> sum (\<lambda>x. norm (?b x)) ?E"
	by (rule norm_sum)
	also have "\<dots> \<le> sum (\<lambda>j. norm (x' - x) * B) ?E"
	apply (intro sum_mono)
	apply (auto intro!: mult_mono B')
	apply (metis (full_types) \<open>\<And>j. j < DIM('a) \<Longrightarrow> E ! j \<in> Basis\<close> inner_diff_left norm_bound_Basis_le order_refl)
	done
	also have "\<dots> = norm (x' - x) * DIM('a) * B"
	by simp
	finally have "norm (f (x + h) - f x - (\<Sum>j\<in>Basis. ((x' - x) \<bullet> j) *\<^sub>R f' j x)) \<le>
	norm (x' - x) * real DIM('a) * B + norm (x' - x) * real DIM('a) * B"
	by arith
	also have "\<dots> /\<^sub>R norm (x' - x) \<le> norm (2 * DIM('a) * B)"
	using \<open>B \<ge> 0\<close>
	by (simp add: divide_simps abs_mult)
	also have "\<dots> < e" using B_thms by simp
	finally show ?case by (auto simp: divide_simps abs_mult h_def)
	qed
	qed
	qed

	lemma
	frechet_derivative_equals_partial_derivative:
	fixes f::"'a::euclidean_space \<Rightarrow> 'a"
	assumes Df: "\<And>x. (f has_derivative Df x) (at x)"
	assumes f': "((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i) \<bullet> b) has_real_derivative f' x i b) (at (x \<bullet> i))"
	shows "Df x i \<bullet> b = f' x i b"
	proof -
	define Dfb where "Dfb x = Blinfun (Df x)" for x
	have Dfb_apply: "blinfun_apply (Dfb x) = Df x" for x
	unfolding Dfb_def
	apply (rule bounded_linear_Blinfun_apply)
	apply (rule has_derivative_bounded_linear)
	apply (rule assms)
	done
	have "Dfb x = blinfun_of_matrix (\<lambda>i b. Dfb x b \<bullet> i)" for x
	using blinfun_of_matrix_works[of "Dfb x"] by auto
	have Dfb: "\<And>x. (f has_derivative Dfb x) (at x)"
	by (auto simp: Dfb_apply Df)
	note [derivative_intros] = diff_chain_at[OF _ Dfb, unfolded o_def]
	have "((\<lambda>p. f (x + (p - x \<bullet> i) *\<^sub>R i) \<bullet> b) has_real_derivative Dfb x i \<bullet> b) (at (x \<bullet> i))"
	by (auto intro!: derivative_eq_intros ext simp: has_field_derivative_def blinfun.bilinear_simps)
	from DERIV_unique[OF f' this]
	show ?thesis by (simp add: Dfb_apply)
	qed


	subsection \<open>Integration\<close>

	lemmas content_real[simp]
	lemmas integrable_continuous[intro, simp]
	and integrable_continuous_real[intro, simp]


	lemma integral_eucl_le:
	fixes f g::"'a::euclidean_space \<Rightarrow> 'b::ordered_euclidean_space"
	assumes "f integrable_on s"
	and "g integrable_on s"
	and "\<And>x. x \<in> s \<Longrightarrow> f x \<le> g x"
	shows "integral s f \<le> integral s g"
	using assms
	by (auto intro!: integral_component_le simp: eucl_le[where 'a='b])

	lemma
	integral_ivl_bound:
	fixes l u::"'a::ordered_euclidean_space"
	assumes "\<And>x h'. h' \<in> {t0 .. h} \<Longrightarrow> x \<in> {t0 .. h} \<Longrightarrow> (h' - t0) *\<^sub>R f x \<in> {l .. u}"
	assumes "t0 \<le> h"
	assumes f_int: "f integrable_on {t0 .. h}"
	shows "integral {t0 .. h} f \<in> {l .. u}"
	proof -
	from assms(1)[of t0 t0] assms(2) have "0 \<in> {l .. u}" by auto
	have "integral {t0 .. h} f = integral {t0 .. h} (\<lambda>t. if t \<in> {t0, h} then 0 else f t)"
	by (rule integral_spike[where S="{t0, h}"]) auto
	also
	{
	fix x
	assume 1: "x \<in> {t0 <..< h}"
	with assms have "(h - t0) *\<^sub>R f x \<in> {l .. u}" by auto
	then have "(if x \<in> {t0, h} then 0 else f x) \<in> {l /\<^sub>R (h - t0) .. u /\<^sub>R (h - t0)}"
	using \<open>x \<in> _\<close>
	by (auto simp: inverse_eq_divide
	simp: eucl_le[where 'a='a] field_simps algebra_simps)
	}
	then have "\<dots> \<in> {integral {t0..h} (\<lambda>_. l /\<^sub>R (h - t0)) .. integral {t0..h} (\<lambda>_. u /\<^sub>R (h - t0))}"
	unfolding atLeastAtMost_iff
	apply (safe intro!: integral_eucl_le)
	using \<open>0 \<in> {l .. u}\<close>
	apply (auto intro!: assms
	intro: integrable_continuous_real integrable_spike[where S="{t0, h}", OF f_int]
	simp: eucl_le[where 'a='a] divide_simps
	split: if_split_asm)
	done
	also have "\<dots> \<subseteq> {l .. u}"
	using assms \<open>0 \<in> {l .. u}\<close>
	by (auto simp: inverse_eq_divide)
	finally show ?thesis .
	qed

	lemma
	add_integral_ivl_bound:
	fixes l u::"'a::ordered_euclidean_space"
	assumes "\<And>x h'. h' \<in> {t0 .. h} \<Longrightarrow> x \<in> {t0 .. h} \<Longrightarrow> (h' - t0) *\<^sub>R f x \<in> {l - x0 .. u - x0}"
	assumes "t0 \<le> h"
	assumes f_int: "f integrable_on {t0 .. h}"
	shows "x0 + integral {t0 .. h} f \<in> {l .. u}"
	using integral_ivl_bound[OF assms]
	by (auto simp: algebra_simps)

	subsection \<open>conditionally complete lattice\<close>


	subsection \<open>Lists\<close>

	lemma
	Ball_set_Cons[simp]: "(\<forall>a\<in>set_Cons x y. P a) \<longleftrightarrow> (\<forall>a\<in>x. \<forall>b\<in>y. P (a#b))"
	by (auto simp: set_Cons_def)

	lemma set_cons_eq_empty[iff]: "set_Cons a b = {} \<longleftrightarrow> a = {} \<or> b = {}"
	by (auto simp: set_Cons_def)

	lemma listset_eq_empty_iff[iff]: "listset XS = {} \<longleftrightarrow> {} \<in> set XS"
	by (induction XS) auto

	lemma sing_in_sings[simp]: "[x] \<in> (\<lambda>x. [x]) ` xd \<longleftrightarrow> x \<in> xd"
	by auto

	lemma those_eq_None_set_iff: "those xs = None \<longleftrightarrow> None \<in> set xs"
	by (induction xs) (auto split: option.split)

	lemma those_eq_Some_lengthD: "those xs = Some ys \<Longrightarrow> length xs = length ys"
	by (induction xs arbitrary: ys) (auto split: option.splits)

	lemma those_eq_Some_map_Some_iff: "those xs = Some ys \<longleftrightarrow> (xs = map Some ys)" (is "?l \<longleftrightarrow> ?r")
	proof safe
	assume ?l
	then have "length xs = length ys"
	by (rule those_eq_Some_lengthD)
	then show ?r using \<open>?l\<close>
	by (induction xs ys rule: list_induct2) (auto split: option.splits)
	next
	assume ?r
	then have "length xs = length ys"
	by simp
	then show "those (map Some ys) = Some ys" using \<open>?r\<close>
	by (induction xs ys rule: list_induct2) (auto split: option.splits)
	qed


	subsection \<open>Set(sum)\<close>

	subsection \<open>Max\<close>

	subsection \<open>Uniform Limit\<close>

	subsection \<open>Bounded Linear Functions\<close>

	lift_definition comp3::\<comment> \<open>TODO: name?\<close>
	"('c::real_normed_vector \<Rightarrow>\<^sub>L 'd::real_normed_vector) \<Rightarrow> ('b::real_normed_vector \<Rightarrow>\<^sub>L 'c) \<Rightarrow>\<^sub>L 'b \<Rightarrow>\<^sub>L 'd" is
	"\<lambda>(cd::('c \<Rightarrow>\<^sub>L 'd)) (bc::'b \<Rightarrow>\<^sub>L 'c). (cd o\<^sub>L bc)"
	by (rule bounded_bilinear.bounded_linear_right[OF bounded_bilinear_blinfun_compose])

	lemma blinfun_apply_comp3[simp]: "blinfun_apply (comp3 a) b = (a o\<^sub>L b)"
	by (simp add: comp3.rep_eq)

	lemma bounded_linear_comp3[bounded_linear]: "bounded_linear comp3"
	by transfer (rule bounded_bilinear_blinfun_compose)

	lift_definition comp12::\<comment> \<open>TODO: name?\<close>
	"('a::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> ('b::real_normed_vector \<Rightarrow>\<^sub>L 'c) \<Rightarrow> ('a \<times> 'b) \<Rightarrow>\<^sub>L 'c"
	is "\<lambda>f g (a, b). f a + g b"
	by (auto intro!: bounded_linear_intros
	intro: bounded_linear_compose
	simp: split_beta')

	lemma blinfun_apply_comp12[simp]: "blinfun_apply (comp12 f g) b = f (fst b) + g (snd b)"
	by (simp add: comp12.rep_eq split_beta)


	subsection \<open>Order Transitivity Attributes\<close>

	attribute_setup le = \<open>Scan.succeed (Thm.rule_attribute [] (fn context => fn thm => thm RS @{thm order_trans}))\<close>
	"transitive version of inequality (useful for intro)"
	attribute_setup ge = \<open>Scan.succeed (Thm.rule_attribute [] (fn context => fn thm => thm RS @{thm order_trans[rotated]}))\<close>
	"transitive version of inequality (useful for intro)"


	subsection \<open>point reflection\<close>

	definition preflect::"'a::real_vector \<Rightarrow> 'a \<Rightarrow> 'a" where "preflect \<equiv> \<lambda>t0 t. 2 *\<^sub>R t0 - t"

	lemma preflect_preflect[simp]: "preflect t0 (preflect t0 t) = t"
	by (simp add: preflect_def algebra_simps)

	lemma preflect_preflect_image[simp]: "preflect t0 ` preflect t0 ` S = S"
	by (simp add: image_image)

	lemma is_interval_preflect[simp]: "is_interval (preflect t0 ` S) \<longleftrightarrow> is_interval S"
	by (auto simp: preflect_def[abs_def])

	lemma iv_in_preflect_image[intro, simp]: "t0 \<in> T \<Longrightarrow> t0 \<in> preflect t0 ` T"
	by (auto intro!: image_eqI simp: preflect_def algebra_simps scaleR_2)

	lemma preflect_tendsto[tendsto_intros]:
	fixes l::"'a::real_normed_vector"
	shows "(g \<longlongrightarrow> l) F \<Longrightarrow> (h \<longlongrightarrow> m) F \<Longrightarrow> ((\<lambda>x. preflect (g x) (h x)) \<longlongrightarrow> preflect l m) F"
	by (auto intro!: tendsto_eq_intros simp: preflect_def)

	lemma continuous_preflect[continuous_intros]:
	fixes a::"'a::real_normed_vector"
	shows "continuous (at a within A) (preflect t0)"
	by (auto simp: continuous_within intro!: tendsto_intros)

	lemma
	fixes t0::"'a::ordered_real_vector"
	shows preflect_le[simp]: "t0 \<le> preflect t0 b \<longleftrightarrow> b \<le> t0"
	and le_preflect[simp]: "preflect t0 b \<le> t0 \<longleftrightarrow> t0 \<le> b"
	and antimono_preflect: "antimono (preflect t0)"
	and preflect_le_preflect[simp]: "preflect t0 a \<le> preflect t0 b \<longleftrightarrow> b \<le> a"
	and preflect_eq_cancel[simp]: "preflect t0 a = preflect t0 b \<longleftrightarrow> a = b"
	by (auto intro!: antimonoI simp: preflect_def scaleR_2)

	lemma preflect_eq_point_iff[simp]: "t0 = preflect t0 s \<longleftrightarrow> t0 = s" "preflect t0 s = t0 \<longleftrightarrow> t0 = s"
	by (auto simp: preflect_def algebra_simps scaleR_2)

	lemma preflect_minus_self[simp]: "preflect t0 s - t0 = t0 - s"
	by (simp add: preflect_def scaleR_2)

	end
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Autoref_Misc.thy b/thys/Ordinary_Differential_Equations/Refinement/Autoref_Misc.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Autoref_Misc.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Autoref_Misc.thy
	@@ -1,730 +1,730 @@
	(* TODO: Integrate into Misc*)
	theory Autoref_Misc
	imports
	Refine_Dflt_No_Comp
	"HOL-Analysis.Analysis"
	begin

	(*****************************)
	(* Refine-Basic *)
	(* TODO: Move to Refine_Basic *)
	lemma nofail_RES_conv: "nofail m \<longleftrightarrow> (\<exists>M. m=RES M)" by (cases m) auto

	(* TODO: Move, near SPEC_nofail *)
	lemma nofail_SPEC: "nofail m \<Longrightarrow> m \<le> SPEC (\<lambda>_. True)"
	by (simp add: pw_le_iff)

	lemma nofail_SPEC_iff: "nofail m \<longleftrightarrow> m \<le> SPEC (\<lambda>_. True)"
	by (simp add: pw_le_iff)

	lemma nofail_SPEC_triv_refine: "\<lbrakk> nofail m; \<And>x. \<Phi> x \<rbrakk> \<Longrightarrow> m \<le> SPEC \<Phi>"
	by (simp add: pw_le_iff)

	(* TODO: Move *)
	lemma bind_cong:
	assumes "m=m'"
	assumes "\<And>x. RETURN x \<le> m' \<Longrightarrow> f x = f' x"
	shows "bind m f = bind m' f'"
	using assms
	by (auto simp: refine_pw_simps pw_eq_iff pw_le_iff)


	primrec the_RES where "the_RES (RES X) = X"
	lemma the_RES_inv[simp]: "nofail m \<Longrightarrow> RES (the_RES m) = m"
	by (cases m) auto

	lemma le_SPEC_UNIV_rule [refine_vcg]:
	"m \<le> SPEC (\<lambda>_. True) \<Longrightarrow> m \<le> RES UNIV" by auto

	lemma nf_inres_RES[simp]: "nf_inres (RES X) x \<longleftrightarrow> x\<in>X"
	by (simp add: refine_pw_simps)

	lemma nf_inres_SPEC[simp]: "nf_inres (SPEC \<Phi>) x \<longleftrightarrow> \<Phi> x"
	by (simp add: refine_pw_simps)

	(* TODO: Move *)
	lemma Let_refine':
	assumes "(m,m')\<in>R"
	assumes "(m,m')\<in>R \<Longrightarrow> f m \<le>\<Down>S (f' m')"
	shows "Let m f \<le> \<Down>S (Let m' f')"
	using assms by simp

	lemma in_nres_rel_iff: "(a,b)\<in>\<langle>R\<rangle>nres_rel \<longleftrightarrow> a \<le>\<Down>R b"
	by (auto simp: nres_rel_def)

	lemma inf_RETURN_RES:
	"inf (RETURN x) (RES X) = (if x\<in>X then RETURN x else SUCCEED)"
	"inf (RES X) (RETURN x) = (if x\<in>X then RETURN x else SUCCEED)"
	by (auto simp: pw_eq_iff refine_pw_simps)

	(* TODO: MOve, test as default simp-rule *)
	lemma inf_RETURN_SPEC[simp]:
	"inf (RETURN x) (SPEC (\<lambda>y. \<Phi> y)) = SPEC (\<lambda>y. y=x \<and> \<Phi> x)"
	"inf (SPEC (\<lambda>y. \<Phi> y)) (RETURN x) = SPEC (\<lambda>y. y=x \<and> \<Phi> x)"
	by (auto simp: pw_eq_iff refine_pw_simps)

	lemma RES_sng_eq_RETURN: "RES {x} = RETURN x"
	by simp

	lemma nofail_inf_serialize:
	"\<lbrakk>nofail a; nofail b\<rbrakk> \<Longrightarrow> inf a b = do {x\<leftarrow>a; ASSUME (inres b x); RETURN x}"
	by (auto simp: pw_eq_iff refine_pw_simps)

	definition lift_assn :: "('a \<times> 'b) set \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)"
	\<comment> \<open>Lift assertion over refinement relation\<close>
	where "lift_assn R \<Phi> s \<equiv> \<exists>s'. (s,s')\<in>R \<and> \<Phi> s'"
	lemma lift_assnI: "\<lbrakk>(s,s')\<in>R; \<Phi> s'\<rbrakk> \<Longrightarrow> lift_assn R \<Phi> s"
	unfolding lift_assn_def by auto

	(* TODO: Replace original lemma *)
	lemma case_option_refine[refine]:
	assumes "(x,x')\<in>Id"
	assumes "x=None \<Longrightarrow> fn \<le> \<Down>R fn'"
	assumes "\<And>v v'. \<lbrakk>x=Some v; (v,v')\<in>Id\<rbrakk> \<Longrightarrow> fs v \<le> \<Down>R (fs' v')"
	shows "case_option fn (\<lambda>v. fs v) x \<le> \<Down>R (case_option fn' (\<lambda>v'. fs' v') x')"
	using assms by (auto split: option.split)


	definition GHOST :: "'a \<Rightarrow> 'a"
	\<comment> \<open>Ghost tag to mark ghost variables in let-expressions\<close>
	where [simp]: "GHOST \<equiv> \<lambda>x. x"
	lemma GHOST_elim_Let: \<comment> \<open>Unfold rule to inline GHOST-Lets\<close>
	shows "(let x=GHOST m in f x) = f m" by simp



	text \<open>The following set of rules executes a step on the LHS or RHS of
	a refinement proof obligation, without changing the other side.
	These kind of rules is useful for performing refinements with
	invisible steps.\<close>
	lemma lhs_step_If:
	"\<lbrakk> b \<Longrightarrow> t \<le> m; \<not>b \<Longrightarrow> e \<le> m \<rbrakk> \<Longrightarrow> If b t e \<le> m" by simp

	lemma lhs_step_RES:
	"\<lbrakk> \<And>x. x\<in>X \<Longrightarrow> RETURN x \<le> m \<rbrakk> \<Longrightarrow> RES X \<le> m"
	by (simp add: pw_le_iff)

	lemma lhs_step_SPEC:
	"\<lbrakk> \<And>x. \<Phi> x \<Longrightarrow> RETURN x \<le> m \<rbrakk> \<Longrightarrow> SPEC (\<lambda>x. \<Phi> x) \<le> m"
	by (simp add: pw_le_iff)

	lemma lhs_step_bind:
	fixes m :: "'a nres" and f :: "'a \<Rightarrow> 'b nres"
	assumes "nofail m' \<Longrightarrow> nofail m"
	assumes "\<And>x. nf_inres m x \<Longrightarrow> f x \<le> m'"
	shows "do {x\<leftarrow>m; f x} \<le> m'"
	using assms
	by (simp add: pw_le_iff refine_pw_simps) blast

	lemma rhs_step_bind_RES:
	assumes "x'\<in>X'"
	assumes "m \<le> \<Down>R (f' x')"
	shows "m \<le> \<Down>R (RES X' \<bind> f')"
	using assms by (simp add: pw_le_iff refine_pw_simps) blast

	lemma rhs_step_bind_SPEC:
	assumes "\<Phi> x'"
	assumes "m \<le> \<Down>R (f' x')"
	shows "m \<le> \<Down>R (SPEC \<Phi> \<bind> f')"
	using assms by (simp add: pw_le_iff refine_pw_simps) blast

	lemma RES_bind_choose:
	assumes "x\<in>X"
	assumes "m \<le> f x"
	shows "m \<le> RES X \<bind> f"
	using assms by (auto simp: pw_le_iff refine_pw_simps)

	lemma pw_RES_bind_choose:
	"nofail (RES X \<bind> f) \<longleftrightarrow> (\<forall>x\<in>X. nofail (f x))"
	"inres (RES X \<bind> f) y \<longleftrightarrow> (\<exists>x\<in>X. inres (f x) y)"
	by (auto simp: refine_pw_simps)


	(* TODO: Move to Refine_Basic: Convenience*)
	lemma use_spec_rule:
	assumes "m \<le> SPEC \<Psi>"
	assumes "m \<le> SPEC (\<lambda>s. \<Psi> s \<longrightarrow> \<Phi> s)"
	shows "m \<le> SPEC \<Phi>"
	using assms
	by (auto simp: pw_le_iff refine_pw_simps)

	lemma strengthen_SPEC: "m \<le> SPEC \<Phi> \<Longrightarrow> m \<le> SPEC(\<lambda>s. inres m s \<and> \<Phi> s)"
	\<comment> \<open>Strengthen SPEC by adding trivial upper bound for result\<close>
	by (auto simp: pw_le_iff refine_pw_simps)

	lemma weaken_SPEC:
	"m \<le> SPEC \<Phi> \<Longrightarrow> (\<And>x. \<Phi> x \<Longrightarrow> \<Psi> x) \<Longrightarrow> m \<le> SPEC \<Psi>"
	by (force elim!: order_trans)


	lemma ife_FAIL_to_ASSERT_cnv:
	"(if \<Phi> then m else FAIL) = op_nres_ASSERT_bnd \<Phi> m"
	by (cases \<Phi>, auto)



	lemma param_op_nres_ASSERT_bnd[param]:
	assumes "\<Phi>' \<Longrightarrow> \<Phi>"
	assumes "\<lbrakk>\<Phi>'; \<Phi>\<rbrakk> \<Longrightarrow> (m,m')\<in>\<langle>R\<rangle>nres_rel"
	shows "(op_nres_ASSERT_bnd \<Phi> m, op_nres_ASSERT_bnd \<Phi>' m') \<in> \<langle>R\<rangle>nres_rel"
	using assms
	by (auto simp: pw_le_iff refine_pw_simps nres_rel_def)

	declare autoref_FAIL[param]


	(*****************************)
	(* Refine_Transfer *)
	lemma (in transfer) transfer_sum[refine_transfer]:
	assumes "\<And>l. \<alpha> (fl l) \<le> Fl l"
	assumes "\<And>r. \<alpha> (fr r) \<le> Fr r"
	shows "\<alpha> (case_sum fl fr x) \<le> (case_sum Fl Fr x)"
	using assms by (auto split: sum.split)


	(* TODO: Move *)
	lemma nres_of_transfer[refine_transfer]: "nres_of x \<le> nres_of x" by simp



	(*****************************)
	(* Refine_Foreach *)
	(* TODO: Change in Refine_Foreach(?)! *)
	declare FOREACH_patterns[autoref_op_pat_def]

	(*****************************)
	(* Refine_Recursion *)

	(*****************************)
	(* Refine_While *)
	context begin interpretation autoref_syn .
	(* TODO: Change in Refine_While *)
	lemma [autoref_op_pat_def]:
	"WHILEIT I \<equiv> OP (WHILEIT I)"
	"WHILEI I \<equiv> OP (WHILEI I)"
	by auto
	end

	(*****************************)
	(* Relators *)
	lemma set_relD: "(s,s')\<in>\<langle>R\<rangle>set_rel \<Longrightarrow> x\<in>s \<Longrightarrow> \<exists>x'\<in>s'. (x,x')\<in>R"
	unfolding set_rel_def by blast

	lemma set_relE[consumes 2]:
	assumes "(s,s')\<in>\<langle>R\<rangle>set_rel" "x\<in>s"
	obtains x' where "x'\<in>s'" "(x,x')\<in>R"
	using set_relD[OF assms] ..

	lemma param_prod': "\<lbrakk>
	\<And>a b a' b'. \<lbrakk>p=(a,b); p'=(a',b')\<rbrakk> \<Longrightarrow> (f a b,f' a' b')\<in>R
	\<rbrakk> \<Longrightarrow> (case_prod f p, case_prod f' p')\<in>R"
	by (auto split: prod.split)



	(*****************************)
	(* Parametricity-HOL *)

	lemma dropWhile_param[param]:
	"(dropWhile, dropWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
	unfolding dropWhile_def by parametricity

	term takeWhile
	lemma takeWhile_param[param]:
	"(takeWhile, takeWhile) \<in> (a \<rightarrow> bool_rel) \<rightarrow> \<langle>a\<rangle>list_rel \<rightarrow> \<langle>a\<rangle>list_rel"
	unfolding takeWhile_def by parametricity

	(*****************************)
	(* Autoref-HOL *)
	lemmas [autoref_rules] = dropWhile_param takeWhile_param


	(*****************************)
	(* Autoref-Tool *)

	method_setup autoref_solve_id_op = \<open>
	Scan.succeed (fn ctxt => SIMPLE_METHOD' (
	Autoref_Id_Ops.id_tac (Config.put Autoref_Id_Ops.cfg_ss_id_op false ctxt)
	))
	\<close>


	(*****************************)
	(* Autoref_Monadic *)

	(* TODO: Replace! *)
	text \<open>Default setup of the autoref-tool for the monadic framework.\<close>

	lemma autoref_monadicI1:
	assumes "(b,a)\<in>\<langle>R\<rangle>nres_rel"
	assumes "RETURN c \<le> b"
	shows "(RETURN c, a)\<in>\<langle>R\<rangle>nres_rel" "RETURN c \<le>\<Down>R a"
	using assms
	unfolding nres_rel_def
	by simp_all

	lemma autoref_monadicI2:
	assumes "(b,a)\<in>\<langle>R\<rangle>nres_rel"
	assumes "nres_of c \<le> b"
	shows "(nres_of c, a)\<in>\<langle>R\<rangle>nres_rel" "nres_of c \<le> \<Down>R a"
	using assms
	unfolding nres_rel_def
	by simp_all

	lemmas autoref_monadicI = autoref_monadicI1 autoref_monadicI2

	ML \<open>
	structure Autoref_Monadic = struct

	val cfg_plain = Attrib.setup_config_bool @{binding autoref_plain} (K false)

	fun autoref_monadic_tac ctxt = let
	open Autoref_Tacticals
	val ctxt = Autoref_Phases.init_data ctxt
	val plain = Config.get ctxt cfg_plain
	val trans_thms = if plain then [] else @{thms the_resI}

	in
	resolve_tac ctxt @{thms autoref_monadicI}
	THEN'
	IF_SOLVED (Autoref_Phases.all_phases_tac ctxt)
	(RefineG_Transfer.post_transfer_tac trans_thms ctxt)
	(K all_tac) (* Autoref failed *)

	end
	end
	\<close>

	method_setup autoref_monadic = \<open>let
	open Refine_Util Autoref_Monadic
	val autoref_flags =
	parse_bool_config "trace" Autoref_Phases.cfg_trace
	\|\| parse_bool_config "debug" Autoref_Phases.cfg_debug
	\|\| parse_bool_config "plain" Autoref_Monadic.cfg_plain

	in
	parse_paren_lists autoref_flags
	>>
	( fn _ => fn ctxt => SIMPLE_METHOD' (
	let
	val ctxt = Config.put Autoref_Phases.cfg_keep_goal true ctxt
	in autoref_monadic_tac ctxt end
	))

	end

	\<close>
	"Automatic Refinement and Determinization for the Monadic Refinement Framework"

	(* Move to Refine Transfer *)
	lemma dres_unit_simps[refine_transfer_post_simp]:
	"dbind (dRETURN (u::unit)) f = f ()"
	by auto

	lemma Let_dRETURN_simp[refine_transfer_post_simp]:
	"Let m dRETURN = dRETURN m" by auto

	(* TODO: Move *)
	lemmas [refine_transfer_post_simp] = dres_monad_laws


	subsection \<open>things added by Fabian\<close>

	bundle art = [[goals_limit=1, autoref_trace, autoref_trace_failed_id, autoref_keep_goal]]

	definition [simp, autoref_tag_defs]: "TRANSFER_tag P == P"
	lemma TRANSFER_tagI: "P ==> TRANSFER_tag P" by simp
	abbreviation "TRANSFER P \<equiv> PREFER_tag (TRANSFER_tag P)"
	declaration
	\<open>
	let
	val _ = ()
	in Tagged_Solver.declare_solver @{thms TRANSFER_tagI} @{binding TRANSFER}
	"transfer"
	(RefineG_Transfer.post_transfer_tac [])
	end\<close>

	(* TODO: check for usage in Autoref? *)
	method_setup refine_vcg =
	\<open>Attrib.thms >> (fn add_thms => fn ctxt => SIMPLE_METHOD' (
	Refine.rcg_tac (add_thms @ Refine.vcg.get ctxt) ctxt THEN_ALL_NEW_FWD
	(TRY o
	(Method.assm_tac ctxt
	ORELSE' SOLVED' (clarsimp_tac ctxt THEN_ALL_NEW Method.assm_tac ctxt)
	ORELSE' Refine.post_tac ctxt))
	))\<close>
	"Refinement framework: Generate refinement and verification conditions"

	lemmas [autoref_rules] = autoref_rec_nat \<comment> \<open>TODO: add to Autoref\<close>
	lemma \<comment> \<open>TODO: needed because @{thm dres.transfer_rec_nat} expects one argument,
	but functions with more arguments defined by primrec take several arguments\<close>
	uncurry_rec_nat: "rec_nat (\<lambda>a b. fn a b) (\<lambda>n rr a b. fs n rr a b) n a b =
	rec_nat (\<lambda>(a,b). fn a b) (\<lambda>n rr (a,b). fs n (\<lambda>a b. rr (a,b)) a b) n (a,b)"
	apply (induction n arbitrary: a b)
	apply (auto split: prod.splits)
	apply metis
	done

	attribute_setup refine_vcg_def =
	\<open>Scan.succeed (Thm.declaration_attribute (fn A =>
	Refine.vcg.add_thm ((A RS @{thm eq_refl}) RS @{thm order.trans})))\<close>

	definition comp2 (infixl "o2" 55) where "comp2 f g x y \<equiv> f (g x y)"
	definition comp3 (infixl "o3" 55) where "comp3 f g x y z \<equiv> f (g x y z)"
	definition comp4 (infixl "o4" 55) where "comp4 f g w x y z \<equiv> f (g w x y z)"
	definition comp5 (infixl "o5" 55) where "comp5 f g w x y z a \<equiv> f (g w x y z a)"
	definition comp6 (infixl "o6" 55) where "comp6 f g w x y z a b \<equiv> f (g w x y z a b)"
	lemmas comps =
	comp_def[abs_def]
	comp2_def[abs_def]
	comp3_def[abs_def]
	comp4_def[abs_def]
	comp5_def[abs_def]
	comp6_def[abs_def]

	locale autoref_op_pat_def = fixes x
	begin
	lemma [autoref_op_pat_def]: "x \<equiv> Autoref_Tagging.OP x"
	by simp
	end

	bundle autoref_syntax begin
	no_notation vec_nth (infixl "$" 90)
	no_notation funcset (infixr "\<rightarrow>" 60)
	notation Autoref_Tagging.APP (infixl "$" 900)
	notation rel_ANNOT (infix ":::" 10)
	notation ind_ANNOT (infix "::#" 10)
	notation "Autoref_Tagging.OP" ("OP")
	notation Autoref_Tagging.ABS (binder "\<lambda>''" 10)
	end

	definition "THE_NRES = case_option SUCCEED RETURN"

	context includes autoref_syntax begin
	schematic_goal THE_NRES_impl:
	assumes [THEN PREFER_sv_D, relator_props]: "PREFER single_valued R"
	assumes [autoref_rules]: "(xi, x) \<in> \<langle>R\<rangle>option_rel"
	shows "(nres_of ?x, THE_NRES $ x) \<in> \<langle>R\<rangle>nres_rel"
	unfolding THE_NRES_def
	by (autoref_monadic)
	end

	concrete_definition THE_DRES uses THE_NRES_impl
	lemmas [autoref_rules] = THE_DRES.refine

	lemma THE_NRES_refine[THEN order_trans, refine_vcg]:
	"THE_NRES x \<le> SPEC (\<lambda>r. x = Some r)"
	by (auto simp: THE_NRES_def split: option.splits)

	definition "CHECK f P = (if P then RETURN () else let _ = f () in SUCCEED)"
	definition "CHECK_dres f P = (if P then dRETURN () else let _ = f () in dSUCCEED)"
	context includes autoref_syntax begin
	lemma CHECK_refine[refine_transfer]:
	"nres_of (CHECK_dres f x) \<le> CHECK f x"
	by (auto simp: CHECK_dres_def CHECK_def)

	lemma CHECK_impl[autoref_rules]:
	"(CHECK, CHECK) \<in> (unit_rel \<rightarrow> A) \<rightarrow> bool_rel \<rightarrow> \<langle>unit_rel\<rangle>nres_rel"
	by (auto simp add: CHECK_def nres_rel_def)

	definition [simp]: "op_nres_CHECK_bnd f \<Phi> m \<equiv> do {CHECK f \<Phi>; m}"
	lemma id_CHECK[autoref_op_pat_def]:
	"do {CHECK f \<Phi>; m} \<equiv> OP op_nres_CHECK_bnd $ f $ \<Phi> $m"
	by simp

	lemma op_nres_CHECK_bnd[autoref_rules]:
	"(\<Phi> \<Longrightarrow> (m', m) \<in> \<langle>R\<rangle>nres_rel) \<Longrightarrow>
	(\<Phi>', \<Phi>) \<in> bool_rel \<Longrightarrow>
	(f', f) \<in> unit_rel \<rightarrow> A \<Longrightarrow>
	(do {CHECK f' \<Phi>'; m'}, op_nres_CHECK_bnd $ f $ \<Phi> $ m) \<in> \<langle>R\<rangle>nres_rel"
	by (simp add: CHECK_def nres_rel_def)

	lemma CHECK_rule[refine_vcg]:
	assumes "P \<Longrightarrow> RETURN () \<le> R"
	shows "CHECK f P \<le> R"
	using assms
	by (auto simp: CHECK_def)

	lemma SPEC_allI:
	assumes "\<And>x. f \<le> SPEC (P x)"
	shows "f \<le> SPEC (\<lambda>r. \<forall>x. P x r)"
	using assms
	by (intro pw_leI) (auto intro!: SPEC_nofail dest!: inres_SPEC)

	lemma SPEC_BallI:
	assumes "nofail f"
	assumes "\<And>x. x \<in> X \<Longrightarrow> f \<le> SPEC (P x)"
	shows "f \<le> SPEC (\<lambda>r. \<forall>x\<in>X. P x r)"
	using assms
	by (intro pw_leI) (force intro!: SPEC_nofail dest!: inres_SPEC)

	lemma map_option_param[param]: "(map_option, map_option) \<in> (R \<rightarrow> S) \<rightarrow> \<langle>R\<rangle>option_rel \<rightarrow> \<langle>S\<rangle>option_rel"
	by (auto simp: option_rel_def fun_relD)

	lemma those_param[param]: "(those, those) \<in> \<langle>\<langle>R\<rangle>option_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>R\<rangle>list_rel\<rangle>option_rel"
	unfolding those_def
	by parametricity

	lemma image_param[param]:
	shows "single_valued A \<Longrightarrow> single_valued B \<Longrightarrow>
	((`), (`)) \<in> (A \<rightarrow> B) \<rightarrow> \<langle>A\<rangle>set_rel \<rightarrow> \<langle>B\<rangle>set_rel"
	by (force simp: set_rel_def fun_rel_def elim!: single_valued_as_brE)

	end

	lemma Up_Down_SPECI:
	assumes a5: "single_valued R"
	assumes a2: "single_valued (S\<inverse>)"
	assumes "SPEC Q \<le> \<Down> (S\<inverse> O R) (SPEC P)"
	shows "\<Up> R (\<Down> S (SPEC Q)) \<le> SPEC P"
	proof -
	have "x \<in> Domain R" if a1: "(x, y) \<in> S" and a3: "Q y" for x y
	proof -
	obtain cc :: "('a \<times> 'b) set \<Rightarrow> ('c \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c"
	and bb :: "('a \<times> 'b) set \<Rightarrow> ('c \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'b"
	and aa :: "('a \<times> 'b) set \<Rightarrow> ('c \<times> 'a) set \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'a" where
	f4: "\<forall>x0 x1 x2 x3. (\<exists>v4 v5 v6. x3 = v4 \<and> x2 = v6 \<and> (v4, v5) \<in> x1 \<and> (v5, v6) \<in> x0) = (x3 = cc x0 x1 x2 x3 \<and> x2 = bb x0 x1 x2 x3 \<and> (cc x0 x1 x2 x3, aa x0 x1 x2 x3) \<in> x1 \<and> (aa x0 x1 x2 x3, bb x0 x1 x2 x3) \<in> x0)"
	by moura
	have f5: "RETURN y \<le> \<Down> (S\<inverse> O R) (SPEC P)"
	using a3 by (meson assms(3) dual_order.trans ireturn_rule)
	obtain bba :: "'b set \<Rightarrow> ('c \<times> 'b) set \<Rightarrow> 'c \<Rightarrow> 'b" where
	"\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> x0 \<and> (x2, v3) \<in> x1) = (bba x0 x1 x2 \<in> x0 \<and> (x2, bba x0 x1 x2) \<in> x1)"
	by moura
	then have "y = cc R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y"
	"bba (Collect P) (S\<inverse> O R) y = bb R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y"
	"(cc R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y, aa R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y) \<in> S\<inverse>"
	"(aa R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y, bb R (S\<inverse>) (bba (Collect P) (S\<inverse> O R) y) y) \<in> R"
	using f5 f4 by (meson RETURN_RES_refine_iff relcomp.cases)+
	then show ?thesis
	using a2 a1 by (metis Domain.simps converse.intros single_valued_def)
	qed
	moreover
	from assms have a1: "Collect Q \<subseteq> (S\<inverse> O R)\<inverse> `` Collect P"
	by (auto simp: conc_fun_def)
	have "P x" if Q: "Q z" and a3: "(y, z) \<in> S" and a4: "(y, x) \<in> R" for x y z
	proof -
	obtain bb :: "'b set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> 'c \<Rightarrow> 'b" where
	f7: "\<forall>x0 x1 x2. (\<exists>v3. (v3, x2) \<in> x1 \<and> v3 \<in> x0) = ((bb x0 x1 x2, x2) \<in> x1 \<and> bb x0 x1 x2 \<in> x0)"
	by moura
	have f8: "z \<in> (S\<inverse> O R)\<inverse> `` Collect P"
	using Q a1 by fastforce
	obtain cc :: "('a \<times> 'c) set \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> 'c" and aa :: "('a \<times> 'c) set \<Rightarrow> 'a \<Rightarrow> 'c \<Rightarrow> 'a" where
	f9: "z = cc S y z \<and> y = aa S y z \<and> (aa S y z, cc S y z) \<in> S"
	using a3 by simp
	then have f10: "(bb (Collect P) ((S\<inverse> O R)\<inverse>) (cc S y z), cc S y z) \<in> (S\<inverse> O R)\<inverse> \<and> bb (Collect P) ((S\<inverse> O R)\<inverse>) (cc S y z) \<in> Collect P"
	using f8 f7 by (metis (no_types) ImageE)
	have "(z, y) \<in> S\<inverse>"
	using a3 by force
	then show ?thesis
	using f10 f9 a2 a5 a4 by (metis converse.cases mem_Collect_eq relcompEpair single_valued_def)
	qed
	ultimately show ?thesis
	by (auto simp: conc_fun_def abs_fun_def)
	qed


	lemma nres_rel_comp: "\<langle>A\<rangle>nres_rel O \<langle>B\<rangle>nres_rel = \<langle>A O B\<rangle> nres_rel"
	unfolding nres_rel_def
	apply (auto simp: nres_rel_def conc_fun_def converse_relcomp relcomp_Image split: )
	apply (subst converse_relcomp)
	apply (subst relcomp_Image)
	apply (auto split: nres.splits)
	apply (meson Image_mono RES_leof_RES_iff equalityE le_RES_nofailI leofD leof_lift leof_trans)
	apply (rule relcompI)
	defer apply force
	apply (auto simp: converse_relcomp relcomp_Image)
	done

	lemma nres_rel_mono: "A \<subseteq> B \<Longrightarrow> \<langle>A\<rangle>nres_rel \<subseteq> \<langle>B\<rangle>nres_rel"
	apply (auto simp: nres_rel_def conc_fun_def)
	apply (split nres.splits)+
	apply auto
	by (meson Image_mono RES_leof_RES_iff converse_mono equalityE le_RES_nofailI leofD leof_lift leof_trans)

	text \<open>TODO: move!!\<close>

	lemma \<comment> \<open>TODO: needed because @{thm dres.transfer_rec_list} expects one argument,
	but functions with more arguments defined by primrec take several arguments\<close>
	uncurry_rec_list: "rec_list (\<lambda>a b. fn a b) (\<lambda>x xs rr a b. fs x xs rr a b) xs a b =
	rec_list (\<lambda>(a,b). fn a b) (\<lambda>x xs rr (a,b). fs x xs (\<lambda>a b. rr (a,b)) a b) xs (a,b)"
	apply (induction xs arbitrary: a b)
	apply (auto split: prod.splits)
	apply metis
	done


	lemma Id_br: "Id = br (\<lambda>x. x) top"
	by (auto simp: br_def)

	lemma br_rel_prod: "br a I \<times>\<^sub>r br b J = br (\<lambda>(x, y). (a x, b y)) (\<lambda>(x, y). I x \<and> J y)"
	by (auto simp: br_def)

	lemma br_list_rel: "\<langle>br a I\<rangle>list_rel = br (map a) (list_all I)"
	apply (auto simp: br_def list_rel_def list_all_iff list_all2_iff split_beta' Ball_def
	in_set_zip intro!: nth_equalityI)
	apply force
	by (metis in_set_conv_nth)

	lemma brD: "(c,a)\<in>br \<alpha> I \<Longrightarrow> a = \<alpha> c \<and> I c"
	by (simp add: br_def)


	primrec nres_of_nress :: "('b \<Rightarrow> bool) \<Rightarrow> 'b nres list \<Rightarrow> 'b list nres"
	where "nres_of_nress P [] = RETURN []"
	\| "nres_of_nress P (x#xs) = do {r \<leftarrow> x; rs \<leftarrow> nres_of_nress P xs; RETURN (r#rs)}"

	lemma nres_of_nress_SPEC[THEN order_trans, refine_vcg]:
	assumes [refine_vcg]: "\<And>x. x \<in> set xs \<Longrightarrow> x \<le> SPEC P"
	shows "nres_of_nress P xs \<le> SPEC (list_all P)"
	using assms
	apply (induction xs)
	- apply (simp add: )
	+ apply simp
	apply (simp add:)
	apply (intro refine_vcg)
	subgoal for x xs
	apply (rule order_trans[of _ "SPEC P"])
	apply auto
	apply refine_vcg
	done
	done
	context includes autoref_syntax begin
	lemma [autoref_op_pat_def]: "nres_of_nress P x \<equiv> (OP (nres_of_nress P) $ x)"
	by auto
	lemma nres_of_nress_alt_def[abs_def]:
	"nres_of_nress P xs = rec_list (RETURN []) (\<lambda>x xs xsa. x \<bind> (\<lambda>r. xsa \<bind> (\<lambda>rs. RETURN (r # rs)))) xs"
	by (induction xs) auto

	schematic_goal nres_of_nress_impl:
	"(?r, nres_of_nress P $ x) \<in> \<langle>\<langle>A\<rangle>list_rel\<rangle>nres_rel"
	if [autoref_rules]: "(xi, x) \<in> \<langle>\<langle>A\<rangle>nres_rel\<rangle>list_rel"
	unfolding nres_of_nress_alt_def
	by autoref
	concrete_definition nres_of_nress_impl uses nres_of_nress_impl
	lemmas [autoref_rules] = nres_of_nress_impl.refine

	lemma nres_of_nress_impl_map:
	"nres_of_nress_impl (map f x) =
	rec_list (RETURN []) (\<lambda>x xs r. do { fx \<leftarrow> f x; r \<leftarrow> r; RETURN (fx # r)}) x"
	by (induction x) (auto simp: nres_of_nress_impl_def)

	definition [refine_vcg_def]: "list_spec X = SPEC (\<lambda>xs. set xs = X)"

	end


	lemma
	insert_mem_set_rel_iff:
	assumes "single_valued A"
	shows "(insert x (set xs), XXS) \<in> \<langle>A\<rangle>set_rel \<longleftrightarrow> (\<exists>X XS. (x, X) \<in> A \<and> (set xs, XS) \<in> \<langle>A\<rangle>set_rel \<and> XXS = insert X XS)"
	using assms
	apply (auto simp: set_rel_def single_valuedD)
	subgoal for a
	apply (cases "x \<in> set xs")
	subgoal by (rule exI[where x=a]) auto
	subgoal
	apply (rule exI[where x=a])
	apply auto
	apply (rule exI[where x="{y\<in>XXS. (\<exists>x\<in>set xs. (x, y) \<in> A)}"])
	apply auto
	subgoal by (drule bspec, assumption) auto
	subgoal by (meson single_valuedD)
	done
	done
	done


	lemma image_mem_set_rel_iff:
	shows "(f ` x, y) \<in> \<langle>R\<rangle>set_rel \<longleftrightarrow> (x, y) \<in> \<langle>br f top O R\<rangle>set_rel"
	proof -
	have "z \<in> Domain ({(c, a). a = f c} O R)"
	if "f ` x \<subseteq> Domain R" "z \<in> x"
	for z
	proof -
	have "(f z, fun_of_rel R (f z)) \<in> R"
	using that
	by (auto intro!: for_in_RI)
	then show ?thesis
	by (auto intro!: Domain.DomainI[where b="fun_of_rel R (f z)"] relcompI[where b="f z"])
	qed
	then show ?thesis
	by (auto simp: set_rel_def relcomp.simps br_def)
	qed

	lemma finite_list_set_rel[autoref_rules]: "(\<lambda>_. True, finite) \<in> \<langle>A\<rangle>list_set_rel \<rightarrow> bool_rel"
	by (auto simp: list_set_rel_def br_def)

	lemma list_set_rel_finiteD: "(xs, X) \<in> \<langle>A\<rangle>list_set_rel \<Longrightarrow> finite X"
	by (auto simp: list_set_rel_def br_def)

	lemma set_rel_br: "\<langle>br a I\<rangle>set_rel = br ((`) a) (\<lambda>X. Ball X I)"
	by (auto simp: set_rel_def br_def)

	lemma set_rel_sv:
	"\<langle>R\<rangle>set_rel = {(S,S'). S'=R``S \<and> S\<subseteq>Domain R}"
	if "single_valued R"
	using that
	by (auto simp: set_rel_def set_rel_br elim!: single_valued_as_brE)
	(auto simp: br_def)

	lemma list_ex_rec_list: "list_ex P xs = rec_list False (\<lambda>x xs b. P x \<or> b) xs"
	by (induct xs) simp_all

	lemma list_ex_param[autoref_rules, param]:
	"(list_ex, list_ex) \<in> (A \<rightarrow> bool_rel) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> bool_rel"
	unfolding list_ex_rec_list
	by parametricity

	lemma zip_param[autoref_rules, param]:
	"(zip, zip) \<in> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A \<times>\<^sub>r A\<rangle>list_rel"
	by (rule param_zip)

	lemma ex_br_conj_iff:
	"(\<exists>x. (y, x) \<in> br a I \<and> P x) \<longleftrightarrow> I y \<and> P (a y)"
	by (auto intro!: brI dest!: brD)

	setup \<open>
	let
	fun higher_order_rl_of assms ctxt thm =
	let
	val ((_, [thm']), ctxt') = Variable.import true [thm] ctxt
	in
	case Thm.concl_of thm' of
	@{mpat "Trueprop ((_,?t)\<in>_)"} => let
	val (f0, args0) = strip_comb t
	val nargs = Thm.nprems_of thm' - length assms
	val (applied, args) = chop (length args0 - nargs) args0
	val f = betapplys (f0, applied)
	in
	if length args = 0 then
	thm
	else let
	val cT = TVar(("'c",0), @{sort type})
	val c = Var (("c",0),cT)
	val R = Var (("R",0), HOLogic.mk_setT (HOLogic.mk_prodT (cT, fastype_of f)))
	val goal =
	HOLogic.mk_mem (HOLogic.mk_prod (c,f), R)
	\|> HOLogic.mk_Trueprop
	\|> Thm.cterm_of ctxt
	val res_thm = Goal.prove_internal ctxt' (map (Thm.cprem_of thm') assms) goal (fn prems =>
	REPEAT (resolve_tac ctxt' @{thms fun_relI} 1)
	THEN (resolve_tac ctxt' [thm] 1)
	THEN (REPEAT (resolve_tac ctxt' prems 1))
	THEN (ALLGOALS (assume_tac ctxt'))
	)
	in
	singleton (Variable.export ctxt' ctxt) res_thm
	end
	end
	\| _ => raise THM("Expected autoref rule",~1,[thm])
	end

	fun higher_order_rl_attr assms =
	Thm.rule_attribute [] (higher_order_rl_of assms o Context.proof_of)
	in
	Attrib.setup @{binding autoref_higher_order_rule}
	(Scan.optional (Scan.lift(Args.parens (Scan.repeat Parse.nat))) [] >>
	higher_order_rl_attr) "Autoref: Convert rule to higher-order form"
	end
	\<close>

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Refine_Default.thy b/thys/Ordinary_Differential_Equations/Refinement/Refine_Default.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Refine_Default.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Refine_Default.thy
	@@ -1,117 +1,117 @@
	theory Refine_Default
	imports
	Enclosure_Operations
	Weak_Set
	begin

	consts i_default::"interface \<Rightarrow> interface"

	definition default_rel_internal: "default_rel d X = insert (None, d) ((\<lambda>(x, y). (Some x, y)) ` X)"
	lemma default_rel_def: "\<langle>X\<rangle>default_rel d = insert (None, d) ((\<lambda>(x, y). (Some x, y)) ` X)"
	by (auto simp: relAPP_def default_rel_internal)
	lemmas [autoref_rel_intf] = REL_INTFI[of "default_rel d" i_default for d]

	lemma single_valued_default_rel[relator_props]:
	"single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>default_rel d)"
	by (auto simp: default_rel_def intro!: relator_props) (auto simp: single_valued_def)

	lemma
	mem_default_relI:
	assumes "a = None \<Longrightarrow> b = d"
	assumes "\<And>x. a = Some x \<Longrightarrow> (x, b) \<in> R"
	shows "(a, b) \<in> \<langle>R\<rangle>default_rel d"
	using assms image_iff
	by (force simp: default_rel_def)

	lemma Some_mem_default_rel: "(Some x, y) \<in> \<langle>X\<rangle>default_rel d\<longleftrightarrow> (x, y) \<in> X"
	by (auto simp: default_rel_def)

	lemma option_rel_inverse[simp]: "(\<langle>R\<rangle>option_rel)\<inverse> = \<langle>R\<inverse>\<rangle>option_rel"
	by (auto simp: option_rel_def)

	lemma default_rel_split[autoref_rules]:
	assumes split_impl: "(split_impl, split_spec) \<in> A \<rightarrow> \<langle>B \<times>\<^sub>r A\<rangle>nres_rel"
	shows "(\<lambda>xs.
	case xs of None \<Rightarrow> SUCCEED
	\| Some x \<Rightarrow> do {(r, s) \<leftarrow> split_impl x; RETURN (r, Some s)},
	split_spec) \<in>
	\<langle>A\<rangle>default_rel d \<rightarrow> \<langle>B \<times>\<^sub>r \<langle>A\<rangle>default_rel d\<rangle>nres_rel"
	proof -
	have "split_impl a \<bind> (\<lambda>(r, s). RETURN (r, Some s))
	\<le> \<Down> (B \<times>\<^sub>r insert (None, d) ((\<lambda>(x, y). (Some x, y)) ` A)) (SPEC (\<lambda>(A, B). b \<subseteq> A \<union> B))"
	if "(a, b) \<in> A"
	for a b
	proof -
	have split_inresD:
	"\<exists>a. (c, a) \<in> B \<and> (\<exists>bb. (Some d, bb) \<in> (\<lambda>(x, y). (Some x, y)) ` A \<and> b \<subseteq> a \<union> bb)"
	if "inres (split_impl a) (c, d)"
	for c d
	proof -
	have "RETURN (c, d) \<le> \<Down> (B \<times>\<^sub>r A) (split_spec b)"
	using \<open>(a, b) \<in> A\<close> that split_impl
	by (auto simp: inres_def nres_rel_def dest!: fun_relD)
	then show ?thesis
	using \<open>(a, b) \<in> A\<close> that split_impl
	by (fastforce simp: split_spec_def elim!: RETURN_ref_SPECD)
	qed
	have "nofail (split_impl a)"
	using split_impl[param_fo, OF \<open>(a, b) \<in> A\<close>] le_RES_nofailI
	by (auto simp: split_spec_def nres_rel_def conc_fun_def)
	then show ?thesis
	using that split_impl
	by (fastforce simp: refine_pw_simps dest!: split_inresD intro!: pw_leI)
	qed
	then show ?thesis
	by (auto simp: split_spec_def default_rel_def
	intro!: nres_relI)
	qed

	lemma br_Some_O_default_rel_eq: "br Some top O \<langle>A\<rangle>default_rel d = A"
	by (auto simp: br_def default_rel_def)

	definition [simp]: "op_Union_default = Union"

	context includes autoref_syntax begin
	lemma [autoref_op_pat]: "Union \<equiv> OP op_Union_default"
	by simp

	lemma default_rel_Union[autoref_rules]:
	assumes sv: "PREFER single_valued A"
	assumes safe: "SIDE_PRECOND (\<forall>x \<in> X. x \<subseteq> d)"
	assumes xs: "(xs, X) \<in> \<langle>\<langle>A\<rangle>default_rel d\<rangle>list_wset_rel"
	assumes Union_A: "(concat, Union) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> A"
	shows "(map_option concat (those xs), op_Union_default $ X) \<in> \<langle>A\<rangle>default_rel d"
	using xs
	apply (safe dest!: list_wset_relD intro!: mem_default_relI)
	subgoal using safe by (auto simp: default_rel_def)
	subgoal by (auto simp: default_rel_def those_eq_None_set_iff dest!: set_relD)[]
	subgoal
	by (auto simp: those_eq_Some_map_Some_iff image_mem_set_rel_iff br_Some_O_default_rel_eq list_wset_rel_def
	intro!: relcompI brI Union_A[param_fo])
	done

	definition [simp]: "op_empty_default = {}"
	lemma default_rel_empty[autoref_rules]:
	assumes "GEN_OP ei {} A"
	shows "(Some ei, op_empty_default) \<in> \<langle>A\<rangle>default_rel d"
	using assms by (auto simp: default_rel_def)

	definition mk_default::"'a set \<Rightarrow> 'a set" where [refine_vcg_def, simp]: "mk_default x = x"

	lemma mk_default[autoref_rules]:
	"(Some, mk_default) \<in> R \<rightarrow> \<langle>R\<rangle>default_rel d"
	by (auto simp: default_rel_def)

	definition [refine_vcg_def]: "default_rep d X = SPEC (\<lambda>x. case x of None \<Rightarrow> X = d \| Some r \<Rightarrow> X = r)"

	lemma default_rep_op_pat[autoref_op_pat_def]: "default_rep d \<equiv> OP (default_rep d)"
	- by (auto simp: )
	+ by auto

	lemma default_rep[autoref_rules]:
	"(\<lambda>x. RETURN x, default_rep d) \<in> (\<langle>R\<rangle>(default_rel d)) \<rightarrow> \<langle>\<langle>R\<rangle>option_rel\<rangle>nres_rel"
	by (force simp: default_rep_def nres_rel_def default_rel_def
	split: option.splits intro!: RETURN_SPEC_refine )

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Refine_Interval.thy b/thys/Ordinary_Differential_Equations/Refinement/Refine_Interval.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Refine_Interval.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Refine_Interval.thy
	@@ -1,812 +1,812 @@
	theory
	Refine_Interval
	imports
	Refine_Unions
	Refine_Vector_List
	Refine_Hyperplane
	Refine_Invar
	begin

	subsubsection \<open>interval approximation of many\<close>

	definition ivl_rep_of_sets::"'a::lattice set set \<Rightarrow> ('a \<times> 'a) nres" where
	"ivl_rep_of_sets (XS::'a set set) = SPEC (\<lambda>(i, s). i \<le> s \<and> (\<forall>X\<in>XS. X \<subseteq> {i..s}))"
	lemmas [refine_vcg] = ivl_rep_of_sets_def[THEN eq_refl, THEN order.trans]

	subsection \<open>Interval representation\<close>

	consts i_ivl::"interface \<Rightarrow> interface"

	context includes autoref_syntax begin

	definition "set_of_ivl x = {fst x .. snd x}"

	definition "set_of_lvivl ivl = (set_of_ivl (map_prod eucl_of_list eucl_of_list ivl)::'a::executable_euclidean_space set)"

	definition ivl_rel::"('a \<times> 'b::ordered_euclidean_space) set \<Rightarrow> (('a \<times> 'a) \<times> 'b set) set" where
	ivl_rel_internal: "ivl_rel S = (S \<times>\<^sub>r S) O br set_of_ivl top"
	lemma ivl_rel_def: "\<langle>S\<rangle>ivl_rel = (S \<times>\<^sub>r S) O br set_of_ivl top"
	unfolding relAPP_def ivl_rel_internal ..

	lemmas [autoref_rel_intf] = REL_INTFI[of "ivl_rel" "i_ivl"]

	lemma ivl_rel_sv[relator_props]: "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>ivl_rel)"
	unfolding relAPP_def
	by (auto simp: ivl_rel_internal intro!: relator_props)

	definition [simp]: "op_atLeastAtMost_ivl = atLeastAtMost"
	lemma [autoref_op_pat]: "atLeastAtMost \<equiv> OP op_atLeastAtMost_ivl"
	by simp

	lemma atLeastAtMost_ivlrel[autoref_rules]:
	"(Pair, op_atLeastAtMost_ivl) \<in> A \<rightarrow> A \<rightarrow> \<langle>A\<rangle>ivl_rel"
	by (auto simp: br_def set_of_ivl_def ivl_rel_def intro!: prod_relI)

	definition [refine_vcg_def]: "ivl_rep X = SPEC (\<lambda>(l, u). X = {l .. u})"

	lemma ivl_rep_autoref[autoref_rules]: "(RETURN, ivl_rep) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A \<times>\<^sub>r A\<rangle>nres_rel"
	by (force intro!: nres_relI RETURN_SPEC_refine simp: ivl_rep_def ivl_rel_def br_def set_of_ivl_def)

	lemma Inf_ivl_rel[autoref_rules]:
	fixes X::"'a::ordered_euclidean_space set"
	assumes "SIDE_PRECOND (X \<noteq> {})"
	assumes "(Xi, X) \<in> \<langle>A\<rangle>ivl_rel"
	shows "(fst Xi, Inf $ X) \<in> A"
	using assms
	by (auto simp: ivl_rel_def br_def set_of_ivl_def)

	lemma Sup_ivl_rel[autoref_rules]:
	fixes X::"'a::ordered_euclidean_space set"
	assumes "SIDE_PRECOND (X \<noteq> {})"
	assumes "(Xi, X) \<in> \<langle>A\<rangle>ivl_rel"
	shows "(snd Xi, Sup $ X) \<in> A"
	using assms
	by (auto simp: ivl_rel_def br_def set_of_ivl_def)

	definition "filter_empty_ivls_impl le ivls = [(i, s) \<leftarrow> ivls. le i s]"

	lemma filter_empty_ivls_impl_simps[simp]:
	shows
	"filter_empty_ivls_impl le [] = []"
	"filter_empty_ivls_impl le (a # xs) =
	(if le (fst a) (snd a) then a#filter_empty_ivls_impl le xs else filter_empty_ivls_impl le xs)"
	by (auto simp: filter_empty_ivls_impl_def)

	definition [simp]: "filter_empty_ivls X = X"

	lemma clw_rel_empty_iff:
	assumes "single_valued A"
	assumes "(x, {}) \<in> A" "(xs, X) \<in> clw_rel A"
	shows "(x#xs, X) \<in> clw_rel A"
	using assms
	by (auto simp: lw_rel_def Union_rel_br elim!: single_valued_as_brE) (auto simp: br_def)

	lemma
	empty_ivl_relD:
	"(a, Y) \<in> \<langle>A\<rangle>ivl_rel \<Longrightarrow> single_valued A \<Longrightarrow> (le, (\<le>)) \<in> A \<rightarrow> A \<rightarrow> bool_rel \<Longrightarrow> \<not> le (fst a) (snd a) \<Longrightarrow> Y = {}"
	by (fastforce simp: ivl_rel_def br_def set_of_ivl_def dest: fun_relD )

	lemma union_clw_relI: "(set xs, YS) \<in> \<langle>A\<rangle>set_rel \<Longrightarrow> (xs, \<Union>YS) \<in> clw_rel (A)"
	apply (auto simp: clw_rel_def br_def )
	apply (auto simp: lw_rel_def Union_rel_br set_rel_def )
	apply (auto simp: br_def)
	done

	lemma filter_empty_ivls_impl_mem_clw_rel_ivl_rel_iff:
	"(filter_empty_ivls_impl (\<le>) xs, X) \<in> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel) \<longleftrightarrow> (xs, X) \<in> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel)"
	by (force simp: lw_rel_def ivl_rel_def Union_rel_br filter_empty_ivls_impl_def
	set_of_ivl_def dest!: brD intro!: brI)

	lemma filter_empty_ivls_eucl:
	"(filter_empty_ivls_impl (\<le>), filter_empty_ivls) \<in> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel) \<rightarrow> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel)"
	by (auto simp: filter_empty_ivls_impl_mem_clw_rel_ivl_rel_iff)

	lemma filter_param[param]:
	"(filter, filter) \<in> (A \<rightarrow> bool_rel) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel"
	unfolding List.filter_def[abs_def]
	by parametricity

	lemma prod_rel_comp_ivl_rel:
	assumes "single_valued A" "single_valued B"
	shows "(A \<times>\<^sub>r A) O \<langle>B\<rangle>ivl_rel = \<langle>A O B\<rangle>ivl_rel"
	using assms
	by (auto simp: ivl_rel_def set_of_ivl_def br_chain br_rel_prod
	elim!: single_valued_as_brE
	intro!:brI dest!: brD)

	lemma filter_empty_ivls[autoref_rules]:
	assumes [THEN PREFER_sv_D, relator_props]: "PREFER single_valued A"
	assumes [THEN GEN_OP_D, param]: "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	assumes xs: "(xs, X) \<in> clw_rel (\<langle>A\<rangle>ivl_rel)"
	shows "(filter_empty_ivls_impl le xs, filter_empty_ivls $ X) \<in> clw_rel (\<langle>A\<rangle>ivl_rel)"
	proof -
	have "(filter_empty_ivls_impl le, filter_empty_ivls_impl (\<le>)) \<in> \<langle>A\<times>\<^sub>rA\<rangle>list_rel \<rightarrow> \<langle>A\<times>\<^sub>rA\<rangle>list_rel"
	unfolding filter_empty_ivls_impl_def
	by parametricity
	moreover
	have "(filter_empty_ivls_impl (\<le>), filter_empty_ivls) \<in> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel) \<rightarrow> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel)"
	by (rule filter_empty_ivls_eucl)
	ultimately have "(filter_empty_ivls_impl le, filter_empty_ivls) \<in>
	(\<langle>A \<times>\<^sub>r A\<rangle>list_rel \<rightarrow> \<langle>A \<times>\<^sub>r A\<rangle>list_rel) O (clw_rel (\<langle>rnv_rel\<rangle>ivl_rel) \<rightarrow> clw_rel (\<langle>rnv_rel\<rangle>ivl_rel))" ..
	also have "\<dots> \<subseteq> (\<langle>A \<times>\<^sub>r A\<rangle>list_rel O clw_rel (\<langle>rnv_rel\<rangle>ivl_rel)) \<rightarrow> (\<langle>A \<times>\<^sub>r A\<rangle>list_rel O clw_rel (\<langle>rnv_rel\<rangle>ivl_rel))"
	by (rule fun_rel_comp_dist)
	also have "(\<langle>A \<times>\<^sub>r A\<rangle>list_rel O clw_rel (\<langle>rnv_rel\<rangle>ivl_rel)) = clw_rel (\<langle>A\<rangle>ivl_rel)"
	unfolding Id_arbitrary_interface_def
	apply (subst list_rel_comp_Union_rel)
	apply (intro relator_props)
	apply (subst prod_rel_comp_ivl_rel)
	apply (intro relator_props)
	apply (intro relator_props)
	apply simp
	done
	finally show ?thesis using xs by (auto dest: fun_relD)
	qed

	definition [simp]: "op_inter_ivl = (\<inter>)"
	lemma [autoref_op_pat]: "(\<inter>) \<equiv> OP op_inter_ivl"
	by simp
	lemma inter_ivl_rel[autoref_rules]:
	assumes infi[THEN GEN_OP_D, param_fo]: "GEN_OP infi inf (A \<rightarrow> A \<rightarrow> A)"
	assumes supi[THEN GEN_OP_D, param_fo]:"GEN_OP supi sup (A \<rightarrow> A \<rightarrow> A)"
	shows "(\<lambda>(i, s). \<lambda>(i', s'). (supi i i', infi s s'), op_inter_ivl) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel"
	using assms
	by (fastforce simp: ivl_rel_def br_def set_of_ivl_def intro!: infi supi prod_relI)

	definition [simp]: "op_inter_ivl_coll = (\<inter>)"
	lemma [autoref_op_pat]: "(\<inter>) \<equiv> OP op_inter_ivl_coll"
	by simp
	lemma inter_ivl_clw_aux:
	assumes sv: "single_valued A"
	assumes intr: "(intr, (\<inter>)) \<in> (\<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel)"
	shows "(\<lambda>xs y. map (intr y) xs, (\<inter>)) \<in> clw_rel (\<langle>A\<rangle>ivl_rel) \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> clw_rel (\<langle>A\<rangle>ivl_rel)"
	apply (rule fun_relI)
	apply (rule fun_relI)
	using sv
	apply (rule single_valued_as_brE)
	apply simp
	unfolding ivl_rel_def br_rel_prod br_chain prod_rel_id_simp Id_O_R
	apply (rule map_mem_clw_rel_br)
	apply (auto simp: set_of_ivl_def)
	subgoal for a b c d e f g h i j
	using intr[param_fo, of "(c, d)" "{f c .. f d}" "(i, j)" "{f i .. f j}"]
	apply (auto simp: lw_rel_def Union_rel_br ivl_rel_def set_of_ivl_def br_rel_prod br_chain)
	apply (auto simp: br_def set_of_ivl_def split_beta')
	apply (rule bexI) prefer 2 apply assumption
	apply simp
	by (metis (mono_tags, lifting) Int_iff atLeastAtMost_iff fst_conv snd_conv)
	subgoal for a b c d e f g h i j
	using intr[param_fo, of "(c, d)" "{f c .. f d}" "(i, j)" "{f i .. f j}"]
	apply (auto simp: lw_rel_def Union_rel_br ivl_rel_def set_of_ivl_def br_rel_prod br_chain)
	apply (auto simp: br_def set_of_ivl_def split_beta')
	by (metis (mono_tags, lifting) Int_iff atLeastAtMost_iff fst_conv snd_conv)+
	subgoal for a b c d e f g h
	using intr[param_fo, of "(c, d)" "{f c .. f d}" ]
	apply (auto simp: lw_rel_def Union_rel_br ivl_rel_def set_of_ivl_def br_rel_prod br_chain)
	apply (auto simp: br_def set_of_ivl_def split_beta')
	apply (rule bexI) prefer 2 apply assumption
	by (metis (mono_tags, lifting) Int_iff atLeastAtMost_iff fst_conv snd_conv)
	subgoal for a b c d e f g h
	using intr[param_fo, of "(c, d)" "{f c .. f d}" ]
	apply (auto simp: lw_rel_def Union_rel_br ivl_rel_def set_of_ivl_def br_rel_prod br_chain)
	apply (auto simp: br_def set_of_ivl_def split_beta')
	by (metis (mono_tags, lifting) fst_conv snd_conv)
	subgoal for a b c d e f g h
	using intr[param_fo, of "(c, d)" "{f c .. f d}" ]
	apply (auto simp: lw_rel_def Union_rel_br ivl_rel_def set_of_ivl_def br_rel_prod br_chain)
	apply (auto simp: br_def set_of_ivl_def split_beta')
	by (metis (mono_tags, lifting) fst_conv snd_conv)
	done

	lemma inter_ivl_clw[autoref_rules]:
	assumes sv[THEN PREFER_sv_D]: "PREFER single_valued A"
	assumes intr[THEN GEN_OP_D]: "GEN_OP intr op_inter_ivl (\<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>ivl_rel)"
	assumes "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(\<lambda>xs y. filter_empty_ivls_impl le (map (intr y) xs), op_inter_ivl_coll) \<in> clw_rel (\<langle>A\<rangle>ivl_rel) \<rightarrow> (\<langle>A\<rangle>ivl_rel) \<rightarrow> clw_rel (\<langle>A\<rangle>ivl_rel)"
	apply safe
	subgoal premises prems
	using filter_empty_ivls[OF assms(1,3), param_fo, OF inter_ivl_clw_aux[OF sv intr[unfolded op_inter_ivl_def], param_fo, OF prems]]
	by simp
	done

	lemma ivl_rel_br: "\<langle>br a I\<rangle>ivl_rel = br (\<lambda>(x, y). set_of_ivl (a x, a y)) (\<lambda>(x, y). I x \<and> I y)"
	unfolding ivl_rel_def br_rel_prod br_chain
	by (simp add: split_beta' o_def)

	lemma Inf_spec_ivl_rel[autoref_rules]:
	"(\<lambda>x. RETURN (fst x), Inf_spec) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
	and Sup_spec_ivl_rel[autoref_rules]:
	"(\<lambda>x. RETURN (snd x), Sup_spec) \<in> \<langle>A\<rangle>ivl_rel \<rightarrow> \<langle>A\<rangle>nres_rel"
	by (force simp: Inf_spec_def Sup_spec_def nres_rel_def ivl_rel_def br_def set_of_ivl_def
	intro!: RETURN_SPEC_refine)+

	abbreviation "lvivl_rel \<equiv> \<langle>lv_rel\<rangle>ivl_rel"

	lemma set_of_lvivl: "length (l) = DIM('a::executable_euclidean_space) \<Longrightarrow>
	length u = DIM('a) \<Longrightarrow>
	((l, u), set_of_lvivl (l, u)::'a set) \<in> lvivl_rel"
	by (force simp: set_of_lvivl_def ivl_rel_br ivl_rel_def lv_rel_def br_def)

	lemma lvivl_rel_br: "lvivl_rel = br (\<lambda>(x, y). set_of_ivl (eucl_of_list x, eucl_of_list y::'a)) (\<lambda>(x, y). length x = DIM('a::executable_euclidean_space) \<and> length y = DIM('a))"
	unfolding lv_rel_def ivl_rel_br by (simp add: split_beta')


	lemma disjoint_sets_nres:
	fixes X Y::"'a::executable_euclidean_space set"
	shows "do {
	(iX, sX) \<leftarrow> ivl_rep X;
	(iY, sY) \<leftarrow> ivl_rep Y;
	RETURN (list_ex (\<lambda>i. sX \<bullet> i < iY \<bullet> i \<or> sY \<bullet> i < iX \<bullet> i) Basis_list)
	} \<le> disjoint_sets X Y"
	by (force simp: Inf_spec_def Sup_spec_def disjoint_sets_def list_ex_iff eucl_le[where 'a='a]
	intro!: refine_vcg)

	schematic_goal disjoint_sets_impl:
	fixes A::"(_ * 'a::executable_euclidean_space set) set"
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a)) n"
	assumes [autoref_rules]: "(ai, a::'a set) \<in> lvivl_rel"
	assumes [autoref_rules]: "(bi, b) \<in> lvivl_rel"
	shows "(nres_of (?f::?'r dres), disjoint_sets $ a $ b) \<in> ?R"
	unfolding autoref_tag_defs
	by (rule disjoint_sets_nres[THEN nres_rel_trans2]) autoref_monadic

	concrete_definition disjoint_sets_impl for n ai bi uses disjoint_sets_impl
	lemma disjoint_sets_impl_refine[autoref_rules]:
	"DIM_precond (TYPE('a::executable_euclidean_space)) n \<Longrightarrow>
	(\<lambda>ai bi. nres_of (disjoint_sets_impl n ai bi), disjoint_sets::'a set \<Rightarrow> _) \<in> lvivl_rel \<rightarrow> lvivl_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using disjoint_sets_impl.refine by force

	definition [simp]: "project_set_ivl X b y = do {
	CHECK (\<lambda>_. ()) (b \<in> set Basis_list \<or> -b \<in> set Basis_list);
	(i, s) \<leftarrow> ivl_rep X;
	RETURN (op_atLeastAtMost_ivl (i + (y - i \<bullet> b) \<^sub>R b) (s + (y - s \<bullet> b) \<^sub>R b):::\<langle>lv_rel\<rangle>ivl_rel)
	}"

	schematic_goal project_set_ivl:
	fixes b::"'a::executable_euclidean_space" and y
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a)) n"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	assumes [autoref_rules]: "(bi, b) \<in> lv_rel"
	assumes [autoref_rules]: "(yi, y) \<in> rnv_rel"
	shows "(nres_of (?f::?'r dres), project_set_ivl X b y) \<in> ?R"
	unfolding project_set_ivl_def
	by autoref_monadic
	concrete_definition project_set_ivl_impl for n Xi bi yi uses project_set_ivl
	lemma project_set_ivl_refine[autoref_rules]:
	"DIM_precond (TYPE('a)) n \<Longrightarrow>
	(\<lambda>Xi bi yi. nres_of (project_set_ivl_impl n Xi bi yi), project_set_ivl) \<in>
	\<langle>lv_rel\<rangle>ivl_rel \<rightarrow> (lv_rel::(_\<times>'a::executable_euclidean_space) set) \<rightarrow> rnv_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>ivl_rel\<rangle>nres_rel"
	using project_set_ivl_impl.refine by force

	lemma project_set_ivl_spec[le, refine_vcg]: "project_set_ivl X b y \<le>
	SPEC (\<lambda>R. abs b \<in> Basis \<and> (\<exists>i s. X = {i .. s} \<and> R = {i + (y - i \<bullet> b) \<^sub>R b .. s + (y - s \<bullet> b) \<^sub>R b}))"
	proof -
	define b' where "b' \<equiv> abs b"
	then have "b \<in> Basis \<Longrightarrow> b' \<in> Basis"
	"- b \<in> Basis \<Longrightarrow> b' \<in> Basis"
	"b \<in> Basis \<Longrightarrow> b = b'"
	"-b \<in> Basis \<Longrightarrow> b = - b'"
	using Basis_nonneg by (fastforce)+
	then show ?thesis
	unfolding project_set_ivl_def
	by refine_vcg
	(auto 0 4 simp: subset_iff eucl_le[where 'a='a] algebra_simps inner_Basis)
	qed

	lemma projection_notempty:
	fixes b::"'a::executable_euclidean_space"
	assumes "b \<in> Basis \<or> -b \<in> Basis"
	assumes "x \<le> z"
	shows "x + (y - x \<bullet> b) \<^sub>R b \<le> z + (y - z \<bullet> b) \<^sub>R b"
	proof -
	define b' where "b' \<equiv> - b"
	then have b_dest: "-b \<in> Basis \<Longrightarrow> b = -b' \<and> b' \<in> Basis"
	by simp
	show ?thesis using assms
	by (auto simp: eucl_le[where 'a='a] algebra_simps inner_Basis dest!: b_dest)
	qed

	end

	definition restrict_to_halfspace::"'a::executable_euclidean_space sctn \<Rightarrow> 'a set \<Rightarrow> 'a set nres"
	where
	"restrict_to_halfspace sctn X = do {
	CHECK (\<lambda>_. ()) (normal sctn \<in> set Basis_list \<or> - normal sctn \<in> set Basis_list);
	let y = pstn sctn;
	let b = normal sctn;
	(i, s) \<leftarrow> ivl_rep X;
	let i' = (if b \<le> 0 then (i + (min (y - i \<bullet> b) 0) *\<^sub>R b) else i);
	let s' = (if b \<ge> 0 then (s + (min (y - s \<bullet> b) 0) *\<^sub>R b) else s);
	RETURN ({i' .. s'}:::\<^sub>i\<langle>i_rnv\<rangle>\<^sub>ii_ivl)
	}"

	context includes autoref_syntax begin

	schematic_goal restrict_to_halfspace_impl:
	fixes b y
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a::executable_euclidean_space)) n"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	assumes [autoref_rules]: "(sctni, sctn::'a sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(nres_of (?f::?'r dres), restrict_to_halfspace sctn X) \<in> ?R"
	unfolding restrict_to_halfspace_def[abs_def]
	by (autoref_monadic)
	concrete_definition restrict_to_halfspace_impl for n sctni Xi uses restrict_to_halfspace_impl
	lemma restrict_to_halfspace_impl_refine[autoref_rules]:
	"DIM_precond (TYPE('a::executable_euclidean_space)) n \<Longrightarrow>
	(\<lambda>sctni Xi. nres_of (restrict_to_halfspace_impl n sctni Xi), restrict_to_halfspace::'a sctn\<Rightarrow>_) \<in>
	\<langle>lv_rel\<rangle>sctn_rel \<rightarrow> \<langle>lv_rel\<rangle>ivl_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>ivl_rel\<rangle>nres_rel"
	using restrict_to_halfspace_impl.refine by force
	lemma restrict_to_halfspace[THEN order_trans, refine_vcg]:
	"restrict_to_halfspace sctn X \<le> SPEC (\<lambda>R. R = X \<inter> below_halfspace sctn)"
	unfolding restrict_to_halfspace_def
	apply (refine_vcg)
	subgoal premises prems for x a b
	proof -
	from prems obtain i where i: "i \<in> Basis" and disj: "normal sctn = i \<or> normal sctn = - i"
	- by (auto simp: )
	+ by auto
	note nn = Basis_nonneg[OF i]
	note nz = nonzero_Basis[OF i]
	have ne: "- i \<noteq> i" using nn nz
	by (metis antisym neg_le_0_iff_le)
	have nn_iff: "0 \<le> normal sctn \<longleftrightarrow> normal sctn = i"
	using disj nn
	by (auto)
	from prems have X: "X = {a .. b}" by auto
	from disj show ?thesis
	unfolding nn_iff
	apply (rule disjE)
	using nn nz ne
	apply (simp_all add: below_halfspace_def le_halfspace_def[abs_def])
	unfolding X using i
	by (auto simp: eucl_le[where 'a='a] min_def algebra_simps inner_Basis
	split: if_splits)
	(auto simp: algebra_simps not_le)
	qed
	done

	lemma restrict_to_halfspaces_impl:
	"do {
	ASSUME (finite sctns);
	FOREACH\<^bsup>\<lambda>sctns' Y. Y = X \<inter> below_halfspaces (sctns - sctns')\<^esup> sctns restrict_to_halfspace X
	} \<le> restrict_to_halfspaces sctns X"
	unfolding restrict_to_halfspaces_def
	by (refine_vcg) (auto simp: halfspace_simps)

	schematic_goal restrict_to_halfspaces_ivl:
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a::executable_euclidean_space)) n"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>lv_rel\<rangle>ivl_rel"
	assumes sctns[autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	notes [simp] = list_set_rel_finiteD[OF sctns]
	shows "(nres_of (?f::?'r dres), restrict_to_halfspaces sctns X::'a set nres) \<in> ?R"
	by (rule nres_rel_trans2[OF restrict_to_halfspaces_impl]) autoref_monadic
	concrete_definition restrict_to_halfspaces_ivl for n sctnsi Xi uses restrict_to_halfspaces_ivl
	lemma restrict_to_halfspaces_impl_refine[autoref_rules]:
	"DIM_precond (TYPE('a::executable_euclidean_space)) n \<Longrightarrow>
	(\<lambda>sctni Xi. nres_of (restrict_to_halfspaces_ivl n sctni Xi), restrict_to_halfspaces) \<in>
	sctns_rel \<rightarrow> \<langle>(lv_rel::(_\<times>'a) set)\<rangle>ivl_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>ivl_rel\<rangle>nres_rel"
	using restrict_to_halfspaces_ivl.refine[of n] by force

	definition [simp]: "restrict_to_halfspaces_clw = restrict_to_halfspaces"
	lemma restrict_to_halfspaces_clw:
	"do {
	XS \<leftarrow> sets_of_coll X;
	FORWEAK XS (RETURN op_empty_coll) (\<lambda>X. do {R \<leftarrow> restrict_to_halfspaces sctns X; RETURN (filter_empty_ivls (mk_coll R))})
	(\<lambda>X Y. RETURN (Y \<union> X))
	} \<le> restrict_to_halfspaces_clw sctns X"
	unfolding restrict_to_halfspaces_def restrict_to_halfspaces_clw_def
	by (refine_vcg FORWEAK_mono_rule[where
	I="\<lambda>XS R. \<Union>XS \<inter> below_halfspaces sctns \<subseteq> R \<and> R \<subseteq> X \<inter> below_halfspaces sctns"])
	auto
	schematic_goal restrict_to_halfspaces_clw_rel:
	fixes X::"'a::executable_euclidean_space set"
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a)) n"
	assumes [autoref_rules]: "(Xi, X) \<in> clw_rel (\<langle>lv_rel\<rangle>ivl_rel)"
	assumes sctns[autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	notes [simp] = list_set_rel_finiteD[OF sctns]
	shows "(nres_of (?f::?'r dres), restrict_to_halfspaces_clw sctns X) \<in> ?R"
	by (rule nres_rel_trans2[OF restrict_to_halfspaces_clw]) autoref_monadic
	concrete_definition restrict_to_halfspaces_clw_rel for n sctnsi Xi uses restrict_to_halfspaces_clw_rel
	lemma restrict_to_halfspaces_clw_rel_refine[autoref_rules]:
	"DIM_precond (TYPE('a::executable_euclidean_space)) n \<Longrightarrow>
	(\<lambda>sctni Xi. nres_of (restrict_to_halfspaces_clw_rel n sctni Xi), restrict_to_halfspaces_clw) \<in>
	sctns_rel \<rightarrow> clw_rel (\<langle>lv_rel\<rangle>ivl_rel) \<rightarrow> \<langle>clw_rel (\<langle>(lv_rel::(_\<times>'a) set)\<rangle>ivl_rel)\<rangle>nres_rel"
	using restrict_to_halfspaces_clw_rel.refine by force

	definition [simp]: "restrict_to_halfspaces_invar_clw = restrict_to_halfspaces"
	lemma restrict_to_halfspaces_invar_clw_ref:
	"do {
	XS \<leftarrow> (sets_of_coll X);
	FORWEAK XS (RETURN op_empty_coll) (\<lambda>X. do {
	(X, i) \<leftarrow> get_invar a X;
	R \<leftarrow> restrict_to_halfspaces sctns X;
	ASSERT (R \<subseteq> a i);
	RETURN (with_invar i (filter_empty_ivls (mk_coll R)):::clw_rel (\<langle>I, lvivl_rel\<rangle>invar_rel a))
	}) (\<lambda>X Y. RETURN (Y \<union> X))
	} \<le> restrict_to_halfspaces_invar_clw sctns X"
	unfolding restrict_to_halfspaces_def restrict_to_halfspaces_invar_clw_def
	by (refine_vcg FORWEAK_mono_rule[where
	I="\<lambda>XS R. \<Union>XS \<inter> below_halfspaces sctns \<subseteq> R \<and> R \<subseteq> X \<inter> below_halfspaces sctns"])
	auto

	schematic_goal restrict_to_halfspaces_invar_clw_impl:
	fixes X::"'a::executable_euclidean_space set"
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a)) n"
	assumes [autoref_rules]: "(Xi, X) \<in> clw_rel (\<langle>I, lvivl_rel\<rangle>invar_rel a)"
	assumes sctns[autoref_rules]: "(sctnsi, sctns) \<in> sctns_rel"
	notes [simp] = list_set_rel_finiteD[OF sctns]
	shows "(nres_of (?f::?'r dres), restrict_to_halfspaces_invar_clw sctns X) \<in> ?R"
	including art
	by (rule nres_rel_trans2[OF restrict_to_halfspaces_invar_clw_ref[where a=a and I=I]])
	(autoref_monadic)

	concrete_definition restrict_to_halfspaces_invar_clw_impl for n sctnsi Xi uses restrict_to_halfspaces_invar_clw_impl
	lemma restrict_to_halfspaces_invar_clw_refine[autoref_rules]:
	"DIM_precond (TYPE('a::executable_euclidean_space)) n \<Longrightarrow>
	(\<lambda>sctnsi Xi. nres_of (restrict_to_halfspaces_invar_clw_impl n sctnsi Xi), restrict_to_halfspaces_invar_clw::'a sctn set \<Rightarrow> _) \<in>
	sctns_rel \<rightarrow> clw_rel (\<langle>I, lvivl_rel\<rangle>invar_rel a) \<rightarrow> \<langle>clw_rel (\<langle>I, lvivl_rel\<rangle>invar_rel a)\<rangle>nres_rel"
	using restrict_to_halfspaces_invar_clw_impl.refine[of n _ _ a I] by force

	abbreviation "below_invar_rel \<equiv> \<lambda>A. \<langle>\<langle>lv_rel\<rangle>sctn_rel, A\<rangle>invar_rel below_halfspace"
	abbreviation "sbelow_invar_rel \<equiv> \<lambda>A. \<langle>\<langle>lv_rel\<rangle>sctn_rel, A\<rangle>invar_rel sbelow_halfspace"
	abbreviation "plane_invar_rel \<equiv> \<lambda>A. \<langle>\<langle>lv_rel\<rangle>sctn_rel, A\<rangle>invar_rel plane_of"
	abbreviation "belows_invar_rel \<equiv> \<lambda>A. \<langle>sctns_rel, A\<rangle>invar_rel below_halfspaces"
	abbreviation "sbelows_invar_rel \<equiv> \<lambda>A. \<langle>sctns_rel, A\<rangle>invar_rel sbelow_halfspaces"

	definition [simp]: "with_invar_on_invar = with_invar"
	lemma with_invar_on_invar_impl[autoref_rules]:
	assumes "PREFER single_valued S"
	assumes "PREFER single_valued A"
	assumes "(sctni, sctn) \<in> S"
	assumes "GEN_OP uni (\<union>) (S \<rightarrow> S \<rightarrow> S)"
	assumes "(Xi, X) \<in> clw_rel (\<langle>S, A\<rangle>invar_rel a)"
	assumes "SIDE_PRECOND (X \<subseteq> a sctn)"
	assumes a_distrib: "SIDE_PRECOND (\<forall>x y. a (x \<union> y) = a x \<inter> a y)"
	shows "(map (\<lambda>(x, y). (x, uni sctni y)) Xi, with_invar_on_invar $ sctn $ X) \<in> clw_rel (\<langle>S, A\<rangle>invar_rel a)"
	using assms(1-6) a_distrib[unfolded autoref_tag_defs, rule_format]
	apply (auto simp: invar_rel_br intro!: map_mem_clw_rel_br elim!: single_valued_as_brE)
	apply (auto simp: lw_rel_def Union_rel_br)
	apply (auto simp: br_def)
	apply (metis (no_types, lifting) case_prod_conv)
	apply (drule_tac x=sctni and x' = sctn in fun_relD, force)
	apply (drule_tac x=b and x' = "\<alpha> b" in fun_relD, force)
	apply force
	apply (drule_tac x=sctni and x' = sctn in fun_relD, force)
	apply (drule_tac x=b and x' = "\<alpha> b" in fun_relD, force)
	apply safe
	proof -
	fix \<alpha> :: "'a \<Rightarrow> 'b set" and invar :: "'a \<Rightarrow> bool" and \<alpha>' :: "'c \<Rightarrow> 'd set" and invara :: "'c \<Rightarrow> bool" and aa :: 'c and b :: 'a and x :: 'd
	assume a1: "x \<in> \<alpha>' aa"
	assume a2: "(aa, b) \<in> set Xi"
	assume a3: "(\<Union>x\<in>set Xi. case x of (x, s) \<Rightarrow> \<alpha>' x) \<subseteq> a (\<alpha> sctni)"
	assume a4: "\<forall>x\<in>set Xi. case x of (x, s) \<Rightarrow> invara x \<and> invar s \<and> \<alpha>' x \<subseteq> a (\<alpha> s)"
	assume a5: "\<And>x y. a (x \<union> y) = a x \<inter> a y"
	assume a6: "\<alpha> sctni \<union> \<alpha> b = \<alpha> (uni sctni b)"
	have f7: "invara aa \<and> invar b \<and> \<alpha>' aa \<subseteq> a (\<alpha> b)"
	using a4 a2 by fastforce
	have "x \<in> a (\<alpha> sctni)"
	using a3 a2 a1 by blast
	then show "x \<in> a (\<alpha> (uni sctni b))"
	using f7 a6 a5 a1 by (metis (full_types) Int_iff subsetCE)
	qed

	lemma
	set_of_ivl_union:
	fixes i1 i2 s1 s2::"'a::executable_euclidean_space"
	shows "set_of_ivl (i1, s1) \<union> set_of_ivl (i2, s2) \<subseteq> set_of_ivl (inf i1 i2, sup s1 s2)"
	by (auto simp: set_of_ivl_def)

	lemma fold_set_of_ivl:
	fixes i s::"'a::executable_euclidean_space"
	assumes "\<And>i s. (i, s) \<in> set xs \<Longrightarrow> i \<le> s"
	assumes "i \<le> s"
	shows "\<Union> (set_of_ivl ` insert (i, s) (set xs)) \<subseteq>
	set_of_ivl (fold (\<lambda>(i1, s1) (i2, s2). (inf i1 i2, sup s1 s2)) xs (i, s))"
	using assms
	proof (induction xs arbitrary: i s)
	case (Cons x xs i s)
	then show ?case
	apply (auto simp: set_of_ivl_def
	simp: split_beta' le_infI2 le_supI2 le_infI1 le_supI1)
	apply (metis (no_types, lifting) inf.absorb_iff2 inf_sup_ord(2) le_infE le_supI2)
	apply (metis (no_types, lifting) inf.absorb_iff2 inf_sup_ord(2) le_infE le_supI2)
	apply (metis (no_types, lifting) inf.absorb_iff2 inf_sup_ord(2) le_infE le_supI2)
	by (metis (no_types, lifting) inf_sup_absorb le_infI2 le_supI2)
	qed simp

	lemma fold_infsup_le:
	fixes i s::"'a::executable_euclidean_space"
	assumes "\<And>i s. (i, s) \<in> set xs \<Longrightarrow> i \<le> s"
	assumes "i \<le> s"
	shows "case (fold (\<lambda>(i1, s1) (i2, s2). (inf i1 i2, sup s1 s2)) xs (i, s)) of (i, s) \<Rightarrow> i \<le> s"
	using assms
	proof (induction xs arbitrary: i s)
	case (Cons x xs i s)
	then show ?case
	by (auto simp: set_of_ivl_def
	simp: split_beta' le_infI2 le_supI2 le_infI1 le_supI1)
	qed simp

	definition "max_coord M (x::'a::executable_euclidean_space) =
	snd (fold (\<lambda>a (b, c). let d = abs x \<bullet> a in if d \<ge> b then (d, a) else (b, c)) (take M Basis_list) (0, 0))"

	schematic_goal max_coord_autoref:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) n"
	assumes [autoref_rules]: "(Xi, X::'a) \<in> lv_rel"
	assumes [autoref_rules]: "(Mi, M) \<in> nat_rel"
	shows "(?r, max_coord M X) \<in> lv_rel"
	unfolding max_coord_def
	by autoref
	concrete_definition max_coord_lv_rel for n Mi Xi uses max_coord_autoref
	lemma max_coord_lv_rel_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) n \<Longrightarrow> (\<lambda>Mi Xi. max_coord_lv_rel n Mi Xi, max_coord::nat\<Rightarrow>'a\<Rightarrow>_) \<in> nat_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	using max_coord_lv_rel.refine by force

	definition "split_ivl_at_halfspace sctn1 x =
	do {
	(i, s) \<leftarrow> ivl_rep x;
	let sctn2 = Sctn (- normal sctn1) (- pstn sctn1);
	x1 \<leftarrow> restrict_to_halfspace sctn1 x;
	x2 \<leftarrow> restrict_to_halfspace sctn2 x;
	RETURN (x1, x2)
	}"

	lemma split_ivl_at_halfspace[THEN order_trans, refine_vcg]:
	"split_ivl_at_halfspace sctn x \<le> split_spec_exact x"
	unfolding split_ivl_at_halfspace_def split_spec_exact_def
	by refine_vcg (auto simp: halfspace_simps)

	schematic_goal split_ivl_at_halfspace_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) n"
	assumes [autoref_rules]: "(Xi, X) \<in> lvivl_rel"
	assumes [autoref_rules]: "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(nres_of ?X, split_ivl_at_halfspace sctn (X::'a set)) \<in> \<langle>lvivl_rel \<times>\<^sub>r lvivl_rel\<rangle>nres_rel"
	unfolding split_ivl_at_halfspace_def
	by (autoref_monadic)
	concrete_definition split_ivl_at_halfspace_impl for n sctni Xi uses split_ivl_at_halfspace_impl
	lemma split_ivl_at_halfspace_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) n \<Longrightarrow>
	(\<lambda>sctni Xi. nres_of (split_ivl_at_halfspace_impl n sctni Xi), split_ivl_at_halfspace::_ \<Rightarrow> 'a set \<Rightarrow> _) \<in>
	\<langle>lv_rel\<rangle>sctn_rel \<rightarrow> lvivl_rel \<rightarrow> \<langle>lvivl_rel \<times>\<^sub>r lvivl_rel\<rangle>nres_rel"
	using split_ivl_at_halfspace_impl.refine
	by force

	definition "split_spec_ivl M x =
	do {
	(i, s) \<leftarrow> ivl_rep x;
	let d = s - i;
	let b = max_coord M d;
	let m = (i \<bullet> b + s \<bullet> b)/2;
	split_ivl_at_halfspace (Sctn b m) x
	}"

	lemma split_spec_ivl_split_spec_exact[THEN order_trans, refine_vcg]:
	"split_spec_ivl M x \<le> split_spec_exact x"
	unfolding split_spec_ivl_def split_spec_exact_def
	by refine_vcg

	schematic_goal split_spec_exact_ivl_rel:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) n"
	assumes [autoref_rules]: "(Xi, X) \<in> lvivl_rel"
	assumes [autoref_rules]: "(Mi, M) \<in> nat_rel"
	shows "(nres_of ?X, split_spec_ivl M (X::'a set)) \<in> \<langle>lvivl_rel \<times>\<^sub>r lvivl_rel\<rangle>nres_rel"
	unfolding split_spec_ivl_def
	by (autoref_monadic)
	concrete_definition split_spec_exact_ivl_rel for n Mi Xi uses split_spec_exact_ivl_rel
	lemma split_spec_exact_ivl_rel_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) n \<Longrightarrow>
	(\<lambda>Mi Xi. nres_of (split_spec_exact_ivl_rel n Mi Xi), split_spec_ivl::nat \<Rightarrow> 'a set \<Rightarrow> _) \<in>
	nat_rel \<rightarrow> lvivl_rel \<rightarrow> \<langle>lvivl_rel \<times>\<^sub>r lvivl_rel\<rangle>nres_rel"
	using split_spec_exact_ivl_rel.refine
	by force

	lemma [autoref_itype]: "op_set_isEmpty ::\<^sub>i \<langle>L, \<langle>A\<rangle>\<^sub>ii_ivl\<rangle>\<^sub>ii_coll \<rightarrow>\<^sub>i i_bool"
	by simp

	lemma op_set_isEmpty_clw_rel_ivl_rel[autoref_rules]:
	assumes sv[THEN PREFER_sv_D, relator_props]: "PREFER single_valued A"
	assumes le[THEN GEN_OP_D, param_fo]: "GEN_OP le (\<le>) (A \<rightarrow> A \<rightarrow> bool_rel)"
	shows "(\<lambda>xs. filter_empty_ivls_impl le xs = [], op_set_isEmpty) \<in> clw_rel (\<langle>A\<rangle>ivl_rel) \<rightarrow> bool_rel"
	apply (rule fun_relI)
	subgoal premises prems for a b
	using filter_empty_ivls[OF assms prems] sv
	apply (auto simp: list_wset_rel_def ivl_rel_br Union_rel_br filter_empty_ivls_impl_def filter_empty_conv
	set_of_ivl_def split_beta' Id_arbitrary_interface_def
	dest!: brD elim!: single_valued_as_brE)
	subgoal for \<alpha> I x y
	using le[of x "\<alpha> x" y "\<alpha> y"]
	apply (auto simp: br_def)
	done
	done
	done

	lemma project_sets_FOREACH_refine:
	"do {
	Xs \<leftarrow> (sets_of_coll X ::: \<langle>\<langle>A\<rangle>list_wset_rel\<rangle>nres_rel);
	FORWEAK Xs (RETURN {}) (\<lambda>X. do { ivl \<leftarrow> project_set X b y; RETURN (mk_coll ivl)}) (\<lambda>a b. RETURN (a \<union> b))
	} \<le> project_sets X b y"
	unfolding project_sets_def autoref_tag_defs
	by (refine_vcg FORWEAK_mono_rule'[where I="\<lambda>S s. \<Union>S \<inter> {x. x \<bullet> b = y} \<subseteq> s \<and> s \<subseteq> {x. x \<bullet> b = y}"])
	auto


	definition split_intersecting
	where [refine_vcg_def]: "split_intersecting X Y = SPEC (\<lambda>(R, S). X = R \<union> S \<and> X \<inter> Y \<subseteq> R \<and> S \<inter> Y = {})"

	definition intersecting_sets where
	"intersecting_sets X Z = do {
	ZS \<leftarrow> sets_of_coll (Z);
	XS \<leftarrow> sets_of_coll (X);
	FORWEAK XS (RETURN (op_empty_coll, op_empty_coll)) (\<lambda>X. do {
	d \<leftarrow> FORWEAK ZS (RETURN True) (disjoint_sets X) (\<lambda>a b. RETURN (a \<and> b));
	RETURN (if d then (op_empty_coll, mk_coll X) else (mk_coll X, op_empty_coll))
	}) (\<lambda>(R, S). \<lambda>(R', S'). RETURN (R' \<union> R, S' \<union> S))
	}"

	lemma intersecting_sets_spec:
	shows "intersecting_sets X Y \<le> split_intersecting X Y"
	unfolding intersecting_sets_def split_intersecting_def
	autoref_tag_defs
	apply (refine_vcg)
	apply (rule FORWEAK_mono_rule[where I="\<lambda>XS. \<lambda>(R, S).
	R \<union> S \<subseteq> X \<and> \<Union>XS \<subseteq> R \<union> S \<and> \<Union>XS \<inter> Y \<subseteq> R \<and> S \<inter> Y = {}"])
	subgoal by (refine_vcg)
	subgoal for a b c
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>ZS d. d \<longrightarrow> \<Union>ZS \<inter> c = {}"]) (auto split: if_splits)
	subgoal by (auto; blast)
	subgoal for a b c d e
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>ZS d. d \<longrightarrow> \<Union>ZS \<inter> c = {}"]) (auto split: if_splits)
	subgoal by auto
	done

	schematic_goal split_intersecting_impl:
	fixes A::"(_ \<times> 'a::executable_euclidean_space set) set"
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a)) n"
	assumes [autoref_rules]: "(Xi,X::'a set)\<in>clw_rel lvivl_rel"
	assumes [autoref_rules]: "(Zi,Z)\<in>clw_rel lvivl_rel"
	shows "(nres_of ?f, split_intersecting $ X $ Z)\<in>\<langle>clw_rel lvivl_rel \<times>\<^sub>r clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	apply (rule nres_rel_trans2[OF intersecting_sets_spec])
	unfolding intersecting_sets_def
	by autoref_monadic

	concrete_definition split_intersecting_impl for Xi Zi uses split_intersecting_impl
	lemmas [autoref_rules] = split_intersecting_impl.refine

	definition inter_overappr where [refine_vcg_def]: "inter_overappr X Y = SPEC (\<lambda>R. X \<inter> Y \<subseteq> R \<and> R \<subseteq> X)"

	lemma inter_overappr_impl: "do {(X, _) \<leftarrow> split_intersecting X Y; RETURN X} \<le> inter_overappr X Y"
	unfolding split_intersecting_def inter_overappr_def autoref_tag_defs
	by (refine_vcg) auto

	schematic_goal inter_overappr_autoref:
	assumes [autoref_rules_raw]: "DIM_precond (TYPE('a::executable_euclidean_space)) n"
	assumes [autoref_rules]: "(Xi,X)\<in>clw_rel lvivl_rel"
	assumes [autoref_rules]: "(Zi,Z)\<in>clw_rel lvivl_rel"
	shows "(nres_of ?f, inter_overappr X Z::'a set nres)\<in>\<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	by (rule nres_rel_trans2[OF inter_overappr_impl]) (autoref_monadic)
	concrete_definition inter_overappr_impl for Xi Zi uses inter_overappr_autoref
	lemmas [autoref_rules] = inter_overappr_impl.refine[autoref_higher_order_rule(1)]

	definition "sctnbounds_of_ivl M X = do {
	(l, u) \<leftarrow> ivl_rep X;
	let ls = (\<lambda>b. Sctn (- b) (- l \<bullet> b)) ` (set (take M Basis_list)::'a::executable_euclidean_space set);
	let us = (\<lambda>b. Sctn (b) (u \<bullet> b)) ` (set (take M Basis_list)::'a set);
	RETURN (ls \<union> us)
	}"

	lemma sctnbounds_of_ivl[THEN order_trans, refine_vcg]:
	"sctnbounds_of_ivl M X \<le> SPEC (\<lambda>sctns. finite sctns \<and> (\<forall>sctn \<in> sctns. normal sctn \<noteq> 0))"
	unfolding sctnbounds_of_ivl_def
	by refine_vcg (auto dest!: in_set_takeD)

	schematic_goal sctnbounds_of_ivl_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> lvivl_rel" "(Mi, M) \<in> nat_rel"
	shows "(?f, sctnbounds_of_ivl $ M $ X) \<in> \<langle>sctns_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding sctnbounds_of_ivl_def
	by autoref_monadic
	concrete_definition sctnbounds_of_ivl_impl for Mi Xi uses sctnbounds_of_ivl_impl
	lemma sctnbounds_of_ivl_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) D \<Longrightarrow>
	(\<lambda>Mi Xi. RETURN (sctnbounds_of_ivl_impl D Mi Xi), sctnbounds_of_ivl::nat \<Rightarrow> 'a set \<Rightarrow> _)
	\<in> nat_rel \<rightarrow> \<langle>lv_rel\<rangle>ivl_rel \<rightarrow> \<langle>sctns_rel\<rangle>nres_rel"
	using sctnbounds_of_ivl_impl.refine by force

	lemma SPEC_True_mono: "b \<le> c \<Longrightarrow> SPEC (\<lambda>_. True) \<bind> (\<lambda>_. b) \<le> c"
	by (auto simp: bind_le_nofailI)

	definition "split_ivls_at_halfspace sctn XS = do {
	XS \<leftarrow> sets_of_coll XS;
	FORWEAK XS (RETURN op_empty_coll) (\<lambda>X. do {
	(A, B) \<leftarrow> split_ivl_at_halfspace sctn X;
	RETURN (filter_empty_ivls (mk_coll A \<union> mk_coll B))
	}) (\<lambda>X X'. RETURN (X' \<union> X))
	}"

	lemma split_ivls_at_halfspace[THEN order_trans, refine_vcg]:
	"split_ivls_at_halfspace sctn X \<le> SPEC (\<lambda>R. R = X)"
	unfolding split_ivls_at_halfspace_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>Xi XS. \<Union>Xi \<subseteq> XS \<and> XS \<subseteq> X"]) auto

	schematic_goal split_ivls_at_halfspace_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> clw_rel lvivl_rel" "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
	shows "(?f, split_ivls_at_halfspace $ sctn $ X) \<in> \<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_ivls_at_halfspace_def
	by autoref_monadic
	concrete_definition split_ivls_at_halfspace_impl for sctni Xi uses split_ivls_at_halfspace_impl
	lemma split_ivls_at_halfspace_impl_refine[autoref_rules]:
	"DIM_precond TYPE('a::executable_euclidean_space) D \<Longrightarrow>
	(\<lambda>Xi sctni. nres_of (split_ivls_at_halfspace_impl D Xi sctni), split_ivls_at_halfspace::'a sctn \<Rightarrow> _)
	\<in> \<langle>lv_rel\<rangle>sctn_rel \<rightarrow> clw_rel (\<langle>lv_rel\<rangle>ivl_rel) \<rightarrow> \<langle>clw_rel (\<langle>lv_rel\<rangle>ivl_rel)\<rangle>nres_rel"
	using split_ivls_at_halfspace_impl.refine
	by force

	definition "split_along_ivls M X IS = do {
	IS \<leftarrow> sets_of_coll IS;
	sctns \<leftarrow> FORWEAK IS (RETURN {}) (sctnbounds_of_ivl M) (\<lambda>sctns sctns'. RETURN (sctns' \<union> sctns));
	FOREACH\<^bsup>\<lambda>_ R. R = X\<^esup> sctns split_ivls_at_halfspace X
	}"

	lemma split_along_ivls[THEN order_trans, refine_vcg]:"split_along_ivls M X IS \<le> SPEC (\<lambda>R. R = X)"
	unfolding split_along_ivls_def
	by (refine_vcg FORWEAK_mono_rule[where I="\<lambda>_ r. finite r"])

	schematic_goal split_along_ivls_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(Xi, X::'a set) \<in> clw_rel lvivl_rel" "(ISi, IS) \<in> clw_rel lvivl_rel"
	"(Mi, M) \<in> nat_rel"
	shows "(?f, split_along_ivls $ M $ X $ IS) \<in> \<langle>clw_rel lvivl_rel\<rangle>nres_rel"
	unfolding autoref_tag_defs
	unfolding split_along_ivls_def
	by autoref_monadic
	concrete_definition split_along_ivls_impl uses split_along_ivls_impl
	lemmas [autoref_rules] = split_along_ivls_impl.refine

	definition "op_ivl_rep_of_set X =
	do { let X = (X); i \<leftarrow> Inf_spec X; s \<leftarrow> Sup_spec X; RETURN (inf i s, s)}"

	definition "op_ivl_rep_of_sets XS =
	FORWEAK XS (RETURN (0, 0)) op_ivl_rep_of_set (\<lambda>(i, s) (i', s').
	RETURN (inf i i':::lv_rel, sup s s':::lv_rel))"

	definition "op_ivl_of_ivl_coll XS =
	do {XS \<leftarrow> sets_of_coll XS;
	(l, u) \<leftarrow> FORWEAK XS (RETURN (0, 0)) ivl_rep (\<lambda>(i, s) (i', s').
	RETURN (inf i i':::lv_rel, sup s s':::lv_rel));
	RETURN (op_atLeastAtMost_ivl l u)
	}"

	schematic_goal op_ivl_of_ivl_coll_impl:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	assumes [autoref_rules]: "(ISi, IS::'a::executable_euclidean_space set) \<in> clw_rel lvivl_rel"
	shows "(?f, op_ivl_of_ivl_coll IS) \<in> \<langle>lvivl_rel\<rangle>nres_rel"
	unfolding op_ivl_of_ivl_coll_def
	by autoref_monadic
	concrete_definition op_ivl_of_ivl_coll_impl uses op_ivl_of_ivl_coll_impl
	lemmas op_ivl_of_ivl_coll_impl_refine[autoref_rules] =
	op_ivl_of_ivl_coll_impl.refine[autoref_higher_order_rule (1)]

	lemma is_empty_lvivl_rel[autoref_rules]:
	shows "(\<lambda>(a, b). \<not> list_all2 (\<le>) a b, is_empty) \<in> lvivl_rel \<rightarrow> bool_rel"
	using le_left_mono
	by (fastforce simp: ivl_rel_def br_def set_of_ivl_def dest: lv_rel_le[param_fo])

	definition [simp]: "op_times_ivl a b = a \<times> b"

	lemma [autoref_op_pat]: "a \<times> b \<equiv> OP op_times_ivl $ a $ b"
	- by (auto simp: )
	+ by auto

	lemma op_times_ivl[autoref_rules]:
	"(\<lambda>(l, u) (l', u'). (l @ l', u @ u'), op_times_ivl) \<in> lvivl_rel \<rightarrow> lvivl_rel \<rightarrow> lvivl_rel"
	apply (auto simp: ivl_rel_def br_def intro!: rel_funI)
	subgoal for a b c d e f g h
	apply (rule relcompI[where b="((c, g), (d, h))"])
	by (auto simp: lv_rel_def br_def set_of_ivl_def)
	done

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Refine_Parallel.thy b/thys/Ordinary_Differential_Equations/Refinement/Refine_Parallel.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Refine_Parallel.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Refine_Parallel.thy
	@@ -1,85 +1,85 @@
	theory
	Refine_Parallel
	imports
	"HOL-Library.Parallel"
	Ordinary_Differential_Equations.ODE_Auxiliarities
	"../Refinement/Autoref_Misc"
	"../Refinement/Weak_Set"
	begin

	context includes autoref_syntax begin

	lemma dres_of_dress_impl:
	"nres_of (rec_list (dRETURN []) (\<lambda>x xs r. do { fx \<leftarrow> x; r \<leftarrow> r; dRETURN (fx # r)}) (Parallel.map f x)) \<le>
	nres_of_nress_impl (Parallel.map f' x)"
	if [refine_transfer]: "\<And>x. nres_of (f x) \<le> f' x"
	unfolding Parallel.map_def nres_of_nress_impl_map
	apply (induction x)
	- apply (auto simp: )
	+ apply auto
	apply refine_transfer
	done
	concrete_definition dres_of_dress_impl uses dres_of_dress_impl
	lemmas [refine_transfer] = dres_of_dress_impl.refine

	definition PAR_IMAGE::"('a \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'c nres) \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'c) set nres" where
	"PAR_IMAGE P f X = do {
	xs \<leftarrow> list_spec X;
	fxs \<leftarrow>nres_of_nress (\<lambda>(x, y). P x y) (Parallel.map (\<lambda>x. do { y \<leftarrow> f x; RETURN (x, y)}) xs);
	RETURN (set fxs)
	}"

	lemma [autoref_op_pat_def]: "PAR_IMAGE P \<equiv> OP (PAR_IMAGE P)" by auto
	lemma [autoref_rules]: "(Parallel.map, Parallel.map) \<in> (A \<rightarrow> B) \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>B\<rangle>list_rel"
	unfolding Parallel.map_def
	by parametricity
	schematic_goal PAR_IMAGE_nres:
	"(?r, PAR_IMAGE P $ f $ X) \<in> \<langle>\<langle>A\<times>\<^sub>rB\<rangle>list_wset_rel\<rangle>nres_rel"
	if [autoref_rules]: "(fi, f) \<in> A \<rightarrow> \<langle>B\<rangle>nres_rel" "(Xi, X) \<in> \<langle>A\<rangle>list_wset_rel"
	and [THEN PREFER_sv_D, relator_props]:
	"PREFER single_valued A" "PREFER single_valued B"
	unfolding PAR_IMAGE_def
	including art
	by autoref
	concrete_definition PAR_IMAGE_nres uses PAR_IMAGE_nres
	lemma PAR_IMAGE_nres_impl_refine[autoref_rules]:
	"PREFER single_valued A \<Longrightarrow>
	PREFER single_valued B \<Longrightarrow>
	(\<lambda>fi Xi. PAR_IMAGE_nres fi Xi, PAR_IMAGE P)
	\<in> (A \<rightarrow> \<langle>B\<rangle>nres_rel) \<rightarrow> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>\<langle>A\<times>\<^sub>rB\<rangle>list_wset_rel\<rangle>nres_rel"
	using PAR_IMAGE_nres.refine by force
	schematic_goal PAR_IMAGE_dres:
	assumes [refine_transfer]: "\<And>x. nres_of (f x) \<le> f' x"
	shows "nres_of (?f) \<le> PAR_IMAGE_nres f' X'"
	unfolding PAR_IMAGE_nres_def
	by refine_transfer
	concrete_definition PAR_IMAGE_dres for f X' uses PAR_IMAGE_dres
	lemmas [refine_transfer] = PAR_IMAGE_dres.refine

	lemma nres_of_nress_Parallel_map_SPEC[le, refine_vcg]:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> f x \<le> SPEC (I x)"
	shows
	"nres_of_nress (\<lambda>(x, y). I x y) (Parallel.map (\<lambda>x. f x \<bind> (\<lambda>y. RETURN (x, y))) xs) \<le>
	SPEC (\<lambda>xrs. map fst xrs = xs \<and> (\<forall>(x, r) \<in> set xrs. I x r))"
	using assms
	apply (induction xs)
	- subgoal by (simp add: )
	+ subgoal by simp
	apply clarsimp
	apply (rule refine_vcg)
	subgoal for x xs
	apply (rule order_trans[of _ "SPEC (I x)"]) apply force
	apply (rule refine_vcg)
	apply (rule refine_vcg)
	apply (rule order_trans, assumption)
	apply refine_vcg
	done
	done

	lemma PAR_IMAGE_SPEC[le, refine_vcg]:
	"PAR_IMAGE I f X \<le> SPEC (\<lambda>R. X = fst ` R \<and> (\<forall>(x,r) \<in> R. I x r))"
	if [le, refine_vcg]: "\<And>x. x \<in> X \<Longrightarrow> f x \<le> SPEC (I x)"
	unfolding PAR_IMAGE_def
	by refine_vcg

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Refine_Vector_List.thy b/thys/Ordinary_Differential_Equations/Refinement/Refine_Vector_List.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Refine_Vector_List.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Refine_Vector_List.thy
	@@ -1,351 +1,351 @@
	theory Refine_Vector_List
	imports
	Ordinary_Differential_Equations.ODE_Auxiliarities
	"../Refinement/Autoref_Misc" (* TODO: what is still needed there? *)
	"../Refinement/Weak_Set"
	"Enclosure_Operations"
	begin

	subsection \<open>Id on euclidean space, real etc\<close>

	consts i_rnv::interface
	abbreviation "rnv_rel \<equiv> (Id::('a::real_normed_vector\<times>_) set)"
	lemmas [autoref_rel_intf] = REL_INTFI[of rnv_rel i_rnv]

	context includes autoref_syntax begin

	lemma [autoref_rules]:
	"((=), (=)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
	"((\<le>), (\<le>)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
	"((<), (<)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> bool_rel"
	"(min, min) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"(max, max) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((+), (+)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((-), (-)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((/), (/)) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((), ()) \<in> rnv_rel \<rightarrow> rnv_rel \<rightarrow> rnv_rel"
	"((^), (^)) \<in> rnv_rel \<rightarrow> nat_rel \<rightarrow> rnv_rel"
	"(int, int) \<in> nat_rel \<rightarrow> int_rel"
	"(Float, Float) \<in> int_rel \<rightarrow> int_rel \<rightarrow> Id"
	"(real_of_float, real_of_float) \<in> Id \<rightarrow> rnv_rel"
	"(upto, upto) \<in> int_rel \<rightarrow> int_rel \<rightarrow> \<langle>int_rel\<rangle>list_rel"
	"(upt, upt) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel"
	"(product_lists, product_lists) \<in> \<langle>\<langle>int_rel\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>\<langle>int_rel\<rangle>list_rel\<rangle>list_rel"
	"(floor, floor) \<in> rnv_rel \<rightarrow> int_rel"
	by auto
	end

	subsection \<open>list vector relation\<close>

	definition lv_rel::"(real list \<times> 'a::executable_euclidean_space) set"
	where "lv_rel = br eucl_of_list (\<lambda>xs. length xs = DIM('a))"

	lemmas [autoref_rel_intf] = REL_INTFI[of lv_rel i_rnv]

	lemma lv_rel_sv[relator_props]: "single_valued lv_rel"
	by (auto simp: lv_rel_def)

	context includes autoref_syntax begin

	lemma lv_rel_le[autoref_rules]: "(list_all2 (\<lambda>x y. x \<le> y), (\<le>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
	by (auto simp: lv_rel_def br_def eucl_le[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id)
	(metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

	lemma lv_rel_inf[autoref_rules]: "(List.map2 min, inf) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_inf[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id inf_real_def
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_sup[autoref_rules]: "(List.map2 max, sup) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_add[autoref_rules]: "(List.map2 (+), (+)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def algebra_simps
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_minus[autoref_rules]: "(List.map2 (-), (-)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def algebra_simps
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_scaleR[autoref_rules]: "(\<lambda>r. map (scaleR r), scaleR) \<in> rnv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_uminus[autoref_rules]: "(map uminus, uminus) \<in> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_sup[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_abs[autoref_rules]: "(map abs, abs) \<in> lv_rel \<rightarrow> lv_rel"
	by (auto simp: lv_rel_def br_def eucl_abs[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id sup_real_def
	intro!: euclidean_eqI[where 'a='a])

	lemma lv_rel_inner[autoref_rules]: "(inner_lv_rel, (\<bullet>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel"
	by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
	(auto simp: lv_rel_def br_def eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)

	definition "mig_real a b = (if a \<le> 0 \<and> 0 \<le> b \<or> b \<le> 0 \<and> 0 \<le> a then 0 else min (abs a) (abs b))"
	definition "mig_componentwise a b = (\<Sum>i\<in>Basis. mig_real (a \<bullet> i) (b \<bullet> i) *\<^sub>R i)"
	definition "mig_lv a b = (List.map2 mig_real a b)"
	lemma length_mig_lv[simp]: "length (mig_lv a b) = min (length a) (length b)"
	by (auto simp: mig_lv_def)
	lemma mig_lv_nth: "mig_real (a ! i) (b ! i) = mig_lv a b ! i" if "i < length a" "i < length b"
	by (auto simp: mig_lv_def that)

	lemma mig_real_abs_le: "\<bar>mig_real a b\<bar> \<le> \<bar>x\<bar>" if "x \<in> {a .. b}" for x::real
	using that
	by (auto simp: mig_real_def abs_real_def)

	lemma norm_eucl_L2: "norm x = sqrt (\<Sum>i\<in>Basis. (x \<bullet> i)\<^sup>2)"
	unfolding norm_conv_dist by (subst euclidean_dist_l2) (simp add: L2_set_def)

	lemma mig_componentwise_inner_Basis: "mig_componentwise a b \<bullet> i = mig_real (a \<bullet> i) (b \<bullet> i)"
	if "i \<in> Basis"
	using that
	by (auto simp: mig_componentwise_def)

	lemma norm_mig_componentwise_le: "norm (mig_componentwise a b) \<le> norm x" if "x \<in> {a .. b}" for
	a::"'a::ordered_euclidean_space"
	apply (rule norm_le_in_cubeI)
	apply (simp add: mig_componentwise_inner_Basis)
	apply (rule mig_real_abs_le)
	using that
	by (auto simp: eucl_le[where 'a='a])

	lemma mig_componentwise_autoref[autoref_rules]:
	"(mig_lv, mig_componentwise) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	unfolding lv_rel_def
	by (auto simp: mig_componentwise_def euclidean_eq_iff[where 'a='a] eucl_of_list_inner mig_lv_nth
	br_def)

	primrec vecsumlist' where
	"vecsumlist' 0 xs = []"
	\| "vecsumlist' (Suc i) xs = sum_list (map hd xs)#vecsumlist' i (map tl xs)"

	lemma vecsumlist':
	assumes "\<And>xs. xs \<in> set xss \<Longrightarrow> i \<le> length xs"
	shows "vecsumlist' i xss = map (\<lambda>i. sum_list (map (\<lambda>xs. xs ! i) xss)) [0..<i]"
	using assms
	proof (induction i arbitrary: xss)
	case 0
	then show ?case by simp
	next
	case (Suc i)
	from Suc.prems have xss_ne: "x \<in> set xss \<Longrightarrow> x \<noteq> []" for x
	by force
	show ?case
	apply simp
	apply (subst Suc.IH)
	subgoal using Suc.prems by force
	apply (auto intro!: nth_equalityI)
	using xss_ne
	apply (auto simp: nth_Cons nth_append o_def split: nat.splits)
	apply (meson hd_conv_nth arg_cong[OF map_cong, where f = sum_list])
	apply (meson hd_conv_nth arg_cong[OF map_cong, where f = sum_list])
	apply (meson Misc.nth_tl arg_cong[OF map_cong, where f = sum_list])
	by (metis (no_types, lifting) Misc.nth_tl Suc_leI le_neq_implies_less map_cong)
	qed

	lemma inner_sum_list_left: "sum_list xs \<bullet> b = (\<Sum>x\<leftarrow>xs. x \<bullet> b)"
	by (auto simp: sum_list_sum_nth inner_sum_left)

	definition [simp]: "DIM_eq (TYPE('a::executable_euclidean_space)) n \<longleftrightarrow> DIM('a) = n"
	abbreviation "DIM_precond TYPE('a) n \<equiv> DIM_eq TYPE('a::executable_euclidean_space) n"

	lemma DIM_precond_times[autoref_rules_raw]:
	"DIM_precond TYPE('a::executable_euclidean_space\<times>'b::executable_euclidean_space) (D + E)"
	if "DIM_precond TYPE('a::executable_euclidean_space) D"
	"DIM_precond TYPE('b::executable_euclidean_space) E"
	- using that by (auto simp: )
	+ using that by auto

	lemma [autoref_rules]: "(sum_list, sum_list) \<in> \<langle>rnv_rel\<rangle>list_rel \<rightarrow> rnv_rel"
	by auto

	lemma lv_rel_sum_list[autoref_rules]:
	assumes "DIM_precond TYPE('a::executable_euclidean_space) n"
	shows "(vecsumlist' n, sum_list) \<in> \<langle>lv_rel::(real list \<times> 'a) set\<rangle>list_rel \<rightarrow> lv_rel"
	proof
	fix xss and XS::"'a list"
	assume xss: "(xss, XS) \<in> \<langle>lv_rel\<rangle>list_rel"
	then have "\<And>xs. xs \<in> set xss \<Longrightarrow> DIM('a) \<le> length xs"
	by (auto simp: lv_rel_def list_rel_def in_set_conv_nth br_def dest!: list_all2_nthD )
	from vecsumlist'[OF this, of xss] assms xss
	show "(vecsumlist' n xss, sum_list XS) \<in> lv_rel"
	apply (auto simp: lv_rel_def br_def)
	apply (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner inner_sum_list_left)
	apply (rule sum_list_nth_eqI)
	apply (auto simp: list_all2_iff list_rel_def in_set_zip Ball_def)
	apply (drule_tac x = "xss ! na" in spec)
	apply (drule_tac x = "XS ! na" in spec)
	apply (auto simp: eucl_of_list_inner)
	done
	qed

	lemma lv_rel_eq[autoref_rules]: "((=), (=)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
	by (auto simp: lv_rel_def br_def euclidean_eq_iff[where 'a='a] eucl_of_list_inner
	intro!: nth_equalityI)
	(metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

	lemma lv_rel_zero[autoref_rules]:
	assumes "DIM_precond TYPE('a::executable_euclidean_space) n"
	shows "(replicate n 0, 0::'a) \<in> lv_rel"
	using assms
	by (auto simp: lv_rel_def br_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])

	definition "Basis_list_impl n = (let zs = replicate n 0 in map (\<lambda>i. zs[i:=1]) [0..<n])"
	lemma lv_rel_Basis_list[autoref_rules]:
	assumes "DIM_precond (TYPE('a::executable_euclidean_space)) n"
	shows "(Basis_list_impl n, Basis_list::'a list) \<in> \<langle>lv_rel\<rangle>list_rel"
	using assms
	by (auto simp: list_rel_def lv_rel_def eucl_of_list_inner inner_Basis nth_eq_iff_index
	Basis_list_impl_def
	intro!: brI list_all2_all_nthI euclidean_eqI[where 'a='a])

	definition "lv_ivl xrs yrs = {zrs. list_all2 (\<le>) xrs zrs \<and> list_all2 (\<le>) zrs yrs}"

	lemma lv_relI:
	"length x = DIM('a) \<Longrightarrow> (x, eucl_of_list x::'a::executable_euclidean_space) \<in> lv_rel"
	by (auto simp: lv_rel_def br_def)

	lemma eucl_of_list_image_lv_ivl:
	assumes [simp]: "length xrs = DIM('a)" "length yrs = DIM('a)"
	shows "eucl_of_list ` (lv_ivl xrs yrs) =
	{eucl_of_list xrs .. eucl_of_list yrs::'a::executable_euclidean_space}"
	apply (auto simp: list_all2_iff lv_ivl_def eucl_le[where 'a='a] eucl_of_list_inner Ball_def
	in_set_zip)
	apply (metis Basis_list index_less_size_conv length_Basis_list)
	apply (metis Basis_list index_less_size_conv length_Basis_list)
	apply (rule image_eqI)
	apply (rule eucl_of_list_list_of_eucl[symmetric])
	using nth_Basis_list_in_Basis apply fastforce
	done

	end

	subsection \<open>Specs for Vectors\<close>

	context includes autoref_syntax begin

	lemma Inf_specs_Inf_spec:
	"(Inf_specs d, Inf_spec::_\<Rightarrow>'a::executable_euclidean_space nres) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
	if "d = DIM('a)"
	apply (auto intro!: nres_relI RES_refine simp: Inf_specs_def Inf_spec_def set_rel_def that)
	subgoal for x y s
	apply (rule exI[where x="eucl_of_list s"])
	apply (auto simp: lv_rel_def br_def subset_iff)
	apply (drule bspec, assumption)
	apply auto
	apply (drule bspec, assumption)
	apply auto
	apply (drule bspec, assumption)
	subgoal for c
	using lv_rel_le[where 'a ='a, param_fo, OF lv_relI lv_relI, of s c]
	by auto
	done
	done

	lemma Sup_specs_Sup_spec:
	"(Sup_specs d, Sup_spec::_\<Rightarrow>'a::executable_euclidean_space nres) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>lv_rel\<rangle>nres_rel"
	if "d = DIM('a)"
	apply (auto intro!: nres_relI RES_refine simp: Sup_specs_def Sup_spec_def set_rel_def that)
	subgoal for x y s
	apply (rule exI[where x="eucl_of_list s"])
	apply (auto simp: lv_rel_def br_def subset_iff)
	apply (drule bspec, assumption)
	apply auto
	apply (drule bspec, assumption)
	apply auto
	apply (drule bspec, assumption)
	subgoal for c
	using lv_rel_le[where 'a ='a, param_fo, OF lv_relI lv_relI, of c s]
	by auto
	done
	done

	lemma Sup_inners_Sup_inner: "(Sup_inners, Sup_inner) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	unfolding set_rel_sv[OF lv_rel_sv]
	apply (auto intro!: nres_relI RES_refine
	simp: Sup_inners_def Sup_inner_def plane_ofs_def plane_of_def lv_rel_def br_def)
	subgoal for a b c d
	using lv_rel_inner[where 'a = 'a, param_fo, OF lv_relI lv_relI, of d b]
	by auto
	done

	lemma Inf_inners_Inf_inner: "(Inf_inners, Inf_inner) \<in> \<langle>lv_rel\<rangle>set_rel \<rightarrow> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
	unfolding set_rel_sv[OF lv_rel_sv]
	apply (auto intro!: nres_relI RES_refine
	simp: Inf_inners_def Inf_inner_def plane_ofs_def plane_of_def lv_rel_def br_def)
	subgoal for a b c d
	using lv_rel_inner[where 'a = 'a, param_fo, OF lv_relI lv_relI, of d b]
	by auto
	done

	lemma split_spec_params_split_spec_param:
	"(split_spec_params d, split_spec_param::nat\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_) \<in> nat_rel \<rightarrow> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>set_rel\<times>\<^sub>r\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
	if "d = DIM('a::executable_euclidean_space)"
	apply (auto intro!: nres_relI RES_refine simp: split_spec_param_def split_spec_params_def env_len_def that)
	unfolding set_rel_sv[OF lv_rel_sv]
	apply (auto intro!: nres_relI RES_refine simp: plane_ofs_def plane_of_def lv_rel_def br_def subset_iff)
	done

	lemma reduce_specs_reduce_spec:
	"(reduce_specs d, reduce_spec::_\<Rightarrow>'a::executable_euclidean_space set\<Rightarrow>_) \<in> Id \<rightarrow> \<langle>lv_rel\<rangle>set_rel \<rightarrow> \<langle>\<langle>lv_rel\<rangle>set_rel\<rangle>nres_rel"
	if "d = DIM('a::executable_euclidean_space)"
	apply (auto intro!: nres_relI RES_refine simp: reduce_spec_def reduce_specs_def env_len_def that)
	unfolding set_rel_sv[OF lv_rel_sv]
	apply (auto intro!: nres_relI RES_refine simp: plane_ofs_def plane_of_def lv_rel_def br_def subset_iff)
	done

	definition [simp]: "rnv_of_lv x = x"

	lemma rnv_of_lv_impl[autoref_rules]: "(hd, rnv_of_lv) \<in> lv_rel \<rightarrow> rnv_rel"
	by (auto simp: lv_rel_def br_def length_Suc_conv)

	lemma
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	shows snd_lv_rel[autoref_rules(overloaded)]: "(drop D, snd::('a \<times> _) \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel"
	and fst_lv_rel[autoref_rules(overloaded)]: "(take D, fst::('a \<times> _) \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel"
	using assms by (auto simp: lv_rel_def br_def eucl_of_list_prod)

	definition [simp]: "Pair_lv_rel = Pair"

	lemma Pair_lv_rel[autoref_rules]:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	shows "((@), Pair_lv_rel::'a \<Rightarrow> _) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_rel"
	using assms
	by (auto simp: lv_rel_def br_def intro!: eucl_of_list_eqI)

	definition [simp]: "split_lv_rel X = (fst X, snd X)"

	schematic_goal split_lv_rel_impl[autoref_rules]:
	assumes [autoref_rules_raw]: "DIM_precond TYPE('a::executable_euclidean_space) D"
	shows "(?r, split_lv_rel::'a\<times>_\<Rightarrow>_) \<in> lv_rel \<rightarrow> lv_rel \<times>\<^sub>r lv_rel"
	unfolding split_lv_rel_def
	by autoref

	lemma lv_rel_less[autoref_rules]: "(list_all2 (\<lambda>x y. x < y), eucl_less) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> bool_rel"
	by (auto simp: lv_rel_def br_def eucl_less_def[where 'a='a] eucl_of_list_inner list_all2_conv_all_nth
	index_nth_id)
	(metis distinct_Basis_list index_nth_id length_Basis_list nth_Basis_list_in_Basis)

	lemma list_of_eucl_autoref[autoref_rules]: "(\<lambda>x. x, list_of_eucl) \<in> lv_rel \<rightarrow> \<langle>rnv_rel\<rangle>list_rel"
	by (auto simp: lv_rel_def br_def)

	definition [simp]: "op_DIM TYPE('a) = DIM('a::executable_euclidean_space)"
	lemma [autoref_op_pat_def]: "DIM('a) \<equiv> OP (op_DIM TYPE('a::executable_euclidean_space))" by simp
	lemma op_DIM[autoref_rules]:
	assumes [simplified, symmetric, simp]: "DIM_precond TYPE('a) E"
	shows "(E, (op_DIM TYPE('a::executable_euclidean_space))) \<in> nat_rel"
	using assms
	by auto

	end

	end
	\ No newline at end of file
	diff --git a/thys/Ordinary_Differential_Equations/Refinement/Weak_Set.thy b/thys/Ordinary_Differential_Equations/Refinement/Weak_Set.thy
	--- a/thys/Ordinary_Differential_Equations/Refinement/Weak_Set.thy
	+++ b/thys/Ordinary_Differential_Equations/Refinement/Weak_Set.thy
	@@ -1,921 +1,921 @@
	theory Weak_Set
	imports
	Autoref_Misc
	begin

	subsection \<open>generic things\<close>

	lemma nres_rel_trans1: "a \<le> b \<Longrightarrow> (b, i) \<in> \<langle>R\<rangle>nres_rel \<Longrightarrow> (a, i) \<in> \<langle>R\<rangle>nres_rel"
	using nres_relD order_trans
	by (blast intro: nres_relI)

	lemma nres_rel_trans2: "a \<le> b \<Longrightarrow> (i, a) \<in> \<langle>R\<rangle>nres_rel \<Longrightarrow> (i, b) \<in> \<langle>R\<rangle>nres_rel"
	using nres_relD
	by (blast intro: nres_relI ref_two_step)

	lemma param_Union[param]: "(Union, Union) \<in> \<langle>\<langle>R\<rangle>set_rel\<rangle>set_rel \<rightarrow> \<langle>R\<rangle>set_rel"
	by (fastforce simp: set_rel_def)

	subsection \<open>relation\<close>

	definition list_wset_rel_internal_def: "list_wset_rel R = br set top O \<langle>R\<rangle>set_rel"

	lemma list_wset_rel_def: "\<langle>R\<rangle>list_wset_rel = br set top O \<langle>R\<rangle>set_rel"
	unfolding list_wset_rel_internal_def[abs_def] by (simp add: relAPP_def)

	lemma list_wset_rel_br_eq: "\<langle>br a I\<rangle>list_wset_rel = br (\<lambda>xs. a ` set xs) (\<lambda>xs. \<forall>x \<in> set xs. I x)"
	by (auto simp: list_wset_rel_def br_def set_rel_def)

	lemma mem_br_list_wset_rel_iff:
	"(xs, X) \<in> \<langle>br a I\<rangle>list_wset_rel \<longleftrightarrow> (X = (a ` set xs) \<and> (\<forall>x \<in> set xs. I x))"
	by (auto simp: list_wset_rel_def set_rel_def br_def)

	lemma list_set_rel_sv[relator_props]:
	"single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>list_wset_rel)"
	unfolding list_wset_rel_def
	by tagged_solver

	lemmas [autoref_rel_intf] = REL_INTFI[of list_wset_rel i_set]

	lemma list_wset_relD:
	assumes "(a, b) \<in> \<langle>R\<rangle>list_wset_rel"
	shows "(set a, b) \<in> \<langle>R\<rangle>set_rel"
	using assms
	by (auto simp: list_wset_rel_def br_def)


	subsection \<open>operations\<close>

	definition "op_set_ndelete x X = RES {X - {x}, X}"

	lemma op_set_ndelete_spec: "op_set_ndelete x X = SPEC(\<lambda>R. R = X - {x} \<or> R = X)"
	by (auto simp: op_set_ndelete_def)


	subsection \<open>implementations\<close>

	lemma list_wset_autoref_empty[autoref_rules]:
	"([],{})\<in>\<langle>R\<rangle>list_wset_rel"
	by (auto simp: list_wset_rel_def br_def relcompI)

	context includes autoref_syntax begin

	lemma mem_set_list_relE1:
	assumes "(xs, ys) \<in> \<langle>R\<rangle>list_rel"
	assumes "x \<in> set xs"
	obtains y where "y \<in> set ys" "(x, y) \<in> R"
	by (metis (no_types, lifting) assms in_set_conv_decomp list_relE3 list_rel_append1)

	lemma mem_set_list_relE2:
	assumes "(xs, ys) \<in> \<langle>R\<rangle>list_rel"
	assumes "y \<in> set ys"
	obtains x where "x \<in> set xs" "(x, y) \<in> R"
	by (metis assms in_set_conv_decomp list_relE4 list_rel_append2)

	lemma in_domain_list_relE:
	assumes "\<And>x. x \<in> set xs \<Longrightarrow> x \<in> Domain R"
	obtains ys where "(xs, ys) \<in> \<langle>R\<rangle>list_rel"
	proof -
	obtain y where y: "\<And>x. x \<in> set xs \<Longrightarrow> (x, y x) \<in> R"
	using assms by (metis for_in_RI)
	have "(xs, map y xs) \<in> \<langle>R\<rangle>list_rel"
	by (auto simp: list_rel_def list_all2_iff in_set_zip intro!: y)
	then show ?thesis ..
	qed

	lemma list_rel_comp_list_wset_rel:
	assumes "single_valued R"
	shows "\<langle>R\<rangle>list_rel O \<langle>S\<rangle>list_wset_rel = \<langle>R O S\<rangle>list_wset_rel"
	proof (safe, goal_cases)
	case hyps: (1 a b x y z)
	show ?case
	unfolding list_wset_rel_def
	proof (rule relcompI[where b = "set x"])
	show "(set x, z) \<in> \<langle>R O S\<rangle>set_rel"
	unfolding set_rel_def
	using hyps
	by (clarsimp simp: list_wset_rel_def br_def set_rel_def)
	(meson mem_set_list_relE1 mem_set_list_relE2 relcomp.relcompI)
	qed (simp add: br_def)
	next
	case hyps: (2 xs zs)
	then have "\<And>x. x \<in> set xs \<Longrightarrow> x \<in> Domain R"
	by (auto simp: list_wset_rel_def br_def set_rel_def)
	from in_domain_list_relE[OF this]
	obtain ys where ys: "(xs, ys) \<in> \<langle>R\<rangle>list_rel" .
	have set_rel: "(set ys, zs) \<in> \<langle>S\<rangle>set_rel"
	unfolding list_wset_rel_def set_rel_def
	using hyps
	by (clarsimp simp: list_wset_rel_def br_def set_rel_def)
	(metis (full_types) assms mem_set_list_relE1 mem_set_list_relE2 relcompEpair single_valued_def ys)
	from ys show ?case
	by (rule relcompI)
	(auto simp: list_wset_rel_def br_def intro!: relcompI[where b="set ys"] set_rel)
	qed

	lemma list_set_autoref_insert[autoref_rules]:
	assumes "PREFER single_valued R"
	shows "(Cons,Set.insert) \<in> R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	proof -
	have 1: "(Cons, Cons) \<in> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel"
	by parametricity
	moreover have 2: "(Cons, Set.insert) \<in> Id \<rightarrow> \<langle>Id\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>list_wset_rel"
	by (auto simp: list_wset_rel_def br_def)
	ultimately have "(Cons, Set.insert) \<in> (R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) O (Id \<rightarrow> \<langle>Id\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>list_wset_rel)"
	by auto
	also have "\<dots> \<subseteq> R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	proof -
	have "\<langle>R\<rangle>list_rel O \<langle>Id\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_rel O \<langle>Id\<rangle>list_wset_rel \<subseteq>
	\<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	by (rule fun_rel_mono)
	(simp_all add: list_rel_comp_list_wset_rel assms[unfolded autoref_tag_defs])
	then have "(\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) O (\<langle>Id\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>list_wset_rel) \<subseteq>
	\<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	by (rule order_trans[OF fun_rel_comp_dist])
	from _ this have
	"R O Id \<rightarrow> (\<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel) O (\<langle>Id\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>list_wset_rel) \<subseteq>
	R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	by (rule fun_rel_mono) simp
	then show ?thesis
	by (rule order_trans[OF fun_rel_comp_dist])
	qed
	finally show ?thesis .
	qed

	lemma op_set_ndelete_wset_refine[autoref_rules]:
	assumes "PREFER single_valued R"
	assumes "(x, y) \<in> R" "(xs, Y) \<in> \<langle>R\<rangle>list_wset_rel"
	shows "(nres_of (dRETURN (List.remove1 x xs)),op_set_ndelete $ y $ Y) \<in> \<langle>\<langle>R\<rangle>list_wset_rel\<rangle>nres_rel"
	proof -
	from assms(3)[unfolded list_wset_rel_def]
	obtain u where u: "(xs, u) \<in> br set top" "(u, Y) \<in> \<langle>R\<rangle>set_rel"
	by (rule relcompE) auto
	have "\<exists>x'. (remove1 x xs, x') \<in> \<langle>R\<rangle>list_wset_rel \<and> (x' = Y - {y} \<or> x' = Y)"
	proof (cases "x \<in> set (remove1 x xs)")
	case True
	then have "set (remove1 x xs) = set xs"
	by (metis in_set_remove1 set_remove1_subset subsetI subset_antisym)
	then show ?thesis
	using True u
	by (auto intro!: simp: list_wset_rel_def br_def)
	next
	case False
	then have r: "set (remove1 x xs) = set xs - {x}"
	using in_set_remove1[of _ x xs] u
	by (auto simp del: in_set_remove1 simp add: br_def)
	from assms old_set_rel_sv_eq[of R] have [simp]: "\<langle>R\<rangle>set_rel = \<langle>R\<rangle>old_set_rel" by simp
	show ?thesis
	using False \<open>(x, y) \<in> R\<close> assms
	by (auto simp: relcomp_unfold r old_set_rel_def single_valued_def br_def list_wset_rel_def)
	qed
	then show ?thesis
	unfolding op_set_ndelete_spec autoref_tag_defs
	by (safe intro!: nres_relI SPEC_refine det_SPEC elim!: relcompE)
	qed


	subsection \<open>pick\<close>

	lemma
	pick_wset_refine[autoref_rules]:
	assumes[unfolded autoref_tag_defs, simp]: "SIDE_PRECOND (X \<noteq> {})"
	assumes "(XS, X) \<in> \<langle>A\<rangle>list_wset_rel"
	shows "(nres_of (dRETURN (hd XS)), op_set_pick $ X) \<in> \<langle>A\<rangle>nres_rel"
	proof -
	have "\<forall>x\<in>set XS. \<exists>y\<in>X. (x, y) \<in> A \<Longrightarrow> \<forall>y\<in>X. \<exists>x\<in>set XS. (x, y) \<in> A \<Longrightarrow>
	\<forall>x'. (hd XS, x') \<in> A \<longrightarrow> x' \<notin> X \<Longrightarrow> xa \<notin> X" for xa
	by (metis (full_types) empty_iff insertCI list.exhaust list.sel(1) list.set)
	show ?thesis
	using assms(2)
	unfolding op_set_pick_def[abs_def] autoref_tag_defs
	by (cases XS)
	(auto simp: Let_def list_wset_rel_def set_rel_def br_def intro!: nres_relI RETURN_RES_refine det_SPEC)
	qed

	subsection \<open>pick remove\<close>

	definition "op_set_npick_remove X = SPEC (\<lambda>(x, X'). x \<in> X \<and> (X' = X - {x} \<or> X' = X))"
	lemma op_set_pick_remove_pat[autoref_op_pat]:
	"SPEC (\<lambda>(x, X'). x \<in> X \<and> (X' = X - {x} \<or> X' = X)) \<equiv> op_set_npick_remove $ X"
	"SPEC (\<lambda>(x, X'). x \<in> X \<and> (X' = X \<or> X' = X - {x})) \<equiv> op_set_npick_remove $ X"
	"do { x \<leftarrow> SPEC (\<lambda>x. x \<in> X); X' \<leftarrow> op_set_ndelete x X; f x X' } \<equiv> do { (x, X') \<leftarrow> op_set_npick_remove X; f x X'}"
	by (auto simp: op_set_npick_remove_def op_set_ndelete_def pw_eq_iff refine_pw_simps intro!: eq_reflection)

	lemma op_set_npick_remove_def':
	"X \<noteq> {} \<Longrightarrow> op_set_npick_remove X =
	do { ASSERT (X \<noteq> {}); x \<leftarrow> op_set_pick X; X' \<leftarrow> op_set_ndelete x X; RETURN (x, X')}"
	by (auto simp: op_set_npick_remove_def op_set_ndelete_def pw_eq_iff refine_pw_simps )

	lemma aux: "(a, c) \<in> R \<Longrightarrow> a = b \<Longrightarrow> (b, c) \<in> R"
	by simp

	lemma
	op_set_npick_remove_refine[autoref_rules]:
	assumes [THEN PREFER_sv_D, relator_props]: "PREFER single_valued A"
	assumes "SIDE_PRECOND (X \<noteq> {})"
	assumes [autoref_rules]: "(XS, X) \<in> \<langle>A\<rangle>list_wset_rel"
	shows "(RETURN (hd XS, tl XS), op_set_npick_remove $ X) \<in> \<langle>A \<times>\<^sub>r \<langle>A\<rangle>list_wset_rel\<rangle>nres_rel"
	proof -
	have "(RETURN (hd XS, remove1 (hd XS) XS), ASSERT (X \<noteq> {}) \<bind> (\<lambda>_. op_set_pick X \<bind> (\<lambda>x. op_set_ndelete x X \<bind> (\<lambda>X'. RETURN (x, X')))))
	\<in> \<langle>A \<times>\<^sub>r \<langle>A\<rangle>list_wset_rel\<rangle>nres_rel"
	by (rule aux, autoref, simp)
	then show ?thesis
	unfolding autoref_tag_defs op_set_npick_remove_def'[OF assms(2)[unfolded autoref_tag_defs]]
	using assms
	by (subst remove1_tl[symmetric]) (force simp: list_wset_rel_def br_def set_rel_def)
	qed


	subsection \<open>emptiness check\<close>

	lemma isEmpty_wset_refine[autoref_rules]:
	assumes "(xs, X) \<in> \<langle>A\<rangle>list_wset_rel"
	shows "(xs = [], op_set_isEmpty $ X) \<in> bool_rel"
	using assms
	by (auto simp: list_wset_rel_def br_def set_rel_def)


	subsection \<open>union\<close>

	lemma union_wset_refine[autoref_rules]:
	"(append, (\<union>)) \<in> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	by (auto 0 3 simp: list_wset_rel_def set_rel_def relcomp_unfold br_def)


	subsection \<open>of list\<close>

	lemma set_wset_refine[autoref_rules]:
	assumes "PREFER single_valued R"
	shows "((\<lambda>x. x), set) \<in> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	proof (rule fun_relI)
	fix a a'
	assume aa': "(a, a') \<in> \<langle>R\<rangle>list_rel"
	moreover have "(a, a') \<in> \<langle>R\<rangle>list_rel \<Longrightarrow> (set a, set a') \<in> \<langle>R\<rangle>set_rel"
	using assms[THEN PREFER_sv_D]
	by parametricity
	ultimately show "(a, set a') \<in> \<langle>R\<rangle>list_wset_rel"
	unfolding list_wset_rel_def
	by (intro relcompI[where b="set a"]) (simp_all add: br_def)
	qed


	subsection \<open>filter set\<close>

	lemma bCollect_param: "((\<lambda>y a. {x \<in> y. a x}), (\<lambda>z a'. {x \<in> z. a' x})) \<in> \<langle>R\<rangle>set_rel \<rightarrow> (R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>set_rel"
	unfolding set_rel_def
	apply safe
	subgoal using tagged_fun_relD_both by fastforce
	subgoal using tagged_fun_relD_both by fastforce
	done

	lemma op_set_filter_list_wset_refine[autoref_rules]:
	"(filter, op_set_filter) \<in> (R \<rightarrow> bool_rel) \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	by (force simp: list_wset_rel_def br_def bCollect_param[param_fo])


	subsection \<open>bound on cardinality\<close>

	definition "op_set_wcard X = SPEC (\<lambda>c. card X \<le> c)"

	lemma op_set_wcard_refine[autoref_rules]: "PREFER single_valued R \<Longrightarrow> ((\<lambda>xs. RETURN (length xs)), op_set_wcard) \<in> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
	proof (auto simp: list_wset_rel_def nres_rel_def br_def op_set_wcard_def, goal_cases)
	case (1 x z)
	thus ?case
	by (induction x arbitrary: z)
	(auto simp: old_set_rel_sv_eq[symmetric] old_set_rel_def Image_insert intro!: card_insert_le_m1)
	qed

	lemmas op_set_wcard_spec[refine_vcg] = op_set_wcard_def[THEN eq_refl, THEN order_trans]

	subsection \<open>big union\<close>

	lemma Union_list_wset_rel[autoref_rules]:
	assumes "PREFER single_valued A"
	shows "(concat, Union) \<in> \<langle>\<langle>A\<rangle>list_wset_rel\<rangle>list_wset_rel \<rightarrow> \<langle>A\<rangle>list_wset_rel"
	proof -
	have "(concat, concat) \<in> \<langle>\<langle>A\<rangle>list_rel\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel" (is "_ \<in> ?A")
	by parametricity
	moreover have "(concat, Union) \<in> \<langle>\<langle>Id\<rangle>list_wset_rel\<rangle>list_wset_rel \<rightarrow> \<langle>Id\<rangle>list_wset_rel" (is "_ \<in> ?B")
	by (auto simp: list_wset_rel_def br_def relcomp_unfold set_rel_def; meson)
	ultimately have "(concat, Union) \<in> ?A O ?B"
	by auto
	also note fun_rel_comp_dist
	finally show ?thesis
	using assms
	by (simp add: list_rel_comp_list_wset_rel list_rel_sv_iff)
	qed


	subsection \<open>image\<close>

	lemma image_list_wset_rel[autoref_rules]:
	assumes "PREFER single_valued B"
	shows "(map, (`)) \<in> (A \<rightarrow> B) \<rightarrow> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>B\<rangle>list_wset_rel"
	unfolding list_wset_rel_def relcomp_unfold
	proof safe
	fix a a' aa a'a y
	assume H: "(a, a') \<in> A \<rightarrow> B" "(aa, y) \<in> br set top" "(y, a'a) \<in> \<langle>A\<rangle>set_rel"
	have "(map a aa, a ` y) \<in> br set top"
	using H
	by (auto simp: br_def)
	moreover have " (a ` y, a' ` a'a) \<in> \<langle>B\<rangle>set_rel"
	using H
	by (fastforce simp: fun_rel_def set_rel_def split: prod.split)
	ultimately show "\<exists>y. (map a aa, y) \<in> br set top \<and> (y, a' ` a'a) \<in> \<langle>B\<rangle>set_rel"
	by (safe intro!: exI[where x = "a ` y"])
	qed

	subsection \<open>Ball\<close>

	lemma Ball_list_wset_rel[autoref_rules]:
	"((\<lambda>xs p. foldli xs (\<lambda>x. x) (\<lambda>a _. p a) True), Ball) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> (A \<rightarrow> bool_rel) \<rightarrow> bool_rel"
	proof -
	have "(set a, a') \<in> \<langle>A\<rangle>set_rel \<Longrightarrow> (Ball (set a), Ball a') \<in> (A \<rightarrow> bool_rel) \<rightarrow> bool_rel" for a a'
	by parametricity
	then have "(\<lambda>xs. Ball (set xs), Ball) \<in> {(x, z). (set x, z) \<in> \<langle>A\<rangle>set_rel} \<rightarrow> (A \<rightarrow> bool_rel) \<rightarrow> bool_rel"
	unfolding mem_Collect_eq split_beta' fst_conv snd_conv
	by (rule fun_relI) auto
	then show ?thesis
	by (simp add: relcomp_unfold br_def foldli_ball_aux list_wset_rel_def)
	qed


	subsection \<open>weak foreach loop\<close>

	definition FORWEAK :: "'a set \<Rightarrow> 'b nres \<Rightarrow> ('a \<Rightarrow> 'b nres) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b nres) \<Rightarrow> 'b nres"
	where "FORWEAK X d f c =
	(if X = {} then d
	else do {
	(a, X) \<leftarrow> op_set_npick_remove X;
	b \<leftarrow> f a;
	(b, _) \<leftarrow> WHILE (\<lambda>(_, X). \<not> op_set_isEmpty X) (\<lambda>(b, X).
	do {
	ASSERT (X \<noteq> {});
	(a, X) \<leftarrow> op_set_npick_remove X;
	b' \<leftarrow> f a;
	b \<leftarrow> c b b';
	RETURN (b, X)
	}) (b, X);
	RETURN b
	})"

	schematic_goal
	FORWEAK_wset_WHILE_refine:
	assumes [relator_props]: "single_valued A"
	assumes [autoref_rules]:
	"(Xi, X) \<in> \<langle>A\<rangle>list_wset_rel"
	"(di, d) \<in> \<langle>B\<rangle>nres_rel"
	"(fi, f) \<in> A \<rightarrow> \<langle>B\<rangle>nres_rel"
	"(ci, c) \<in> B \<rightarrow> B \<rightarrow> \<langle>B\<rangle>nres_rel"
	shows "(?f, FORWEAK X d f c) \<in> \<langle>B\<rangle>nres_rel"
	unfolding FORWEAK_def
	by autoref

	lemma FORWEAK_LIST_transfer_nfoldli:
	"nfoldli xs (\<lambda>_. True) (\<lambda>x a. c a x) a \<le> do {
	(a, _) \<leftarrow>
	WHILE (\<lambda>(a, xs). xs \<noteq> []) (\<lambda>(a, xs). do {
	(x, xs) \<leftarrow> RETURN (hd xs, tl xs);
	a \<leftarrow> c a x;
	RETURN (a, xs)
	}) (a, xs);
	RETURN a}"
	proof (induct xs arbitrary: a)
	case Nil thus ?case by (auto simp: WHILE_unfold)
	next
	case (Cons x xs)
	show ?case
	by (auto simp: WHILE_unfold intro!: bind_mono Cons[THEN order.trans])
	qed

	lemma
	FORWEAK_wset_refine:
	assumes [relator_props]: "PREFER single_valued A"
	assumes [autoref_rules]:
	"(Xi, X) \<in> \<langle>A\<rangle>list_wset_rel"
	"(di, d) \<in> \<langle>B\<rangle>nres_rel"
	"(fi, f) \<in> A \<rightarrow> \<langle>B\<rangle>nres_rel"
	"(ci, c) \<in> B \<rightarrow> B \<rightarrow> \<langle>B\<rangle>nres_rel"
	shows
	"((if Xi = [] then di else do { b \<leftarrow> fi (hd Xi); nfoldli (tl Xi) (\<lambda>_. True) (\<lambda>x b. do {b' \<leftarrow> fi x; ci b b'}) b }),
	(OP FORWEAK ::: \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>B\<rangle>nres_rel \<rightarrow> (A \<rightarrow> \<langle>B\<rangle>nres_rel) \<rightarrow> (B \<rightarrow> B \<rightarrow> \<langle>B\<rangle>nres_rel) \<rightarrow> \<langle>B\<rangle>nres_rel) $ X $ d $ f $ c) \<in> \<langle>B\<rangle>nres_rel"
	unfolding autoref_tag_defs
	by (rule nres_rel_trans1[OF _ FORWEAK_wset_WHILE_refine[OF assms[simplified autoref_tag_defs]]])
	(auto intro!: bind_mono FORWEAK_LIST_transfer_nfoldli[THEN order.trans])
	concrete_definition FORWEAK_LIST for Xi di fi ci uses FORWEAK_wset_refine
	lemmas [autoref_rules] = FORWEAK_LIST.refine

	schematic_goal FORWEAK_LIST_transfer_nres:
	assumes [refine_transfer]: "nres_of d \<le> d'"
	assumes [refine_transfer]: "\<And>x. nres_of (f x) \<le> f' x"
	assumes [refine_transfer]: "\<And>x y. nres_of (g x y) \<le> g' x y"
	shows
	"nres_of (?f) \<le> FORWEAK_LIST xs d' f' g'"
	unfolding FORWEAK_LIST_def
	by refine_transfer
	concrete_definition dFORWEAK_LIST for xs d f g uses FORWEAK_LIST_transfer_nres
	lemmas [refine_transfer] = dFORWEAK_LIST.refine

	schematic_goal FORWEAK_LIST_transfer_plain:
	assumes [refine_transfer]: "RETURN d \<le> d'"
	assumes [refine_transfer]: "\<And>x. RETURN (f x) \<le> f' x"
	assumes [refine_transfer]: "\<And>x y. RETURN (g x y) \<le> g' x y"
	shows "RETURN ?f \<le> FORWEAK_LIST xs d' f' g'"
	unfolding FORWEAK_LIST_def
	by refine_transfer
	concrete_definition FORWEAK_LIST_plain for xs f g uses FORWEAK_LIST_transfer_plain
	lemmas [refine_transfer] = FORWEAK_LIST_plain.refine

	schematic_goal FORWEAK_LIST_transfer_ne_plain:
	assumes "SIDE_PRECOND_OPT (xs \<noteq> [])"
	assumes [refine_transfer]: "\<And>x. RETURN (f x) \<le> f' x"
	assumes [refine_transfer]: "\<And>x y. RETURN (g x y) \<le> g' x y"
	shows "RETURN ?f \<le> FORWEAK_LIST xs d' f' g'"
	using assms
	by (simp add: FORWEAK_LIST_def) refine_transfer
	concrete_definition FORWEAK_LIST_ne_plain for xs f g uses FORWEAK_LIST_transfer_ne_plain


	lemma FORWEAK_empty[simp]: "FORWEAK {} = (\<lambda>d _ _. d)"
	by (auto simp: FORWEAK_def[abs_def])

	lemma FORWEAK_WHILE_casesI:
	assumes "X = {} \<Longrightarrow> d \<le> SPEC P"
	assumes "\<And>a X'. a \<in> X \<Longrightarrow> X' = X - {a} \<Longrightarrow>
	f a \<le> SPEC (\<lambda>x. WHILE (\<lambda>(_, X). X \<noteq> {})
	(\<lambda>(b, X).
	do {
	ASSERT (X \<noteq> {});
	(a, X) \<leftarrow> op_set_npick_remove X;
	b' \<leftarrow> f a;
	b \<leftarrow> c b b';
	RETURN (b, X)
	})
	(x, X')
	\<le> SPEC (\<lambda>(b, _). RETURN b \<le> SPEC P))"
	assumes "\<And>a. a \<in> X \<Longrightarrow>
	f a \<le> SPEC (\<lambda>x. WHILE (\<lambda>(_, X). X \<noteq> {})
	(\<lambda>(b, X).
	do {
	ASSERT (X \<noteq> {});
	(a, X) \<leftarrow> op_set_npick_remove X;
	b' \<leftarrow> f a;
	b \<leftarrow> c b b';
	RETURN (b, X)
	})
	(x, X)
	\<le> SPEC (\<lambda>(b, _). RETURN b \<le> SPEC P))"
	shows "FORWEAK X d f c \<le> SPEC P"
	unfolding FORWEAK_def
	apply (cases "X = {}")
	subgoal by (simp add: assms(1))
	subgoal
	supply op_set_npick_remove_def[refine_vcg_def]
	apply (refine_vcg)
	apply clarsimp
	apply (erule disjE)
	subgoal
	by (refine_vcg assms(2))
	subgoal
	by (refine_vcg assms(3))
	done
	done

	lemma FORWEAK_invarI:
	fixes I::"'b \<Rightarrow> 'a set \<Rightarrow> bool"
	assumes "X = {} \<Longrightarrow> d \<le> SPEC P"
	assumes fspec_init1[THEN order_trans]: "\<And>a. a \<in> X \<Longrightarrow> f a \<le> SPEC (\<lambda>x. I x (X - {a}))"
	assumes fspec_init2[THEN order_trans]: "\<And>a. a \<in> X \<Longrightarrow> f a \<le> SPEC (\<lambda>x. I x X)"
	assumes fspec_invar1[THEN order_trans]:
	"\<And>a aa b ba. I aa b \<Longrightarrow> a \<in> b \<Longrightarrow> f a \<le> SPEC (\<lambda>xb. c aa xb \<le> SPEC (\<lambda>r. I r (b - {a})))"
	assumes fspec_invar2[THEN order_trans]: "\<And>a aa b ba. I aa b \<Longrightarrow> a \<in> b \<Longrightarrow> f a \<le> SPEC (\<lambda>xb. c aa xb \<le> SPEC (\<lambda>r. I r b))"
	assumes fin: "\<And>aa. I aa {} \<Longrightarrow> P aa"
	shows "FORWEAK X d f c \<le> SPEC P"
	unfolding FORWEAK_def
	apply (cases "X = {}")
	subgoal by (simp add: assms(1))
	subgoal
	supply op_set_npick_remove_def[refine_vcg_def]
	apply (refine_vcg)
	apply clarsimp
	apply (erule disjE)
	subgoal
	apply (refine_vcg fspec_init1)
	apply (rule order_trans[OF WHILE_le_WHILEI[where I="\<lambda>(a, b). I a b"]])
	apply (refine_vcg)
	subgoal
	apply clarsimp
	apply (erule disjE)
	subgoal by (rule fspec_invar1, assumption, assumption) (refine_vcg)
	subgoal by (rule fspec_invar2, assumption, assumption) (refine_vcg)
	done
	subgoal by (simp add: fin)
	done
	subgoal
	apply (refine_vcg fspec_init2)
	apply (rule order_trans[OF WHILE_le_WHILEI[where I="\<lambda>(a, b). I a b"]])
	apply (refine_vcg)
	subgoal
	apply clarsimp
	apply (erule disjE)
	subgoal by (rule fspec_invar1, assumption, assumption) (refine_vcg)
	subgoal by (rule fspec_invar2, assumption, assumption) (refine_vcg)
	done
	subgoal by (simp add: fin)
	done
	done
	done

	lemma FORWEAK_mono_rule:
	fixes f::"'d \<Rightarrow> 'e nres" and c::"'e \<Rightarrow> 'e \<Rightarrow> 'e nres" and I::"'d set \<Rightarrow> 'e \<Rightarrow> bool"
	assumes empty: "S = {} \<Longrightarrow> d \<le> SPEC P"
	assumes I0[THEN order_trans]: "\<And>s. s \<in> S \<Longrightarrow> f s \<le> SPEC (I {s})"
	assumes I_mono: "\<And>it it' \<sigma>. I it \<sigma> \<Longrightarrow> it' \<subseteq> it \<Longrightarrow> it \<subseteq> S \<Longrightarrow> I it' \<sigma>"
	assumes IP[THEN order_trans]:
	"\<And>x it \<sigma>. \<lbrakk> x\<in>S; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I (insert x it)))"
	assumes II: "\<And>\<sigma>. I S \<sigma> \<Longrightarrow> P \<sigma>"
	shows "FORWEAK S d f c \<le> SPEC P"
	apply (rule FORWEAK_invarI[where I="\<lambda>b X. X \<subseteq> S \<and> I (S - X) b"])
	subgoal by (rule empty)
	subgoal by (auto simp: Diff_Diff_Int intro!: I0)
	subgoal
	by (metis (mono_tags, lifting) Diff_cancel I0 I_mono Refine_Basic.RES_sng_eq_RETURN iSPEC_rule
	less_eq_nres.simps(2) nres_order_simps(21) subset_insertI subset_refl)
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: order_trans)
	done
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: I_mono)
	done
	subgoal by (auto intro!: II)
	done

	lemma FORWEAK_case_rule:
	fixes f::"'d \<Rightarrow> 'e nres" and c::"'e \<Rightarrow> 'e \<Rightarrow> 'e nres" and I::"'d set \<Rightarrow> 'e \<Rightarrow> bool"
	assumes empty: "S = {} \<Longrightarrow> d \<le> SPEC P"
	assumes I01[THEN order_trans]: "\<And>s. s \<in> S \<Longrightarrow> f s \<le> SPEC (I (S - {s}))"
	assumes I02[THEN order_trans]: "\<And>s. s \<in> S \<Longrightarrow> f s \<le> SPEC (I S)"
	assumes IP1[THEN order_trans]:
	"\<And>x it \<sigma>. \<lbrakk> x\<in>it; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I (it-{x})))"
	assumes IP2[THEN order_trans]:
	"\<And>x it \<sigma>. \<lbrakk> x\<in>it; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I it))"
	assumes II: "\<And>\<sigma>. I {} \<sigma> \<Longrightarrow> P \<sigma>"
	shows "FORWEAK S d f c \<le> SPEC P"
	apply (rule FORWEAK_invarI[where I = "\<lambda>a b. I b a \<and> b \<subseteq> S"])
	subgoal by (rule empty)
	subgoal by (rule I01) auto
	subgoal by (rule I02) auto
	subgoal for a b it
	apply (rule IP1[of a it b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	by (rule order_trans, assumption) auto
	done
	subgoal by (rule IP2) auto
	subgoal by (rule II) auto
	done

	lemma FORWEAK_elementwise_rule:
	assumes "nofail d"
	assumes Inf_spec: "\<And>X. X \<in> XX \<Longrightarrow> Inf_spec X \<le> SPEC (Q X)"
	notes [refine_vcg] = order.trans[OF Inf_spec]
	assumes comb_spec1: "\<And>a b X Y. Q X a \<Longrightarrow> comb a b \<le> SPEC (Q X)"
	assumes comb_spec2: "\<And>a b X Y. Q X b \<Longrightarrow> comb a b \<le> SPEC (Q X)"
	shows "FORWEAK XX d Inf_spec comb \<le> SPEC (\<lambda>i. \<forall>x\<in>XX. Q x i)"
	apply (rule FORWEAK_mono_rule[where I="\<lambda>S i. \<forall>x\<in>S. Q x i"])
	subgoal using \<open>nofail d\<close> by (simp add: nofail_SPEC_iff)
	subgoal by (simp add: Diff_Diff_Int Inf_spec)
	subgoal by force
	subgoal for x it \<sigma>
	apply (refine_transfer refine_vcg)
	apply (rule SPEC_BallI)
	apply (rule SPEC_nofail)
	apply (rule comb_spec2)
	apply assumption
	subgoal for y z
	apply (cases "z = x")
	subgoal by simp (rule comb_spec2)
	subgoal by (rule comb_spec1) force
	done
	done
	subgoal by force
	done

	end

	lemma nofail_imp_RES_UNIV: "nofail s \<Longrightarrow> s \<le> RES UNIV"
	by (metis Refine_Basic.nofail_SPEC_triv_refine UNIV_I top_empty_eq top_set_def)

	lemma FORWEAK_unit_rule[THEN order_trans, refine_vcg]:
	assumes "nofail d"
	assumes "\<And>s. nofail (f s)"
	assumes "nofail (c () ())"
	shows "FORWEAK XS d f c \<le> SPEC (\<lambda>(_::unit). True)"
	using assms
	by (intro order_trans[OF FORWEAK_elementwise_rule[where Q=top]])
	(auto simp: top_fun_def le_SPEC_UNIV_rule nofail_SPEC_triv_refine nofail_imp_RES_UNIV)

	lemma FORWEAK_mono_rule':
	fixes f::"'d \<Rightarrow> 'e nres" and c::"'e \<Rightarrow> 'e \<Rightarrow> 'e nres" and I::"'d set \<Rightarrow> 'e \<Rightarrow> bool"
	assumes empty: "S = {} \<Longrightarrow> d \<le> SPEC P"
	assumes I0[THEN order_trans]: "\<And>s. s \<in> S \<Longrightarrow> f s \<le> SPEC (I {s})"
	assumes I_mono: "\<And>ab bb xb. ab \<in> bb \<Longrightarrow> bb \<subseteq> S \<Longrightarrow> I (insert ab (S - bb)) xb \<Longrightarrow> I (S - bb) xb"
	assumes IP[THEN order_trans]:
	"\<And>x it \<sigma>. \<lbrakk> x\<in>S; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I (insert x it)))"
	assumes II: "\<And>\<sigma>. I S \<sigma> \<Longrightarrow> P \<sigma>"
	shows "FORWEAK S d f c \<le> SPEC P"
	apply (rule FORWEAK_invarI[where I="\<lambda>b X. X \<subseteq> S \<and> I (S - X) b"])
	subgoal by (rule empty)
	subgoal by (auto simp: Diff_Diff_Int intro!: I0)
	subgoal
	apply (rule I0, assumption)
	apply (rule SPEC_rule)
	apply (rule conjI)
	subgoal by simp
	subgoal by (rule I_mono, assumption) auto
	done
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: order_trans)
	done
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: I_mono)
	done
	subgoal by (auto intro!: II)
	done

	lemma
	op_set_npick_remove_refine_SPEC[refine_vcg]:
	assumes "\<And>x X'. x \<in> X1 \<Longrightarrow> X' = X1 - {x} \<Longrightarrow> Q (x, X')"
	assumes "\<And>x. x \<in> X1 \<Longrightarrow> Q (x, X1)"
	shows "op_set_npick_remove X1 \<le> SPEC Q"
	using assms
	by (auto simp: op_set_npick_remove_def )

	context includes autoref_syntax begin
	definition "op_set_pick_remove X \<equiv> SPEC (\<lambda>(x, X'). x \<in> X \<and> X' = X - {x})"
	lemma op_set_pick_removepat[autoref_op_pat]:
	"SPEC (\<lambda>(x, X'). x \<in> X \<and> X' = X - {x}) \<equiv> op_set_pick_remove $ X"
	"do { x \<leftarrow> SPEC (\<lambda>x. x \<in> X); let X' = X - {x}; f x X' } \<equiv> do { (x, X') \<leftarrow> op_set_pick_remove X; f x X'}"
	by (auto simp: op_set_pick_remove_def pw_eq_iff refine_pw_simps intro!: eq_reflection)

	lemma list_all2_tlI: "list_all2 A XS y \<Longrightarrow> list_all2 A (tl XS) (tl y)"
	by (metis list.rel_sel list.sel(2))

	lemma
	op_set_pick_remove_refine[autoref_rules]:
	assumes "(XS, X) \<in> \<langle>A\<rangle>list_set_rel"
	assumes "SIDE_PRECOND (X \<noteq> {})"
	shows "(nres_of (dRETURN (hd XS, tl XS)), op_set_pick_remove $ X) \<in> \<langle>A \<times>\<^sub>r \<langle>A\<rangle>list_set_rel\<rangle>nres_rel"
	using assms(1)
	unfolding op_set_pick_remove_def[abs_def] autoref_tag_defs list_set_rel_def list_rel_def br_def
	apply (intro nres_relI SPEC_refine det_SPEC)
	apply safe
	subgoal for x y z
	using assms(2)
	apply (safe intro!: exI[where x="(hd y, set (tl y))"])
	subgoal
	apply (rule prod_relI)
	subgoal by (induct XS y rule: list_all2_induct) auto
	subgoal
	apply (rule relcompI[where b = "tl y"])
	subgoal
	unfolding mem_Collect_eq split_beta' fst_conv snd_conv
	by (rule list_all2_tlI)
	subgoal
	unfolding mem_Collect_eq split_beta' fst_conv snd_conv
	apply (rule conjI)
	subgoal by (metis remove1_tl set_remove1_eq)
	subgoal by simp
	done
	done
	done
	subgoal by (subst (asm) list.rel_sel) simp
	subgoal by (simp add: in_set_tlD)
	subgoal by (simp add: distinct_hd_tl)
	subgoal by auto (meson in_hd_or_tl_conv)
	done
	done

	definition [simp, refine_vcg_def]: "isEmpty_spec X = SPEC (\<lambda>b. b \<longrightarrow> X = {})"

	lemma [autoref_itype]: "isEmpty_spec::\<^sub>i A \<rightarrow>\<^sub>i \<langle>i_bool\<rangle>\<^sub>ii_nres"
	by simp
	lemma op_wset_isEmpty_list_wset_rel[autoref_rules]:
	"(\<lambda>x. RETURN (x = []), isEmpty_spec) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	by (auto simp: nres_rel_def list_wset_rel_def set_rel_def br_def)


	definition WEAK_ALL:: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> bool nres) \<Rightarrow> bool nres" ("WEAK'_ALL\<^bsup>_\<^esup>") where
	"WEAK_ALL I X P = do {
	(_, b) \<leftarrow> WHILE\<^bsup>\<lambda>(Y, b). b \<longrightarrow> (\<forall>x \<in> X - Y. I x)\<^esup> (\<lambda>(X, b). b \<and> X \<noteq> {}) (\<lambda>(X, b). do {
	ASSERT (X \<noteq> {});
	(x, X') \<leftarrow> op_set_npick_remove X;
	b' \<leftarrow> P x;
	RETURN (X', b' \<and> b)
	}) (X, True); RETURN b}"
	schematic_goal WEAK_ALL_list[autoref_rules]:
	assumes [relator_props]: "single_valued A"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>A\<rangle>list_wset_rel"
	"(P_impl, P) \<in> A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	shows "(?r, WEAK_ALL I X P) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding WEAK_ALL_def
	including art
	by (autoref)
	concrete_definition WEAK_ALL_list for Xi P_impl uses WEAK_ALL_list
	lemma WEAK_ALL_list_refine[autoref_rules]:
	"PREFER single_valued A \<Longrightarrow> (WEAK_ALL_list, WEAK_ALL I) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> (A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel) \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using WEAK_ALL_list.refine by force

	schematic_goal WEAK_ALL_transfer_nres:
	assumes [refine_transfer]: "\<And>x. nres_of (f x) \<le> f' x"
	shows "nres_of (?f) \<le> WEAK_ALL_list xs f'"
	unfolding WEAK_ALL_list_def
	by refine_transfer
	concrete_definition dWEAK_ALL for xs f uses WEAK_ALL_transfer_nres
	lemmas [refine_transfer] = dWEAK_ALL.refine

	definition WEAK_EX:: "('a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> ('a \<Rightarrow> bool nres) \<Rightarrow> bool nres" ("WEAK'_EX\<^bsup>_\<^esup>") where
	"WEAK_EX I X P = do {
	(_, b) \<leftarrow> WHILE\<^bsup>\<lambda>(Y, b). Y \<subseteq> X \<and> (b \<longrightarrow> (\<exists>x \<in> X. I x))\<^esup> (\<lambda>(X, b). \<not>b \<and> X \<noteq> {}) (\<lambda>(X, b). do {
	ASSERT (X \<noteq> {});
	(x, X') \<leftarrow> op_set_npick_remove X;
	b' \<leftarrow> P x;
	RETURN (X', b' \<or> b)
	}) (X, False); RETURN b}"
	schematic_goal WEAK_EX_list[autoref_rules]:
	assumes [relator_props]: "single_valued A"
	assumes [autoref_rules]: "(Xi, X) \<in> \<langle>A\<rangle>list_wset_rel"
	"(P_impl, P) \<in> A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	shows "(?r, WEAK_EX I X P) \<in> \<langle>bool_rel\<rangle>nres_rel"
	unfolding WEAK_EX_def
	including art
	by (autoref)
	concrete_definition WEAK_EX_list for Xi P_impl uses WEAK_EX_list
	lemma WEAK_EX_list_refine[autoref_rules]:
	"PREFER single_valued A \<Longrightarrow> (WEAK_EX_list, WEAK_EX I) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> (A \<rightarrow> \<langle>bool_rel\<rangle>nres_rel) \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	using WEAK_EX_list.refine by force

	schematic_goal WEAK_EX_transfer_nres:
	assumes [refine_transfer]: "\<And>x. nres_of (f x) \<le> f' x"
	shows "nres_of (?f) \<le> WEAK_EX_list xs f'"
	unfolding WEAK_EX_list_def
	by refine_transfer
	concrete_definition dWEAK_EX for xs f uses WEAK_EX_transfer_nres
	lemmas [refine_transfer] = dWEAK_EX.refine

	lemma WEAK_EX[THEN order_trans, refine_vcg]:
	assumes [THEN order_trans, refine_vcg]: "\<And>x. F x \<le> SPEC (\<lambda>r. r \<longrightarrow> I x)"
	shows "WEAK_EX I X F \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<exists>x\<in>X. I x))"
	unfolding WEAK_EX_def
	- by (refine_vcg ) (auto simp: )
	+ by (refine_vcg ) auto

	lemma WEAK_ALL[THEN order_trans, refine_vcg]:
	assumes [THEN order_trans, refine_vcg]: "\<And>x. F x \<le> SPEC (\<lambda>r. r \<longrightarrow> I x)"
	shows "WEAK_ALL I X F \<le> SPEC (\<lambda>r. r \<longrightarrow> (\<forall>x\<in>X. I x))"
	unfolding WEAK_ALL_def
	by (refine_vcg) auto

	lemma [autoref_op_pat_def]:
	"WEAK_ALL I \<equiv> OP (WEAK_ALL I)"
	"WEAK_EX I \<equiv> OP (WEAK_EX I)"
	by auto

	lemma list_spec_impl[autoref_rules]:
	"(\<lambda>x. RETURN x, list_spec) \<in> \<langle>A\<rangle>list_wset_rel \<rightarrow> \<langle>\<langle>A\<rangle>list_rel\<rangle>nres_rel"
	if "PREFER single_valued A"
	using that
	apply (auto simp: list_spec_def nres_rel_def RETURN_RES_refine_iff list_wset_rel_br_eq
	br_list_rel intro!: brI dest!: brD
	elim!: single_valued_as_brE)
	subgoal for a I xs
	apply (rule exI[where x="map a xs"])
	by (auto simp: br_def list_all_iff)
	done

	lemma list_wset_autoref_delete[autoref_rules]:
	assumes "PREFER single_valued R"
	assumes "GEN_OP eq (=) (R \<rightarrow> R \<rightarrow> bool_rel)"
	shows "(\<lambda>y xs. [x\<leftarrow>xs. \<not>eq y x], op_set_delete) \<in> R \<rightarrow> \<langle>R\<rangle>list_wset_rel \<rightarrow> \<langle>R\<rangle>list_wset_rel"
	using assms
	apply (auto simp: list_wset_rel_def dest!: brD elim!: single_valued_as_brE)
	apply (rule relcompI)
	apply (rule brI)
	apply (rule refl)
	apply auto
	apply (auto simp: set_rel_br)
	apply (rule brI)
	apply (auto dest!: brD dest: fun_relD)
	apply (auto simp: image_iff dest: fun_relD intro: brI)
	subgoal for a b c d e
	apply (drule spec[where x=e])
	apply auto
	apply (drule fun_relD)
	apply (rule brI[where c="c"])
	apply (rule refl)
	apply assumption
	apply (drule bspec, assumption)
	apply (drule fun_relD)
	apply (rule brI[where c="e"])
	apply (rule refl)
	apply assumption
	apply auto
	done
	done

	lemma FORWEAK_mono_rule'':
	fixes f::"'d \<Rightarrow> 'e nres" and c::"'e \<Rightarrow> 'e \<Rightarrow> 'e nres" and I::"'d set \<Rightarrow> 'e \<Rightarrow> bool"
	assumes empty: "S = {} \<Longrightarrow> d \<le> SPEC P"
	assumes I0[THEN order_trans]: "\<And>s. s \<in> S \<Longrightarrow> f s \<le> SPEC (I {s})"
	assumes I_mono: "\<And>it it' \<sigma>. I it \<sigma> \<Longrightarrow> it' \<subseteq> it \<Longrightarrow> it \<subseteq> S \<Longrightarrow> I it' \<sigma>"
	assumes IP[THEN order_trans]:
	"\<And>x it \<sigma>. \<lbrakk> x\<in>S; x \<notin> it; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I (insert x it)))"
	assumes II: "\<And>\<sigma>. I S \<sigma> \<Longrightarrow> P \<sigma>"
	shows "FORWEAK S d f c \<le> SPEC P"
	apply (rule FORWEAK_invarI[where I="\<lambda>b X. X \<subseteq> S \<and> I (S - X) b"])
	subgoal by (rule empty)
	subgoal by (auto simp: Diff_Diff_Int intro!: I0)
	subgoal
	by (metis (mono_tags, lifting) Diff_cancel I0 I_mono Refine_Basic.RES_sng_eq_RETURN iSPEC_rule
	less_eq_nres.simps(2) nres_order_simps(21) subset_insertI subset_refl)
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: order_trans)
	done
	subgoal for a b it
	apply (rule IP[of _ "S - it" b])
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal by force
	subgoal
	apply clarsimp
	apply (rule order_trans, assumption)
	by (auto simp: it_step_insert_iff intro: I_mono)
	done
	subgoal by (auto intro!: II)
	done

	lemma FORWEAK_mono_rule_empty:
	fixes f::"'d \<Rightarrow> 'e nres" and c::"'e \<Rightarrow> 'e \<Rightarrow> 'e nres" and I::"'d set \<Rightarrow> 'e \<Rightarrow> bool"
	assumes empty: "S = {} \<Longrightarrow> RETURN d \<le> SPEC P"
	assumes I0: "I {} d"
	assumes I1: "\<And>s x. s \<in> S \<Longrightarrow> c d x \<le> SPEC (I {s}) \<Longrightarrow> I {s} x"
	assumes I_mono: "\<And>it it' \<sigma>. I it \<sigma> \<Longrightarrow> it' \<subseteq> it \<Longrightarrow> it \<subseteq> S \<Longrightarrow> I it' \<sigma>"
	assumes II: "\<And>\<sigma>. I S \<sigma> \<Longrightarrow> P \<sigma>"
	assumes IP: "\<And>x it \<sigma>. \<lbrakk> x\<in>S; x \<notin> it; it\<subseteq>S; I it \<sigma> \<rbrakk> \<Longrightarrow> f x \<le> SPEC (\<lambda>f'. c \<sigma> f' \<le> SPEC (I (insert x it)))"
	shows "FORWEAK S (RETURN d) f c \<le> SPEC P"
	apply (rule FORWEAK_mono_rule''[where S=S and I=I and P=P])
	subgoal by (rule empty)
	subgoal for s
	apply (rule IP[of _ "{}" d, THEN order_trans])
	apply assumption
	apply force
	apply force
	apply (rule I0)
	by (auto intro!: I1)
	subgoal by (rule I_mono)
	subgoal by (rule IP)
	subgoal by (rule II)
	done

	end

	end
	diff --git a/thys/PAC_Checker/PAC_More_Poly.thy b/thys/PAC_Checker/PAC_More_Poly.thy
	--- a/thys/PAC_Checker/PAC_More_Poly.thy
	+++ b/thys/PAC_Checker/PAC_More_Poly.thy
	@@ -1,926 +1,926 @@
	(*
	File: PAC_More_Poly.thy
	Author: Mathias Fleury, Daniela Kaufmann, JKU
	Maintainer: Mathias Fleury, JKU
	*)
	theory PAC_More_Poly
	imports "HOL-Library.Poly_Mapping" "HOL-Algebra.Polynomials" "Polynomials.MPoly_Type_Class"
	"HOL-Algebra.Module" "HOL-Library.Countable_Set"
	begin


	section \<open>Overview\<close>

	text \<open>

	One solution to check circuit of multipliers is to use algebraic method, like producing proofs on
	polynomials. We are here interested in checking PAC proofs on the Boolean ring. The idea is the
	following: each variable represents an input or the output of a gate and we want to prove the
	bitwise multiplication of the input bits yields the output, namely the bitwise representation of the
	multiplication of the input (modulo \<^term>\<open>(2::nat)^n\<close> where \<^term>\<open>n::nat\<close> is the number of bits of the
	circuit).

	Algebraic proof systems typically reason over polynomials in a ring $\set K[X]$,
	where the variables $X$ represent Boolean values.
	The aim of an algebraic proof is to derive whether a polynomial $f$ can be derived from a given set of polynomials
	$G = \{g_1,\dots,g_l\} \subseteq \set K[X]$ together with the Boolean value constraints
	$B(X) = \{x^2_i-x_i \mid x_i \in X\}$. In algebraic terms this means to show that the polynomial \<^latex>\<open>$f \in \langle G \cup B(X)\rangle$\<close>.

	In our setting we set $\set K = \set Z$ and we treat the Boolean value constraints implicitly, i.e.,
	we consider proofs in the ring \<^latex>\<open>$\set Z[X]/\langle B(X)\rangle$\<close> to admit shorter proofs



	The checker takes as input 3 files:
	\<^enum> an input file containing all polynomials that are initially present;
	\<^enum> a target (or specification) polynomial ;
	\<^enum> a ``proof'' file to check that contains the proof in PAC format that shows that the specification
	is in the ideal generated by the polynomials present initially.


	Each step of the proof is either an addition of two polynomials previously derived, a multiplication
	from a previously derived polynomial and an arbitrary polynomial, and the deletion a derived
	polynomial.

	One restriction on the proofs compared to generic PAC proofs is that \<^term>\<open>(x::nat)^2 = x\<close> in the
	Boolean ring we are considering.

	The checker can produce two outputs: valid (meaning that each derived polynomial in the proof has
	been correctly derived and the specification polynomial was also derived at some point [either in
	the proof or as input]) or invalid (without proven information what went wrong).


	The development is organised as follows:
	\<^item> \<^file>\<open>PAC_Specification.thy\<close> (this file) contains the specification as described above on ideals
	without any peculiarities on the PAC proof format
	\<^item> \<^file>\<open>PAC_Checker_Specification.thy\<close> specialises to the PAC format and enters the nondeterminism
	monad to prepare the subsequent refinements.
	\<^item> \<^file>\<open>PAC_Checker.thy\<close> contains the refined version where polynomials are represented as lists.
	\<^item> \<^file>\<open>PAC_Checker_Synthesis.thy\<close> contains the efficient implementation with imperative data
	structure like a hash set.
	\<^item> \<^file>\<open>PAC_Checker_MLton.thy\<close> contains the code generation and the command to compile the file with
	the ML compiler MLton.


	Here is an example of a proof and an input file (taken from the appendix of our FMCAD
	paper~\cite{KaufmannFleuryBiere-FMCAD20}, available at \<^url>\<open>http://fmv.jku.at/pacheck_pasteque\<close>):
	\<^verbatim>\<open>
	<res.input> <res.proof>
	1 x*y; 3 = fz, -z+1;
	2 yz-y-z+1; 4 3, y-1, -fzy+fz-yz+y+z-1;
	5 + 2, 4, -fz*y+fz;
	2 d;
	4 d;
	<res.target> 6 * 1, fz, fzxy;
	-x*z+x; 1 d;
	7 * 5, x, -fzxy+fz*x;
	8 + 6, 7, fz*x;
	9 * 3, x, -fzx-xz+x;
	10 + 8, 9, -x*z+x;
	\<close>

	Each line starts with a number that is used to index the (conclusion) polynomial. In the proof,
	there are four kind of steps:
	\<^enum> \<^verbatim>\<open>3 = fz, -z+1;\<close> is an extension that introduces a new variable (in this case \<^verbatim>\<open>fz\<close>);
	\<^enum> \<^verbatim>\<open>4 * 3, y-1, -fzy+fz-yz+y+z-1;\<close> is a multiplication of the existing polynomial with
	index 3 by the arbitrary polynomial \<^verbatim>\<open>y-1\<close> and generates the new polynomial
	\<^verbatim>\<open>-fzy+fz-yz+y+z-1\<close> with index 4;
	\<^enum> \<^verbatim>\<open>5 + 2, 4, -fz*y+fz;\<close> is an addition of the existing polynomials with
	index 2 and 4 and generates the new polynomial \<^verbatim>\<open>-fz*y+fz\<close> with index 5;
	\<^enum> \<^verbatim>\<open>1 d;\<close> deletes the polynomial with index 1 and it cannot be reused in subsequent steps.



	Remark that unlike DRAT checker, we do forward checking and check every derived polynomial. The
	target polynomial can also be part of the input file.
	\<close>

	section \<open>Libraries\<close>

	subsection \<open>More Polynomials\<close>

	text \<open>

	Here are more theorems on polynomials. Most of these facts are
	extremely trivial and should probably be generalised and moved to
	the Isabelle distribution.
	\<close>

	lemma Const\<^sub>0_add:
	\<open>Const\<^sub>0 (a + b) = Const\<^sub>0 a + Const\<^sub>0 b\<close>
	by transfer
	(simp add: Const\<^sub>0_def single_add)

	lemma Const_mult:
	\<open>Const (a * b) = Const a * Const b\<close>
	by transfer (simp add: Const\<^sub>0_def times_monomial_monomial)

	lemma Const\<^sub>0_mult:
	\<open>Const\<^sub>0 (a * b) = Const\<^sub>0 a * Const\<^sub>0 b\<close>
	by transfer (simp add: Const\<^sub>0_def times_monomial_monomial)

	lemma Const0[simp]:
	\<open>Const 0 = 0\<close>
	by transfer (simp add: Const\<^sub>0_def)

	lemma (in -) Const_uminus[simp]:
	\<open>Const (-n) = - Const n\<close>
	by transfer (auto simp: Const\<^sub>0_def monomial_uminus)

	lemma [simp]: \<open>Const\<^sub>0 0 = 0\<close>
	\<open>MPoly 0 = 0\<close>
	by (auto simp: Const\<^sub>0_def zero_mpoly_def)

	lemma Const_add:
	\<open>Const (a + b) = Const a + Const b\<close>
	by transfer (simp add: Const\<^sub>0_def single_add)

	instance mpoly :: (comm_semiring_1) comm_semiring_1
	by standard

	lemma degree_uminus[simp]:
	\<open>degree (-A) x' = degree A x'\<close>
	by (auto simp: degree_def uminus_mpoly.rep_eq)

	lemma degree_sum_notin:
	\<open>x' \<notin> vars B \<Longrightarrow> degree (A + B) x' = degree A x'\<close>
	apply (auto simp: degree_def)
	apply (rule arg_cong[of _ _ Max])
	apply standard+
	apply (auto simp: plus_mpoly.rep_eq UN_I UnE image_iff in_keys_iff subsetD vars_def lookup_add
	dest: keys_add intro: in_keys_plusI1 cong: ball_cong_simp)
	done

	lemma degree_notin_vars:
	\<open>x \<notin> (vars B) \<Longrightarrow> degree (B :: 'a :: {monoid_add} mpoly) x = 0\<close>
	using degree_sum_notin[of x B 0]
	by auto

	lemma not_in_vars_coeff0:
	\<open>x \<notin> vars p \<Longrightarrow> MPoly_Type.coeff p (monomial (Suc 0) x) = 0\<close>
	by (subst not_not[symmetric], subst coeff_keys[symmetric])
	(auto simp: vars_def)

	lemma keys_add':
	"p \<in> keys (f + g) \<Longrightarrow> p \<in> keys f \<union> keys g"
	by transfer auto

	lemma keys_mapping_sum_add:
	\<open>finite A \<Longrightarrow> keys (mapping_of (\<Sum>v \<in> A. f v)) \<subseteq> \<Union>(keys ` mapping_of ` f ` UNIV)\<close>
	by (induction A rule: finite_induct)
	(auto simp add: zero_mpoly.rep_eq plus_mpoly.rep_eq
	keys_plus_ninv_comm_monoid_add dest: keys_add')

	lemma vars_sum_vars_union:
	fixes f :: \<open>int mpoly \<Rightarrow> int mpoly\<close>
	assumes \<open>finite {v. f v \<noteq> 0}\<close>
	shows \<open>vars (\<Sum>v \| f v \<noteq> 0. f v * v) \<subseteq> \<Union>(vars ` {v. f v \<noteq> 0}) \<union> \<Union>(vars ` f ` {v. f v \<noteq> 0})\<close>
	(is \<open>?A \<subseteq> ?B\<close>)
	proof
	fix p
	assume \<open>p \<in> vars (\<Sum>v \| f v \<noteq> 0. f v * v)\<close>
	then obtain x where \<open>x \<in> keys (mapping_of (\<Sum>v \| f v \<noteq> 0. f v * v))\<close> and
	p: \<open>p \<in> keys x\<close>
	by (auto simp: vars_def times_mpoly.rep_eq simp del: keys_mult)
	then have \<open>x \<in> (\<Union>x. keys (mapping_of (f x) * mapping_of x))\<close>
	using keys_mapping_sum_add[of \<open>{v. f v \<noteq> 0}\<close> \<open>\<lambda>x. f x * x\<close>] assms
	by (auto simp: vars_def times_mpoly.rep_eq)
	then have \<open>x \<in> (\<Union>x. {a+b\| a b. a \<in> keys (mapping_of (f x)) \<and> b \<in> keys (mapping_of x)})\<close>
	using Union_mono[OF ] keys_mult by fast
	then show \<open>p \<in> ?B\<close>
	using p by (force simp: vars_def zero_mpoly.rep_eq dest!: keys_add')
	qed


	lemma vars_in_right_only:
	"x \<in> vars q \<Longrightarrow> x \<notin> vars p \<Longrightarrow> x \<in> vars (p+q)"
	unfolding vars_def keys_def plus_mpoly.rep_eq lookup_plus_fun
	apply clarify
	subgoal for xa
	by (auto simp: vars_def keys_def plus_mpoly.rep_eq
	lookup_plus_fun intro!: exI[of _ xa] dest!: spec[of _ xa])
	done

	lemma [simp]:
	\<open>vars 0 = {}\<close>
	by (simp add: vars_def zero_mpoly.rep_eq)


	lemma vars_Un_nointer:
	\<open>keys (mapping_of p) \<inter> keys (mapping_of q) = {} \<Longrightarrow> vars (p + q) = vars p \<union> vars q\<close>
	by (auto simp: vars_def plus_mpoly.rep_eq simp flip: More_MPoly_Type.keys_add dest!: keys_add')

	lemmas [simp] = zero_mpoly.rep_eq

	lemma polynomial_sum_monoms:
	fixes p :: \<open>'a :: {comm_monoid_add,cancel_comm_monoid_add} mpoly\<close>
	shows
	\<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	\<open>keys (mapping_of p) \<subseteq> I \<Longrightarrow> finite I \<Longrightarrow> p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	proof -
	define J where \<open>J \<equiv> keys (mapping_of p)\<close>
	define a where \<open>a x \<equiv> coeff p x\<close> for x
	have \<open>finite (keys (mapping_of p))\<close>
	by auto
	have \<open>p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	if \<open>finite I\<close> and \<open>keys (mapping_of p) \<subseteq> I\<close>
	for I
	using that
	unfolding a_def
	proof (induction I arbitrary: p rule: finite_induct)
	case empty
	then have \<open>p = 0\<close>
	using empty coeff_all_0 coeff_keys by blast
	then show ?case using empty by (auto simp: zero_mpoly.rep_eq)
	next
	case (insert x F) note fin = this(1) and xF = this(2) and IH = this(3) and
	incl = this(4)
	let ?p = \<open>p - MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>
	have H: \<open>\<And>xa. x \<notin> F \<Longrightarrow> xa \<in> F \<Longrightarrow>
	MPoly_Type.monom xa (MPoly_Type.coeff (p - MPoly_Type.monom x (MPoly_Type.coeff p x)) xa) =
	MPoly_Type.monom xa (MPoly_Type.coeff p xa)\<close>
	by (metis (mono_tags, opaque_lifting) add_diff_cancel_right' remove_term_coeff
	remove_term_sum when_def)
	have \<open>?p = (\<Sum>xa\<in>F. MPoly_Type.monom xa (MPoly_Type.coeff ?p xa))\<close>
	apply (rule IH)
	using incl apply -
	by standard (smt Diff_iff Diff_insert_absorb add_diff_cancel_right'
	remove_term_keys remove_term_sum subsetD xF)
	also have \<open>... = (\<Sum>xa\<in>F. MPoly_Type.monom xa (MPoly_Type.coeff p xa))\<close>
	by (use xF in \<open>auto intro!: sum.cong simp: H\<close>)
	finally show ?case
	apply (subst (asm) remove_term_sum[of x p, symmetric])
	apply (subst remove_term_sum[of x p, symmetric])
	using xF fin by (auto simp: ac_simps)
	qed
	from this[of I] this[of J] show
	\<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	\<open>keys (mapping_of p) \<subseteq> I \<Longrightarrow> finite I \<Longrightarrow> p = (\<Sum>x\<in>I. MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	by (auto simp: J_def)
	qed


	lemma vars_mult_monom:
	fixes p :: \<open>int mpoly\<close>
	shows \<open>vars (p * (monom (monomial (Suc 0) x') 1)) = (if p = 0 then {} else insert x' (vars p))\<close>
	proof -

	let ?v = \<open>monom (monomial (Suc 0) x') 1\<close>
	have
	p: \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close> (is \<open>_ = (\<Sum>x \<in> ?I. ?f x)\<close>)
	using polynomial_sum_monoms(1)[of p] .
	have pv: \<open>p * ?v = (\<Sum>x \<in> ?I. ?f x * ?v)\<close>
	by (subst p) (auto simp: field_simps sum_distrib_left)
	define I where \<open>I \<equiv> ?I\<close>
	have in_keysD: \<open>x \<in> keys (mapping_of (\<Sum>x\<in>I. MPoly_Type.monom x (h x))) \<Longrightarrow> x \<in> I\<close>
	if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close> and x
	using that by (induction rule: finite_induct)
	(force simp: monom.rep_eq empty_iff insert_iff keys_single coeff_monom
	simp: coeff_keys simp flip: coeff_add
	simp del: coeff_add)+
	have in_keys: \<open>keys (mapping_of (\<Sum>x\<in>I. MPoly_Type.monom x (h x))) = (\<Union>x \<in> I. (if h x = 0 then {} else {x}))\<close>
	if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close> and x
	supply in_keysD[dest]
	using that by (induction rule: finite_induct)
	(auto simp: plus_mpoly.rep_eq MPoly_Type_Class.keys_plus_eqI)

	have H[simp]: \<open>vars ((\<Sum>x\<in>I. MPoly_Type.monom x (h x))) = (\<Union>x\<in>I. (if h x = 0 then {} else keys x))\<close>
	if \<open>finite I\<close> for I and h :: \<open>_ \<Rightarrow> int\<close>
	using that by (auto simp: vars_def in_keys)

	have sums: \<open>(\<Sum>x\<in>I.
	MPoly_Type.monom (x + a') (c x)) =
	(\<Sum>x\<in> (\<lambda>x. x + a') ` I.
	MPoly_Type.monom x (c (x - a')))\<close>
	if \<open>finite I\<close> for I a' c q
	using that apply (induction rule: finite_induct)
	subgoal by auto
	subgoal
	unfolding image_insert by (subst sum.insert) auto
	done
	have non_zero_keysEx: \<open>p \<noteq> 0 \<Longrightarrow> \<exists>a. a \<in> keys (mapping_of p)\<close> for p :: \<open>int mpoly\<close>
	using mapping_of_inject by (fastforce simp add: ex_in_conv)
	have \<open>finite I\<close> \<open>keys (mapping_of p) \<subseteq> I\<close>
	unfolding I_def by auto
	then show
	\<open>vars (p * (monom (monomial (Suc 0) x') 1)) = (if p = 0 then {} else insert x' (vars p))\<close>
	apply (subst pv, subst I_def[symmetric], subst mult_monom)
	apply (auto simp: mult_monom sums I_def)
	using Poly_Mapping.keys_add vars_def apply fastforce
	apply (auto dest!: non_zero_keysEx)
	apply (rule_tac x= \<open>a + monomial (Suc 0) x'\<close> in bexI)
	apply (auto simp: coeff_keys)
	apply (simp add: in_keys_iff lookup_add)
	apply (auto simp: vars_def)
	apply (rule_tac x= \<open>xa + monomial (Suc 0) x'\<close> in bexI)
	apply (auto simp: coeff_keys)
	apply (simp add: in_keys_iff lookup_add)
	done
	qed


	term \<open>(x', u, lookup u x', A)\<close>
	lemma in_mapping_mult_single:
	\<open>x \<in> (\<lambda>x. lookup x x') ` keys (A * (Var\<^sub>0 x' :: (nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b :: {monoid_mult,zero_neq_one,semiring_0})) \<longleftrightarrow>
	x > 0 \<and> x - 1 \<in> (\<lambda>x. lookup x x') ` keys (A)\<close>
	apply (standard+; clarify)
	subgoal
	apply (auto elim!: in_keys_timesE simp: lookup_add)
	apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff)
	done
	subgoal
	apply (auto elim!: in_keys_timesE simp: lookup_add)
	apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff)
	done
	subgoal for xa
	apply (auto elim!: in_keys_timesE simp: lookup_add)
	apply (auto simp: keys_def lookup_times_monomial_right Var\<^sub>0_def lookup_single image_iff lookup_add
	intro!: exI[of _ \<open>xa + Poly_Mapping.single x' 1\<close>])
	done
	done

	lemma Max_Suc_Suc_Max:
	\<open>finite A \<Longrightarrow> A \<noteq> {} \<Longrightarrow> Max (insert 0 (Suc ` A)) =
	Suc (Max (insert 0 A))\<close>
	by (induction rule: finite_induct)
	(auto simp: hom_Max_commute)

	lemma [simp]:
	\<open>keys (Var\<^sub>0 x' :: ('a \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b :: {zero_neq_one}) = {Poly_Mapping.single x' 1}\<close>
	by (auto simp: Var\<^sub>0_def)


	lemma degree_mult_Var:
	\<open>degree (A * Var x') x' = (if A = 0 then 0 else Suc (degree A x'))\<close> for A :: \<open>int mpoly\<close>
	proof -
	have [simp]: \<open>A \<noteq> 0 \<Longrightarrow>
	Max (insert 0 ((\<lambda>x. Suc (lookup x x')) ` keys (mapping_of A))) =
	Max (insert (Suc 0) ((\<lambda>x. Suc (lookup x x')) ` keys (mapping_of A)))\<close>
	unfolding image_image[of Suc \<open>\<lambda>x. lookup x x'\<close>, symmetric] image_insert[symmetric]
	by (subst Max_Suc_Suc_Max, use mapping_of_inject in fastforce, use mapping_of_inject in fastforce)+
	(simp add: Max.hom_commute)
	have \<open>A \<noteq> 0 \<Longrightarrow>
	Max (insert 0
	((\<lambda>x. lookup x x') `
	keys (mapping_of A * mapping_of (Var x')))) =
	Suc (Max (insert 0 ((\<lambda>m. lookup m x') ` keys (mapping_of A))))\<close>
	by (subst arg_cong[of _ \<open>insert 0
	(Suc ` ((\<lambda>x. lookup x x') ` keys (mapping_of A)))\<close> Max])
	(auto simp: image_image Var.rep_eq lookup_plus_fun in_mapping_mult_single
	hom_Max_commute Max_Suc_Suc_Max
	elim!: in_keys_timesE split: if_splits)
	then show ?thesis
	by (auto simp: degree_def times_mpoly.rep_eq
	intro!: arg_cong[of _ \<open>insert 0
	(Suc ` ((\<lambda>x. lookup x x') ` keys (mapping_of A)))\<close> Max])
	qed

	lemma degree_mult_Var':
	\<open>degree (Var x' * A) x' = (if A = 0 then 0 else Suc (degree A x'))\<close> for A :: \<open>int mpoly\<close>
	by (simp add: degree_mult_Var semiring_normalization_rules(7))

	lemma degree_times_le:
	\<open>degree (A * B) x \<le> degree A x + degree B x\<close>
	by (auto simp: degree_def times_mpoly.rep_eq
	max_def lookup_add add_mono
	dest!: set_rev_mp[OF _ Poly_Mapping.keys_add]
	elim!: in_keys_timesE)

	lemma monomial_inj:
	"monomial c s = monomial (d::'b::zero_neq_one) t \<longleftrightarrow> (c = 0 \<and> d = 0) \<or> (c = d \<and> s = t)"
	by (fastforce simp add: monomial_inj Poly_Mapping.single_def
	poly_mapping.Abs_poly_mapping_inject when_def fun_eq_iff
	cong: if_cong
	split: if_splits)

	lemma MPoly_monomial_power':
	\<open>MPoly (monomial 1 x') ^ (n+1) = MPoly (monomial (1) (((\<lambda>x. x + x') ^^ n) x'))\<close>
	by (induction n)
	(auto simp: times_mpoly.abs_eq mult_single ac_simps)

	lemma MPoly_monomial_power:
	\<open>n > 0 \<Longrightarrow> MPoly (monomial 1 x') ^ (n) = MPoly (monomial (1) (((\<lambda>x. x + x') ^^ (n - 1)) x'))\<close>
	using MPoly_monomial_power'[of _ \<open>n-1\<close>]
	by auto


	lemma vars_uminus[simp]:
	\<open>vars (-p) = vars p\<close>
	by (auto simp: vars_def uminus_mpoly.rep_eq)

	lemma coeff_uminus[simp]:
	\<open>MPoly_Type.coeff (-p) x = -MPoly_Type.coeff p x\<close>
	by (auto simp: coeff_def uminus_mpoly.rep_eq)

	definition decrease_key::"'a \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b::{monoid_add, minus,one}) \<Rightarrow> ('a \<Rightarrow>\<^sub>0 'b)" where
	"decrease_key k0 f = Abs_poly_mapping (\<lambda>k. if k = k0 \<and> lookup f k \<noteq> 0 then lookup f k - 1 else lookup f k)"

	lemma remove_key_lookup:
	"lookup (decrease_key k0 f) k = (if k = k0 \<and> lookup f k \<noteq> 0 then lookup f k - 1 else lookup f k)"
	- unfolding decrease_key_def using finite_subset apply (simp add: )
	+ unfolding decrease_key_def using finite_subset apply simp
	apply (subst lookup_Abs_poly_mapping)
	apply (auto intro: finite_subset[of _ \<open>{x. lookup f x \<noteq> 0}\<close>])
	apply (subst lookup_Abs_poly_mapping)
	apply (auto intro: finite_subset[of _ \<open>{x. lookup f x \<noteq> 0}\<close>])
	done

	lemma polynomial_split_on_var:
	fixes p :: \<open>'a :: {comm_monoid_add,cancel_comm_monoid_add,semiring_0,comm_semiring_1} mpoly\<close>
	obtains q r where
	\<open>p = monom (monomial (Suc 0) x') 1 * q + r\<close> and
	\<open>x' \<notin> vars r\<close>
	proof -
	have [simp]: \<open>{x \<in> keys (mapping_of p). x' \<in> keys x} \<union>
	{x \<in> keys (mapping_of p). x' \<notin> keys x} = keys (mapping_of p)\<close>
	by auto
	have
	\<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close> (is \<open>_ = (\<Sum>x \<in> ?I. ?f x)\<close>)
	using polynomial_sum_monoms(1)[of p] .
	also have \<open>... = (\<Sum>x\<in> {x \<in> ?I. x' \<in> keys x}. ?f x) + (\<Sum>x\<in> {x \<in> ?I. x' \<notin> keys x}. ?f x)\<close> (is \<open>_ = ?pX + ?qX\<close>)
	by (subst comm_monoid_add_class.sum.union_disjoint[symmetric]) auto
	finally have 1: \<open>p = ?pX + ?qX\<close> .
	have H: \<open>0 < lookup x x' \<Longrightarrow> (\<lambda>k. (if x' = k then Suc 0 else 0) +
	(if k = x' \<and> 0 < lookup x k then lookup x k - 1
	else lookup x k)) = lookup x\<close> for x x'
	by auto
	have [simp]: \<open>finite {x. 0 < (Suc 0 when x' = x)}\<close> for x' :: nat and x
	by (smt bounded_nat_set_is_finite lessI mem_Collect_eq neq0_conv when_cong when_neq_zero)
	have H: \<open>x' \<in> keys x \<Longrightarrow> monomial (Suc 0) x' + Abs_poly_mapping (\<lambda>k. if k = x' \<and> 0 < lookup x k then lookup x k - 1 else lookup x k) = x\<close>
	for x and x' :: nat
	apply (simp only: keys_def single.abs_eq)
	apply (subst plus_poly_mapping.abs_eq)
	by (auto simp: eq_onp_def when_def H
	intro!: finite_subset[of \<open>{xa. (xa = x' \<and> 0 < lookup x xa \<longrightarrow> Suc 0 < lookup x x') \<and>
	(xa \<noteq> x' \<longrightarrow> 0 < lookup x xa)}\<close> \<open>{xa. 0 < lookup x xa}\<close>])

	have [simp]: \<open>x' \<in> keys x \<Longrightarrow>
	MPoly_Type.monom (monomial (Suc 0) x' + decrease_key x' x) n =
	MPoly_Type.monom x n\<close> for x n and x'
	apply (subst mpoly.mapping_of_inject[symmetric], subst poly_mapping.lookup_inject[symmetric])
	unfolding mapping_of_monom lookup_single
	apply (auto intro!: ext simp: decrease_key_def when_def H)
	done
	have pX: \<open>?pX = monom (monomial (Suc 0) x') 1 * (\<Sum>x\<in> {x \<in> ?I. x' \<in> keys x}. MPoly_Type.monom (decrease_key x' x) (MPoly_Type.coeff p x))\<close>
	(is \<open>_ = _ * ?pX'\<close>)
	by (subst sum_distrib_left, subst mult_monom)
	(auto intro!: sum.cong)
	have \<open>x' \<notin> vars ?qX\<close>
	using vars_setsum[of \<open>{x. x \<in> keys (mapping_of p) \<and> x' \<notin> keys x}\<close> \<open>?f\<close>]
	by (auto dest!: vars_monom_subset[unfolded subset_eq Ball_def, rule_format])
	then show ?thesis
	using that[of ?pX' ?qX]
	unfolding pX[symmetric] 1[symmetric]
	by blast
	qed


	lemma polynomial_split_on_var2:
	fixes p :: \<open>int mpoly\<close>
	assumes \<open>x' \<notin> vars s\<close>
	obtains q r where
	\<open>p = (monom (monomial (Suc 0) x') 1 - s) * q + r\<close> and
	\<open>x' \<notin> vars r\<close>
	proof -
	have eq[simp]: \<open>monom (monomial (Suc 0) x') 1 = Var x'\<close>
	by (simp add: Var.abs_eq Var\<^sub>0_def monom.abs_eq)
	have \<open>\<forall>m \<le> n. \<forall>P::int mpoly. degree P x' < m \<longrightarrow> (\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B)\<close> for n
	proof (induction n)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then have IH: \<open>m\<le>n \<Longrightarrow> MPoly_Type.degree P x' < m \<Longrightarrow>
	(\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B)\<close> for m P
	by fast
	show ?case
	proof (intro allI impI)
	fix m and P :: \<open>int mpoly\<close>
	assume \<open>m \<le> Suc n\<close> and deg: \<open>MPoly_Type.degree P x' < m\<close>
	consider
	\<open>m \<le> n\<close> \|
	\<open>m = Suc n\<close>
	using \<open>m \<le> Suc n\<close> by linarith
	then show \<open>\<exists>A B. P = (Var x' - s) * A + B \<and> x' \<notin> vars B\<close>
	proof cases
	case 1
	then show \<open>?thesis\<close>
	using Suc deg by blast
	next
	case [simp]: 2
	obtain A B where
	P: \<open>P = Var x' * A + B\<close> and
	\<open>x' \<notin> vars B\<close>
	using polynomial_split_on_var[of P x'] unfolding eq by blast
	have P': \<open>P = (Var x' - s) * A + (s * A + B)\<close>
	by (auto simp: field_simps P)
	have \<open>A = 0 \<or> degree (s * A) x' < degree P x'\<close>
	using deg \<open>x' \<notin> vars B\<close> \<open>x' \<notin> vars s\<close> degree_times_le[of s A x'] deg
	unfolding P
	by (auto simp: degree_sum_notin degree_mult_Var' degree_mult_Var degree_notin_vars
	split: if_splits)
	then obtain A' B' where
	sA: \<open>sA = (Var x' - s) A' + B'\<close> and
	\<open>x' \<notin> vars B'\<close>
	using IH[of \<open>m-1\<close> \<open>s*A\<close>] deg \<open>x' \<notin> vars B\<close> that[of 0 0]
	by (cases \<open>0 < n\<close>) (auto dest!: vars_in_right_only)
	have \<open>P = (Var x' - s) * (A + A') + (B' + B)\<close>
	unfolding P' sA by (auto simp: field_simps)
	moreover have \<open>x' \<notin> vars (B' + B)\<close>
	using \<open>x' \<notin> vars B'\<close> \<open>x' \<notin> vars B\<close>
	by (meson UnE subset_iff vars_add)
	ultimately show ?thesis
	by fast
	qed
	qed
	qed
	then show ?thesis
	using that unfolding eq
	by blast
	qed

	lemma finit_whenI[intro]:
	\<open>finite {x. (0 :: nat) < (y x)} \<Longrightarrow> finite {x. 0 < (y x when x \<noteq> x')}\<close>
	apply (rule finite_subset)
	defer apply assumption
	apply (auto simp: when_def)
	done

	lemma polynomial_split_on_var_diff_sq2:
	fixes p :: \<open>int mpoly\<close>
	obtains q r s where
	\<open>p = monom (monomial (Suc 0) x') 1 * q + r + s * (monom (monomial (Suc 0) x') 1^2 - monom (monomial (Suc 0) x') 1)\<close> and
	\<open>x' \<notin> vars r\<close> and
	\<open>x' \<notin> vars q\<close>
	proof -
	let ?v = \<open>monom (monomial (Suc 0) x') 1 :: int mpoly\<close>
	have H: \<open>n < m \<Longrightarrow> n > 0 \<Longrightarrow> \<exists>q. ?v^n = ?v + q * (?v^2 - ?v)\<close> for n m :: nat
	proof (induction m arbitrary: n)
	case 0
	then show ?case by auto
	next
	case (Suc m n) note IH = this(1-)
	consider
	\<open>n < m\<close> \|
	\<open>m = n\<close> \<open>n > 1\<close> \|
	\<open>n = 1\<close>
	using IH
	by (cases \<open>n < m\<close>; cases n) auto
	then show ?case
	proof cases
	case 1
	then show ?thesis using IH by auto
	next
	case 2
	have eq: \<open>?v^(n) = ((?v :: int mpoly) ^ (n-2)) * (?v^2-?v) + ?v^(n-1)\<close>
	using 2 by (auto simp: field_simps power_eq_if
	ideal.scale_right_diff_distrib)
	obtain q where
	q: \<open>?v^(n-1) = ?v + q * (?v^2 - ?v)\<close>
	using IH(1)[of \<open>n-1\<close>] 2
	by auto
	show ?thesis
	using q unfolding eq
	by (auto intro!: exI[of _ \<open>?v ^ (n - 2) + q\<close>] simp: distrib_right)
	next
	case 3
	then show \<open>?thesis\<close>
	by auto
	qed
	qed
	have H: \<open>n>0 \<Longrightarrow> \<exists>q. ?v^n = ?v + q * (?v^2-?v)\<close> for n
	using H[of n \<open>n+1\<close>]
	by auto
	obtain qr :: \<open>nat \<Rightarrow> int mpoly\<close> where
	qr: \<open>n > 0 \<Longrightarrow> ?v^n = ?v + qr n * (?v^2-?v)\<close> for n
	using H by metis
	have vn: \<open>(if lookup x x' = 0 then 1 else Var x' ^ lookup x x') =
	(if lookup x x' = 0 then 1 else ?v) + (if lookup x x' = 0 then 0 else 1) * qr (lookup x x') * (?v^2-?v)\<close> for x
	by (simp add: qr[symmetric] Var_def Var\<^sub>0_def monom.abs_eq[symmetric] cong: if_cong)

	have q: \<open>p = (\<Sum>x\<in>keys (mapping_of p). MPoly_Type.monom x (MPoly_Type.coeff p x))\<close>
	by (rule polynomial_sum_monoms(1)[of p])
	have [simp]:
	\<open>lookup x x' = 0 \<Longrightarrow>
	Abs_poly_mapping (\<lambda>k. lookup x k when k \<noteq> x') = x\<close> for x
	by (cases x, auto simp: poly_mapping.Abs_poly_mapping_inject)
	(auto intro!: ext simp: when_def)
	have [simp]: \<open>finite {x. 0 < (a when x' = x)}\<close> for a :: nat
	by (metis (no_types, lifting) infinite_nat_iff_unbounded less_not_refl lookup_single lookup_single_not_eq mem_Collect_eq)

	have [simp]: \<open>((\<lambda>x. x + monomial (Suc 0) x') ^^ (n))
	(monomial (Suc 0) x') = Abs_poly_mapping (\<lambda>k. (if k = x' then n+1 else 0))\<close> for n
	by (induction n)
	(auto simp: single_def Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def cong:if_cong)
	have [simp]: \<open>0 < lookup x x' \<Longrightarrow>
	Abs_poly_mapping (\<lambda>k. lookup x k when k \<noteq> x') +
	Abs_poly_mapping (\<lambda>k. if k = x' then lookup x x' - Suc 0 + 1 else 0) =
	x\<close> for x
	apply (cases x, auto simp: poly_mapping.Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def)
	apply (subst plus_poly_mapping.abs_eq)
	apply (auto simp: poly_mapping.Abs_poly_mapping_inject plus_poly_mapping.abs_eq eq_onp_def)
	apply (subst Abs_poly_mapping_inject)
	apply auto
	done
	define f where
	\<open>f x = (MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)) *
	(if lookup x x' = 0 then 1 else Var x' ^ (lookup x x'))\<close> for x
	have f_alt_def: \<open>f x = MPoly_Type.monom x (MPoly_Type.coeff p x)\<close> for x
	by (auto simp: f_def monom_def remove_key_def Var_def MPoly_monomial_power Var\<^sub>0_def
	mpoly.MPoly_inject monomial_inj times_mpoly.abs_eq
	times_mpoly.abs_eq mult_single)
	have p: \<open>p = (\<Sum>x\<in>keys (mapping_of p).
	MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
	(if lookup x x' = 0 then 1 else ?v)) +
	(\<Sum>x\<in>keys (mapping_of p).
	MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
	(if lookup x x' = 0 then 0
	else 1) * qr (lookup x x')) *
	(?v\<^sup>2 - ?v)\<close>
	(is \<open>_ = ?a + ?v2v\<close>)
	apply (subst q)
	unfolding f_alt_def[symmetric, abs_def] f_def vn semiring_class.distrib_left
	comm_semiring_1_class.semiring_normalization_rules(18) semiring_0_class.sum_distrib_right
	by (simp add: semiring_class.distrib_left
	sum.distrib)

	have I: \<open>keys (mapping_of p) = {x \<in> keys (mapping_of p). lookup x x' = 0} \<union> {x \<in> keys (mapping_of p). lookup x x' \<noteq> 0}\<close>
	by auto

	have \<open>p = (\<Sum>x \| x \<in> keys (mapping_of p) \<and> lookup x x' = 0.
	MPoly_Type.monom x (MPoly_Type.coeff p x)) +
	(\<Sum>x \| x \<in> keys (mapping_of p) \<and> lookup x x' \<noteq> 0.
	MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)) *
	(MPoly_Type.monom (monomial (Suc 0) x') 1) +
	(\<Sum>x \| x \<in> keys (mapping_of p) \<and> lookup x x' \<noteq> 0.
	MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
	qr (lookup x x')) *
	(?v\<^sup>2 - ?v)\<close>
	(is \<open>p = ?A + ?B * _ + ?C * _\<close>)
	unfolding semiring_0_class.sum_distrib_right[of _ _ \<open>(MPoly_Type.monom (monomial (Suc 0) x') 1)\<close>]
	apply (subst p)
	apply (subst (2)I)
	apply (subst I)
	apply (subst comm_monoid_add_class.sum.union_disjoint)
	apply auto[3]
	apply (subst comm_monoid_add_class.sum.union_disjoint)
	apply auto[3]
	apply (subst (4) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
	qr (lookup x x')\<close>])
	apply (auto; fail)
	apply (subst (3) sum.cong[OF refl, of _ _ \<open>\<lambda>x. 0\<close>])
	apply (auto; fail)
	apply (subst (2) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x) *
	(MPoly_Type.monom (monomial (Suc 0) x') 1)\<close>])
	apply (auto; fail)
	apply (subst (1) sum.cong[OF refl, of _ _ \<open>\<lambda>x. MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>])
	by (auto simp: f_def simp flip: f_alt_def)

	moreover have \<open>x' \<notin> vars ?A\<close>
	using vars_setsum[of \<open>{x \<in> keys (mapping_of p). lookup x x' = 0}\<close>
	\<open>\<lambda>x. MPoly_Type.monom x (MPoly_Type.coeff p x)\<close>]
	apply auto
	apply (drule set_rev_mp, assumption)
	apply (auto dest!: lookup_eq_zero_in_keys_contradict)
	by (meson lookup_eq_zero_in_keys_contradict subsetD vars_monom_subset)
	moreover have \<open>x' \<notin> vars ?B\<close>
	using vars_setsum[of \<open>{x \<in> keys (mapping_of p). lookup x x' \<noteq> 0}\<close>
	\<open>\<lambda>x. MPoly_Type.monom (remove_key x' x) (MPoly_Type.coeff p x)\<close>]
	apply auto
	apply (drule set_rev_mp, assumption)
	apply (auto dest!: lookup_eq_zero_in_keys_contradict)
	apply (drule subsetD[OF vars_monom_subset])
	apply (auto simp: remove_key_keys[symmetric])
	done
	ultimately show ?thesis apply -
	apply (rule that[of ?B ?A ?C])
	apply (auto simp: ac_simps)
	done
	qed


	lemma polynomial_decomp_alien_var:
	fixes q A b :: \<open>int mpoly\<close>
	assumes
	q: \<open>q = A * (monom (monomial (Suc 0) x') 1) + b\<close> and
	x: \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars b\<close>
	shows
	\<open>A = 0\<close> and
	\<open>q = b\<close>
	proof -
	let ?A = \<open>A * (monom (monomial (Suc 0) x') 1)\<close>
	have \<open>?A = q - b\<close>
	using arg_cong[OF q, of \<open>\<lambda>a. a - b\<close>]
	by auto
	moreover have \<open>x' \<notin> vars (q - b)\<close>
	using x vars_in_right_only
	by fastforce
	ultimately have \<open>x' \<notin> vars (?A)\<close>
	by simp
	then have \<open>?A = 0\<close>
	by (auto simp: vars_mult_monom split: if_splits)
	moreover have \<open>?A = 0 \<Longrightarrow> A = 0\<close>
	by (metis empty_not_insert mult_zero_left vars_mult_monom)
	ultimately show \<open>A = 0\<close>
	by blast
	then show \<open>q = b\<close>
	using q by auto
	qed

	lemma polynomial_decomp_alien_var2:
	fixes q A b :: \<open>int mpoly\<close>
	assumes
	q: \<open>q = A * (monom (monomial (Suc 0) x') 1 + p) + b\<close> and
	x: \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars b\<close> \<open>x' \<notin> vars p\<close>
	shows
	\<open>A = 0\<close> and
	\<open>q = b\<close>
	proof -
	let ?x = \<open>monom (monomial (Suc 0) x') 1\<close>
	have x'[simp]: \<open>?x = Var x'\<close>
	by (simp add: Var.abs_eq Var\<^sub>0_def monom.abs_eq)
	have \<open>\<exists>n Ax A'. A = ?x * Ax + A' \<and> x' \<notin> vars A' \<and> degree Ax x' = n\<close>
	using polynomial_split_on_var[of A x'] by metis
	from wellorder_class.exists_least_iff[THEN iffD1, OF this] obtain Ax A' n where
	A: \<open>A = Ax * ?x + A'\<close> and
	\<open>x' \<notin> vars A'\<close> and
	n: \<open>MPoly_Type.degree Ax x' = n\<close> and
	H: \<open>\<And>m Ax A'. m < n \<longrightarrow>
	A \<noteq> Ax * MPoly_Type.monom (monomial (Suc 0) x') 1 + A' \<or>
	x' \<in> vars A' \<or> MPoly_Type.degree Ax x' \<noteq> m\<close>
	unfolding wellorder_class.exists_least_iff[of \<open>\<lambda>n. \<exists>Ax A'. A = Ax * ?x + A' \<and> x' \<notin> vars A' \<and>
	degree Ax x' = n\<close>]
	by (auto simp: field_simps)

	have \<open>q = (A + Ax * p) * monom (monomial (Suc 0) x') 1 + (p * A' + b)\<close>
	unfolding q A by (auto simp: field_simps)
	moreover have \<open>x' \<notin> vars q\<close> \<open>x' \<notin> vars (p * A' + b)\<close>
	using x \<open>x' \<notin> vars A'\<close>
	by (smt UnE add.assoc add.commute calculation subset_iff vars_in_right_only vars_mult)+
	ultimately have \<open>A + Ax * p = 0\<close> \<open>q = p * A' + b\<close>
	by (rule polynomial_decomp_alien_var)+

	have A': \<open>A' = -Ax * ?x - Ax * p\<close>
	using \<open>A + Ax * p = 0\<close> unfolding A
	by (metis (no_types, lifting) add_uminus_conv_diff eq_neg_iff_add_eq_0 minus_add_cancel
	mult_minus_left)

	have \<open>A = - (Ax * p)\<close>
	using A unfolding A'
	apply auto
	done

	obtain Axx Ax' where
	Ax: \<open>Ax = ?x * Axx + Ax'\<close> and
	\<open>x' \<notin> vars Ax'\<close>
	using polynomial_split_on_var[of Ax x'] by metis

	have \<open>A = ?x * (- Axx * p) + (- Ax' * p)\<close>
	unfolding \<open>A = - (Ax * p)\<close> Ax
	by (auto simp: field_simps)

	moreover have \<open>x' \<notin> vars (-Ax' * p)\<close>
	using \<open>x' \<notin> vars Ax'\<close> by (metis (no_types, opaque_lifting) UnE add.right_neutral
	add_minus_cancel assms(4) subsetD vars_in_right_only vars_mult)
	moreover have \<open>Axx \<noteq> 0 \<Longrightarrow> MPoly_Type.degree (- Axx * p) x' < degree Ax x'\<close>
	using degree_times_le[of Axx p x'] x
	by (auto simp: Ax degree_sum_notin \<open>x' \<notin> vars Ax'\<close> degree_mult_Var'
	degree_notin_vars)
	ultimately have [simp]: \<open>Axx = 0\<close>
	using H[of \<open>MPoly_Type.degree (- Axx * p) x'\<close> \<open>- Axx * p\<close> \<open>- Ax' * p\<close>]
	by (auto simp: n)
	then have [simp]: \<open>Ax' = Ax\<close>
	using Ax by auto

	show \<open>A = 0\<close>
	using A \<open>A = - (Ax * p)\<close> \<open>x' \<notin> vars (- Ax' * p)\<close> \<open>x' \<notin> vars A'\<close> polynomial_decomp_alien_var(1) by force
	then show \<open>q = b\<close>
	using q by auto
	qed

	lemma vars_unE: \<open>x \<in> vars (a * b) \<Longrightarrow> (x \<in> vars a \<Longrightarrow> thesis) \<Longrightarrow> (x \<in> vars b \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
	using vars_mult[of a b] by auto


	lemma in_keys_minusI1:
	assumes "t \<in> keys p" and "t \<notin> keys q"
	shows "t \<in> keys (p - q)"
	using assms unfolding in_keys_iff lookup_minus by simp

	lemma in_keys_minusI2:
	fixes t :: \<open>'a\<close> and q :: \<open>'a \<Rightarrow>\<^sub>0 'b :: {cancel_comm_monoid_add,group_add}\<close>
	assumes "t \<in> keys q" and "t \<notin> keys p"
	shows "t \<in> keys (p - q)"
	using assms unfolding in_keys_iff lookup_minus by simp


	lemma in_vars_addE:
	\<open>x \<in> vars (p + q) \<Longrightarrow> (x \<in> vars p \<Longrightarrow> thesis) \<Longrightarrow> (x \<in> vars q \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>
	by (meson UnE in_mono vars_add)

	lemma lookup_monomial_If:
	\<open>lookup (monomial v k) = (\<lambda>k'. if k = k' then v else 0)\<close>
	by (intro ext) (auto simp: lookup_single_not_eq)

	lemma vars_mult_Var:
	\<open>vars (Var x * p) = (if p = 0 then {} else insert x (vars p))\<close> for p :: \<open>int mpoly\<close>
	proof -
	have \<open>p \<noteq> 0 \<Longrightarrow>
	\<exists>xa. (\<exists>k. xa = monomial (Suc 0) x + k) \<and>
	lookup (mapping_of p) (xa - monomial (Suc 0) x) \<noteq> 0 \<and>
	0 < lookup xa x\<close>
	by (metis (no_types, opaque_lifting) One_nat_def ab_semigroup_add_class.add.commute
	add_diff_cancel_right' aux lookup_add lookup_single_eq mapping_of_inject
	neq0_conv one_neq_zero plus_eq_zero_2 zero_mpoly.rep_eq)
	then show ?thesis
	apply (auto simp: vars_def times_mpoly.rep_eq Var.rep_eq
	elim!: in_keys_timesE dest: keys_add')
	apply (auto simp: keys_def lookup_times_monomial_left Var.rep_eq Var\<^sub>0_def adds_def
	lookup_add eq_diff_eq'[symmetric])
	done
	qed

	lemma keys_mult_monomial:
	\<open>keys (monomial (n :: int) k * mapping_of a) = (if n = 0 then {} else ((+) k) ` keys (mapping_of a))\<close>
	proof -
	have [simp]: \<open>(\<Sum>aa. (if k = aa then n else 0) *
	(\<Sum>q. lookup (mapping_of a) q when k + xa = aa + q)) =
	(\<Sum>aa. (if k = aa then n * (\<Sum>q. lookup (mapping_of a) q when k + xa = aa + q) else 0))\<close>
	for xa
	by (smt Sum_any.cong mult_not_zero)
	show ?thesis
	apply (auto simp: vars_def times_mpoly.rep_eq Const.rep_eq times_poly_mapping.rep_eq
	Const\<^sub>0_def elim!: in_keys_timesE split: if_splits)
	apply (auto simp: lookup_monomial_If prod_fun_def
	keys_def times_poly_mapping.rep_eq)
	done
	qed

	lemma vars_mult_Const:
	\<open>vars (Const n * a) = (if n = 0 then {} else vars a)\<close> for a :: \<open>int mpoly\<close>
	by (auto simp: vars_def times_mpoly.rep_eq Const.rep_eq keys_mult_monomial
	Const\<^sub>0_def elim!: in_keys_timesE split: if_splits)

	lemma coeff_minus: "coeff p m - coeff q m = coeff (p-q) m"
	by (simp add: coeff_def lookup_minus minus_mpoly.rep_eq)

	lemma Const_1_eq_1: \<open>Const (1 :: int) = (1 :: int mpoly)\<close>
	by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly.abs_eq)

	lemma [simp]:
	\<open>vars (1 :: int mpoly) = {}\<close>
	by (auto simp: vars_def one_mpoly.rep_eq Const_1_eq_1)


	subsection \<open>More Ideals\<close>

	lemma
	fixes A :: \<open>(('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'a::comm_ring_1) set\<close>
	assumes \<open>p \<in> ideal A\<close>
	shows \<open>p * q \<in> ideal A\<close>
	by (metis assms ideal.span_scale semiring_normalization_rules(7))


	text \<open>The following theorem is very close to @{thm ideal.span_insert}, except that it
	is more useful if we need to take an element of \<^term>\<open>More_Modules.ideal (insert a S)\<close>.\<close>
	lemma ideal_insert':
	\<open>More_Modules.ideal (insert a S) = {y. \<exists>x k. y = x + k * a \<and> x \<in> More_Modules.ideal S}\<close>
	apply (auto simp: ideal.span_insert
	intro: exI[of _ \<open>_ - k * a\<close>])
	apply (rule_tac x = \<open>x - k * a\<close> in exI)
	apply auto
	apply (rule_tac x = \<open>k\<close> in exI)
	apply auto
	done

	lemma ideal_mult_right_in:
	\<open>a \<in> ideal A \<Longrightarrow> a * b \<in> More_Modules.ideal A\<close>
	by (metis ideal.span_scale mult.commute)

	lemma ideal_mult_right_in2:
	\<open>a \<in> ideal A \<Longrightarrow> b * a \<in> More_Modules.ideal A\<close>
	by (metis ideal.span_scale)


	lemma [simp]: \<open>vars (Var x :: 'a :: {zero_neq_one} mpoly) = {x}\<close>
	by (auto simp: vars_def Var.rep_eq Var\<^sub>0_def)

	lemma vars_minus_Var_subset:
	\<open>vars (p' - Var x :: 'a :: {ab_group_add,one,zero_neq_one} mpoly) \<subseteq> \<V> \<Longrightarrow> vars p' \<subseteq> insert x \<V>\<close>
	using vars_add[of \<open>p' - Var x\<close> \<open>Var x\<close>]
	by auto

	lemma vars_add_Var_subset:
	\<open>vars (p' + Var x :: 'a :: {ab_group_add,one,zero_neq_one} mpoly) \<subseteq> \<V> \<Longrightarrow> vars p' \<subseteq> insert x \<V>\<close>
	using vars_add[of \<open>p' + Var x\<close> \<open>-Var x\<close>]
	by auto

	lemma coeff_monomila_in_varsD:
	\<open>coeff p (monomial (Suc 0) x) \<noteq> 0 \<Longrightarrow> x \<in> vars (p :: int mpoly)\<close>
	by (auto simp: coeff_def vars_def keys_def
	intro!: exI[of _ \<open>monomial (Suc 0) x\<close>])

	lemma coeff_MPoly_monomial[simp]:
	\<open>(MPoly_Type.coeff (MPoly (monomial a m)) m) = a\<close>
	by (metis MPoly_Type.coeff_def lookup_single_eq monom.abs_eq monom.rep_eq)

	end
	\ No newline at end of file
	diff --git a/thys/Planarity_Certificates/Planarity/Graph_Genus.thy b/thys/Planarity_Certificates/Planarity/Graph_Genus.thy
	--- a/thys/Planarity_Certificates/Planarity/Graph_Genus.thy
	+++ b/thys/Planarity_Certificates/Planarity/Graph_Genus.thy
	@@ -1,538 +1,538 @@
	theory Graph_Genus
	imports
	"HOL-Combinatorics.Permutations"
	Graph_Theory.Graph_Theory
	begin

	lemma nat_diff_mod_right:
	fixes a b c :: nat
	assumes "b < a"
	shows "(a - b) mod c = (a - b mod c) mod c"
	proof -
	from assms have b_mod: "b mod c \<le> a"
	by (metis mod_less_eq_dividend linear not_le order_trans)
	have "int ((a - b) mod c) = (int a - int b mod int c) mod int c"
	using assms by (simp add: zmod_int of_nat_diff mod_simps)
	also have "\<dots> = int ((a - b mod c) mod c)"
	using assms b_mod
	by (simp add: zmod_int [symmetric] of_nat_diff [symmetric])
	finally show ?thesis by simp
	qed

	lemma inj_on_f_imageI:
	assumes "inj_on f S" "\<And>t. t \<in> T \<Longrightarrow> t \<subseteq> S"
	shows "inj_on ((`) f) T"
	using assms by (auto simp: inj_on_image_eq_iff intro: inj_onI)



	section \<open>Combinatorial Maps\<close>

	lemma (in bidirected_digraph) has_dom_arev:
	"has_dom arev (arcs G)"
	using arev_dom by (auto simp: has_dom_def)

	record 'b pre_map =
	edge_rev :: "'b \<Rightarrow> 'b"
	edge_succ :: "'b \<Rightarrow> 'b"

	definition edge_pred :: "'b pre_map \<Rightarrow> 'b \<Rightarrow> 'b" where
	"edge_pred M = inv (edge_succ M)"


	locale pre_digraph_map = pre_digraph + fixes M :: "'b pre_map"

	locale digraph_map = fin_digraph G
	+ pre_digraph_map G M
	+ bidirected_digraph G "edge_rev M" for G M +
	assumes edge_succ_permutes: "edge_succ M permutes arcs G"
	assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"

	lemma (in fin_digraph) digraph_mapI:
	assumes bidi: "\<And>a. a \<notin> arcs G \<Longrightarrow> edge_rev M a = a"
	"\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M a \<noteq> a"
	"\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M (edge_rev M a) = a"
	"\<And>a. a \<in> arcs G \<Longrightarrow> tail G (edge_rev M a) = head G a"
	assumes edge_succ_permutes: "edge_succ M permutes arcs G"
	assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"
	shows "digraph_map G M"
	using assms by unfold_locales auto

	lemma (in fin_digraph) digraph_mapI_permutes:
	assumes bidi: "edge_rev M permutes arcs G"
	"\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M a \<noteq> a"
	"\<And>a. a \<in> arcs G \<Longrightarrow> edge_rev M (edge_rev M a) = a"
	"\<And>a. a \<in> arcs G \<Longrightarrow> tail G (edge_rev M a) = head G a"
	assumes edge_succ_permutes: "edge_succ M permutes arcs G"
	assumes edge_succ_cyclic: "\<And>v. v \<in> verts G \<Longrightarrow> out_arcs G v \<noteq> {} \<Longrightarrow> cyclic_on (edge_succ M) (out_arcs G v)"
	shows "digraph_map G M"
	proof -
	interpret bidirected_digraph G "edge_rev M" using bidi by unfold_locales (auto simp: permutes_def)
	show ?thesis
	using edge_succ_permutes edge_succ_cyclic by unfold_locales
	qed


	context digraph_map
	begin

	lemma digraph_map[intro]: "digraph_map G M" by unfold_locales

	lemma permutation_edge_succ: "permutation (edge_succ M)"
	by (metis edge_succ_permutes finite_arcs permutation_permutes)

	lemma edge_pred_succ[simp]: "edge_pred M (edge_succ M a) = a"
	by (metis edge_pred_def edge_succ_permutes permutes_inverses(2))

	lemma edge_succ_pred[simp]: "edge_succ M (edge_pred M a) = a"
	by (metis edge_pred_def edge_succ_permutes permutes_inverses(1))

	lemma edge_pred_permutes: "edge_pred M permutes arcs G"
	unfolding edge_pred_def using edge_succ_permutes by (rule permutes_inv)

	lemma permutation_edge_pred: "permutation (edge_pred M)"
	by (metis edge_pred_permutes finite_arcs permutation_permutes)

	lemma edge_succ_eq_iff[simp]: "\<And>x y. edge_succ M x = edge_succ M y \<longleftrightarrow> x = y"
	by (metis edge_pred_succ)

	lemma edge_rev_in_arcs[simp]: "edge_rev M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
	by (metis arev_arev arev_permutes_arcs permutes_not_in)

	lemma edge_succ_in_arcs[simp]: "edge_succ M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
	by (metis edge_pred_succ edge_succ_permutes permutes_not_in)

	lemma edge_pred_in_arcs[simp]: "edge_pred M a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
	by (metis edge_succ_pred edge_pred_permutes permutes_not_in)

	lemma tail_edge_succ[simp]: "tail G (edge_succ M a) = tail G a"
	proof cases
	assume "a \<in> arcs G"
	then have "tail G a \<in> verts G" by auto
	moreover
	then have "out_arcs G (tail G a) \<noteq> {}"
	using \<open>a \<in> arcs G\<close> by auto
	ultimately
	have "cyclic_on (edge_succ M) (out_arcs G (tail G a))"
	by (rule edge_succ_cyclic)
	moreover
	have "a \<in> out_arcs G (tail G a)"
	using \<open>a \<in> arcs G\<close> by simp
	ultimately
	have "edge_succ M a \<in> out_arcs G (tail G a)"
	by (rule cyclic_on_inI)
	then show ?thesis by simp
	next
	assume "a \<notin> arcs G" then show ?thesis using edge_succ_permutes by (simp add: permutes_not_in)
	qed

	lemma tail_edge_pred[simp]: "tail G (edge_pred M a) = tail G a"
	by (metis edge_succ_pred tail_edge_succ)

	lemma bij_edge_succ[intro]: "bij (edge_succ M)"
	using edge_succ_permutes by (simp add: permutes_conv_has_dom)

	lemma edge_pred_cyclic:
	assumes "v \<in> verts G" "out_arcs G v \<noteq> {}"
	shows "cyclic_on (edge_pred M) (out_arcs G v)"
	proof -
	obtain a where orb_a_eq: "orbit (edge_succ M) a = out_arcs G v"
	using edge_succ_cyclic[OF assms] by (auto simp: cyclic_on_def)
	have "cyclic_on (edge_pred M) (orbit (edge_pred M) a)"
	using permutation_edge_pred by (rule cyclic_on_orbit')
	also have "orbit (edge_pred M) a = orbit (edge_succ M) a"
	unfolding edge_pred_def using permutation_edge_succ by (rule orbit_inv_eq)
	finally show "cyclic_on (edge_pred M) (out_arcs G v)" by (simp add: orb_a_eq)
	qed

	definition (in pre_digraph_map) face_cycle_succ :: "'b \<Rightarrow> 'b" where
	"face_cycle_succ \<equiv> edge_succ M o edge_rev M"

	definition (in pre_digraph_map) face_cycle_pred :: "'b \<Rightarrow> 'b" where
	"face_cycle_pred \<equiv> edge_rev M o edge_pred M"

	lemma face_cycle_pred_succ[simp]:
	shows "face_cycle_pred (face_cycle_succ a) = a"
	unfolding face_cycle_pred_def face_cycle_succ_def by simp

	lemma face_cycle_succ_pred[simp]:
	shows "face_cycle_succ (face_cycle_pred a) = a"
	unfolding face_cycle_pred_def face_cycle_succ_def by simp

	lemma tail_face_cycle_succ: "a \<in> arcs G \<Longrightarrow> tail G (face_cycle_succ a) = head G a"
	by (auto simp: face_cycle_succ_def)

	lemma funpow_prop:
	assumes "\<And>x. P (f x) \<longleftrightarrow> P x"
	shows "P ((f ^^ n) x) \<longleftrightarrow> P x"
	- using assms by (induct n) (auto simp: )
	+ using assms by (induct n) auto

	lemma face_cycle_succ_no_arc[simp]: "a \<notin> arcs G \<Longrightarrow> face_cycle_succ a = a"
	by (auto simp: face_cycle_succ_def permutes_not_in[OF arev_permutes_arcs]
	permutes_not_in[OF edge_succ_permutes])

	lemma funpow_face_cycle_succ_no_arc[simp]:
	assumes "a \<notin> arcs G" shows "(face_cycle_succ ^^ n) a = a"
	using assms by (induct n) auto

	lemma funpow_face_cycle_pred_no_arc[simp]:
	assumes "a \<notin> arcs G" shows "(face_cycle_pred ^^ n) a = a"
	using assms
	by (induct n) (auto simp: face_cycle_pred_def permutes_not_in[OF arev_permutes_arcs]
	permutes_not_in[OF edge_pred_permutes])

	lemma face_cycle_succ_closed[simp]:
	"face_cycle_succ a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
	by (metis comp_apply edge_rev_in_arcs edge_succ_in_arcs face_cycle_succ_def)

	lemma face_cycle_pred_closed[simp]:
	"face_cycle_pred a \<in> arcs G \<longleftrightarrow> a \<in> arcs G"
	by (metis face_cycle_succ_closed face_cycle_succ_pred)

	lemma face_cycle_succ_permutes:
	"face_cycle_succ permutes arcs G"
	unfolding face_cycle_succ_def
	using arev_permutes_arcs edge_succ_permutes by (rule permutes_compose)

	lemma permutation_face_cycle_succ: "permutation face_cycle_succ"
	using face_cycle_succ_permutes finite_arcs by (metis permutation_permutes)

	lemma bij_face_cycle_succ: "bij face_cycle_succ"
	using face_cycle_succ_permutes by (simp add: permutes_conv_has_dom)

	lemma face_cycle_pred_permutes:
	"face_cycle_pred permutes arcs G"
	unfolding face_cycle_pred_def
	using edge_pred_permutes arev_permutes_arcs by (rule permutes_compose)

	definition (in pre_digraph_map) face_cycle_set :: "'b \<Rightarrow> 'b set" where
	"face_cycle_set a = orbit face_cycle_succ a"

	definition (in pre_digraph_map) face_cycle_sets :: "'b set set" where
	"face_cycle_sets = face_cycle_set ` arcs G"

	lemma face_cycle_set_altdef: "face_cycle_set a = {(face_cycle_succ ^^ n) a \| n. True}"
	unfolding face_cycle_set_def
	by (intro orbit_altdef_self_in permutation_self_in_orbit permutation_face_cycle_succ)

	lemma face_cycle_set_self[simp, intro]: "a \<in> face_cycle_set a"
	unfolding face_cycle_set_def using permutation_face_cycle_succ by (rule permutation_self_in_orbit)

	lemma empty_not_in_face_cycle_sets: "{} \<notin> face_cycle_sets"
	by (auto simp: face_cycle_sets_def)

	lemma finite_face_cycle_set[simp, intro]: "finite (face_cycle_set a)"
	using face_cycle_set_self unfolding face_cycle_set_def by (simp add: finite_orbit)

	lemma finite_face_cycle_sets[simp, intro]: "finite face_cycle_sets"
	by (auto simp: face_cycle_sets_def)

	lemma face_cycle_set_induct[case_names base step, induct set: face_cycle_set]:
	assumes consume: "a \<in> face_cycle_set x"
	and ih_base: "P x"
	and ih_step: "\<And>y. y \<in> face_cycle_set x \<Longrightarrow> P y \<Longrightarrow> P (face_cycle_succ y)"
	shows "P a"
	using consume unfolding face_cycle_set_def
	by induct (auto simp: ih_step face_cycle_set_def[symmetric] ih_base )

	lemma face_cycle_succ_cyclic:
	"cyclic_on face_cycle_succ (face_cycle_set a)"
	unfolding face_cycle_set_def using permutation_face_cycle_succ by (rule cyclic_on_orbit')

	lemma face_cycle_eq:
	assumes "b \<in> face_cycle_set a" shows "face_cycle_set b = face_cycle_set a"
	using assms unfolding face_cycle_set_def
	by (auto intro: orbit_swap orbit_trans permutation_face_cycle_succ permutation_self_in_orbit)

	lemma face_cycle_succ_in_arcsI: "\<And>a. a \<in> arcs G \<Longrightarrow> face_cycle_succ a \<in> arcs G"
	by (auto simp: face_cycle_succ_def)

	lemma face_cycle_succ_inI: "\<And>x y. x \<in> face_cycle_set y \<Longrightarrow> face_cycle_succ x \<in> face_cycle_set y"
	by (metis face_cycle_succ_cyclic cyclic_on_inI)

	lemma face_cycle_succ_inD: "\<And>x y. face_cycle_succ x \<in> face_cycle_set y \<Longrightarrow> x \<in> face_cycle_set y"
	by (metis face_cycle_eq face_cycle_set_self face_cycle_succ_inI)

	lemma face_cycle_set_parts:
	"face_cycle_set a = face_cycle_set b \<or> face_cycle_set a \<inter> face_cycle_set b = {}"
	by (metis disjoint_iff_not_equal face_cycle_eq)

	definition fc_equiv :: "'b \<Rightarrow> 'b \<Rightarrow> bool" where
	"fc_equiv a b \<equiv> a \<in> face_cycle_set b"

	lemma reflp_fc_equiv: "reflp fc_equiv"
	by (rule reflpI) (simp add: fc_equiv_def)

	lemma symp_fc_equiv: "symp fc_equiv"
	using face_cycle_set_parts
	by (intro sympI) (auto simp: fc_equiv_def)

	lemma transp_fc_equiv: "transp fc_equiv"
	using face_cycle_set_parts
	by (intro transpI) (auto simp: fc_equiv_def)

	lemma "equivp fc_equiv"
	by (intro equivpI reflp_fc_equiv symp_fc_equiv transp_fc_equiv)

	lemma in_face_cycle_setD:
	assumes "y \<in> face_cycle_set x" "x \<in> arcs G" shows "y \<in> arcs G"
	using assms
	by (auto simp: face_cycle_set_def dest: permutes_orbit_subset[OF face_cycle_succ_permutes])

	lemma in_face_cycle_setsD:
	assumes "x \<in> face_cycle_sets" shows "x \<subseteq> arcs G"
	using assms by (auto simp: face_cycle_sets_def dest: in_face_cycle_setD)

	end

	definition (in pre_digraph) isolated_verts :: "'a set" where
	"isolated_verts \<equiv> {v \<in> verts G. out_arcs G v = {}}"

	definition (in pre_digraph_map) euler_char :: int where
	"euler_char \<equiv> int (card (verts G)) - int (card (arcs G) div 2) + int (card face_cycle_sets)"

	definition (in pre_digraph_map) euler_genus :: int where
	"euler_genus \<equiv> (int (2 * card sccs) - int (card isolated_verts) - euler_char) div 2"

	definition comb_planar :: "('a,'b) pre_digraph \<Rightarrow> bool" where
	"comb_planar G \<equiv> \<exists>M. digraph_map G M \<and> pre_digraph_map.euler_genus G M = 0"


	text \<open>Number of isolated vertices is a graph invariant\<close>
	context
	fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
	begin

	interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

	lemma isolated_verts_app_iso[simp]:
	"pre_digraph.isolated_verts (app_iso hom G) = iso_verts hom ` isolated_verts"
	using hom
	by (auto simp: pre_digraph.isolated_verts_def iso_verts_tail inj_image_mem_iff out_arcs_app_iso_eq)

	lemma card_isolated_verts_iso[simp]:
	"card (iso_verts hom ` pre_digraph.isolated_verts G) = card isolated_verts"
	apply (rule card_image)
	using hom apply (rule digraph_isomorphism_inj_on_verts[THEN subset_inj_on])
	apply (auto simp: isolated_verts_def)
	done

	end



	context digraph_map begin

	lemma face_cycle_succ_neq:
	assumes "a \<in> arcs G" "tail G a \<noteq> head G a" shows "face_cycle_succ a \<noteq> a "
	proof -
	from assms have "edge_rev M a \<in> arcs G"
	by (subst edge_rev_in_arcs) simp
	then have "cyclic_on (edge_succ M) (out_arcs G (tail G (edge_rev M a)))"
	by (intro edge_succ_cyclic) (auto dest: tail_in_verts simp: out_arcs_def intro: exI[where x="edge_rev M a"])
	then have "edge_succ M (edge_rev M a) \<in> (out_arcs G (tail G (edge_rev M a)))"
	by (rule cyclic_on_inI) (auto simp: \<open>edge_rev M a \<in> _\<close>[simplified])
	moreover have "tail G (edge_succ M (edge_rev M a)) = head G a"
	using assms by auto
	then have "edge_succ M (edge_rev M a) \<noteq> a" using assms by metis
	ultimately show ?thesis
	using assms by (auto simp: face_cycle_succ_def)
	qed

	end


	section \<open>Maps and Isomorphism\<close>

	definition (in pre_digraph)
	"wrap_iso_arcs hom f = perm_restrict (iso_arcs hom o f o iso_arcs (inv_iso hom)) (arcs (app_iso hom G))"

	definition (in pre_digraph_map) map_iso :: "('a,'b,'a2,'b2) digraph_isomorphism \<Rightarrow> 'b2 pre_map" where
	"map_iso f \<equiv>
	\<lparr> edge_rev = wrap_iso_arcs f (edge_rev M)
	, edge_succ = wrap_iso_arcs f (edge_succ M)
	\<rparr>"

	lemma funcsetI_permutes:
	assumes "f permutes S" shows "f \<in> S \<rightarrow> S"
	by (metis assms funcsetI permutes_in_image)

	context
	fixes G hom assumes hom: "pre_digraph.digraph_isomorphism G hom"
	begin

	interpretation wf_digraph G using hom by (auto simp: pre_digraph.digraph_isomorphism_def)

	lemma wrap_iso_arcs_iso_arcs[simp]:
	assumes "x \<in> arcs G"
	shows "wrap_iso_arcs hom f (iso_arcs hom x) = iso_arcs hom (f x)"
	using assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)

	lemma inj_on_wrap_iso_arcs:
	assumes dom: "\<And>f. f \<in> F \<Longrightarrow> has_dom f (arcs G)"
	assumes funcset: "F \<subseteq> arcs G \<rightarrow> arcs G"
	shows "inj_on (wrap_iso_arcs hom) F"
	proof (rule inj_onI)
	fix f g assume F: "f \<in> F" "g \<in> F" and eq: "wrap_iso_arcs hom f = wrap_iso_arcs hom g"
	{ fix x assume "x \<notin> arcs G"
	then have "f x = x" "g x = x" using F dom by (auto simp: has_dom_def)
	then have "f x = g x" by simp
	}
	moreover
	{ fix x assume "x \<in> arcs G"
	then have "f x \<in> arcs G" "g x \<in> arcs G" using F funcset by auto
	with digraph_isomorphism_inj_on_arcs[OF hom] _
	have "iso_arcs hom (f x) = iso_arcs hom (g x) \<Longrightarrow> f x = g x"
	by (rule inj_onD)
	then have "f x = g x"
	using assms hom \<open>x \<in> arcs G\<close> eq
	by (auto simp: wrap_iso_arcs_def fun_eq_iff perm_restrict_def split: if_splits)
	}
	ultimately show "f = g" by auto
	qed

	lemma inj_on_wrap_iso_arcs_f:
	assumes "A \<subseteq> arcs G" "f \<in> A \<rightarrow> A" "B = iso_arcs hom ` A"
	assumes "inj_on f A" shows "inj_on (wrap_iso_arcs hom f) B"
	proof (rule inj_onI)
	fix x y
	assume in_hom_A: "x \<in> B" "y \<in> B"
	and wia_eq: "wrap_iso_arcs hom f x = wrap_iso_arcs hom f y"
	from in_hom_A \<open>B = _\<close> obtain x0 where x0: "x = iso_arcs hom x0" "x0 \<in> A" by auto
	from in_hom_A \<open>B = _\<close> obtain y0 where y0: "y = iso_arcs hom y0" "y0 \<in> A" by auto
	have arcs_0: "x0 \<in> arcs G" "y0 \<in> arcs G" "f x0 \<in> arcs G" "f y0 \<in> arcs G"
	using x0 y0 \<open>A \<subseteq> _\<close> \<open>f \<in> _\<close> by auto

	have "(iso_arcs hom o f o iso_arcs (inv_iso hom)) x = (iso_arcs hom o f o iso_arcs (inv_iso hom)) y"
	using in_hom_A wia_eq assms(1) \<open>B = _\<close> by (auto simp: wrap_iso_arcs_def perm_restrict_def split: if_splits)
	then show "x = y"
	using hom assms digraph_isomorphism_inj_on_arcs[OF hom] x0 y0 arcs_0 \<open>inj_on f A\<close> \<open>A \<subseteq> _\<close>
	by (auto dest!: inj_onD)
	qed

	lemma wrap_iso_arcs_in_funcsetI:
	assumes "A \<subseteq> arcs G" "f \<in> A \<rightarrow> A"
	shows "wrap_iso_arcs hom f \<in> iso_arcs hom ` A \<rightarrow> iso_arcs hom ` A"
	proof
	fix x assume "x \<in> iso_arcs hom ` A"
	then obtain x0 where "x = iso_arcs hom x0" "x0 \<in> A" by blast
	then have "f x0 \<in> A" using \<open>f \<in> _\<close> by auto
	then show "wrap_iso_arcs hom f x \<in> iso_arcs hom ` A"
	unfolding \<open>x = _\<close> using \<open>x0 \<in> A\<close> assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)
	qed

	lemma wrap_iso_arcs_permutes:
	assumes "A \<subseteq> arcs G" "f permutes A"
	shows "wrap_iso_arcs hom f permutes (iso_arcs hom ` A)"
	proof -
	{ fix x assume A: "x \<notin> iso_arcs hom ` A"
	have "wrap_iso_arcs hom f x = x"
	proof cases
	assume "x \<in> iso_arcs hom ` arcs G"
	then have "iso_arcs (inv_iso hom) x \<notin> A" "x \<in> arcs (app_iso hom G)"
	using A hom by (metis arcs_app_iso image_eqI pre_digraph.iso_arcs_iso_inv, simp)
	then have "f (iso_arcs (inv_iso hom) x) = (iso_arcs (inv_iso hom) x)"
	using \<open>f permutes A\<close> by (simp add: permutes_not_in)
	then show ?thesis using hom assms \<open>x \<in> arcs _\<close>
	by (simp add: wrap_iso_arcs_def perm_restrict_def)
	next
	assume "x \<notin> iso_arcs hom ` arcs G"
	then show ?thesis
	by (simp add: wrap_iso_arcs_def perm_restrict_def)
	qed
	} note not_in_id = this

	have "f \<in> A \<rightarrow> A" using assms by (intro funcsetI_permutes)
	have inj_on_wrap: "inj_on (wrap_iso_arcs hom f) (iso_arcs hom ` A)"
	using assms \<open>f \<in> A \<rightarrow> A\<close> by (intro inj_on_wrap_iso_arcs_f) (auto intro: subset_inj_on permutes_inj)
	have woa_in_fs: "wrap_iso_arcs hom f \<in> iso_arcs hom ` A \<rightarrow> iso_arcs hom ` A"
	using assms \<open>f \<in> A \<rightarrow> A\<close> by (intro wrap_iso_arcs_in_funcsetI)

	{ fix x y assume "wrap_iso_arcs hom f x = wrap_iso_arcs hom f y"
	then have "x = y"
	apply (cases "x \<in> iso_arcs hom ` A"; cases "y \<in> iso_arcs hom ` A")
	using woa_in_fs inj_on_wrap by (auto dest: inj_onD simp: not_in_id)
	} note uniqueD = this

	note \<open>f permutes A\<close>
	moreover
	note not_in_id
	moreover
	{ fix y have "\<exists>x. wrap_iso_arcs hom f x = y"
	proof cases
	assume "y \<in> iso_arcs hom ` A"
	then obtain y0 where "y0 \<in> A" "iso_arcs hom y0 = y" by blast
	with \<open>f permutes A\<close> obtain x0 where "x0 \<in> A" "f x0 = y0" unfolding permutes_def by metis
	moreover
	then have "\<And>x. x \<in> arcs G \<Longrightarrow> iso_arcs hom x0 = iso_arcs hom x \<Longrightarrow> x0 = x"
	using assms hom by (auto simp: digraph_isomorphism_def dest: inj_onD)
	ultimately
	have "wrap_iso_arcs hom f (iso_arcs hom x0) = y"
	using \<open>_ = y\<close> assms hom by (auto simp: wrap_iso_arcs_def perm_restrict_def)
	then show ?thesis ..
	qed (metis not_in_id)
	}
	ultimately
	show ?thesis unfolding permutes_def by (auto simp: dest: uniqueD)
	qed

	end

	lemma (in digraph_map) digraph_map_isoI:
	assumes "digraph_isomorphism hom" shows "digraph_map (app_iso hom G) (map_iso hom)"
	proof -
	interpret iG: fin_digraph "app_iso hom G" using assms by (rule fin_digraphI_app_iso)
	show ?thesis
	proof (rule iG.digraph_mapI_permutes)
	show "edge_rev (map_iso hom) permutes arcs (app_iso hom G)"
	using assms unfolding map_iso_def by (simp add: wrap_iso_arcs_permutes arev_permutes_arcs)
	next
	show "edge_succ (map_iso hom) permutes arcs (app_iso hom G)"
	using assms unfolding map_iso_def by (simp add: wrap_iso_arcs_permutes edge_succ_permutes)
	next
	fix a assume A: "a \<in> arcs (app_iso hom G)"
	show "tail (app_iso hom G) (edge_rev (map_iso hom) a) = head (app_iso hom G) a"
	using A assms
	by (cases rule: in_arcs_app_iso_cases) (auto simp: map_iso_def iso_verts_tail iso_verts_head)
	show "edge_rev (map_iso hom) (edge_rev (map_iso hom) a) = a"
	using A assms by (cases rule: in_arcs_app_iso_cases) (auto simp: map_iso_def)
	show "edge_rev (map_iso hom) a \<noteq> a"
	using A assms by (auto simp: map_iso_def arev_neq)
	next
	fix v assume "v \<in> verts (app_iso hom G)" and oa_hom: "out_arcs (app_iso hom G) v \<noteq> {}"
	then obtain v0 where "v0 \<in> verts G" "v = iso_verts hom v0" by auto
	moreover
	then have oa: "out_arcs G v0 \<noteq> {}"
	using assms oa_hom by (auto simp: out_arcs_def iso_verts_tail)
	ultimately
	have cyclic_on_v0: "cyclic_on (edge_succ M) (out_arcs G v0)"
	by (intro edge_succ_cyclic)

	from oa_hom obtain a where "a \<in> out_arcs (app_iso hom G) v" by blast
	then obtain a0 where "a0 \<in> arcs G" "a = iso_arcs hom a0" by auto
	then have "a0 \<in> out_arcs G v0"
	using \<open>v = _\<close> \<open>v0 \<in> _\<close> \<open>a \<in> _\<close> assms by (simp add: iso_verts_tail)

	show "cyclic_on (edge_succ (map_iso hom)) (out_arcs (app_iso hom G) v)"
	proof (rule cyclic_on_singleI)
	show "a \<in> out_arcs (app_iso hom G) v" by fact
	next
	have "out_arcs (app_iso hom G) v = iso_arcs hom ` out_arcs G v0"
	unfolding \<open>v = _\<close> by (rule out_arcs_app_iso_eq) fact+
	also have "out_arcs G v0 = orbit (edge_succ M) a0"
	using cyclic_on_v0 \<open>a0 \<in> out_arcs G v0\<close> unfolding cyclic_on_alldef by simp
	also have "iso_arcs hom ` \<dots> = orbit (edge_succ (map_iso hom)) a"
	proof -
	have "\<And>x. x \<in> orbit (edge_succ M) a0 \<Longrightarrow> x \<in> arcs G"
	using \<open>out_arcs G v0 = _\<close> by auto
	then show ?thesis using \<open>out_arcs G v0 = _\<close>
	unfolding \<open>a = _\<close> using \<open>a0 \<in> out_arcs G v0\<close> assms
	by (intro orbit_inverse) (auto simp: map_iso_def)
	qed
	finally show "out_arcs (app_iso hom G) v = orbit (edge_succ (map_iso hom)) a" .
	qed
	qed
	qed

	end

	diff --git a/thys/Poincare_Bendixson/Analysis_Misc.thy b/thys/Poincare_Bendixson/Analysis_Misc.thy
	--- a/thys/Poincare_Bendixson/Analysis_Misc.thy
	+++ b/thys/Poincare_Bendixson/Analysis_Misc.thy
	@@ -1,1135 +1,1135 @@
	section \<open>Additions to HOL-Analysis\<close>
	theory Analysis_Misc
	imports
	Ordinary_Differential_Equations.ODE_Analysis
	begin

	subsection \<open>Unsorted Lemmas (TODO: sort!)\<close>

	lemma uminus_uminus_image: "uminus ` uminus ` S = S"
	for S::"'r::ab_group_add set"
	by (auto simp: image_image)

	lemma in_uminus_image_iff[simp]: "x \<in> uminus ` S \<longleftrightarrow> - x \<in> S"
	for S::"'r::ab_group_add set"
	by force

	lemma closed_subsegmentI:
	"w + t *\<^sub>R (z - w) \<in> {x--y}"
	if "w \<in> {x -- y}" "z \<in> {x -- y}" and t: "0 \<le> t" "t\<le> 1"
	proof -
	from that obtain u v where
	w_def: "w = (1 - u) \<^sub>R x + u \<^sub>R y" and u: "0 \<le> u" "u \<le> 1"
	and z_def: "z = (1 - v) \<^sub>R x + v \<^sub>R y" and v: "0 \<le> v" "v \<le> 1"
	by (auto simp: in_segment)
	have "w + t *\<^sub>R (z - w) =
	(1 - (u - t * (u - v))) \<^sub>R x + (u - t (u - v)) *\<^sub>R y"
	by (simp add: algebra_simps w_def z_def)
	also have "\<dots> \<in> {x -- y}"
	unfolding closed_segment_image_interval
	apply (rule imageI)
	using t u v
	apply auto
	apply (metis (full_types) diff_0_right diff_left_mono linear mult_left_le_one_le mult_nonneg_nonpos order.trans)
	by (smt mult_left_le_one_le mult_nonneg_nonneg vector_space_over_itself.scale_right_diff_distrib)
	finally show ?thesis .
	qed

	lemma tendsto_minus_cancel_right: "((\<lambda>x. -g x) \<longlongrightarrow> l) F \<longleftrightarrow> (g \<longlongrightarrow> -l) F"
	\<comment> \<open>cf @{thm tendsto_minus_cancel_left}\<close>
	for g::"_ \<Rightarrow> 'b::topological_group_add"
	by (simp add: tendsto_minus_cancel_left)

	lemma tendsto_nhds_continuousI: "(f \<longlongrightarrow> l) (nhds x)" if "(f \<longlongrightarrow> l) (at x)" "f x = l"
	\<comment> \<open>TODO: the assumption is continuity of f at x\<close>
	proof (rule topological_tendstoI)
	fix S::"'b set" assume "open S" "l \<in> S"
	from topological_tendstoD[OF that(1) this]
	have "\<forall>\<^sub>F x in at x. f x \<in> S" .
	then show "\<forall>\<^sub>F x in nhds x. f x \<in> S"
	unfolding eventually_at_filter
	by eventually_elim (auto simp: that \<open>l \<in> S\<close>)
	qed

	lemma inj_composeD:
	assumes "inj (\<lambda>x. g (t x))"
	shows "inj t"
	using assms
	by (auto simp: inj_def)

	lemma compact_sequentialE:
	fixes S T::"'a::first_countable_topology set"
	assumes "compact S"
	assumes "infinite T"
	assumes "T \<subseteq> S"
	obtains t::"nat \<Rightarrow> 'a" and l::'a
	where "\<And>n. t n \<in> T" "\<And>n. t n \<noteq> l" "t \<longlonglongrightarrow> l" "l \<in> S"
	proof -
	from Heine_Borel_imp_Bolzano_Weierstrass[OF assms]
	obtain l where "l \<in> S" "l islimpt T" by metis
	then obtain t where "t n \<in> T" "t n \<noteq> l" "t \<longlonglongrightarrow> l" "l \<in> S" for n unfolding islimpt_sequential
	by auto
	then show ?thesis ..
	qed

	lemma infinite_countable_subsetE:
	fixes S::"'a set"
	assumes "infinite S"
	obtains g::"nat\<Rightarrow>'a" where "inj g" "range g \<subseteq> S"
	using assms
	by atomize_elim (simp add: infinite_countable_subset)

	lemma real_quad_ge: "2 * (an * bn) \<le> an * an + bn * bn" for an bn::real
	by (sos "(((A<0 * R<1) + (R<1 * (R<1 * [an + ~1*bn]^2))))")

	lemma inner_quad_ge: "2 * (a \<bullet> b) \<le> a \<bullet> a + b \<bullet> b"
	for a b::"'a::euclidean_space"\<comment> \<open>generalize?\<close>
	proof -
	show ?thesis
	by (subst (1 2 3) euclidean_inner)
	(auto simp add: sum.distrib[symmetric] sum_distrib_left intro!: sum_mono real_quad_ge)
	qed

	lemma inner_quad_gt: "2 * (a \<bullet> b) < a \<bullet> a + b \<bullet> b"
	if "a \<noteq> b"
	for a b::"'a::euclidean_space"\<comment> \<open>generalize?\<close>
	proof -
	from that obtain i where "i \<in> Basis" "a \<bullet> i \<noteq> b \<bullet> i"
	by (auto simp: euclidean_eq_iff[where 'a='a])
	then have "2 * (a \<bullet> i * (b \<bullet> i)) < a \<bullet> i * (a \<bullet> i) + b \<bullet> i * (b \<bullet> i)"
	using sum_sqs_eq[of "a\<bullet>i" "b\<bullet>i"]
	by (auto intro!: le_neq_trans real_quad_ge)
	then show ?thesis
	by (subst (1 2 3) euclidean_inner)
	(auto simp add: \<open>i \<in> Basis\<close> sum.distrib[symmetric] sum_distrib_left
	intro!: sum_strict_mono_ex1 real_quad_ge)
	qed

	lemma closed_segment_line_hyperplanes:
	"{a -- b} = range (\<lambda>u. a + u *\<^sub>R (b - a)) \<inter> {x. a \<bullet> (b - a) \<le> x \<bullet> (b - a) \<and> x \<bullet> (b - a) \<le> b \<bullet> (b - a)}"
	if "a \<noteq> b"
	for a b::"'a::euclidean_space"
	proof safe
	fix x assume x: "x \<in> {a--b}"
	then obtain u where u: "0 \<le> u" "u \<le> 1" and x_eq: "x = a + u *\<^sub>R (b - a)"
	by (auto simp add: in_segment algebra_simps)
	show "x \<in> range (\<lambda>u. a + u *\<^sub>R (b - a))" using x_eq by auto
	have "2 * (a \<bullet> b) \<le> a \<bullet> a + b \<bullet> b"
	by (rule inner_quad_ge)
	then have "u * (2 * (a \<bullet> b) - a \<bullet> a - b \<bullet> b) \<le> 0"
	"0 \<le> (1 - u) * (a \<bullet> a + b \<bullet> b - a \<bullet> b * 2)"
	by (simp_all add: mult_le_0_iff u)
	then show " a \<bullet> (b - a) \<le> x \<bullet> (b - a)" "x \<bullet> (b - a) \<le> b \<bullet> (b - a)"
	by (auto simp: x_eq algebra_simps power2_eq_square inner_commute)
	next
	fix u assume
	"a \<bullet> (b - a) \<le> (a + u *\<^sub>R (b - a)) \<bullet> (b - a)"
	"(a + u *\<^sub>R (b - a)) \<bullet> (b - a) \<le> b \<bullet> (b - a)"
	then have "0 \<le> u * ((b - a) \<bullet> (b - a))" "0 \<le> (1 - u) * ((b - a) \<bullet> (b - a))"
	by (auto simp: algebra_simps)
	then have "0 \<le> u" "u \<le> 1"
	using inner_ge_zero[of "(b - a)"] that
	by (auto simp add: zero_le_mult_iff)
	then show "a + u *\<^sub>R (b - a) \<in> {a--b}"
	by (auto simp: in_segment algebra_simps)
	qed

	lemma open_segment_line_hyperplanes:
	"{a <--< b} = range (\<lambda>u. a + u *\<^sub>R (b - a)) \<inter> {x. a \<bullet> (b - a) < x \<bullet> (b - a) \<and> x \<bullet> (b - a) < b \<bullet> (b - a)}"
	if "a \<noteq> b"
	for a b::"'a::euclidean_space"
	proof safe
	fix x assume x: "x \<in> {a<--<b}"
	then obtain u where u: "0 < u" "u < 1" and x_eq: "x = a + u *\<^sub>R (b - a)"
	by (auto simp add: in_segment algebra_simps)
	show "x \<in> range (\<lambda>u. a + u *\<^sub>R (b - a))" using x_eq by auto
	have "2 * (a \<bullet> b) < a \<bullet> a + b \<bullet> b" using that
	by (rule inner_quad_gt)
	then have "u * (2 * (a \<bullet> b) - a \<bullet> a - b \<bullet> b) < 0"
	"0 < (1 - u) * (a \<bullet> a + b \<bullet> b - a \<bullet> b * 2)"
	by (simp_all add: mult_less_0_iff u)
	then show " a \<bullet> (b - a) < x \<bullet> (b - a)" "x \<bullet> (b - a) < b \<bullet> (b - a)"
	by (auto simp: x_eq algebra_simps power2_eq_square inner_commute)
	next
	fix u assume
	"a \<bullet> (b - a) < (a + u *\<^sub>R (b - a)) \<bullet> (b - a)"
	"(a + u *\<^sub>R (b - a)) \<bullet> (b - a) < b \<bullet> (b - a)"
	then have "0 < u * ((b - a) \<bullet> (b - a))" "0 < (1 - u) * ((b - a) \<bullet> (b - a))"
	by (auto simp: algebra_simps)
	then have "0 < u" "u < 1"
	using inner_ge_zero[of "(b - a)"] that
	by (auto simp add: zero_less_mult_iff)
	then show "a + u *\<^sub>R (b - a) \<in> {a<--<b}"
	by (auto simp: in_segment algebra_simps that)
	qed

	lemma at_within_interior: "NO_MATCH UNIV S \<Longrightarrow> x \<in> interior S \<Longrightarrow> at x within S = at x"
	by (auto intro: at_within_interior)

	lemma tendsto_at_topI:
	"(f \<longlongrightarrow> l) at_top" if "\<And>e. 0 < e \<Longrightarrow> \<exists>x0. \<forall>x\<ge>x0. dist (f x) l < e"
	for f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	using that
	apply (intro tendstoI)
	unfolding eventually_at_top_linorder
	by auto

	lemma tendsto_at_topE:
	fixes f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	assumes "(f \<longlongrightarrow> l) at_top"
	assumes "e > 0"
	obtains x0 where "\<And>x. x \<ge> x0 \<Longrightarrow> dist (f x) l < e"
	proof -
	from assms(1)[THEN tendstoD, OF assms(2)]
	have "\<forall>\<^sub>F x in at_top. dist (f x) l < e" .
	then show ?thesis
	unfolding eventually_at_top_linorder
	by (auto intro: that)
	qed
	lemma tendsto_at_top_iff: "(f \<longlongrightarrow> l) at_top \<longleftrightarrow> (\<forall>e>0. \<exists>x0. \<forall>x\<ge>x0. dist (f x) l < e)"
	for f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	by (auto intro!: tendsto_at_topI elim!: tendsto_at_topE)

	lemma tendsto_at_top_eq_left:
	fixes f g::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	assumes "(f \<longlongrightarrow> l) at_top"
	assumes "\<And>x. x \<ge> x0 \<Longrightarrow> f x = g x"
	shows "(g \<longlongrightarrow> l) at_top"
	unfolding tendsto_at_top_iff
	by (metis (no_types, opaque_lifting) assms(1) assms(2) linear order_trans tendsto_at_topE)

	lemma lim_divide_n: "(\<lambda>x. e / real x) \<longlonglongrightarrow> 0"
	proof -
	have "(\<lambda>x. e * inverse (real x)) \<longlonglongrightarrow> 0"
	by (auto intro: tendsto_eq_intros lim_inverse_n)
	then show ?thesis by (simp add: inverse_eq_divide)
	qed

	definition at_top_within :: "('a::order) set \<Rightarrow> 'a filter"
	where "at_top_within s = (INF k \<in> s. principal ({k ..} \<inter> s)) "

	lemma at_top_within_at_top[simp]:
	shows "at_top_within UNIV = at_top"
	unfolding at_top_within_def at_top_def
	by (auto)

	lemma at_top_within_empty[simp]:
	shows "at_top_within {} = top"
	unfolding at_top_within_def
	by (auto)

	definition "nhds_set X = (INF S\<in>{S. open S \<and> X \<subseteq> S}. principal S)"

	lemma eventually_nhds_set:
	"(\<forall>\<^sub>F x in nhds_set X. P x) \<longleftrightarrow> (\<exists>S. open S \<and> X \<subseteq> S \<and> (\<forall>x\<in>S. P x))"
	unfolding nhds_set_def by (subst eventually_INF_base) (auto simp: eventually_principal)

	term "filterlim f (nhds_set (frontier X)) F" \<comment> \<open>f tends to the boundary of X?\<close>


	text \<open>somewhat inspired by @{thm islimpt_range_imp_convergent_subsequence} and its dependencies.
	The class constraints seem somewhat arbitrary, perhaps this can be generalized in some way.
	\<close>
	lemma limpt_closed_imp_exploding_subsequence:\<comment>\<open>TODO: improve name?!\<close>
	fixes f::"'a::{heine_borel,real_normed_vector} \<Rightarrow> 'b::{first_countable_topology, t2_space}"
	assumes cont[THEN continuous_on_compose2, continuous_intros]: "continuous_on T f"
	assumes closed: "closed T"
	assumes bound: "\<And>t. t \<in> T \<Longrightarrow> f t \<noteq> l"
	assumes limpt: "l islimpt (f ` T)"
	obtains s where
	"(f \<circ> s) \<longlonglongrightarrow> l"
	"\<And>i. s i \<in> T"
	"\<And>C. compact C \<Longrightarrow> C \<subseteq> T \<Longrightarrow> \<forall>\<^sub>F i in sequentially. s i \<notin> C"
	proof -
	from countable_basis_at_decseq[of l]
	obtain A where A: "\<And>i. open (A i)" "\<And>i. l \<in> A i"
	and evA: "\<And>S. open S \<Longrightarrow> l \<in> S \<Longrightarrow> eventually (\<lambda>i. A i \<subseteq> S) sequentially"
	by blast

	from closed_Union_compact_subsets[OF closed]
	obtain C
	where C: "(\<And>n. compact (C n))" "(\<And>n. C n \<subseteq> T)" "(\<And>n. C n \<subseteq> C (Suc n))" "\<Union> (range C) = T"
	and evC: "(\<And>K. compact K \<Longrightarrow> K \<subseteq> T \<Longrightarrow> \<forall>\<^sub>F i in sequentially. K \<subseteq> C i)"
	by (metis eventually_sequentially)

	have AC: "l \<in> A i - f ` C i" "open (A i - f ` C i)" for i
	using C bound
	by (fastforce intro!: open_Diff A compact_imp_closed compact_continuous_image continuous_intros)+

	from islimptE[OF limpt AC] have "\<exists>t\<in>T. f t \<in> A i - f ` C i \<and> f t \<noteq> l" for i by blast
	then obtain t where t: "\<And>i. t i \<in> T" "\<And>i. f (t i) \<in> A i - f ` C i" "\<And>i. f (t i) \<noteq> l"
	by metis

	have "(f o t) \<longlonglongrightarrow> l"
	using t
	by (auto intro!: topological_tendstoI dest!: evA elim!: eventually_mono)
	moreover
	have "\<And>i. t i \<in> T" by fact
	moreover
	have "\<forall>\<^sub>F i in sequentially. t i \<notin> K" if "compact K" "K \<subseteq> T" for K
	using evC[OF that]
	by eventually_elim (use t in auto)
	ultimately show ?thesis ..
	qed

	lemma Inf_islimpt: "bdd_below S \<Longrightarrow> Inf S \<notin> S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> Inf S islimpt S" for S::"real set"
	by (auto simp: islimpt_in_closure intro!: closure_contains_Inf)

	context linorder
	begin

	text \<open>HOL-analysis doesn't seem to have these, maybe they were never needed.
	Some variants are around @{thm Int_atLeastAtMost}, but with old-style naming conventions.
	Change to the "modern" I.. convention there?\<close>

	lemma Int_Ico[simp]:
	shows "{a..} \<inter> {b..} = {max a b ..}"
	by (auto)

	lemma Int_Ici_Ico[simp]:
	shows "{a..} \<inter> {b..<c} = {max a b ..<c}"
	by auto

	lemma Int_Ico_Ici[simp]:
	shows "{a..<c} \<inter> {b..} = {max a b ..<c}"
	by auto

	lemma subset_Ico_iff[simp]:
	"{a..<b} \<subseteq> {c..<b} \<longleftrightarrow> b \<le> a \<or> c \<le> a"
	unfolding atLeastLessThan_def
	by auto

	lemma Ico_subset_Ioo_iff[simp]:
	"{a..<b} \<subseteq> {c<..<b} \<longleftrightarrow> b \<le> a \<or> c < a"
	unfolding greaterThanLessThan_def atLeastLessThan_def
	by auto

	lemma Icc_Un_Ici[simp]:
	shows "{a..b} \<union> {b..} = {min a b..}"
	unfolding atLeastAtMost_def atLeast_def atMost_def min_def
	by auto

	end

	lemma at_top_within_at_top_unbounded_right:
	fixes a::"'a::linorder"
	shows "at_top_within {a..} = at_top"
	unfolding at_top_within_def at_top_def
	apply (auto intro!: INF_eq)
	by (metis linorder_class.linear linorder_class.max.cobounded1 linorder_class.max.idem ord_class.atLeast_iff)

	lemma at_top_within_at_top_unbounded_rightI:
	fixes a::"'a::linorder"
	assumes "{a..} \<subseteq> s"
	shows "at_top_within s = at_top"
	unfolding at_top_within_def at_top_def
	apply (auto intro!: INF_eq)
	apply (meson Ici_subset_Ioi_iff Ioi_le_Ico assms dual_order.refl dual_order.trans leI)
	by (metis assms atLeast_iff atLeast_subset_iff inf.cobounded1 linear subsetD)

	lemma at_top_within_at_top_bounded_right:
	fixes a b::"'a::{dense_order,linorder_topology}"
	assumes "a < b"
	shows "at_top_within {a..<b} = at_left b"
	unfolding at_top_within_def at_left_eq[OF assms(1)]
	apply (auto intro!: INF_eq)
	apply (smt atLeastLessThan_iff greaterThanLessThan_iff le_less lessThan_iff max.absorb1 subset_eq)
	by (metis assms atLeastLessThan_iff dense linear max.absorb1 not_less order_trans)

	lemma at_top_within_at_top_bounded_right':
	fixes a b::"'a::{dense_order,linorder_topology}"
	assumes "a < b"
	shows "at_top_within {..<b} = at_left b"
	unfolding at_top_within_def at_left_eq[OF assms(1)]
	apply (auto intro!: INF_eq)
	apply (meson atLeast_iff greaterThanLessThan_iff le_less lessThan_iff subset_eq)
	by (metis Ico_subset_Ioo_iff atLeastLessThan_def dense lessThan_iff)

	lemma eventually_at_top_within_linorder:
	assumes sn:"s \<noteq> {}"
	shows "eventually P (at_top_within s) \<longleftrightarrow> (\<exists>x0::'a::{linorder_topology} \<in> s. \<forall>x \<ge> x0. x\<in> s \<longrightarrow> P x)"
	unfolding at_top_within_def
	apply (subst eventually_INF_base)
	apply (auto simp:eventually_principal sn)
	by (metis atLeast_subset_iff inf.coboundedI2 inf_commute linear)

	lemma tendsto_at_top_withinI:
	fixes f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	assumes "s \<noteq> {}"
	assumes "\<And>e. 0 < e \<Longrightarrow> \<exists>x0 \<in> s. \<forall>x \<in> {x0..} \<inter> s. dist (f x) l < e"
	shows "(f \<longlongrightarrow> l) (at_top_within s)"
	apply(intro tendstoI)
	unfolding at_top_within_def apply (subst eventually_INF_base)
	apply (auto simp:eventually_principal assms)
	by (metis atLeast_subset_iff inf.coboundedI2 inf_commute linear)

	lemma tendsto_at_top_withinE:
	fixes f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	assumes "s \<noteq> {}"
	assumes "(f \<longlongrightarrow> l) (at_top_within s)"
	assumes "e > 0"
	obtains x0 where "x0 \<in> s" "\<And>x. x \<in> {x0..} \<inter> s \<Longrightarrow> dist (f x) l < e"
	proof -
	from assms(2)[THEN tendstoD, OF assms(3)]
	have "\<forall>\<^sub>F x in at_top_within s. dist (f x) l < e" .
	then show ?thesis unfolding eventually_at_top_within_linorder[OF \<open>s \<noteq> {}\<close>]
	by (auto intro: that)
	qed

	lemma tendsto_at_top_within_iff:
	fixes f::"'a::linorder_topology \<Rightarrow> 'b::metric_space"
	assumes "s \<noteq> {}"
	shows "(f \<longlongrightarrow> l) (at_top_within s) \<longleftrightarrow> (\<forall>e>0. \<exists>x0 \<in> s. \<forall>x \<in> {x0..} \<inter> s. dist (f x) l < e)"
	by (auto intro!: tendsto_at_top_withinI[OF \<open>s \<noteq> {}\<close>] elim!: tendsto_at_top_withinE[OF \<open>s \<noteq> {}\<close>])

	lemma filterlim_at_top_at_top_within_bounded_right:
	fixes a b::"'a::{dense_order,linorder_topology}"
	fixes f::"'a \<Rightarrow> real"
	assumes "a < b"
	shows "filterlim f at_top (at_top_within {..<b}) = (f \<longlongrightarrow> \<infinity>) (at_left b)"
	unfolding filterlim_at_top_dense
	at_top_within_at_top_bounded_right'[OF assms(1)]
	eventually_at_left[OF assms(1)]
	tendsto_PInfty
	by auto

	text \<open>Extract a sequence (going to infinity) bounded away from l\<close>

	lemma not_tendsto_frequentlyE:
	assumes "\<not>((f \<longlongrightarrow> l) F)"
	obtains S where "open S" "l \<in> S" "\<exists>\<^sub>F x in F. f x \<notin> S"
	using assms
	by (auto simp: tendsto_def not_eventually)

	lemma not_tendsto_frequently_metricE:
	assumes "\<not>((f \<longlongrightarrow> l) F)"
	obtains e where "e > 0" "\<exists>\<^sub>F x in F. e \<le> dist (f x) l"
	using assms
	by (auto simp: tendsto_iff not_eventually not_less)

	lemma eventually_frequently_conj: "frequently P F \<Longrightarrow> eventually Q F \<Longrightarrow> frequently (\<lambda>x. P x \<and> Q x) F"
	unfolding frequently_def
	apply (erule contrapos_nn)
	subgoal premises prems
	using prems by eventually_elim auto
	done

	lemma frequently_at_top:
	"(\<exists>\<^sub>F t in at_top. P t) \<longleftrightarrow> (\<forall>t0. \<exists>t>t0. P t)"
	for P::"'a::{linorder,no_top}\<Rightarrow>bool"
	by (auto simp: frequently_def eventually_at_top_dense)

	lemma frequently_at_topE:
	fixes P::"nat \<Rightarrow> 'a::{linorder,no_top}\<Rightarrow>_"
	assumes freq[rule_format]: "\<forall>n. \<exists>\<^sub>F a in at_top. P n a"
	obtains s::"nat\<Rightarrow>'a"
	where "\<And>i. P i (s i)" "strict_mono s"
	proof -
	have "\<exists>f. \<forall>n. P n (f n) \<and> f n < f (Suc n)"
	proof (rule dependent_nat_choice)
	from frequently_ex[OF freq[of 0]] show "\<exists>x. P 0 x" .
	fix x n assume "P n x"
	from freq[unfolded frequently_at_top, rule_format, of x "Suc n"]
	obtain y where "P (Suc n) y" "y > x" by auto
	then show "\<exists>y. P (Suc n) y \<and> x < y"
	by auto
	qed
	then obtain s where "\<And>i. P i (s i)" "strict_mono s"
	unfolding strict_mono_Suc_iff by auto
	then show ?thesis ..
	qed

	lemma frequently_at_topE':
	fixes P::"nat \<Rightarrow> 'a::{linorder,no_top}\<Rightarrow>_"
	assumes freq[rule_format]: "\<forall>n. \<exists>\<^sub>F a in at_top. P n a"
	and g: "filterlim g at_top sequentially"
	obtains s::"nat\<Rightarrow>'a"
	where "\<And>i. P i (s i)" "strict_mono s" "\<And>n. g n \<le> s n"
	proof -
	have "\<forall>n. \<exists>\<^sub>F a in at_top. P n a \<and> g n \<le> a"
	using freq
	by (auto intro!: eventually_frequently_conj)
	from frequently_at_topE[OF this] obtain s where "\<And>i. P i (s i)" "strict_mono s" "\<And>n. g n \<le> s n"
	by metis
	then show ?thesis ..
	qed

	lemma frequently_at_top_at_topE:
	fixes P::"nat \<Rightarrow> 'a::{linorder,no_top}\<Rightarrow>_" and g::"nat\<Rightarrow>'a"
	assumes "\<forall>n. \<exists>\<^sub>F a in at_top. P n a" "filterlim g at_top sequentially"
	obtains s::"nat\<Rightarrow>'a"
	where "\<And>i. P i (s i)" "filterlim s at_top sequentially"
	proof -
	from frequently_at_topE'[OF assms]
	obtain s where s: "(\<And>i. P i (s i))" "strict_mono s" "(\<And>n. g n \<le> s n)" by blast
	have s_at_top: "filterlim s at_top sequentially"
	by (rule filterlim_at_top_mono) (use assms s in auto)
	with s(1) show ?thesis ..
	qed

	(* Extract a strict monotone and sequence converging to something other than l *)
	lemma not_tendsto_convergent_seq:
	fixes f::"real \<Rightarrow> 'a::metric_space"
	assumes X: "compact (X::'a set)"
	assumes im: "\<And>x. x \<ge> 0 \<Longrightarrow> f x \<in> X"
	assumes nl: "\<not> ((f \<longlongrightarrow> (l::'a)) at_top)"
	obtains s k where
	"k \<in> X" "k \<noteq> l" "(f \<circ> s) \<longlonglongrightarrow> k" "strict_mono s" "\<forall>n. s n \<ge> n"
	proof -
	from not_tendsto_frequentlyE[OF nl]
	obtain S where "open S" "l \<in> S" "\<exists>\<^sub>F x in at_top. f x \<notin> S" .
	have "\<forall>n. \<exists>\<^sub>F x in at_top. f x \<notin> S \<and> real n \<le> x"
	apply (rule allI)
	apply (rule eventually_frequently_conj)
	apply fact
	by (rule eventually_ge_at_top)
	from frequently_at_topE[OF this]
	obtain s where "\<And>i. f (s i) \<notin> S" and s: "strict_mono s" and s_ge: "(\<And>i. real i \<le> s i)" by metis
	then have "0 \<le> s i" for i using dual_order.trans of_nat_0_le_iff by blast
	then have "\<forall>n. (f \<circ> s) n \<in> X" using im by auto
	from X[unfolded compact_def, THEN spec, THEN mp, OF this]
	obtain k r where k: "k \<in> X" and r: "strict_mono r" and kLim: "(f \<circ> s \<circ> r) \<longlonglongrightarrow> k" by metis
	have "k \<in> X - S"
	by (rule Lim_in_closed_set[of "X - S", OF _ _ _ kLim])
	(auto simp: im \<open>0 \<le> s _\<close> \<open>\<And>i. f (s i) \<notin> S\<close> intro!: \<open>open S\<close> X intro: compact_imp_closed)

	note k
	moreover have "k \<noteq> l" using \<open>k \<in> X - S\<close> \<open>l \<in> S\<close> by auto
	moreover have "(f \<circ> (s \<circ> r)) \<longlonglongrightarrow> k" using kLim by (simp add: o_assoc)
	moreover have "strict_mono (s \<circ> r)" using s r by (rule strict_mono_o)
	moreover have "\<forall>n. (s \<circ> r) n \<ge> n" using s_ge r
	by (metis comp_apply dual_order.trans of_nat_le_iff seq_suble)
	ultimately show ?thesis ..
	qed

	lemma harmonic_bound:
	shows "1 / 2 ^(Suc n) < 1 / real (Suc n)"
	proof (induction n)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then show ?case
	by (smt frac_less2 of_nat_0_less_iff of_nat_less_two_power zero_less_Suc)
	qed

	lemma INF_bounded_imp_convergent_seq:
	fixes f::"real \<Rightarrow> real"
	assumes cont: "continuous_on {a..} f"
	assumes bound: "\<And>t. t \<ge> a \<Longrightarrow> f t > l"
	assumes inf: "(INF t\<in>{a..}. f t) = l"
	obtains s where
	"(f \<circ> s) \<longlonglongrightarrow> l"
	"\<And>i. s i \<in> {a..}"
	"filterlim s at_top sequentially"
	proof -
	have bound': "t \<in> {a..} \<Longrightarrow> f t \<noteq> l" for t using bound[of t] by auto
	have limpt: "l islimpt f ` {a..}"
	proof -
	have "Inf (f ` {a..}) islimpt f ` {a..}"
	by (rule Inf_islimpt) (auto simp: inf intro!: bdd_belowI2[where m=l] dest: bound)
	then show ?thesis by (simp add: inf)
	qed
	from limpt_closed_imp_exploding_subsequence[OF cont closed_atLeast bound' limpt]
	obtain s where s: "(f \<circ> s) \<longlonglongrightarrow> l"
	"\<And>i. s i \<in> {a..}"
	"compact C \<Longrightarrow> C \<subseteq> {a..} \<Longrightarrow> \<forall>\<^sub>F i in sequentially. s i \<notin> C" for C
	by metis
	have "\<forall>\<^sub>F i in sequentially. s i \<ge> n" for n
	using s(3)[of "{a..n}"] s(2)
	by (auto elim!: eventually_mono)
	then have "filterlim s at_top sequentially"
	unfolding filterlim_at_top
	by auto
	from s(1) s(2) this
	show ?thesis ..
	qed

	(* Generalizes to other combinations of strict_mono and filterlim *)
	lemma filterlim_at_top_strict_mono:
	fixes s :: "_ \<Rightarrow> 'a::linorder"
	fixes r :: "nat \<Rightarrow> _"
	assumes "strict_mono s"
	assumes "strict_mono r"
	assumes "filterlim s at_top F"
	shows "filterlim (s \<circ> r) at_top F"
	apply (rule filterlim_at_top_mono[OF assms(3)])
	by (simp add: assms(1) assms(2) seq_suble strict_mono_leD)

	lemma LIMSEQ_lb:
	assumes fl: "s \<longlonglongrightarrow> (l::real)"
	assumes u: "l < u"
	shows "\<exists>n0. \<forall>n\<ge>n0. s n < u"
	proof -
	from fl have "\<exists>no>0. \<forall>n\<ge>no. dist (s n) l < u-l" unfolding LIMSEQ_iff_nz using u
	by simp
	thus ?thesis using dist_real_def by fastforce
	qed

	(* Used to sharpen a tendsto with additional information*)
	lemma filterlim_at_top_choose_lower:
	assumes "filterlim s at_top sequentially"
	assumes "(f \<circ> s) \<longlonglongrightarrow> l"
	obtains t where
	"filterlim t at_top sequentially"
	"(f \<circ> t) \<longlonglongrightarrow> l"
	"\<forall>n. t n \<ge> (b::real)"
	proof -
	obtain k where k: "\<forall>n \<ge> k. s n \<ge> b" using assms(1)
	unfolding filterlim_at_top eventually_sequentially by blast
	define t where "t = (\<lambda>n. s (n+k))"
	then have "\<forall>n. t n \<ge> b" using k by simp
	have "filterlim t at_top sequentially" using assms(1)
	unfolding filterlim_at_top eventually_sequentially t_def
	by (metis (full_types) add.commute trans_le_add2)
	from LIMSEQ_ignore_initial_segment[OF assms(2), of "k"]
	have "(\<lambda>n. (f \<circ> s) (n + k)) \<longlonglongrightarrow> l" .
	then have "(f \<circ> t) \<longlonglongrightarrow> l" unfolding t_def o_def by simp
	show ?thesis
	using \<open>(f \<circ> t) \<longlonglongrightarrow> l\<close> \<open>\<forall>n. b \<le> t n\<close> \<open>filterlim t at_top sequentially\<close> that by blast
	qed

	lemma frequently_at_top_realE:
	fixes P::"nat \<Rightarrow> real \<Rightarrow> bool"
	assumes "\<forall>n. \<exists>\<^sub>F t in at_top. P n t"
	obtains s::"nat\<Rightarrow>real"
	where "\<And>i. P i (s i)" "filterlim s at_top at_top"
	by (metis assms frequently_at_top_at_topE[OF _ filterlim_real_sequentially])

	lemma approachable_sequenceE:
	fixes f::"real \<Rightarrow> 'a::metric_space"
	assumes "\<And>t e. 0 \<le> t \<Longrightarrow> 0 < e \<Longrightarrow> \<exists>tt\<ge>t. dist (f tt) p < e"
	obtains s where "filterlim s at_top sequentially" "(f \<circ> s) \<longlonglongrightarrow> p"
	proof -
	have "\<forall>n. \<exists>\<^sub>F i in at_top. dist (f i) p < 1/real (Suc n)"
	unfolding frequently_at_top
	apply (auto )
	subgoal for n m
	using assms[of "max 0 (m+1)" "1/(Suc n)"]
	by force
	done
	from frequently_at_top_realE[OF this]
	obtain s where s: "\<And>i. dist (f (s i)) p < 1 / real (Suc i)" "filterlim s at_top sequentially"
	by metis
	note this(2)
	moreover
	have "(f o s) \<longlonglongrightarrow> p"
	proof (rule tendstoI)
	fix e::real assume "e > 0"
	have "\<forall>\<^sub>F i in sequentially. 1 / real (Suc i) < e"
	apply (rule order_tendstoD[OF _ \<open>0 < e\<close>])
	apply (rule real_tendsto_divide_at_top)
	apply (rule tendsto_intros)
	by (rule filterlim_compose[OF filterlim_real_sequentially filterlim_Suc])
	then show "\<forall>\<^sub>F x in sequentially. dist ((f \<circ> s) x) p < e"
	by eventually_elim (use dual_order.strict_trans s \<open>e > 0\<close> in auto)
	qed
	ultimately show ?thesis ..
	qed

	lemma mono_inc_bdd_above_has_limit_at_topI:
	fixes f::"real \<Rightarrow> real"
	assumes "mono f"
	assumes "\<And>x. f x \<le> u"
	shows "\<exists>l. (f \<longlongrightarrow> l) at_top"
	proof -
	define l where "l = Sup (range (\<lambda>n. f (real n)))"
	have t:"(\<lambda>n. f (real n)) \<longlonglongrightarrow> l" unfolding l_def
	apply (rule LIMSEQ_incseq_SUP)
	apply (meson assms(2) bdd_aboveI2)
	by (meson assms(1) mono_def of_nat_mono)
	from tendsto_at_topI_sequentially_real[OF assms(1) t]
	have "(f \<longlongrightarrow> l) at_top" .
	thus ?thesis by blast
	qed

	lemma gen_mono_inc_bdd_above_has_limit_at_topI:
	fixes f::"real \<Rightarrow> real"
	assumes "\<And>x y. x \<ge> b \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<le> f y"
	assumes "\<And>x. x \<ge> b \<Longrightarrow> f x \<le> u"
	shows "\<exists>l. (f \<longlongrightarrow> l) at_top"
	proof -
	define ff where "ff = (\<lambda>x. if x \<ge> b then f x else f b)"
	have m1:"mono ff" unfolding ff_def mono_def using assms(1) by simp
	have m2:"\<And>x. ff x \<le> u" unfolding ff_def using assms(2) by simp
	from mono_inc_bdd_above_has_limit_at_topI[OF m1 m2]
	obtain l where "(ff \<longlongrightarrow> l) at_top" by blast
	thus ?thesis
	by (meson \<open>(ff \<longlongrightarrow> l) at_top\<close> ff_def tendsto_at_top_eq_left)
	qed

	lemma gen_mono_dec_bdd_below_has_limit_at_topI:
	fixes f::"real \<Rightarrow> real"
	assumes "\<And>x y. x \<ge> b \<Longrightarrow> x \<le> y \<Longrightarrow> f x \<ge> f y"
	assumes "\<And>x. x \<ge> b \<Longrightarrow> f x \<ge> u"
	shows "\<exists>l. (f \<longlongrightarrow> l) at_top"
	proof -
	define ff where "ff = (\<lambda>x. if x \<ge> b then f x else f b)"
	have m1:"mono (-ff)" unfolding ff_def mono_def using assms(1) by simp
	have m2:"\<And>x. (-ff) x \<le> -u" unfolding ff_def using assms(2) by simp
	from mono_inc_bdd_above_has_limit_at_topI[OF m1 m2]
	obtain l where "(-ff \<longlongrightarrow> l) at_top" by blast
	then have "(ff \<longlongrightarrow> -l) at_top"
	using tendsto_at_top_eq_left tendsto_minus_cancel_left by fastforce
	thus ?thesis
	by (meson \<open>(ff \<longlongrightarrow> -l) at_top\<close> ff_def tendsto_at_top_eq_left)
	qed

	lemma infdist_closed:
	shows "closed ({z. infdist z S \<ge> e})"
	by (auto intro!:closed_Collect_le simp add:continuous_on_infdist)

	(* TODO: this is a copy of LIMSEQ_norm_0 where the sequence
	is bounded above in norm by a geometric series *)
	lemma LIMSEQ_norm_0_pow:
	assumes "k > 0" "b > 1"
	assumes "\<And>n::nat. norm (s n) \<le> k / b^n"
	shows "s \<longlonglongrightarrow> 0"
	proof (rule metric_LIMSEQ_I)
	fix e
	assume "e > (0::real)"
	then have "k / e > 0" using assms(1) by auto
	obtain N where N: "b^(N::nat) > k / e" using assms(2)
	using real_arch_pow by blast
	then have "norm (s n) < e" if "n \<ge> N" for n
	proof -
	have "k / b^n \<le> k / b^N"
	by (smt assms(1) assms(2) frac_le leD power_less_imp_less_exp that zero_less_power)
	also have " ... < e" using N
	by (metis \<open>0 < e\<close> assms(2) less_trans mult.commute pos_divide_less_eq zero_less_one zero_less_power)
	finally show ?thesis
	by (meson assms less_eq_real_def not_le order_trans)
	qed
	then show "\<exists>no. \<forall>n\<ge>no. dist (s n) 0 < e"
	by auto
	qed

	lemma filterlim_apply_filtermap:
	assumes g: "filterlim g G F"
	shows "filterlim (\<lambda>x. m (g x)) (filtermap m G) F"
	by (metis filterlim_def filterlim_filtermap filtermap_mono g)

	lemma eventually_at_right_field_le:
	"eventually P (at_right x) \<longleftrightarrow> (\<exists>b>x. \<forall>y>x. y \<le> b \<longrightarrow> P y)"
	for x :: "'a::{linordered_field, linorder_topology}"
	by (smt dense eventually_at_right_field le_less_trans less_le_not_le order.strict_trans1)

	subsection \<open>indexing euclidean space with natural numbers\<close>

	definition nth_eucl :: "'a::executable_euclidean_space \<Rightarrow> nat \<Rightarrow> real" where
	"nth_eucl x i = x \<bullet> (Basis_list ! i)"
	\<comment> \<open>TODO: why is that and some sort of \<open>lambda_eucl\<close> nowhere available?\<close>
	definition lambda_eucl :: "(nat \<Rightarrow> real) \<Rightarrow> 'a::executable_euclidean_space" where
	"lambda_eucl (f::nat\<Rightarrow>real) = (\<Sum>i<DIM('a). f i *\<^sub>R Basis_list ! i)"

	lemma eucl_eq_iff: "x = y \<longleftrightarrow> (\<forall>i<DIM('a). nth_eucl x i = nth_eucl y i)"
	for x y::"'a::executable_euclidean_space"
	apply (auto simp: nth_eucl_def euclidean_eq_iff[where 'a='a])
	by (metis eucl_of_list_list_of_eucl list_of_eucl_eq_iff)

	bundle eucl_notation begin
	notation nth_eucl (infixl "$\<^sub>e" 90)
	end
	bundle no_eucl_notation begin
	no_notation nth_eucl (infixl "$\<^sub>e" 90)
	end

	unbundle eucl_notation

	lemma eucl_of_list_eucl_nth:
	"(eucl_of_list xs::'a) $\<^sub>e i = xs ! i"
	if "length xs = DIM('a::executable_euclidean_space)"
	"i < DIM('a)"
	using that
	apply (auto simp: nth_eucl_def)
	by (metis list_of_eucl_eucl_of_list list_of_eucl_nth)

	lemma eucl_of_list_inner:
	"(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = (\<Sum>(x,y)\<leftarrow>zip xs ys. x * y)"
	if "length xs = DIM('a::executable_euclidean_space)"
	"length ys = DIM('a::executable_euclidean_space)"
	using that
	by (auto simp: nth_eucl_def eucl_of_list_inner_eq inner_lv_rel_def)

	lemma self_eq_eucl_of_list: "x = eucl_of_list (map (\<lambda>i. x $\<^sub>e i) [0..<DIM('a)])"
	for x::"'a::executable_euclidean_space"
	by (auto simp: eucl_eq_iff[where 'a='a] eucl_of_list_eucl_nth)

	lemma inner_nth_eucl: "x \<bullet> y = (\<Sum>i<DIM('a). x $\<^sub>e i * y $\<^sub>e i)"
	for x y::"'a::executable_euclidean_space"
	apply (subst self_eq_eucl_of_list[where x=x])
	apply (subst self_eq_eucl_of_list[where x=y])
	apply (subst eucl_of_list_inner)
	by (auto simp: map2_map_map atLeast_upt interv_sum_list_conv_sum_set_nat)

	lemma norm_nth_eucl: "norm x = L2_set (\<lambda>i. x $\<^sub>e i) {..<DIM('a)}"
	for x::"'a::executable_euclidean_space"
	unfolding norm_eq_sqrt_inner inner_nth_eucl L2_set_def
	by (auto simp: power2_eq_square)


	lemma plus_nth_eucl: "(x + y) $\<^sub>e i = x $\<^sub>e i + y $\<^sub>e i"
	and minus_nth_eucl: "(x - y) $\<^sub>e i = x $\<^sub>e i - y $\<^sub>e i"
	and uminus_nth_eucl: "(-x) $\<^sub>e i = - x $\<^sub>e i"
	and scaleR_nth_eucl: "(c \<^sub>R x) $\<^sub>e i = c \<^sub>R (x $\<^sub>e i)"
	by (auto simp: nth_eucl_def algebra_simps)

	lemma inf_nth_eucl: "inf x y $\<^sub>e i = min (x $\<^sub>e i) (y $\<^sub>e i)"
	if "i < DIM('a)"
	for x::"'a::executable_euclidean_space"
	by (auto simp: nth_eucl_def algebra_simps inner_Basis_inf_left that inf_min)
	lemma sup_nth_eucl: "sup x y $\<^sub>e i = max (x $\<^sub>e i) (y $\<^sub>e i)"
	if "i < DIM('a)"
	for x::"'a::executable_euclidean_space"
	by (auto simp: nth_eucl_def algebra_simps inner_Basis_sup_left that sup_max)

	lemma le_iff_le_nth_eucl: "x \<le> y \<longleftrightarrow> (\<forall>i<DIM('a). (x $\<^sub>e i) \<le> (y $\<^sub>e i))"
	for x::"'a::executable_euclidean_space"
	apply (auto simp: nth_eucl_def algebra_simps eucl_le[where 'a='a])
	by (meson eucl_le eucl_le_Basis_list_iff)

	lemma eucl_less_iff_less_nth_eucl: "eucl_less x y \<longleftrightarrow> (\<forall>i<DIM('a). (x $\<^sub>e i) < (y $\<^sub>e i))"
	for x::"'a::executable_euclidean_space"
	apply (auto simp: nth_eucl_def algebra_simps eucl_less_def[where 'a='a])
	by (metis Basis_zero eucl_eq_iff inner_not_same_Basis inner_zero_left length_Basis_list
	nth_Basis_list_in_Basis nth_eucl_def)

	lemma continuous_on_nth_eucl[continuous_intros]:
	"continuous_on X (\<lambda>x. f x $\<^sub>e i)"
	if "continuous_on X f"
	by (auto simp: nth_eucl_def intro!: continuous_intros that)


	subsection \<open>derivatives\<close>

	lemma eventually_at_ne[intro, simp]: "\<forall>\<^sub>F x in at x0. x \<noteq> x0"
	by (auto simp: eventually_at_filter)

	lemma has_vector_derivative_withinD:
	fixes f::"real \<Rightarrow> 'b::euclidean_space"
	assumes "(f has_vector_derivative f') (at x0 within S)"
	shows "((\<lambda>x. (f x - f x0) /\<^sub>R (x - x0)) \<longlongrightarrow> f') (at x0 within S)"
	apply (rule LIM_zero_cancel)
	apply (rule tendsto_norm_zero_cancel)
	apply (rule Lim_transform_eventually)
	proof -
	show "\<forall>\<^sub>F x in at x0 within S. norm ((f x - f x0 - (x - x0) *\<^sub>R f') /\<^sub>R norm (x - x0)) =
	norm ((f x - f x0) /\<^sub>R (x - x0) - f')"
	(is "\<forall>\<^sub>F x in _. ?th x")
	unfolding eventually_at_filter
	proof (safe intro!: eventuallyI)
	fix x assume x: "x \<noteq> x0"
	then have "norm ((f x - f x0) /\<^sub>R (x - x0) - f') = norm (sgn (x - x0) *\<^sub>R ((f x - f x0) /\<^sub>R (x - x0) - f'))"
	by simp
	also have "sgn (x - x0) \<^sub>R ((f x - f x0) /\<^sub>R (x - x0) - f') = ((f x - f x0) /\<^sub>R norm (x - x0) - (x - x0) \<^sub>R f' /\<^sub>R norm (x - x0))"
	by (auto simp add: algebra_simps sgn_div_norm divide_simps)
	(metis add.commute add_divide_distrib diff_add_cancel scaleR_add_left)
	also have "\<dots> = (f x - f x0 - (x - x0) *\<^sub>R f') /\<^sub>R norm (x - x0)" by (simp add: algebra_simps)
	finally show "?th x" ..
	qed
	show "((\<lambda>x. norm ((f x - f x0 - (x - x0) *\<^sub>R f') /\<^sub>R norm (x - x0))) \<longlongrightarrow> 0) (at x0 within S)"
	by (rule tendsto_norm_zero)
	(use assms in \<open>auto simp: has_vector_derivative_def has_derivative_at_within\<close>)
	qed

	text \<open>A \<open>path_connected\<close> set \<open>S\<close> entering both \<open>T\<close> and \<open>-T\<close>
	must cross the frontier of \<open>T\<close> \<close>
	lemma path_connected_frontier:
	fixes S :: "'a::real_normed_vector set"
	assumes "path_connected S"
	assumes "S \<inter> T \<noteq> {}"
	assumes "S \<inter> -T \<noteq> {}"
	obtains s where "s \<in> S" "s \<in> frontier T"
	proof -
	obtain st where st:"st \<in> S \<inter> T" using assms(2) by blast
	obtain sn where sn:"sn \<in> S \<inter> -T" using assms(3) by blast
	obtain g where g: "path g" "path_image g \<subseteq> S"
	"pathstart g = st" "pathfinish g = sn"
	using assms(1) st sn unfolding path_connected_def by blast
	have a1:"pathstart g \<in> closure T" using st g(3) closure_Un_frontier by fastforce
	have a2:"pathfinish g \<notin> T" using sn g(4) by auto
	from exists_path_subpath_to_frontier[OF g(1) a1 a2]
	obtain h where "path_image h \<subseteq> path_image g" "pathfinish h \<in> frontier T" by metis
	thus ?thesis using g(2)
	by (meson in_mono pathfinish_in_path_image that)
	qed

	lemma path_connected_not_frontier_subset:
	fixes S :: "'a::real_normed_vector set"
	assumes "path_connected S"
	assumes "S \<inter> T \<noteq> {}"
	assumes "S \<inter> frontier T = {}"
	shows "S \<subseteq> T"
	using path_connected_frontier assms by auto

	lemma compact_attains_bounds:
	fixes f::"'a::topological_space \<Rightarrow> 'b::linorder_topology"
	assumes compact: "compact S"
	assumes ne: "S \<noteq> {}"
	assumes cont: "continuous_on S f"
	obtains l u where "l \<in> S" "u \<in> S" "\<And>x. x \<in> S \<Longrightarrow> f x \<in> {f l .. f u}"
	proof -
	from compact_continuous_image[OF cont compact]
	have compact_image: "compact (f ` S)" .
	have ne_image: "f ` S \<noteq> {}" using ne by simp
	from compact_attains_inf[OF compact_image ne_image]
	obtain l where "l \<in> S" "\<And>x. x \<in> S \<Longrightarrow> f l \<le> f x" by auto
	moreover
	from compact_attains_sup[OF compact_image ne_image]
	obtain u where "u \<in> S" "\<And>x. x \<in> S \<Longrightarrow> f x \<le> f u" by auto
	ultimately
	have "l \<in> S" "u \<in> S" "\<And>x. x \<in> S \<Longrightarrow> f x \<in> {f l .. f u}" by auto
	then show ?thesis ..
	qed

	lemma uniform_limit_const[uniform_limit_intros]:
	"uniform_limit S (\<lambda>x y. f x) (\<lambda>_. l) F" if "(f \<longlongrightarrow> l) F"
	apply (auto simp: uniform_limit_iff)
	subgoal for e
	using tendstoD[OF that(1), of e]
	by (auto simp: eventually_mono)
	done

	subsection \<open>Segments\<close>

	text \<open>\<open>closed_segment\<close> throws away the order that our intuition keeps\<close>

	definition line::"'a::real_vector \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> 'a"
	("{_ -- _}\<^bsub>_\<^esub>")
	where "{a -- b}\<^bsub>u\<^esub> = a + u *\<^sub>R (b - a)"

	abbreviation "line_image a b U \<equiv>(\<lambda>u. {a -- b}\<^bsub>u\<^esub>) ` U"
	notation line_image ("{_ -- _}\<^bsub>`_\<^esub>")

	lemma in_closed_segment_iff_line: "x \<in> {a -- b} \<longleftrightarrow> (\<exists>c\<in>{0..1}. x = line a b c)"
	by (auto simp: in_segment line_def algebra_simps)

	lemma in_open_segment_iff_line: "x \<in> {a <--< b} \<longleftrightarrow> (\<exists>c\<in>{0<..<1}. a \<noteq> b \<and> x = line a b c)"
	by (auto simp: in_segment line_def algebra_simps)

	lemma line_convex_combination1: "(1 - u) \<^sub>R line a b i + u \<^sub>R b = line a b (i + u - i * u)"
	by (auto simp: line_def algebra_simps)

	lemma line_convex_combination2: "(1 - u) \<^sub>R a + u \<^sub>R line a b i = line a b (i*u)"
	by (auto simp: line_def algebra_simps)

	lemma line_convex_combination12: "(1 - u) \<^sub>R line a b i + u \<^sub>R line a b j = line a b (i + u * (j - i))"
	by (auto simp: line_def algebra_simps)

	lemma mult_less_one_less_self: "0 < x \<Longrightarrow> i < 1 \<Longrightarrow> i * x < x" for i x::real
	by auto

	lemma plus_times_le_one_lemma: "i + u - i * u \<le> 1" if "i \<le> 1" "u \<le> 1" for i u::real
	by (simp add: diff_le_eq sum_le_prod1 that)

	lemma plus_times_less_one_lemma: "i + u - i * u < 1" if "i < 1" "u < 1" for i u::real
	proof -
	have "u * (1 - i) < 1 - i"
	using that by force
	then show ?thesis by (simp add: algebra_simps)
	qed

	lemma line_eq_endpoint_iff[simp]:
	"line a b i = b \<longleftrightarrow> (a = b \<or> i = 1)"
	"a = line a b i \<longleftrightarrow> (a = b \<or> i = 0)"
	by (auto simp: line_def algebra_simps)

	lemma line_eq_iff[simp]: "line a b x = line a b y \<longleftrightarrow> (x = y \<or> a = b)"
	by (auto simp: line_def)

	lemma line_open_segment_iff:
	"{line a b i<--<b} = line a b ` {i<..<1}"
	if "i < 1" "a \<noteq> b"
	using that
	apply (auto simp: in_segment line_convex_combination1 plus_times_less_one_lemma)
	subgoal for j
	apply (rule exI[where x="(j - i)/(1 - i)"])
	apply (auto simp: divide_simps algebra_simps)
	by (metis add_diff_cancel less_numeral_extra(4) mult_2_right plus_times_less_one_lemma that(1))
	done

	lemma open_segment_line_iff:
	"{a<--<line a b i} = line a b ` {0<..<i}"
	if "0 < i" "a \<noteq> b"
	using that
	apply (auto simp: in_segment line_convex_combination2 plus_times_less_one_lemma)
	subgoal for j
	apply (rule exI[where x="j/i"])
	- by (auto simp: )
	+ by auto
	done

	lemma line_closed_segment_iff:
	"{line a b i--b} = line a b ` {i..1}"
	if "i \<le> 1" "a \<noteq> b"
	using that
	apply (auto simp: in_segment line_convex_combination1 mult_le_cancel_right2 plus_times_le_one_lemma)
	subgoal for j
	apply (rule exI[where x="(j - i)/(1 - i)"])
	apply (auto simp: divide_simps algebra_simps)
	by (metis add_diff_cancel less_numeral_extra(4) mult_2_right plus_times_less_one_lemma that(1))
	done

	lemma closed_segment_line_iff:
	"{a--line a b i} = line a b ` {0..i}"
	if "0 < i" "a \<noteq> b"
	using that
	apply (auto simp: in_segment line_convex_combination2 plus_times_less_one_lemma)
	subgoal for j
	apply (rule exI[where x="j/i"])
	- by (auto simp: )
	+ by auto
	done

	lemma closed_segment_line_line_iff: "{line a b i1--line a b i2} = line a b ` {i1..i2}" if "i1 \<le> i2"
	using that
	apply (auto simp: in_segment line_convex_combination12 intro!: imageI)
	apply (smt mult_left_le_one_le)
	subgoal for u
	by (rule exI[where x="(u - i1)/(i2-i1)"]) auto
	done

	lemma line_line1: "line (line a b c) b x = line a b (c + x - c * x)"
	by (simp add: line_def algebra_simps)

	lemma line_line2: "line a (line a b c) x = line a b (c*x)"
	by (simp add: line_def algebra_simps)

	lemma line_in_subsegment:
	"i1 < 1 \<Longrightarrow> i2 < 1 \<Longrightarrow> a \<noteq> b \<Longrightarrow> line a b i1 \<in> {line a b i2<--<b} \<longleftrightarrow> i2 < i1"
	by (auto simp: line_open_segment_iff intro!: imageI)

	lemma line_in_subsegment2:
	"0 < i2 \<Longrightarrow> 0 < i1 \<Longrightarrow> a \<noteq> b \<Longrightarrow> line a b i1 \<in> {a<--<line a b i2} \<longleftrightarrow> i1 < i2"
	by (auto simp: open_segment_line_iff intro!: imageI)

	lemma line_in_open_segment_iff[simp]:
	"line a b i \<in> {a<--<b} \<longleftrightarrow> (a \<noteq> b \<and> 0 < i \<and> i < 1)"
	by (auto simp: in_open_segment_iff_line)

	subsection \<open>Open Segments\<close>

	lemma open_segment_subsegment:
	assumes "x1 \<in> {x0<--<x3}"
	"x2 \<in> {x1<--<x3}"
	shows "x1 \<in> {x0<--<x2}"
	using assms
	proof -\<comment> \<open>TODO: use \<open>line\<close>\<close>
	from assms obtain u v::real where
	ne: "x0 \<noteq> x3" "(1 - u) \<^sub>R x0 + u \<^sub>R x3 \<noteq> x3"
	and x1_def: "x1 = (1 - u) \<^sub>R x0 + u \<^sub>R x3"
	and x2_def: "x2 = (1 - v) \<^sub>R ((1 - u) \<^sub>R x0 + u \<^sub>R x3) + v \<^sub>R x3"
	and uv: \<open>0 < u\<close> \<open>0 < v\<close> \<open>u < 1\<close> \<open>v < 1\<close>
	by (auto simp: in_segment)
	let ?d = "(u + v - u * v)"
	have "?d > 0" using uv
	by (auto simp: add_nonneg_pos pos_add_strict)
	with \<open>x0 \<noteq> x3\<close> have "0 \<noteq> ?d *\<^sub>R (x3 - x0)" by simp
	moreover
	define ua where "ua = u / ?d"
	have "ua * (u * v - u - v) - - u = 0"
	by (auto simp: ua_def algebra_simps divide_simps)
	(metis uv add_less_same_cancel1 add_strict_mono mult.right_neutral
	mult_less_cancel_left_pos not_real_square_gt_zero vector_space_over_itself.scale_zero_left)
	then have "(ua * (u * v - u - v) - - u) *\<^sub>R (x3 - x0) = 0"
	by simp
	moreover
	have "0 < ua" "ua < 1"
	using \<open>0 < u\<close> \<open>0 < v\<close> \<open>u < 1\<close> \<open>v < 1\<close>
	by (auto simp: ua_def pos_add_strict intro!: divide_pos_pos)
	ultimately show ?thesis
	unfolding x1_def x2_def
	by (auto intro!: exI[where x=ua] simp: algebra_simps in_segment)
	qed


	subsection \<open>Syntax\<close>

	abbreviation sequentially_at_top::"(nat\<Rightarrow>real)\<Rightarrow>bool"
	("_ \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity>") \<comment> \<open>the \<open>\<^bsub>\<^esub>\<close> is to disambiguate syntax...\<close>
	where "s \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity> \<equiv> filterlim s at_top sequentially"

	abbreviation sequentially_at_bot::"(nat\<Rightarrow>real)\<Rightarrow>bool"
	("_ \<longlonglongrightarrow>\<^bsub>\<^esub> -\<infinity>")
	where "s \<longlonglongrightarrow>\<^bsub>\<^esub> -\<infinity> \<equiv> filterlim s at_bot sequentially"


	subsection \<open>Paths\<close>

	lemma subpath0_linepath:
	shows "subpath 0 u (linepath t t') = linepath t (t + u * (t' - t))"
	unfolding subpath_def linepath_def
	apply (rule ext)
	apply auto
	proof -
	fix x :: real
	have f1: "\<And>r ra rb rc. (r::real) + ra * rb - ra * rc = r - ra * (rc - rb)"
	by (simp add: right_diff_distrib')
	have f2: "\<And>r ra. (r::real) - r * ra = r * (1 - ra)"
	by (simp add: right_diff_distrib')
	have f3: "\<And>r ra rb. (r::real) - ra + rb + ra - r = rb"
	by auto
	have f4: "\<And>r. (r::real) + (1 - 1) = r"
	by linarith
	have f5: "\<And>r ra. (r::real) + ra = ra + r"
	by force
	have f6: "\<And>r ra. (r::real) + (1 - (r + 1) + ra) = ra"
	by linarith
	have "t - x * (t - (t + u * (t' - t))) = t' * (u * x) + (t - t * (u * x))"
	by (simp add: right_diff_distrib')
	then show "(1 - u * x) * t + u * x * t' = (1 - x) * t + x * (t + u * (t' - t))"
	using f6 f5 f4 f3 f2 f1 by (metis (no_types) mult.commute)
	qed

	lemma linepath_image0_right_open_real:
	assumes "t < (t'::real)"
	shows "linepath t t' ` {0..<1} = {t..<t'}"
	unfolding linepath_def
	apply auto
	apply (metis add.commute add_diff_cancel_left' assms diff_diff_eq2 diff_le_eq less_eq_real_def mult.commute mult.right_neutral mult_right_mono right_diff_distrib')
	apply (smt assms comm_semiring_class.distrib mult_diff_mult semiring_normalization_rules(2) zero_le_mult_iff)
	proof -
	fix x
	assume "t \<le> x" "x < t'"
	let ?u = "(x-t)/(t'-t)"
	have "?u \<ge> 0"
	using \<open>t \<le> x\<close> assms by auto
	moreover have "?u < 1"
	by (simp add: \<open>x < t'\<close> assms)
	moreover have "x = (1-?u) * t + ?u*t'"
	proof -
	have f1: "\<forall>r ra. (ra::real) * - r = r * - ra"
	by simp
	have "t + (t' + - t) * ((x + - t) / (t' + - t)) = x"
	using assms by force
	then have "t' * ((x + - t) / (t' + - t)) + t * (1 + - ((x + - t) / (t' + - t))) = x"
	using f1 by (metis (no_types) add.left_commute distrib_left mult.commute mult.right_neutral)
	then show ?thesis
	by (simp add: mult.commute)
	qed
	ultimately show "x \<in> (\<lambda>x. (1 - x) * t + x * t') ` {0..<1}"
	using atLeastLessThan_iff by blast
	qed

	lemma oriented_subsegment_scale:
	assumes "x1 \<in> {a<--<b}"
	assumes "x2 \<in> {x1<--<b}"
	obtains e where "e > 0" "b-a = e *\<^sub>R (x2-x1)"
	proof -
	from assms(1) obtain u where u : "u > 0" "u < 1" "x1 = (1 - u) \<^sub>R a + u \<^sub>R b"
	unfolding in_segment by blast
	from assms(2) obtain v where v: "v > 0" "v < 1" "x2 = (1 - v) \<^sub>R x1 + v \<^sub>R b"
	unfolding in_segment by blast
	have "x2-x1 = -v \<^sub>R x1 + v \<^sub>R b" using v
	by (metis add.commute add_diff_cancel_right diff_minus_eq_add scaleR_collapse scaleR_left.minus)
	also have "... = (-v) \<^sub>R ((1 - u) \<^sub>R a + u \<^sub>R b) + v \<^sub>R b" using u by auto
	also have "... = v \<^sub>R ((1-u)\<^sub>R b - (1-u)*\<^sub>R a )"
	by (smt add_diff_cancel diff_diff_add diff_minus_eq_add minus_diff_eq scaleR_collapse scale_minus_left scale_right_diff_distrib)
	finally have x2x1:"x2-x1 = (v (1-u)) \<^sub>R (b - a)"
	by (metis scaleR_scaleR scale_right_diff_distrib)
	have "v * (1-u) > 0" using u(2) v(1) by simp
	then have "(x2-x1)/\<^sub>R (v * (1-u)) = (b-a)" unfolding x2x1
	by (smt field_class.field_inverse scaleR_one scaleR_scaleR)
	thus ?thesis
	using \<open>0 < v * (1 - u)\<close> positive_imp_inverse_positive that by fastforce
	qed

	end
	diff --git a/thys/Poincare_Bendixson/ODE_Misc.thy b/thys/Poincare_Bendixson/ODE_Misc.thy
	--- a/thys/Poincare_Bendixson/ODE_Misc.thy
	+++ b/thys/Poincare_Bendixson/ODE_Misc.thy
	@@ -1,1111 +1,1111 @@
	section \<open>Additions to the ODE Library\<close>
	theory ODE_Misc
	imports
	Ordinary_Differential_Equations.ODE_Analysis
	Analysis_Misc
	begin

	lemma local_lipschitz_compact_bicomposeE:
	assumes ll: "local_lipschitz T X f"
	assumes cf: "\<And>x. x \<in> X \<Longrightarrow> continuous_on I (\<lambda>t. f t x)"
	assumes cI: "compact I"
	assumes "I \<subseteq> T"
	assumes cv: "continuous_on I v"
	assumes cw: "continuous_on I w"
	assumes v: "v ` I \<subseteq> X"
	assumes w: "w ` I \<subseteq> X"
	obtains L where "L > 0" "\<And>x. x \<in> I \<Longrightarrow> dist (f x (v x)) (f x (w x)) \<le> L * dist (v x) (w x)"
	proof -
	from v w have "v ` I \<union> w ` I \<subseteq> X" by auto
	with ll \<open>I \<subseteq> T\<close> have llI:"local_lipschitz I (v ` I \<union> w ` I) f"
	by (rule local_lipschitz_subset)
	have cvwI: "compact (v ` I \<union> w ` I)"
	by (auto intro!: compact_continuous_image cv cw cI)

	from local_lipschitz_compact_implies_lipschitz[OF llI cvwI \<open>compact I\<close> cf]
	obtain L where L: "\<And>t. t \<in> I \<Longrightarrow> L-lipschitz_on (v ` I \<union> w ` I) (f t)"
	using v w
	by blast
	define L' where "L' = max L 1"
	with L have "L' > 0" "\<And>x. x \<in> I \<Longrightarrow> dist (f x (v x)) (f x (w x)) \<le> L' * dist (v x) (w x)"
	apply (auto simp: lipschitz_on_def L'_def)
	by (smt Un_iff image_eqI mult_right_mono zero_le_dist)
	then show ?thesis ..
	qed

	subsection \<open>Comparison Principle\<close>

	lemma comparison_principle_le:
	fixes f::"real \<Rightarrow> real \<Rightarrow> real"
	and \<phi> \<psi>::"real \<Rightarrow> real"
	assumes ll: "local_lipschitz X Y f"
	assumes cf: "\<And>x. x \<in> Y \<Longrightarrow> continuous_on {a..b} (\<lambda>t. f t x)"
	assumes abX: "{a .. b} \<subseteq> X"
	assumes \<phi>': "\<And>x. x \<in> {a .. b} \<Longrightarrow> (\<phi> has_real_derivative \<phi>' x) (at x)"
	assumes \<psi>': "\<And>x. x \<in> {a .. b} \<Longrightarrow> (\<psi> has_real_derivative \<psi>' x) (at x)"
	assumes \<phi>_in: "\<phi> ` {a..b} \<subseteq> Y"
	assumes \<psi>_in: "\<psi> ` {a..b} \<subseteq> Y"
	assumes init: "\<phi> a \<le> \<psi> a"
	assumes defect: "\<And>x. x \<in> {a .. b} \<Longrightarrow> \<phi>' x - f x (\<phi> x) \<le> \<psi>' x - f x (\<psi> x)"
	shows "\<forall>x \<in> {a .. b}. \<phi> x \<le> \<psi> x" (is "?th1")
	(*
	"(\<forall>x \<in> {a .. b}. \<phi> x < \<psi> x) \<or> (\<exists>c\<in>{a..b}. (\<forall>x\<in>{a..c}. \<phi> x \<le> \<psi> x) \<and> (\<forall>x\<in>{c<..b}. \<phi> x < \<psi> x))"
	(is "?th2")
	*)
	unfolding atomize_conj
	apply (cases "a \<le> b")
	defer subgoal by simp
	proof -
	assume "a \<le> b"
	note \<phi>_cont = has_real_derivative_imp_continuous_on[OF \<phi>']
	note \<psi>_cont = has_real_derivative_imp_continuous_on[OF \<psi>']
	from local_lipschitz_compact_bicomposeE[OF ll cf compact_Icc abX \<phi>_cont \<psi>_cont \<phi>_in \<psi>_in]
	obtain L where L: "L > 0" "\<And>x. x \<in> {a..b} \<Longrightarrow> dist (f x (\<phi> x)) (f x (\<psi> x)) \<le> L * dist (\<phi> x) (\<psi> x)" by blast
	define w where "w x = \<psi> x - \<phi> x" for x

	have w'[derivative_intros]: "\<And>x. x \<in> {a .. b} \<Longrightarrow> (w has_real_derivative \<psi>' x - \<phi>' x) (at x)"
	using \<phi>' \<psi>'
	by (auto simp: has_vderiv_on_def w_def[abs_def] intro!: derivative_eq_intros)
	note w_cont[continuous_intros] = has_real_derivative_imp_continuous_on[OF w', THEN continuous_on_compose2]
	have "w d \<ge> 0" if "d \<in> {a .. b}" for d
	proof (rule ccontr, unfold not_le)
	assume "w d < 0"
	let ?N = "(w -` {..0} \<inter> {a .. d})"
	from \<open>w d < 0\<close> that have "d \<in> ?N" by auto
	then have "?N \<noteq> {}" by auto
	have "closed ?N"
	unfolding compact_eq_bounded_closed
	using that
	by (intro conjI closed_vimage_Int) (auto intro!: continuous_intros)

	let ?N' = "{a0 \<in> {a .. d}. w ` {a0 .. d} \<subseteq> {..0}}"
	from \<open>w d < 0\<close> that have "d \<in> ?N'" by simp
	then have "?N' \<noteq> {}" by auto
	have "compact ?N'"
	unfolding compact_eq_bounded_closed
	proof
	have "?N' \<subseteq> {a .. d}" using that by auto
	then show "bounded ?N'"
	by (rule bounded_subset[rotated]) simp
	have "w u \<le> 0" if "(\<forall>n. x n \<in> ?N')" "x \<longlonglongrightarrow> l" "l \<le> u" "u \<le> d" for x l u
	proof cases
	assume "l = u"
	have "\<forall>n. x n \<in> ?N" using that(1) by force
	from closed_sequentially[OF \<open>closed ?N\<close> this \<open>x \<longlonglongrightarrow> l\<close>]
	show ?thesis by (auto simp: \<open>l = u\<close>)
	next
	assume "l \<noteq> u" with that have "l < u" by auto
	from order_tendstoD(2)[OF \<open>x \<longlonglongrightarrow> l\<close> \<open>l < u\<close>] obtain n where "x n < u"
	by (auto dest: eventually_happens)
	with that show ?thesis using \<open>l < u\<close>
	by (auto dest!: spec[where x=n] simp: image_subset_iff)
	qed
	then show "closed ?N'"
	unfolding closed_sequential_limits
	by (auto simp: Lim_bounded Lim_bounded2)
	qed

	from compact_attains_inf[OF \<open>compact ?N'\<close> \<open>?N' \<noteq> {}\<close>]
	obtain a0 where a0: "a \<le> a0" "a0 \<le> d" "w ` {a0..d} \<subseteq> {..0}"
	and a0_least: "\<And>x. a \<le> x \<Longrightarrow> x \<le> d \<Longrightarrow> w ` {x..d} \<subseteq> {..0} \<Longrightarrow> a0 \<le> x"
	by auto
	have a0d: "{a0 .. d} \<subseteq> {a .. b}" using that a0
	by auto
	have L_w_bound: "L * w x \<le> \<psi>' x - \<phi>' x" if "x \<in> {a0 .. d}" for x
	proof -
	from set_mp[OF a0d that] have "x \<in> {a .. b}" .
	from defect[OF this]
	have "\<phi>' x - \<psi>' x \<le> dist (f x (\<phi> x)) (f x (\<psi> x))"
	by (simp add: dist_real_def)
	also have "\<dots> \<le> L * dist (\<phi> x) (\<psi> x)"
	using \<open>x \<in> {a .. b}\<close>
	by (rule L)
	also have "\<dots> \<le> -L * w x"
	using \<open>0 < L\<close> a0 that
	by (force simp add: dist_real_def abs_real_def w_def algebra_split_simps )
	finally show ?thesis
	by simp
	qed
	have mono: "mono_on (\<lambda>x. w x * exp(-L*x)) {a0..d}"
	apply (rule mono_onI)
	apply (rule DERIV_nonneg_imp_nondecreasing, assumption)
	using a0d
	by (auto intro!: exI[where x="(\<psi>' x - \<phi>' x) * exp (- (L * x)) - exp (- (L * x)) * L * w x" for x]
	derivative_eq_intros L_w_bound simp: )
	then have "w a0 * exp (-L * a0) \<le> w d * exp (-L * d)"
	by (rule mono_onD) (use that a0 in auto)
	also have "\<dots> < 0" using \<open>w d < 0\<close> by (simp add: algebra_split_simps)
	finally have "w a0 * exp (- L * a0) < 0" .
	then have "w a0 < 0" by (simp add: algebra_split_simps)
	have "a0 \<le> a"
	proof (rule ccontr, unfold not_le)
	assume "a < a0"
	have "continuous_on {a.. a0} w"
	by (rule continuous_intros, assumption) (use a0 a0d in auto)
	from continuous_on_Icc_at_leftD[OF this \<open>a < a0\<close>]
	have "(w \<longlongrightarrow> w a0) (at_left a0)" .
	from order_tendstoD(2)[OF this \<open>w a0 < 0\<close>] have "\<forall>\<^sub>F x in at_left a0. w x < 0" .
	moreover have "\<forall>\<^sub>F x in at_left a0. a < x"
	by (rule order_tendstoD) (auto intro!: \<open>a < a0\<close>)
	ultimately have "\<forall>\<^sub>F x in at_left a0. a < x \<and> w x < 0" by eventually_elim auto
	then obtain a1' where "a1'<a0" and a1_neg: "\<And>y. y > a1' \<Longrightarrow> y < a0 \<Longrightarrow> a < y \<and> w y < 0"
	unfolding eventually_at_left_field by auto
	define a1 where "a1 = (a1' + a0)/2"
	have "a1 < a0" using \<open>a1' < a0\<close> by (auto simp: a1_def)
	have "a \<le> a1"
	using \<open>a < a0\<close> a1_neg by (force simp: a1_def)
	moreover have "a1 \<le> d"
	using \<open>a1' < a0\<close> a0(2) by (auto simp: a1_def)
	moreover have "w ` {a1..a0} \<subseteq> {..0}"
	using \<open>w a0 < 0\<close> a1_neg a0(3)
	by (auto simp: a1_def) smt
	moreover have "w ` {a0..d} \<subseteq> {..0}" using a0 by auto
	ultimately
	have "a0 \<le> a1"
	apply (intro a0_least) apply assumption apply assumption
	by (smt atLeastAtMost_iff image_subset_iff)
	with \<open>a1<a0\<close> show False by simp
	qed
	then have "a0 = a" using \<open>a \<le> a0\<close> by simp
	with \<open>w a0 < 0\<close> have "w a < 0" by simp
	with init show False
	by (auto simp: w_def)
	qed
	then show ?thesis
	by (auto simp: w_def)
	qed

	lemma local_lipschitz_mult:
	shows "local_lipschitz (UNIV::real set) (UNIV::real set) (*)"
	apply (auto intro!: c1_implies_local_lipschitz[where f'="\<lambda>p. blinfun_mult_left (fst p)"])
	apply (simp add: has_derivative_mult_right mult_commute_abs)
	by (auto intro!: continuous_intros)

	lemma comparison_principle_le_linear:
	fixes \<phi> :: "real \<Rightarrow> real"
	assumes "continuous_on {a..b} g"
	assumes "(\<And>t. t \<in> {a..b} \<Longrightarrow> (\<phi> has_real_derivative \<phi>' t) (at t))"
	assumes "\<phi> a \<le> 0"
	assumes "(\<And>t. t \<in> {a..b} \<Longrightarrow> \<phi>' t \<le> g t *\<^sub>R \<phi> t)"
	shows "\<forall>t\<in>{a..b}. \<phi> t \<le> 0"
	proof -
	have : "\<And>x. continuous_on {a..b} (\<lambda>t. g t x)"
	using assms(1) continuous_on_mult_right by blast
	then have "local_lipschitz (g`{a..b}) UNIV (*)"
	using local_lipschitz_subset[OF local_lipschitz_mult] by blast
	from local_lipschitz_compose1[OF this assms(1)]
	have "local_lipschitz {a..b} UNIV (\<lambda>t. (*) (g t))" .
	from comparison_principle_le[OF this _ _ assms(2) _ _ _ assms(3), of b "\<lambda>t.0"] * assms(4)
	show ?thesis by auto
	qed

	subsection \<open>Locally Lipschitz ODEs\<close>

	context ll_on_open_it begin

	lemma flow_lipschitzE:
	assumes "{a .. b} \<subseteq> existence_ivl t0 x"
	obtains L where "L-lipschitz_on {a .. b} (flow t0 x)"
	proof -
	have f': "(flow t0 x has_derivative (\<lambda>i. i *\<^sub>R f t (flow t0 x t))) (at t within {a .. b})" if "t \<in> {a .. b}" for t
	using flow_has_derivative[of t x] assms that
	by (auto simp: has_derivative_at_withinI)

	have "compact ((\<lambda>t. f t (flow t0 x t)) ` {a .. b})"
	using assms
	apply (auto intro!: compact_continuous_image continuous_intros)
	using local.existence_ivl_empty2 apply fastforce
	apply (meson atLeastAtMost_iff general.existence_ivl_subset in_mono)
	by (simp add: general.flow_in_domain subset_iff)
	then obtain C where "t \<in> {a .. b} \<Longrightarrow> norm (f t (flow t0 x t)) \<le> C" for t
	by (fastforce dest!: compact_imp_bounded simp: bounded_iff intro: that)
	then have "t \<in> {a..b} \<Longrightarrow> onorm (\<lambda>i. i *\<^sub>R f t (flow t0 x t)) \<le> max 0 C" for t
	apply (subst onorm_scaleR_left)
	apply (auto simp: onorm_id max_def)
	by (metis diff_0_right diff_mono diff_self norm_ge_zero)
	from bounded_derivative_imp_lipschitz[OF f' _ this]
	have "(max 0 C)-lipschitz_on {a..b} (flow t0 x)"
	by auto
	then show ?thesis ..
	qed

	lemma flow_undefined0: "t \<notin> existence_ivl t0 x \<Longrightarrow> flow t0 x t = 0"
	unfolding flow_def by auto

	lemma csols_undefined: "x \<notin> X \<Longrightarrow> csols t0 x = {}"
	apply (auto simp: csols_def)
	using general.existence_ivl_empty2 general.existence_ivl_maximal_segment
	apply blast
	done

	lemmas existence_ivl_undefined = existence_ivl_empty2

	end

	subsection \<open>Reverse flow as Sublocale\<close>

	lemma range_preflect_0[simp]: "range (preflect 0) = UNIV"
	by (auto simp: preflect_def)
	lemma range_uminus[simp]: "range uminus = (UNIV::'a::ab_group_add set)"
	by auto

	context auto_ll_on_open begin

	sublocale rev: auto_ll_on_open "-f" rewrites "-(-f) = f"
	apply unfold_locales
	using auto_local_lipschitz auto_open_domain
	unfolding fun_Compl_def local_lipschitz_minus
	by auto

	lemma existence_ivl_eq_rev0: "existence_ivl0 y = uminus ` rev.existence_ivl0 y" for y
	by (auto simp: existence_ivl_eq_rev rev.existence_ivl0_def preflect_def)

	lemma rev_existence_ivl_eq0: "rev.existence_ivl0 y = uminus ` existence_ivl0 y" for y
	using uminus_uminus_image[of "rev.existence_ivl0 y"]
	by (simp add: existence_ivl_eq_rev0)

	lemma flow_eq_rev0: "flow0 y t = rev.flow0 y (-t)" for y t
	apply (cases "t \<in> existence_ivl0 y")
	subgoal
	apply (subst flow_eq_rev(2), assumption)
	apply (subst rev.flow0_def)
	by (simp add: preflect_def)
	subgoal
	apply (frule flow_undefined0)
	by (auto simp: existence_ivl_eq_rev0 rev.flow_undefined0)
	done

	lemma rev_eq_flow: "rev.flow0 y t = flow0 y (-t)" for y t
	apply (subst flow_eq_rev0)
	using uminus_uminus_image[of "rev.existence_ivl0 y"]
	apply -
	apply (subst (asm) existence_ivl_eq_rev0[symmetric])
	by auto

	lemma rev_flow_image_eq: "rev.flow0 x ` S = flow0 x ` (uminus ` S)"
	unfolding rev_eq_flow[abs_def]
	by force

	lemma flow_image_eq_rev: "flow0 x ` S = rev.flow0 x ` (uminus ` S)"
	unfolding rev_eq_flow[abs_def]
	by force

	end

	context c1_on_open begin

	sublocale rev: c1_on_open "-f" "-f'" rewrites "-(-f) = f" and "-(-f') = f'"
	by (rule c1_on_open_rev) auto

	end

	context c1_on_open_euclidean begin

	sublocale rev: c1_on_open_euclidean "-f" "-f'" rewrites "-(-f) = f" and "-(-f') = f'"
	by unfold_locales auto

	end


	subsection \<open>Autonomous LL ODE : Existence Interval and trapping on the interval\<close>

	lemma bdd_above_is_intervalI: "bdd_above I"
	if "is_interval I" "a \<le> b" "a \<in> I" "b \<notin> I" for I::"real set"
	by (meson bdd_above_def is_interval_1 le_cases that)

	lemma bdd_below_is_intervalI: "bdd_below I"
	if "is_interval I" "a \<le> b" "a \<notin> I" "b \<in> I" for I::"real set"
	by (meson bdd_below_def is_interval_1 le_cases that)

	context auto_ll_on_open begin

	lemma open_existence_ivl0:
	assumes x : "x \<in> X"
	shows "\<exists>a b. a < 0 \<and> 0 < b \<and> {a..b} \<subseteq> existence_ivl0 x"
	proof -
	have a1:"0 \<in> existence_ivl0 x"
	by (simp add: x)
	have a2: "open (existence_ivl0 x)"
	by (simp add: x)
	from a1 a2 obtain d where "d > 0" "ball 0 d \<subseteq> existence_ivl0 x"
	using openE by blast
	have "{-d/2..d/2} \<subseteq> ball 0 d"
	using \<open>0 < d\<close> dist_norm mem_ball by auto
	thus ?thesis
	by (smt \<open>0 < d\<close> \<open>ball 0 d \<subseteq> existence_ivl0 x\<close> divide_minus_left half_gt_zero order_trans)
	qed

	lemma open_existence_ivl':
	assumes x : "x \<in> X"
	obtains a where "a > 0" "{-a..a} \<subseteq> existence_ivl0 x"
	proof -
	from open_existence_ivl0[OF assms(1)]
	obtain a b where ab: "a < 0" "0 < b" "{a..b} \<subseteq> existence_ivl0 x" by auto
	then have "min (-a) b > 0" by linarith
	have "{-min (-a) b .. min(-a) b} \<subseteq> {a..b}" by auto
	thus ?thesis using ab(3) that[OF \<open>min (-a) b > 0\<close>] by blast
	qed

	lemma open_existence_ivl_on_compact:
	assumes C: "C \<subseteq> X" and "compact C" "C \<noteq> {}"
	obtains a where "a > 0" "\<And>x. x \<in> C \<Longrightarrow> {-a..a} \<subseteq> existence_ivl0 x"
	proof -
	from existence_ivl_cballs
	have "\<forall>x\<in>C. \<exists>e>0. \<exists>t>0. \<forall>y\<in>cball x e. cball 0 t\<subseteq>existence_ivl0 y"
	by (metis (full_types) C Int_absorb1 Int_iff UNIV_I)
	then
	obtain d' t' where *:
	"\<forall>x\<in>C. 0 < d' x \<and> t' x > 0 \<and> (\<forall>y\<in>cball x (d' x). cball 0 (t' x) \<subseteq> existence_ivl0 y)"
	by metis
	with compactE_image[OF \<open>compact C\<close>, of C "\<lambda>x. ball x (d' x)"]
	obtain C' where "C' \<subseteq> C" and [simp]: "finite C'" and C_subset: "C \<subseteq> (\<Union>c\<in>C'. ball c (d' c))"
	by force
	from C_subset \<open>C \<noteq> {}\<close> have [simp]: "C' \<noteq> {}" by auto
	define d where "d = Min (d' ` C')"
	define t where "t = Min (t' ` C')"
	have "t > 0" using * \<open>C' \<subseteq> C\<close>
	by (auto simp: t_def)
	moreover have "{-t .. t} \<subseteq> existence_ivl0 x" if "x \<in> C" for x
	proof -
	from C_subset that \<open>C' \<subseteq> C\<close>
	obtain c where c: "c \<in> C'" "x \<in> ball c (d' c)" "c \<in> C" by force
	then have "{-t .. t} \<subseteq> cball 0 (t' c)"
	by (auto simp: abs_real_def t_def minus_le_iff)
	also
	from c have "cball 0 (t' c) \<subseteq> existence_ivl0 x"
	using *[rule_format, OF \<open>c \<in> C\<close>] by auto
	finally show ?thesis .
	qed
	ultimately show ?thesis ..
	qed

	definition "trapped_forward x K \<longleftrightarrow> (flow0 x ` (existence_ivl0 x \<inter> {0..}) \<subseteq> K)"
	\<comment> \<open>TODO: use this for backwards trapped, invariant, and all assumptions\<close>

	definition "trapped_backward x K \<longleftrightarrow> (flow0 x ` (existence_ivl0 x \<inter> {..0}) \<subseteq> K)"

	definition "trapped x K \<longleftrightarrow> trapped_forward x K \<and> trapped_backward x K"

	lemma trapped_iff_on_existence_ivl0:
	"trapped x K \<longleftrightarrow> (flow0 x ` (existence_ivl0 x) \<subseteq> K)"
	unfolding trapped_def trapped_forward_def trapped_backward_def
	apply (auto)
	by (metis IntI atLeast_iff atMost_iff image_subset_iff less_eq_real_def linorder_not_less)
	end

	context auto_ll_on_open begin

	lemma infinite_rev_existence_ivl0_rewrites:
	"{0..} \<subseteq> rev.existence_ivl0 x \<longleftrightarrow> {..0} \<subseteq> existence_ivl0 x"
	"{..0} \<subseteq> rev.existence_ivl0 x \<longleftrightarrow> {0..} \<subseteq> existence_ivl0 x"
	apply (auto simp add: rev.rev_existence_ivl_eq0 subset_iff)
	using neg_le_0_iff_le apply fastforce
	using neg_0_le_iff_le by fastforce

	lemma trapped_backward_iff_rev_trapped_forward:
	"trapped_backward x K \<longleftrightarrow> rev.trapped_forward x K"
	unfolding trapped_backward_def rev.trapped_forward_def
	by (auto simp add: rev_flow_image_eq existence_ivl_eq_rev0 image_subset_iff)

	text \<open>If solution is trapped in a compact set at some time
	on its existence interval then it is trapped forever\<close>
	lemma trapped_sol_right:
	\<comment> \<open>TODO: when building on afp-devel (??? outdated):
	\<^url>\<open>https://bitbucket.org/isa-afp/afp-devel/commits/0c3edf9248d5389197f248c723b625c419e4d3eb\<close>\<close>
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	shows "{0..} \<subseteq> existence_ivl0 x"
	proof (rule ccontr)
	assume "\<not> {0..} \<subseteq> existence_ivl0 x"
	from this obtain t where "0 \<le> t" "t \<notin> existence_ivl0 x" by blast
	then have bdd: "bdd_above (existence_ivl0 x)"
	by (auto intro!: bdd_above_is_intervalI \<open>x \<in> X\<close>)
	from flow_leaves_compact_ivl_right [OF UNIV_I \<open>x \<in> X\<close> bdd UNIV_I assms(1-2)]
	show False by (metis assms(4) trapped_forward_def IntI atLeast_iff image_subset_iff)
	qed

	lemma trapped_sol_right_gen:
	assumes "compact K" "K \<subseteq> X"
	assumes "t \<in> existence_ivl0 x" "trapped_forward (flow0 x t) K"
	shows "{t..} \<subseteq> existence_ivl0 x"
	proof -
	have "x \<in> X"
	using assms(3) local.existence_ivl_empty_iff by fastforce
	have xtk: "flow0 x t \<in> X"
	by (simp add: assms(3) local.flow_in_domain)
	from trapped_sol_right[OF assms(1-2) xtk assms(4)] have "{0..} \<subseteq> existence_ivl0 (flow0 x t)" .
	thus "{t..} \<subseteq> existence_ivl0 x"
	using existence_ivl_trans[OF assms(3)]
	by (metis add.commute atLeast_iff diff_add_cancel le_add_same_cancel1 subset_iff)
	qed

	lemma trapped_sol_left:
	\<comment> \<open>TODO: when building on afp-devel:
	\<^url>\<open>https://bitbucket.org/isa-afp/afp-devel/commits/0c3edf9248d5389197f248c723b625c419e4d3eb\<close>\<close>
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_backward x K"
	shows "{..0} \<subseteq> existence_ivl0 x"
	proof (rule ccontr)
	assume "\<not> {..0} \<subseteq> existence_ivl0 x"
	from this obtain t where "t \<le> 0" "t \<notin> existence_ivl0 x" by blast
	then have bdd: "bdd_below (existence_ivl0 x)"
	by (auto intro!: bdd_below_is_intervalI \<open>x \<in> X\<close>)
	from flow_leaves_compact_ivl_left [OF UNIV_I \<open>x \<in> X\<close> bdd UNIV_I assms(1-2)]
	show False
	by (metis IntI assms(4) atMost_iff auto_ll_on_open.trapped_backward_def auto_ll_on_open_axioms image_subset_iff)
	qed

	lemma trapped_sol_left_gen:
	assumes "compact K" "K \<subseteq> X"
	assumes "t \<in> existence_ivl0 x" "trapped_backward (flow0 x t) K"
	shows "{..t} \<subseteq> existence_ivl0 x"
	proof -
	have "x \<in> X"
	using assms(3) local.existence_ivl_empty_iff by fastforce
	have xtk: "flow0 x t \<in> X"
	by (simp add: assms(3) local.flow_in_domain)
	from trapped_sol_left[OF assms(1-2) xtk assms(4)] have "{..0} \<subseteq> existence_ivl0 (flow0 x t)" .
	thus "{..t} \<subseteq> existence_ivl0 x"
	using existence_ivl_trans[OF assms(3)]
	by (metis add.commute add_le_same_cancel1 atMost_iff diff_add_cancel subset_eq)
	qed

	lemma trapped_sol:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped x K"
	shows "existence_ivl0 x = UNIV"
	by (metis (mono_tags, lifting) assms existence_ivl_zero image_subset_iff interval local.existence_ivl_initial_time_iff local.existence_ivl_subset local.subset_mem_compact_implies_subset_existence_interval order_refl subset_antisym trapped_iff_on_existence_ivl0)

	(* Follows from rectification *)
	lemma regular_locally_noteq:\<comment> \<open>TODO: should be true in \<open>ll_on_open_it\<close>\<close>
	assumes "x \<in> X" "f x \<noteq> 0"
	shows "eventually (\<lambda>t. flow0 x t \<noteq> x) (at 0)"
	proof -
	have nf:"norm (f x) > 0" by (simp add: assms(2))
	(* By continuity of solutions and f probably *)
	obtain a where
	a: "a>0"
	"{-a--a} \<subseteq> existence_ivl0 x"
	"0 \<in> {-a--a}"
	"\<And>t. t \<in> {-a--a} \<Longrightarrow> norm(f (flow0 x t) - f (flow0 x 0)) \<le> norm(f x)/2"
	proof -
	from open_existence_ivl'[OF assms(1)]
	obtain a1 where a1: "a1 > 0" "{-a1..a1} \<subseteq> existence_ivl0 x" .
	have "continuous (at 0) (\<lambda>t. norm(f (flow0 x t) - f (flow0 x 0) ))"
	apply (auto intro!: continuous_intros)
	by (simp add: assms(1) local.f_flow_continuous)
	then obtain a2 where "a2>0"
	"\<forall>t. norm t < a2 \<longrightarrow>
	norm (f (flow0 x t) - f (flow0 x 0)) < norm(f x)/2"
	unfolding continuous_at_real_range
	by (metis abs_norm_cancel cancel_comm_monoid_add_class.diff_cancel diff_zero half_gt_zero nf norm_zero)
	then have
	t: "\<And>t. t \<in> {-a2<--<a2} \<Longrightarrow> norm(f (flow0 x t) - f (flow0 x 0)) \<le> norm(f x)/2"
	by (smt open_segment_bound(2) open_segment_bound1 real_norm_def)
	define a where "a = min a1 (a2/2)"
	have t1:"a > 0" unfolding a_def using \<open>a1 > 0\<close> \<open>a2 > 0\<close> by auto
	then have t3:"0 \<in>{-a--a}"
	using closed_segment_eq_real_ivl by auto
	have "{-a--a} \<subseteq> {-a1..a1}" unfolding a_def using \<open>a1 > 0\<close> \<open>a2 > 0\<close>
	using ODE_Auxiliarities.closed_segment_eq_real_ivl by auto
	then have t2:"{-a--a} \<subseteq> existence_ivl0 x" using a1 by auto
	have "{-a--a} \<subseteq> {-a2<--<a2}" unfolding a_def using \<open>a1 > 0\<close> \<open>a2 > 0\<close>
	by (smt Diff_iff closed_segment_eq_real_ivl atLeastAtMost_iff empty_iff half_gt_zero insert_iff pos_half_less segment(1) subset_eq)
	then have t4:"\<And>t. t \<in> {-a--a} \<Longrightarrow> norm(f (flow0 x t) - f (flow0 x 0)) \<le> norm(f x)/2" using t by auto
	show ?thesis using t1 t2 t3 t4 that by auto
	qed
	have "\<And>t. t \<in> {-a--a} \<Longrightarrow> (flow0 x has_vector_derivative f (flow0 x t)) (at t within {-a--a})"
	apply (rule has_vector_derivative_at_within)
	using a(2) by (auto intro!:flow_has_vector_derivative)
	from vector_differentiable_bound_linearization[OF this _ a(4)]
	have nb:"\<And>c d. {c--d} \<subseteq> {-a--a} \<Longrightarrow>
	norm (flow0 x d - flow0 x c - (d - c) \<^sub>R f (flow0 x 0)) \<le> norm (d - c) (norm (f x) / 2)"
	using a(3) by blast
	have "\<And>t. dist t 0 < a \<Longrightarrow> t \<noteq> 0 \<Longrightarrow> flow0 x t \<noteq> x"
	proof (rule ccontr)
	fix t
	assume "dist t 0 < a" "t \<noteq> 0" "\<not> flow0 x t \<noteq> x"
	then have tx:"flow0 x t = x" by auto
	have "t \<in> {-a--a}"
	using closed_segment_eq_real_ivl \<open>dist t 0 < a\<close> by auto
	have "t > 0 \<or> t < 0" using \<open>t \<noteq> 0\<close> by linarith
	moreover {
	assume "t > 0"
	then have "{0--t} \<subseteq> {-a--a}"
	by (simp add: \<open>t \<in> {-a--a}\<close> a(3) subset_closed_segment)
	from nb[OF this] have
	"norm (flow0 x t - x - t \<^sub>R f x) \<le> norm t (norm (f x) / 2)"
	by (simp add: assms(1))
	then have "norm (t \<^sub>R f x) \<le> norm t (norm (f x) / 2)" using tx by auto
	then have False using nf
	using \<open>0 < t\<close> by auto
	}
	moreover {
	assume "t < 0"
	then have "{t--0} \<subseteq> {-a--a}"
	by (simp add: \<open>t \<in> {-a--a}\<close> a(3) subset_closed_segment)
	from nb[OF this] have
	"norm (x - flow0 x t + t \<^sub>R f x) \<le> norm t (norm (f x) / 2)"
	by (simp add: assms(1))
	then have "norm (t \<^sub>R f x) \<le> norm t (norm (f x) / 2)" using tx by auto
	then have False using nf
	using \<open>t < 0\<close> by auto
	}
	ultimately show False by blast
	qed
	thus ?thesis unfolding eventually_at
	using a(1) by blast
	qed

	lemma compact_max_time_flow_in_closed:
	assumes "closed M" and t_ex: "t \<in> existence_ivl0 x"
	shows "compact {s \<in> {0..t}. flow0 x ` {0..s} \<subseteq> M}" (is "compact ?C")
	unfolding compact_eq_bounded_closed
	proof
	have "bounded {0 .. t}" by auto
	then show "bounded ?C"
	by (rule bounded_subset) auto
	show "closed ?C"
	unfolding closed_def
	proof (rule topological_space_class.openI, clarsimp)
	\<comment> \<open>TODO: there must be a more abstract argument for this, e.g., with
	@{thm continuous_on_closed_vimageI} and then reasoning about the connected component around 0?\<close>
	fix s
	assume notM: "s \<le> t \<longrightarrow> 0 \<le> s \<longrightarrow> \<not> flow0 x ` {0..s} \<subseteq> M"
	consider "0 \<le> s" "s \<le> t" "flow0 x s \<notin> M" \| "0 \<le> s" "s \<le> t" "flow0 x s \<in> M" \| "s < 0" \| "s > t"
	by arith
	then show "\<exists>T. open T \<and> s \<in> T \<and> T \<subseteq> - {s. 0 \<le> s \<and> s \<le> t \<and> flow0 x ` {0..s} \<subseteq> M}"
	proof cases
	assume s: "0 \<le> s" "s \<le> t" and sM: "flow0 x s \<notin> M"
	have "isCont (flow0 x) s"
	using s ivl_subset_existence_ivl[OF t_ex]
	by (auto intro!: flow_continuous)
	from this[unfolded continuous_at_open, rule_format, of "-M"] sM \<open>closed M\<close>
	obtain S where "open S" "s \<in> S" "(\<forall>x'\<in>S. flow0 x x' \<in> - M)"
	by auto
	then show ?thesis
	by (force intro!: exI[where x=S])
	next
	assume s: "0 \<le> s" "s \<le> t" and sM: "flow0 x s \<in> M"
	from this notM obtain s0 where s0: "0 \<le> s0" "s0 < s" "flow0 x s0 \<notin> M"
	by force
	from order_tendstoD(1)[OF tendsto_ident_at \<open>s0 < s\<close>, of UNIV, unfolded eventually_at_topological]
	obtain S where "open S" "s \<in> S" "\<And>x. x \<in> S \<Longrightarrow> x \<noteq> s \<Longrightarrow> s0 < x"
	by auto
	then show ?thesis using s0
	by (auto simp: intro!: exI[where x=S]) (smt atLeastAtMost_iff image_subset_iff)
	qed (force intro: exI[where x="{t<..}"] exI[where x="{..<0}"])+
	qed
	qed

	lemma flow_in_closed_max_timeE:
	assumes "closed M" "t \<in> existence_ivl0 x" "0 \<le> t" "x \<in> M"
	obtains T where "0 \<le> T" "T \<le> t" "flow0 x ` {0..T} \<subseteq> M"
	"\<And>s'. 0 \<le> s' \<Longrightarrow> s' \<le> t \<Longrightarrow> flow0 x ` {0..s'} \<subseteq> M \<Longrightarrow> s' \<le> T"
	proof -
	let ?C = "{s \<in> {0..t}. flow0 x ` {0..s} \<subseteq> M}"
	have "?C \<noteq> {}"
	using assms
	using local.mem_existence_ivl_iv_defined
	by (auto intro!: exI[where x=0])
	from compact_max_time_flow_in_closed[OF assms(1,2)]
	have "compact ?C" .
	from compact_attains_sup[OF this \<open>?C \<noteq> {}\<close>]
	obtain s where s: "0 \<le> s" "s \<le> t" "flow0 x ` {0..s} \<subseteq> M"
	and s_max: "\<And>s'. 0 \<le> s' \<Longrightarrow> s' \<le> t \<Longrightarrow> flow0 x ` {0..s'} \<subseteq> M \<Longrightarrow> s' \<le> s"
	by auto
	then show ?thesis ..
	qed

	lemma flow_leaves_closed_at_frontierE:
	assumes "closed M" and t_ex: "t \<in> existence_ivl0 x" and "0 \<le> t" "x \<in> M" "flow0 x t \<notin> M"
	obtains s where "0 \<le> s" "s < t" "flow0 x ` {0..s} \<subseteq> M"
	"flow0 x s \<in> frontier M"
	"\<exists>\<^sub>F s' in at_right s. flow0 x s' \<notin> M"
	proof -
	from flow_in_closed_max_timeE[OF assms(1-4)] assms(5)
	obtain s where s: "0 \<le> s" "s < t" "flow0 x ` {0..s} \<subseteq> M"
	and s_max: "\<And>s'. 0 \<le> s' \<Longrightarrow> s' \<le> t \<Longrightarrow> flow0 x ` {0..s'} \<subseteq> M \<Longrightarrow> s' \<le> s"
	by (smt atLeastAtMost_iff image_subset_iff)
	note s
	moreover
	have "flow0 x s \<notin> interior M"
	proof
	assume interior: "flow0 x s \<in> interior M"
	have "s \<in> existence_ivl0 x" using ivl_subset_existence_ivl[OF \<open>t \<in> _\<close>] s by auto
	from flow_continuous[OF this, THEN isContD, THEN topological_tendstoD, OF open_interior interior]
	have "\<forall>\<^sub>F s' in at s. flow0 x s' \<in> interior M" by auto
	then have "\<forall>\<^sub>F s' in at_right s. flow0 x s' \<in> interior M"
	by (auto simp: eventually_at_split)
	moreover have "\<forall>\<^sub>F s' in at_right s. s' < t"
	using tendsto_ident_at \<open>s < t\<close>
	by (rule order_tendstoD)
	ultimately have "\<forall>\<^sub>F s' in at_right s. flow0 x s' \<in> M \<and> s' < t"
	by eventually_elim (use interior_subset[of M] in auto)
	then obtain s' where s': "s < s'" "s' < t" "\<And>y. y > s \<Longrightarrow> y \<le> s' \<Longrightarrow> flow0 x y \<in> M"
	by (auto simp: eventually_at_right_field_le)
	have s'_ivl: "flow0 x ` {0..s'} \<subseteq> M"
	proof safe
	fix s'' assume "s'' \<in> {0 .. s'}"
	then show "flow0 x s'' \<in> M"
	using s interior_subset[of M] s'
	by (cases "s'' \<le> s") auto
	qed
	with s_max[of s'] \<open>s' < t\<close> \<open>0 \<le> s\<close> \<open>s < s'\<close> show False by auto
	qed
	then have "flow0 x s \<in> frontier M"
	using s closure_subset[of M]
	by (force simp: frontier_def)
	moreover
	have "compact (flow0 x -` M \<inter> {s..t})" (is "compact ?C")
	unfolding compact_eq_bounded_closed
	proof
	have "bounded {s .. t}" by simp
	then show "bounded ?C"
	by (rule bounded_subset) auto
	show "closed ?C"
	using \<open>closed M\<close> assms mem_existence_ivl_iv_defined(2)[OF t_ex] ivl_subset_existence_ivl[OF t_ex] \<open>0 \<le> s\<close>
	by (intro closed_vimage_Int) (auto intro!: continuous_intros)
	qed
	have "\<exists>\<^sub>F s' in at_right s. flow0 x s' \<notin> M"
	apply (rule ccontr)
	unfolding not_frequently
	proof -
	assume "\<forall>\<^sub>F s' in at_right s. \<not> flow0 x s' \<notin> M"
	moreover have "\<forall>\<^sub>F s' in at_right s. s' < t"
	using tendsto_ident_at \<open>s < t\<close>
	by (rule order_tendstoD)
	ultimately have "\<forall>\<^sub>F s' in at_right s. flow0 x s' \<in> M \<and> s' < t" by eventually_elim auto
	then obtain s' where s': "s < s'"
	"\<And>y. y > s \<Longrightarrow> y < s' \<Longrightarrow> flow0 x y \<in> M"
	"\<And>y. y > s \<Longrightarrow> y < s' \<Longrightarrow> y < t"
	by (auto simp: eventually_at_right_field)
	define s'' where "s'' = (s + s') / 2"
	have "0 \<le> s''" "s'' \<le> t" "s < s''" "s'' < s'"
	using s s'
	by (auto simp del: divide_le_eq_numeral1 le_divide_eq_numeral1 simp: s''_def) fastforce
	then have "flow0 x ` {0..s''} \<subseteq> M"
	using s s'
	- apply (auto simp: )
	+ apply auto
	subgoal for u
	by (cases "u\<le>s") auto
	done
	from s_max[OF \<open>0 \<le> s''\<close> \<open>s''\<le> t\<close> this] \<open>s'' > s\<close>
	show False by simp
	qed
	ultimately show ?thesis ..
	qed


	subsection \<open>Connectedness\<close>

	lemma fcontX:
	shows "continuous_on X f"
	using auto_local_lipschitz local_lipschitz_continuous_on by blast

	lemma fcontx:
	assumes "x \<in> X"
	shows "continuous (at x) f"
	proof -
	have "open X" by simp
	from continuous_on_eq_continuous_at[OF this]
	show ?thesis using fcontX assms(1) by blast
	qed

	lemma continuous_at_imp_cball:
	assumes "continuous (at x) g"
	assumes "g x > (0::real)"
	obtains r where "r > 0" "\<forall>y \<in> cball x r. g y > 0"
	proof -
	from assms(1)
	obtain d where "d>0" "g ` (ball x d) \<subseteq> ball (g x) ((g x)/2)"
	by (meson assms(2) continuous_at_ball half_gt_zero)
	then have "\<forall>y \<in> cball x (d/2). g y > 0"
	by (smt assms(2) dist_norm image_subset_iff mem_ball mem_cball pos_half_less real_norm_def)
	thus ?thesis
	using \<open>0 < d\<close> that half_gt_zero by blast
	qed

	text \<open> \<open>flow0\<close> is \<open>path_connected\<close> \<close>
	lemma flow0_path_connected_time:
	assumes "ts \<subseteq> existence_ivl0 x" "path_connected ts"
	shows "path_connected (flow0 x ` ts)"
	proof -
	have "continuous_on ts (flow0 x)"
	by (meson assms continuous_on_sequentially flow_continuous_on subsetD)
	from path_connected_continuous_image[OF this assms(2)]
	show ?thesis .
	qed

	lemma flow0_path_connected:
	assumes "path_connected D"
	"path_connected ts"
	"\<And>x. x \<in> D \<Longrightarrow> ts \<subseteq> existence_ivl0 x"
	shows "path_connected ( (\<lambda>(x, y). flow0 x y) ` (D \<times> ts))"
	proof -
	have "D \<times> ts \<subseteq> Sigma X existence_ivl0"
	using assms(3) subset_iff by fastforce
	then have a1:"continuous_on (D \<times> ts) (\<lambda>(x, y). flow0 x y)"
	using flow_continuous_on_state_space continuous_on_subset by blast
	have a2 : "path_connected (D \<times> ts)" using path_connected_Times assms by auto
	from path_connected_continuous_image[OF a1 a2]
	show ?thesis .
	qed

	end

	subsection \<open>Return Time and Implicit Function Theorem\<close>

	context c1_on_open_euclidean begin

	lemma flow_implicit_function:
	\<comment> \<open>TODO: generalization of @{thm returns_to_implicit_function}!\<close>
	fixes s::"'a::euclidean_space \<Rightarrow> real" and S::"'a set"
	assumes t: "t \<in> existence_ivl0 x" and x: "x \<in> X" and st: "s (flow0 x t) = 0"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "isCont Ds (flow0 x t)"
	assumes nz: "Ds (flow0 x t) (f (flow0 x t)) \<noteq> 0"
	obtains u e
	where "s (flow0 x (u x)) = 0"
	"u x = t"
	"(\<And>y. y \<in> cball x e \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> Sigma X existence_ivl0"
	"0 < e" "(u has_derivative (- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (flow0 x t)) (f (flow0 x t)))) o\<^sub>L
	(Ds (flow0 x t) o\<^sub>L flowderiv x t) o\<^sub>L embed1_blinfun)) (at x)"
	proof -
	note [derivative_intros] = has_derivative_compose[OF _ Ds]
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds])
	note cls[simp, intro] = closed_levelset[OF cont_s]
	then have xt1: "(x, t) \<in> Sigma X existence_ivl0"
	by (auto simp: t x)
	have D: "(\<And>x. x \<in> Sigma X existence_ivl0 \<Longrightarrow>
	((\<lambda>(x, t). s (flow0 x t)) has_derivative
	blinfun_apply (Ds (flow0 (fst x) (snd x)) o\<^sub>L (flowderiv (fst x) (snd x))))
	(at x))"
	by (auto intro!: derivative_eq_intros)
	have C: "isCont (\<lambda>x. Ds (flow0 (fst x) (snd x)) o\<^sub>L flowderiv (fst x) (snd x))
	(x, t)"
	using flowderiv_continuous_on[unfolded continuous_on_eq_continuous_within,
	rule_format, OF xt1]
	using at_within_open[OF xt1 open_state_space]
	by (auto intro!: continuous_intros tendsto_eq_intros x t
	isCont_tendsto_compose[OF DsC, unfolded poincare_map_def]
	simp: split_beta' isCont_def)
	have Z: "(case (x, t) of (x, t) \<Rightarrow> s (flow0 x t)) = 0"
	by (auto simp: st)
	have I1: "blinfun_scaleR_left (inverse (Ds (flow0 x t)(f (flow0 x t)))) o\<^sub>L
	((Ds (flow0 (fst (x, t))
	(snd (x, t))) o\<^sub>L
	flowderiv (fst (x, t))
	(snd (x, t))) o\<^sub>L
	embed2_blinfun)
	= 1\<^sub>L"
	using nz
	by (auto intro!: blinfun_eqI
	simp: flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	have I2: "((Ds (flow0 (fst (x, t))
	(snd (x, t))) o\<^sub>L
	flowderiv (fst (x, t))
	(snd (x, t))) o\<^sub>L
	embed2_blinfun) o\<^sub>L blinfun_scaleR_left (inverse (Ds (flow0 x t)(f (flow0 x t))))
	= 1\<^sub>L"
	using nz
	by (auto intro!: blinfun_eqI
	simp: flowderiv_def blinfun.bilinear_simps inverse_eq_divide poincare_map_def)
	show ?thesis
	apply (rule implicit_function_theorem[where f="\<lambda>(x, t). s (flow0 x t)"
	and S="Sigma X existence_ivl0", OF D xt1 open_state_space order_refl C Z I1 I2])
	apply blast
	unfolding split_beta' fst_conv snd_conv poincare_map_def[symmetric]
	..
	qed

	lemma flow_implicit_function_at:
	fixes s::"'a::euclidean_space \<Rightarrow> real" and S::"'a set"
	assumes x: "x \<in> X" and st: "s x = 0"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	assumes DsC: "isCont Ds x"
	assumes nz: "Ds x (f x) \<noteq> 0"
	assumes pos: "e > 0"
	obtains u d
	where
	"0 < d"
	"u x = 0"
	"\<And>y. y \<in> cball x d \<Longrightarrow> s (flow0 y (u y)) = 0"
	"\<And>y. y \<in> cball x d \<Longrightarrow> \<bar>u y\<bar> < e"
	"\<And>y. y \<in> cball x d \<Longrightarrow> u y \<in> existence_ivl0 y"
	"continuous_on (cball x d) u"
	"(u has_derivative -Ds x /\<^sub>R (Ds x) (f x)) (at x)"
	proof -
	have x0: "flow0 x 0 = x" by (simp add: x)
	from flow_implicit_function[OF existence_ivl_zero[OF x] x, unfolded x0, of s, OF st Ds DsC nz]
	obtain u d0 where
	s0: "s (flow0 x (u x)) = 0"
	and u0: "u x = 0"
	and u: "\<And>y. y \<in> cball x d0 \<Longrightarrow> s (flow0 y (u y)) = 0"
	and uc: "continuous_on (cball x d0) u"
	and uex: "(\<lambda>t. (t, u t)) ` cball x d0 \<subseteq> Sigma X existence_ivl0"
	and d0: "0 < d0"
	and u': "(u has_derivative
	blinfun_apply
	(- blinfun_scaleR_left (inverse (blinfun_apply (Ds x) (f x))) o\<^sub>L (Ds x o\<^sub>L flowderiv x 0) o\<^sub>L embed1_blinfun))
	(at x)"
	by blast
	have "at x within cball x d0 = at x" by (rule at_within_interior) (auto simp: \<open>0 < d0\<close>)
	then have "(u \<longlongrightarrow> 0) (at x)"
	using uc d0 by (auto simp: continuous_on_def u0 dest!: bspec[where x=x])
	from tendstoD[OF this \<open>0 < e\<close>] pos u0
	obtain d1 where d1: "0 < d1" "\<And>xa. dist xa x \<le> d1 \<Longrightarrow> \<bar>u xa\<bar> < e"
	unfolding eventually_at_le
	by force
	define d where "d = min d0 d1"
	have "0 < d" by (auto simp: d_def d0 d1)
	moreover note u0
	moreover have "\<And>y. y \<in> cball x d \<Longrightarrow> s (flow0 y (u y)) = 0" by (auto intro!: u simp: d_def)
	moreover have "\<And>y. y \<in> cball x d \<Longrightarrow> \<bar>u y\<bar> < e" using d1 by (auto simp: d_def dist_commute)
	moreover have "\<And>y. y \<in> cball x d \<Longrightarrow> u y \<in> existence_ivl0 y"
	using uex by (force simp: d_def)
	moreover have "continuous_on (cball x d) u"
	using uc by (rule continuous_on_subset) (auto simp: d_def)
	moreover
	have "(u has_derivative -Ds x /\<^sub>R (Ds x) (f x)) (at x)"
	using u'
	by (rule has_derivative_subst) (auto intro!: ext simp: x x0 flowderiv_def blinfun.bilinear_simps)
	ultimately show ?thesis ..
	qed

	lemma returns_to_implicit_function_gen:
	\<comment> \<open>TODO: generalizes proof of @{thm returns_to_implicit_function}!\<close>
	fixes s::"'a::euclidean_space \<Rightarrow> real"
	assumes rt: "returns_to {x \<in> S. s x = 0} x" (is "returns_to ?P x")
	assumes cS: "closed S"
	assumes Ds: "\<And>x. (s has_derivative blinfun_apply (Ds x)) (at x)"
	"isCont Ds (poincare_map ?P x)"
	"Ds (poincare_map ?P x) (f (poincare_map ?P x)) \<noteq> 0"
	obtains u e
	where "s (flow0 x (u x)) = 0"
	"u x = return_time ?P x"
	"(\<And>y. y \<in> cball x e \<Longrightarrow> s (flow0 y (u y)) = 0)"
	"continuous_on (cball x e) u"
	"(\<lambda>t. (t, u t)) ` cball x e \<subseteq> Sigma X existence_ivl0"
	"0 < e" "(u has_derivative (- blinfun_scaleR_left
	(inverse (blinfun_apply (Ds (poincare_map ?P x)) (f (poincare_map ?P x)))) o\<^sub>L
	(Ds (poincare_map ?P x) o\<^sub>L flowderiv x (return_time ?P x)) o\<^sub>L embed1_blinfun)) (at x)"
	proof -
	note [derivative_intros] = has_derivative_compose[OF _ Ds(1)]
	have cont_s: "continuous_on UNIV s" by (rule has_derivative_continuous_on[OF Ds(1)])
	note cls[simp, intro] = closed_levelset[OF cont_s]
	let ?t1 = "return_time ?P x"
	have cls[simp, intro]: "closed {x \<in> S. s x = 0}"
	by (rule closed_levelset_within) (auto intro!: cS continuous_on_subset[OF cont_s])

	have *: "poincare_map ?P x = flow0 x (return_time {x \<in> S. s x = 0} x)"
	by (simp add: poincare_map_def)
	have "return_time {x \<in> S. s x = 0} x \<in> existence_ivl0 x"
	"x \<in> X"
	"s (poincare_map ?P x) = 0"
	using poincare_map_returns rt
	by (auto intro!: return_time_exivl rt)
	note E = flow_implicit_function[of "return_time ?P x" x s Ds, OF this[unfolded ] Ds[unfolded ],
	folded *]
	show ?thesis
	by (rule E) rule
	qed

	text \<open>c.f. Perko Section 3.7 Lemma 2 part 1.\<close>

	lemma flow_transversal_surface_finite_intersections:
	fixes s::"'a \<Rightarrow> 'b::real_normed_vector"
	and Ds::"'a \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
	assumes "closed S"
	assumes "\<And>x. (s has_derivative (Ds x)) (at x)"
	assumes "\<And>x. x \<in> S \<Longrightarrow> s x = 0 \<Longrightarrow> Ds x (f x) \<noteq> 0"
	assumes "a \<le> b" "{a .. b} \<subseteq> existence_ivl0 x"
	shows "finite {t\<in>{a..b}. flow0 x t \<in> {x \<in> S. s x = 0}}"
	\<comment> \<open>TODO: define notion of (compact/closed)-(continuous/differentiable/C1)-surface?\<close>
	proof cases
	note Ds = \<open>\<And>x. (s has_derivative (Ds x)) (at x)\<close>
	note transversal = \<open>\<And>x. x \<in> S \<Longrightarrow> s x = 0 \<Longrightarrow> Ds x (f x) \<noteq> 0\<close>
	assume "a < b"
	show ?thesis
	proof (rule ccontr)
	let ?S = "{x \<in> S. s x = 0}"
	let ?T = "{t\<in>{a..b}. flow0 x t \<in> {x \<in> S. s x = 0}}"
	define \<phi> where "\<phi> = flow0 x"
	have [THEN continuous_on_compose2, continuous_intros]: "continuous_on S s"
	by (auto simp: intro!: has_derivative_continuous_on Ds intro: has_derivative_at_withinI)
	assume "infinite ?T"
	from compact_sequentialE[OF compact_Icc[of a b] this]
	obtain t tl where t: "t n \<in> ?T" "flow0 x (t n) \<in> ?S" "t n \<in> {a .. b}" "t n \<noteq> tl"
	and tl: "t \<longlonglongrightarrow> tl" "tl \<in> {a..b}"
	for n
	by force
	have tl_ex: "tl \<in> existence_ivl0 x" using \<open>{a .. b} \<subseteq> existence_ivl0 x\<close> \<open>tl \<in> {a .. b}\<close> by auto
	have "closed ?S"
	by (auto intro!: closed_levelset_within \<open>closed S\<close> continuous_intros)
	moreover
	have "\<forall>n. flow0 x (t n) \<in> ?S"
	using t by auto
	moreover
	have flow_t: "(\<lambda>n. flow0 x (t n)) \<longlonglongrightarrow> flow0 x tl"
	by (auto intro!: tendsto_eq_intros tl_ex tl)
	ultimately have "flow0 x tl \<in> ?S"
	by (rule closed_sequentially)

	let ?qt = "\<lambda>t. (flow0 x t - flow0 x tl) /\<^sub>R (t - tl)"
	from flow_has_vector_derivative[OF tl_ex, THEN has_vector_derivative_withinD]
	have qt_tendsto: "?qt \<midarrow>tl\<rightarrow> f (flow0 x tl)" .
	let ?q = "\<lambda>n. ?qt (t n)"
	have "filterlim t (at tl) sequentially"
	using tl(1)
	by (rule filterlim_atI) (simp add: t)
	with qt_tendsto have "?q \<longlonglongrightarrow> f (flow0 x tl)"
	by (rule filterlim_compose)
	then have "((\<lambda>n. Ds (flow0 x tl) (?q n))) \<longlonglongrightarrow> Ds (flow0 x tl) (f (flow0 x tl))"
	by (auto intro!: tendsto_intros)
	moreover

	from flow_lipschitzE[OF \<open>{a .. b} \<subseteq> existence_ivl0 x\<close>] obtain L' where L': "L'-lipschitz_on {a..b} (flow0 x)" .
	define L where "L = L' + 1"
	from lipschitz_on_le[OF L', of L] lipschitz_on_nonneg[OF L']
	have L: "L-lipschitz_on {a .. b} (flow0 x)" and "L > 0"
	by (auto simp: L_def)
	from flow_lipschitzE[OF \<open>{a .. b} \<subseteq> existence_ivl0 x\<close>] obtain L' where "L'-lipschitz_on {a..b} (flow0 x)" .
	\<comment> \<open>TODO: is this reasoning (below) with this Lipschitz constant really necessary?\<close>
	have s[simp]: "s (flow0 x (t n)) = 0""s (flow0 x tl) = 0"
	for n
	using t \<open>flow0 x tl \<in> ?S\<close>
	by auto

	from Ds(1)[of "flow0 x tl", unfolded has_derivative_within]
	have "(\<lambda>y. (1 / norm (y - flow0 x tl)) *\<^sub>R (s y - (s (flow0 x tl) + blinfun_apply (Ds (flow0 x tl)) (y - flow0 x tl)))) \<midarrow>flow0 x tl\<rightarrow> 0"
	by auto
	then have "((\<lambda>y. (1 / norm (y - flow0 x tl)) *\<^sub>R (s y - (s (flow0 x tl) + blinfun_apply (Ds (flow0 x tl)) (y - flow0 x tl)))) \<longlongrightarrow> 0)
	(nhds (flow0 x tl))"
	by (rule tendsto_nhds_continuousI) simp

	from filterlim_compose[OF this flow_t]
	have "(\<lambda>xa. (blinfun_apply (Ds (flow0 x tl)) (flow0 x (t xa) - flow0 x tl)) /\<^sub>R norm (flow0 x (t xa) - flow0 x tl))
	\<longlonglongrightarrow> 0"
	using t
	by (auto simp: inverse_eq_divide tendsto_minus_cancel_right)
	from tendsto_mult[OF tendsto_const[of "L"] tendsto_norm[OF this, simplified, simplified divide_inverse_commute[symmetric]]]\<comment> \<open>TODO: uuugly\<close>
	have Ds0: "(\<lambda>xa. norm (blinfun_apply (Ds (flow0 x tl)) (flow0 x (t xa) - flow0 x tl)) / (norm (flow0 x (t xa) - flow0 x tl)/(L))) \<longlonglongrightarrow> 0"
	by (auto simp: ac_simps)

	from _ Ds0 have "((\<lambda>n. Ds (flow0 x tl) (?q n)) \<longlonglongrightarrow> 0)"
	apply (rule Lim_null_comparison)
	apply (rule eventuallyI)
	unfolding norm_scaleR blinfun.scaleR_right abs_inverse divide_inverse_commute[symmetric]
	subgoal for n
	apply (cases "flow0 x (t n) = flow0 x tl")
	subgoal by (simp add: blinfun.bilinear_simps)
	subgoal
	apply (rule divide_left_mono)
	using lipschitz_onD[OF L, of "t n" tl] \<open>0 < L\<close> t(3) tl(2)
	by (auto simp: algebra_split_simps zero_less_divide_iff dist_norm pos_divide_le_eq
	intro!: add_pos_nonneg)
	done
	done
	ultimately have "Ds (flow0 x tl) (f (flow0 x tl)) = 0"
	by (rule LIMSEQ_unique)
	moreover have "Ds (flow0 x tl) (f (flow0 x tl)) \<noteq> 0"
	by (rule transversal) (use \<open>flow0 x tl \<in> ?S\<close> in auto)
	ultimately show False by auto
	qed
	qed (use assms in auto)

	lemma uniform_limit_flow0_state:\<comment> \<open>TODO: is that something more general?\<close>
	assumes "compact C"
	assumes "C \<subseteq> X"
	shows "uniform_limit C (\<lambda>s x. flow0 x s) (\<lambda>x. flow0 x 0) (at 0)"
	proof (cases "C = {}")
	case True then show ?thesis by auto
	next
	case False show ?thesis
	proof (rule uniform_limitI)
	fix e::real assume "0 < e"
	{
	fix x assume "x \<in> C"
	with assms have "x \<in> X" by auto
	from existence_ivl_cballs[OF UNIV_I \<open>x \<in> X\<close>]
	obtain t L u where "\<And>y. y \<in> cball x u \<Longrightarrow> cball 0 t \<subseteq> existence_ivl0 y"
	"\<And>s y. y \<in> cball x u \<Longrightarrow> s \<in> cball 0 t \<Longrightarrow> flow0 y s \<in> cball y u"
	"L-lipschitz_on (cball 0 t\<times>cball x u) (\<lambda>(t, x). flow0 x t)"
	"\<And>y. y \<in> cball x u \<Longrightarrow> cball y u \<subseteq> X"
	"0 < t" "0 < u"
	by metis
	then have "\<exists>L. \<exists>u>0. \<exists>t>0. L-lipschitz_on (cball 0 t\<times>cball x u) (\<lambda>(t, x). flow0 x t)" by blast
	} then have "\<forall>x\<in>C. \<exists>L. \<exists>u>0. \<exists>t>0. L-lipschitz_on (cball 0 t\<times>cball x u) (\<lambda>(t, x). flow0 x t)" ..
	then obtain L d' u' where
	L: "\<And>x. x \<in> C \<Longrightarrow> (L x)-lipschitz_on (cball 0 (d' x)\<times>cball x (u' x)) (\<lambda>(t, x). flow0 x t)"
	and d': "\<And>x. x \<in> C \<Longrightarrow> d' x > 0"
	and u': "\<And>x. x \<in> C \<Longrightarrow> u' x > 0"
	by metis
	have "C \<subseteq> (\<Union>c\<in>C. ball c (u' c))" using u' by auto
	from compactE_image[OF \<open>compact C\<close> _ this]
	obtain C' where "C' \<subseteq> C" and [simp]: "finite C'" and C'_cover: "C \<subseteq> (\<Union>c\<in>C'. ball c (u' c))"
	by auto
	from C'_cover obtain c' where c': "x \<in> C \<Longrightarrow> x \<in> ball (c' x) (u' (c' x))" "x \<in> C \<Longrightarrow> c' x \<in> C'" for x
	by (auto simp: subset_iff) metis
	have "\<forall>\<^sub>F s in at 0. \<forall>x\<in>ball c (u' c). dist (flow0 x s) (flow0 x 0) < e" if "c \<in> C'" for c
	proof -
	have cC: "c \<in> C"
	using c' \<open>c \<in> C'\<close> d' \<open>C' \<subseteq> C\<close>
	by auto
	have : "dist (flow0 x s) (flow0 x 0) \<le> L c \<bar>s\<bar>"
	if "x\<in>ball c (u' c)"
	"s \<in> cball 0 (d' c)"
	for x s
	proof -
	from L[OF cC, THEN lipschitz_onD, of "(0, x)" "(s, x)"] d'[OF cC] that
	show ?thesis
	by (auto simp: dist_prod_def dist_commute)
	qed
	have "\<forall>\<^sub>F s in at 0. abs s < d' c"
	by (rule order_tendstoD tendsto_intros)+ (use d' cC in auto)
	moreover have "\<forall>\<^sub>F s in at 0. L c * \<bar>s\<bar> < e"
	by (rule order_tendstoD tendsto_intros)+ (use \<open>0 < e\<close> in auto)
	ultimately show ?thesis
	apply eventually_elim
	apply (use * in auto)
	by smt
	qed
	then have "\<forall>\<^sub>F s in at 0. \<forall>c\<in>C'. \<forall>x\<in>ball c (u' c). dist (flow0 x s) (flow0 x 0) < e"
	by (simp add: eventually_ball_finite_distrib)
	then show "\<forall>\<^sub>F s in at 0. \<forall>x\<in>C. dist (flow0 x s) (flow0 x 0) < e"
	apply eventually_elim
	- apply (auto simp: )
	+ apply auto
	subgoal for s x
	apply (drule bspec[where x="c' x"])
	apply (simp add: c'(2))
	apply (drule bspec) prefer 2 apply assumption
	apply auto
	using c'(1) by auto
	done
	qed
	qed

	end

	subsection \<open>Fixpoints\<close>

	context auto_ll_on_open begin

	lemma fixpoint_sol:
	assumes "x \<in> X" "f x = 0"
	shows "existence_ivl0 x = UNIV" "flow0 x t = x"
	proof -
	have sol: "((\<lambda>t::real. x) solves_ode (\<lambda>_. f)) UNIV X"
	apply (rule solves_odeI)
	by(auto simp add: assms intro!: derivative_intros)
	from maximal_existence_flow[OF sol] have
	"UNIV \<subseteq> existence_ivl0 x" "flow0 x t = x" by auto
	thus "existence_ivl0 x = UNIV" "flow0 x t = x" by auto
	qed

	end

	end
	\ No newline at end of file
	diff --git a/thys/Poincare_Bendixson/Poincare_Bendixson.thy b/thys/Poincare_Bendixson/Poincare_Bendixson.thy
	--- a/thys/Poincare_Bendixson/Poincare_Bendixson.thy
	+++ b/thys/Poincare_Bendixson/Poincare_Bendixson.thy
	@@ -1,2821 +1,2821 @@
	section \<open>Poincare Bendixson Theory\<close>
	theory Poincare_Bendixson
	imports
	Ordinary_Differential_Equations.ODE_Analysis
	Analysis_Misc ODE_Misc Periodic_Orbit
	begin


	subsection \<open>Flow to Path\<close>

	context auto_ll_on_open begin

	(* The path along the flow starting at time t to time t' *)
	definition "flow_to_path x t t' = flow0 x \<circ> linepath t t'"

	lemma pathstart_flow_to_path[simp]:
	shows "pathstart (flow_to_path x t t') = flow0 x t"
	unfolding flow_to_path_def
	by (auto simp add: pathstart_compose)

	lemma pathfinish_flow_to_path[simp]:
	shows "pathfinish (flow_to_path x t t') = flow0 x t'"
	unfolding flow_to_path_def
	by (auto simp add: pathfinish_compose)

	lemma flow_to_path_unfold:
	shows "flow_to_path x t t' s = flow0 x ((1 - s) * t + s * t')"
	unfolding flow_to_path_def o_def linepath_def by auto

	lemma subpath0_flow_to_path:
	shows "(subpath 0 u (flow_to_path x t t')) = flow_to_path x t (t + u*(t'-t))"
	unfolding flow_to_path_def subpath_image subpath0_linepath
	by auto

	lemma path_image_flow_to_path[simp]:
	assumes "t \<le> t'"
	shows "path_image (flow_to_path x t t') = flow0 x ` {t..t'}"
	unfolding flow_to_path_def path_image_compose path_image_linepath
	using assms real_Icc_closed_segment by auto

	lemma flow_to_path_image0_right_open[simp]:
	assumes "t < t'"
	shows "flow_to_path x t t' ` {0..<1} = flow0 x `{t..<t'}"
	unfolding flow_to_path_def image_comp[symmetric] linepath_image0_right_open_real[OF assms]
	by auto

	lemma flow_to_path_path:
	assumes "t \<le> t'"
	assumes "{t..t'} \<subseteq> existence_ivl0 x"
	shows "path (flow_to_path x t t')"
	proof -
	have "x \<in> X"
	using assms(1) assms(2) subset_empty by fastforce
	have "\<And>xa. 0 \<le> xa \<Longrightarrow> xa \<le> 1 \<Longrightarrow> (1 - xa) * t + xa * t' \<le> t'"
	by (simp add: assms(1) convex_bound_le)
	moreover have "\<And>xa. 0 \<le> xa \<Longrightarrow> xa \<le> 1 \<Longrightarrow> t \<le> (1 - xa) * t + xa * t'" using assms(1)
	by (metis add.commute add_diff_cancel_left' diff_diff_eq2 diff_le_eq mult.commute mult.right_neutral mult_right_mono right_diff_distrib')
	ultimately have "\<And>xa. 0 \<le> xa \<Longrightarrow> xa \<le> 1 \<Longrightarrow> (1 - xa) * t + xa * t' \<in> existence_ivl0 x"
	using assms(2) by auto
	thus ?thesis unfolding path_def flow_to_path_def linepath_def
	by (auto intro!:continuous_intros simp add :\<open>x \<in> X\<close>)
	qed

	lemma flow_to_path_arc:
	assumes "t \<le> t'"
	assumes "{t..t'} \<subseteq> existence_ivl0 x"
	assumes "\<forall>s \<in> {t<..<t'}. flow0 x s \<noteq> flow0 x t"
	assumes "flow0 x t \<noteq> flow0 x t'"
	shows "arc (flow_to_path x t t')"
	unfolding arc_def
	proof safe
	from flow_to_path_path[OF assms(1-2)]
	show "path (flow_to_path x t t')" .
	next
	show "inj_on (flow_to_path x t t') {0..1}"
	unfolding flow_to_path_def
	apply (rule comp_inj_on)
	apply (metis assms(4) inj_on_linepath)
	using assms path_image_linepath[of t t'] apply (auto intro!:flow0_inj_on)
	using flow0_inj_on greaterThanLessThan_iff linepath_image_01 real_Icc_closed_segment by fastforce
	qed

	end

	locale c1_on_open_R2 = c1_on_open_euclidean f f' X for f::"'a::executable_euclidean_space \<Rightarrow> _" and f' and X +
	assumes dim2: "DIM('a) = 2"
	begin


	subsection \<open>2D Line segments\<close>

	text \<open>Line segments are specified by two endpoints
	The closed line segment from x to y is given by the set {x--y}
	and {x<--<y} for the open segment\<close>

	text \<open> Rotates a vector clockwise 90 degrees \<close>
	definition "rot (v::'a) = (eucl_of_list [nth_eucl v 1, -nth_eucl v 0]::'a)"

	lemma exhaust2_nat: "(\<forall>i<(2::nat). P i) \<longleftrightarrow> P 0 \<and> P 1"
	using less_2_cases by auto
	lemma sum2_nat: "(\<Sum>i<(2::nat). P i) = P 0 + P 1"
	by (simp add: eval_nat_numeral)

	lemmas vec_simps =
	eucl_eq_iff[where 'a='a] dim2 eucl_of_list_eucl_nth exhaust2_nat
	plus_nth_eucl
	minus_nth_eucl
	uminus_nth_eucl
	scaleR_nth_eucl
	inner_nth_eucl
	sum2_nat
	algebra_simps

	lemma minus_expand:
	shows "(x::'a)-y = (eucl_of_list [x$\<^sub>e0 - y$\<^sub>e0, x$\<^sub>e1 - y$\<^sub>e1])"
	by (simp add:vec_simps)

	lemma dot_ortho[simp]: "x \<bullet> rot x = 0"
	unfolding rot_def minus_expand
	by (simp add: vec_simps)

	lemma nrm_dot:
	shows "((x::'a)-y) \<bullet> (rot (x-y)) = 0"
	unfolding rot_def minus_expand
	by (simp add: vec_simps)

	lemma nrm_reverse: "a \<bullet> (rot (x-y)) = - a \<bullet> (rot (y-x))" for x y::'a
	unfolding rot_def
	by (simp add:vec_simps)

	lemma norm_rot: "norm (rot v) = norm v" for v::'a
	unfolding rot_def
	by (simp add:vec_simps norm_nth_eucl L2_set_def)

	lemma rot_rot[simp]:
	shows "rot (rot v) = -v"
	unfolding rot_def
	by (simp add:vec_simps)

	lemma rot_scaleR[simp]:
	shows "rot ( u \<^sub>R v) = u \<^sub>R (rot v)"
	unfolding rot_def
	by (simp add:vec_simps)

	lemma rot_0[simp]: "rot 0 = 0"
	using rot_scaleR[of 0] by simp

	lemma rot_eq_0_iff[simp]: "rot x = 0 \<longleftrightarrow> x = 0"
	apply (auto simp: rot_def)
	apply (metis One_nat_def norm_eq_zero norm_rot norm_zero rot_def)
	using rot_0 rot_def by auto

	lemma in_segment_inner_rot:
	"(x - a) \<bullet> rot (b - a) = 0"
	if "x \<in> {a--b}"
	proof -
	from that obtain u where x: "x = a + u *\<^sub>R (b - a)" "0 \<le> u" "u \<le> 1"
	by (auto simp: in_segment algebra_simps)
	show ?thesis
	unfolding x
	by (simp add: inner_add_left nrm_dot)
	qed

	lemma inner_rot_in_segment:
	"x \<in> range (\<lambda>u. a + u *\<^sub>R (b - a))"
	if "(x - a) \<bullet> rot (b - a) = 0" "a \<noteq> b"
	proof -
	from that have
	x0: "b $\<^sub>e 0 = a $\<^sub>e 0 \<Longrightarrow> x $\<^sub>e 0 =
	(a $\<^sub>e 0 * b $\<^sub>e Suc 0 - b $\<^sub>e 0 * a $\<^sub>e Suc 0 + (b $\<^sub>e 0 - a $\<^sub>e 0) * x $\<^sub>e Suc 0) /
	(b $\<^sub>e Suc 0 - a $\<^sub>e Suc 0)"
	and x1: "b $\<^sub>e 0 \<noteq> a $\<^sub>e 0 \<Longrightarrow> x $\<^sub>e Suc 0 =
	((b $\<^sub>e Suc 0 - a $\<^sub>e Suc 0) * x $\<^sub>e 0 - a $\<^sub>e 0 * b $\<^sub>e Suc 0 + b $\<^sub>e 0 * a $\<^sub>e Suc 0) / (b $\<^sub>e 0 - a $\<^sub>e 0)"
	by (auto simp: rot_def vec_simps divide_simps)
	define u where "u = (if b $\<^sub>e 0 - a $\<^sub>e 0 \<noteq> 0
	then ((x $\<^sub>e 0 - a $\<^sub>e 0) / (b $\<^sub>e 0 - a $\<^sub>e 0))
	else ((x $\<^sub>e 1 - a $\<^sub>e 1) / (b $\<^sub>e 1 - a $\<^sub>e 1)))
	"
	show ?thesis
	apply (cases "b $\<^sub>e 0 - a $\<^sub>e 0 = 0")
	subgoal
	using that(2)
	apply (auto intro!: image_eqI[where x="((x $\<^sub>e 1 - a $\<^sub>e 1) / (b $\<^sub>e 1 - a $\<^sub>e 1))"]
	simp: vec_simps x0 divide_simps algebra_simps)
	apply (metis ab_semigroup_mult_class.mult_ac(1) mult.commute sum_sqs_eq)
	by (metis mult.commute mult.left_commute sum_sqs_eq)
	subgoal
	apply (auto intro!: image_eqI[where x="((x $\<^sub>e 0 - a $\<^sub>e 0) / (b $\<^sub>e 0 - a $\<^sub>e 0))"]
	simp: vec_simps x1 divide_simps algebra_simps)
	apply (metis ab_semigroup_mult_class.mult_ac(1) mult.commute sum_sqs_eq)
	by (metis mult.commute mult.left_commute sum_sqs_eq)
	done
	qed

	lemma in_open_segment_iff_rot:
	"x \<in> {a<--<b} \<longleftrightarrow> (x - a) \<bullet> rot (b - a) = 0 \<and> x \<bullet> (b - a) \<in> {a\<bullet>(b - a) <..< b \<bullet> (b - a)}"
	if "a \<noteq> b"
	unfolding open_segment_line_hyperplanes[OF that]
	by (auto simp: nrm_dot intro!: inner_rot_in_segment)

	lemma in_open_segment_rotD:
	"x \<in> {a<--<b} \<Longrightarrow> (x - a) \<bullet> rot (b - a) = 0 \<and> x \<bullet> (b - a) \<in> {a\<bullet>(b - a) <..< b \<bullet> (b - a)}"
	by (subst in_open_segment_iff_rot[symmetric]) auto

	lemma in_closed_segment_iff_rot:
	"x \<in> {a--b} \<longleftrightarrow> (x - a) \<bullet> rot (b - a) = 0 \<and> x \<bullet> (b - a) \<in> {a\<bullet>(b - a) .. b \<bullet> (b - a)}"
	if "a \<noteq> b"
	unfolding closed_segment_line_hyperplanes[OF that] using that
	by (auto simp: nrm_dot intro!: inner_rot_in_segment)

	lemma in_segment_inner_rot2:
	"(x - y) \<bullet> rot (a - b) = 0"
	if "x \<in> {a--b}" "y \<in> {a--b}"
	proof -
	from that obtain u where x: "x = a + u *\<^sub>R (b - a)" "0 \<le> u" "u \<le> 1"
	by (auto simp: in_segment algebra_simps)
	from that obtain v where y: "y = a + v *\<^sub>R (b - a)" "0 \<le> v" "v \<le> 1"
	by (auto simp: in_segment algebra_simps)
	show ?thesis
	unfolding x y
	apply (auto simp: inner_add_left )
	by (smt add_diff_cancel_left' in_segment_inner_rot inner_diff_left minus_diff_eq nrm_reverse that(1) that(2) x(1) y(1))
	qed

	lemma closed_segment_surface:
	"a \<noteq> b \<Longrightarrow> {a--b} = { x \<in> {x. x \<bullet> (b - a) \<in> {a\<bullet>(b - a) .. b \<bullet> (b - a)}}. (x - a) \<bullet> rot (b - a) = 0}"
	by (auto simp: in_closed_segment_iff_rot)

	lemma rot_diff_commute: "rot (b - a) = -rot(a - b)"
	apply (auto simp: rot_def algebra_simps)
	by (metis One_nat_def minus_diff_eq rot_def rot_rot)


	subsection \<open>Bijection Real-Complex for Jordan Curve Theorem\<close>

	definition "complex_of (x::'a) = x$\<^sub>e0 + \<i> * x$\<^sub>e1"

	definition "real_of (x::complex) = (eucl_of_list [Re x, Im x]::'a)"

	lemma complex_of_linear:
	shows "linear complex_of"
	unfolding complex_of_def
	apply (auto intro!:linearI simp add: distrib_left plus_nth_eucl)
	by (simp add: of_real_def scaleR_add_right scaleR_nth_eucl)

	lemma complex_of_bounded_linear:
	shows "bounded_linear complex_of"
	unfolding complex_of_def
	apply (auto intro!:bounded_linearI' simp add: distrib_left plus_nth_eucl)
	by (simp add: of_real_def scaleR_add_right scaleR_nth_eucl)

	lemma real_of_linear:
	shows "linear real_of"
	unfolding real_of_def
	by (auto intro!:linearI simp add: vec_simps)

	lemma real_of_bounded_linear:
	shows "bounded_linear real_of"
	unfolding real_of_def
	by (auto intro!:bounded_linearI' simp add: vec_simps)

	lemma complex_of_real_of:
	"(complex_of \<circ> real_of) = id"
	unfolding complex_of_def real_of_def
	using complex_eq by (auto simp add:vec_simps)

	lemma real_of_complex_of:
	"(real_of \<circ> complex_of) = id"
	unfolding complex_of_def real_of_def
	using complex_eq by (auto simp add:vec_simps)

	lemma complex_of_bij:
	shows "bij (complex_of)"
	using o_bij[OF real_of_complex_of complex_of_real_of] .

	lemma real_of_bij:
	shows "bij (real_of)"
	using o_bij[OF complex_of_real_of real_of_complex_of] .

	lemma real_of_inj:
	shows "inj (real_of)"
	using real_of_bij
	using bij_betw_imp_inj_on by auto

	lemma Jordan_curve_R2:
	fixes c :: "real \<Rightarrow> 'a"
	assumes "simple_path c" "pathfinish c = pathstart c"
	obtains inside outside where
	"inside \<noteq> {}" "open inside" "connected inside"
	"outside \<noteq> {}" "open outside" "connected outside"
	"bounded inside" "\<not> bounded outside"
	"inside \<inter> outside = {}"
	"inside \<union> outside = - path_image c"
	"frontier inside = path_image c"
	"frontier outside = path_image c"
	proof -
	from simple_path_linear_image_eq[OF complex_of_linear]
	have a1:"simple_path (complex_of \<circ> c)" using assms(1) complex_of_bij
	using bij_betw_imp_inj_on by blast
	have a2:"pathfinish (complex_of \<circ> c) = pathstart (complex_of \<circ> c)"
	using assms(2) by (simp add:pathstart_compose pathfinish_compose)

	from Jordan_curve[OF a1 a2]
	obtain inside outside where io:
	"inside \<noteq> {}" "open inside" "connected inside"
	"outside \<noteq> {}" "open outside" "connected outside"
	"bounded inside" "\<not> bounded outside" "inside \<inter> outside = {}"
	"inside \<union> outside = - path_image (complex_of \<circ> c)"
	"frontier inside = path_image (complex_of \<circ> c)"
	"frontier outside = path_image (complex_of \<circ> c)" by blast
	let ?rin = "real_of ` inside"
	let ?rout = "real_of ` outside"
	have i: "inside = complex_of ` ?rin" using complex_of_real_of unfolding image_comp
	by auto
	have o: "outside = complex_of ` ?rout" using complex_of_real_of unfolding image_comp
	by auto
	have c: "path_image(complex_of \<circ> c) = complex_of ` (path_image c)"
	by (simp add: path_image_compose)
	have "?rin \<noteq> {}" using io by auto
	moreover from open_bijective_linear_image_eq[OF real_of_linear real_of_bij]
	have "open ?rin" using io by auto
	moreover from connected_linear_image[OF real_of_linear]
	have "connected ?rin" using io by auto
	moreover have "?rout \<noteq> {}" using io by auto
	moreover from open_bijective_linear_image_eq[OF real_of_linear real_of_bij]
	have "open ?rout" using io by auto
	moreover from connected_linear_image[OF real_of_linear]
	have "connected ?rout" using io by auto
	moreover from bounded_linear_image[OF io(7) real_of_bounded_linear]
	have "bounded ?rin" .
	moreover from bounded_linear_image[OF _ complex_of_bounded_linear]
	have "\<not> bounded ?rout" using io(8) o
	by force
	from image_Int[OF real_of_inj]
	have "?rin \<inter> ?rout = {}" using io(9) by auto
	moreover from bij_image_Compl_eq[OF complex_of_bij]
	have "?rin \<union> ?rout = - path_image c" using io(10) unfolding c
	by (metis id_apply image_Un image_comp image_cong image_ident real_of_complex_of)
	moreover from closure_injective_linear_image[OF real_of_linear real_of_inj]
	have "frontier ?rin = path_image c" using io(11)
	unfolding frontier_closures c
	by (metis \<open>\<And>B A. real_of ` (A \<inter> B) = real_of ` A \<inter> real_of ` B\<close> bij_image_Compl_eq c calculation(9) compl_sup double_compl io(10) real_of_bij)
	moreover from closure_injective_linear_image[OF real_of_linear real_of_inj]
	have "frontier ?rout = path_image c" using io(12)
	unfolding frontier_closures c
	by (metis \<open>\<And>B A. real_of ` (A \<inter> B) = real_of ` A \<inter> real_of ` B\<close> bij_image_Compl_eq c calculation(10) frontier_closures io(11) real_of_bij)
	ultimately show ?thesis
	by (meson \<open>\<not> bounded (real_of ` outside)\<close> that)
	qed

	(* copied *)
	corollary Jordan_inside_outside_R2:
	fixes c :: "real \<Rightarrow> 'a"
	assumes "simple_path c" "pathfinish c = pathstart c"
	shows "inside(path_image c) \<noteq> {} \<and>
	open(inside(path_image c)) \<and>
	connected(inside(path_image c)) \<and>
	outside(path_image c) \<noteq> {} \<and>
	open(outside(path_image c)) \<and>
	connected(outside(path_image c)) \<and>
	bounded(inside(path_image c)) \<and>
	\<not> bounded(outside(path_image c)) \<and>
	inside(path_image c) \<inter> outside(path_image c) = {} \<and>
	inside(path_image c) \<union> outside(path_image c) =
	- path_image c \<and>
	frontier(inside(path_image c)) = path_image c \<and>
	frontier(outside(path_image c)) = path_image c"
	proof -
	obtain inner outer
	where *: "inner \<noteq> {}" "open inner" "connected inner"
	"outer \<noteq> {}" "open outer" "connected outer"
	"bounded inner" "\<not> bounded outer" "inner \<inter> outer = {}"
	"inner \<union> outer = - path_image c"
	"frontier inner = path_image c"
	"frontier outer = path_image c"
	using Jordan_curve_R2 [OF assms] by blast
	then have inner: "inside(path_image c) = inner"
	by (metis dual_order.antisym inside_subset interior_eq interior_inside_frontier)
	have outer: "outside(path_image c) = outer"
	using \<open>inner \<union> outer = - path_image c\<close> \<open>inside (path_image c) = inner\<close>
	outside_inside \<open>inner \<inter> outer = {}\<close> by auto
	show ?thesis
	using * by (auto simp: inner outer)
	qed

	lemma jordan_points_inside_outside:
	fixes p :: "real \<Rightarrow> 'a"
	assumes "0 < e"
	assumes jordan: "simple_path p" "pathfinish p = pathstart p"
	assumes x: "x \<in> path_image p"
	obtains y z where "y \<in> inside (path_image p)" "y \<in> ball x e"
	"z \<in> outside (path_image p)" "z \<in> ball x e"
	proof -
	from Jordan_inside_outside_R2[OF jordan]
	have xi: "x \<in> frontier(inside (path_image p))" and
	xo: "x \<in> frontier(outside (path_image p))"
	using x by auto
	obtain y where y:"y \<in> inside (path_image p)" "y \<in> ball x e" using \<open>0 < e\<close> xi
	unfolding frontier_straddle
	by auto
	obtain z where z:"z \<in> outside (path_image p)" "z \<in> ball x e" using \<open>0 < e\<close> xo
	unfolding frontier_straddle
	by auto
	show ?thesis using y z that by blast
	qed

	lemma eventually_at_open_segment:
	assumes "x \<in> {a<--<b}"
	shows "\<forall>\<^sub>F y in at x. (y-a) \<bullet> rot(a-b) = 0 \<longrightarrow> y \<in> {a <--< b}"
	proof -
	from assms have "a \<noteq> b" by auto
	from assms have x: "(x - a) \<bullet> rot (b - a) = 0" "x \<bullet> (b - a) \<in> {a \<bullet> (b - a)<..<b \<bullet> (b - a)}"
	unfolding in_open_segment_iff_rot[OF \<open>a \<noteq> b\<close>]
	by auto
	then have "\<forall>\<^sub>F y in at x. y \<bullet> (b - a) \<in> {a \<bullet> (b - a)<..<b \<bullet> (b - a)}"
	by (intro topological_tendstoD) (auto intro!: tendsto_intros)
	then show ?thesis
	by eventually_elim (auto simp: in_open_segment_iff_rot[OF \<open>a \<noteq> b\<close>] nrm_reverse[of _ a b] algebra_simps dist_commute)
	qed

	lemma linepath_ball:
	assumes "x \<in> {a<--<b}"
	obtains e where "e > 0" "ball x e \<inter> {y. (y-a) \<bullet> rot(a-b) = 0} \<subseteq> {a <--< b}"
	proof -
	from eventually_at_open_segment[OF assms] assms
	obtain e where "0 < e" "ball x e \<inter> {y. (y - a) \<bullet> rot (a - b) = 0} \<subseteq> {a<--<b}"
	by (force simp: eventually_at in_open_segment_iff_rot dist_commute)
	then show ?thesis ..
	qed

	lemma linepath_ball_inside_outside:
	fixes p :: "real \<Rightarrow> 'a"
	assumes jordan: "simple_path (p +++ linepath a b)" "pathfinish p = a" "pathstart p = b"
	assumes x: "x \<in> {a<--<b}"
	obtains e where "e > 0" "ball x e \<inter> path_image p = {}"
	"ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) > 0} \<subseteq> inside (path_image (p +++ linepath a b)) \<and>
	ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) < 0} \<subseteq> outside (path_image (p +++ linepath a b))
	\<or>
	ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) < 0} \<subseteq> inside (path_image (p +++ linepath a b)) \<and>
	ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) > 0} \<subseteq> outside (path_image (p +++ linepath a b))"
	proof -
	let ?lp = "p +++ linepath a b"
	have "a \<noteq> b" using x by auto
	have pp:"path p" using jordan path_join pathfinish_linepath simple_path_imp_path
	by fastforce
	have "path_image p \<inter> path_image (linepath a b) \<subseteq> {a,b}"
	using jordan simple_path_join_loop_eq
	by (metis (no_types, lifting) inf_sup_aci(1) insert_commute path_join_path_ends path_linepath simple_path_imp_path simple_path_joinE)
	then have "x \<notin> path_image p" using x unfolding path_image_linepath
	by (metis DiffE Int_iff le_iff_inf open_segment_def)
	then have "\<forall>\<^sub>F y in at x. y \<notin> path_image p"
	by (intro eventually_not_in_closed) (auto simp: closed_path_image \<open>path p\<close>)
	moreover
	have "\<forall>\<^sub>F y in at x. (y - a) \<bullet> rot (a - b) = 0 \<longrightarrow> y \<in> {a<--<b}"
	by (rule eventually_at_open_segment[OF x])
	ultimately have "\<forall>\<^sub>F y in at x. y \<notin> path_image p \<and> ((y - a) \<bullet> rot (a - b) = 0 \<longrightarrow> y \<in> {a<--<b})"
	by eventually_elim auto
	then obtain e where e: "e > 0" "ball x e \<inter> path_image p = {}"
	"ball x e \<inter> {y. (y - a) \<bullet> rot (a - b) = 0} \<subseteq> {a<--<b}"
	using \<open>x \<notin> path_image p\<close> x in_open_segment_rotD[OF x]
	apply (auto simp: eventually_at subset_iff dist_commute dest!: )
	by (metis Int_iff all_not_in_conv dist_commute mem_ball)
	have a1: "pathfinish ?lp = pathstart ?lp"
	by (auto simp add: jordan)
	have "x \<in> path_image ?lp"
	using jordan(1) open_closed_segment path_image_join path_join_path_ends simple_path_imp_path x by fastforce
	from jordan_points_inside_outside[OF e(1) jordan(1) a1 this]
	obtain y z where y: "y \<in> inside (path_image ?lp)" "y \<in> ball x e"
	and z: "z \<in> outside (path_image ?lp)" "z \<in> ball x e" by blast
	have jordancurve:
	"inside (path_image ?lp) \<inter> outside(path_image ?lp) = {}"
	"frontier (inside (path_image ?lp)) = path_image ?lp"
	"frontier (outside (path_image ?lp)) = path_image ?lp"
	using Jordan_inside_outside_R2[OF jordan(1) a1] by auto
	define b1 where "b1 = ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) > 0}"
	define b2 where "b2 = ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) < 0}"
	define b3 where "b3 = ball x e \<inter> {y. (y-a) \<bullet> rot (a-b) = 0}"
	have "path_connected b1" unfolding b1_def
	apply (auto intro!: convex_imp_path_connected convex_Int simp add:inner_diff_left)
	using convex_halfspace_gt[of "a \<bullet> rot (a - b)" "rot(a-b)"] inner_commute
	by (metis (no_types, lifting) Collect_cong)
	have "path_connected b2" unfolding b2_def
	apply (auto intro!: convex_imp_path_connected convex_Int simp add:inner_diff_left)
	using convex_halfspace_lt[of "rot(a-b)" "a \<bullet> rot (a - b)"] inner_commute
	by (metis (no_types, lifting) Collect_cong)
	have "b1 \<inter> path_image(linepath a b) = {}" unfolding path_image_linepath b1_def
	using closed_segment_surface[OF \<open>a \<noteq> b\<close>] in_segment_inner_rot2 by auto
	then have b1i:"b1 \<inter> path_image ?lp = {}"
	by (metis IntD2 b1_def disjoint_iff_not_equal e(2) inf_sup_aci(1) not_in_path_image_join)
	have "b2 \<inter> path_image(linepath a b) = {}" unfolding path_image_linepath b2_def
	using closed_segment_surface[OF \<open>a \<noteq> b\<close>] in_segment_inner_rot2 by auto
	then have b2i:"b2 \<inter> path_image ?lp = {}"
	by (metis IntD2 b2_def disjoint_iff_not_equal e(2) inf_sup_aci(1) not_in_path_image_join)
	have bsplit: "ball x e = b1 \<union> b2 \<union> b3"
	unfolding b1_def b2_def b3_def
	by auto
	have "z \<notin> b3"
	proof clarsimp
	assume "z \<in> b3"
	then have "z \<in> {a<--<b}" unfolding b3_def using e by blast
	then have "z \<in> path_image(linepath a b)" by (auto simp add: open_segment_def)
	then have "z \<in> path_image ?lp"
	by (simp add: jordan(2) path_image_join)
	thus False using z
	using inside_Un_outside by fastforce
	qed
	then have z12: "z \<in> b1 \<or> z \<in> b2" using z bsplit by blast
	have "y \<notin> b3"
	proof clarsimp
	assume "y \<in> b3"
	then have "y \<in> {a<--<b}" unfolding b3_def using e by auto
	then have "y \<in> path_image(linepath a b)" by (auto simp add: open_segment_def)
	then have "y \<in> path_image ?lp"
	by (simp add: jordan(2) path_image_join)
	thus False using y
	using inside_Un_outside by fastforce
	qed
	then have "y \<in> b1 \<or> y \<in> b2" using y bsplit by blast
	moreover {
	assume "y \<in> b1"
	then have "b1 \<inter> inside (path_image ?lp) \<noteq> {}" using y by blast
	from path_connected_not_frontier_subset[OF \<open>path_connected b1\<close> this]
	have 1:"b1 \<subseteq> inside (path_image ?lp)" unfolding jordancurve using b1i
	by blast
	then have "z \<in> b2" using jordancurve(1) z(1) z12 by blast
	then have "b2 \<inter> outside (path_image ?lp) \<noteq> {}" using z by blast
	from path_connected_not_frontier_subset[OF \<open>path_connected b2\<close> this]
	have 2:"b2 \<subseteq> outside (path_image ?lp)" unfolding jordancurve using b2i
	by blast
	note conjI[OF 1 2]
	}
	moreover {
	assume "y \<in> b2"
	then have "b2 \<inter> inside (path_image ?lp) \<noteq> {}" using y by blast
	from path_connected_not_frontier_subset[OF \<open>path_connected b2\<close> this]
	have 1:"b2 \<subseteq> inside (path_image ?lp)" unfolding jordancurve using b2i
	by blast
	then have "z \<in> b1" using jordancurve(1) z(1) z12 by blast
	then have "b1 \<inter> outside (path_image ?lp) \<noteq> {}" using z by blast
	from path_connected_not_frontier_subset[OF \<open>path_connected b1\<close> this]
	have 2:"b1 \<subseteq> outside (path_image ?lp)" unfolding jordancurve using b1i
	by blast
	note conjI[OF 1 2]
	}
	ultimately show ?thesis unfolding b1_def b2_def using that[OF e(1-2)] by auto
	qed

	subsection \<open>Transversal Segments\<close>\<comment> \<open>TODO: Transversal surface in Euclidean space?!\<close>

	definition "transversal_segment a b \<longleftrightarrow>
	a \<noteq> b \<and> {a--b} \<subseteq> X \<and>
	(\<forall>z \<in> {a--b}. f z \<bullet> rot (a-b) \<noteq> 0)"

	lemma transversal_segment_reverse:
	assumes "transversal_segment x y"
	shows "transversal_segment y x"
	unfolding transversal_segment_def
	by (metis (no_types, opaque_lifting) add.left_neutral add_uminus_conv_diff assms closed_segment_commute inner_diff_left inner_zero_left nrm_reverse transversal_segment_def)

	lemma transversal_segment_commute: "transversal_segment x y \<longleftrightarrow> transversal_segment y x"
	using transversal_segment_reverse by blast

	lemma transversal_segment_neg:
	assumes "transversal_segment x y"
	assumes w: "w \<in> {x -- y}" and "f w \<bullet> rot (x-y) < 0"
	shows "\<forall>z \<in> {x--y}. f(z) \<bullet> rot (x-y) < 0"
	proof (rule ccontr)
	assume " \<not> (\<forall>z\<in>{x--y}. f z \<bullet> rot (x-y) < 0)"
	then obtain z where z: "z \<in> {x--y}" "f z \<bullet> rot (x-y) \<ge> 0" by auto
	define ff where "ff = (\<lambda>s. f (w + s *\<^sub>R (z - w)) \<bullet> rot (x-y))"
	have f0:"ff 0 \<le> 0" unfolding ff_def using assms(3)
	by simp
	have fu:"ff 1 \<ge> 0"
	by (auto simp: ff_def z)
	from assms(2) obtain u where u: "0 \<le> u" "u \<le> 1" "w = (1 - u) \<^sub>R x + u \<^sub>R y"
	unfolding in_segment by blast
	have "{x--y} \<subseteq> X" using assms(1) unfolding transversal_segment_def by blast
	then have "continuous_on {0..1} ff" unfolding ff_def
	using assms(2)
	by (auto intro!:continuous_intros closed_subsegmentI z elim!: set_mp)
	from IVT'[of ff, OF f0 fu zero_le_one this]
	obtain s where s: "s \<ge> 0" "s \<le> 1" "ff s = 0" by blast
	have "w + s *\<^sub>R (z - w) \<in> {x -- y}"
	by (auto intro!: closed_subsegmentI z s w)
	with \<open>ff s = 0\<close> show False
	using s assms(1) unfolding transversal_segment_def ff_def by blast
	qed

	lemmas transversal_segment_sign_less = transversal_segment_neg[OF _ ends_in_segment(1)]

	lemma transversal_segment_pos:
	assumes "transversal_segment x y"
	assumes w: "w \<in> {x -- y}" "f w \<bullet> rot (x-y) > 0"
	shows "\<forall>z \<in> {x--y}. f(z) \<bullet> rot (x-y) > 0"
	using transversal_segment_neg[OF transversal_segment_reverse[OF assms(1)], of w] w
	by (auto simp: rot_diff_commute[of x y] closed_segment_commute)

	lemma transversal_segment_posD:
	assumes "transversal_segment x y"
	and pos: "z \<in> {x -- y}" "f z \<bullet> rot (x - y) > 0"
	shows "x \<noteq> y" "{x--y} \<subseteq> X" "\<And>z. z \<in> {x--y} \<Longrightarrow> f z \<bullet> rot (x-y) > 0"
	using assms(1) transversal_segment_pos[OF assms]
	by (auto simp: transversal_segment_def)

	lemma transversal_segment_negD:
	assumes "transversal_segment x y"
	and pos: "z \<in> {x -- y}" "f z \<bullet> rot (x - y) < 0"
	shows "x \<noteq> y" "{x--y} \<subseteq> X" "\<And>z. z \<in> {x--y} \<Longrightarrow> f z \<bullet> rot (x-y) < 0"
	using assms(1) transversal_segment_neg[OF assms]
	by (auto simp: transversal_segment_def)

	lemma transversal_segmentE:
	assumes "transversal_segment x y"
	obtains "x \<noteq> y" "{x -- y} \<subseteq> X" "\<And>z. z \<in> {x--y} \<Longrightarrow> f z \<bullet> rot (x - y) > 0"
	\| "x \<noteq> y" "{x -- y} \<subseteq> X" "\<And>z. z \<in> {x--y} \<Longrightarrow> f z \<bullet> rot (y - x) > 0"
	proof (cases "f x \<bullet> rot (x - y) < 0")
	case True
	from transversal_segment_negD[OF assms ends_in_segment(1) True]
	have "x \<noteq> y" "{x -- y} \<subseteq> X" "\<And>z. z \<in> {x--y} \<Longrightarrow> f z \<bullet> rot (y - x) > 0"
	by (auto simp: rot_diff_commute[of x y])
	then show ?thesis ..
	next
	case False
	then have "f x \<bullet> rot (x - y) > 0" using assms
	by (auto simp: transversal_segment_def algebra_split_simps not_less order.order_iff_strict)
	from transversal_segment_posD[OF assms ends_in_segment(1) this]
	show ?thesis ..
	qed

	lemma dist_add_vec:
	shows "dist (x + s \<^sub>R v) x = abs s norm v"
	by (simp add: dist_cancel_add1)

	lemma transversal_segment_exists:
	assumes "x \<in> X" "f x \<noteq> 0"
	obtains a b where "x \<in> {a<--<b}"
	"transversal_segment a b"
	proof -
	(* Line through x perpendicular to f x *)
	define l where "l = (\<lambda>s::real. x + (s/norm(f x)) *\<^sub>R rot (f x))"
	have "norm (f x) > 0" using assms(2) using zero_less_norm_iff by blast
	then have distl: "\<forall>s. dist (l s) x = abs s" unfolding l_def dist_add_vec
	by (auto simp add: norm_rot)
	obtain d where d:"d > 0" "cball x d \<subseteq> X"
	by (meson UNIV_I assms(1) local.local_unique_solution)
	then have lb: "l`{-d..d} \<subseteq> cball x d" using distl by (simp add: abs_le_iff dist_commute image_subset_iff)
	from fcontx[OF assms(1)] have "continuous (at x) f" .
	then have c:"continuous (at 0) ((\<lambda>y. (f y \<bullet> f x)) \<circ> l)" unfolding l_def
	by (auto intro!:continuous_intros simp add: assms(2))
	have "((\<lambda>y. f y \<bullet> f x) \<circ> l) 0 > 0" using assms(2) unfolding l_def o_def by auto
	from continuous_at_imp_cball[OF c this]
	obtain r where r:"r > 0" " \<forall>z\<in>cball 0 r. 0 < ((\<lambda>y. f y \<bullet> f x) \<circ> l) z" by blast
	then have rc:"\<forall>z \<in> l`{-r..r}. 0 < f z \<bullet> f x" using real_norm_def by auto
	define dr where "dr = min r d"
	have t1:"l (-dr) \<noteq> l dr" unfolding l_def dr_def
	by (smt \<open>0 < d\<close> \<open>0 < norm (f x)\<close> \<open>0 < r\<close> add_left_imp_eq divide_cancel_right norm_rot norm_zero scale_cancel_right)
	have "x = midpoint (l (-dr)) (l dr)" unfolding midpoint_def l_def by auto
	then have xin:"x \<in> {l (-dr)<--<(l dr)}" using t1 by auto
	(* TODO: actually this should be equality, but l is affine ...
	also the existing stuff about -- is a little too specific *)
	have lsub:"{l (-dr)--l dr} \<subseteq> l`{-dr..dr}"
	proof safe
	fix z
	assume "z \<in> {l (- dr)--l dr}"
	then obtain u where u: "0 \<le> u" "u \<le> 1" "z = (1 - u) \<^sub>R (l (-dr)) + u \<^sub>R (l dr)"
	unfolding in_segment by blast
	then have "z = x - (1-u) \<^sub>R (dr/norm(f x)) \<^sub>R rot (f x) + u \<^sub>R (dr/norm(f x)) \<^sub>R rot (f x) "
	unfolding l_def
	by (simp add: l_def scaleR_add_right scale_right_diff_distrib u(3))
	also have "... = x - (1 - 2 * u) \<^sub>R (dr/norm(f x)) \<^sub>R rot (f x)"
	by (auto simp add: algebra_simps divide_simps simp flip: scaleR_add_left)
	also have "... = x + (((2 * u - 1) * dr)/norm(f x)) *\<^sub>R rot (f x)"
	by (smt add_uminus_conv_diff scaleR_scaleR scale_minus_left times_divide_eq_right)
	finally have zeq: "z = l ((2u-1)dr)" unfolding l_def .
	have ub: " 2* u - 1 \<le> 1 \<and> -1 \<le> 2* u - 1 " using u by linarith
	thus "z \<in> l ` {- dr..dr}" using zeq
	by (smt atLeastAtMost_iff d(1) dr_def image_eqI mult.commute mult_left_le mult_minus_left r(1))
	qed
	have t2: "{l (- dr)--l dr} \<subseteq> X" using lsub
	by (smt atLeastAtMost_iff d(2) dist_commute distl dr_def image_subset_iff mem_cball order_trans)
	have "l (- dr) - l dr = -2 \<^sub>R (dr/norm(f x)) \<^sub>R rot (f x)" unfolding l_def
	by (simp add: algebra_simps flip: scaleR_add_left)
	then have req: "rot (l (- dr) - l dr) = (2 * dr/norm(f x)) *\<^sub>R f x"
	by auto (metis add.inverse_inverse rot_rot rot_scaleR)
	have "l`{-dr..dr} \<subseteq> l ` {-r ..r}"
	by (simp add: dr_def image_mono)
	then have "{l (- dr)--l dr} \<subseteq> l ` {-r .. r}" using lsub by auto
	then have "\<forall>z \<in> {l (- dr)--l dr}. 0 < f z \<bullet> f x" using rc by blast
	moreover have "(dr / norm (f x)) > 0"
	using \<open>0 < norm (f x)\<close> d(1) dr_def r(1) by auto
	ultimately have t3: "\<forall>z \<in> {l (- dr)--l dr}. f z \<bullet> rot (l (- dr)- l dr) > 0" unfolding req
	by (smt divide_divide_eq_right inner_scaleR_right mult_2 norm_not_less_zero scaleR_2 times_divide_eq_left times_divide_eq_right zero_less_divide_iff)
	have "transversal_segment (l (-dr)) (l dr)" using t1 t2 t3 unfolding transversal_segment_def by auto
	thus ?thesis using xin
	using that by auto
	qed

	text \<open>Perko Section 3.7 Lemma 2 part 1.\<close>
	lemma flow_transversal_segment_finite_intersections:
	assumes "transversal_segment a b"
	assumes "t \<le> t'" "{t .. t'} \<subseteq> existence_ivl0 x"
	shows "finite {s\<in>{t..t'}. flow0 x s \<in> {a--b}}"
	proof -
	from assms have "a \<noteq> b" by (simp add: transversal_segment_def)
	show ?thesis
	unfolding closed_segment_surface[OF \<open>a \<noteq> b\<close>]
	apply (rule flow_transversal_surface_finite_intersections[where Ds="\<lambda>_. blinfun_inner_left (rot (b - a))"])
	by
	(use assms in \<open>auto intro!: closed_Collect_conj closed_halfspace_component_ge closed_halfspace_component_le
	derivative_eq_intros
	simp: transversal_segment_def nrm_reverse[where x=a] in_closed_segment_iff_rot\<close>)
	qed

	lemma transversal_bound_posE:
	assumes transversal: "transversal_segment a b"
	assumes direction: "z \<in> {a -- b}" "f z \<bullet> (rot (a - b)) > 0"
	obtains d B where "d > 0" "0 < B"
	"\<And>x y. x \<in> {a -- b} \<Longrightarrow> dist x y \<le> d \<Longrightarrow> f y \<bullet> (rot (a - b)) \<ge> B"
	proof -
	let ?a = "(\<lambda>y. (f y) \<bullet> (rot (a - b)))"
	from transversal_segment_posD[OF transversal direction]
	have seg: "a \<noteq> b" "{a--b} \<subseteq> X" "z \<in> {a--b} \<Longrightarrow> 0 < f z \<bullet> rot (a - b)" for z
	by auto
	{
	fix x
	assume "x \<in> {a--b}"
	then have "x \<in> X" "f x \<noteq> 0" "a \<noteq> b" using transversal by (auto simp: transversal_segment_def)
	then have "?a \<midarrow>x\<rightarrow> ?a x"
	by (auto intro!: tendsto_eq_intros)
	moreover have "?a x > 0"
	using seg \<open>x \<in> {a -- b}\<close> \<open>f x \<noteq> 0\<close>
	by (auto simp: simp del: divide_const_simps
	intro!: divide_pos_pos mult_pos_pos)
	ultimately have "\<forall>\<^sub>F x in at x. ?a x > 0"
	by (rule order_tendstoD)
	moreover have "\<forall>\<^sub>F x in at x. x \<in> X"
	by (rule topological_tendstoD[OF tendsto_ident_at open_dom \<open>x \<in> X\<close>])
	moreover have "\<forall>\<^sub>F x in at x. f x \<noteq> 0"
	by (rule tendsto_imp_eventually_ne tendsto_intros \<open>x \<in> X\<close> \<open>f x \<noteq> 0\<close>)+
	ultimately have "\<forall>\<^sub>F x in at x. ?a x>0 \<and> x \<in> X \<and> f x \<noteq> 0" by eventually_elim auto
	then obtain d where d: "0 < d" "\<And>y. y \<in> cball x d \<Longrightarrow> ?a y > 0 \<and> y \<in> X \<and> f y \<noteq> 0"
	using \<open>?a x > 0\<close> \<open>x \<in> X\<close>
	by (force simp: eventually_at_le dist_commute)

	have "continuous_on (cball x d) ?a"
	using d \<open>a \<noteq> b\<close>
	by (auto intro!: continuous_intros)
	from compact_continuous_image[OF this compact_cball]
	have "compact (?a ` cball x d)" .
	from compact_attains_inf[OF this] obtain s where "s \<in> cball x d" "\<forall>x\<in>cball x d. ?a x \<ge> ?a s"
	using \<open>d > 0\<close>
	by auto
	then have "\<exists>d>0. \<exists>b>0. \<forall>x \<in> cball x d. ?a x \<ge> b"
	using d
	by (force simp: intro: exI[where x="?a s"])
	} then obtain dx Bx where dB:
	"\<And>x y. x \<in> {a -- b} \<Longrightarrow> y\<in>cball x (dx x) \<Longrightarrow> ?a y \<ge> Bx x"
	"\<And>x. x \<in> {a -- b} \<Longrightarrow> Bx x > 0"
	"\<And>x. x \<in> {a -- b} \<Longrightarrow> dx x > 0"
	by metis
	define d' where "d' = (\<lambda>x. dx x / 2)"
	have d':
	"\<And>x. x \<in> {a -- b} \<Longrightarrow> \<forall>y\<in>cball x (d' x). ?a y \<ge> Bx x"
	"\<And>x. x \<in> {a -- b} \<Longrightarrow> d' x > 0"
	using dB(1,3) by (force simp: d'_def)+
	have d'B: "\<And>x. x \<in> {a -- b} \<Longrightarrow> \<forall>y\<in>cball x (d' x). ?a y \<ge> Bx x"
	using d' by auto
	have "{a--b} \<subseteq> \<Union>((\<lambda>x. ball x (d' x)) ` {a -- b})"
	using d'(2) by auto
	from compactE_image[OF compact_segment _ this]
	obtain X where X: "X \<subseteq> {a--b}"
	and [simp]: "finite X"
	and cover: "{a--b} \<subseteq> (\<Union>x\<in>X. ball x (d' x))"
	by auto
	have [simp]: "X \<noteq> {}" using X cover by auto
	define d where "d = Min (d' ` X)"
	define B where "B = Min (Bx ` X)"
	have "d > 0"
	using X d'
	by (auto simp: d_def d'_def)
	moreover have "B > 0"
	using X dB
	by (auto simp: B_def simp del: divide_const_simps)
	moreover have "B \<le> ?a y" if "x \<in> {a -- b}" "dist x y \<le> d" for x y
	proof -
	from \<open>x \<in> {a -- b}\<close> obtain xc where xc: "xc \<in> X" "x \<in> ball xc (d' xc)"
	using cover by auto
	have "?a y \<ge> Bx xc"
	proof (rule dB)
	show "xc \<in> {a -- b}" using xc \<open>X \<subseteq> _\<close> by auto
	have "dist xc y \<le> dist xc x + dist x y" by norm
	also have "dist xc x \<le> d' xc" using xc by auto
	also note \<open>dist x y \<le> d\<close>
	also have "d \<le> d' xc"
	using xc
	by (auto simp: d_def)
	also have "d' xc + d' xc = dx xc" by (simp add: d'_def)
	finally show "y \<in> cball xc (dx xc)" by simp
	qed
	also have "B \<le> Bx xc"
	using xc
	unfolding B_def
	by (auto simp: B_def)
	finally (xtrans) show ?thesis .
	qed
	ultimately show ?thesis ..
	qed

	lemma transversal_bound_negE:
	assumes transversal: "transversal_segment a b"
	assumes direction: "z \<in> {a -- b}" "f z \<bullet> (rot (a - b)) < 0"
	obtains d B where "d > 0" "0 < B"
	"\<And>x y. x \<in> {a -- b} \<Longrightarrow> dist x y \<le> d \<Longrightarrow> f y \<bullet> (rot (b - a)) \<ge> B"
	proof -
	from direction have "z \<in> {b -- a}" "f z \<bullet> (rot (b - a)) > 0"
	by (auto simp: closed_segment_commute rot_diff_commute[of b a])
	from transversal_bound_posE[OF transversal_segment_reverse[OF transversal] this]
	obtain d B where "d > 0" "0 < B"
	"\<And>x y. x \<in> {a -- b} \<Longrightarrow> dist x y \<le> d \<Longrightarrow> f y \<bullet> (rot (b - a)) \<ge> B"
	by (auto simp: closed_segment_commute)
	then show ?thesis ..
	qed

	lemma leaves_transversal_segmentE:
	assumes transversal: "transversal_segment a b"
	obtains T n where "T > 0" "n = a - b \<or> n = b - a"
	"\<And>x. x \<in> {a -- b} \<Longrightarrow> {-T..T} \<subseteq> existence_ivl0 x"
	"\<And>x s. x \<in> {a -- b} \<Longrightarrow> 0 < s \<Longrightarrow> s \<le> T \<Longrightarrow>
	(flow0 x s - x) \<bullet> rot n > 0"
	"\<And>x s. x \<in> {a -- b} \<Longrightarrow> -T \<le> s \<Longrightarrow> s < 0 \<Longrightarrow>
	(flow0 x s - x) \<bullet> rot n < 0"
	proof -
	from transversal_segmentE[OF assms(1)] obtain n
	where n: "n = (a - b) \<or> n = (b - a)"
	and seg: "a \<noteq> b" "{a -- b} \<subseteq> X" "\<And>z. z \<in> {a--b} \<Longrightarrow> f z \<bullet> rot n > 0"
	by metis
	from open_existence_ivl_on_compact[OF \<open>{a -- b} \<subseteq> X\<close>]
	obtain t where "0 < t" and t: "x \<in> {a--b} \<Longrightarrow> {- t..t} \<subseteq> existence_ivl0 x" for x
	by auto
	from n obtain d B where B: "0 < d" "0 < B" "(\<And>x y. x \<in> {a--b} \<Longrightarrow> dist x y \<le> d \<Longrightarrow> B \<le> f y \<bullet> rot n)"
	proof
	assume n_def: "n = a - b"
	with seg have pos: "0 < f a \<bullet> rot (a - b)"
	by auto
	from transversal_bound_posE[OF transversal ends_in_segment(1) pos, folded n_def]
	show ?thesis using that by blast
	next
	assume n_def: "n = b - a"
	with seg have pos: "0 > f a \<bullet> rot (a - b)"
	by (auto simp: rot_diff_commute[of a b])
	from transversal_bound_negE[OF transversal ends_in_segment(1) this, folded n_def]
	show ?thesis using that by blast
	qed
	define S where "S = \<Union>((\<lambda>x. ball x d) ` {a -- b})"
	have S: "x \<in> S \<Longrightarrow> B \<le> f x \<bullet> rot n" for x
	by (auto simp: S_def intro!: B)
	have "open S" by (auto simp: S_def)
	have "{a -- b} \<subseteq> S"
	by (auto simp: S_def \<open>0 < d\<close>)
	have "\<forall>\<^sub>F (t, x) in at (0, x). flow0 x t \<in> S" if "x \<in> {a -- b}" for x
	unfolding split_beta'
	apply (rule topological_tendstoD tendsto_intros)+
	using set_mp[OF \<open>{a -- b} \<subseteq> X\<close> that] \<open>0 < d\<close> that \<open>open S\<close> \<open>{a -- b} \<subseteq> S\<close>
	- by (force simp: )+
	+ by force+
	then obtain d' where d':
	"\<And>x. x \<in> {a--b} \<Longrightarrow> d' x > 0"
	"\<And>x y s. x \<in> {a--b} \<Longrightarrow> (s = 0 \<longrightarrow> y \<noteq> x) \<Longrightarrow> dist (s, y) (0, x) < d' x \<Longrightarrow> flow0 y s \<in> S"
	by (auto simp: eventually_at) metis
	define d2 where "d2 x = d' x / 2" for x
	have d2: "\<And>x. x \<in> {a--b} \<Longrightarrow> d2 x > 0" using d' by (auto simp: d2_def)
	have C: "{a--b} \<subseteq> \<Union>((\<lambda>x. ball x (d2 x)) ` {a -- b})"
	using d2 by auto
	from compactE_image[OF compact_segment _ C]
	obtain C' where "C' \<subseteq> {a--b}" and [simp]: "finite C'"
	and C'_cover: "{a--b} \<subseteq> (\<Union>c\<in>C'. ball c (d2 c))" by auto

	define T where "T = Min (insert t (d2 ` C'))"

	have "T > 0"
	using \<open>0 < t\<close> d2 \<open>C' \<subseteq> _\<close>
	by (auto simp: T_def)
	moreover
	note n
	moreover
	have T_ex: "{-T..T} \<subseteq> existence_ivl0 x" if "x \<in> {a--b}" for x
	by (rule order_trans[OF _ t[OF that]]) (auto simp: T_def)
	moreover
	have B_le: "B \<le> f (flow0 x \<xi>) \<bullet> rot n"
	if "x \<in> {a -- b}"
	and c': "c' \<in> C'" "x \<in> ball c' (d2 c')"
	and "\<xi> \<noteq> 0" and \<xi>_le: "\<bar>\<xi>\<bar> < d2 c'"
	for x c' \<xi>
	proof -
	have "c' \<in> {a -- b}" using c' \<open>C' \<subseteq> _\<close> by auto
	moreover have "\<xi> = 0 \<longrightarrow> x \<noteq> c'" using \<open>\<xi> \<noteq> 0\<close> by simp
	moreover have "dist (\<xi>, x) (0, c') < d' c'"
	proof -
	have "dist (\<xi>, x) (0, c') \<le> dist (\<xi>, x) (\<xi>, c') + dist (\<xi>, c') (0, c')"
	by norm
	also have "dist (\<xi>, x) (\<xi>, c') < d2 c'"
	using c'
	by (simp add: dist_prod_def dist_commute)
	also
	have "T \<le> d2 c'" using c'
	by (auto simp: T_def)
	then have "dist (\<xi>, c') (0, c') < d2 c'"
	using \<xi>_le
	by (simp add: dist_prod_def)
	also have "d2 c' + d2 c' = d' c'" by (simp add: d2_def)
	finally show ?thesis by simp
	qed
	ultimately have "flow0 x \<xi> \<in> S"
	by (rule d')
	then show ?thesis
	by (rule S)
	qed
	let ?g = "(\<lambda>x t. (flow0 x t - x) \<bullet> rot n)"
	have cont: "continuous_on {-T .. T} (?g x)"
	if "x \<in> {a--b}" for x
	using T_ex that
	by (force intro!: continuous_intros)
	have deriv: "-T \<le> s' \<Longrightarrow> s' \<le> T \<Longrightarrow> ((?g x) has_derivative
	(\<lambda>t. t * (f (flow0 x s') \<bullet> rot n))) (at s')"
	if "x \<in> {a--b}" for x s'
	using T_ex that
	by (force intro!: derivative_eq_intros simp: flowderiv_def blinfun.bilinear_simps)

	have "(flow0 x s - x) \<bullet> rot n > 0" if "x \<in> {a -- b}" "0 < s" "s \<le> T" for x s
	proof (rule ccontr, unfold not_less)
	have [simp]: "x \<in> X" using that \<open>{a -- b} \<subseteq> X\<close> by auto
	assume H: "(flow0 x s - x) \<bullet> rot n \<le> 0"
	have cont: "continuous_on {0 .. s} (?g x)"
	using cont by (rule continuous_on_subset) (use that in auto)
	from mvt[OF \<open>0 < s\<close> cont deriv] that
	obtain \<xi> where \<xi>: "0 < \<xi>" "\<xi> < s" "(flow0 x s - x) \<bullet> rot n = s * (f (flow0 x \<xi>) \<bullet> rot n)"
	by (auto intro: continuous_on_subset)
	note \<open>0 < B\<close>
	also
	from C'_cover that obtain c' where c': "c' \<in> C'" "x \<in> ball c' (d2 c')" by auto
	have "B \<le> f (flow0 x \<xi>) \<bullet> rot n"
	proof (rule B_le[OF that(1) c'])
	show "\<xi> \<noteq> 0" using \<open>0 < \<xi>\<close> by simp
	have "T \<le> d2 c'" using c'
	by (auto simp: T_def)
	then show "\<bar>\<xi>\<bar> < d2 c'"
	using \<open>0 < \<xi>\<close> \<open>\<xi> < s\<close> \<open>s \<le> T\<close>
	by (simp add: dist_prod_def)
	qed
	also from \<xi> H have "\<dots> \<le> 0"
	by (auto simp add: algebra_split_simps not_less split: if_splits)
	finally show False by simp
	qed
	moreover
	have "(flow0 x s - x) \<bullet> rot n < 0" if "x \<in> {a -- b}" "-T \<le> s" "s < 0" for x s
	proof (rule ccontr, unfold not_less)
	have [simp]: "x \<in> X" using that \<open>{a -- b} \<subseteq> X\<close> by auto
	assume H: "(flow0 x s - x) \<bullet> rot n \<ge> 0"
	have cont: "continuous_on {s .. 0} (?g x)"
	using cont by (rule continuous_on_subset) (use that in auto)
	from mvt[OF \<open>s < 0\<close> cont deriv] that
	obtain \<xi> where \<xi>: "s < \<xi>" "\<xi> < 0" "(flow0 x s - x) \<bullet> rot n = s * (f (flow0 x \<xi>) \<bullet> rot n)"
	by auto
	note \<open>0 < B\<close>
	also
	from C'_cover that obtain c' where c': "c' \<in> C'" "x \<in> ball c' (d2 c')" by auto
	have "B \<le> (f (flow0 x \<xi>) \<bullet> rot n)"
	proof (rule B_le[OF that(1) c'])
	show "\<xi> \<noteq> 0" using \<open>0 > \<xi>\<close> by simp
	have "T \<le> d2 c'" using c'
	by (auto simp: T_def)
	then show "\<bar>\<xi>\<bar> < d2 c'"
	using \<open>0 > \<xi>\<close> \<open>\<xi> > s\<close> \<open>s \<ge> - T\<close>
	by (simp add: dist_prod_def)
	qed
	also from \<xi> H have "\<dots> \<le> 0"
	by (simp add: algebra_split_simps)
	finally show False by simp
	qed
	ultimately show ?thesis ..
	qed


	lemma inner_rot_pos_move_base: "(x - a) \<bullet> rot (a - b) > 0"
	if "(x - y) \<bullet> rot (a - b) > 0" "y \<in> {a -- b}"
	by (smt in_segment_inner_rot inner_diff_left inner_minus_right minus_diff_eq rot_rot that)

	lemma inner_rot_neg_move_base: "(x - a) \<bullet> rot (a - b) < 0"
	if "(x - y) \<bullet> rot (a - b) < 0" "y \<in> {a -- b}"
	by (smt in_segment_inner_rot inner_diff_left inner_minus_right minus_diff_eq rot_rot that)

	lemma inner_pos_move_base: "(x - a) \<bullet> n > 0"
	if "(a - b) \<bullet> n = 0" "(x - y) \<bullet> n > 0" "y \<in> {a -- b}"
	proof -
	from that(3) obtain u where y_def: "y = (1 - u) \<^sub>R a + u \<^sub>R b" and u: "0 \<le> u" "u \<le> 1"
	by (auto simp: in_segment)
	have "(x - a) \<bullet> n = (x - y) \<bullet> n - u * ((a - b) \<bullet> n)"
	by (simp add: algebra_simps y_def)
	also have "\<dots> = (x - y) \<bullet> n"
	by (simp add: that)
	also note \<open>\<dots> > 0\<close>
	finally show ?thesis .
	qed

	lemma inner_neg_move_base: "(x - a) \<bullet> n < 0"
	if "(a - b) \<bullet> n = 0" "(x - y) \<bullet> n < 0" "y \<in> {a -- b}"
	proof -
	from that(3) obtain u where y_def: "y = (1 - u) \<^sub>R a + u \<^sub>R b" and u: "0 \<le> u" "u \<le> 1"
	by (auto simp: in_segment)
	have "(x - a) \<bullet> n = (x - y) \<bullet> n - u * ((a - b) \<bullet> n)"
	by (simp add: algebra_simps y_def)
	also have "\<dots> = (x - y) \<bullet> n"
	by (simp add: that)
	also note \<open>\<dots> < 0\<close>
	finally show ?thesis .
	qed

	lemma rot_same_dir:
	assumes "x1 \<in> {a<--<b}"
	assumes "x2 \<in> {x1<--<b}"
	shows "(y \<bullet> rot (a-b) > 0) = (y \<bullet> rot(x1-x2) > 0)" "(y \<bullet> rot (a-b) < 0) = (y \<bullet> rot(x1-x2) < 0)"
	using oriented_subsegment_scale[OF assms]
	apply (smt inner_scaleR_right nrm_reverse rot_scaleR zero_less_mult_iff)
	by (smt \<open>\<And>thesis. (\<And>e. \<lbrakk>0 < e; b - a = e *\<^sub>R (x2 - x1)\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> inner_minus_right inner_scaleR_right rot_diff_commute rot_scaleR zero_less_mult_iff)


	subsection \<open>Monotone Step Lemma\<close>

	lemma flow0_transversal_segment_monotone_step:
	assumes "transversal_segment a b"
	assumes "t1 \<le> t2" "{t1..t2} \<subseteq> existence_ivl0 x"
	assumes x1: "flow0 x t1 \<in> {a<--<b}"
	assumes x2: "flow0 x t2 \<in> {flow0 x t1<--<b}"
	assumes "\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}"
	assumes "t > t2" "t \<in> existence_ivl0 x"
	shows "flow0 x t \<notin> {a<--<flow0 x t2}"
	proof -
	note exist = \<open>{t1..t2} \<subseteq> existence_ivl0 x\<close>
	note t1t2 = \<open>\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}\<close>
	(* Basic properties of the segment *)
	have x1neqx2: "flow0 x t1 \<noteq> flow0 x t2"
	using open_segment_def x2 by force
	then have t1neqt2: "t1 \<noteq> t2" by auto

	have [simp]: "a \<noteq> b" and \<open>{a -- b} \<subseteq> X\<close> using \<open>transversal_segment a b\<close>
	by (auto simp: transversal_segment_def)

	from x1 obtain i1 where i1: "flow0 x t1 = line a b i1" "0 < i1" "i1 < 1"
	by (auto simp: in_open_segment_iff_line)
	from x2 obtain i2 where i2: "flow0 x t2 = line a b i2" "0 < i1" "i1 < i2"
	by (auto simp: i1 line_open_segment_iff)


	have "{a <--< flow0 x t1} \<subseteq> {a<--<b}"
	by (simp add: open_closed_segment subset_open_segment x1)
	have t12sub: "{flow0 x t1--flow0 x t2} \<subseteq> {a<--<b}"
	by (metis ends_in_segment(2) open_closed_segment subset_co_segment subset_eq subset_open_segment x1 x2)
	have subr: "{flow0 x t1<--<flow0 x t2} \<subseteq> {flow0 x t1 <--<b}"
	by (simp add: open_closed_segment subset_open_segment x2)
	have "flow0 x t1 \<in> {a <--<flow0 x t2}" using x1 x2
	by (rule open_segment_subsegment)
	then have subl: "{flow0 x t1<--<flow0 x t2} \<subseteq> {a <--< flow0 x t2}" using x1 x2
	by (simp add: open_closed_segment subset_open_segment x2)
	then have subl2: "{flow0 x t1--<flow0 x t2} \<subseteq> {a <--< flow0 x t2}" using x1 x2
	by (smt DiffE DiffI \<open>flow0 x t1 \<in> {a<--<flow0 x t2}\<close> half_open_segment_def insert_iff open_segment_def subset_eq)

	have sub1b: "{flow0 x t1--b} \<subseteq> {a--b}"
	by (simp add: open_closed_segment subset_closed_segment x1)
	have suba2: "{a--flow0 x t2} \<subseteq> {a -- b}"
	using open_closed_segment subset_closed_segment t12sub by blast
	then have suba2o: "{a<--<flow0 x t2} \<subseteq> {a -- b}"
	using open_closed_segment subset_closed_segment t12sub by blast
	have x2_notmem: "flow0 x t2 \<notin> {a--flow0 x t1}"
	using i1 i2
	by (auto simp: closed_segment_line_iff)
	have suba12: "{a--flow0 x t1} \<subseteq> {a--flow0 x t2}"
	by (simp add: \<open>flow0 x t1 \<in> {a<--<flow0 x t2}\<close> open_closed_segment subset_closed_segment)
	then have suba12_open: "{a<--<flow0 x t1} \<subseteq> {a<--<flow0 x t2}"
	using x2_notmem
	by (auto simp: open_segment_def)
	have "flow0 x t2 \<in> {a--b}"
	using suba2 by auto

	have intereq: "\<And>t. t1 \<le> t \<Longrightarrow> t \<le> t2 \<Longrightarrow> flow0 x t \<in> {a<--<b} \<Longrightarrow> t = t1 \<or> t = t2"
	proof (rule ccontr)
	fix t
	assume t: "t1 \<le> t" "t \<le> t2" "flow0 x t \<in> {a<--<b}" "\<not>(t= t1 \<or> t = t2)"
	then have "t \<in> {t1<..<t2}" by auto
	then have "flow0 x t \<notin> {a<--<b}" using t1t2 by blast
	thus False using t by auto
	qed
	then have intereqt12: "\<And>t. t1 \<le> t \<Longrightarrow> t \<le> t2 \<Longrightarrow> flow0 x t \<in> {flow0 x t1--flow0 x t2} \<Longrightarrow> t = t1 \<or> t = t2"
	using t12sub by blast

	(* The Jordan curve *)
	define J1 where "J1 = flow_to_path x t1 t2"
	define J2 where "J2 = linepath (flow0 x t2) (flow0 x t1)"
	define J where "J = J1 +++ J2"
	(* Proof that J is a Jordan curve *)
	have "pathfinish J = pathstart J" unfolding J_def J1_def J2_def
	by (auto simp add: pathstart_compose pathfinish_compose)
	have piJ: "path_image J = path_image J1 \<union> path_image J2"
	unfolding J_def J1_def J2_def
	apply (rule path_image_join)
	by auto
	have "flow0 x t1 \<in> flow0 x ` {t1..t2} \<and> flow0 x t2 \<in> flow0 x ` {t1..t2}"
	using atLeastAtMost_iff \<open>t1 \<le> t2\<close> by blast
	then have piD: "path_image J = path_image J1 \<union> {flow0 x t1 <--<flow0 x t2}"
	unfolding piJ J1_def J2_def path_image_flow_to_path[OF \<open>t1 \<le> t2\<close>]
	path_image_linepath open_segment_def
	by (smt Diff_idemp Diff_insert2 Un_Diff_cancel closed_segment_commute mk_disjoint_insert)
	have "\<forall>s\<in>{t1<..<t2}. flow0 x s \<noteq> flow0 x t1"
	using x1 t1t2 by fastforce
	from flow_to_path_arc[OF \<open>t1 \<le> t2\<close> exist this x1neqx2]
	have "arc J1" using J1_def assms flow_to_path_arc by auto
	then have "simple_path J" unfolding J_def
	using \<open>arc J1\<close> J1_def J2_def assms x1neqx2 t1neqt2 apply (auto intro!:simple_path_join_loop)
	using intereqt12 closed_segment_commute by blast

	from Jordan_inside_outside_R2[OF this \<open>pathfinish J = pathstart J\<close>]
	obtain inner outer where inner_def: "inner = inside (path_image J)"
	and outer_def: "outer = outside (path_image J)"
	and io:
	"inner \<noteq> {}" "open inner" "connected inner"
	"outer \<noteq> {}" "open outer" "connected outer"
	"bounded inner" "\<not> bounded outer" "inner \<inter> outer = {}"
	"inner \<union> outer = - path_image J"
	"frontier inner = path_image J"
	"frontier outer = path_image J" by metis
	from io have io2: "outer \<inter> inner = {}" "outer \<union> inner = - path_image J" by auto

	have swap_side: "\<And>y t. y \<in> side2 \<Longrightarrow>
	0 \<le> t \<Longrightarrow> t \<in> existence_ivl0 y \<Longrightarrow>
	flow0 y t \<in> closure side1 \<Longrightarrow>
	\<exists>T. 0 < T \<and> T \<le> t \<and> (\<forall>s \<in>{0..<T}. flow0 y s \<in> side2) \<and>
	flow0 y T \<in> {flow0 x t1--<flow0 x t2}"
	if "side1 \<inter> side2 = {}"
	"open side2"
	"frontier side1 = path_image J"
	"frontier side2 = path_image J"
	"side1 \<union> side2 = - path_image J"
	for side1 side2
	proof -
	fix y t
	assume yt: "y \<in> side2" "0 \<le> t" "t \<in> existence_ivl0 y"
	"flow0 y t \<in> closure side1"
	define fp where "fp = flow_to_path y 0 t"
	have ex:"{0..t} \<subseteq> existence_ivl0 y"
	using ivl_subset_existence_ivl yt(3) by blast
	then have y0:"flow0 y 0 = y"
	using mem_existence_ivl_iv_defined(2) yt(3) by auto
	then have tpos: "t > 0" using yt(2) \<open>side1 \<inter> side2 = {}\<close>
	using yt(1) yt(4)
	by (metis closure_iff_nhds_not_empty less_eq_real_def order_refl that(2))
	from flow_to_path_path[OF yt(2) ex]
	have a1: "path fp" unfolding fp_def .
	have "y \<in> closure side2" using yt(1)
	by (simp add: assms closure_def)
	then have a2: "pathstart fp \<in> closure side2" unfolding fp_def using y0 by auto
	have a3:"pathfinish fp \<notin> side2" using yt(4) \<open>side1 \<inter> side2 = {}\<close>
	unfolding fp_def apply auto
	using closure_iff_nhds_not_empty that(2) by blast
	from subpath_to_frontier_strong[OF a1 a3]
	obtain u where u:"0 \<le> u" "u \<le> 1"
	"fp u \<notin> interior side2"
	"u = 0 \<or>
	(\<forall>x. 0 \<le> x \<and> x < 1 \<longrightarrow>
	subpath 0 u fp x \<in> interior side2) \<and> fp u \<in> closure side2" by blast
	have p1:"path_image (subpath 0 u fp) = flow0 y ` {0 .. u*t}"
	unfolding fp_def subpath0_flow_to_path using path_image_flow_to_path
	by (simp add: u(1) yt(2))
	have p2:"fp u = flow0 y (u*t)" unfolding fp_def flow_to_path_unfold by simp
	have inout:"interior side2 = side2" using \<open>open side2\<close>
	by (simp add: interior_eq)
	then have iemp: "side2 \<inter> path_image J = {}"
	using \<open>frontier side2 = path_image J\<close>
	by (metis frontier_disjoint_eq inf_sup_aci(1) interior_eq)
	have "u \<noteq> 0" using inout u(3) y0 p2 yt(1) by force
	then have c1:"u * t > 0" using tpos u y0 \<open>side1 \<inter> side2 = {}\<close>
	using frontier_disjoint_eq io(5) yt(1) zero_less_mult_iff by fastforce
	have uim:"fp u \<in> path_image J" using u \<open>u \<noteq> 0\<close>
	using \<open>frontier side2 = path_image J\<close>
	by (metis ComplI IntI closure_subset frontier_closures inout subsetD)
	have c2:"u * t \<le> t" using u(1-2) tpos by auto
	have"(flow_to_path y 0 (u * t) ` {0..<1} \<subseteq> side2)"
	using \<open>u \<noteq> 0\<close> u inout unfolding fp_def subpath0_flow_to_path by auto
	then have c3:"\<forall>s \<in>{0..<u*t}. flow0 y s \<in> side2" by auto
	have c4: "flow0 y (u*t) \<in> path_image J"
	using uim path_image_join_subset
	by (simp add: p2)
	have "flow0 y (ut) \<notin> path_image J1 \<or> flow0 y (ut) = flow0 x t1"
	proof clarsimp
	assume "flow0 y (u*t) \<in> path_image J1"
	then obtain s where s: "t1 \<le> s" "s \<le> t2" "flow0 x s = flow0 y (u*t)"
	using J1_def \<open>t1 \<le> t2\<close> by auto
	have "s = t1"
	proof (rule ccontr)
	assume "s \<noteq> t1"
	then have st1:"s > t1" using s(1) by linarith
	define sc where "sc = min (s-t1) (u*t)"
	have scd: "s-sc \<in> {t1..t2}" unfolding sc_def
	using c1 s(1) s(2) by auto
	then have *:"flow0 x (s-sc) \<in> path_image J1" unfolding J1_def path_image_flow_to_path[OF \<open>t1 \<le> t2\<close>]
	by blast
	have "flow0 x (s-sc) = flow0 (flow0 x s) (-sc)"
	by (smt exist atLeastAtMost_iff existence_ivl_trans' flow_trans s(1) s(2) scd subsetD)
	then have *:"flow0 (flow0 y (ut)) (-sc) \<in> path_image J1"
	using s(3) * by auto
	have b:"ut - sc \<in> {0..<ut}" unfolding sc_def by (simp add: st1 c1 s(1))
	then have "u*t - sc \<in> existence_ivl0 y"
	using c2 ex by auto
	then have "flow0 y (ut - sc) \<in> path_image J1" using *
	by (smt atLeastAtMost_iff diff_existence_ivl_trans ex flow_trans mult_left_le_one_le mult_nonneg_nonneg subset_eq u(1) u(2) yt(2))
	thus False using b c3 iemp piJ by blast
	qed
	thus "flow0 y (u * t) = flow0 x t1" using s by simp
	qed
	thus "\<exists>T>0. T \<le> t \<and> (\<forall>s\<in>{0..<T}. flow0 y s \<in> side2) \<and>
	flow0 y T \<in> {flow0 x t1--<flow0 x t2}"
	using c1 c2 c3 c4 unfolding piD
	by (metis DiffE UnE ends_in_segment(1) half_open_segment_closed_segmentI insertCI open_segment_def x1neqx2)
	qed
	have outside_in: "\<And>y t. y \<in> outer \<Longrightarrow>
	0 \<le> t \<Longrightarrow> t \<in> existence_ivl0 y \<Longrightarrow>
	flow0 y t \<in> closure inner \<Longrightarrow>
	\<exists>T. 0 < T \<and> T \<le> t \<and> (\<forall>s \<in>{0..<T}. flow0 y s \<in> outer) \<and>
	flow0 y T \<in> {flow0 x t1--<flow0 x t2}"
	by (rule swap_side; (rule io \| assumption))
	have inside_out: "\<And>y t. y \<in> inner \<Longrightarrow>
	0 \<le> t \<Longrightarrow> t \<in> existence_ivl0 y \<Longrightarrow>
	flow0 y t \<in> closure outer \<Longrightarrow>
	\<exists>T. 0 < T \<and> T \<le> t \<and> (\<forall>s \<in>{0..<T}. flow0 y s \<in> inner) \<and>
	flow0 y T \<in> {flow0 x t1--<flow0 x t2}"
	by (rule swap_side; (rule io2 io \| assumption))

	from leaves_transversal_segmentE[OF assms(1)]
	obtain d n where d: "d > (0::real)"
	and n: "n = a - b \<or> n = b - a"
	and d_ex: "\<And>x. x \<in> {a -- b} \<Longrightarrow> {-d..d} \<subseteq> existence_ivl0 x"
	and d_above: "\<And>x s. x \<in> {a -- b} \<Longrightarrow> 0 < s \<Longrightarrow> s \<le> d \<Longrightarrow> (flow0 x s - x) \<bullet> rot n > 0"
	and d_below: "\<And>x s. x \<in> {a -- b} \<Longrightarrow> -d \<le> s \<Longrightarrow> s < 0 \<Longrightarrow> (flow0 x s - x) \<bullet> rot n < 0"
	by blast

	have ortho: "(a - b) \<bullet> rot n = 0"
	using n by (auto simp: algebra_simps)

	(* These "rectangles" are either fully inside or fully outside
	\|-----------------------\|
	\| r1 \| (flow d)
	a --- (t1) --- rp --- (t2) --- b
	\| r2 \| (flow -d)
	\|-----------------------\|
	*)
	define r1 where "r1 = (\<lambda>(x, y). flow0 x y)`({flow0 x t1<--<b} \<times> {0<..<d}) "
	have r1a1: "path_connected {flow0 x t1 <--<b}" by simp
	have r1a2: "path_connected {0<..<d}" by simp
	have "{flow0 x t1<--<b} \<subseteq> {a--b}"
	by (simp add: open_closed_segment subset_oc_segment x1)
	then have r1a3: "y \<in> {flow0 x t1<--<b} \<Longrightarrow> {0<..<d} \<subseteq> existence_ivl0 y" for y
	using d_ex[of y]
	by force
	from flow0_path_connected[OF r1a1 r1a2 r1a3]
	have pcr1:"path_connected r1" unfolding r1_def by auto
	have pir1J1: "r1 \<inter> path_image J1 = {}"
	unfolding J1_def path_image_flow_to_path[OF \<open>t1 \<le> t2\<close>]
	proof (rule ccontr)
	assume "r1 \<inter> flow0 x ` {t1..t2} \<noteq> {}"
	then obtain xx tt ss where
	eq: "flow0 xx tt = flow0 x ss"
	and xx: "xx \<in> {flow0 x t1<--<b}"
	and ss: "t1 \<le> ss" "ss \<le> t2"
	and tt: "0 < tt" "tt < d"
	unfolding r1_def
	by force
	have "xx \<in> {a -- b}"
	using sub1b
	apply (rule set_mp)
	using xx by (simp add: open_closed_segment)
	then have [simp]: "xx \<in> X" using \<open>transversal_segment a b\<close> by (auto simp: transversal_segment_def)
	from ss have ss_ex: "ss \<in> existence_ivl0 x" using exist
	by auto
	from d_ex[OF \<open>xx \<in> {a -- b}\<close>] tt
	have tt_ex: "tt \<in> existence_ivl0 xx" by auto
	then have neg_tt_ex: "- tt \<in> existence_ivl0 (flow0 xx tt)"
	by (rule existence_ivl_reverse[simplified])
	from eq have "flow0 (flow0 xx tt) (-tt) = flow0 (flow0 x ss) (-tt)"
	by simp
	then have "xx = flow0 x (ss - tt)"
	apply (subst (asm) flow_trans[symmetric])
	apply (rule tt_ex)
	apply (rule neg_tt_ex)
	apply (subst (asm) flow_trans[symmetric])
	apply (rule ss_ex)
	apply (subst eq[symmetric])
	apply (rule neg_tt_ex)
	by simp
	moreover
	define e where "e = ss - t1"
	consider "e > tt" \| "e \<le> tt" by arith
	then show False
	proof cases
	case 1
	have "flow0 (flow0 x ss) (-tt) \<notin> {a<--<b}"
	apply (subst flow_trans[symmetric])
	apply fact
	subgoal using neg_tt_ex eq by simp
	apply (rule t1t2)
	using 1 ss tt
	unfolding e_def
	by auto
	moreover have "flow0 (flow0 x ss) (-tt) \<in> {a<--<b}"
	unfolding eq[symmetric] using tt_ex xx
	apply (subst flow_trans[symmetric])
	apply (auto simp add: neg_tt_ex)
	by (metis (no_types, opaque_lifting) sub1b subset_eq subset_open_segment)
	ultimately show ?thesis by simp
	next
	case 2
	have les: "0 \<le> tt - e" "tt - e \<le> d"
	using tt ss 2 e_def
	by auto
	have xxtte: "flow0 xx (tt - e) = flow0 x t1"
	apply (simp add: e_def)
	by (smt \<open>0 \<le> tt - e\<close> \<open>{- d..d} \<subseteq> existence_ivl0 xx\<close> atLeastAtMost_iff e_def eq
	local.existence_ivl_reverse local.existence_ivl_trans local.flow_trans ss(1) ss_ex subset_iff tt(2))
	show False
	proof (cases "tt = e")
	case True
	with xxtte have "xx = flow0 x t1"
	- by (simp add: )
	+ by simp
	with xx show ?thesis
	apply auto
	by (auto simp: open_segment_def)
	next
	case False
	with les have "0 < tt - e" by (simp)
	from d_above[OF \<open>xx \<in> {a -- b}\<close> this \<open>tt - e \<le> d\<close>]
	have "flow0 xx (tt - e) \<notin> {a -- b}"
	apply (simp add: in_closed_segment_iff_rot[OF \<open>a \<noteq> b\<close>]
	not_le )
	by (smt \<open>xx \<in> {a--b}\<close> inner_minus_right inner_rot_neg_move_base inner_rot_pos_move_base n rot_diff_commute)
	with xxtte show ?thesis
	using \<open>flow0 x t1 \<in> {a<--<flow0 x t2}\<close> suba2o by auto
	qed
	qed
	qed
	(* for sufficiently small d, the flow does not return to the line *)
	moreover
	have pir1J2: "r1 \<inter> path_image J2 = {}"
	proof -
	have "r1 \<subseteq> {x. (x - a) \<bullet> rot n > 0}"
	unfolding r1_def
	proof safe
	fix aa ba
	assume "aa \<in> {flow0 x t1<--<b}" "ba \<in> {0<..<d}"
	with sub1b show "0 < (flow0 aa ba - a) \<bullet> rot n"
	using segment_open_subset_closed[of "flow0 x t1" b]
	by (intro inner_pos_move_base[OF ortho d_above]) auto
	qed
	also have "\<dots> \<inter> {a -- b} = {}"
	using in_segment_inner_rot in_segment_inner_rot2 n by auto
	finally show ?thesis
	unfolding J2_def path_image_linepath
	using t12sub open_closed_segment
	by (force simp: closed_segment_commute)
	qed
	ultimately have pir1:"r1 \<inter> (path_image J) = {}" unfolding J_def
	by (metis disjoint_iff_not_equal not_in_path_image_join)

	define r2 where "r2 =(\<lambda>(x, y). flow0 x y)`({a <--< flow0 x t2} \<times> {-d<..<0})"
	have r2a1:"path_connected {a <--< flow0 x t2}" by simp
	have r2a2:"path_connected {-d<..<0}" by simp
	have "{a <--< flow0 x t2} \<subseteq> {a -- b}"
	by (meson ends_in_segment(1) open_closed_segment subset_co_segment subset_oc_segment t12sub)
	then have r2a3: "y \<in> {a <--< flow0 x t2} \<Longrightarrow> {-d<..<0} \<subseteq> existence_ivl0 y" for y
	using d_ex[of y]
	by force
	from flow0_path_connected[OF r2a1 r2a2 r2a3]
	have pcr2:"path_connected r2" unfolding r2_def by auto
	have pir2J2: "r2 \<inter> path_image J1 = {}"
	unfolding J1_def path_image_flow_to_path[OF \<open>t1 \<le> t2\<close>]
	proof (rule ccontr)
	assume "r2 \<inter> flow0 x ` {t1..t2} \<noteq> {}"
	then obtain xx tt ss where
	eq: "flow0 xx tt = flow0 x ss"
	and xx: "xx \<in> {a<--<flow0 x t2}"
	and ss: "t1 \<le> ss" "ss \<le> t2"
	and tt: "-d < tt" "tt < 0"
	unfolding r2_def
	by force
	have "xx \<in> {a -- b}"
	using suba2
	apply (rule set_mp)
	using xx by (simp add: open_closed_segment)
	then have [simp]: "xx \<in> X" using \<open>transversal_segment a b\<close> by (auto simp: transversal_segment_def)
	from ss have ss_ex: "ss \<in> existence_ivl0 x" using exist
	by auto
	from d_ex[OF \<open>xx \<in> {a -- b}\<close>] tt
	have tt_ex: "tt \<in> existence_ivl0 xx" by auto
	then have neg_tt_ex: "- tt \<in> existence_ivl0 (flow0 xx tt)"
	by (rule existence_ivl_reverse[simplified])
	from eq have "flow0 (flow0 xx tt) (-tt) = flow0 (flow0 x ss) (-tt)"
	by simp
	then have "xx = flow0 x (ss - tt)"
	apply (subst (asm) flow_trans[symmetric])
	apply (rule tt_ex)
	apply (rule neg_tt_ex)
	apply (subst (asm) flow_trans[symmetric])
	apply (rule ss_ex)
	apply (subst eq[symmetric])
	apply (rule neg_tt_ex)
	by simp
	moreover
	define e where "e = t2 - ss"
	consider "e > - tt" \| "e \<le> -tt" by arith
	then show False
	proof cases
	case 1
	have "flow0 (flow0 x ss) (-tt) \<notin> {a<--<b}"
	apply (subst flow_trans[symmetric])
	apply fact
	subgoal using neg_tt_ex eq by simp
	apply (rule t1t2)
	using 1 ss tt
	unfolding e_def
	by auto
	moreover have "flow0 (flow0 x ss) (-tt) \<in> {a<--<b}"
	unfolding eq[symmetric] using tt_ex xx
	apply (subst flow_trans[symmetric])
	apply (auto simp add: neg_tt_ex)
	by (metis (no_types, opaque_lifting) suba2 subset_eq subset_open_segment)
	ultimately show ?thesis by simp
	next
	case 2
	have les: "tt + e \<le> 0" "-d \<le> tt + e"
	using tt ss 2 e_def
	by auto
	have xxtte: "flow0 xx (tt + e) = flow0 x t2"
	apply (simp add: e_def)
	by (smt atLeastAtMost_iff calculation eq exist local.existence_ivl_trans' local.flow_trans neg_tt_ex ss_ex subset_iff \<open>t1 \<le> t2\<close>)
	show False
	proof (cases "tt=-e")
	case True
	with xxtte have "xx = flow0 x t2"
	- by (simp add: )
	+ by simp
	with xx show ?thesis
	apply auto
	by (auto simp: open_segment_def)
	next
	case False
	with les have "tt+e < 0" by simp
	from d_below[OF \<open>xx \<in> {a -- b}\<close> \<open>-d \<le> tt + e\<close> this]
	have "flow0 xx (tt + e) \<notin> {a -- b}"
	apply (simp add: in_closed_segment_iff_rot[OF \<open>a \<noteq> b\<close>]
	not_le )
	by (smt \<open>xx \<in> {a--b}\<close> inner_minus_right inner_rot_neg_move_base inner_rot_pos_move_base n rot_diff_commute)
	with xxtte show ?thesis
	using \<open>flow0 x t2 \<in> {a--b}\<close> by simp
	qed
	qed
	qed
	moreover
	have pir2J2: "r2 \<inter> path_image J2 = {}"
	proof -
	have "r2 \<subseteq> {x. (x - a) \<bullet> rot n < 0}"
	unfolding r2_def
	proof safe
	fix aa ba
	assume "aa \<in> {a<--<flow0 x t2}" "ba \<in> {-d<..<0}"
	with suba2 show "0 > (flow0 aa ba - a) \<bullet> rot n"
	using segment_open_subset_closed[of a "flow0 x t2"]
	by (intro inner_neg_move_base[OF ortho d_below]) auto
	qed
	also have "\<dots> \<inter> {a -- b} = {}"
	using in_segment_inner_rot in_segment_inner_rot2 n by auto
	finally show ?thesis
	unfolding J2_def path_image_linepath
	using t12sub open_closed_segment
	by (force simp: closed_segment_commute)
	qed
	ultimately have pir2:"r2 \<inter> (path_image J) = {}"
	unfolding J_def
	by (metis disjoint_iff_not_equal not_in_path_image_join)

	define rp where "rp = midpoint (flow0 x t1) (flow0 x t2)"
	have rpi: "rp \<in> {flow0 x t1<--<flow0 x t2}" unfolding rp_def
	by (simp add: x1neqx2)
	have "rp \<in> {a -- b}"
	using rpi suba2o subl by blast
	then have [simp]: "rp \<in> X"
	using \<open>{a--b} \<subseteq> X\<close> by blast

	(* The fundamental case distinction *)
	have *: "pathfinish J1 = flow0 x t2"
	"pathstart J1 = flow0 x t1"
	"rp \<in> {flow0 x t2<--<flow0 x t1}"
	using rpi
	by (auto simp: open_segment_commute J1_def)
	have "{y. 0 < (y - flow0 x t2) \<bullet> rot (flow0 x t2 - flow0 x t1)} = {y. 0 < (y - rp) \<bullet> rot (flow0 x t2 - flow0 x t1)}"
	by (smt Collect_cong in_open_segment_rotD inner_diff_left nrm_dot rpi)
	also have "... = {y. 0 > (y - rp) \<bullet> rot (flow0 x t1 - flow0 x t2)}"
	by (smt Collect_cong inner_minus_left nrm_reverse)
	also have " ... = {y. 0 > (y - rp) \<bullet> rot (a - b) }"
	by (metis rot_same_dir(2) x1 x2)
	finally have side1: "{y. 0 < (y - flow0 x t2) \<bullet> rot (flow0 x t2 - flow0 x t1)} = {y. 0 > (y - rp) \<bullet> rot (a - b) }"
	(is "_ = ?lower1") .
	have "{y. (y - flow0 x t2) \<bullet> rot (flow0 x t2 - flow0 x t1) < 0} = {y. (y - rp) \<bullet> rot (flow0 x t2 - flow0 x t1) < 0}"
	by (smt Collect_cong in_open_segment_rotD inner_diff_left nrm_dot rpi)
	also have "... = {y. (y - rp) \<bullet> rot (flow0 x t1 - flow0 x t2) > 0}"
	by (smt Collect_cong inner_minus_left nrm_reverse)
	also have " ... = {y. 0 < (y - rp) \<bullet> rot (a - b) }"
	by (metis rot_same_dir(1) x1 x2)
	finally have side2: "{y. (y - flow0 x t2) \<bullet> rot (flow0 x t2 - flow0 x t1) < 0} = {y. 0 < (y - rp) \<bullet> rot (a - b) }"
	(is "_ = ?upper1") .
	from linepath_ball_inside_outside[OF \<open>simple_path J\<close>[unfolded J_def J2_def] *,
	folded J2_def J_def, unfolded side1 side2]
	obtain e where e0: "0 < e"
	"ball rp e \<inter> path_image J1 = {}"
	"ball rp e \<inter> ?lower1 \<subseteq> inner \<and>
	ball rp e \<inter> ?upper1 \<subseteq> outer \<or>
	ball rp e \<inter> ?upper1 \<subseteq> inner \<and>
	ball rp e \<inter> ?lower1 \<subseteq> outer"
	by (auto simp: inner_def outer_def)

	let ?lower = "{y. 0 > (y - rp) \<bullet> rot n }"
	let ?upper = "{y. 0 < (y - rp) \<bullet> rot n }"
	have "?lower1 = {y. 0 < (y - rp) \<bullet> rot n } \<and> ?upper1 = {y. 0 > (y - rp) \<bullet> rot n } \<or>
	?lower1 = {y. 0 > (y - rp) \<bullet> rot n } \<and> ?upper1 = {y. 0 < (y - rp) \<bullet> rot n }"
	using n rot_diff_commute[of a b]
	by auto
	from this e0 have e: "0 < e"
	"ball rp e \<inter> path_image J1 = {}"
	"ball rp e \<inter> ?lower \<subseteq> inner \<and>
	ball rp e \<inter> ?upper \<subseteq> outer \<or>
	ball rp e \<inter> ?upper \<subseteq> inner \<and>
	ball rp e \<inter> ?lower \<subseteq> outer"
	by auto

	have "\<forall>\<^sub>F t in at_right 0. t < d"
	by (auto intro!: order_tendstoD \<open>0 < d\<close>)
	then have evr: "\<forall>\<^sub>F t in at_right 0. 0 < (flow0 rp t - rp) \<bullet> rot n"
	unfolding eventually_at_filter
	by eventually_elim (auto intro!: \<open>rp \<in> {a--b}\<close> d_above)
	have "\<forall>\<^sub>F t in at_left 0. t > -d"
	by (auto intro!: order_tendstoD \<open>0 < d\<close>)
	then have evl: "\<forall>\<^sub>F t in at_left 0. 0 > (flow0 rp t - rp) \<bullet> rot n"
	unfolding eventually_at_filter
	by eventually_elim (auto intro!: \<open>rp \<in> {a--b}\<close> d_below)
	have "\<forall>\<^sub>F t in at 0. flow0 rp t \<in> ball rp e"
	unfolding mem_ball
	apply (subst dist_commute)
	apply (rule tendstoD)
	by (auto intro!: tendsto_eq_intros \<open>0 < e\<close>)
	then have evl2: "(\<forall>\<^sub>F t in at_left 0. flow0 rp t \<in> ball rp e)"
	and evr2: "(\<forall>\<^sub>F t in at_right 0. flow0 rp t \<in> ball rp e)"
	unfolding eventually_at_split by auto
	have evl3: "(\<forall>\<^sub>F t in at_left 0. t > -d)"
	and evr3: "(\<forall>\<^sub>F t in at_right 0. t < d)"
	by (auto intro!: order_tendstoD \<open>0 < d\<close>)
	have evl4: "(\<forall>\<^sub>F t in at_left 0. t < 0)"
	and evr4: "(\<forall>\<^sub>F t in at_right 0. t > 0)"
	by (auto simp: eventually_at_filter)
	from evl evl2 evl3 evl4
	have "\<forall>\<^sub>F t in at_left 0. (flow0 rp t - rp) \<bullet> rot n < 0 \<and> flow0 rp t \<in> ball rp e \<and> t > -d \<and> t < 0"
	by eventually_elim auto
	from eventually_happens[OF this]
	obtain dl where dl: "(flow0 rp dl - rp) \<bullet> rot n < 0" "flow0 rp dl \<in> ball rp e" "- d < dl" "dl < 0"
	by auto
	from evr evr2 evr3 evr4
	have "\<forall>\<^sub>F t in at_right 0. (flow0 rp t - rp) \<bullet> rot n > 0 \<and> flow0 rp t \<in> ball rp e \<and> t < d \<and> t > 0"
	by eventually_elim auto
	from eventually_happens[OF this]
	obtain dr where dr: "(flow0 rp dr - rp) \<bullet> rot n > 0" "flow0 rp dr \<in> ball rp e" "d > dr" "dr > 0"
	by auto

	have "rp \<in> {flow0 x t1<--<b}" using rpi subr by auto
	then have rpr1:"flow0 rp (dr) \<in> r1" unfolding r1_def using \<open>d > dr\<close> \<open>dr > 0\<close>
	by auto
	have "rp \<in> {a<--<flow0 x t2}" using rpi subl by auto
	then have rpr2:"flow0 rp (dl) \<in> r2" unfolding r2_def using \<open>-d < dl\<close> \<open>dl < 0\<close>
	by auto

	from e(3) dr dl
	have "flow0 rp (dr) \<in> outer \<and> flow0 rp (dl) \<in> inner \<or> flow0 rp (dr) \<in> inner \<and> flow0 rp (dl) \<in> outer"
	by auto
	moreover {
	assume "flow0 rp dr \<in> outer" "flow0 rp dl \<in> inner"
	then have
	r1o: "r1 \<inter> outer \<noteq> {}" and
	r2i: "r2 \<inter> inner \<noteq> {}" using rpr1 rpr2 by auto
	from path_connected_not_frontier_subset[OF pcr1 r1o]
	have "r1 \<subseteq> outer" using pir1 by (simp add: io(12))
	from path_connected_not_frontier_subset[OF pcr2 r2i]
	have "r2 \<subseteq> inner" using pir2 by (simp add: io(11))
	have "(\<lambda>(x, y). flow0 x y)`({flow0 x t2} \<times> {0<..<d}) \<subseteq> r1" unfolding r1_def
	by (auto intro!:image_mono simp add: x2)
	then have *:"\<And>t. 0 < t \<Longrightarrow> t < d \<Longrightarrow> flow0 (flow0 x t2) t \<in> outer"
	by (smt \<open>r1 \<subseteq> outer\<close> greaterThanLessThan_iff mem_Sigma_iff pair_imageI r1_def subset_eq x2)

	then have t2o: "\<And>t. 0 < t \<Longrightarrow> t < d \<Longrightarrow> flow0 x (t2 + t) \<in> outer"
	using r1a3[OF x2] exist flow_trans
	by (metis (no_types, opaque_lifting) closed_segment_commute ends_in_segment(1) local.existence_ivl_trans' local.flow_undefined0 real_Icc_closed_segment subset_eq \<open>t1 \<le> t2\<close>)

	(* Construct a sequence of times converging to these points in r2 \<subseteq> inner *)
	have inner: "{a <--< flow0 x t2} \<subseteq> closure inner"
	proof (rule subsetI)
	fix y
	assume y: "y \<in> {a <--< flow0 x t2}"
	have [simp]: "y \<in> X"
	using y suba12_open suba2o \<open>{a -- b} \<subseteq> X\<close>
	by auto
	have "(\<forall>n. flow0 y (- d / real (Suc (Suc n))) \<in> inner)"
	using y
	using suba12_open \<open>0 < d\<close> suba2o \<open>{a -- b} \<subseteq> X\<close>
	by (auto intro!: set_mp[OF \<open>r2 \<subseteq> inner\<close>] image_eqI[where x="(y, -d/Suc (Suc n))" for n]
	simp: r2_def divide_simps)
	moreover
	have d_over_0: "(\<lambda>s. - d / real (Suc (Suc s))) \<longlonglongrightarrow> 0"
	by (rule real_tendsto_divide_at_top)
	(auto intro!: filterlim_tendsto_add_at_top filterlim_real_sequentially)
	have "(\<lambda>n. flow0 y (- d / real (Suc (Suc n)))) \<longlonglongrightarrow> y"
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule d_over_0)
	by auto
	ultimately show "y \<in> closure inner"
	unfolding closure_sequential
	by (intro exI[where x="\<lambda>n. flow0 y (-d/Suc (Suc n))"]) (rule conjI)
	qed
	then have "{a <--< flow0 x t1} \<subseteq> closure inner"
	using suba12_open by blast
	then have "{flow0 x t1 -- flow0 x t2} \<subseteq> closure inner"
	by (metis (no_types, lifting) closure_closure closure_mono closure_open_segment dual_order.trans inner subl x1neqx2)
	have outer:"\<And>t. t > t2 \<Longrightarrow> t \<in> existence_ivl0 x \<Longrightarrow> flow0 x t \<in> outer"
	proof (rule ccontr)
	fix t
	assume t: "t > t2" "t \<in> existence_ivl0 x" "flow0 x t \<notin> outer"
	have "0 \<le> t- (t2+d)" using t2o t by smt
	then have a2:"0 \<le> t - (t2+dr)" using d \<open>0 < dr\<close> \<open>dr < d\<close> by linarith
	have t2d2_ex: "t2 + dr \<in> existence_ivl0 x"
	using \<open>t1 \<le> t2\<close> exist d_ex[of "flow0 x t2"] \<open>flow0 x t2 \<in> {a--b}\<close> \<open>0 < d\<close> \<open>0 < dr\<close> \<open>dr < d\<close>
	by (intro existence_ivl_trans) auto
	then have a3: "t - (t2 + dr) \<in> existence_ivl0 (flow0 x (t2 + dr))"
	using t(2)
	by (intro diff_existence_ivl_trans) auto
	then have "flow0 (flow0 x (t2 + dr)) (t - (t2 + dr)) = flow0 x t"
	by (subst flow_trans[symmetric]) (auto simp: t2d2_ex)
	moreover have "flow0 x t \<in> closure inner" using t(3) io
	by (metis ComplI Un_iff closure_Un_frontier)
	ultimately have a4: "flow0 (flow0 x (t2 + dr)) (t - (t2 + dr)) \<in> closure inner" by auto
	have a1: "flow0 x (t2+dr) \<in> outer"
	by (simp add: d t2o \<open>0 < dr\<close> \<open>dr < d\<close>)
	from outside_in[OF a1 a2 a3 a4]
	obtain T where T: "T > 0" "T \<le> t - (t2 + dr)"
	"(\<forall>s\<in>{0..<T}. flow0 (flow0 x (t2 + dr)) s \<in> outer)"
	"flow0 (flow0 x (t2 + dr)) T \<in> {flow0 x t1 --< flow0 x t2}" by blast
	define y where "y = flow0 (flow0 x (t2 + dr)) T"
	have "y \<in> {a <--< flow0 x t2}" unfolding y_def using T(4)
	using subl2 by blast
	then have "(\<lambda>(x, y). flow0 x y)`({y} \<times> {-d<..<0}) \<subseteq> r2" unfolding r2_def
	by (auto intro!:image_mono)
	then have *:"\<And>t. -d < t \<Longrightarrow> t < 0 \<Longrightarrow> flow0 y t \<in> r2"
	by (simp add: pair_imageI subsetD)
	have "max (-T/2) dl < 0" using d T \<open>0 > dl\<close> \<open>dl > -d\<close> by auto
	moreover have "-d < max (-T/2) dl" using d T \<open>0 > dl\<close> \<open>dl > -d\<close> by auto
	ultimately have inner: "flow0 y (max (-T/2) dl) \<in> inner" using * \<open>r2 \<subseteq> inner\<close> by blast
	have "0\<le>(T+(max (-T/2) dl))" using T(1) by linarith
	moreover have "(T+(max (-T/2) dl)) < T" using T(1) d \<open>0 > dl\<close> \<open>dl > -d\<close> by linarith
	ultimately have outer: " flow0 (flow0 x (t2 + dr)) (T+(max (-T/2) dl)) \<in> outer"
	using T by auto
	have T_ex: "T \<in> existence_ivl0 (flow0 x (t2 + dr))"
	apply (subst flow_trans)
	using exist \<open>t1 \<le> t2\<close>
	using d_ex[of "flow0 x t2"] \<open>flow0 x t2 \<in> {a -- b}\<close> \<open>d > 0\<close> T \<open>0 < dr\<close> \<open>dr < d\<close>
	- apply (auto simp: )
	+ apply auto
	apply (rule set_rev_mp[where A="{0 .. t - (t2 + dr)}"], force)
	apply (rule ivl_subset_existence_ivl)
	apply (rule existence_ivl_trans')
	apply (rule existence_ivl_trans')
	by (auto simp: t)
	have T_ex2: "dr + T \<in> existence_ivl0 (flow0 x t2)"
	by (smt T_ex ends_in_segment(2) exist local.existence_ivl_trans local.existence_ivl_trans' real_Icc_closed_segment subset_eq t2d2_ex \<open>t1 \<le> t2\<close>)
	thus False using T \<open>t1 \<le> t2\<close> exist
	by (smt T_ex diff_existence_ivl_trans disjoint_iff_not_equal inner io(9) local.flow_trans local.flow_undefined0 outer y_def)
	qed
	have "closure inner \<inter> outer = {}"
	by (simp add: inf_sup_aci(1) io(5) io(9) open_Int_closure_eq_empty)
	then have "flow0 x t \<notin> {a<--<flow0 x t2}"
	using \<open>t > t2\<close> \<open>t \<in> existence_ivl0 x\<close> inner outer by blast
	}
	moreover {
	assume "flow0 rp dr \<in> inner" "flow0 rp dl \<in> outer"
	then have
	r1i: "r1 \<inter> inner \<noteq> {}" and
	r2o: "r2 \<inter> outer \<noteq> {}" using rpr1 rpr2 by auto
	from path_connected_not_frontier_subset[OF pcr1 r1i]
	have "r1 \<subseteq> inner" using pir1 by (simp add: io(11))
	from path_connected_not_frontier_subset[OF pcr2 r2o]
	have "r2 \<subseteq> outer" using pir2 by (simp add: io(12))

	have "(\<lambda>(x, y). flow0 x y)`({flow0 x t2} \<times> {0<..<d}) \<subseteq> r1" unfolding r1_def
	by (auto intro!:image_mono simp add: x2)
	then have
	*:"\<And>t. 0 < t \<Longrightarrow> t < d \<Longrightarrow> flow0 (flow0 x t2) t \<in> inner"
	by (smt \<open>r1 \<subseteq> inner\<close> greaterThanLessThan_iff mem_Sigma_iff pair_imageI r1_def subset_eq x2)

	then have t2o: "\<And>t. 0 < t \<Longrightarrow> t < d \<Longrightarrow> flow0 x (t2 + t) \<in> inner"
	using r1a3[OF x2] exist flow_trans
	by (metis (no_types, opaque_lifting) closed_segment_commute ends_in_segment(1) local.existence_ivl_trans' local.flow_undefined0 real_Icc_closed_segment subset_eq \<open>t1 \<le> t2\<close>)

	(* Construct a sequence of times converging to these points in r2 \<subseteq> outer *)
	have outer: "{a <--< flow0 x t2} \<subseteq> closure outer"
	proof (rule subsetI)
	fix y
	assume y: "y \<in> {a <--< flow0 x t2}"
	have [simp]: "y \<in> X"
	using y suba12_open suba2o \<open>{a -- b} \<subseteq> X\<close>
	by auto
	have "(\<forall>n. flow0 y (- d / real (Suc (Suc n))) \<in> outer)"
	using y
	using suba12_open \<open>0 < d\<close> suba2o \<open>{a -- b} \<subseteq> X\<close>
	by (auto intro!: set_mp[OF \<open>r2 \<subseteq> outer\<close>] image_eqI[where x="(y, -d/Suc (Suc n))" for n]
	simp: r2_def divide_simps)
	moreover
	have d_over_0: "(\<lambda>s. - d / real (Suc (Suc s))) \<longlonglongrightarrow> 0"
	by (rule real_tendsto_divide_at_top)
	(auto intro!: filterlim_tendsto_add_at_top filterlim_real_sequentially)
	have "(\<lambda>n. flow0 y (- d / real (Suc (Suc n)))) \<longlonglongrightarrow> y"
	apply (rule tendsto_eq_intros)
	apply (rule tendsto_intros)
	apply (rule d_over_0)
	by auto
	ultimately show "y \<in> closure outer"
	unfolding closure_sequential
	by (intro exI[where x="\<lambda>n. flow0 y (-d/Suc (Suc n))"]) (rule conjI)
	qed
	then have "{a <--< flow0 x t1} \<subseteq> closure outer"
	using suba12_open by blast
	then have "{flow0 x t1 -- flow0 x t2} \<subseteq> closure outer"
	by (metis (no_types, lifting) closure_closure closure_mono closure_open_segment dual_order.trans outer subl x1neqx2)

	have inner:"\<And>t. t > t2 \<Longrightarrow> t \<in> existence_ivl0 x \<Longrightarrow> flow0 x t \<in> inner"
	proof (rule ccontr)
	fix t
	assume t: "t > t2" "t \<in> existence_ivl0 x" "flow0 x t \<notin> inner"
	have "0 \<le> t- (t2+d)" using t2o t by smt
	then have a2:"0 \<le> t - (t2+dr)" using d \<open>0 < dr\<close> \<open>dr < d\<close> by linarith
	have t2d2_ex: "t2 + dr \<in> existence_ivl0 x"
	using \<open>t1 \<le> t2\<close> exist d_ex[of "flow0 x t2"] \<open>flow0 x t2 \<in> {a--b}\<close> \<open>0 < d\<close> \<open>0 < dr\<close> \<open>dr < d\<close>
	by (intro existence_ivl_trans) auto
	then have a3: "t - (t2 + dr) \<in> existence_ivl0 (flow0 x (t2 + dr))"
	using t(2)
	by (intro diff_existence_ivl_trans) auto
	then have "flow0 (flow0 x (t2 + dr)) (t - (t2 + dr)) = flow0 x t"
	by (subst flow_trans[symmetric]) (auto simp: t2d2_ex)
	moreover have "flow0 x t \<in> closure outer" using t(3) io
	by (metis ComplI Un_iff closure_Un_frontier)
	ultimately have a4: "flow0 (flow0 x (t2 + dr)) (t - (t2 + dr)) \<in> closure outer" by auto
	have a1: "flow0 x (t2+dr) \<in> inner"
	by (simp add: d t2o \<open>0 < dr\<close> \<open>dr < d\<close>)
	from inside_out[OF a1 a2 a3 a4]
	obtain T where T: "T > 0" "T \<le> t - (t2 + dr)"
	"(\<forall>s\<in>{0..<T}. flow0 (flow0 x (t2 + dr)) s \<in> inner)"
	"flow0 (flow0 x (t2 + dr)) T \<in> {flow0 x t1 --< flow0 x t2}" by blast
	define y where "y = flow0 (flow0 x (t2 + dr)) T"
	have "y \<in> {a <--< flow0 x t2}" unfolding y_def using T(4)
	using subl2 by blast
	then have "(\<lambda>(x, y). flow0 x y)`({y} \<times> {-d<..<0}) \<subseteq> r2" unfolding r2_def
	by (auto intro!:image_mono)
	then have *:"\<And>t. -d < t \<Longrightarrow> t < 0 \<Longrightarrow> flow0 y t \<in> r2"
	by (simp add: pair_imageI subsetD)
	have "max (-T/2) dl < 0" using d T \<open>0 > dl\<close> \<open>dl > -d\<close> by auto
	moreover have "-d < max (-T/2) dl" using d T \<open>0 > dl\<close> \<open>dl > -d\<close> by auto
	ultimately have outer: "flow0 y (max (-T/2) dl) \<in> outer" using * \<open>r2 \<subseteq> outer\<close> by blast
	have "0\<le>(T+(max (-T/2) dl))" using T(1) by linarith
	moreover have "(T+(max (-T/2) dl)) < T" using T(1) d \<open>0 > dl\<close> \<open>dl > -d\<close> by linarith
	ultimately have inner: " flow0 (flow0 x (t2 + dr)) (T+(max (-T/2) dl)) \<in> inner"
	using T by auto
	have T_ex: "T \<in> existence_ivl0 (flow0 x (t2 + dr))"
	apply (subst flow_trans)
	using exist \<open>t1 \<le> t2\<close>
	using d_ex[of "flow0 x t2"] \<open>flow0 x t2 \<in> {a -- b}\<close> \<open>d > 0\<close> T \<open>0 < dr\<close> \<open>dr < d\<close>
	- apply (auto simp: )
	+ apply auto
	apply (rule set_rev_mp[where A="{0 .. t - (t2 + dr)}"], force)
	apply (rule ivl_subset_existence_ivl)
	apply (rule existence_ivl_trans')
	apply (rule existence_ivl_trans')
	by (auto simp: t)
	have T_ex2: "dr + T \<in> existence_ivl0 (flow0 x t2)"
	by (smt T_ex ends_in_segment(2) exist local.existence_ivl_trans local.existence_ivl_trans' real_Icc_closed_segment subset_eq t2d2_ex \<open>t1 \<le> t2\<close>)
	thus False using T \<open>t1 \<le> t2\<close> exist
	by (smt T_ex diff_existence_ivl_trans disjoint_iff_not_equal inner io(9) local.flow_trans local.flow_undefined0 outer y_def)
	qed
	have "closure outer \<inter> inner = {}"
	by (metis inf_sup_aci(1) io(2) io2(1) open_Int_closure_eq_empty)
	then have "flow0 x t \<notin> {a<--<flow0 x t2}"
	using \<open>t > t2\<close> \<open>t \<in> existence_ivl0 x\<close> inner outer by blast
	}
	ultimately show
	"flow0 x t \<notin> {a<--<flow0 x t2}" by auto
	qed

	lemma open_segment_trichotomy:
	fixes x y a b::'a
	assumes x:"x \<in> {a<--<b}"
	assumes y:"y \<in> {a<--<b}"
	shows "x = y \<or> y \<in> {x<--<b} \<or> y \<in> {a<--<x}"
	proof -
	from Un_open_segment[OF y]
	have "{a<--<y} \<union> {y} \<union> {y<--<b} = {a<--<b}" .
	then have "x \<in> {a<--<y} \<or> x = y \<or> x \<in> {y <--<b}" using x by blast
	moreover {
	assume "x \<in> {a<--<y}"
	then have "y \<in> {x<--<b}" using open_segment_subsegment
	using open_segment_commute y by blast
	}
	moreover {
	assume "x \<in> {y<--<b}"
	from open_segment_subsegment[OF y this]
	have "y \<in> {a<--<x}" .
	}
	ultimately show ?thesis by blast
	qed

	sublocale rev: c1_on_open_R2 "-f" "-f'" rewrites "-(-f) = f" and "-(-f') = f'"
	by unfold_locales (auto simp: dim2)

	lemma rev_transversal_segment: "rev.transversal_segment a b = transversal_segment a b"
	by (auto simp: transversal_segment_def rev.transversal_segment_def)

	lemma flow0_transversal_segment_monotone_step_reverse:
	assumes "transversal_segment a b"
	assumes "t1 \<le> t2"
	assumes "{t1..t2} \<subseteq> existence_ivl0 x"
	assumes x1: "flow0 x t1 \<in> {a<--<b}"
	assumes x2: "flow0 x t2 \<in> {a<--<flow0 x t1}"
	assumes "\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}"
	assumes "t < t1" "t \<in> existence_ivl0 x"
	shows "flow0 x t \<notin> {a<--<flow0 x t1}"
	proof -
	note exist = \<open>{t1..t2} \<subseteq> existence_ivl0 x\<close>
	note t1t2 = \<open>\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}\<close>
	from \<open>transversal_segment a b\<close> have [simp]: "a \<noteq> b" by (simp add: transversal_segment_def)
	from x1 obtain i1 where i1: "flow0 x t1 = line a b i1" "0 < i1" "i1 < 1"
	by (auto simp: in_open_segment_iff_line)
	from x2 obtain i2 where i2: "flow0 x t2 = line a b i2" "0 < i2" "i2 < i1"
	by (auto simp: i1 open_segment_line_iff)

	have t2_exist[simp]: "t2 \<in> existence_ivl0 x"
	using \<open>t1 \<le> t2\<close> exist by auto
	have t2_mem: "flow0 x t2 \<in> {a<--<b}"
	and x1_mem: "flow0 x t1 \<in> {flow0 x t2<--<b}"
	using i1 i2
	by (auto simp: line_in_subsegment line_line1)

	have transversal': "rev.transversal_segment a b"
	using \<open>transversal_segment a b\<close> unfolding rev_transversal_segment .
	have time': "0 \<le> t2 - t1" using \<open>t1 \<le> t2\<close> by simp
	have [simp, intro]: "flow0 x t2 \<in> X"
	using exist \<open>t1 \<le> t2\<close>
	by auto
	have exivl': "{0..t2 - t1} \<subseteq> rev.existence_ivl0 (flow0 x t2)"
	using exist \<open>t1 \<le> t2\<close>
	by (force simp add: rev_existence_ivl_eq0 intro!: existence_ivl_trans')
	have step': "rev.flow0 (flow0 x t2) (t2-t) \<notin> {a<--<rev.flow0 (flow0 x t2) (t2 - t1)}"
	apply (rule rev.flow0_transversal_segment_monotone_step[OF transversal' time' exivl'])
	using exist \<open>t1 \<le> t2\<close> x1 x2 t2_mem x1_mem t1t2 \<open>t < t1\<close> \<open>t \<in> existence_ivl0 x\<close>
	apply (auto simp: rev_existence_ivl_eq0 rev_eq_flow existence_ivl_trans' flow_trans[symmetric])
	by (subst (asm) flow_trans[symmetric]) (auto intro!: existence_ivl_trans')
	then show ?thesis
	unfolding rev_eq_flow
	using \<open>t1 \<le> t2\<close> exist \<open>t < t1\<close> \<open>t \<in> existence_ivl0 x\<close>
	by (auto simp: flow_trans[symmetric] existence_ivl_trans')
	qed

	lemma flow0_transversal_segment_monotone_step_reverse2:
	assumes transversal: "transversal_segment a b"
	assumes time: "t1 \<le> t2"
	assumes exist: "{t1..t2} \<subseteq> existence_ivl0 x"
	assumes t1: "flow0 x t1 \<in> {a<--<b}"
	assumes t2: "flow0 x t2 \<in> {flow0 x t1<--<b}"
	assumes t1t2: "\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}"
	assumes t: "t < t1" "t \<in> existence_ivl0 x"
	shows "flow0 x t \<notin> {flow0 x t1<--<b}"
	using flow0_transversal_segment_monotone_step_reverse[of b a, OF _ time exist, of t]
	assms
	by (auto simp: open_segment_commute transversal_segment_commute)

	lemma flow0_transversal_segment_monotone_step2:
	assumes transversal: "transversal_segment a b"
	assumes time: "t1 \<le> t2"
	assumes exist: "{t1..t2} \<subseteq> existence_ivl0 x"
	assumes t1: "flow0 x t1 \<in> {a<--<b}"
	assumes t2: "flow0 x t2 \<in> {a<--<flow0 x t1}"
	assumes t1t2: "\<And>t. t \<in> {t1<..<t2} \<Longrightarrow> flow0 x t \<notin> {a<--<b}"
	shows "\<And>t. t > t2 \<Longrightarrow> t \<in> existence_ivl0 x \<Longrightarrow> flow0 x t \<notin> {flow0 x t2<--<b}"
	using flow0_transversal_segment_monotone_step[of b a, OF _ time exist]
	assms
	by (auto simp: transversal_segment_commute open_segment_commute)

	lemma flow0_transversal_segment_monotone:
	assumes "transversal_segment a b"
	assumes "t1 \<le> t2"
	assumes "{t1..t2} \<subseteq> existence_ivl0 x"
	assumes x1: "flow0 x t1 \<in> {a<--<b}"
	assumes x2: "flow0 x t2 \<in> {flow0 x t1<--<b}"
	assumes "t > t2" "t \<in> existence_ivl0 x"
	shows "flow0 x t \<notin> {a<--<flow0 x t2}"
	proof -
	note exist = \<open>{t1..t2} \<subseteq> existence_ivl0 x\<close>
	note t = \<open>t > t2\<close> \<open>t \<in> existence_ivl0 x\<close>
	have x1neqx2: "flow0 x t1 \<noteq> flow0 x t2"
	using open_segment_def x2 by force
	then have t1neqt2: "t1 \<noteq> t2" by auto
	with \<open>t1 \<le> t2\<close> have "t1 < t2" by simp

	from \<open>transversal_segment a b\<close> have [simp]: "a \<noteq> b" by (simp add: transversal_segment_def)
	from x1 obtain i1 where i1: "flow0 x t1 = line a b i1" "0 < i1" "i1 < 1"
	by (auto simp: in_open_segment_iff_line)
	from x2 i1 obtain i2 where i2: "flow0 x t2 = line a b i2" "i1 < i2" "i2 < 1"
	by (auto simp: line_open_segment_iff)
	have t2_in: "flow0 x t2 \<in> {a<--<b}"
	using i1 i2
	by simp

	let ?T = "{s \<in> {t1..t2}. flow0 x s \<in> {a--b}}"
	let ?T' = "{s \<in> {t1..<t2}. flow0 x s \<in> {a<--<b}}"
	from flow_transversal_segment_finite_intersections[OF \<open>transversal_segment a b\<close> \<open>t1 \<le> t2\<close> exist]
	have "finite ?T" .
	then have "finite ?T'" by (rule finite_subset[rotated]) (auto simp: open_closed_segment)
	have "?T' \<noteq> {}"
	by (auto intro!: exI[where x=t1] \<open>t1 < t2\<close> x1)
	note tm_defined = \<open>finite ?T'\<close> \<open>?T' \<noteq> {}\<close>
	define tm where "tm = Max ?T'"
	have "tm \<in> ?T'"
	unfolding tm_def
	using tm_defined by (rule Max_in)
	have tm_in: "flow0 x tm \<in> {a<--<b}"
	using \<open>tm \<in> ?T'\<close>
	by auto
	have tm: "t1 \<le> tm" "tm < t2" "tm \<le> t2"
	using \<open>tm \<in> ?T'\<close> by auto
	have tm_Max: "t \<le> tm" if "t \<in> ?T'" for t
	unfolding tm_def
	using tm_defined(1) that
	by (rule Max_ge)

	have tm_exclude: "flow0 x t \<notin> {a<--<b}" if "t \<in> {tm<..<t2}" for t
	using \<open>tm \<in> ?T'\<close> tm_Max that
	by auto (meson approximation_preproc_push_neg(2) dual_order.strict_trans2 le_cases)
	have "{tm..t2} \<subseteq> existence_ivl0 x"
	using exist tm by auto

	from open_segment_trichotomy[OF tm_in t2_in]
	consider
	"flow0 x t2 \<in> {flow0 x tm<--<b}" \|
	"flow0 x t2 \<in> {a<--<flow0 x tm}" \|
	"flow0 x tm = flow0 x t2"
	by blast
	then show "flow0 x t \<notin> {a<--<flow0 x t2}"
	proof cases
	case 1
	from flow0_transversal_segment_monotone_step[OF \<open>transversal_segment a b\<close> \<open>tm \<le> t2\<close>
	\<open>{tm..t2} \<subseteq> existence_ivl0 x\<close> tm_in 1 tm_exclude t]
	show ?thesis .
	next
	case 2
	have "t1 \<noteq> tm"
	using 2 x2 i1 i2
	by (auto simp: line_in_subsegment line_in_subsegment2)
	then have "t1 < tm" using \<open>t1 \<le> tm\<close> by simp
	from flow0_transversal_segment_monotone_step_reverse[OF \<open>transversal_segment a b\<close> \<open>tm \<le> t2\<close>
	\<open>{tm..t2} \<subseteq> existence_ivl0 x\<close> tm_in 2 tm_exclude \<open>t1 < tm\<close>] exist \<open>t1 \<le> t2\<close>
	have "flow0 x t1 \<notin> {a<--<flow0 x tm}" by auto
	then have False
	using x1 x2 2 i1 i2
	apply (auto simp: line_in_subsegment line_in_subsegment2)
	by (smt greaterThanLessThan_iff in_open_segment_iff_line line_in_subsegment2 tm_in)
	then show ?thesis by simp
	next
	case 3
	have "t1 \<noteq> tm"
	using 3 x2
	by (auto simp: open_segment_def)
	then have "t1 < tm" using \<open>t1 \<le> tm\<close> by simp
	have "range (flow0 x) = flow0 x ` {tm..t2}"
	apply (rule recurrence_time_restricts_compact_flow'[OF \<open>tm < t2\<close> _ _ 3])
	using exist \<open>t1 \<le> t2\<close> \<open>t1 < tm\<close> \<open>tm < t2\<close>
	by auto
	also have "\<dots> = flow0 x ` (insert t2 {tm<..<t2})"
	using \<open>tm \<le> t2\<close> 3
	- apply (auto simp: )
	+ apply auto
	by (smt greaterThanLessThan_iff image_eqI)
	finally have "flow0 x t1 \<in> flow0 x ` (insert t2 {tm<..<t2})"
	by auto
	then have "flow0 x t1 \<in> flow0 x ` {tm<..<t2}" using x1neqx2
	by auto
	moreover have "\<dots> \<inter> {a<--<b} = {}"
	using tm_exclude
	by auto
	ultimately have False using x1 by auto
	then show ?thesis by blast
	qed
	qed

	subsection \<open>Straightening\<close>

	text \<open> This lemma uses the implicit function theorem \<close>
	lemma cross_time_continuous:
	assumes "transversal_segment a b"
	assumes "x \<in> {a<--<b}"
	assumes "e > 0"
	obtains d t where "d > 0" "continuous_on (ball x d) t"
	"\<And>y. y \<in> ball x d \<Longrightarrow> flow0 y (t y) \<in> {a<--<b}"
	"\<And>y. y \<in> ball x d \<Longrightarrow> \<bar>t y\<bar> < e"
	"continuous_on (ball x d) t"
	"t x = 0"
	proof -
	have "x \<in> X" using assms segment_open_subset_closed[of a b]
	by (auto simp: transversal_segment_def)
	have "a \<noteq> b" using assms by auto
	define s where "s x = (x - a) \<bullet> rot (b - a)" for x
	have "s x = 0"
	unfolding s_def
	by (subst in_segment_inner_rot) (auto intro!: assms open_closed_segment)
	have Ds: "(s has_derivative blinfun_inner_left (rot (b - a))) (at x)"
	(is "(_ has_derivative blinfun_apply (?Ds x)) _")
	for x
	unfolding s_def
	by (auto intro!: derivative_eq_intros)
	have Dsc: "isCont ?Ds x" by (auto intro!: continuous_intros)
	have nz: "?Ds x (f x) \<noteq> 0"
	using assms apply auto
	unfolding transversal_segment_def
	by (smt inner_minus_left nrm_reverse open_closed_segment)

	from flow_implicit_function_at[OF \<open>x \<in> X\<close>, of s, OF \<open>s x = 0\<close> Ds Dsc nz \<open>e > 0\<close>]
	obtain t d1 where "0 < d1"
	and t0: "t x = 0"
	and d1: "(\<And>y. y \<in> cball x d1 \<Longrightarrow> s (flow0 y (t y)) = 0)"
	"(\<And>y. y \<in> cball x d1 \<Longrightarrow> \<bar>t y\<bar> < e)"
	"(\<And>y. y \<in> cball x d1 \<Longrightarrow> t y \<in> existence_ivl0 y)"
	and tc: "continuous_on (cball x d1) t"
	and t': "(t has_derivative
	(- blinfun_inner_left (rot (b - a)) /\<^sub>R (blinfun_inner_left (rot (b - a))) (f x)))
	(at x)"
	by metis
	from tc
	have "t \<midarrow>x\<rightarrow> 0"
	using \<open>0 < d1\<close>
	by (auto simp: continuous_on_def at_within_interior t0 dest!: bspec[where x=x])
	then have ftc: "((\<lambda>y. flow0 y (t y)) \<longlongrightarrow> x) (at x)"
	by (auto intro!: tendsto_eq_intros simp: \<open>x \<in> X\<close>)



	define e2 where "e2 = min (dist a x) (dist b x)"
	have "e2 > 0"
	using assms
	by (auto simp: e2_def open_segment_def)

	from tendstoD[OF ftc this] have "\<forall>\<^sub>F y in at x. dist (flow0 y (t y)) x < e2" .
	moreover
	let ?S = "{x. a \<bullet> (b - a) < x \<bullet> (b - a) \<and> x \<bullet> (b - a) < b \<bullet> (b - a)}"
	have "open ?S" "x \<in> ?S"
	using \<open>x \<in> {a<--<b}\<close>
	by (auto simp add: open_segment_line_hyperplanes \<open>a \<noteq> b\<close>
	intro!: open_Collect_conj open_halfspace_component_gt open_halfspace_component_lt)
	from topological_tendstoD[OF ftc this] have "\<forall>\<^sub>F y in at x. flow0 y (t y) \<in> ?S" .
	ultimately
	have "\<forall>\<^sub>F y in at x. flow0 y (t y) \<in> ball x e2 \<inter> ?S" by eventually_elim (auto simp: dist_commute)
	then obtain d2 where "0 < d2" and "\<And>y. x \<noteq> y \<Longrightarrow> dist y x < d2 \<Longrightarrow> flow0 y (t y) \<in> ball x e2 \<inter> ?S"
	by (force simp: eventually_at)
	then have d2: "dist y x < d2 \<Longrightarrow> flow0 y (t y) \<in> ball x e2 \<inter> ?S" for y
	using \<open>0 < e2\<close> \<open>x \<in> X\<close> t0 \<open>x \<in> ?S\<close>
	by (cases "y = x") auto

	define d where "d = min d1 d2"
	have "d > 0" using \<open>0 < d1\<close> \<open>0 < d2\<close> by (simp add: d_def)
	moreover have "continuous_on (ball x d) t"
	by (auto intro!:continuous_on_subset[OF tc] simp add: d_def)
	moreover
	have "ball x e2 \<inter> ?S \<inter> {x. s x = 0} \<subseteq> {a<--<b}"
	by (auto simp add: in_open_segment_iff_rot \<open>a \<noteq> b\<close>) (auto simp: s_def e2_def in_segment)
	then have "\<And>y. y \<in> ball x d \<Longrightarrow> flow0 y (t y) \<in> {a<--<b}"
	apply (rule set_mp)
	using d1 d2 \<open>0 < d2\<close>
	by (auto simp: d_def e2_def dist_commute)
	moreover have "\<And>y. y \<in> ball x d \<Longrightarrow> \<bar>t y\<bar> < e"
	using d1 by (auto simp: d_def)
	moreover have "continuous_on (ball x d) t"
	using tc by (rule continuous_on_subset) (auto simp: d_def)
	moreover have "t x = 0" by (simp add: t0)
	ultimately show ?thesis ..
	qed

	lemma \<omega>_limit_crossings:
	assumes "transversal_segment a b"
	assumes pos_ex: "{0..} \<subseteq> existence_ivl0 x"
	assumes "\<omega>_limit_point x p"
	assumes "p \<in> {a<--<b}"
	obtains s where
	"s \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity>"
	"(flow0 x \<circ> s) \<longlonglongrightarrow> p"
	"\<forall>\<^sub>F n in sequentially. flow0 x (s n) \<in> {a<--<b} \<and> s n \<in> existence_ivl0 x"
	proof -
	from assms have "p \<in> X" by (auto simp: transversal_segment_def open_closed_segment)
	from assms(3)
	obtain t where
	"t \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity>" "(flow0 x \<circ> t) \<longlonglongrightarrow> p"
	by (auto simp: \<omega>_limit_point_def)
	note t = \<open>t \<longlonglongrightarrow>\<^bsub>\<^esub> \<infinity>\<close> \<open>(flow0 x \<circ> t) \<longlonglongrightarrow> p\<close>
	note [tendsto_intros] = t(2)
	from cross_time_continuous[OF assms(1,4) zero_less_one\<comment> \<open>TODO ??\<close>]
	obtain \<tau> \<delta>
	where "0 < \<delta>" "continuous_on (ball p \<delta>) \<tau>"
	"\<tau> p = 0" "(\<And>y. y \<in> ball p \<delta> \<Longrightarrow> \<bar>\<tau> y\<bar> < 1)"
	"(\<And>y. y \<in> ball p \<delta> \<Longrightarrow> flow0 y (\<tau> y) \<in> {a<--<b})"
	by metis
	note \<tau> =
	\<open>(\<And>y. y \<in> ball p \<delta> \<Longrightarrow> flow0 y (\<tau> y) \<in> {a<--<b})\<close>
	\<open>(\<And>y. y \<in> ball p \<delta> \<Longrightarrow> \<bar>\<tau> y\<bar> < 1)\<close>
	\<open>continuous_on (ball p \<delta>) \<tau>\<close> \<open>\<tau> p = 0\<close>
	define s where "s n = t n + \<tau> (flow0 x (t n))" for n
	have ev_in_ball: "\<forall>\<^sub>F n in at_top. flow0 x (t n) \<in> ball p \<delta>"
	- apply (simp add: )
	+ apply simp
	apply (subst dist_commute)
	apply (rule tendstoD)
	apply (rule t[unfolded o_def])
	apply (rule \<open>0 < \<delta>\<close>)
	done
	have "filterlim s at_top sequentially"
	proof (rule filterlim_at_top_mono)
	show "filterlim (\<lambda>n. -1 + t n) at_top sequentially"
	by (rule filterlim_tendsto_add_at_top) (auto intro!: filterlim_tendsto_add_at_top t)
	from ev_in_ball show "\<forall>\<^sub>F x in sequentially. -1 + t x \<le> s x"
	apply eventually_elim
	using \<tau>
	by (force simp : s_def)
	qed
	moreover
	have \<tau>_cont: "\<tau> \<midarrow>p\<rightarrow> \<tau> p"
	using \<tau>(3) \<open>0 < \<delta>\<close>
	by (auto simp: continuous_on_def at_within_ball dest!: bspec[where x=p])
	note [tendsto_intros] = tendsto_compose_at[OF _ this, simplified]
	have ev1: "\<forall>\<^sub>F n in sequentially. t n > 1"
	using filterlim_at_top_dense t(1) by auto
	then have ev_eq: "\<forall>\<^sub>F n in sequentially. flow0 ((flow0 x o t) n) ((\<tau> o (flow0 x o t)) n) = (flow0 x o s) n"
	using ev_in_ball
	apply (eventually_elim)
	apply (drule \<tau>(2))
	unfolding o_def
	apply (subst flow_trans[symmetric])
	using pos_ex
	apply (auto simp: s_def)
	apply (rule existence_ivl_trans')
	by auto
	then
	have "\<forall>\<^sub>F n in sequentially.
	(flow0 x o s) n = flow0 ((flow0 x o t) n) ((\<tau> o (flow0 x o t)) n)"
	by (simp add: eventually_mono)
	from \<open>(flow0 x \<circ> t) \<longlonglongrightarrow> p\<close> and \<open>\<tau> \<midarrow>p\<rightarrow> \<tau> p\<close>
	have
	"(\<lambda>n. flow0 ((flow0 x \<circ> t) n) ((\<tau> \<circ> (flow0 x \<circ> t)) n))
	\<longlonglongrightarrow>
	flow0 p (\<tau> p)"
	using \<open>\<tau> p = 0\<close> \<tau>_cont \<open>p \<in> X\<close>
	by (intro tendsto_eq_intros) auto
	then have "(flow0 x o s) \<longlonglongrightarrow> flow0 p (\<tau> p)"
	using ev_eq by (rule Lim_transform_eventually)
	then have "(flow0 x o s) \<longlonglongrightarrow> p"
	using \<open>p \<in> X\<close> \<open>\<tau> p = 0\<close>
	by simp
	moreover
	{
	have "\<forall>\<^sub>F n in sequentially. flow0 x (s n) \<in> {a<--<b}"
	using ev_eq ev_in_ball
	apply eventually_elim
	apply (drule sym)
	apply simp
	apply (rule \<tau>) by simp
	moreover have "\<forall>\<^sub>F n in sequentially. s n \<in> existence_ivl0 x"
	using ev_in_ball ev1
	apply (eventually_elim)
	apply (drule \<tau>(2))
	using pos_ex
	by (auto simp: s_def)
	ultimately have "\<forall>\<^sub>F n in sequentially. flow0 x (s n) \<in> {a<--<b} \<and> s n \<in> existence_ivl0 x"
	by eventually_elim auto
	}
	ultimately show ?thesis ..
	qed

	(* Obvious but frequently used step *)
	lemma filterlim_at_top_tendstoE:
	assumes "e > 0"
	assumes "filterlim s at_top sequentially"
	assumes "(flow0 x \<circ> s) \<longlonglongrightarrow> u"
	assumes "\<forall>\<^sub>F n in sequentially. P (s n)"
	obtains m where "m > b" "P m" "dist (flow0 x m) u < e"
	proof -
	from assms(2) have "\<forall>\<^sub>F n in sequentially. b < s n"
	by (simp add: filterlim_at_top_dense)
	moreover have "\<forall>\<^sub>F n in sequentially. norm ((flow0 x \<circ> s) n - u) < e"
	using assms(3)[THEN tendstoD, OF assms(1)] by (simp add: dist_norm)
	moreover note assms(4)
	ultimately have "\<forall>\<^sub>F n in sequentially. b < s n \<and> norm ((flow0 x \<circ> s) n - u) < e \<and> P (s n)"
	by eventually_elim auto
	then obtain m where "m > b" "P m" "dist (flow0 x m) u < e"
	by (auto simp add: eventually_sequentially dist_norm)
	then show ?thesis ..
	qed

	lemma open_segment_separate_left:
	fixes u v x a b::'a
	assumes u:"u \<in> {a <--< b}"
	assumes v:"v \<in> {u <--< b}"
	assumes x: "dist x u < dist u v" "x \<in> {a <--< b}"
	shows "x \<in> {a <--< v}"
	proof -
	have "v \<noteq> x"
	by (smt dist_commute x(1))
	moreover have "x \<notin> {v<--<b}"
	by (smt dist_commute dist_in_open_segment open_segment_subsegment v x(1))
	moreover have "v \<in> {a<--<b}" using v
	by (metis ends_in_segment(1) segment_open_subset_closed subset_eq subset_segment(4) u)
	ultimately show ?thesis using open_segment_trichotomy[OF _ x(2)]
	by blast
	qed

	lemma open_segment_separate_right:
	fixes u v x a b::'a
	assumes u:"u \<in> {a <--< b}"
	assumes v:"v \<in> {a <--< u}"
	assumes x: "dist x u < dist u v" "x \<in> {a <--< b}"
	shows "x \<in> {v <--< b}"
	proof -
	have "v \<noteq> x"
	by (smt dist_commute x(1))
	moreover have "x \<notin> {a<--<v}"
	by (smt dist_commute dist_in_open_segment open_segment_commute open_segment_subsegment v x(1))
	moreover have "v \<in> {a<--<b}" using v
	by (metis ends_in_segment(1) segment_open_subset_closed subset_eq subset_segment(4) u)
	ultimately show ?thesis using open_segment_trichotomy[OF _ x(2)]
	by blast
	qed

	lemma no_two_\<omega>_limit_points:
	assumes transversal: "transversal_segment a b"
	assumes ex_pos: "{0..} \<subseteq> existence_ivl0 x"
	assumes u: "\<omega>_limit_point x u" "u \<in> {a<--<b}"
	assumes v: "\<omega>_limit_point x v" "v \<in> {a<--<b}"
	assumes uv: "v \<in> {u<--<b}"
	shows False
	proof -
	have unotv: "u \<noteq> v" using uv
	using dist_in_open_segment by blast
	define duv where "duv = dist u v / 2"
	have duv: "duv > 0" unfolding duv_def using unotv by simp
	from \<omega>_limit_crossings[OF transversal ex_pos u]
	obtain su where su: "filterlim su at_top sequentially"
	"(flow0 x \<circ> su) \<longlonglongrightarrow> u"
	"\<forall>\<^sub>F n in sequentially. flow0 x (su n) \<in> {a<--<b} \<and> su n \<in> existence_ivl0 x" by blast
	from \<omega>_limit_crossings[OF transversal ex_pos v]
	obtain sv where sv: "filterlim sv at_top sequentially"
	"(flow0 x \<circ> sv) \<longlonglongrightarrow> v"
	"\<forall>\<^sub>F n in sequentially. flow0 x (sv n) \<in> {a<--<b} \<and> sv n \<in> existence_ivl0 x" by blast
	from filterlim_at_top_tendstoE[OF duv su]
	obtain su1 where su1:"su1 > 0" "flow0 x su1 \<in> {a<--<b}"
	"su1 \<in> existence_ivl0 x" "dist (flow0 x su1) u < duv" by auto
	from filterlim_at_top_tendstoE[OF duv sv, of su1]
	obtain su2 where su2:"su2 > su1" "flow0 x su2 \<in> {a<--<b}"
	"su2 \<in> existence_ivl0 x" "dist (flow0 x su2) v < duv" by auto
	from filterlim_at_top_tendstoE[OF duv su, of su2]
	obtain su3 where su3:"su3 > su2" "flow0 x su3 \<in> {a<--<b}"
	"su3 \<in> existence_ivl0 x" "dist (flow0 x su3) u < duv" by auto
	have *: "su1 \<le> su2" "{su1..su2} \<subseteq> existence_ivl0 x" using su1 su2
	apply linarith
	by (metis atLeastatMost_empty_iff empty_iff mvar.closed_segment_subset_domain real_Icc_closed_segment su1(3) su2(3) subset_eq)

	(* by construction *)
	have d1: "dist (flow0 x su1) v \<ge> (dist u v)/2" using su1(4) duv unfolding duv_def
	by (smt dist_triangle_half_r)
	have "dist (flow0 x su1) u < dist u v" using su1(4) duv unfolding duv_def by linarith
	from open_segment_separate_left[OF u(2) uv this su1(2)]
	have su1l:"flow0 x su1 \<in> {a<--<v}" .
	have "dist (flow0 x su2) v < dist v (flow0 x su1)" using d1
	by (smt dist_commute duv_def su2(4))
	from open_segment_separate_right[OF v(2) su1l this su2(2)]
	have su2l:"flow0 x su2 \<in> {flow0 x su1<--<b}" .
	then have su2ll:"flow0 x su2 \<in> {u<--<b}"
	by (smt dist_commute dist_pos_lt duv_def open_segment_subsegment pos_half_less open_segment_separate_right su2(2) su2(4) u(2) uv v(2) unotv)

	have "dist (flow0 x su2) u \<ge> (dist u v)/2" using su2(4) duv unfolding duv_def
	by (smt dist_triangle_half_r)
	then have "dist (flow0 x su3) u < dist u (flow0 x su2)"
	by (smt dist_commute duv_def su3(4))
	from open_segment_separate_left[OF u(2) su2ll this su3(2)]
	have su3l:"flow0 x su3 \<in> {a<--<flow0 x su2}" .

	from flow0_transversal_segment_monotone[OF transversal * su1(2) su2l su3(1) su3(3)]
	have "flow0 x su3 \<notin> {a <--<flow0 x su2}" .
	thus False using su3l by auto
	qed


	subsection \<open>Unique Intersection\<close>

	text \<open>Perko Section 3.7 Remark 2\<close>
	lemma unique_transversal_segment_intersection:
	assumes "transversal_segment a b"
	assumes "{0..} \<subseteq> existence_ivl0 x"
	assumes "u \<in> \<omega>_limit_set x \<inter> {a<--<b}"
	shows "\<omega>_limit_set x \<inter> {a<--<b} = {u}"
	proof (rule ccontr)
	assume "\<omega>_limit_set x \<inter> {a<--<b} \<noteq> {u}"
	then
	obtain v where uv: "u \<noteq> v"
	and v: "\<omega>_limit_point x v" "v \<in> {a<--<b}" using assms unfolding \<omega>_limit_set_def
	by fastforce
	have u:"\<omega>_limit_point x u" "u \<in> {a<--<b}" using assms unfolding \<omega>_limit_set_def
	by auto
	show False using no_two_\<omega>_limit_points[OF \<open>transversal_segment a b\<close>]
	by (smt dist_commute dist_in_open_segment open_segment_trichotomy u uv v assms)
	qed

	text \<open>Adapted from Perko Section 3.7 Lemma 4 (+ Chicone )\<close>
	lemma periodic_imp_\<omega>_limit_set:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	assumes "periodic_orbit y"
	"flow0 y ` UNIV \<subseteq> \<omega>_limit_set x"
	shows "flow0 y `UNIV = \<omega>_limit_set x"
	proof (rule ccontr)
	note y = \<open>periodic_orbit y\<close> \<open>flow0 y ` UNIV \<subseteq> \<omega>_limit_set x\<close>
	from trapped_sol_right[OF assms(1-4)]
	have ex_pos: "{0..} \<subseteq> existence_ivl0 x" by blast
	assume "flow0 y `UNIV \<noteq> \<omega>_limit_set x"
	obtain p where p: "p \<in> \<omega>_limit_set x" "p \<notin> flow0 y ` UNIV"
	using y(2) apply auto
	using \<open>range (flow0 y) \<noteq> \<omega>_limit_set x\<close> by blast
	from \<omega>_limit_set_in_compact_connected[OF assms(1-4)] have
	wcon: "connected (\<omega>_limit_set x)" .
	from \<omega>_limit_set_invariant have
	"invariant (\<omega>_limit_set x)" .
	from \<omega>_limit_set_in_compact_compact[OF assms(1-4)] have
	"compact (\<omega>_limit_set x)" .
	then have sc: "seq_compact (\<omega>_limit_set x)"
	using compact_imp_seq_compact by blast
	have y1:"closed (flow0 y ` UNIV)"
	using closed_orbit_\<omega>_limit_set periodic_orbit_def \<omega>_limit_set_closed y(1) by auto
	have y2: "flow0 y ` UNIV \<noteq> {}" by simp
	let ?py = "infdist p (range (flow0 y))"
	have "0 < ?py"
	using y1 y2 p(2)
	by (rule infdist_pos_not_in_closed)
	have "\<forall>n::nat. \<exists>z. z \<in> \<omega>_limit_set x - flow0 y ` UNIV \<and>
	infdist z (flow0 y ` UNIV) < ?py/2^n"
	proof (rule ccontr)
	assume " \<not> (\<forall>n. \<exists>z. z \<in> \<omega>_limit_set x - range (flow0 y) \<and>
	infdist z (range (flow0 y))
	< infdist p (range (flow0 y)) / 2 ^ n) "
	then obtain n where n: "(\<forall>z \<in> \<omega>_limit_set x - range (flow0 y).
	infdist z (range (flow0 y)) \<ge> ?py / 2 ^ n)"
	using not_less by blast
	define A where "A = flow0 y ` UNIV"
	define B where "B = {z. infdist z (range (flow0 y)) \<ge> ?py / 2 ^ n}"
	have Ac:"closed A" unfolding A_def using y1 by auto
	have Bc:"closed B" unfolding B_def using infdist_closed by auto
	have "A \<inter> B = {}"
	proof (rule ccontr)
	assume "A \<inter> B \<noteq> {}"
	then obtain q where q: "q \<in> A" "q \<in> B" by blast
	have qz:"infdist q (range(flow0 y)) = 0" using q(1) unfolding A_def
	by simp
	note \<open>0 < ?py\<close>
	moreover have "2 ^ n > (0::real)" by auto
	ultimately have "infdist p (range (flow0 y)) / 2 ^ n > (0::real)"
	by simp
	then have qnz: "infdist q(range (flow0 y)) > 0" using q(2) unfolding B_def
	by auto
	show False using qz qnz by auto
	qed
	then have a1:"A \<inter> B \<inter> \<omega>_limit_set x = {}" by auto
	have "\<omega>_limit_set x - range(flow0 y) \<subseteq> B" using n B_def by blast
	then have a2:"\<omega>_limit_set x \<subseteq> A \<union> B" using A_def by auto
	from connected_closedD[OF wcon a1 a2 Ac Bc]
	have "A \<inter> \<omega>_limit_set x = {} \<or> B \<inter> \<omega>_limit_set x = {}" .
	moreover {
	assume "A \<inter> \<omega>_limit_set x = {}"
	then have False unfolding A_def using y(2) by blast
	}
	moreover {
	assume "B \<inter> \<omega>_limit_set x = {}"
	then have False unfolding B_def using p
	using A_def B_def a2 by blast
	}
	ultimately show False by blast
	qed
	then obtain s where s: "\<forall>n::nat. (s::nat \<Rightarrow> _) n \<in> \<omega>_limit_set x - flow0 y ` UNIV \<and>
	infdist (s n) (flow0 y ` UNIV) < ?py/2^n"
	by metis
	then have "\<forall>n. s n \<in> \<omega>_limit_set x" by blast
	from seq_compactE[OF sc this]
	obtain l r where lr: "l \<in> \<omega>_limit_set x" "strict_mono r" "(s \<circ> r) \<longlonglongrightarrow> l" by blast
	have "\<And>n. infdist (s n) (range (flow0 y)) \<le> ?py / 2 ^ n" using s
	using less_eq_real_def by blast
	then have "\<And>n. norm(infdist (s n) (range (flow0 y))) \<le> ?py / 2 ^ n"
	by (auto simp add: infdist_nonneg)
	from LIMSEQ_norm_0_pow[OF \<open>0 < ?py\<close> _ this]
	have "((\<lambda>z. infdist z (flow0 y ` UNIV)) \<circ> s) \<longlonglongrightarrow> 0"
	by (auto simp add:o_def)
	from LIMSEQ_subseq_LIMSEQ[OF this lr(2)]
	have "((\<lambda>z. infdist z (flow0 y ` UNIV)) \<circ> (s \<circ> r)) \<longlonglongrightarrow> 0" by (simp add: o_assoc)
	moreover have "((\<lambda>z. infdist z (flow0 y ` UNIV)) \<circ> (s \<circ> r)) \<longlonglongrightarrow> infdist l (flow0 y ` UNIV)"
	by (auto intro!: tendsto_eq_intros tendsto_compose_at[OF lr(3)])
	ultimately have "infdist l (flow0 y `UNIV) = 0" using LIMSEQ_unique by auto
	then have lu: "l \<in> flow0 y ` UNIV" using in_closed_iff_infdist_zero[OF y1 y2] by auto
	then have l1:"l \<in> X"
	using closed_orbit_global_existence periodic_orbit_def y(1) by auto
	(* TODO: factor out as periodic_orbitE *)
	have l2:"f l \<noteq> 0"
	by (smt \<open>l \<in> X\<close> \<open>l \<in> range (flow0 y)\<close> closed_orbit_global_existence fixed_point_imp_closed_orbit_period_zero(2) fixpoint_sol(2) image_iff local.flows_reverse periodic_orbit_def y(1))
	from transversal_segment_exists[OF l1 l2]
	obtain a b where ab: "transversal_segment a b" "l \<in> {a<--<b}" by blast
	then have "l \<in> \<omega>_limit_set x \<inter> {a<--<b}" using lr by auto
	from unique_transversal_segment_intersection[OF ab(1) ex_pos this]
	have luniq: "\<omega>_limit_set x \<inter> {a<--<b} = {l} " .
	from cross_time_continuous[OF ab, of 1]
	obtain d t where dt: "0 < d"
	"(\<And>y. y \<in> ball l d \<Longrightarrow> flow0 y (t y) \<in> {a<--<b})"
	"(\<And>y. y \<in> ball l d \<Longrightarrow> \<bar>t y\<bar> < 1)"
	"continuous_on (ball l d) t" "t l = 0"
	by auto
	obtain n where "(s \<circ> r) n \<in> ball l d" using lr(3) dt(1) unfolding LIMSEQ_iff_nz
	by (metis dist_commute mem_ball order_refl)
	then have "flow0 ((s \<circ> r) n) (t ((s \<circ> r) n )) \<in> {a<--<b}" using dt by auto
	moreover have sr: "(s \<circ> r) n \<in> \<omega>_limit_set x" "(s \<circ> r) n \<notin> flow0 y ` UNIV"
	using s by auto
	moreover have "flow0 ((s \<circ> r) n) (t ((s \<circ> r) n )) \<in> \<omega>_limit_set x"
	using \<open>invariant (\<omega>_limit_set x)\<close> calculation unfolding invariant_def trapped_def
	by (smt \<omega>_limit_set_in_compact_subset \<open>invariant (\<omega>_limit_set x)\<close> assms(1-4) invariant_def order_trans range_eqI subsetD trapped_iff_on_existence_ivl0 trapped_sol)
	ultimately have "flow0 ((s \<circ> r) n) (t ((s \<circ> r) n )) \<in> \<omega>_limit_set x \<inter> {a<--<b}" by auto
	from unique_transversal_segment_intersection[OF ab(1) ex_pos this]
	have "flow0 ((s \<circ> r) n) (t ((s \<circ> r) n )) = l" using luniq by auto
	then have "((s \<circ> r) n) = flow0 l (-(t ((s \<circ> r) n ))) "
	by (smt UNIV_I \<open>(s \<circ> r) n \<in> \<omega>_limit_set x\<close> flows_reverse \<omega>_limit_set_in_compact_existence assms(1-4))
	thus False using sr(2) lu
	\<open>flow0 ((s \<circ> r) n) (t ((s \<circ> r) n)) = l\<close> \<open>flow0 ((s \<circ> r) n) (t ((s \<circ> r) n)) \<in> \<omega>_limit_set x\<close>
	closed_orbit_global_existence image_iff local.flow_trans periodic_orbit_def \<omega>_limit_set_in_compact_existence range_eqI assms y(1)
	by smt
	qed

	end context c1_on_open_R2 begin

	lemma \<alpha>_limit_crossings:
	assumes "transversal_segment a b"
	assumes pos_ex: "{..0} \<subseteq> existence_ivl0 x"
	assumes "\<alpha>_limit_point x p"
	assumes "p \<in> {a<--<b}"
	obtains s where
	"s \<longlonglongrightarrow>\<^bsub>\<^esub> -\<infinity>"
	"(flow0 x \<circ> s) \<longlonglongrightarrow> p"
	"\<forall>\<^sub>F n in sequentially.
	flow0 x (s n) \<in> {a<--<b} \<and>
	s n \<in> existence_ivl0 x"
	proof -
	from pos_ex have "{0..} \<subseteq> uminus ` existence_ivl0 x" by force
	from rev.\<omega>_limit_crossings[unfolded rev_transversal_segment rev_existence_ivl_eq0 rev_eq_flow
	\<alpha>_limit_point_eq_rev[symmetric], OF assms(1) this assms(3,4)]
	obtain s where "filterlim s at_top sequentially" "((\<lambda>t. flow0 x (- t)) \<circ> s) \<longlonglongrightarrow> p"
	"\<forall>\<^sub>F n in sequentially. flow0 x (- s n) \<in> {a<--<b} \<and> s n \<in> uminus ` existence_ivl0 x" .
	then have "filterlim (-s) at_bot sequentially"
	"(flow0 x \<circ> (-s)) \<longlonglongrightarrow> p"
	"\<forall>\<^sub>F n in sequentially. flow0 x ((-s) n) \<in> {a<--<b} \<and> (-s) n \<in> existence_ivl0 x"
	by (auto simp: fun_Compl_def o_def filterlim_uminus_at_top)
	then show ?thesis ..
	qed

	text \<open>If a positive limit point has a regular point in its positive limit set then it is periodic\<close>
	lemma \<omega>_limit_point_\<omega>_limit_set_regular_imp_periodic:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	assumes y: "y \<in> \<omega>_limit_set x" "f y \<noteq> 0"
	assumes z: "z \<in> \<omega>_limit_set y \<union> \<alpha>_limit_set y" "f z \<noteq> 0"
	shows "periodic_orbit y \<and> flow0 y ` UNIV = \<omega>_limit_set x"
	proof -
	from trapped_sol_right[OF assms(1-4)] have ex_pos: "{0..} \<subseteq> existence_ivl0 x" by blast
	from \<omega>_limit_set_in_compact_existence[OF assms(1-4) y(1)]
	have yex: "existence_ivl0 y = UNIV" .
	from \<omega>_limit_set_invariant
	have "invariant (\<omega>_limit_set x)" .
	then have yinv: "flow0 y ` UNIV \<subseteq> \<omega>_limit_set x" using yex unfolding invariant_def
	using trapped_iff_on_existence_ivl0 y(1) by blast

	have zy: "\<omega>_limit_point y z \<or> \<alpha>_limit_point y z"
	using z unfolding \<omega>_limit_set_def \<alpha>_limit_set_def by auto

	from \<omega>_limit_set_in_compact_\<omega>_limit_set_contained[OF assms(1-4)]
	\<omega>_limit_set_in_compact_\<alpha>_limit_set_contained[OF assms(1-4)]
	have zx:"z \<in> \<omega>_limit_set x" using zy y
	using z(1) by blast
	then have "z \<in> X"
	by (metis UNIV_I local.existence_ivl_initial_time_iff \<omega>_limit_set_in_compact_existence assms(1-4))
	from transversal_segment_exists[OF this z(2)]
	obtain a b where ab: "transversal_segment a b" "z \<in> {a<--<b}" by blast

	from zy
	obtain t1 t2 where t1: "flow0 y t1 \<in> {a<--<b}" and t2: "flow0 y t2 \<in> {a<--<b}" and "t1 \<noteq> t2"
	proof
	assume zy: "\<omega>_limit_point y z"
	from \<omega>_limit_crossings[OF ab(1) _ zy ab(2), unfolded yex]
	obtain s where s: "filterlim s at_top sequentially"
	"(flow0 y \<circ> s) \<longlonglongrightarrow> z"
	"\<forall>\<^sub>F n in sequentially. flow0 y (s n) \<in> {a<--<b}"
	by auto
	from eventually_happens[OF this(3)] obtain t1 where t1: "flow0 y t1 \<in> {a<--<b}" by auto
	have "\<forall>\<^sub>F n in sequentially. s n > t1"
	using filterlim_at_top_dense s(1) by auto
	with s(3) have "\<forall>\<^sub>F n in sequentially. flow0 y (s n) \<in> {a<--<b} \<and> s n > t1"
	by eventually_elim simp
	from eventually_happens[OF this] obtain t2 where t2: "flow0 y t2 \<in> {a<--<b}" and "t1 \<noteq> t2"
	by auto
	from t1 this show ?thesis ..
	next
	assume zy: "\<alpha>_limit_point y z"
	from \<alpha>_limit_crossings[OF ab(1) _ zy ab(2), unfolded yex]
	obtain s where s: "filterlim s at_bot sequentially"
	"(flow0 y \<circ> s) \<longlonglongrightarrow> z"
	"\<forall>\<^sub>F n in sequentially. flow0 y (s n) \<in> {a<--<b}"
	by auto
	from eventually_happens[OF this(3)] obtain t1 where t1: "flow0 y t1 \<in> {a<--<b}" by auto
	have "\<forall>\<^sub>F n in sequentially. s n < t1"
	using filterlim_at_bot_dense s(1) by auto
	with s(3) have "\<forall>\<^sub>F n in sequentially. flow0 y (s n) \<in> {a<--<b} \<and> s n < t1"
	by eventually_elim simp
	from eventually_happens[OF this] obtain t2 where t2: "flow0 y t2 \<in> {a<--<b}" and "t1 \<noteq> t2"
	by auto
	from t1 this show ?thesis ..
	qed
	have "flow0 y t1 \<in> \<omega>_limit_set x \<inter> {a<--<b}" using t1 UNIV_I yinv by auto
	moreover have "flow0 y t2 \<in> \<omega>_limit_set x \<inter> {a<--<b}" using t2 UNIV_I yinv by auto
	ultimately have feq:"flow0 y t1 = flow0 y t2"
	using unique_transversal_segment_intersection[OF \<open>transversal_segment a b\<close> ex_pos]
	by blast
	have "t1 \<noteq> t2" "t1 \<in> existence_ivl0 y" "t2 \<in> existence_ivl0 y" using \<open>t1 \<noteq> t2\<close>
	apply blast
	apply (simp add: yex)
	by (simp add: yex)
	from periodic_orbitI[OF this feq y(2)]
	have 1: "periodic_orbit y" .
	from periodic_imp_\<omega>_limit_set[OF assms(1-4) this yinv]
	have 2: "flow0 y` UNIV = \<omega>_limit_set x" .
	show ?thesis using 1 2 by auto
	qed

	subsection \<open>Poincare Bendixson Theorems\<close>
	text \<open>Perko Section 3.7 Theorem 1\<close>
	theorem poincare_bendixson:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	assumes "0 \<notin> f ` (\<omega>_limit_set x)"
	obtains y where "periodic_orbit y"
	"flow0 y ` UNIV = \<omega>_limit_set x"
	proof -
	note f = \<open>0 \<notin> f ` (\<omega>_limit_set x)\<close>
	from \<omega>_limit_set_in_compact_nonempty[OF assms(1-4)]
	obtain y where y: "y \<in> \<omega>_limit_set x" by fastforce
	from \<omega>_limit_set_in_compact_existence[OF assms(1-4) y]
	have yex: "existence_ivl0 y = UNIV" .
	from \<omega>_limit_set_invariant
	have "invariant (\<omega>_limit_set x)" .
	then have yinv: "flow0 y ` UNIV \<subseteq> \<omega>_limit_set x" using yex unfolding invariant_def
	using trapped_iff_on_existence_ivl0 y by blast
	from \<omega>_limit_set_in_compact_subset[OF assms(1-4)]
	have "\<omega>_limit_set x \<subseteq> K" .
	then have "flow0 y ` UNIV \<subseteq> K" using yinv by auto
	then have yk:"trapped_forward y K"
	by (simp add: image_subsetI range_subsetD trapped_forward_def)
	have "y \<in> X"
	by (simp add: local.mem_existence_ivl_iv_defined(2) yex)

	from \<omega>_limit_set_in_compact_nonempty[OF assms(1-2) this _]
	obtain z where z: "z \<in> \<omega>_limit_set y" using yk by blast
	from \<omega>_limit_set_in_compact_\<omega>_limit_set_contained[OF assms(1-4)]
	have zx:"z \<in> \<omega>_limit_set x" using \<open>z \<in> \<omega>_limit_set y\<close> y by auto

	have yreg : "f y \<noteq> 0" using f y
	by (metis rev_image_eqI)
	have zreg : "f z \<noteq> 0" using f zx
	by (metis rev_image_eqI)
	from \<omega>_limit_point_\<omega>_limit_set_regular_imp_periodic[OF assms(1-4) y yreg _ zreg] z
	show ?thesis using that by blast
	qed

	lemma fixed_point_in_\<omega>_limit_set_imp_\<omega>_limit_set_singleton_fixed_point:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	assumes fp: "yfp \<in> \<omega>_limit_set x" "f yfp = 0"
	assumes zpx: "z \<in> \<omega>_limit_set x"
	assumes finite_fp: "finite {y \<in> K. f y = 0}" (is "finite ?S")
	shows "(\<exists>p1 \<in> \<omega>_limit_set x. f p1 = 0 \<and> \<omega>_limit_set z = {p1}) \<and>
	(\<exists>p2 \<in> \<omega>_limit_set x. f p2 = 0 \<and> \<alpha>_limit_set z = {p2})"
	proof -
	let ?weq = "{y \<in> \<omega>_limit_set x. f y = 0}"
	from \<omega>_limit_set_in_compact_subset[OF assms(1-4)]
	have wxK: "\<omega>_limit_set x \<subseteq> K" .
	from \<omega>_limit_set_in_compact_\<omega>_limit_set_contained[OF assms(1-4)]
	have zx: "\<omega>_limit_set z \<subseteq> \<omega>_limit_set x" using zpx by auto
	have zX: "z \<in> X" using subset_trans[OF wxK assms(2)]
	by (metis subset_iff zpx)
	from \<omega>_limit_set_in_compact_subset[OF assms(1-4)]
	have "?weq \<subseteq> ?S"
	by (smt Collect_mono_iff Int_iff inf.absorb_iff1)
	then have "finite ?weq" using \<open>finite ?S\<close>
	by (blast intro: rev_finite_subset)

	consider "f z = 0" \| "f z \<noteq> 0" by auto
	then show ?thesis
	proof cases
	assume "f z = 0"
	from fixed_point_imp_\<omega>_limit_set[OF zX this]
	fixed_point_imp_\<alpha>_limit_set[OF zX this]
	show ?thesis
	by (metis (mono_tags) \<open>f z = 0\<close> zpx)
	next
	assume "f z \<noteq> 0"
	have zweq: "\<omega>_limit_set z \<subseteq> ?weq"
	apply clarsimp
	proof (rule ccontr)
	fix k assume k: "k \<in> \<omega>_limit_set z" "\<not> (k \<in> \<omega>_limit_set x \<and> f k = 0)"
	then have "f k \<noteq> 0" using zx k by auto
	from \<omega>_limit_point_\<omega>_limit_set_regular_imp_periodic[OF assms(1-4) zpx \<open>f z \<noteq> 0\<close> _ this] k(1)
	have "periodic_orbit z" "range(flow0 z) = \<omega>_limit_set x" by auto
	then have "0 \<notin> f ` (\<omega>_limit_set x)"
	by (metis image_iff periodic_orbit_imp_flow0_regular)
	thus False using fp
	by (metis (mono_tags, lifting) empty_Collect_eq image_eqI)
	qed
	have zweq0: "\<alpha>_limit_set z \<subseteq> ?weq"
	apply clarsimp
	proof (rule ccontr)
	fix k assume k: "k \<in> \<alpha>_limit_set z" "\<not> (k \<in> \<omega>_limit_set x \<and> f k = 0)"
	then have "f k \<noteq> 0" using zx k
	\<omega>_limit_set_in_compact_\<alpha>_limit_set_contained[OF assms(1-4), of z] zpx
	by auto
	from \<omega>_limit_point_\<omega>_limit_set_regular_imp_periodic[OF assms(1-4) zpx \<open>f z \<noteq> 0\<close> _ this] k(1)
	have "periodic_orbit z" "range(flow0 z) = \<omega>_limit_set x" by auto
	then have "0 \<notin> f ` (\<omega>_limit_set x)"
	by (metis image_iff periodic_orbit_imp_flow0_regular)
	thus False using fp
	by (metis (mono_tags, lifting) empty_Collect_eq image_eqI)
	qed
	from \<omega>_limit_set_in_compact_existence[OF assms(1-4) zpx]
	have zex: "existence_ivl0 z = UNIV" .
	from \<omega>_limit_set_invariant
	have "invariant (\<omega>_limit_set x)" .
	then have zinv: "flow0 z ` UNIV \<subseteq> \<omega>_limit_set x" using zex unfolding invariant_def
	using trapped_iff_on_existence_ivl0 zpx by blast
	then have "flow0 z ` UNIV \<subseteq> K" using wxK by auto
	then have a2: "trapped_forward z K" "trapped_backward z K"
	using trapped_def trapped_iff_on_existence_ivl0 apply fastforce
	using \<open>range (flow0 z) \<subseteq> K\<close> trapped_def trapped_iff_on_existence_ivl0 by blast
	have a3: "finite (\<omega>_limit_set z)"
	by (metis \<open>finite ?weq\<close> finite_subset zweq)
	from finite_\<omega>_limit_set_in_compact_imp_unique_fixed_point[OF assms(1-2) zX a2(1) a3]
	obtain p1 where p1: "\<omega>_limit_set z = {p1}" "f p1 = 0" by blast
	then have "p1 \<in> ?weq" using zweq by blast
	moreover
	have "finite (\<alpha>_limit_set z)"
	by (metis \<open>finite ?weq\<close> finite_subset zweq0)
	from finite_\<alpha>_limit_set_in_compact_imp_unique_fixed_point[OF assms(1-2) zX a2(2) this]
	obtain p2 where p2: "\<alpha>_limit_set z = {p2}" "f p2 = 0" by blast
	then have "p2 \<in> ?weq" using zweq0 by blast
	ultimately show ?thesis
	by (simp add: p1 p2)
	qed
	qed

	end context c1_on_open_R2 begin

	text \<open>Perko Section 3.7 Theorem 2\<close>
	theorem poincare_bendixson_general:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> X" "trapped_forward x K"
	assumes "S = {y \<in> K. f y = 0}" "finite S"
	shows
	"(\<exists>y \<in> S. \<omega>_limit_set x = {y}) \<or>
	(\<exists>y. periodic_orbit y \<and>
	flow0 y ` UNIV = \<omega>_limit_set x) \<or>
	(\<exists>P R. \<omega>_limit_set x = P \<union> R \<and>
	P \<subseteq> S \<and> 0 \<notin> f ` R \<and> R \<noteq> {} \<and>
	(\<forall>z \<in> R.
	(\<exists>p1 \<in> P. \<omega>_limit_set z = {p1}) \<and>
	(\<exists>p2 \<in> P. \<alpha>_limit_set z = {p2})))"
	proof -
	note S = \<open>S = {y \<in> K. f y = 0}\<close>
	let ?wreg = "{y \<in> \<omega>_limit_set x. f y \<noteq> 0}"
	let ?weq = "{y \<in> \<omega>_limit_set x. f y = 0}"
	have wreqweq: "?wreg \<union> ?weq = \<omega>_limit_set x"
	by (smt Collect_cong Collect_disj_eq mem_Collect_eq \<omega>_limit_set_def)

	from trapped_sol_right[OF assms(1-4)] have ex_pos: "{0..} \<subseteq> existence_ivl0 x" by blast
	from \<omega>_limit_set_in_compact_subset[OF assms(1-4)]
	have wxK: "\<omega>_limit_set x \<subseteq> K" .
	then have "?weq \<subseteq> S" using S
	by (smt Collect_mono_iff Int_iff inf.absorb_iff1)
	then have "finite ?weq" using \<open>finite S\<close>
	by (metis rev_finite_subset)
	from \<omega>_limit_set_invariant
	have xinv: "invariant (\<omega>_limit_set x)" .

	from \<omega>_limit_set_in_compact_nonempty[OF assms(1-4)] wreqweq
	consider "?wreg = {}" \|
	"?weq = {}" \|
	"?weq \<noteq> {}" "?wreg \<noteq> {}" by auto
	then show ?thesis
	proof cases
	(* If w has no regular points then it is equal to a single unique fixed point *)
	assume "?wreg = {}"
	then have "finite (\<omega>_limit_set x)"
	by (metis (mono_tags, lifting) \<open>{y \<in> \<omega>_limit_set x. f y = 0} \<subseteq> S\<close> \<open>finite S\<close> rev_finite_subset sup_bot.left_neutral wreqweq)
	from finite_\<omega>_limit_set_in_compact_imp_unique_fixed_point[OF assms(1-4) this]
	obtain y where y: "\<omega>_limit_set x = {y}" "f y = 0" by blast
	then have "y \<in> S"
	by (metis Un_empty_left \<open>?weq \<subseteq> S\<close> \<open>?wreg = {}\<close> insert_subset wreqweq)
	then show ?thesis using y by auto
	next
	(* If w has no fixed points, then the Poincare Bendixson theorem applies *)
	assume "?weq = {}"
	then have " 0 \<notin> f ` \<omega>_limit_set x"
	by (smt empty_Collect_eq imageE)
	from poincare_bendixson[OF assms(1-4) this]
	have "(\<exists>y. periodic_orbit y \<and> flow0 y ` UNIV = \<omega>_limit_set x)"
	by metis
	then show ?thesis by blast
	next
	(* Otherwise, all points in the limit set converge to a finite subset of the fixed points *)
	assume "?weq \<noteq> {}" "?wreg \<noteq> {}"
	then obtain yfp where yfp: "yfp \<in> \<omega>_limit_set x" "f yfp = 0" by auto
	have "0 \<notin> f ` ?wreg" by auto
	have "(\<exists>p1\<in>\<omega>_limit_set x. f p1 = 0 \<and> \<omega>_limit_set z = {p1}) \<and>
	(\<exists>p2\<in>\<omega>_limit_set x. f p2 = 0 \<and> \<alpha>_limit_set z = {p2})"
	if zpx: "z \<in> \<omega>_limit_set x" for z
	using fixed_point_in_\<omega>_limit_set_imp_\<omega>_limit_set_singleton_fixed_point[
	OF assms(1-4) yfp zpx \<open>finite S\<close>[unfolded S]] by auto
	then have "\<omega>_limit_set x = ?weq \<union> ?wreg \<and>
	?weq \<subseteq> S \<and> 0 \<notin> f ` ?wreg \<and> ?wreg \<noteq> {} \<and>
	(\<forall>z \<in> ?wreg.
	(\<exists>p1 \<in> ?weq. \<omega>_limit_set z = {p1}) \<and>
	(\<exists>p2 \<in> ?weq. \<alpha>_limit_set z = {p2}))"
	using wreqweq \<open>?weq \<subseteq> S\<close> \<open>?wreg \<noteq> {}\<close> \<open>0 \<notin> f ` ?wreg\<close>
	by blast
	then show ?thesis by blast
	qed
	qed

	corollary poincare_bendixson_applied:
	assumes "compact K" "K \<subseteq> X"
	assumes "K \<noteq> {}" "positively_invariant K"
	assumes "0 \<notin> f ` K"
	obtains y where "periodic_orbit y" "flow0 y ` UNIV \<subseteq> K"
	proof -
	from assms(1-4) obtain x where "x \<in> K" "x \<in> X" by auto
	have *: "trapped_forward x K"
	using assms(4) \<open>x \<in> K\<close>
	by (auto simp: positively_invariant_def)
	have subs: "\<omega>_limit_set x \<subseteq> K"
	by (rule \<omega>_limit_set_in_compact_subset[OF assms(1-2) \<open>x \<in> X\<close> *])
	with assms(5) have "0 \<notin> f ` \<omega>_limit_set x" by auto
	from poincare_bendixson[OF assms(1-2) \<open>x \<in> X\<close> * this]
	obtain y where "periodic_orbit y" "range (flow0 y) = \<omega>_limit_set x"
	by force
	then have "periodic_orbit y" "flow0 y ` UNIV \<subseteq> K" using subs by auto
	then show ?thesis ..
	qed

	(*
	Limit cycles are periodic orbits that is the \<omega> (or \<alpha>)-limit set of some point not in the cycle.
	As with periodic_orbit, limit_cycles are defined for a representative point y
	*)
	definition "limit_cycle y \<longleftrightarrow>
	periodic_orbit y \<and>
	(\<exists>x. x \<notin> flow0 y ` UNIV \<and>
	(flow0 y ` UNIV = \<omega>_limit_set x \<or> flow0 y ` UNIV = \<alpha>_limit_set x))"

	corollary poincare_bendixson_limit_cycle:
	assumes "compact K" "K \<subseteq> X"
	assumes "x \<in> K" "positively_invariant K"
	assumes "0 \<notin> f ` K"
	assumes "rev.flow0 x t \<notin> K"
	obtains y where "limit_cycle y" "flow0 y ` UNIV \<subseteq> K"
	proof -
	have "x \<in> X" using assms(2-3) by blast
	have *: "trapped_forward x K"
	using assms(3-4)
	by (auto simp: positively_invariant_def)
	have subs: "\<omega>_limit_set x \<subseteq> K"
	by (rule \<omega>_limit_set_in_compact_subset[OF assms(1-2) \<open>x \<in> X\<close> *])
	with assms(5) have "0 \<notin> f ` \<omega>_limit_set x" by auto
	from poincare_bendixson[OF assms(1-2) \<open>x \<in> X\<close> * this]
	obtain y where y: "periodic_orbit y" "range (flow0 y) = \<omega>_limit_set x"
	by force
	then have c2: "flow0 y ` UNIV \<subseteq> K" using subs by auto
	have exy: "existence_ivl0 y = UNIV"
	using closed_orbit_global_existence periodic_orbit_def y(1) by blast
	have "x \<notin> flow0 y ` UNIV"
	proof clarsimp
	fix tt
	assume "x = flow0 y tt"
	then have "rev.flow0 (flow0 y tt) t \<notin> K" using assms(6) by auto
	moreover have "rev.flow0 (flow0 y tt) t \<in> flow0 y ` UNIV" using exy unfolding rev_eq_flow
	using UNIV_I \<open>x = flow0 y tt\<close> closed_orbit_\<omega>_limit_set closed_orbit_flow0 periodic_orbit_def y by auto
	ultimately show False using c2 by blast
	qed
	then have "limit_cycle y" "flow0 y ` UNIV \<subseteq> K" using y c2 unfolding limit_cycle_def by auto
	then show ?thesis ..
	qed

	end

	end
	diff --git a/thys/Random_BSTs/Random_BSTs.thy b/thys/Random_BSTs/Random_BSTs.thy
	--- a/thys/Random_BSTs/Random_BSTs.thy
	+++ b/thys/Random_BSTs/Random_BSTs.thy
	@@ -1,818 +1,818 @@
	(*
	File: Random_BSTs.thy
	Author: Manuel Eberl <manuel@pruvisto.org>

	Expected shape of random Binary Search Trees
	*)
	section \<open>Expected shape of random Binary Search Trees\<close>
	theory Random_BSTs
	imports
	Complex_Main
	"HOL-Probability.Random_Permutations"
	"HOL-Data_Structures.Tree_Set"
	Quick_Sort_Cost.Quick_Sort_Average_Case
	begin

	(* TODO: Hide this in the proper place *)
	hide_const (open) Tree_Set.insert

	subsection \<open>Auxiliary lemmas\<close>

	(* TODO: Move? *)
	lemma linorder_on_linorder_class [intro]:
	"linorder_on UNIV {(x, y). x \<le> (y :: 'a :: linorder)}"
	by (auto simp: linorder_on_def refl_on_def antisym_def trans_def total_on_def)

	lemma Nil_in_permutations_of_set_iff [simp]: "[] \<in> permutations_of_set A \<longleftrightarrow> A = {}"
	by (auto simp: permutations_of_set_def)

	lemma max_power_distrib_right:
	fixes a :: "'a :: linordered_semidom"
	shows "a > 1 \<Longrightarrow> max (a ^ b) (a ^ c) = a ^ max b c"
	by (auto simp: max_def)

	lemma set_tree_empty_iff [simp]: "set_tree t = {} \<longleftrightarrow> t = Leaf"
	by (cases t) auto

	lemma card_set_tree_bst: "bst t \<Longrightarrow> card (set_tree t) = size t"
	proof (induction t)
	case (Node l x r)
	have "set_tree \<langle>l, x, r\<rangle> = insert x (set_tree l \<union> set_tree r)" by simp
	also from Node.prems have "card \<dots> = Suc (card (set_tree l \<union> set_tree r))"
	by (intro card_insert_disjoint) auto
	also from Node have "card (set_tree l \<union> set_tree r) = size l + size r"
	by (subst card_Un_disjoint) force+
	finally show ?case by simp
	qed simp_all

	lemma pair_pmf_cong:
	"p = p' \<Longrightarrow> q = q' \<Longrightarrow> pair_pmf p q = pair_pmf p' q'"
	by simp

	lemma expectation_add_pair_pmf:
	fixes f :: "'a \<Rightarrow> 'c::{banach, second_countable_topology}"
	assumes "finite (set_pmf p)" and "finite (set_pmf q)"
	shows "measure_pmf.expectation (pair_pmf p q) (\<lambda>(x,y). f x + g y) =
	measure_pmf.expectation p f + measure_pmf.expectation q g"
	proof -
	have "measure_pmf.expectation (pair_pmf p q) (\<lambda>(x,y). f x + g y) =
	measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z) + g (snd z))"
	by (simp add: case_prod_unfold)
	also have "\<dots> = measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z)) +
	measure_pmf.expectation (pair_pmf p q) (\<lambda>z. g (snd z))"
	by (intro Bochner_Integration.integral_add integrable_measure_pmf_finite) (auto intro: assms)
	also have "measure_pmf.expectation (pair_pmf p q) (\<lambda>z. f (fst z)) =
	measure_pmf.expectation (map_pmf fst (pair_pmf p q)) f" by simp
	also have "map_pmf fst (pair_pmf p q) = p" by (rule map_fst_pair_pmf)
	also have "measure_pmf.expectation (pair_pmf p q) (\<lambda>z. g (snd z)) =
	measure_pmf.expectation (map_pmf snd (pair_pmf p q)) g" by simp
	also have "map_pmf snd (pair_pmf p q) = q" by (rule map_snd_pair_pmf)
	finally show ?thesis .
	qed


	subsection \<open>Creating a BST from a list\<close>

	text \<open>
	The following recursive function creates a binary search tree from a given list of
	elements by inserting them into an initially empty BST from left to right. We will prove
	that this is the case later, but the recursive definition has the advantage of giving us
	a useful induction rule, so we chose that definition and prove the alternative definitions later.

	This recursion, which already almost looks like QuickSort, will be key in analysing the
	shape distributions of random BSTs.
	\<close>
	fun bst_of_list :: "'a :: linorder list \<Rightarrow> 'a tree" where
	"bst_of_list [] = Leaf"
	\| "bst_of_list (x # xs) =
	Node (bst_of_list [y \<leftarrow> xs. y < x]) x (bst_of_list [y \<leftarrow> xs. y > x])"

	lemma bst_of_list_eq_Leaf_iff [simp]: "bst_of_list xs = Leaf \<longleftrightarrow> xs = []"
	by (induction xs) auto

	lemma bst_of_list_snoc [simp]:
	"bst_of_list (xs @ [y]) = Tree_Set.insert y (bst_of_list xs)"
	by (induction xs rule: bst_of_list.induct) auto

	lemma bst_of_list_append:
	"bst_of_list (xs @ ys) = fold Tree_Set.insert ys (bst_of_list xs)"
	proof (induction ys arbitrary: xs)
	case (Cons y ys)
	have "bst_of_list (xs @ (y # ys)) = bst_of_list ((xs @ [y]) @ ys)" by simp
	also have "\<dots> = fold Tree_Set.insert ys (bst_of_list (xs @ [y]))"
	by (rule Cons.IH)
	finally show ?case by simp
	qed simp_all

	text \<open>
	The following now shows that the recursive function indeed corresponds to the
	notion of inserting the elements from the list from left to right.
	\<close>
	lemma bst_of_list_altdef: "bst_of_list xs = fold Tree_Set.insert xs Leaf"
	using bst_of_list_append[of "[]" xs] by simp

	lemma size_bst_insert: "x \<notin> set_tree t \<Longrightarrow> size (Tree_Set.insert x t) = Suc (size t)"
	by (induction t) auto

	lemma set_bst_insert [simp]: "set_tree (Tree_Set.insert x t) = insert x (set_tree t)"
	by (induction t) auto

	lemma set_bst_of_list [simp]: "set_tree (bst_of_list xs) = set xs"
	by (induction xs rule: rev_induct) simp_all

	lemma size_bst_of_list_distinct [simp]:
	assumes "distinct xs"
	shows "size (bst_of_list xs) = length xs"
	using assms by (induction xs rule: rev_induct) (auto simp: size_bst_insert)

	lemma strict_mono_on_imp_less_iff:
	assumes "strict_mono_on f A" "x \<in> A" "y \<in> A"
	shows "f x < (f y :: 'b :: linorder) \<longleftrightarrow> x < (y :: 'a :: linorder)"
	using assms by (cases x y rule: linorder_cases; force simp: strict_mono_on_def)+

	lemma bst_of_list_map:
	fixes f :: "'a :: linorder \<Rightarrow> 'b :: linorder"
	assumes "strict_mono_on f A" "set xs \<subseteq> A"
	shows "bst_of_list (map f xs) = map_tree f (bst_of_list xs)"
	using assms
	proof (induction xs rule: bst_of_list.induct)
	case (2 x xs)
	have "[xa\<leftarrow>xs . f xa < f x] = [xa\<leftarrow>xs . xa < x]" and "[xa\<leftarrow>xs . f xa > f x] = [xa\<leftarrow>xs . xa > x]"
	using "2.prems" by (auto simp: strict_mono_on_imp_less_iff intro!: filter_cong)
	with 2 show ?case by (auto simp: filter_map o_def)
	qed auto


	subsection \<open>Random BSTs\<close>

	text \<open>
	Analogously to the previous section, we can now view the concept of a random BST
	(i.\,e.\ a BST obtained by inserting a given set of elements in random order) in two
	different ways.

	We again start with the recursive variant:
	\<close>
	function random_bst :: "'a :: linorder set \<Rightarrow> 'a tree pmf" where
	"random_bst A =
	(if \<not>finite A \<or> A = {} then
	return_pmf Leaf
	else do {
	x \<leftarrow> pmf_of_set A;
	l \<leftarrow> random_bst {y \<in> A. y < x};
	r \<leftarrow> random_bst {y \<in> A. y > x};
	return_pmf (Node l x r)
	})"
	by auto
	termination by (relation finite_psubset) auto

	declare random_bst.simps [simp del]

	lemma random_bst_empty [simp]: "random_bst {} = return_pmf Leaf"
	by (simp add: random_bst.simps)

	lemma set_pmf_random_permutation [simp]:
	"finite A \<Longrightarrow> set_pmf (pmf_of_set (permutations_of_set A)) = {xs. distinct xs \<and> set xs = A}"
	by (subst set_pmf_of_set) (auto dest: permutations_of_setD)

	text \<open>
	The alternative characterisation is the more intuitive one where we simply pick a
	random permutation of the set elements uniformly at random and insert them into an empty
	tree from left to right:
	\<close>
	lemma random_bst_altdef:
	assumes "finite A"
	shows "random_bst A = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
	using assms
	proof (induction A rule: finite_psubset_induct)
	case (psubset A)
	define L R where "L = (\<lambda>x. {y\<in>A. y < x})" and "R = (\<lambda>x. {y\<in>A. y > x})"
	{
	fix x assume x: "x \<in> A"
	hence *: "L x \<subset> A" "R x \<subset> A" by (auto simp: L_def R_def)
	note this [THEN psubset.IH]
	} note IH = this

	show ?case
	proof (cases "A = {}")
	case False
	note A = \<open>finite A\<close> \<open>A \<noteq> {}\<close>
	have "random_bst A =
	do {
	x \<leftarrow> pmf_of_set A;
	(l, r) \<leftarrow> pair_pmf (random_bst (L x)) (random_bst (R x));
	return_pmf (Node l x r)
	}" using A unfolding pair_pmf_def L_def R_def
	by (subst random_bst.simps) (simp add: bind_return_pmf bind_assoc_pmf)
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	(l, r) \<leftarrow> pair_pmf
	(map_pmf bst_of_list (pmf_of_set (permutations_of_set (L x))))
	(map_pmf bst_of_list (pmf_of_set (permutations_of_set (R x))));
	return_pmf (Node l x r)
	}"
	using A by (intro bind_pmf_cong refl) (simp_all add: IH)
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	(ls, rs) \<leftarrow> pair_pmf (pmf_of_set (permutations_of_set (L x)))
	(pmf_of_set (permutations_of_set (R x)));
	return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
	}" unfolding map_pair [symmetric]
	by (simp add: map_pmf_def case_prod_unfold bind_return_pmf bind_assoc_pmf)
	also have "L = (\<lambda>x. {y \<in> A - {x}. y \<le> x})" by (auto simp: L_def)
	also have "R = (\<lambda>x. {y \<in> A - {x}. \<not>y \<le> x})" by (auto simp: R_def)
	also have "do {
	x \<leftarrow> pmf_of_set A;
	(ls, rs) \<leftarrow> pair_pmf (pmf_of_set (permutations_of_set {y \<in> A - {x}. y \<le> x}))
	(pmf_of_set (permutations_of_set {y \<in> A - {x}. \<not>y \<le> x}));
	return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
	} =
	do {
	x \<leftarrow> pmf_of_set A;
	(ls, rs) \<leftarrow> map_pmf (partition (\<lambda>y. y \<le> x))
	(pmf_of_set (permutations_of_set (A - {x})));
	return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
	}" using \<open>finite A\<close>
	by (intro bind_pmf_cong refl partition_random_permutations [symmetric]) auto
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	(ls, rs) \<leftarrow> map_pmf (\<lambda>xs. ([y\<leftarrow>xs. y < x], [y\<leftarrow>xs. y > x]))
	(pmf_of_set (permutations_of_set (A - {x})));
	return_pmf (Node (bst_of_list ls) x (bst_of_list rs))
	}" using A
	by (intro bind_pmf_cong refl map_pmf_cong)
	(auto intro!: filter_cong dest: permutations_of_setD simp: order.strict_iff_order)
	also have "\<dots> = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
	using A by (subst random_permutation_of_set[of A])
	(auto simp: map_pmf_def bind_return_pmf o_def bind_assoc_pmf not_le)
	finally show ?thesis .
	qed (simp_all add: pmf_of_set_singleton)
	qed

	lemma finite_set_random_bst [simp, intro]:
	"finite A \<Longrightarrow> finite (set_pmf (random_bst A))"
	by (simp add: random_bst_altdef)

	lemma random_bst_code [code]:
	"random_bst (set xs) = map_pmf bst_of_list (pmf_of_set (permutations_of_set (set xs)))"
	by (rule random_bst_altdef) simp_all

	lemma random_bst_singleton [simp]: "random_bst {x} = return_pmf (Node Leaf x Leaf)"
	by (simp add: random_bst_altdef pmf_of_set_singleton)

	lemma size_random_bst:
	assumes "t \<in> set_pmf (random_bst A)" "finite A"
	shows "size t = card A"
	proof -
	from assms obtain xs where "distinct xs" "A = set xs" "t = bst_of_list xs"
	by (auto simp: random_bst_altdef dest: permutations_of_setD)
	thus ?thesis using \<open>finite A\<close> by (simp add: distinct_card)
	qed

	lemma random_bst_image:
	assumes "finite A" "strict_mono_on f A"
	shows "random_bst (f ` A) = map_pmf (map_tree f) (random_bst A)"
	proof -
	from assms(2) have inj: "inj_on f A" by (rule strict_mono_on_imp_inj_on)
	with assms have "inj_on (map f) (permutations_of_set A)"
	by (intro inj_on_mapI) auto
	with assms inj have "random_bst (f ` A) =
	map_pmf (\<lambda>x. bst_of_list (map f x)) (pmf_of_set (permutations_of_set A))"
	by (simp add: random_bst_altdef permutations_of_set_image_inj map_pmf_of_set_inj [symmetric]
	pmf.map_comp o_def)
	also have "\<dots> = map_pmf (map_tree f) (random_bst A)"
	unfolding random_bst_altdef[OF \<open>finite A\<close>] pmf.map_comp o_def using assms
	by (intro map_pmf_cong refl bst_of_list_map[of f A]) (auto dest: permutations_of_setD)
	finally show ?thesis .
	qed


	text \<open>
	We can also re-phrase the non-recursive definition using the @{const fold_random_permutation}
	combinator from the HOL-Probability library, which folds over a given set in random order.
	\<close>
	lemma random_bst_altdef':
	assumes "finite A"
	shows "random_bst A = fold_random_permutation Tree_Set.insert Leaf A"
	proof -
	have "random_bst A = map_pmf bst_of_list (pmf_of_set (permutations_of_set A))"
	using assms by (simp add: random_bst_altdef)
	also have "\<dots> = map_pmf (\<lambda>xs. fold Tree_Set.insert xs Leaf) (pmf_of_set (permutations_of_set A))"
	using assms by (intro map_pmf_cong refl) (auto simp: bst_of_list_altdef)
	also from assms have "\<dots> = fold_random_permutation Tree_Set.insert Leaf A"
	by (simp add: fold_random_permutation_fold)
	finally show ?thesis .
	qed


	subsection \<open>Expected height\<close>

	text \<open>
	For the purposes of the analysis of the expected height, we define the following notion
	of `expected height', which is essentially two to the power of the height (as defined
	by Cormen \textit{et al.}) with a special treatment for the empty tree, which has exponential
	height 0.

	Note that the height defined by Cormen \textit{et al.}\ differs from the @{const height}
	function here in Isabelle in that for them, the height of the empty tree is undefined and
	the height of a singleton tree is 0 etc., whereas in Isabelle, the height of the empty tree is
	0 and the height of a singleton tree is 1.
	\<close>
	definition eheight :: "'a tree \<Rightarrow> nat" where
	"eheight t = (if t = Leaf then 0 else 2 ^ (height t - 1))"

	lemma eheight_Leaf [simp]: "eheight Leaf = 0"
	by (simp add: eheight_def)

	lemma eheight_Node_singleton [simp]: "eheight (Node Leaf x Leaf) = 1"
	by (simp add: eheight_def)

	lemma eheight_Node:
	"l \<noteq> Leaf \<or> r \<noteq> Leaf \<Longrightarrow> eheight (Node l x r) = 2 * max (eheight l) (eheight r)"
	by (cases l; cases r) (simp_all add: eheight_def max_power_distrib_right)


	fun eheight_rbst :: "nat \<Rightarrow> nat pmf" where
	"eheight_rbst 0 = return_pmf 0"
	\| "eheight_rbst (Suc 0) = return_pmf 1"
	\| "eheight_rbst (Suc n) =
	do {
	k \<leftarrow> pmf_of_set {..n};
	h1 \<leftarrow> eheight_rbst k;
	h2 \<leftarrow> eheight_rbst (n - k);
	return_pmf (2 * max h1 h2)}"

	definition eheight_exp :: "nat \<Rightarrow> real" where
	"eheight_exp n = measure_pmf.expectation (eheight_rbst n) real"

	lemma eheight_rbst_reduce:
	assumes "n > 1"
	shows "eheight_rbst n =
	do {k \<leftarrow> pmf_of_set {..<n}; h1 \<leftarrow> eheight_rbst k; h2 \<leftarrow> eheight_rbst (n - k - 1);
	return_pmf (2 * max h1 h2)}"
	using assms by (cases n rule: eheight_rbst.cases) (simp_all add: lessThan_Suc_atMost)

	lemma Leaf_in_set_random_bst_iff:
	assumes "finite A"
	shows "Leaf \<in> set_pmf (random_bst A) \<longleftrightarrow> A = {}"
	proof
	assume "Leaf \<in> set_pmf (random_bst A)"
	from size_random_bst[OF this] and assms show "A = {}" by auto
	qed auto

	lemma eheight_rbst:
	assumes "finite A"
	shows "eheight_rbst (card A) = map_pmf eheight (random_bst A)"
	using assms
	proof (induction A rule: finite_psubset_induct)
	case (psubset A)
	define rank where "rank = linorder_rank {(x,y). x \<le> y} A"
	from \<open>finite A\<close> have "A = {} \<or> is_singleton A \<or> card A > 1"
	by (auto simp: not_less le_Suc_eq is_singleton_altdef)
	then consider "A = {}" \| "is_singleton A" \| "card A > 1" by blast
	thus ?case
	proof cases
	case 3
	hence nonempty: "A \<noteq> {}" by auto
	from 3 have "\<not>is_singleton A" by (auto simp: is_singleton_def)
	hence exists_other: "\<exists>y\<in>A. y \<noteq> x" for x using \<open>A \<noteq> {}\<close> by (force simp: is_singleton_def)

	hence "map_pmf eheight (random_bst A) =
	do {
	x \<leftarrow> pmf_of_set A;
	l \<leftarrow> random_bst {y \<in> A. y < x};
	r \<leftarrow> random_bst {y \<in> A. y > x};
	return_pmf (eheight (Node l x r))
	}"
	using \<open>finite A\<close> by (subst random_bst.simps) (auto simp: map_bind_pmf)
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	l \<leftarrow> random_bst {y \<in> A. y < x};
	r \<leftarrow> random_bst {y \<in> A. y > x};
	return_pmf (2 * max (eheight l) (eheight r))
	}"
	using 3 \<open>finite A\<close> exists_other
	by (intro bind_pmf_cong refl, subst eheight_Node)
	(force simp: Leaf_in_set_random_bst_iff not_less nonempty eheight_Node)+
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	h1 \<leftarrow> map_pmf eheight (random_bst {y \<in> A. y < x});
	h2 \<leftarrow> map_pmf eheight (random_bst {y \<in> A. y > x});
	return_pmf (2 * max h1 h2)
	}"
	by (simp add: bind_map_pmf)
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	h1 \<leftarrow> eheight_rbst (card {y \<in> A. y < x});
	h2 \<leftarrow> eheight_rbst (card {y \<in> A. y > x});
	return_pmf (2 * max h1 h2)
	}"
	using \<open>A \<noteq> {}\<close> \<open>finite A\<close> by (intro bind_pmf_cong psubset.IH [symmetric] refl) auto
	also have "\<dots> = do {
	k \<leftarrow> map_pmf rank (pmf_of_set A);
	h1 \<leftarrow> eheight_rbst k;
	h2 \<leftarrow> eheight_rbst (card A - k - 1);
	return_pmf (2 * max h1 h2)
	}"
	unfolding bind_map_pmf
	proof (intro bind_pmf_cong refl, goal_cases)
	case (1 x)
	have "rank x = card {y\<in>A-{x}. y \<le> x}" by (simp add: rank_def linorder_rank_def)
	also have "{y\<in>A-{x}. y \<le> x} = {y\<in>A. y < x}" by auto
	finally show ?case by simp
	next
	case (2 x)
	have "A - {x} = {y\<in>A-{x}. y \<le> x} \<union> {y\<in>A. y > x}" by auto
	also have "card \<dots> = rank x + card {y\<in>A. y > x}"
	using \<open>finite A\<close> by (subst card_Un_disjoint) (auto simp: rank_def linorder_rank_def)
	finally have "card {y\<in>A. y > x} = card A - rank x - 1"
	using 2 \<open>finite A\<close> \<open>A \<noteq> {}\<close> by simp
	thus ?case by simp
	qed
	also have "map_pmf rank (pmf_of_set A) = pmf_of_set {..<card A}"
	using \<open>A \<noteq> {}\<close> \<open>finite A\<close> unfolding rank_def
	by (intro map_pmf_of_set_bij_betw bij_betw_linorder_rank[of UNIV]) auto
	also have "do {
	k \<leftarrow> pmf_of_set {..<card A};
	h1 \<leftarrow> eheight_rbst k;
	h2 \<leftarrow> eheight_rbst (card A - k - 1);
	return_pmf (2 * max h1 h2)
	} = eheight_rbst (card A)"
	by (rule eheight_rbst_reduce [symmetric]) fact+
	finally show ?thesis ..
	qed (auto simp: is_singleton_def)
	qed

	lemma finite_pmf_set_eheight_rbst [simp, intro]: "finite (set_pmf (eheight_rbst n))"
	proof -
	have "eheight_rbst n = map_pmf eheight (random_bst {..<n})"
	by (subst eheight_rbst [symmetric]) auto
	also have "finite (set_pmf \<dots>)" by simp
	finally show ?thesis .
	qed

	lemma eheight_exp_0 [simp]: "eheight_exp 0 = 0"
	by (simp add: eheight_exp_def)

	lemma eheight_exp_1 [simp]: "eheight_exp (Suc 0) = 1"
	by (simp add: eheight_exp_def lessThan_Suc)

	lemma eheight_exp_reduce_bound:
	assumes "n > 1"
	shows "eheight_exp n \<le> 4 / n * (\<Sum>k<n. eheight_exp k)"
	proof -
	have [simp]: "real (max a b) = max (real a) (real b)" for a b
	by (simp add: max_def)
	let ?f = "\<lambda>(h1,h2). max h1 h2"
	let ?p = "\<lambda>k. pair_pmf (eheight_rbst k) (eheight_rbst (n - Suc k))"
	have "eheight_exp n = measure_pmf.expectation (eheight_rbst n) real"
	by (simp add: eheight_exp_def)
	also have "\<dots> = 1 / real n * (\<Sum>k<n. measure_pmf.expectation
	(map_pmf (\<lambda>(h1,h2). 2 * max h1 h2) (?p k)) real)"
	(is "_ = _ * ?S") unfolding pair_pmf_def map_bind_pmf
	by (subst eheight_rbst_reduce [OF assms], subst pmf_expectation_bind_pmf_of_set)
	(insert assms, auto simp: sum_divide_distrib divide_simps)
	also have "?S = (\<Sum>k<n. measure_pmf.expectation (map_pmf (\<lambda>x. 2 * x) (map_pmf ?f (?p k))) real)"
	by (simp only: pmf.map_comp o_def case_prod_unfold)
	also have "\<dots> = 2 * (\<Sum>k<n. measure_pmf.expectation (map_pmf ?f (?p k)) real)" (is "_ = _ * ?S'")
	by (subst integral_map_pmf) (simp add: sum_distrib_left)
	also have "?S' = (\<Sum>k<n. measure_pmf.expectation (?p k) (\<lambda>(h1,h2). max (real h1) (real h2)))"
	by (simp add: case_prod_unfold)
	also have "\<dots> \<le> (\<Sum>k<n. measure_pmf.expectation (?p k) (\<lambda>(h1,h2). real h1 + real h2))"
	unfolding integral_map_pmf case_prod_unfold
	by (intro sum_mono Bochner_Integration.integral_mono integrable_measure_pmf_finite) auto
	also have "\<dots> = (\<Sum>k<n. eheight_exp k) + (\<Sum>k<n. eheight_exp (n - Suc k))"
	by (subst expectation_add_pair_pmf) (auto simp: sum.distrib eheight_exp_def)
	also have "(\<Sum>k<n. eheight_exp (n - Suc k)) = (\<Sum>k<n. eheight_exp k)"
	by (intro sum.reindex_bij_witness[of _ "\<lambda>k. n - Suc k" "\<lambda>k. n - Suc k"]) auto
	also have "1 / real n * (2 * (\<dots> + \<dots>)) = 4 / real n * \<dots>" by simp
	finally show ?thesis using assms by (simp_all add: mult_left_mono divide_right_mono)
	qed


	text \<open>
	We now define the following upper bound on the expected exponential height due to
	Cormen\ \textit{et\ al.}~\cite{cormen}:
	\<close>
	lemma eheight_exp_bound: "eheight_exp n \<le> real ((n + 3) choose 3) / 4"
	proof (induction n rule: less_induct)
	case (less n)
	consider "n = 0" \| "n = 1" \| "n > 1" by force
	thus ?case
	proof cases
	case 3
	hence "eheight_exp n \<le> 4 / n * (\<Sum>k<n. eheight_exp k)"
	by (rule eheight_exp_reduce_bound)
	also have "(\<Sum>k<n. eheight_exp k) \<le> (\<Sum>k<n. real ((k + 3) choose 3) / 4)"
	by (intro sum_mono less.IH) auto
	also have "\<dots> = real (\<Sum>k<n. ((k + 3) choose 3)) / 4"
	by (simp add: sum_divide_distrib)
	also have "(\<Sum>k<n. ((k + 3) choose 3)) = (\<Sum>k\<le>n - 1. ((k + 3) choose 3))"
	using \<open>n > 1\<close> by (intro sum.cong) auto
	also have "\<dots> = ((n + 3) choose 4)"
	using choose_rising_sum(1)[of 3 "n - 1"] and \<open>n > 1\<close> by (simp add: add_ac Suc3_eq_add_3)
	also have "4 / real n * (\<dots> / 4) = real ((n + 3) choose 3) / 4" using \<open>n > 1\<close>
	by (cases n) (simp_all add: binomial_fact fact_numeral divide_simps)
	finally show ?thesis using \<open>n > 1\<close> by (simp add: mult_left_mono divide_right_mono)
	qed (auto simp: eval_nat_numeral)
	qed


	text \<open>
	We then show that this is indeed an upper bound on the expected exponential height by induction
	over the set of elements. This proof mostly follows that by Cormen\ \textit{et al.}~\cite{cormen},
	and partially an answer on the Computer Science Stack Exchange~\cite{sofl}.
	\<close>

	text \<open>
	Since the function $\uplambda x.\ 2 ^ x$ is convex, we can then easily derive a bound on the
	actual height using Jensen's inequality:
	\<close>
	definition height_exp_approx :: "nat \<Rightarrow> real" where
	"height_exp_approx n = log 2 (real ((n + 3) choose 3) / 4) + 1"

	theorem height_expectation_bound:
	assumes "finite A" "A \<noteq> {}"
	shows "measure_pmf.expectation (random_bst A) height
	\<le> height_exp_approx (card A)"
	proof -
	have "convex_on UNIV ((powr) 2)"
	by (intro convex_on_realI[where f' = "\<lambda>x. ln 2 * 2 powr x"])
	(auto intro!: derivative_eq_intros DERIV_powr simp: powr_def [abs_def])
	hence "2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t - 1)) \<le>
	measure_pmf.expectation (random_bst A) (\<lambda>t. 2 powr real (height t - 1))"
	using assms
	by (intro measure_pmf.jensens_inequality[where I = UNIV])
	(auto intro!: integrable_measure_pmf_finite)
	also have "(\<lambda>t. 2 powr real (height t - 1)) = (\<lambda>t. 2 ^ (height t - 1))"
	by (simp add: powr_realpow)
	also have "measure_pmf.expectation (random_bst A) (\<lambda>t. 2 ^ (height t - 1)) =
	measure_pmf.expectation (random_bst A) (\<lambda>t. real (eheight t))"
	using assms
	by (intro integral_cong_AE)
	(auto simp: AE_measure_pmf_iff random_bst_altdef eheight_def)
	also have "\<dots> = measure_pmf.expectation (map_pmf eheight (random_bst A)) real"
	by simp
	also have "map_pmf eheight (random_bst A) = eheight_rbst (card A)"
	by (rule eheight_rbst [symmetric]) fact+
	also have "measure_pmf.expectation \<dots> real = eheight_exp (card A)"
	by (simp add: eheight_exp_def)
	also have "\<dots> \<le> real ((card A + 3) choose 3) / 4" by (rule eheight_exp_bound)
	also have "measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t - 1)) =
	measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)"
	proof (intro integral_cong_AE AE_pmfI, goal_cases)
	case (3 t)
	with \<open>A \<noteq> {}\<close> and assms show ?case
	by (subst of_nat_diff) (auto simp: Suc_le_eq random_bst_altdef)
	qed auto
	finally have "2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)
	\<le> real ((card A + 3) choose 3) / 4" .
	hence "log 2 (2 powr measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)) \<le>
	log 2 (real ((card A + 3) choose 3) / 4)" (is "?lhs \<le> ?rhs")
	- by (subst log_le_cancel_iff) (auto simp: )
	+ by (subst log_le_cancel_iff) auto
	also have "?lhs = measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t) - 1)"
	by simp
	also have "\<dots> = measure_pmf.expectation (random_bst A) (\<lambda>t. real (height t)) - 1"
	using assms
	by (subst Bochner_Integration.integral_diff) (auto intro!: integrable_measure_pmf_finite)
	finally show ?thesis by (simp add: height_exp_approx_def)
	qed

	text \<open>
	This upper bound is asymptotically equivalent to $c \ln n$ with
	$c = \frac{3}{\ln 2} \approx 4.328$. This is actually a relatively tight upper bound, since
	the exact asymptotics of the expected height of a random BST is $c \ln n$ with
	$c \approx 4.311$.~\cite{reed} However, the proof of these precise asymptotics is very intricate
	and we will therefore be content with the upper bound.

	In particular, we can now show that the expected height is $O(\log n)$.
	\<close>
	lemma ln_sum_bigo_ln: "(\<lambda>x::real. ln (x + c)) \<in> O(ln)"
	proof (rule bigoI_tendsto)
	from eventually_gt_at_top[of "1::real"] show "eventually (\<lambda>x::real. ln x \<noteq> 0) at_top"
	by eventually_elim simp_all
	next
	show "((\<lambda>x. ln (x + c) / ln x) \<longlongrightarrow> 1) at_top"
	proof (rule lhospital_at_top_at_top)
	show "eventually (\<lambda>x. ((\<lambda>x. ln (x + c)) has_real_derivative inverse (x + c)) (at x)) at_top"
	using eventually_gt_at_top[of "-c"]
	by eventually_elim (auto intro!: derivative_eq_intros simp: field_simps)
	show "eventually (\<lambda>x. ((\<lambda>x. ln x) has_real_derivative inverse x) (at x)) at_top"
	using eventually_gt_at_top[of 0]
	by eventually_elim (auto intro!: derivative_eq_intros simp: field_simps)
	show "((\<lambda>x. inverse (x + c) / inverse x) \<longlongrightarrow> 1) at_top"
	proof (rule Lim_transform_eventually)
	show "eventually (\<lambda>x. inverse (1 + c / x) = inverse (x + c) / inverse x) at_top"
	using eventually_gt_at_top[of "0::real"] eventually_gt_at_top[of "-c"]
	by eventually_elim (simp add: field_simps)
	have "((\<lambda>x. inverse (1 + c / x)) \<longlongrightarrow> inverse (1 + 0)) at_top"
	by (intro tendsto_inverse tendsto_add tendsto_const
	real_tendsto_divide_at_top[OF tendsto_const] filterlim_ident) simp_all
	thus "((\<lambda>x. inverse (1 + c / x)) \<longlongrightarrow> 1) at_top" by simp
	qed
	qed (auto simp: ln_at_top eventually_at_top_not_equal)
	qed

	corollary height_expectation_bigo: "height_exp_approx \<in> O(ln)"
	proof -
	let ?T = "\<lambda>x::real. log 2 (x + 1) + log 2 (x + 2) + log 2 (x + 3) + (1 - log 2 24)"
	have "eventually (\<lambda>n. height_exp_approx n =
	log 2 (real n + 1) + log 2 (real n + 2) + log 2 (real n + 3) + (1 - log 2 24)) at_top"
	(is "eventually (\<lambda>n. _ = ?T n) at_top") using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim n)
	have "height_exp_approx n = log 2 (real (n + 3 choose 3) / 4) + 1"
	by (simp add: height_exp_approx_def log_divide)
	also have "real ((n + 3) choose 3) = real (n + 3) gchoose 3"
	by (simp add: binomial_gbinomial)
	also have "\<dots> / 4 = (real n + 1) * (real n + 2) * (real n + 3) / 24"
	by (simp add: gbinomial_pochhammer' numeral_3_eq_3 pochhammer_Suc add_ac)
	also have "log 2 \<dots> = log 2 (real n + 1) + log 2 (real n + 2) + log 2 (real n + 3) - log 2 24"
	by (simp add: log_divide log_mult)
	finally show ?case by simp
	qed
	hence "height_exp_approx \<in> \<Theta>(?T)" by (rule bigthetaI_cong)
	also have *: "(\<lambda>x. ln (x + c) / ln 2) \<in> O(ln)" for c :: real
	by (subst landau_o.big.cdiv_in_iff') (auto intro!: ln_sum_bigo_ln)
	have "?T \<in> O(\<lambda>n. ln (real n))" unfolding log_def
	by (intro bigo_real_nat_transfer sum_in_bigo ln_sum_bigo_ln *) simp_all
	finally show ?thesis .
	qed


	subsection \<open>Lookup costs\<close>

	text \<open>
	The following function describes the cost incurred when looking up a specific element
	in a specific BST. The cost corresponds to the number of edges traversed in the lookup.
	\<close>

	primrec lookup_cost :: "'a :: linorder \<Rightarrow> 'a tree \<Rightarrow> nat" where
	"lookup_cost x Leaf = 0"
	\| "lookup_cost x (Node l y r) =
	(if x = y then 0
	else if x < y then Suc (lookup_cost x l)
	else Suc (lookup_cost x r))"

	text \<open>
	Some of the literature defines these costs as 1 in the case that the current node is
	the correct one, i.\,e.\ their costs are our costs plus 1. These alternative costs are
	exactly the number of comparisons performed in the lookup. Our cost function has the
	advantage of precisely summing up to the internal path length and therefore gives us
	slightly nicer results, and since the difference is only a ${}+1$ in the end, this
	variant seemed more reasonable.
	\<close>

	text \<open>
	It can be shown with a simple induction that The sum of all lookup costs in a tree is the
	internal path length of the tree.
	\<close>
	theorem sum_lookup_costs:
	fixes t :: "'a :: linorder tree"
	assumes "bst t"
	shows "(\<Sum>x\<in>set_tree t. lookup_cost x t) = ipl t"
	using assms
	proof (induction t)
	case (Node l x r)
	from Node.prems
	have disj: "x \<notin> set_tree l" "x \<notin> set_tree r" "set_tree l \<inter> set_tree r = {}" by force+
	have "set_tree (Node l x r) = insert x (set_tree l \<union> set_tree r)" by simp
	also have "(\<Sum>y\<in>\<dots>. lookup_cost y (Node l x r)) = lookup_cost x \<langle>l, x, r\<rangle> +
	(\<Sum>y\<in>set_tree l. lookup_cost y \<langle>l, x, r\<rangle>) + (\<Sum>y\<in>set_tree r. lookup_cost y \<langle>l, x, r\<rangle>)"
	using disj by (simp add: sum.union_disjoint)
	also have "(\<Sum>y\<in>set_tree l. lookup_cost y \<langle>l, x, r\<rangle>) = (\<Sum>y\<in>set_tree l. 1 + lookup_cost y l)"
	using disj and Node by (intro sum.cong refl) auto
	also have "\<dots> = size l + ipl l" using Node
	by (subst sum.distrib) (simp_all add: card_set_tree_bst)
	also have "(\<Sum>y\<in>set_tree r. lookup_cost y \<langle>l, x, r\<rangle>) = (\<Sum>y\<in>set_tree r. 1 + lookup_cost y r)"
	using disj and Node by (intro sum.cong refl) auto
	also have "\<dots> = size r + ipl r" using Node
	by (subst sum.distrib) (simp_all add: card_set_tree_bst)
	finally show ?case by simp
	qed simp_all

	text \<open>
	This allows us to easily show that the expected cost of looking up a random element in a
	fixed tree is the internal path length divided by the number of elements.
	\<close>
	theorem expected_lookup_cost:
	assumes "bst t" "t \<noteq> Leaf"
	shows "measure_pmf.expectation (pmf_of_set (set_tree t)) (\<lambda>x. lookup_cost x t) =
	ipl t / size t"
	using assms by (subst integral_pmf_of_set)
	(simp_all add: sum_lookup_costs of_nat_sum [symmetric] card_set_tree_bst)

	text \<open>
	Therefore, we will now turn to analysing the internal path length of a random BST. This
	then clearly related to the expected lookup costs of a random element in a random BST by
	the above result.
	\<close>


	subsection \<open>Average Path Length\<close>

	text \<open>
	The internal path length satisfies the recursive equation @{thm ipl.simps(2)[of l x r]}.
	This is quite similar to the number of comparisons performed by QuickSort, and indeed, we can
	reduce the internal path length of a random BST to the number of comparisons performed by
	QuickSort on a randomly-ordered list relatively easily:
	\<close>
	theorem map_pmf_random_bst_eq_rqs_cost:
	assumes "finite A"
	shows "map_pmf ipl (random_bst A) = rqs_cost (card A)"
	using assms
	proof (induction A rule: finite_psubset_induct)
	case (psubset A)
	show ?case
	proof (cases "A = {}")
	case False
	note A = \<open>finite A\<close> \<open>A \<noteq> {}\<close>
	define n where "n = card A - 1"
	define rank :: "'a \<Rightarrow> nat" where "rank = linorder_rank {(x,y). x \<le> y} A"
	from A have card: "card A = Suc n" by (cases "card A") (auto simp: n_def)
	from A have "map_pmf ipl (random_bst A) =
	do {
	x \<leftarrow> pmf_of_set A;
	(l,r) \<leftarrow> pair_pmf (random_bst {y \<in> A. y < x}) (random_bst {y \<in> A. y > x});
	return_pmf (ipl (Node l x r))
	}"
	by (subst random_bst.simps)
	(simp_all add: pair_pmf_def card map_pmf_def bind_assoc_pmf bind_return_pmf)
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	(l,r) \<leftarrow> pair_pmf (random_bst {y \<in> A. y < x}) (random_bst {y \<in> A. y > x});
	return_pmf (n + ipl l + ipl r)
	}"
	proof (intro bind_pmf_cong refl, clarify, goal_cases)
	case (1 x l r)
	from 1 and A have "n = card (A - {x})" by (simp add: n_def)
	also have "A - {x} = {y\<in>A. y < x} \<union> {y\<in>A. y > x}" by auto
	also have "card \<dots> = card {y\<in>A. y < x} + card {y\<in>A. y > x}"
	using \<open>finite A\<close> by (intro card_Un_disjoint) auto
	also from 1 and A have "card {y\<in>A. y < x} = size l" by (auto dest: size_random_bst)
	also from 1 and A have "card {y\<in>A. y > x} = size r" by (auto dest: size_random_bst)
	finally show ?case by simp
	qed
	also have "\<dots> = do {
	x \<leftarrow> pmf_of_set A;
	(l,r) \<leftarrow> pair_pmf (map_pmf ipl (random_bst {y \<in> A. y < x}))
	(map_pmf ipl (random_bst {y \<in> A. y > x}));
	return_pmf (n + l + r)
	}" by (simp add: map_pair [symmetric] case_prod_unfold bind_map_pmf)
	also have "\<dots> = do {
	i \<leftarrow> map_pmf rank (pmf_of_set A);
	(l,r) \<leftarrow> pair_pmf (rqs_cost i) (rqs_cost (n - i));
	return_pmf (n + l + r)
	}" (is "_ = bind_pmf _ ?f") unfolding bind_map_pmf
	proof (intro bind_pmf_cong refl pair_pmf_cong, goal_cases)
	case (1 x)
	have "map_pmf ipl (random_bst {y \<in> A. y < x}) = rqs_cost (card {y \<in> A. y < x})"
	using 1 and A by (intro psubset.IH) auto
	also have "{y \<in> A. y < x} = {y \<in> A - {x}. y \<le> x}" by auto
	hence "card {y \<in> A. y < x} = rank x" by (simp add: rank_def linorder_rank_def)
	finally show ?case .
	next
	case (2 x)
	have "map_pmf ipl (random_bst {y \<in> A. y > x}) = rqs_cost (card {y \<in> A. y > x})"
	using 2 and A by (intro psubset.IH) auto
	also have "{y \<in> A. y > x} = A - {x} - {y \<in> A - {x}. y \<le> x}" by auto
	hence "card {y \<in> A. y > x} = card \<dots>" by (simp only:)
	also from 2 and A have "\<dots> = n - rank x"
	by (subst card_Diff_subset) (auto simp: rank_def linorder_rank_def n_def)
	finally show ?case .
	qed
	also from A have "map_pmf rank (pmf_of_set A) = pmf_of_set {..<card A}"
	unfolding rank_def by (intro map_pmf_of_set_bij_betw bij_betw_linorder_rank[of UNIV]) auto
	also have "{..<card A} = {..n}" by (auto simp: card)
	also have "pmf_of_set \<dots> \<bind> ?f = rqs_cost (card A)"
	by (simp add: pair_pmf_def bind_assoc_pmf bind_return_pmf card)
	finally show ?thesis .
	qed simp_all
	qed

	text \<open>
	In particular, this means that the expected values are the same:
	\<close>
	corollary expected_ipl_random_bst_eq:
	assumes "finite A"
	shows "measure_pmf.expectation (random_bst A) ipl = rqs_cost_exp (card A)"
	proof -
	have "measure_pmf.expectation (random_bst A) ipl =
	measure_pmf.expectation (map_pmf ipl (random_bst A)) real" by simp
	also from assms have "map_pmf ipl (random_bst A) = rqs_cost (card A)"
	by (rule map_pmf_random_bst_eq_rqs_cost)
	also have "measure_pmf.expectation \<dots> real = rqs_cost_exp (card A)"
	by (rule expectation_rqs_cost)
	finally show ?thesis .
	qed

	text \<open>
	Therefore, the results about the expected number of comparisons of QuickSort carry over
	to the expected internal path length:
	\<close>
	corollary expected_ipl_random_bst_eq':
	assumes "finite A"
	shows "measure_pmf.expectation (random_bst A) ipl =
	2 * real (card A + 1) * harm (card A) - 4 * real (card A)"
	by (simp add: expected_ipl_random_bst_eq rqs_cost_exp_eq assms)

	end
	diff --git a/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heap.thy b/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heap.thy
	--- a/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heap.thy
	+++ b/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heap.thy
	@@ -1,903 +1,903 @@
	section \<open>Heap Implementation On Lists\<close>
	theory IICF_Abs_Heap
	imports
	"HOL-Library.Multiset"
	"../../../Sepref"
	"List-Index.List_Index"
	"../../Intf/IICF_List"
	"../../Intf/IICF_Prio_Bag"
	begin

	text \<open>
	We define Min-Heaps, which implement multisets of prioritized values.
	The operations are:
	empty heap, emptiness check, insert an element,
	remove a minimum priority element.\<close>

	subsection \<open>Basic Definitions\<close>

	type_synonym 'a heap = "'a list"

	locale heapstruct =
	fixes prio :: "'a \<Rightarrow> 'b::linorder"
	begin
	definition valid :: "'a heap \<Rightarrow> nat \<Rightarrow> bool"
	where "valid h i \<equiv> i>0 \<and> i\<le>length h"

	abbreviation \<alpha> :: "'a heap \<Rightarrow> 'a multiset" where "\<alpha> \<equiv> mset"


	lemma valid_empty[simp]: "\<not>valid [] i" by (auto simp: valid_def)
	lemma valid0[simp]: "\<not>valid h 0" by (auto simp: valid_def)
	lemma valid_glen[simp]: "i>length h \<Longrightarrow> \<not>valid h i" by (auto simp: valid_def)

	lemma valid_len[simp]: "h\<noteq>[] \<Longrightarrow> valid h (length h)" by (auto simp: valid_def)

	lemma validI: "0<i \<Longrightarrow> i\<le>length h \<Longrightarrow> valid h i"
	by (auto simp: valid_def)

	definition val_of :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a" where "val_of l i \<equiv> l!(i-1)"
	abbreviation prio_of :: "'a heap \<Rightarrow> nat \<Rightarrow> 'b" where
	"prio_of l i \<equiv> prio (val_of l i)"

	subsubsection \<open>Navigating the tree\<close>

	definition parent :: "nat \<Rightarrow> nat" where "parent i \<equiv> i div 2"
	definition left :: "nat \<Rightarrow> nat" where "left i \<equiv> 2*i"
	definition right :: "nat \<Rightarrow> nat" where "right i \<equiv> 2*i + 1"

	abbreviation "has_parent h i \<equiv> valid h (parent i)"
	abbreviation "has_left h i \<equiv> valid h (left i)"
	abbreviation "has_right h i \<equiv> valid h (right i)"

	abbreviation "vparent h i == val_of h (parent i)"
	abbreviation "vleft h i == val_of h (left i)"
	abbreviation "vright h i == val_of h (right i)"

	abbreviation "pparent h i == prio_of h (parent i)"
	abbreviation "pleft h i == prio_of h (left i)"
	abbreviation "pright h i == prio_of h (right i)"

	lemma parent_left_id[simp]: "parent (left i) = i"
	unfolding parent_def left_def
	by auto

	lemma parent_right_id[simp]: "parent (right i) = i"
	unfolding parent_def right_def
	by auto

	lemma child_of_parentD:
	"has_parent l i \<Longrightarrow> left (parent i) = i \<or> right (parent i) = i"
	unfolding parent_def left_def right_def valid_def
	by auto

	lemma rc_imp_lc: "\<lbrakk>valid h i; has_right h i\<rbrakk> \<Longrightarrow> has_left h i"
	by (auto simp: valid_def left_def right_def)

	lemma plr_corner_cases[simp]:
	assumes "0<i"
	shows
	"i\<noteq>parent i"
	"i\<noteq>left i"
	"i\<noteq>right i"
	"parent i \<noteq> i"
	"left i \<noteq> i"
	"right i \<noteq> i"
	using assms
	by (auto simp: parent_def left_def right_def)

	lemma i_eq_parent_conv[simp]: "i=parent i \<longleftrightarrow> i=0"
	by (auto simp: parent_def)

	subsubsection \<open>Heap Property\<close>
	text \<open>The heap property states, that every node's priority is greater
	or equal to its parent's priority \<close>
	definition heap_invar :: "'a heap \<Rightarrow> bool"
	where "heap_invar l
	\<equiv> \<forall>i. valid l i \<longrightarrow> has_parent l i \<longrightarrow> pparent l i \<le> prio_of l i"


	definition "heap_rel1 \<equiv> br \<alpha> heap_invar"

	lemma heap_invar_empty[simp]: "heap_invar []"
	by (auto simp: heap_invar_def)

	function heap_induction_scheme :: "nat \<Rightarrow> unit" where
	"heap_induction_scheme i = (
	if i>1 then heap_induction_scheme (parent i) else ())"
	by pat_completeness auto

	termination
	apply (relation "less_than")
	apply (auto simp: parent_def)
	done

	lemma
	heap_parent_le: "\<lbrakk>heap_invar l; valid l i; has_parent l i\<rbrakk>
	\<Longrightarrow> pparent l i \<le> prio_of l i"
	unfolding heap_invar_def
	by auto

	lemma heap_min_prop:
	assumes H: "heap_invar h"
	assumes V: "valid h i"
	shows "prio_of h (Suc 0) \<le> prio_of h i"
	proof (cases "i>1")
	case False with V show ?thesis
	by (auto simp: valid_def intro: Suc_lessI)
	next
	case True
	from V have "i\<le>length h" "valid h (Suc 0)" by (auto simp: valid_def)
	with True show ?thesis
	apply (induction i rule: heap_induction_scheme.induct)
	apply (rename_tac i)
	apply (case_tac "parent i = Suc 0")
	apply (rule order_trans[rotated])
	apply (rule heap_parent_le[OF H])
	apply (auto simp: valid_def) [3]

	apply (rule order_trans)
	apply (rprems)
	apply (auto simp: parent_def) [4]
	apply (rule heap_parent_le[OF H])
	apply (auto simp: valid_def parent_def)
	done
	qed

	text \<open> Obviously, the heap property can also be stated in terms of children,
	i.e., each node's priority is smaller or equal to it's children's priority.\<close>

	definition "children_ge h p i \<equiv>
	(has_left h i \<longrightarrow> p \<le> pleft h i)
	\<and> (has_right h i \<longrightarrow> p \<le> pright h i)"

	definition "heap_invar' h \<equiv> \<forall>i. valid h i \<longrightarrow> children_ge h (prio_of h i) i"

	lemma heap_eq_heap':
	shows "heap_invar h \<longleftrightarrow> heap_invar' h"
	unfolding heap_invar_def
	unfolding heap_invar'_def children_ge_def
	apply rule
	apply auto []
	apply clarsimp
	apply (frule child_of_parentD)
	apply auto []
	done

	subsection \<open>Basic Operations\<close>
	text \<open>The basic operations are the only operations that directly
	modify the underlying data structure.\<close>
	subsubsection \<open>Val-Of\<close>
	abbreviation (input) "val_of_pre l i \<equiv> valid l i"
	definition val_of_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a nres"
	where "val_of_op l i \<equiv> ASSERT (i>0) \<then> mop_list_get l (i-1)"
	lemma val_of_correct[refine_vcg]:
	"val_of_pre l i \<Longrightarrow> val_of_op l i \<le> SPEC (\<lambda>r. r = val_of l i)"
	unfolding val_of_op_def val_of_def valid_def
	by refine_vcg auto

	abbreviation (input) "prio_of_pre \<equiv> val_of_pre"
	definition "prio_of_op l i \<equiv> do {v \<leftarrow> val_of_op l i; RETURN (prio v)}"
	lemma prio_of_op_correct[refine_vcg]:
	"prio_of_pre l i \<Longrightarrow> prio_of_op l i \<le> SPEC (\<lambda>r. r = prio_of l i)"
	unfolding prio_of_op_def
	apply refine_vcg by simp

	subsubsection \<open>Update\<close>
	abbreviation "update_pre h i v \<equiv> valid h i"
	definition update :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a heap"
	where "update h i v \<equiv> h[i - 1 := v]"
	definition update_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a heap nres"
	where "update_op h i v \<equiv> ASSERT (i>0) \<then> mop_list_set h (i-1) v"
	lemma update_correct[refine_vcg]:
	"update_pre h i v \<Longrightarrow> update_op h i v \<le> SPEC(\<lambda>r. r = update h i v)"
	unfolding update_op_def update_def valid_def by refine_vcg auto

	lemma update_valid[simp]: "valid (update h i v) j \<longleftrightarrow> valid h j"
	by (auto simp: update_def valid_def)

	lemma val_of_update[simp]: "\<lbrakk>update_pre h i v; valid h j\<rbrakk> \<Longrightarrow> val_of (update h i v) j = (
	if i=j then v else val_of h j)"
	unfolding update_def val_of_def
	by (auto simp: nth_list_update valid_def)

	lemma length_update[simp]: "length (update l i v) = length l"
	by (auto simp: update_def)

	subsubsection \<open>Exchange\<close>
	text \<open> Exchange two elements \<close>

	definition exch :: "'a heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a heap" where
	"exch l i j \<equiv> swap l (i - 1) (j - 1)"
	abbreviation "exch_pre l i j \<equiv> valid l i \<and> valid l j"

	definition exch_op :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list nres"
	where "exch_op l i j \<equiv> do {
	ASSERT (i>0 \<and> j>0);
	l \<leftarrow> mop_list_swap l (i - 1) (j - 1);
	RETURN l
	}"

	lemma exch_op_alt: "exch_op l i j = do {
	vi \<leftarrow> val_of_op l i;
	vj \<leftarrow> val_of_op l j;
	l \<leftarrow> update_op l i vj;
	l \<leftarrow> update_op l j vi;
	RETURN l }"
	by (auto simp: exch_op_def swap_def val_of_op_def update_op_def
	pw_eq_iff refine_pw_simps)

	lemma exch_op_correct[refine_vcg]:
	"exch_pre l i j \<Longrightarrow> exch_op l i j \<le> SPEC (\<lambda>r. r = exch l i j)"
	unfolding exch_op_def
	apply refine_vcg
	apply (auto simp: exch_def valid_def)
	done

	lemma valid_exch[simp]: "valid (exch l i j) k = valid l k"
	unfolding exch_def by (auto simp: valid_def)

	lemma val_of_exch[simp]: "\<lbrakk>valid l i; valid l j; valid l k\<rbrakk> \<Longrightarrow>
	val_of (exch l i j) k = (
	if k=i then val_of l j
	else if k=j then val_of l i
	else val_of l k
	)"
	unfolding exch_def val_of_def valid_def
	by (auto)

	lemma exch_eq[simp]: "exch h i i = h"
	by (auto simp: exch_def)

	lemma \<alpha>_exch[simp]: "\<lbrakk>valid l i; valid l j\<rbrakk>
	\<Longrightarrow> \<alpha> (exch l i j) = \<alpha> l"
	unfolding exch_def valid_def
	by (auto)

	lemma length_exch[simp]: "length (exch l i j) = length l"
	by (auto simp: exch_def)

	subsubsection \<open>Butlast\<close>
	text \<open>Remove last element\<close>

	abbreviation "butlast_pre l \<equiv> l\<noteq>[]"
	definition butlast_op :: "'a heap \<Rightarrow> 'a heap nres"
	where "butlast_op l \<equiv> mop_list_butlast l"
	lemma butlast_op_correct[refine_vcg]:
	"butlast_pre l \<Longrightarrow> butlast_op l \<le> SPEC (\<lambda>r. r = butlast l)"
	unfolding butlast_op_def by (refine_vcg; auto)

	lemma valid_butlast_conv[simp]: "valid (butlast h) i \<longleftrightarrow> valid h i \<and> i < length h"
	by (auto simp: valid_def)

	lemma valid_butlast: "valid (butlast h) i \<Longrightarrow> valid h i"
	by (cases h rule: rev_cases) (auto simp: valid_def)

	lemma val_of_butlast[simp]: "\<lbrakk>valid h i; i<length h\<rbrakk>
	\<Longrightarrow> val_of (butlast h) i = val_of h i"
	by (auto simp: valid_def val_of_def nth_butlast)

	lemma val_of_butlast'[simp]:
	"valid (butlast h) i \<Longrightarrow> val_of (butlast h) i = val_of h i"
	by (cases h rule: rev_cases) (auto simp: valid_def val_of_def nth_append)

	lemma \<alpha>_butlast[simp]: "\<lbrakk> length h \<noteq> 0 \<rbrakk>
	\<Longrightarrow> \<alpha> (butlast h) = \<alpha> h - {# val_of h (length h)#}"
	apply (cases h rule: rev_cases)
	apply (auto simp: val_of_def)
	done

	lemma heap_invar_butlast[simp]: "heap_invar h \<Longrightarrow> heap_invar (butlast h)"
	apply (cases "h = []")
	apply simp
	apply (auto simp: heap_invar_def dest: valid_butlast)
	done

	subsubsection \<open>Append\<close>
	definition append_op :: "'a heap \<Rightarrow> 'a \<Rightarrow> 'a heap nres"
	where "append_op l v \<equiv> mop_list_append l v"
	lemma append_op_correct[refine_vcg]:
	"append_op l v \<le> SPEC (\<lambda>r. r = l@[v])"
	unfolding append_op_def by (refine_vcg; auto)


	lemma valid_append[simp]: "valid (l@[v]) i \<longleftrightarrow> valid l i \<or> i = length l + 1"
	by (auto simp: valid_def)

	lemma val_of_append[simp]: "valid (l@[v]) i \<Longrightarrow>
	val_of (l@[v]) i = (if valid l i then val_of l i else v)"
	unfolding valid_def val_of_def by (auto simp: nth_append)

	lemma \<alpha>_append[simp]: "\<alpha> (l@[v]) = \<alpha> l + {#v#}"
	- by (auto simp: )
	+ by auto

	subsection \<open>Auxiliary operations\<close>
	text \<open>The auxiliary operations do not have a corresponding abstract operation, but
	are to restore the heap property after modification.\<close>
	subsubsection \<open>Swim\<close>

	text \<open>This invariant expresses that the heap has a single defect,
	which can be repaired by swimming up\<close>
	definition swim_invar :: "'a heap \<Rightarrow> nat \<Rightarrow> bool"
	where "swim_invar h i \<equiv>
	valid h i
	\<and> (\<forall>j. valid h j \<and> has_parent h j \<and> j\<noteq>i \<longrightarrow> pparent h j \<le> prio_of h j)
	\<and> (has_parent h i \<longrightarrow>
	(\<forall>j. valid h j \<and> has_parent h j \<and> parent j = i
	\<longrightarrow> pparent h i \<le> prio_of h j))"

	text \<open>Move up an element that is too small, until it fits\<close>
	definition swim_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a heap nres" where
	"swim_op h i \<equiv> do {
	RECT (\<lambda>swim (h,i). do {
	ASSERT (valid h i \<and> swim_invar h i);
	if has_parent h i then do {
	ppi \<leftarrow> prio_of_op h (parent i);
	pi \<leftarrow> prio_of_op h i;
	if (\<not>ppi \<le> pi) then do {
	h \<leftarrow> exch_op h i (parent i);
	swim (h, parent i)
	} else
	RETURN h
	} else
	RETURN h
	}) (h,i)
	}"

	lemma swim_invar_valid: "swim_invar h i \<Longrightarrow> valid h i"
	unfolding swim_invar_def by simp

	lemma swim_invar_exit1: "\<not>has_parent h i \<Longrightarrow> swim_invar h i \<Longrightarrow> heap_invar h"
	unfolding heap_invar_def swim_invar_def by auto

	lemma swim_invar_exit2: "pparent h i \<le> prio_of h i \<Longrightarrow> swim_invar h i \<Longrightarrow> heap_invar h"
	unfolding heap_invar_def swim_invar_def by auto

	lemma swim_invar_pres:
	assumes HPI: "has_parent h i"
	assumes VIOLATED: "pparent h i > prio_of h i"
	and INV: "swim_invar h i"
	defines "h' \<equiv> exch h i (parent i)"
	shows "swim_invar h' (parent i)"
	unfolding swim_invar_def
	apply safe
	apply (simp add: h'_def HPI)

	using HPI VIOLATED INV
	unfolding swim_invar_def h'_def
	apply auto []

	using HPI VIOLATED INV
	unfolding swim_invar_def h'_def
	apply auto
	by (metis order_trans)


	lemma swim_invar_decr:
	assumes INV: "heap_invar h"
	assumes V: "valid h i"
	assumes DECR: "prio v \<le> prio_of h i"
	shows "swim_invar (update h i v) i"
	using INV V DECR
	apply (auto simp: swim_invar_def heap_invar_def intro: dual_order.trans)
	done

	lemma swim_op_correct[refine_vcg]:
	"\<lbrakk>swim_invar h i\<rbrakk> \<Longrightarrow>
	swim_op h i \<le> SPEC (\<lambda>h'. \<alpha> h' = \<alpha> h \<and> heap_invar h' \<and> length h' = length h)"
	unfolding swim_op_def
	using [[goals_limit = 1]]
	apply (refine_vcg RECT_rule[where
	pre="\<lambda>(hh,i).
	swim_invar hh i
	\<and> \<alpha> hh = \<alpha> h
	\<and> length hh = length h" and
	V = "inv_image less_than snd"
	])
	apply (auto) []
	apply (auto) []
	apply (auto) []
	apply (auto) []
	apply (auto simp: swim_invar_valid) []
	apply (auto) []
	apply (auto) []
	apply (auto) []

	apply rprems
	apply (auto simp: swim_invar_pres) []
	apply (auto simp: parent_def valid_def) []

	apply (auto) []
	apply (auto simp: swim_invar_exit2) []
	apply (auto) []
	apply (auto) []
	apply (auto simp: swim_invar_exit1) []
	apply (auto) []
	done



	subsubsection \<open>Sink\<close>
	text \<open>Move down an element that is too big, until it fits in\<close>

	definition sink_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a heap nres" where
	"sink_op h i \<equiv> do {
	RECT (\<lambda>sink (h,i). do {
	ASSERT (valid h i);
	if has_right h i then do {
	ASSERT (has_left h i);
	lp \<leftarrow> prio_of_op h (left i);
	rp \<leftarrow> prio_of_op h (right i);
	p \<leftarrow> prio_of_op h i;
	if (lp < p \<and> rp \<ge> lp) then do {
	h \<leftarrow> exch_op h i (left i);
	sink (h,left i)
	} else if (rp<lp \<and> rp < p) then do {
	h \<leftarrow> exch_op h i (right i);
	sink (h,right i)
	} else
	RETURN h
	} else if (has_left h i) then do {
	lp \<leftarrow> prio_of_op h (left i);
	p \<leftarrow> prio_of_op h i;
	if (lp < p) then do {
	h \<leftarrow> exch_op h i (left i);
	sink (h,left i)
	} else
	RETURN h

	} else
	RETURN h
	}) (h,i)
	}"

	text \<open>This invariant expresses that the heap has a single defect,
	which can be repaired by sinking\<close>
	definition "sink_invar l i \<equiv>
	valid l i
	\<and> (\<forall>j. valid l j \<and> j\<noteq>i \<longrightarrow> children_ge l (prio_of l j) j)
	\<and> (has_parent l i \<longrightarrow> children_ge l (pparent l i) i)"

	lemma sink_invar_valid: "sink_invar l i \<Longrightarrow> valid l i"
	unfolding sink_invar_def by auto

	lemma sink_invar_exit: "\<lbrakk>sink_invar l i; children_ge l (prio_of l i) i\<rbrakk>
	\<Longrightarrow> heap_invar' l"
	unfolding heap_invar'_def sink_invar_def
	by auto

	lemma sink_aux1: "\<not> (2*i \<le> length h) \<Longrightarrow> \<not>has_left h i \<and> \<not>has_right h i"
	unfolding valid_def left_def right_def by auto

	lemma sink_invar_pres1:
	assumes "sink_invar h i"
	assumes "has_left h i" "has_right h i"
	assumes "prio_of h i \<ge> pleft h i"
	assumes "pleft h i \<ge> pright h i"
	shows "sink_invar (exch h i (right i)) (right i)"
	using assms
	unfolding sink_invar_def
	apply auto
	apply (auto simp: children_ge_def)
	done

	lemma sink_invar_pres2:
	assumes "sink_invar h i"
	assumes "has_left h i" "has_right h i"
	assumes "prio_of h i \<ge> pleft h i"
	assumes "pleft h i \<le> pright h i"
	shows "sink_invar (exch h i (left i)) (left i)"
	using assms
	unfolding sink_invar_def
	apply auto
	apply (auto simp: children_ge_def)
	done

	lemma sink_invar_pres3:
	assumes "sink_invar h i"
	assumes "has_left h i" "has_right h i"
	assumes "prio_of h i \<ge> pright h i"
	assumes "pleft h i \<le> pright h i"
	shows "sink_invar (exch h i (left i)) (left i)"
	using assms
	unfolding sink_invar_def
	apply auto
	apply (auto simp: children_ge_def)
	done

	lemma sink_invar_pres4:
	assumes "sink_invar h i"
	assumes "has_left h i" "has_right h i"
	assumes "prio_of h i \<ge> pright h i"
	assumes "pleft h i \<ge> pright h i"
	shows "sink_invar (exch h i (right i)) (right i)"
	using assms
	unfolding sink_invar_def
	apply auto
	apply (auto simp: children_ge_def)
	done

	lemma sink_invar_pres5:
	assumes "sink_invar h i"
	assumes "has_left h i" "\<not>has_right h i"
	assumes "prio_of h i \<ge> pleft h i"
	shows "sink_invar (exch h i (left i)) (left i)"
	using assms
	unfolding sink_invar_def
	apply auto
	apply (auto simp: children_ge_def)
	done

	lemmas sink_invar_pres =
	sink_invar_pres1
	sink_invar_pres2
	sink_invar_pres3
	sink_invar_pres4
	sink_invar_pres5


	lemma sink_invar_incr:
	assumes INV: "heap_invar h"
	assumes V: "valid h i"
	assumes INCR: "prio v \<ge> prio_of h i"
	shows "sink_invar (update h i v) i"
	using INV V INCR
	apply (auto simp: sink_invar_def)
	apply (auto simp: children_ge_def heap_invar_def) []
	apply (auto simp: children_ge_def heap_invar_def intro: order_trans) []
	apply (frule spec[where x="left i"])
	apply auto []
	apply (frule spec[where x="right i"])
	apply auto []
	done


	lemma sink_op_correct[refine_vcg]:
	"\<lbrakk>sink_invar h i\<rbrakk> \<Longrightarrow>
	sink_op h i \<le> SPEC (\<lambda>h'. \<alpha> h' = \<alpha> h \<and> heap_invar h' \<and> length h' = length h)"
	unfolding sink_op_def heap_eq_heap'
	using [[goals_limit = 1]]

	apply (refine_vcg RECT_rule[where
	pre="\<lambda>(hh,i). sink_invar hh i \<and> \<alpha> hh = \<alpha> h \<and> length hh = length h" and
	V = "measure (\<lambda>(l,i). length l - i)"
	])

	apply (auto) []
	apply (auto) []
	apply (auto) []
	apply (auto) []
	apply (auto simp: sink_invar_valid) []
	apply (auto simp: valid_def left_def right_def) []

	apply rprems
	apply (auto intro: sink_invar_pres) []
	apply (auto simp: valid_def left_def right_def) []

	apply rprems
	apply (auto intro: sink_invar_pres) []
	apply (auto simp: valid_def left_def right_def) []

	apply (auto) []

	apply clarsimp
	apply (rule sink_invar_exit, assumption) []
	apply (auto simp: children_ge_def) []

	apply (auto) []

	apply rprems
	apply (auto intro: sink_invar_pres) []
	apply (auto simp: valid_def left_def right_def) []

	apply (auto) []

	apply clarsimp
	apply (rule sink_invar_exit, assumption) []
	apply (auto simp: children_ge_def) []

	apply (auto) []

	apply (auto) []

	apply clarsimp
	apply (rule sink_invar_exit, assumption) []
	apply (auto simp: children_ge_def) []

	apply (auto) []
	done

	lemma sink_op_swim_rule:
	"swim_invar h i \<Longrightarrow> sink_op h i \<le> SPEC (\<lambda>h'. h'=h)"
	apply (frule swim_invar_valid)
	unfolding sink_op_def
	apply (subst RECT_unfold, refine_mono)
	apply (fold sink_op_def)
	apply refine_vcg
	apply (simp_all)
	apply (auto simp add: valid_def left_def right_def dest: swim_invar_valid) []
	apply (auto simp: swim_invar_def) []
	apply (auto simp: swim_invar_def) []
	apply (auto simp: swim_invar_def) []
	apply (auto simp: swim_invar_def) []
	apply (auto simp: swim_invar_def) []
	apply (auto simp: swim_invar_def) []
	done

	definition sink_op_opt
	\<comment> \<open>Sink operation as presented in Sedgewick et al. Algs4 reference implementation\<close>
	where
	"sink_op_opt h k \<equiv> RECT (\<lambda>D (h,k). do {
	ASSERT (k>0 \<and> k\<le>length h);
	let len = length h;
	if (2*k \<le> len) then do {
	let j = 2*k;
	pj \<leftarrow> prio_of_op h j;

	j \<leftarrow> (
	if j<len then do {
	psj \<leftarrow> prio_of_op h (Suc j);
	if pj>psj then RETURN (j+1) else RETURN j
	} else RETURN j);

	pj \<leftarrow> prio_of_op h j;
	pk \<leftarrow> prio_of_op h k;
	if (pk > pj) then do {
	h \<leftarrow> exch_op h k j;
	D (h,j)
	} else
	RETURN h
	} else RETURN h
	}) (h,k)"

	lemma sink_op_opt_eq: "sink_op_opt h k = sink_op h k"
	unfolding sink_op_opt_def sink_op_def
	apply (fo_rule arg_cong fun_cong)+
	apply (intro ext)
	unfolding sink_op_def[symmetric]
	apply (simp cong: if_cong split del: if_split add: Let_def)

	apply (auto simp: valid_def left_def right_def prio_of_op_def val_of_op_def
	val_of_def less_imp_diff_less ASSERT_same_eq_conv nz_le_conv_less) []
	done

	subsubsection \<open>Repair\<close>
	text \<open>Repair a local defect in the heap. This can be done
	by swimming and sinking. Note that, depending on the defect, only one
	of the operations will change the heap.
	Moreover, note that we do not need repair to implement the heap operations.
	However, it is required for heapmaps. \<close>

	definition "repair_op h i \<equiv> do {
	h \<leftarrow> sink_op h i;
	h \<leftarrow> swim_op h i;
	RETURN h
	}"

	lemma update_sink_swim_cases:
	assumes "heap_invar h"
	assumes "valid h i"
	obtains "swim_invar (update h i v) i" \| "sink_invar (update h i v) i"
	apply (cases rule: linear[of "prio v" "prio_of h i", THEN disjE])
	apply (blast dest: swim_invar_decr[OF assms])
	apply (blast dest: sink_invar_incr[OF assms])
	done

	lemma heap_invar_imp_swim_invar: "\<lbrakk>heap_invar h; valid h i\<rbrakk> \<Longrightarrow> swim_invar h i"
	unfolding heap_invar_def swim_invar_def
	by (auto intro: order_trans)


	lemma repair_correct[refine_vcg]:
	assumes "heap_invar h" and "valid h i"
	shows "repair_op (update h i v) i \<le> SPEC (\<lambda>h'.
	heap_invar h' \<and> \<alpha> h' = \<alpha> (update h i v) \<and> length h' = length h)"
	apply (rule update_sink_swim_cases[of h i v, OF assms])
	unfolding repair_op_def
	apply (refine_vcg sink_op_swim_rule)
	apply auto [4]
	apply (refine_vcg)
	using assms(2)
	apply (auto intro: heap_invar_imp_swim_invar simp: valid_def) []
	apply auto [3]
	done

	subsection \<open>Operations\<close>

	(*
	subsubsection \<open>Length\<close>
	definition length_op :: "'a heap \<Rightarrow> nat nres" where "length_op \<equiv> lst_op_length"

	lemma [refine_vcg]: "length_op l \<le> SPEC (\<lambda>r. r = length l)"
	unfolding length_op_def
	by refine_vcg
	*)

	subsubsection \<open>Empty\<close>
	abbreviation (input) empty :: "'a heap" \<comment> \<open>The empty heap\<close>
	where "empty \<equiv> []"
	definition empty_op :: "'a heap nres"
	where "empty_op \<equiv> mop_list_empty"
	lemma empty_op_correct[refine_vcg]:
	"empty_op \<le> SPEC (\<lambda>r. \<alpha> r = {#} \<and> heap_invar r)"
	unfolding empty_op_def apply refine_vcg by auto

	subsubsection \<open>Emptiness check\<close>
	definition is_empty_op :: "'a heap \<Rightarrow> bool nres" \<comment> \<open>Check for emptiness\<close>
	where "is_empty_op h \<equiv> do {ASSERT (heap_invar h); let l=length h; RETURN (l=0)}"
	lemma is_empty_op_correct[refine_vcg]:
	"heap_invar h \<Longrightarrow> is_empty_op h \<le> SPEC (\<lambda>r. r\<longleftrightarrow>\<alpha> h = {#})"
	unfolding is_empty_op_def
	apply refine_vcg by auto

	subsubsection \<open>Insert\<close>
	definition insert_op :: "'a \<Rightarrow> 'a heap \<Rightarrow> 'a heap nres" \<comment> \<open>Insert element\<close>
	where "insert_op v h \<equiv> do {
	ASSERT (heap_invar h);
	h \<leftarrow> append_op h v;
	let l = length h;
	h \<leftarrow> swim_op h l;
	RETURN h
	}"

	lemma swim_invar_insert: "heap_invar l \<Longrightarrow> swim_invar (l@[x]) (Suc (length l))"
	unfolding swim_invar_def heap_invar_def valid_def parent_def val_of_def
	by (fastforce simp: nth_append)

	lemma
	"(insert_op,RETURN oo op_mset_insert) \<in> Id \<rightarrow> heap_rel1 \<rightarrow> \<langle>heap_rel1\<rangle>nres_rel"
	unfolding insert_op_def[abs_def] heap_rel1_def o_def
	by refine_vcg (auto simp: swim_invar_insert in_br_conv)

	lemma insert_op_correct:
	"heap_invar h \<Longrightarrow> insert_op v h \<le> SPEC (\<lambda>h'. heap_invar h' \<and> \<alpha> h' = \<alpha> h + {#v#})"
	unfolding insert_op_def
	by (refine_vcg) (auto simp: swim_invar_insert)
	lemmas [refine_vcg] = insert_op_correct

	subsubsection \<open>Pop minimum element\<close>

	definition pop_min_op :: "'a heap \<Rightarrow> ('a \<times> 'a heap) nres" where
	"pop_min_op h \<equiv> do {
	ASSERT (heap_invar h);
	ASSERT (valid h 1);
	m \<leftarrow> val_of_op h 1;
	let l = length h;
	h \<leftarrow> exch_op h 1 l;
	h \<leftarrow> butlast_op h;

	if (l\<noteq>1) then do {
	h \<leftarrow> sink_op h 1;
	RETURN (m,h)
	} else RETURN (m,h)
	}"


	lemma left_not_one[simp]: "left j \<noteq> Suc 0"
	by (auto simp: left_def)

	lemma right_one_conv[simp]: "right j = Suc 0 \<longleftrightarrow> j=0"
	by (auto simp: right_def)

	lemma parent_one_conv[simp]: "parent (Suc 0) = 0"
	by (auto simp: parent_def)

	lemma sink_invar_init:
	assumes I: "heap_invar h"
	assumes NE: "length h > 1"
	shows "sink_invar (butlast (exch h (Suc 0) (length h))) (Suc 0)"
	proof -
	from NE have V: "valid h (Suc 0)" "valid h (length h)"
	apply -
	apply (auto simp: valid_def neq_Nil_conv) []
	by (cases h) (auto simp: valid_def)

	show ?thesis using I
	unfolding heap_eq_heap' heap_invar'_def sink_invar_def
	apply (intro impI conjI allI)
	using NE apply (auto simp: V valid_butlast_conv) []
	apply (auto simp add: children_ge_def V NE valid_butlast_conv) []
	apply (auto simp add: children_ge_def V NE valid_butlast_conv) []
	done
	qed

	lemma in_set_conv_val: "v \<in> set h \<longleftrightarrow> (\<exists>i. valid h i \<and> v = val_of h i)"
	apply (rule iffI)
	apply (clarsimp simp add: valid_def val_of_def in_set_conv_nth)
	apply (rule_tac x="Suc i" in exI; auto)
	apply (clarsimp simp add: valid_def val_of_def in_set_conv_nth)
	apply (rule_tac x="i - Suc 0" in exI; auto)
	done


	lemma pop_min_op_correct:
	assumes "heap_invar h" "\<alpha> h \<noteq> {#}"
	shows "pop_min_op h \<le> SPEC (\<lambda>(v,h'). heap_invar h' \<and>
	v \<in># \<alpha> h \<and> \<alpha> h' = \<alpha> h - {#v#} \<and> (\<forall>v'\<in>set_mset (\<alpha> h). prio v \<le> prio v'))"
	proof -
	note [simp del] = length_greater_0_conv
	note LG = length_greater_0_conv[symmetric]

	from assms show ?thesis
	unfolding pop_min_op_def
	apply refine_vcg
	apply (simp_all add: sink_invar_init LG)
	apply (auto simp: valid_def) []
	apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
	apply (auto simp: in_set_conv_val simp: heap_min_prop) []
	apply auto []
	apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
	apply auto []
	apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
	done
	qed

	lemmas [refine_vcg] = pop_min_op_correct

	subsubsection \<open>Peek minimum element\<close>

	definition peek_min_op :: "'a heap \<Rightarrow> 'a nres" where
	"peek_min_op h \<equiv> do {
	ASSERT (heap_invar h);
	ASSERT (valid h 1);
	val_of_op h 1
	}"

	lemma peek_min_op_correct:
	assumes "heap_invar h" "\<alpha> h \<noteq> {#}"
	shows "peek_min_op h \<le> SPEC (\<lambda>v.
	v \<in># \<alpha> h \<and> (\<forall>v'\<in>set_mset (\<alpha> h). prio v \<le> prio v'))"
	unfolding peek_min_op_def
	apply refine_vcg
	using assms
	apply clarsimp_all
	apply (auto simp: valid_def) []
	apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
	apply (auto simp: in_set_conv_val simp: heap_min_prop) []
	done

	lemmas peek_min_op_correct'[refine_vcg] = peek_min_op_correct


	subsection \<open>Operations as Relator-Style Refinement\<close>

	lemma empty_op_refine: "(empty_op,RETURN op_mset_empty)\<in>\<langle>heap_rel1\<rangle>nres_rel"
	apply (rule nres_relI)
	apply (rule order_trans)
	apply (rule empty_op_correct)
	apply (auto simp: heap_rel1_def br_def pw_le_iff refine_pw_simps)
	done

	lemma is_empty_op_refine: "(is_empty_op,RETURN o op_mset_is_empty) \<in> heap_rel1 \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	apply (intro nres_relI fun_relI; simp)
	apply refine_vcg
	apply (auto simp: heap_rel1_def br_def)
	done

	lemma insert_op_refine: "(insert_op,RETURN oo op_mset_insert) \<in> Id \<rightarrow> heap_rel1 \<rightarrow> \<langle>heap_rel1\<rangle>nres_rel"
	apply (intro nres_relI fun_relI; simp)
	apply (refine_vcg RETURN_as_SPEC_refine)
	apply (auto simp: heap_rel1_def br_def pw_le_iff refine_pw_simps)
	done

	lemma pop_min_op_refine:
	"(pop_min_op, PR_CONST (mop_prio_pop_min prio)) \<in> heap_rel1 \<rightarrow> \<langle>Id \<times>\<^sub>r heap_rel1\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding mop_prio_pop_min_def PR_CONST_def
	apply (refine_vcg SPEC_refine)
	apply (auto simp: heap_rel1_def br_def)
	done

	lemma peek_min_op_refine:
	"(peek_min_op, PR_CONST (mop_prio_peek_min prio)) \<in> heap_rel1 \<rightarrow> \<langle>Id\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding mop_prio_peek_min_def PR_CONST_def
	apply (refine_vcg RES_refine)
	apply (auto simp: heap_rel1_def br_def)
	done


	end

	end

	diff --git a/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heapmap.thy b/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heapmap.thy
	--- a/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heapmap.thy
	+++ b/thys/Refine_Imperative_HOL/IICF/Impl/Heaps/IICF_Abs_Heapmap.thy
	@@ -1,1214 +1,1214 @@
	section \<open>Priority Maps implemented with List and Map\<close>
	theory IICF_Abs_Heapmap
	imports IICF_Abs_Heap "HOL-Library.Rewrite" "../../Intf/IICF_Prio_Map"
	begin

	type_synonym ('k,'v) ahm = "'k list \<times> ('k \<rightharpoonup> 'v)"

	subsection \<open>Basic Setup\<close>

	text \<open>First, we define a mapping to list-based heaps\<close>
	definition hmr_\<alpha> :: "('k,'v) ahm \<Rightarrow> 'v heap" where
	"hmr_\<alpha> \<equiv> \<lambda>(pq,m). map (the o m) pq"

	definition "hmr_invar \<equiv> \<lambda>(pq,m). distinct pq \<and> dom m = set pq"

	definition "hmr_rel \<equiv> br hmr_\<alpha> hmr_invar"

	lemmas hmr_rel_defs = hmr_rel_def br_def hmr_\<alpha>_def hmr_invar_def

	lemma hmr_empty_invar[simp]: "hmr_invar ([],Map.empty)"
	by (auto simp: hmr_invar_def)


	locale hmstruct = h: heapstruct prio for prio :: "'v \<Rightarrow> 'b::linorder"
	begin

	text \<open>Next, we define a mapping to priority maps.\<close>

	definition heapmap_\<alpha> :: "('k,'v) ahm \<Rightarrow> ('k \<rightharpoonup> 'v)" where
	"heapmap_\<alpha> \<equiv> \<lambda>(pq,m). m"

	definition heapmap_invar :: "('k,'v) ahm \<Rightarrow> bool" where
	"heapmap_invar \<equiv> \<lambda>hm. hmr_invar hm \<and> h.heap_invar (hmr_\<alpha> hm)"

	definition "heapmap_rel \<equiv> br heapmap_\<alpha> heapmap_invar"

	lemmas heapmap_rel_defs = heapmap_rel_def br_def heapmap_\<alpha>_def heapmap_invar_def

	lemma [refine_dref_RELATES]: "RELATES hmr_rel" by (simp add: RELATES_def)


	lemma h_heap_invarI[simp]: "heapmap_invar hm \<Longrightarrow> h.heap_invar (hmr_\<alpha> hm)"
	by (simp add: heapmap_invar_def)

	lemma hmr_invarI[simp]: "heapmap_invar hm \<Longrightarrow> hmr_invar hm"
	unfolding heapmap_invar_def by blast



	lemma set_hmr_\<alpha>[simp]: "hmr_invar hm \<Longrightarrow> set (hmr_\<alpha> hm) = ran (heapmap_\<alpha> hm)"
	apply (clarsimp simp: hmr_\<alpha>_def hmr_invar_def heapmap_\<alpha>_def
	eq_commute[of "dom _" "set _"] ran_def)
	apply force
	done

	lemma in_h_hmr_\<alpha>_conv[simp]: "hmr_invar hm \<Longrightarrow> x \<in># h.\<alpha> (hmr_\<alpha> hm) \<longleftrightarrow> x \<in> ran (heapmap_\<alpha> hm)"
	by (force simp: hmr_\<alpha>_def hmr_invar_def heapmap_\<alpha>_def in_multiset_in_set ran_is_image)

	subsection \<open>Basic Operations\<close>
	(* length, val_of_op, update, butlast, append, empty *)

	text \<open>In this section, we define the basic operations on heapmaps,
	and their relations to heaps and maps.\<close>

	subsubsection \<open>Length\<close>
	text \<open>Length of the list that represents the heap\<close>
	definition hm_length :: "('k,'v) ahm \<Rightarrow> nat" where
	"hm_length \<equiv> \<lambda>(pq,_). length pq"

	lemma hm_length_refine: "(hm_length, length) \<in> hmr_rel \<rightarrow> nat_rel"
	apply (intro fun_relI)
	unfolding hm_length_def
	by (auto simp: hmr_rel_defs)

	lemma hm_length_hmr_\<alpha>[simp]: "length (hmr_\<alpha> hm) = hm_length hm"
	by (auto simp: hm_length_def hmr_\<alpha>_def split: prod.splits)

	lemmas [refine] = hm_length_refine[param_fo]

	subsubsection \<open>Valid\<close>
	text \<open>Check whether index is valid\<close>
	definition "hm_valid hm i \<equiv> i>0 \<and> i\<le> hm_length hm"

	lemma hm_valid_refine: "(hm_valid,h.valid)\<in>hmr_rel \<rightarrow> nat_rel \<rightarrow> bool_rel"
	apply (intro fun_relI)
	unfolding hm_valid_def h.valid_def
	by (parametricity add: hm_length_refine)

	lemma hm_valid_hmr_\<alpha>[simp]: "h.valid (hmr_\<alpha> hm) = hm_valid hm"
	by (intro ext) (auto simp: h.valid_def hm_valid_def)

	subsubsection \<open>Key-Of\<close>
	definition hm_key_of :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'k" where
	"hm_key_of \<equiv> \<lambda>(pq,m) i. pq!(i - 1)"

	definition hm_key_of_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'k nres" where
	"hm_key_of_op \<equiv> \<lambda>(pq,m) i. ASSERT (i>0) \<then> mop_list_get pq (i - 1)"

	lemma hm_key_of_op_unfold:
	shows "hm_key_of_op hm i = ASSERT (hm_valid hm i) \<then> RETURN (hm_key_of hm i)"
	unfolding hm_valid_def hm_length_def hm_key_of_op_def hm_key_of_def
	by (auto split: prod.splits simp: pw_eq_iff refine_pw_simps)

	lemma val_of_hmr_\<alpha>[simp]: "hm_valid hm i \<Longrightarrow> h.val_of (hmr_\<alpha> hm) i
	= the (heapmap_\<alpha> hm (hm_key_of hm i))"
	by (auto
	simp: hmr_\<alpha>_def h.val_of_def heapmap_\<alpha>_def hm_key_of_def hm_valid_def hm_length_def
	split: prod.splits)

	lemma hm_\<alpha>_key_ex[simp]:
	"\<lbrakk>hmr_invar hm; hm_valid hm i\<rbrakk> \<Longrightarrow> (heapmap_\<alpha> hm (hm_key_of hm i) \<noteq> None)"
	unfolding heapmap_invar_def hmr_invar_def hm_valid_def heapmap_\<alpha>_def
	hm_key_of_def hm_length_def
	by (auto split: prod.splits)

	subsubsection \<open>Lookup\<close>
	abbreviation (input) hm_lookup where "hm_lookup \<equiv> heapmap_\<alpha>"

	definition "hm_the_lookup_op hm k \<equiv>
	ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> hmr_invar hm)
	\<then> RETURN (the (heapmap_\<alpha> hm k))"


	subsubsection \<open>Exchange\<close>
	text \<open>Exchange two indices\<close>

	definition "hm_exch_op \<equiv> \<lambda>(pq,m) i j. do {
	ASSERT (hm_valid (pq,m) i);
	ASSERT (hm_valid (pq,m) j);
	ASSERT (hmr_invar (pq,m));
	pq \<leftarrow> mop_list_swap pq (i - 1) (j - 1);
	RETURN (pq,m)
	}"

	lemma hm_exch_op_invar: "hm_exch_op hm i j \<le>\<^sub>n SPEC hmr_invar"
	unfolding hm_exch_op_def h.exch_op_def h.val_of_op_def h.update_op_def
	apply simp
	apply refine_vcg
	apply (auto simp: hm_valid_def map_swap hm_length_def hmr_rel_defs)
	done

	lemma hm_exch_op_refine: "(hm_exch_op,h.exch_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_exch_op_def h.exch_op_def h.val_of_op_def h.update_op_def
	apply simp
	apply refine_vcg
	apply (auto simp: hm_valid_def map_swap hm_length_def hmr_rel_defs)
	done

	lemmas hm_exch_op_refine'[refine] = hm_exch_op_refine[param_fo, THEN nres_relD]

	definition hm_exch :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('k,'v) ahm"
	where "hm_exch \<equiv> \<lambda>(pq,m) i j. (swap pq (i-1) (j-1),m)"


	lemma hm_exch_op_\<alpha>_correct: "hm_exch_op hm i j \<le>\<^sub>n SPEC (\<lambda>hm'.
	hm_valid hm i \<and> hm_valid hm j \<and> hm'=hm_exch hm i j
	)"
	unfolding hm_exch_op_def
	apply refine_vcg
	apply (vc_solve simp: hm_valid_def hm_length_def heapmap_\<alpha>_def solve: asm_rl)
	apply (auto simp add: hm_key_of_def hm_exch_def swap_def) []
	done

	lemma hm_exch_\<alpha>[simp]: "heapmap_\<alpha> (hm_exch hm i j) = (heapmap_\<alpha> hm)"
	by (auto simp: heapmap_\<alpha>_def hm_exch_def split: prod.splits)
	lemma hm_exch_valid[simp]: "hm_valid (hm_exch hm i j) = hm_valid hm"
	by (intro ext) (auto simp: hm_valid_def hm_length_def hm_exch_def split: prod.splits)
	lemma hm_exch_length[simp]: "hm_length (hm_exch hm i j) = hm_length hm"
	by (auto simp: hm_length_def hm_exch_def split: prod.splits)

	lemma hm_exch_same[simp]: "hm_exch hm i i = hm"
	by (auto simp: hm_exch_def split: prod.splits)


	lemma hm_key_of_exch_conv[simp]:
	"\<lbrakk>hm_valid hm i; hm_valid hm j; hm_valid hm k\<rbrakk> \<Longrightarrow>
	hm_key_of (hm_exch hm i j) k = (
	if k=i then hm_key_of hm j
	else if k=j then hm_key_of hm i
	else hm_key_of hm k
	)"
	unfolding hm_exch_def hm_valid_def hm_length_def hm_key_of_def
	by (auto split: prod.splits)

	lemma hm_key_of_exch_matching[simp]:
	"\<lbrakk>hm_valid hm i; hm_valid hm j\<rbrakk> \<Longrightarrow> hm_key_of (hm_exch hm i j) i = hm_key_of hm j"
	"\<lbrakk>hm_valid hm i; hm_valid hm j\<rbrakk> \<Longrightarrow> hm_key_of (hm_exch hm i j) j = hm_key_of hm i"
	by simp_all

	subsubsection \<open>Index\<close>
	text \<open>Obtaining the index of a key\<close>
	definition "hm_index \<equiv> \<lambda>(pq,m) k. index pq k + 1"

	lemma hm_index_valid[simp]: "\<lbrakk>hmr_invar hm; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow> hm_valid hm (hm_index hm k)"
	by (force simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def Suc_le_eq)

	lemma hm_index_key_of[simp]: "\<lbrakk>hmr_invar hm; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow> hm_key_of hm (hm_index hm k) = k"
	by (force
	simp: hm_valid_def heapmap_\<alpha>_def hmr_invar_def hm_index_def hm_length_def hm_key_of_def Suc_le_eq)


	definition "hm_index_op \<equiv> \<lambda>(pq,m) k.
	do {
	ASSERT (hmr_invar (pq,m) \<and> heapmap_\<alpha> (pq,m) k \<noteq> None);
	i \<leftarrow> mop_list_index pq k;
	RETURN (i+1)
	}"

	lemma hm_index_op_correct:
	assumes "hmr_invar hm"
	assumes "heapmap_\<alpha> hm k \<noteq> None"
	shows "hm_index_op hm k \<le> SPEC (\<lambda>r. r= hm_index hm k)"
	using assms unfolding hm_index_op_def
	apply refine_vcg
	apply (auto simp: heapmap_\<alpha>_def hmr_invar_def hm_index_def index_nth_id)
	done
	lemmas [refine_vcg] = hm_index_op_correct


	subsubsection \<open>Update\<close>
	text \<open>Updating the heap at an index\<close>
	definition hm_update_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm nres" where
	"hm_update_op \<equiv> \<lambda>(pq,m) i v. do {
	ASSERT (hm_valid (pq,m) i \<and> hmr_invar (pq,m));
	k \<leftarrow> mop_list_get pq (i - 1);
	RETURN (pq, m(k \<mapsto> v))
	}"

	lemma hm_update_op_invar: "hm_update_op hm k v \<le>\<^sub>n SPEC hmr_invar"
	unfolding hm_update_op_def h.update_op_def
	apply refine_vcg
	by (auto simp: hmr_rel_defs map_distinct_upd_conv hm_valid_def hm_length_def)

	lemma hm_update_op_refine: "(hm_update_op, h.update_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> Id \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_update_op_def h.update_op_def mop_list_get_alt mop_list_set_alt
	apply refine_vcg
	apply (auto simp: hmr_rel_defs map_distinct_upd_conv hm_valid_def hm_length_def)
	done

	lemmas [refine] = hm_update_op_refine[param_fo, THEN nres_relD]

	lemma hm_update_op_\<alpha>_correct:
	assumes "hmr_invar hm"
	assumes "heapmap_\<alpha> hm k \<noteq> None"
	shows "hm_update_op hm (hm_index hm k) v \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)(k\<mapsto>v))"
	using assms
	unfolding hm_update_op_def
	apply refine_vcg
	apply (force simp: heapmap_rel_defs hmr_rel_defs hm_index_def)
	done

	subsubsection \<open>Butlast\<close>
	text \<open>Remove last element\<close>
	definition hm_butlast_op :: "('k,'v) ahm \<Rightarrow> ('k,'v) ahm nres" where
	"hm_butlast_op \<equiv> \<lambda>(pq,m). do {
	ASSERT (hmr_invar (pq,m));
	k \<leftarrow> mop_list_get pq (length pq - 1);
	pq \<leftarrow> mop_list_butlast pq;
	let m = m(k:=None);
	RETURN (pq,m)
	}"

	lemma hm_butlast_op_refine: "(hm_butlast_op, h.butlast_op) \<in> hmr_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	supply [simp del] = map_upd_eq_restrict
	apply (intro fun_relI nres_relI)
	unfolding hm_butlast_op_def h.butlast_op_def
	apply simp
	apply refine_vcg
	apply (clarsimp_all simp: hmr_rel_defs map_butlast distinct_butlast)
	apply (auto simp: neq_Nil_rev_conv) []
	done

	lemmas [refine] = hm_butlast_op_refine[param_fo, THEN nres_relD]

	lemma hm_butlast_op_\<alpha>_correct: "hm_butlast_op hm \<le>\<^sub>n SPEC (
	\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)( hm_key_of hm (hm_length hm) := None ))"
	unfolding hm_butlast_op_def
	apply refine_vcg
	apply (auto simp: heapmap_\<alpha>_def hm_key_of_def hm_length_def)
	done

	subsubsection \<open>Append\<close>
	text \<open>Append new element at end of heap\<close>

	definition hm_append_op :: "('k,'v) ahm \<Rightarrow> 'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm nres"
	where "hm_append_op \<equiv> \<lambda>(pq,m) k v. do {
	ASSERT (k \<notin> dom m);
	ASSERT (hmr_invar (pq,m));
	pq \<leftarrow> mop_list_append pq k;
	let m = m (k \<mapsto> v);
	RETURN (pq,m)
	}"

	lemma hm_append_op_invar: "hm_append_op hm k v \<le>\<^sub>n SPEC hmr_invar"
	unfolding hm_append_op_def h.append_op_def
	apply refine_vcg
	unfolding heapmap_\<alpha>_def hmr_rel_defs
	- apply (auto simp: )
	+ apply auto
	done

	lemma hm_append_op_refine: "\<lbrakk> heapmap_\<alpha> hm k = None; (hm,h)\<in>hmr_rel \<rbrakk>
	\<Longrightarrow> (hm_append_op hm k v, h.append_op h v) \<in> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_append_op_def h.append_op_def
	apply refine_vcg
	unfolding heapmap_\<alpha>_def hmr_rel_defs
	- apply (auto simp: )
	+ apply auto
	done

	lemmas hm_append_op_refine'[refine] = hm_append_op_refine[param_fo, THEN nres_relD]

	lemma hm_append_op_\<alpha>_correct:
	"hm_append_op hm k v \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm) (k \<mapsto> v))"
	unfolding hm_append_op_def
	apply refine_vcg
	by (auto simp: heapmap_\<alpha>_def)


	subsection \<open>Auxiliary Operations\<close>
	text \<open>Auxiliary operations on heapmaps, which are derived
	from the basic operations, but do not correspond to
	operations of the priority map interface\<close>


	text \<open>We start with some setup\<close>

	lemma heapmap_hmr_relI: "(hm,h)\<in>heapmap_rel \<Longrightarrow> (hm,hmr_\<alpha> hm) \<in> hmr_rel"
	by (auto simp: heapmap_rel_defs hmr_rel_defs)

	lemma heapmap_hmr_relI': "heapmap_invar hm \<Longrightarrow> (hm,hmr_\<alpha> hm) \<in> hmr_rel"
	by (auto simp: heapmap_rel_defs hmr_rel_defs)

	text \<open>The basic principle how we prove correctness of our operations:
	Invariant preservation is shown by relating the operations to
	operations on heaps. Then, only correctness on the abstraction
	remains to be shown, assuming the operation does not fail.
	\<close>
	lemma heapmap_nres_relI':
	assumes "hm \<le> \<Down>hmr_rel h'"
	assumes "h' \<le> SPEC (h.heap_invar)"
	assumes "hm \<le>\<^sub>n SPEC (\<lambda>hm'. RETURN (heapmap_\<alpha> hm') \<le> h)"
	shows "hm \<le> \<Down>heapmap_rel h"
	using assms
	unfolding heapmap_rel_defs hmr_rel_def
	by (auto simp: pw_le_iff pw_leof_iff refine_pw_simps)

	lemma heapmap_nres_relI'':
	assumes "hm \<le> \<Down>hmr_rel h'"
	assumes "h' \<le> SPEC \<Phi>"
	assumes "\<And>h'. \<Phi> h' \<Longrightarrow> h.heap_invar h'"
	assumes "hm \<le>\<^sub>n SPEC (\<lambda>hm'. RETURN (heapmap_\<alpha> hm') \<le> h)"
	shows "hm \<le> \<Down>heapmap_rel h"
	apply (rule heapmap_nres_relI')
	apply fact
	apply (rule order_trans, fact)
	apply (clarsimp; fact)
	apply fact
	done

	subsubsection \<open>Val-of\<close>
	text \<open>Indexing into the heap\<close>
	definition hm_val_of_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> 'v nres" where
	"hm_val_of_op \<equiv> \<lambda>hm i. do {
	k \<leftarrow> hm_key_of_op hm i;
	v \<leftarrow> hm_the_lookup_op hm k;
	RETURN v
	}"

	lemma hm_val_of_op_refine: "(hm_val_of_op,h.val_of_op) \<in> (hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel)"
	apply (intro fun_relI nres_relI)
	unfolding hm_val_of_op_def h.val_of_op_def
	hm_key_of_op_def hm_key_of_def hm_valid_def hm_length_def
	hm_the_lookup_op_def
	apply clarsimp
	apply (rule refine_IdD)
	apply refine_vcg
	apply (auto simp: hmr_rel_defs heapmap_\<alpha>_def)
	done

	lemmas [refine] = hm_val_of_op_refine[param_fo, THEN nres_relD]

	subsubsection \<open>Prio-of\<close>
	text \<open>Priority of key\<close>
	definition "hm_prio_of_op h i \<equiv> do {v \<leftarrow> hm_val_of_op h i; RETURN (prio v)}"

	lemma hm_prio_of_op_refine: "(hm_prio_of_op, h.prio_of_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>Id\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_prio_of_op_def h.prio_of_op_def
	apply refine_rcg
	by auto

	lemmas hm_prio_of_op_refine'[refine] = hm_prio_of_op_refine[param_fo, THEN nres_relD]

	subsubsection \<open>Swim\<close>

	definition hm_swim_op :: "('k,'v) ahm \<Rightarrow> nat \<Rightarrow> ('k,'v) ahm nres" where
	"hm_swim_op h i \<equiv> do {
	RECT (\<lambda>swim (h,i). do {
	ASSERT (hm_valid h i \<and> h.swim_invar (hmr_\<alpha> h) i);
	if hm_valid h (h.parent i) then do {
	ppi \<leftarrow> hm_prio_of_op h (h.parent i);
	pi \<leftarrow> hm_prio_of_op h i;
	if (\<not>ppi \<le> pi) then do {
	h \<leftarrow> hm_exch_op h i (h.parent i);
	swim (h, h.parent i)
	} else
	RETURN h
	} else
	RETURN h
	}) (h,i)
	}"

	lemma hm_swim_op_refine: "(hm_swim_op, h.swim_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_swim_op_def h.swim_op_def
	apply refine_rcg
	apply refine_dref_type
	apply (clarsimp_all simp: hm_valid_refine[param_fo, THEN IdD])
	apply (simp add: hmr_rel_def in_br_conv)
	done

	lemmas hm_swim_op_refine'[refine] = hm_swim_op_refine[param_fo, THEN nres_relD]


	lemma hm_swim_op_nofail_imp_valid:
	"nofail (hm_swim_op hm i) \<Longrightarrow> hm_valid hm i \<and> h.swim_invar (hmr_\<alpha> hm) i"
	unfolding hm_swim_op_def
	apply (subst (asm) RECT_unfold, refine_mono)
	by (auto simp: refine_pw_simps)

	lemma hm_swim_op_\<alpha>_correct: "hm_swim_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
	apply (rule leof_add_nofailI)
	apply (drule hm_swim_op_nofail_imp_valid)
	unfolding hm_swim_op_def
	apply (rule RECT_rule_leof[where
	pre="\<lambda>(hm',i). hm_valid hm' i \<and> heapmap_\<alpha> hm' = heapmap_\<alpha> hm"
	and V = "inv_image less_than snd"
	])
	apply simp
	apply simp

	unfolding hm_prio_of_op_def hm_val_of_op_def
	hm_exch_op_def hm_key_of_op_def hm_the_lookup_op_def
	apply (refine_vcg)
	apply (vc_solve simp add: hm_valid_def hm_length_def)
	apply rprems
	apply (vc_solve simp: heapmap_\<alpha>_def h.parent_def)
	done

	subsubsection \<open>Sink\<close>
	definition hm_sink_op
	where
	"hm_sink_op h k \<equiv> RECT (\<lambda>D (h,k). do {
	ASSERT (k>0 \<and> k\<le>hm_length h);
	let len = hm_length h;
	if (2*k \<le> len) then do {
	let j = 2*k;
	pj \<leftarrow> hm_prio_of_op h j;

	j \<leftarrow> (
	if j<len then do {
	psj \<leftarrow> hm_prio_of_op h (Suc j);
	if pj>psj then RETURN (j+1) else RETURN j
	} else RETURN j);

	pj \<leftarrow> hm_prio_of_op h j;
	pk \<leftarrow> hm_prio_of_op h k;
	if (pk > pj) then do {
	h \<leftarrow> hm_exch_op h k j;
	D (h,j)
	} else
	RETURN h
	} else RETURN h
	}) (h,k)"

	lemma hm_sink_op_refine: "(hm_sink_op, h.sink_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_sink_op_def h.sink_op_opt_eq[symmetric] h.sink_op_opt_def
	apply refine_rcg
	apply refine_dref_type

	unfolding hmr_rel_def heapmap_rel_def
	apply (clarsimp_all simp: in_br_conv)
	done

	lemmas hm_sink_op_refine'[refine] = hm_sink_op_refine[param_fo, THEN nres_relD]

	lemma hm_sink_op_nofail_imp_valid: "nofail (hm_sink_op hm i) \<Longrightarrow> hm_valid hm i"
	unfolding hm_sink_op_def
	apply (subst (asm) RECT_unfold, refine_mono)
	by (auto simp: refine_pw_simps hm_valid_def)

	lemma hm_sink_op_\<alpha>_correct: "hm_sink_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
	apply (rule leof_add_nofailI)
	apply (drule hm_sink_op_nofail_imp_valid)
	unfolding hm_sink_op_def
	apply (rule RECT_rule_leof[where
	pre="\<lambda>(hm',i). hm_valid hm' i \<and> heapmap_\<alpha> hm' = heapmap_\<alpha> hm \<and> hm_length hm' = hm_length hm"
	and V = "measure (\<lambda>(hm',i). hm_length hm' - i)"
	])
	apply simp
	apply simp

	unfolding hm_prio_of_op_def hm_val_of_op_def hm_exch_op_def
	hm_key_of_op_def hm_the_lookup_op_def
	apply (refine_vcg)
	apply (vc_solve simp add: hm_valid_def hm_length_def) (* Takes long *)
	apply rprems
	apply (vc_solve simp: heapmap_\<alpha>_def h.parent_def split: prod.splits)
	apply (auto)
	done

	subsubsection \<open>Repair\<close>
	definition "hm_repair_op hm i \<equiv> do {
	hm \<leftarrow> hm_sink_op hm i;
	hm \<leftarrow> hm_swim_op hm i;
	RETURN hm
	}"

	lemma hm_repair_op_refine: "(hm_repair_op, h.repair_op) \<in> hmr_rel \<rightarrow> nat_rel \<rightarrow> \<langle>hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_repair_op_def h.repair_op_def
	by refine_rcg

	lemmas hm_repair_op_refine'[refine] = hm_repair_op_refine[param_fo, THEN nres_relD]

	lemma hm_repair_op_\<alpha>_correct: "hm_repair_op hm i \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm)"
	unfolding hm_repair_op_def
	apply (refine_vcg
	hm_swim_op_\<alpha>_correct[THEN leof_trans]
	hm_sink_op_\<alpha>_correct[THEN leof_trans])
	by auto


	subsection \<open>Operations\<close>
	text \<open>In this section, we define the operations that implement the priority-map interface\<close>

	subsubsection \<open>Empty\<close>
	definition hm_empty_op :: "('k,'v) ahm nres"
	where "hm_empty_op \<equiv> RETURN ([],Map.empty)"

	lemma hm_empty_aref: "(hm_empty_op,RETURN op_map_empty) \<in> \<langle>heapmap_rel\<rangle>nres_rel"
	unfolding hm_empty_op_def
	by (auto simp: heapmap_rel_defs hmr_rel_defs intro: nres_relI)

	subsubsection \<open>Insert\<close>
	definition hm_insert_op :: "'k \<Rightarrow> 'v \<Rightarrow> ('k,'v) ahm \<Rightarrow> ('k,'v) ahm nres" where
	"hm_insert_op \<equiv> \<lambda>k v h. do {
	ASSERT (h.heap_invar (hmr_\<alpha> h));
	h \<leftarrow> hm_append_op h k v;
	let l = hm_length h;
	h \<leftarrow> hm_swim_op h l;
	RETURN h
	}"

	lemma hm_insert_op_refine[refine]: "\<lbrakk> heapmap_\<alpha> hm k = None; (hm,h)\<in>hmr_rel \<rbrakk> \<Longrightarrow>
	hm_insert_op k v hm \<le> \<Down>hmr_rel (h.insert_op v h)"
	unfolding hm_insert_op_def h.insert_op_def
	apply refine_rcg
	by (auto simp: hmr_rel_def br_def)

	lemma hm_insert_op_aref:
	"(hm_insert_op,mop_map_update_new) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding mop_map_update_new_alt
	apply (rule ASSERT_refine_right)
	apply (rule heapmap_nres_relI''[OF hm_insert_op_refine h.insert_op_correct])
	apply (unfold heapmap_rel_def in_br_conv; clarsimp)
	apply (erule heapmap_hmr_relI)
	apply (unfold heapmap_rel_def in_br_conv; clarsimp)
	apply (unfold heapmap_rel_def in_br_conv; clarsimp)
	unfolding hm_insert_op_def
	apply (refine_vcg
	hm_append_op_\<alpha>_correct[THEN leof_trans]
	hm_swim_op_\<alpha>_correct[THEN leof_trans])
	apply (unfold heapmap_rel_def in_br_conv; clarsimp)
	done

	subsubsection \<open>Is-Empty\<close>

	lemma hmr_\<alpha>_empty_iff[simp]:
	"hmr_invar hm \<Longrightarrow> hmr_\<alpha> hm = [] \<longleftrightarrow> heapmap_\<alpha> hm = Map.empty"
	by (auto
	simp: hmr_\<alpha>_def heapmap_invar_def heapmap_\<alpha>_def hmr_invar_def
	split: prod.split)

	definition hm_is_empty_op :: "('k,'v) ahm \<Rightarrow> bool nres" where
	"hm_is_empty_op \<equiv> \<lambda>hm. do {
	ASSERT (hmr_invar hm);
	let l = hm_length hm;
	RETURN (l=0)
	}"

	lemma hm_is_empty_op_refine: "(hm_is_empty_op, h.is_empty_op) \<in> hmr_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_is_empty_op_def h.is_empty_op_def
	apply refine_rcg
	apply (auto simp: hmr_rel_defs) []
	apply (parametricity add: hm_length_refine)
	done


	lemma hm_is_empty_op_aref: "(hm_is_empty_op, RETURN o op_map_is_empty) \<in> heapmap_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_is_empty_op_def
	apply refine_vcg
	apply (auto simp: hmr_rel_defs heapmap_rel_defs hm_length_def)
	done

	subsubsection \<open>Lookup\<close>

	definition hm_lookup_op :: "'k \<Rightarrow> ('k,'v) ahm \<Rightarrow> 'v option nres"
	where "hm_lookup_op \<equiv> \<lambda>k hm. ASSERT (heapmap_invar hm) \<then> RETURN (hm_lookup hm k)"

	lemma hm_lookup_op_aref: "(hm_lookup_op,RETURN oo op_map_lookup) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>\<langle>Id\<rangle>option_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_lookup_op_def heapmap_rel_def in_br_conv
	apply refine_vcg
	apply simp_all
	done

	subsubsection \<open>Contains-Key\<close>

	definition "hm_contains_key_op \<equiv> \<lambda>k (pq,m). ASSERT (heapmap_invar (pq,m)) \<then> RETURN (k\<in>dom m)"
	lemma hm_contains_key_op_aref: "(hm_contains_key_op,RETURN oo op_map_contains_key) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_contains_key_op_def heapmap_rel_defs
	apply refine_vcg
	by (auto)

	subsubsection \<open>Decrease-Key\<close>


	definition "hm_decrease_key_op \<equiv> \<lambda>k v hm. do {
	ASSERT (heapmap_invar hm);
	ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> prio v \<le> prio (the (heapmap_\<alpha> hm k)));
	i \<leftarrow> hm_index_op hm k;
	hm \<leftarrow> hm_update_op hm i v;
	hm_swim_op hm i
	}"

	definition (in heapstruct) "decrease_key_op i v h \<equiv> do {
	ASSERT (valid h i \<and> prio v \<le> prio_of h i);
	h \<leftarrow> update_op h i v;
	swim_op h i
	}"

	lemma (in heapstruct) decrease_key_op_invar:
	"\<lbrakk>heap_invar h; valid h i; prio v \<le> prio_of h i\<rbrakk> \<Longrightarrow> decrease_key_op i v h \<le> SPEC heap_invar"
	unfolding decrease_key_op_def
	apply refine_vcg
	by (auto simp: swim_invar_decr)


	lemma index_op_inline_refine:
	assumes "heapmap_invar hm"
	assumes "heapmap_\<alpha> hm k \<noteq> None"
	assumes "f (hm_index hm k) \<le> m"
	shows "do {i \<leftarrow> hm_index_op hm k; f i} \<le> m"
	using hm_index_op_correct[of hm k] assms
	by (auto simp: pw_le_iff refine_pw_simps)

	lemma hm_decrease_key_op_refine:
	"\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
	\<Longrightarrow> hm_decrease_key_op k v hm \<le>\<Down>hmr_rel (h.decrease_key_op (hm_index hm k) v h)"
	unfolding hm_decrease_key_op_def h.decrease_key_op_def
	(apply (rewrite at "Let (hm_index hm k) _" Let_def))
	apply (refine_rcg index_op_inline_refine)
	unfolding hmr_rel_def heapmap_rel_def in_br_conv
	apply (clarsimp_all)
	done

	lemma hm_index_op_inline_leof:
	assumes "f (hm_index hm k) \<le>\<^sub>n m"
	shows "do {i \<leftarrow> hm_index_op hm k; f i} \<le>\<^sub>n m"
	using hm_index_op_correct[of hm k] assms unfolding hm_index_op_def
	by (auto simp: pw_le_iff pw_leof_iff refine_pw_simps split: prod.splits)

	lemma hm_decrease_key_op_\<alpha>_correct:
	"heapmap_invar hm \<Longrightarrow> hm_decrease_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
	unfolding hm_decrease_key_op_def
	apply (refine_vcg
	hm_update_op_\<alpha>_correct[THEN leof_trans]
	hm_swim_op_\<alpha>_correct[THEN leof_trans]
	hm_index_op_inline_leof
	)
	apply simp_all
	done

	lemma hm_decrease_key_op_aref:
	"(hm_decrease_key_op, PR_CONST (mop_pm_decrease_key prio)) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	unfolding PR_CONST_def
	apply (intro fun_relI nres_relI)
	apply (frule heapmap_hmr_relI)
	unfolding mop_pm_decrease_key_alt
	apply (rule ASSERT_refine_right; clarsimp)
	apply (rule heapmap_nres_relI')
	apply (rule hm_decrease_key_op_refine; assumption)
	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (rule h.decrease_key_op_invar; simp; fail )
	apply (refine_vcg hm_decrease_key_op_\<alpha>_correct[THEN leof_trans]; simp; fail)
	done

	subsubsection \<open>Increase-Key\<close>

	definition "hm_increase_key_op \<equiv> \<lambda>k v hm. do {
	ASSERT (heapmap_invar hm);
	ASSERT (heapmap_\<alpha> hm k \<noteq> None \<and> prio v \<ge> prio (the (heapmap_\<alpha> hm k)));
	i \<leftarrow> hm_index_op hm k;
	hm \<leftarrow> hm_update_op hm i v;
	hm_sink_op hm i
	}"

	definition (in heapstruct) "increase_key_op i v h \<equiv> do {
	ASSERT (valid h i \<and> prio v \<ge> prio_of h i);
	h \<leftarrow> update_op h i v;
	sink_op h i
	}"

	lemma (in heapstruct) increase_key_op_invar:
	"\<lbrakk>heap_invar h; valid h i; prio v \<ge> prio_of h i\<rbrakk> \<Longrightarrow> increase_key_op i v h \<le> SPEC heap_invar"
	unfolding increase_key_op_def
	apply refine_vcg
	by (auto simp: sink_invar_incr)

	lemma hm_increase_key_op_refine:
	"\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
	\<Longrightarrow> hm_increase_key_op k v hm \<le>\<Down>hmr_rel (h.increase_key_op (hm_index hm k) v h)"
	unfolding hm_increase_key_op_def h.increase_key_op_def
	(apply (rewrite at "Let (hm_index hm k) _" Let_def))
	apply (refine_rcg index_op_inline_refine)
	unfolding hmr_rel_def heapmap_rel_def in_br_conv
	apply (clarsimp_all)
	done

	lemma hm_increase_key_op_\<alpha>_correct:
	"heapmap_invar hm \<Longrightarrow> hm_increase_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
	unfolding hm_increase_key_op_def
	apply (refine_vcg
	hm_update_op_\<alpha>_correct[THEN leof_trans]
	hm_sink_op_\<alpha>_correct[THEN leof_trans]
	hm_index_op_inline_leof)
	apply simp_all
	done

	lemma hm_increase_key_op_aref:
	"(hm_increase_key_op, PR_CONST (mop_pm_increase_key prio)) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	unfolding PR_CONST_def
	apply (intro fun_relI nres_relI)
	apply (frule heapmap_hmr_relI)
	unfolding mop_pm_increase_key_alt
	apply (rule ASSERT_refine_right; clarsimp)
	apply (rule heapmap_nres_relI')
	apply (rule hm_increase_key_op_refine; assumption)
	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (rule h.increase_key_op_invar; simp; fail )
	apply (refine_vcg hm_increase_key_op_\<alpha>_correct[THEN leof_trans]; simp)
	done

	subsubsection \<open>Change-Key\<close>

	definition "hm_change_key_op \<equiv> \<lambda>k v hm. do {
	ASSERT (heapmap_invar hm);
	ASSERT (heapmap_\<alpha> hm k \<noteq> None);
	i \<leftarrow> hm_index_op hm k;
	hm \<leftarrow> hm_update_op hm i v;
	hm_repair_op hm i
	}"

	definition (in heapstruct) "change_key_op i v h \<equiv> do {
	ASSERT (valid h i);
	h \<leftarrow> update_op h i v;
	repair_op h i
	}"

	lemma (in heapstruct) change_key_op_invar:
	"\<lbrakk>heap_invar h; valid h i\<rbrakk> \<Longrightarrow> change_key_op i v h \<le> SPEC heap_invar"
	unfolding change_key_op_def
	apply (refine_vcg)
	apply hypsubst
	apply refine_vcg
	by (auto simp: sink_invar_incr)

	lemma hm_change_key_op_refine:
	"\<lbrakk>(hm,h)\<in>hmr_rel; (hm,m)\<in>heapmap_rel; m k = Some v'\<rbrakk>
	\<Longrightarrow> hm_change_key_op k v hm \<le>\<Down>hmr_rel (h.change_key_op (hm_index hm k) v h)"
	unfolding hm_change_key_op_def h.change_key_op_def
	(apply (rewrite at "Let (hm_index hm k) _" Let_def))
	apply (refine_rcg index_op_inline_refine)
	unfolding hmr_rel_def heapmap_rel_def in_br_conv
	apply (clarsimp_all)
	done

	lemma hm_change_key_op_\<alpha>_correct:
	"heapmap_invar hm \<Longrightarrow> hm_change_key_op k v hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = heapmap_\<alpha> hm(k\<mapsto>v))"
	unfolding hm_change_key_op_def
	apply (refine_vcg
	hm_update_op_\<alpha>_correct[THEN leof_trans]
	hm_repair_op_\<alpha>_correct[THEN leof_trans]
	hm_index_op_inline_leof)
	unfolding heapmap_rel_def in_br_conv
	apply simp
	apply simp
	done

	lemma hm_change_key_op_aref:
	"(hm_change_key_op, mop_map_update_ex) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	apply (frule heapmap_hmr_relI)
	unfolding mop_map_update_ex_alt
	apply (rule ASSERT_refine_right; clarsimp)
	apply (rule heapmap_nres_relI')
	apply (rule hm_change_key_op_refine; assumption)
	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (rule h.change_key_op_invar; simp; fail )
	apply ((refine_vcg hm_change_key_op_\<alpha>_correct[THEN leof_trans]; simp))
	done

	subsubsection \<open>Set\<close>

	text \<open>Realized as generic algorithm!\<close> (* TODO: Implement as such! *)
	lemma (in -) op_pm_set_gen_impl: "RETURN ooo op_map_update = (\<lambda>k v m. do {
	c \<leftarrow> RETURN (op_map_contains_key k m);
	if c then
	mop_map_update_ex k v m
	else
	mop_map_update_new k v m
	})"
	apply (intro ext)
	unfolding op_map_contains_key_def mop_map_update_ex_def mop_map_update_new_def
	by simp

	definition "hm_set_op k v hm \<equiv> do {
	c \<leftarrow> hm_contains_key_op k hm;
	if c then
	hm_change_key_op k v hm
	else
	hm_insert_op k v hm
	}"

	lemma hm_set_op_aref:
	"(hm_set_op, RETURN ooo op_map_update) \<in> Id \<rightarrow> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	unfolding op_pm_set_gen_impl
	apply (intro fun_relI nres_relI)
	unfolding hm_set_op_def o_def
	apply (refine_rcg
	hm_contains_key_op_aref[param_fo, unfolded o_def, THEN nres_relD]
	hm_change_key_op_aref[param_fo, THEN nres_relD]
	hm_insert_op_aref[param_fo, THEN nres_relD]
	)
	by auto



	subsubsection \<open>Pop-Min\<close>

	definition hm_pop_min_op :: "('k,'v) ahm \<Rightarrow> (('k\<times>'v) \<times> ('k,'v) ahm) nres" where
	"hm_pop_min_op hm \<equiv> do {
	ASSERT (heapmap_invar hm);
	ASSERT (hm_valid hm 1);
	k \<leftarrow> hm_key_of_op hm 1;
	v \<leftarrow> hm_the_lookup_op hm k;
	let l = hm_length hm;
	hm \<leftarrow> hm_exch_op hm 1 l;
	hm \<leftarrow> hm_butlast_op hm;

	if (l\<noteq>1) then do {
	hm \<leftarrow> hm_sink_op hm 1;
	RETURN ((k,v),hm)
	} else RETURN ((k,v),hm)
	}"

	lemma hm_pop_min_op_refine:
	"(hm_pop_min_op, h.pop_min_op) \<in> hmr_rel \<rightarrow> \<langle>UNIV \<times>\<^sub>r hmr_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding hm_pop_min_op_def h.pop_min_op_def
	(* Project away stuff of second component *)
	unfolding ignore_snd_refine_conv hm_the_lookup_op_def hm_key_of_op_unfold
	apply (simp cong: if_cong add: Let_def)
	apply (simp add: unused_bind_conv h.val_of_op_def refine_pw_simps)

	(* Prove refinement *)
	apply refine_rcg
	unfolding hmr_rel_def in_br_conv
	apply (unfold heapmap_invar_def;simp)
	apply (auto simp: in_br_conv)
	done

	text \<open>We demonstrate two different approaches for proving correctness
	here.
	The first approach uses the relation to plain heaps only to establish
	the invariant.

	The second approach also uses the relation to heaps to establish
	correctness of the result.

	The first approach seems to be more robust against badly set
	up simpsets, which may be the case in early stages of development.

	Assuming a working simpset, the second approach may be less work,
	and the proof may look more elegant.
	\<close>

	text_raw \<open>\paragraph{First approach}\<close>
	text \<open>Transfer heapmin-property to heapmap-domain\<close>
	lemma heapmap_min_prop:
	assumes INV: "heapmap_invar hm"
	assumes V': "heapmap_\<alpha> hm k = Some v'"
	assumes NE: "hm_valid hm (Suc 0)"
	shows "prio (the (heapmap_\<alpha> hm (hm_key_of hm (Suc 0)))) \<le> prio v'"
	proof -
	\<comment> \<open>Transform into the domain of heaps\<close>
	obtain pq m where [simp]: "hm=(pq,m)" by (cases hm)

	from NE have [simp]: "pq\<noteq>[]" by (auto simp: hm_valid_def hm_length_def)

	have CNV_LHS: "prio (the (heapmap_\<alpha> hm (hm_key_of hm (Suc 0))))
	= h.prio_of (hmr_\<alpha> hm) (Suc 0)"
	by (auto simp: heapmap_\<alpha>_def hm_key_of_def hmr_\<alpha>_def h.val_of_def)

	from INV have INV': "h.heap_invar (hmr_\<alpha> hm)"
	unfolding heapmap_invar_def by auto

	from V' INV obtain i where IDX: "h.valid (hmr_\<alpha> hm) i"
	and CNV_RHS: "prio v' = h.prio_of (hmr_\<alpha> hm) i"
	apply (clarsimp simp: heapmap_\<alpha>_def heapmap_invar_def hmr_invar_def hmr_\<alpha>_def
	h.valid_def h.val_of_def)
	by (metis (no_types, opaque_lifting) Suc_leI comp_apply diff_Suc_Suc
	diff_zero domI index_less_size_conv neq0_conv nth_index nth_map
	old.nat.distinct(2) option.sel)

	from h.heap_min_prop[OF INV' IDX] show ?thesis
	unfolding CNV_LHS CNV_RHS .
	qed


	text \<open>With the above lemma, the correctness proof is straightforward\<close>
	lemma hm_pop_min_\<alpha>_correct: "hm_pop_min_op hm \<le>\<^sub>n SPEC (\<lambda>((k,v),hm').
	heapmap_\<alpha> hm k = Some v
	\<and> heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)(k:=None)
	\<and> (\<forall>k' v'. heapmap_\<alpha> hm k' = Some v' \<longrightarrow> prio v \<le> prio v'))"
	unfolding hm_pop_min_op_def hm_key_of_op_unfold hm_the_lookup_op_def
	apply (refine_vcg
	hm_exch_op_\<alpha>_correct[THEN leof_trans]
	hm_butlast_op_\<alpha>_correct[THEN leof_trans]
	hm_sink_op_\<alpha>_correct[THEN leof_trans]
	)
	apply (auto simp: heapmap_min_prop)
	done

	lemma heapmap_nres_rel_prodI:
	assumes "hmx \<le> \<Down>(UNIV \<times>\<^sub>r hmr_rel) h'x"
	assumes "h'x \<le> SPEC (\<lambda>(_,h'). h.heap_invar h')"
	assumes "hmx \<le>\<^sub>n SPEC (\<lambda>(r,hm'). RETURN (r,heapmap_\<alpha> hm') \<le> \<Down>(R\<times>\<^sub>rId) hx)"
	shows "hmx \<le> \<Down>(R\<times>\<^sub>rheapmap_rel) hx"
	using assms
	unfolding heapmap_rel_def hmr_rel_def br_def heapmap_invar_def
	apply (auto simp: pw_le_iff pw_leof_iff refine_pw_simps; blast)
	done


	lemma hm_pop_min_op_aref: "(hm_pop_min_op, PR_CONST (mop_pm_pop_min prio)) \<in> heapmap_rel \<rightarrow> \<langle>(Id\<times>\<^sub>rId)\<times>\<^sub>rheapmap_rel\<rangle>nres_rel"
	unfolding PR_CONST_def
	apply (intro fun_relI nres_relI)
	apply (frule heapmap_hmr_relI)
	unfolding mop_pm_pop_min_alt
	apply (intro ASSERT_refine_right)
	apply (rule heapmap_nres_rel_prodI)
	apply (rule hm_pop_min_op_refine[param_fo, THEN nres_relD]; assumption)
	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (refine_vcg; simp)
	apply (refine_vcg hm_pop_min_\<alpha>_correct[THEN leof_trans]; simp split: prod.splits)
	done

	text_raw \<open>\paragraph{Second approach}\<close>

	(* Alternative approach: Also use knowledge about result
	in multiset domain. Obtaining property seems infeasible at first attempt! *)

	definition "hm_kv_of_op hm i \<equiv> do {
	ASSERT (hm_valid hm i \<and> hmr_invar hm);
	k \<leftarrow> hm_key_of_op hm i;
	v \<leftarrow> hm_the_lookup_op hm k;
	RETURN (k, v)
	}"


	definition "kvi_rel hm i \<equiv> {((k,v),v) \| k v. hm_key_of hm i = k}"

	lemma hm_kv_op_refine[refine]:
	assumes "(hm,h)\<in>hmr_rel"
	shows "hm_kv_of_op hm i \<le> \<Down>(kvi_rel hm i) (h.val_of_op h i)"
	unfolding hm_kv_of_op_def h.val_of_op_def kvi_rel_def
	hm_key_of_op_unfold hm_the_lookup_op_def
	apply simp
	apply refine_vcg
	using assms
	by (auto
	simp: hm_valid_def hm_length_def hmr_rel_defs heapmap_\<alpha>_def hm_key_of_def
	split: prod.splits)

	definition hm_pop_min_op' :: "('k,'v) ahm \<Rightarrow> (('k\<times>'v) \<times> ('k,'v) ahm) nres" where
	"hm_pop_min_op' hm \<equiv> do {
	ASSERT (heapmap_invar hm);
	ASSERT (hm_valid hm 1);
	kv \<leftarrow> hm_kv_of_op hm 1;
	let l = hm_length hm;
	hm \<leftarrow> hm_exch_op hm 1 l;
	hm \<leftarrow> hm_butlast_op hm;

	if (l\<noteq>1) then do {
	hm \<leftarrow> hm_sink_op hm 1;
	RETURN (kv,hm)
	} else RETURN (kv,hm)
	}"


	lemma hm_pop_min_op_refine':
	"\<lbrakk> (hm,h)\<in>hmr_rel \<rbrakk> \<Longrightarrow> hm_pop_min_op' hm \<le> \<Down>(kvi_rel hm 1 \<times>\<^sub>r hmr_rel) (h.pop_min_op h)"
	unfolding hm_pop_min_op'_def h.pop_min_op_def
	(* Project away stuff of second component *)
	unfolding ignore_snd_refine_conv
	(* Prove refinement *)
	apply refine_rcg
	unfolding hmr_rel_def heapmap_rel_def
	apply (unfold heapmap_invar_def; simp add: in_br_conv)
	apply (simp_all add: in_br_conv)
	done


	lemma heapmap_nres_rel_prodI':
	assumes "hmx \<le> \<Down>(S \<times>\<^sub>r hmr_rel) h'x"
	assumes "h'x \<le> SPEC \<Phi>"
	assumes "\<And>h' r. \<Phi> (r,h') \<Longrightarrow> h.heap_invar h'"
	assumes "hmx \<le>\<^sub>n SPEC (\<lambda>(r,hm'). (\<exists>r'. (r,r')\<in>S \<and> \<Phi> (r',hmr_\<alpha> hm')) \<and> hmr_invar hm' \<longrightarrow> RETURN (r,heapmap_\<alpha> hm') \<le> \<Down>(R\<times>\<^sub>rId) hx)"
	shows "hmx \<le> \<Down>(R\<times>\<^sub>rheapmap_rel) hx"
	using assms
	unfolding heapmap_rel_def hmr_rel_def heapmap_invar_def
	apply (auto
	simp: pw_le_iff pw_leof_iff refine_pw_simps in_br_conv
	)
	by meson

	lemma ex_in_kvi_rel_conv:
	"(\<exists>r'. (r,r')\<in>kvi_rel hm i \<and> \<Phi> r') \<longleftrightarrow> (fst r = hm_key_of hm i \<and> \<Phi> (snd r))"
	unfolding kvi_rel_def
	apply (cases r)
	apply auto
	done


	lemma hm_pop_min_aref': "(hm_pop_min_op', mop_pm_pop_min prio) \<in> heapmap_rel \<rightarrow> \<langle>(Id\<times>\<^sub>rId) \<times>\<^sub>r heapmap_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	apply (frule heapmap_hmr_relI)
	unfolding mop_pm_pop_min_alt
	apply (intro ASSERT_refine_right)
	apply (rule heapmap_nres_rel_prodI')
	apply (erule hm_pop_min_op_refine')

	apply (unfold heapmap_rel_def hmr_rel_def in_br_conv) []
	apply (rule h.pop_min_op_correct)
	apply simp
	apply simp

	apply simp

	apply (clarsimp simp: ex_in_kvi_rel_conv split: prod.splits)
	unfolding hm_pop_min_op'_def hm_kv_of_op_def hm_key_of_op_unfold
	hm_the_lookup_op_def
	apply (refine_vcg
	hm_exch_op_\<alpha>_correct[THEN leof_trans]
	hm_butlast_op_\<alpha>_correct[THEN leof_trans]
	hm_sink_op_\<alpha>_correct[THEN leof_trans]
	)
	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (auto intro: ranI)
	done

	subsubsection \<open>Remove\<close>

	definition "hm_remove_op k hm \<equiv> do {
	ASSERT (heapmap_invar hm);
	ASSERT (k \<in> dom (heapmap_\<alpha> hm));
	i \<leftarrow> hm_index_op hm k;
	let l = hm_length hm;
	hm \<leftarrow> hm_exch_op hm i l;
	hm \<leftarrow> hm_butlast_op hm;
	if i \<noteq> l then
	hm_repair_op hm i
	else
	RETURN hm
	}"

	definition (in heapstruct) "remove_op i h \<equiv> do {
	ASSERT (heap_invar h);
	ASSERT (valid h i);
	let l = length h;
	h \<leftarrow> exch_op h i l;
	h \<leftarrow> butlast_op h;
	if i \<noteq> l then
	repair_op h i
	else
	RETURN h
	}"

	lemma (in -) swap_empty_iff[iff]: "swap l i j = [] \<longleftrightarrow> l=[]"
	by (auto simp: swap_def)

	lemma (in heapstruct)
	butlast_exch_last: "butlast (exch h i (length h)) = update (butlast h) i (last h)"
	unfolding exch_def update_def
	apply (cases h rule: rev_cases)
	apply (auto simp: swap_def butlast_list_update)
	done

	lemma (in heapstruct) remove_op_invar:
	"\<lbrakk> heap_invar h; valid h i \<rbrakk> \<Longrightarrow> remove_op i h \<le> SPEC heap_invar"
	unfolding remove_op_def
	apply refine_vcg
	apply (auto simp: valid_def) []
	apply (auto simp: valid_def exch_def) []
	apply (simp add: butlast_exch_last)
	apply refine_vcg
	apply auto []
	apply auto []
	apply (auto simp: valid_def) []
	apply auto []
	apply auto []
	done

	lemma hm_remove_op_refine[refine]:
	"\<lbrakk> (hm,m)\<in>heapmap_rel; (hm,h)\<in>hmr_rel; heapmap_\<alpha> hm k \<noteq> None\<rbrakk> \<Longrightarrow>
	hm_remove_op k hm \<le> \<Down>hmr_rel (h.remove_op (hm_index hm k) h)"
	unfolding hm_remove_op_def h.remove_op_def heapmap_rel_def
	(apply (rewrite at "Let (hm_index hm k) _" Let_def))
	apply (refine_rcg index_op_inline_refine)
	unfolding hmr_rel_def
	apply (auto simp: in_br_conv)
	done

	lemma hm_remove_op_\<alpha>_correct:
	"hm_remove_op k hm \<le>\<^sub>n SPEC (\<lambda>hm'. heapmap_\<alpha> hm' = (heapmap_\<alpha> hm)(k:=None))"
	unfolding hm_remove_op_def
	apply (refine_vcg
	hm_exch_op_\<alpha>_correct[THEN leof_trans]
	hm_butlast_op_\<alpha>_correct[THEN leof_trans]
	hm_repair_op_\<alpha>_correct[THEN leof_trans]
	hm_index_op_inline_leof
	)
	apply (auto; fail)

	apply clarsimp
	apply (rewrite at "hm_index _ k = hm_length _" in asm eq_commute)
	apply (auto; fail)
	done

	lemma hm_remove_op_aref:
	"(hm_remove_op,mop_map_delete_ex) \<in> Id \<rightarrow> heapmap_rel \<rightarrow> \<langle>heapmap_rel\<rangle>nres_rel"
	apply (intro fun_relI nres_relI)
	unfolding mop_map_delete_ex_alt
	apply (rule ASSERT_refine_right)
	apply (frule heapmap_hmr_relI)
	apply (rule heapmap_nres_relI')
	apply (rule hm_remove_op_refine; assumption?)
	apply (unfold heapmap_rel_def in_br_conv; auto)

	unfolding heapmap_rel_def hmr_rel_def in_br_conv
	apply (refine_vcg h.remove_op_invar; clarsimp; fail)
	apply (refine_vcg hm_remove_op_\<alpha>_correct[THEN leof_trans]; simp; fail)
	done

	subsubsection \<open>Peek-Min\<close>


	definition hm_peek_min_op :: "('k,'v) ahm \<Rightarrow> ('k\<times>'v) nres" where
	"hm_peek_min_op hm \<equiv> hm_kv_of_op hm 1"

	lemma hm_peek_min_op_aref:
	"(hm_peek_min_op, PR_CONST (mop_pm_peek_min prio)) \<in> heapmap_rel \<rightarrow> \<langle>Id\<times>\<^sub>rId\<rangle>nres_rel"
	unfolding PR_CONST_def
	apply (intro fun_relI nres_relI)
	proof -
	fix hm and m :: "'k \<rightharpoonup> 'v"
	assume A: "(hm,m)\<in>heapmap_rel"

	from A have [simp]: "h.heap_invar (hmr_\<alpha> hm)" "hmr_invar hm" "m=heapmap_\<alpha> hm"
	unfolding heapmap_rel_def in_br_conv heapmap_invar_def
	by simp_all

	have "hm_peek_min_op hm \<le> \<Down> (kvi_rel hm 1) (h.peek_min_op (hmr_\<alpha> hm))"
	unfolding hm_peek_min_op_def h.peek_min_op_def
	apply (refine_rcg hm_kv_op_refine)
	using A
	apply (simp add: heapmap_hmr_relI)
	done
	also have "\<lbrakk>hmr_\<alpha> hm \<noteq> []\<rbrakk> \<Longrightarrow> (h.peek_min_op (hmr_\<alpha> hm))
	\<le> SPEC (\<lambda>v. v\<in>ran (heapmap_\<alpha> hm) \<and> (\<forall>v'\<in>ran (heapmap_\<alpha> hm). prio v \<le> prio v'))"
	apply refine_vcg
	by simp_all
	finally show "hm_peek_min_op hm \<le> \<Down> (Id \<times>\<^sub>r Id) (mop_pm_peek_min prio m)"
	unfolding mop_pm_peek_min_alt
	apply (simp add: pw_le_iff refine_pw_simps hm_peek_min_op_def hm_kv_of_op_def
	hm_key_of_op_unfold hm_the_lookup_op_def)
	apply (fastforce simp: kvi_rel_def ran_def)
	done

	qed


	end

	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,3758 +1,3758 @@
	(***********************************************************************************
	* 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
	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 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)
	by (smt 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 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 Int_absorb2 finite_set_in get_child_nodes_is_strongly_scdom_component_safe_step in_mono
	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_ptr_in_heap local.get_scdom_component_subset_get_dom_component
	returns_result_select_result subsetI)
	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 IntI finite_set_in in_mono local.get_dom_component_ok local.get_dom_component_ptr
	local.get_parent_is_strongly_dom_component_safe_step local.get_parent_parent_in_heap
	local.get_scdom_component_impl local.get_scdom_component_ok local.get_scdom_component_subset_get_dom_component
	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)
	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 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 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 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 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 \<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 add: )
	+ using children' by simp
	have 7: "\|h' \<turnstile> get_disconnected_nodes xb\|\<^sub>r = disc_nodes'"
	- using disc_nodes' by (simp add: )
	+ 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 add: )
	+ bysimp
	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 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)
	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)
	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 \<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 \<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)
	using \<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

	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 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>result = new_element_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_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 \<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 \<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)
	using \<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

	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 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 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 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/Security_Protocol_Refinement/Refinement/Message.thy b/thys/Security_Protocol_Refinement/Refinement/Message.thy
	--- a/thys/Security_Protocol_Refinement/Refinement/Message.thy
	+++ b/thys/Security_Protocol_Refinement/Refinement/Message.thy
	@@ -1,888 +1,888 @@
	(*******************************************************************************

	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"

	********************************************************************************

	Module: Refinement/Message.thy (Isabelle/HOL 2016-1)
	ID: $Id: Message.thy 133856 2017-03-20 18:05:54Z csprenge $
	Edited: Christoph Sprenger <sprenger@inf.ethz.ch>, ETH Zurich

	Integrated and adapted for security protocol refinement

	*******************************************************************************)

	section \<open>Theory of Agents and Messages for Security Protocols\<close>

	theory Message imports Keys begin

	(Needed occasionally with spy_analz_tac, e.g. in analz_insert_Key_newK)
	lemma Un_idem_collapse [simp]: "A \<union> (B \<union> A) = B \<union> A"
	by blast

	datatype
	msg = Agent agent \<comment> \<open>Agent names\<close>
	\| Number nat \<comment> \<open>Ordinary integers, timestamps, ...\<close>
	\| Nonce nonce \<comment> \<open>Unguessable nonces\<close>
	\| Key key \<comment> \<open>Crypto keys\<close>
	\| Hash msg \<comment> \<open>Hashing\<close>
	\| MPair msg msg \<comment> \<open>Compound messages\<close>
	\| Crypt key msg \<comment> \<open>Encryption, public- or shared-key\<close>


	text\<open>Concrete syntax: messages appear as \<open>\<lbrace>A,B,NA\<rbrace>\<close>, etc...\<close>

	syntax
	"_MTuple" :: "['a, args] => 'a * 'b" ("(2\<lbrace>_,/ _\<rbrace>)")
	translations
	"\<lbrace>x, y, z\<rbrace>" == "\<lbrace>x, \<lbrace>y, z\<rbrace>\<rbrace>"
	"\<lbrace>x, y\<rbrace>" == "CONST MPair x y"


	definition
	HPair :: "[msg,msg] \<Rightarrow> msg" ("(4Hash[_] /_)" [0, 1000])
	where
	\<comment> \<open>Message Y paired with a MAC computed with the help of X\<close>
	"Hash[X] Y \<equiv> \<lbrace>Hash\<lbrace>X,Y\<rbrace>, Y\<rbrace>"

	definition
	keysFor :: "msg 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 :: "msg set => msg set"
	for H :: "msg set"
	where
	Inj [intro]: "X \<in> H ==> X \<in> parts H"
	\| Fst: "\<lbrace>X,Y\<rbrace> \<in> parts H ==> X \<in> parts H"
	\| Snd: "\<lbrace>X,Y\<rbrace> \<in> parts H ==> Y \<in> parts H"
	\| Body: "Crypt K X \<in> parts H ==> X \<in> parts H"


	text\<open>Monotonicity\<close>
	lemma parts_mono: "G \<subseteq> H ==> parts(G) \<subseteq> parts(H)"
	apply auto
	apply (erule parts.induct)
	apply (blast dest: parts.Fst parts.Snd parts.Body)+
	done


	text\<open>Equations hold because constructors are injective.\<close>
	lemma Other_image_eq [simp]: "(Agent x \<in> Agent`A) = (x:A)"
	by auto

	lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
	by auto

	lemma Nonce_Key_image_eq [simp]: "(Nonce 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 ==> keysFor(G) \<subseteq> keysFor(H)"
	by (unfold keysFor_def, blast)

	lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) 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_Number [simp]: "keysFor (insert (Number 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_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
	by (unfold keysFor_def, auto)

	lemma keysFor_insert_MPair [simp]: "keysFor (insert \<lbrace>X,Y\<rbrace> 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 ==> invKey K \<in> keysFor H"
	by (unfold keysFor_def, blast)


	subsection\<open>Inductive relation "parts"\<close>

	lemma MPair_parts:
	"[\| \<lbrace>X,Y\<rbrace> \<in> parts H;
	[\| X \<in> parts H; Y \<in> parts H \|] ==> P \|] ==> P"
	by (blast dest: parts.Fst parts.Snd)

	declare MPair_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.
	\<open>MPair_parts\<close> 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{} ==> P"
	by simp

	text\<open>WARNING: loops if H = {Y}, therefore must not be repeated!\<close>
	lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
	by (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+)
	done

	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

	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, blast+)
	done

	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 \<open>blast\<close> 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 and transitivity\<close>

	lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
	by (erule parts.induct, blast+)

	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

	lemma parts_trans: "[\| X\<in> parts G; G \<subseteq> parts H \|] ==> X\<in> parts H"
	by (drule parts_mono, blast)

	text\<open>Cut\<close>
	lemma parts_cut:
	"[\| Y\<in> parts (insert X G); X\<in> parts H \|] ==> Y\<in> parts (G \<union> H)"
	by (blast intro: parts_trans)


	lemma parts_cut_eq [simp]: "X\<in> parts H ==> 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_Agent [simp]:
	"parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
	apply (rule parts_insert_eq_I)
	apply (erule parts.induct, auto)
	done

	lemma parts_insert_Nonce [simp]:
	"parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
	apply (rule parts_insert_eq_I)
	apply (erule parts.induct, auto)
	done

	lemma parts_insert_Number [simp]:
	"parts (insert (Number N) H) = insert (Number N) (parts H)"
	apply (rule parts_insert_eq_I)
	apply (erule parts.induct, auto)
	done

	lemma parts_insert_Key [simp]:
	"parts (insert (Key K) H) = insert (Key K) (parts H)"
	apply (rule parts_insert_eq_I)
	apply (erule parts.induct, auto)
	done

	lemma parts_insert_Hash [simp]:
	"parts (insert (Hash X) H) = insert (Hash X) (parts H)"
	apply (rule parts_insert_eq_I)
	apply (erule parts.induct, auto)
	done

	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)
	apply (blast intro: parts.Body)
	done

	lemma parts_insert_MPair [simp]:
	"parts (insert \<lbrace>X,Y\<rbrace> H) =
	insert \<lbrace>X,Y\<rbrace> (parts (insert X (insert Y H)))"
	apply (rule equalityI)
	apply (rule subsetI)
	apply (erule parts.induct, auto)
	apply (blast intro: parts.Fst parts.Snd)+
	done

	lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
	apply auto
	apply (erule parts.induct, auto)
	done


	text\<open>In any message, there is an upper bound N on its greatest nonce.\<close>
	(*
	lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
	apply (induct msg)
	apply (simp_all (no_asm_simp) add: exI parts_insert2)
	txt{MPair case: blast works out the necessary sum itself!}
	prefer 2 apply auto apply (blast elim!: add_leE)
	txt{Nonce case}
	apply (rule_tac x = "N + Suc nat" in exI, auto)
	done
	*)


	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 :: "msg set => msg set"
	for H :: "msg set"
	where
	Inj [intro,simp] : "X \<in> H ==> X \<in> analz H"
	\| Fst: "\<lbrace>X,Y\<rbrace> \<in> analz H ==> X \<in> analz H"
	\| Snd: "\<lbrace>X,Y\<rbrace> \<in> analz H ==> Y \<in> analz H"
	\| Decrypt [dest]:
	"[\|Crypt K X \<in> analz H; Key(invKey K): analz H\|] ==> X \<in> analz H"


	text\<open>Monotonicity; Lemma 1 of Lowe's paper\<close>
	lemma analz_mono: "G\<subseteq>H ==> analz(G) \<subseteq> analz(H)"
	apply auto
	apply (erule analz.induct)
	apply (auto dest: analz.Fst analz.Snd)
	done

	lemmas analz_monotonic = analz_mono [THEN [2] rev_subsetD]

	text\<open>Making it safe speeds up proofs\<close>
	lemma MPair_analz [elim!]:
	"[\| \<lbrace>X,Y\<rbrace> \<in> analz H;
	[\| X \<in> analz H; Y \<in> analz H \|] ==> P
	\|] ==> P"
	by (blast dest: analz.Fst analz.Snd)

	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+)
	done

	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_Agent [simp]:
	"analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)
	done

	lemma analz_insert_Nonce [simp]:
	"analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)
	done

	lemma analz_insert_Number [simp]:
	"analz (insert (Number N) H) = insert (Number N) (analz H)"
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)
	done

	lemma analz_insert_Hash [simp]:
	"analz (insert (Hash X) H) = insert (Hash X) (analz H)"
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)
	done

	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) ==>
	analz (insert (Key K) H) = insert (Key K) (analz H)"
	apply (unfold keysFor_def)
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)
	done

	lemma analz_insert_MPair [simp]:
	"analz (insert \<lbrace>X,Y\<rbrace> H) =
	insert \<lbrace>X,Y\<rbrace> (analz (insert X (insert Y H)))"
	apply (rule equalityI)
	apply (rule subsetI)
	apply (erule analz.induct, auto)
	apply (erule analz.induct)
	apply (blast intro: analz.Fst analz.Snd)+
	done

	text\<open>Can pull out enCrypted message if the Key is not known\<close>
	lemma analz_insert_Crypt:
	"Key (invKey K) \<notin> analz H
	==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
	apply (rule analz_insert_eq_I)
	apply (erule analz.induct, auto)

	done

	lemma lemma1: "Key (invKey K) \<in> analz H ==>
	analz (insert (Crypt K X) H) \<subseteq>
	insert (Crypt K X) (analz (insert X H))"
	apply (rule subsetI)
	apply (erule_tac x = x in analz.induct, auto)
	done

	lemma lemma2: "Key (invKey K) \<in> analz H ==>
	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)
	apply (blast intro: analz_insertI analz.Decrypt)
	done

	lemma analz_insert_Decrypt:
	"Key (invKey K) \<in> analz H ==>
	analz (insert (Crypt K X) H) =
	insert (Crypt K X) (analz (insert X H))"
	by (intro equalityI lemma1 lemma2)

	text\<open>Case analysis: either the message is secure, or it is not! Effective,
	but can cause subgoals to blow up! Use with \<open>split_if\<close>; apparently
	\<open>split_tac\<close> 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)
	apply (erule analz.induct, auto)
	done


	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) ==> X\<in> analz H"
	by (erule analz.induct, blast+)

	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: "[\| X\<in> analz G; G \<subseteq> analz H \|] ==> X\<in> analz H"
	by (drule analz_mono, blast)

	text\<open>Cut; Lemma 2 of Lowe\<close>
	lemma analz_cut: "[\| Y\<in> analz (insert X H); X\<in> analz H \|] ==> Y\<in> analz H"
	by (erule analz_trans, blast)

	(*Cut can be proved easily by induction on
	"Y: analz (insert X H) ==> 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 ==> 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:
	"[\| analz G \<subseteq> analz G'; analz H \<subseteq> analz H' \|]
	==> 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:
	"[\| analz G = analz G'; analz H = analz H' \|]
	==> analz (G \<union> H) = analz (G' \<union> H')"
	by (intro equalityI analz_subset_cong, simp_all)

	lemma analz_insert_cong:
	"analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
	by (force simp only: insert_def intro!: analz_cong)

	text\<open>If there are no pairs or encryptions then analz does nothing\<close>
	lemma analz_trivial:
	"[\| \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H; \<forall>X K. Crypt K X \<notin> H \|] ==> analz H = H"
	apply safe
	apply (erule analz.induct, blast+)
	done

	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)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
	apply (erule analz.induct)
	apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
	done

	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])


	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. Agent names are public domain.
	Numbers can be guessed, but Nonces cannot be.\<close>

	inductive_set
	synth :: "msg set => msg set"
	for H :: "msg set"
	where
	Inj [intro]: "X \<in> H ==> X \<in> synth H"
	\| Agent [intro]: "Agent agt \<in> synth H"
	\| Number [intro]: "Number n \<in> synth H"
	\| Hash [intro]: "X \<in> synth H ==> Hash X \<in> synth H"
	\| MPair [intro]: "[\|X \<in> synth H; Y \<in> synth H\|] ==> \<lbrace>X,Y\<rbrace> \<in> synth H"
	\| Crypt [intro]: "[\|X \<in> synth H; Key(K) \<in> H\|] ==> Crypt K X \<in> synth H"

	text\<open>Monotonicity\<close>
	lemma synth_mono: "G\<subseteq>H ==> synth(G) \<subseteq> synth(H)"
	by (auto, erule synth.induct, auto)

	text\<open>NO \<open>Agent_synth\<close>, as any Agent name can be synthesized.
	The same holds for @{term Number}\<close>
	inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
	inductive_cases Key_synth [elim!]: "Key K \<in> synth H"
	inductive_cases Hash_synth [elim!]: "Hash X \<in> synth H"
	inductive_cases MPair_synth [elim!]: "\<lbrace>X,Y\<rbrace> \<in> synth H"
	inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"


	lemma synth_increasing: "H \<subseteq> synth(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) ==> X\<in> synth H"
	by (erule synth.induct, 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: "[\| X\<in> synth G; G \<subseteq> synth H \|] ==> X\<in> synth H"
	by (drule synth_mono, blast)

	text\<open>Cut; Lemma 2 of Lowe\<close>
	lemma synth_cut: "[\| Y\<in> synth (insert X H); X\<in> synth H \|] ==> Y\<in> synth H"
	by (erule synth_trans, blast)

	lemma Agent_synth [simp]: "Agent A \<in> synth H"
	by blast

	lemma Number_synth [simp]: "Number n \<in> synth H"
	by 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 ==> (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)


	subsubsection\<open>Combinations of parts, analz and synth\<close>

	lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
	apply (rule equalityI)
	apply (rule subsetI)
	apply (erule parts.induct)
	apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
	parts.Fst parts.Snd parts.Body)+
	done

	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"
	apply (rule equalityI)
	apply (rule subsetI)
	apply (erule analz.induct)
	prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
	apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
	done

	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

	text \<open>chsp: added\<close>

	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 ==> 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) ==>
	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:
	"[\|Z \<in> parts (insert X H); X \<in> synth (analz H)\|]
	==> 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) ==>
	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]:
	"(\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) =
	(X \<in> synth (analz H) & Y \<in> synth (analz H))"
	by blast

	lemma Crypt_synth_analz:
	"[\| Key K \<in> analz H; Key (invKey K) \<in> analz H \|]
	==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
	by blast


	lemma Hash_synth_analz [simp]:
	"X \<notin> synth (analz H)
	==> (Hash\<lbrace>X,Y\<rbrace> \<in> synth (analz H)) = (Hash\<lbrace>X,Y\<rbrace> \<in> analz H)"
	by blast


	subsection\<open>HPair: a combination of Hash and MPair\<close>

	subsubsection\<open>Freeness\<close>

	lemma Agent_neq_HPair: "Agent A ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemma Nonce_neq_HPair: "Nonce N ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemma Number_neq_HPair: "Number N ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemma Key_neq_HPair: "Key K ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemma Hash_neq_HPair: "Hash Z ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemma Crypt_neq_HPair: "Crypt K X' ~= Hash[X] Y"
	by (unfold HPair_def, simp)

	lemmas HPair_neqs = Agent_neq_HPair Nonce_neq_HPair Number_neq_HPair
	Key_neq_HPair Hash_neq_HPair Crypt_neq_HPair

	declare HPair_neqs [iff]
	declare HPair_neqs [symmetric, iff]

	lemma HPair_eq [iff]: "(Hash[X'] Y' = Hash[X] Y) = (X' = X & Y'=Y)"
	by (simp add: HPair_def)

	lemma MPair_eq_HPair [iff]:
	"(\<lbrace>X',Y'\<rbrace> = Hash[X] Y) = (X' = Hash\<lbrace>X,Y\<rbrace> & Y'=Y)"
	by (simp add: HPair_def)

	lemma HPair_eq_MPair [iff]:
	"(Hash[X] Y = \<lbrace>X',Y'\<rbrace>) = (X' = Hash\<lbrace>X,Y\<rbrace> & Y'=Y)"
	by (auto simp add: HPair_def)


	subsubsection\<open>Specialized laws, proved in terms of those for Hash and MPair\<close>

	lemma keysFor_insert_HPair [simp]: "keysFor (insert (Hash[X] Y) H) = keysFor H"
	by (simp add: HPair_def)

	lemma parts_insert_HPair [simp]:
	"parts (insert (Hash[X] Y) H) =
	insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (parts (insert Y H)))"
	by (simp add: HPair_def)

	lemma analz_insert_HPair [simp]:
	"analz (insert (Hash[X] Y) H) =
	insert (Hash[X] Y) (insert (Hash\<lbrace>X,Y\<rbrace>) (analz (insert Y H)))"
	by (simp add: HPair_def)

	lemma HPair_synth_analz [simp]:
	"X \<notin> synth (analz H)
	==> (Hash[X] Y \<in> synth (analz H)) =
	(Hash\<lbrace>X, Y\<rbrace> \<in> analz H & Y \<in> synth (analz H))"
	by (simp add: HPair_def)


	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 \<open>analz_insert\<close> rules\<close>

	lemmas pushKeys =
	insert_commute [of "Key K" "Agent C" for K C]
	insert_commute [of "Key K" "Nonce N" for K N]
	insert_commute [of "Key K" "Number 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]

	lemmas pushCrypts =
	insert_commute [of "Crypt X K" "Agent C" for X K C]
	insert_commute [of "Crypt X K" "Agent C" for X K C]
	insert_commute [of "Crypt X K" "Nonce N" for X K N]
	insert_commute [of "Crypt X K" "Number 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 \<open>[simp]\<close> -- messages should not always be
	re-ordered.\<close>
	lemmas pushes = pushKeys pushCrypts


	text\<open>By default only \<open>o_apply\<close> 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 ==> synth (analz(G)) \<subseteq> synth (analz(H))"
	by (iprover intro: synth_mono analz_mono)

	lemma Fake_analz_eq [simp]:
	"X \<in> synth(analz H) ==> 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 simp
	apply (rule synth_analz_mono, blast)
	done

	text\<open>Two generalizations of \<open>analz_insert_eq\<close>\<close>
	lemma gen_analz_insert_eq [rule_format]:
	"X \<in> analz H ==> 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 synth_analz_insert_eq [rule_format]:
	"X \<in> synth (analz H)
	==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
	apply (erule synth.induct)
	apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
	done

	lemma Fake_parts_sing:
	"X \<in> synth (analz H) ==> 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]


	end
	diff --git a/thys/Smooth_Manifolds/Analysis_More.thy b/thys/Smooth_Manifolds/Analysis_More.thy
	--- a/thys/Smooth_Manifolds/Analysis_More.thy
	+++ b/thys/Smooth_Manifolds/Analysis_More.thy
	@@ -1,1394 +1,1394 @@
	section \<open>Library Additions\<close>
	theory Analysis_More
	imports "HOL-Analysis.Equivalence_Lebesgue_Henstock_Integration"
	"HOL-Library.Function_Algebras"
	"HOL-Types_To_Sets.Linear_Algebra_On"
	begin


	lemma openin_open_Int'[intro]:
	"open S \<Longrightarrow> openin (top_of_set U) (S \<inter> U)"
	by (auto simp: openin_open)

	subsection \<open>Parametricity rules for topology\<close>

	text \<open>TODO: also check with theory \<open>Transfer_Euclidean_Space_Vector\<close> in AFP/ODE...\<close>

	context includes lifting_syntax begin

	lemma Sigma_transfer[transfer_rule]:
	"(rel_set A ===> (A ===> rel_set B) ===> rel_set (rel_prod A B)) Sigma Sigma"
	unfolding Sigma_def
	by transfer_prover

	lemma filterlim_transfer[transfer_rule]:
	"((A ===> B) ===> rel_filter B ===> rel_filter A ===> (=)) filterlim filterlim"
	if [transfer_rule]: "bi_unique B"
	unfolding filterlim_iff
	by transfer_prover

	lemma nhds_transfer[transfer_rule]:
	"(A ===> rel_filter A) nhds nhds"
	if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
	unfolding nhds_def
	by transfer_prover

	lemma at_within_transfer[transfer_rule]:
	"(A ===> rel_set A ===> rel_filter A) at_within at_within"
	if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
	unfolding at_within_def
	by transfer_prover

	lemma continuous_on_transfer[transfer_rule]:
	"(rel_set A ===> (A ===> B) ===> (=)) continuous_on continuous_on"
	if [transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
	"bi_unique B" "bi_total B" "(rel_set B ===> (=)) open open"
	unfolding continuous_on_def
	by transfer_prover

	lemma continuous_on_transfer_right_total[transfer_rule]:
	"(rel_set A ===> (A ===> B) ===> (=)) (\<lambda>X::'a::t2_space set. continuous_on (X \<inter> Collect AP)) (\<lambda>Y::'b::t2_space set. continuous_on Y)"
	if DomainA: "Domainp A = AP"
	and [folded DomainA, transfer_rule]: "bi_unique A" "right_total A" "(rel_set A ===> (=)) (openin (top_of_set (Collect AP))) open"
	"bi_unique B" "bi_total B" "(rel_set B ===> (=)) open open"
	unfolding DomainA[symmetric]
	proof (intro rel_funI)
	fix X Y f g
	assume H[transfer_rule]: "rel_set A X Y" "(A ===> B) f g"
	from H(1) have XA: "x \<in> X \<Longrightarrow> Domainp A x" for x
	by (auto simp: rel_set_def)
	then have *: "X \<inter> Collect (Domainp A) = X" by auto
	have "openin (top_of_set (Collect (Domainp A))) (Collect (Domainp A))" by auto
	show " continuous_on (X \<inter> Collect (Domainp A)) f = continuous_on Y g"
	unfolding continuous_on_eq_continuous_within continuous_within_topological *
	apply transfer
	apply safe
	subgoal for x B
	apply (drule bspec, assumption, drule spec, drule mp, assumption, drule mp, assumption)
	apply clarsimp
	subgoal for AA
	apply (rule exI[where x="AA \<inter> Collect (Domainp A)"])
	by (auto intro: XA)
	done
	subgoal using XA by (force simp: openin_subtopology)
	done
	qed

	lemma continuous_on_transfer_right_total2[transfer_rule]:
	"(rel_set A ===> (A ===> B) ===> (=)) (\<lambda>X::'a::t2_space set. continuous_on X) (\<lambda>Y::'b::t2_space set. continuous_on Y)"
	if DomainB: "Domainp B = BP"
	and [folded DomainB, transfer_rule]: "bi_unique A" "bi_total A" "(rel_set A ===> (=)) open open"
	"bi_unique B" "right_total B" "(rel_set B ===> (=)) ((openin (top_of_set (Collect BP)))) open"
	unfolding DomainB[symmetric]
	proof (intro rel_funI)
	fix X Y f g
	assume H[transfer_rule]: "rel_set A X Y" "(A ===> B) f g"
	show "continuous_on X f = continuous_on Y g"
	unfolding continuous_on_eq_continuous_within continuous_within_topological
	apply transfer
	apply safe
	subgoal for x C
	apply (clarsimp simp: openin_subtopology)
	apply (drule bspec, assumption, drule spec, drule mp, assumption, drule mp, assumption)
	apply clarsimp
	by (meson Domainp_applyI H(1) H(2) rel_setD1)
	subgoal for x C
	proof -
	let ?sub = "top_of_set (Collect (Domainp B))"
	assume cont: "\<forall>x\<in>X. \<forall>Ba\<in>{A. Ball A (Domainp B)}.
	openin (top_of_set (Collect (Domainp B))) Ba \<longrightarrow> f x \<in> Ba \<longrightarrow> (\<exists>Aa. open Aa \<and> x \<in> Aa \<and> (\<forall>y\<in>X. y \<in> Aa \<longrightarrow> f y \<in> Ba))"
	and x: "x \<in> X" "open C" "f x \<in> C"
	let ?B = "C \<inter> Collect (Domainp B)"
	have "?B \<in> {A. Ball A (Domainp B)}" by auto
	have "openin ?sub (Collect (Domainp B))" by auto
	then have "openin ?sub ?B" using \<open>open C\<close> by auto
	moreover have "f x \<in> ?B" using x
	apply transfer apply auto
	by (meson Domainp_applyI H(1) H(2) rel_setD1)
	ultimately obtain D where "open D \<and> x \<in> D \<and> (\<forall>y\<in>X. y \<in> D \<longrightarrow> f y \<in> ?B)"
	using cont x
	by blast
	then show "\<exists>A. open A \<and> x \<in> A \<and> (\<forall>y\<in>X. y \<in> A \<longrightarrow> f y \<in> C)" by auto
	qed
	done
	qed


	lemma generate_topology_transfer[transfer_rule]:
	includes lifting_syntax
	assumes [transfer_rule]: "right_total A" "bi_unique A"
	shows "(rel_set (rel_set A) ===> rel_set A ===> (=)) (generate_topology o (insert (Collect (Domainp A)))) generate_topology"
	proof (intro rel_funI)
	fix B C X Y assume t[transfer_rule]: "rel_set (rel_set A) B C" "rel_set A X Y"
	then have "X \<subseteq> Collect (Domainp A)" by (auto simp: rel_set_def)
	with t have rI: "rel_set A (X \<inter> Collect (Domainp A)) Y"
	by (auto simp: inf_absorb1)
	have eq_UNIV_I: "Z = UNIV" if [transfer_rule]: "rel_set A {a. Domainp A a} Z" for Z
	using that assms
	apply (auto simp: right_total_def rel_set_def)
	using bi_uniqueDr by fastforce
	show "(generate_topology \<circ> insert (Collect (Domainp A))) B X = generate_topology C Y"
	unfolding o_def
	proof (rule iffI)
	fix x
	assume "generate_topology (insert (Collect (Domainp A)) B) X"
	then show "generate_topology C Y" unfolding o_def
	using rI
	proof (induction X arbitrary: Y)
	case [transfer_rule]: UNIV
	with eq_UNIV_I[of Y] show ?case
	by (simp add: generate_topology.UNIV)
	next
	case (Int a b)
	note [transfer_rule] = Int(5)
	obtain a' where a'[transfer_rule]: "rel_set A (a \<inter> Collect (Domainp A)) a'"
	by (metis Domainp_iff Domainp_set Int_Collect)
	obtain b' where b'[transfer_rule]: "rel_set A (b \<inter> Collect (Domainp A)) b'"
	by (metis Domainp_iff Domainp_set Int_Collect)
	from Int.IH(1)[OF a'] Int.IH(2)[OF b']
	have "generate_topology C a'" "generate_topology C b'" by auto
	from generate_topology.Int[OF this] have "generate_topology C (a' \<inter> b')" .
	also have "a' \<inter> b' = Y"
	by transfer auto
	finally show ?case
	by (simp add: generate_topology.Int)
	next
	case (UN K)
	note [transfer_rule] = UN(3)
	have "\<exists>K'. \<forall>k. rel_set A (k \<inter> Collect (Domainp A)) (K' k)"
	by (rule choice) (metis Domainp_iff Domainp_set Int_Collect)
	then obtain K' where K': "\<And>k. rel_set A (k \<inter> Collect (Domainp A)) (K' k)" by metis
	from UN.IH[OF _ this] have "generate_topology C k'" if "k' \<in> K'`K" for k' using that by auto
	from generate_topology.UN[OF this] have "generate_topology C (\<Union>(K' ` K))" .
	also
	from K' have [transfer_rule]: "(rel_set (=) ===> rel_set A) (\<lambda>x. x \<inter> Collect (Domainp A)) K'"
	by (fastforce simp: rel_fun_def rel_set_def)
	have "\<Union>(K' ` K) = Y"
	by transfer auto
	finally show ?case
	by (simp add: generate_topology.UN)
	next
	case (Basis s)
	from this(1) show ?case
	proof
	assume "s = Collect (Domainp A)"
	with eq_UNIV_I[of Y] Basis(2)
	show ?case
	by (simp add: generate_topology.UNIV)
	next
	assume "s \<in> B"
	with Basis(2) obtain t where [transfer_rule]: "rel_set A (s \<inter> Collect (Domainp A)) t" by auto
	from Basis(1) t(1) have s: "s \<inter> Collect (Domainp A) = s"
	by (force simp: rel_set_def)
	have "t \<in> C" using \<open>s \<in> B\<close> s
	by transfer auto
	also note [transfer_rule] = Basis(2)
	have "t = Y"
	by transfer auto
	finally show ?case
	by (rule generate_topology.Basis)
	qed
	qed
	next
	assume "generate_topology C Y"
	then show "generate_topology (insert (Collect (Domainp A)) B) X"
	using \<open>rel_set A X Y\<close>
	proof (induction arbitrary: X)
	case [transfer_rule]: UNIV
	have "UNIV = (UNIV::'b set)" by auto
	then have "X = {a. Domainp A a}" by transfer
	then show ?case by (intro generate_topology.Basis) auto
	next
	case (Int a b)
	obtain a' b' where [transfer_rule]: "rel_set A a' a" "rel_set A b' b"
	by (meson assms(1) right_total_def right_total_rel_set)
	from generate_topology.Int[OF Int.IH(1)[OF this(1)] Int.IH(2)[OF this(2)]]
	have "generate_topology (insert {a. Domainp A a} B) (a' \<inter> b')" by simp
	also
	define I where "I = a \<inter> b"
	from \<open>rel_set A X (a \<inter> b)\<close> have [transfer_rule]: "rel_set A X I" by (simp add: I_def)
	from I_def
	have "a' \<inter> b' = X" by transfer simp
	finally show ?case .
	next
	case (UN K)
	have "\<exists>K'. \<forall>k. rel_set A (K' k) k"
	by (rule choice) (meson assms(1) right_total_def right_total_rel_set)
	then obtain K' where K': "\<And>k. rel_set A (K' k) k" by metis
	from UN.IH[OF _ this] have "generate_topology (insert {a. Domainp A a} B) k"
	if "k \<in> K'`K" for k using that by auto
	from generate_topology.UN[OF this]
	have "generate_topology (insert {a. Domainp A a} B) (\<Union>(K'`K))" by auto
	also
	from K' have [transfer_rule]: "(rel_set (=) ===> rel_set A) K' id"
	by (fastforce simp: rel_fun_def rel_set_def)
	define U where "U = (\<Union>(id ` K))"
	from \<open>rel_set A X _\<close> have [transfer_rule]: "rel_set A X U" by (simp add: U_def)
	from U_def have "\<Union>(K' ` K) = X" by transfer simp
	finally show ?case .
	next
	case (Basis s)
	note [transfer_rule] = \<open>rel_set A X s\<close>
	from \<open>s \<in> C\<close> have "X \<in> B" by transfer
	then show ?case by (intro generate_topology.Basis) auto
	qed
	qed
	qed

	end


	subsection \<open>Miscellaneous\<close>

	lemmas [simp del] = mem_ball

	lemma in_closureI[intro, simp]: "x \<in> X \<Longrightarrow> x \<in> closure X"
	using closure_subset by auto

	lemmas open_continuous_vimage = continuous_on_open_vimage[THEN iffD1, rule_format]
	lemma open_continuous_vimage': "open s \<Longrightarrow> continuous_on s f \<Longrightarrow> open B \<Longrightarrow> open (s \<inter> f -` B)"
	using open_continuous_vimage[of s f B] by (auto simp: Int_commute)

	lemma support_on_mono: "support_on carrier f \<subseteq> support_on carrier g"
	if "\<And>x. x \<in> carrier \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> g x \<noteq> 0"
	using that
	by (auto simp: support_on_def)


	lemma image_prod: "(\<lambda>(x, y). (f x, g y)) ` (A \<times> B) = f ` A \<times> g ` B" by auto


	subsection \<open>Closed support\<close>

	definition "csupport_on X S = closure (support_on X S)"

	lemma closed_csupport_on[intro, simp]: "closed (csupport_on carrier \<phi>)"
	by (auto simp: csupport_on_def)

	lemma not_in_csupportD: "x \<notin> csupport_on carrier \<phi> \<Longrightarrow> x \<in> carrier \<Longrightarrow> \<phi> x = 0"
	by (auto simp: csupport_on_def support_on_def)

	lemma csupport_on_mono: "csupport_on carrier f \<subseteq> csupport_on carrier g"
	if "\<And>x. x \<in> carrier \<Longrightarrow> f x \<noteq> 0 \<Longrightarrow> g x \<noteq> 0"
	unfolding csupport_on_def
	apply (rule closure_mono)
	using that
	by (rule support_on_mono)

	subsection \<open>Homeomorphism\<close>

	lemma homeomorphism_empty[simp]:
	"homeomorphism {} t f f' \<longleftrightarrow> t = {}"
	"homeomorphism s {} f f' \<longleftrightarrow> s = {}"
	by (auto simp: homeomorphism_def)

	lemma homeomorphism_add:
	"homeomorphism UNIV UNIV (\<lambda>x. x + c) (\<lambda>x. x - c)"
	for c::"_::real_normed_vector"
	unfolding homeomorphism_def
	by (auto simp: algebra_simps continuous_intros intro!: image_eqI[where x="x - c" for x])

	lemma in_range_scaleR_iff: "x \<in> range ((*\<^sub>R) c) \<longleftrightarrow> c = 0 \<longrightarrow> x = 0"
	for x::"_::real_vector"
	by (auto simp: intro!: image_eqI[where x="x /\<^sub>R c"])

	lemma homeomorphism_scaleR:
	"homeomorphism UNIV UNIV (\<lambda>x. c *\<^sub>R x::_::real_normed_vector) (\<lambda>x. x /\<^sub>R c)"
	if "c \<noteq> 0"
	using that
	unfolding homeomorphism_def
	by (auto simp: in_range_scaleR_iff algebra_simps intro!: continuous_intros)


	lemma homeomorphism_prod:
	"homeomorphism (a \<times> b) (c \<times> d) (\<lambda>(x, y). (f x, g y)) (\<lambda>(x, y). (f' x, g' y))"
	if "homeomorphism a c f f'"
	"homeomorphism b d g g'"
	using that by (simp add: homeomorphism_def image_prod)
	(auto simp add: split_beta intro!: continuous_intros elim: continuous_on_compose2)


	subsection \<open>Generalizations\<close>

	lemma openin_subtopology_eq_generate_topology:
	"openin (top_of_set S) x = generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x"
	if open_gen: "open = generate_topology BB" and subset: "x \<subseteq> S"
	proof -
	have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (T \<inter> S)"
	if "generate_topology BB T"
	for T
	using that
	proof (induction)
	case UNIV
	then show ?case by (auto intro!: generate_topology.Basis)
	next
	case (Int a b)
	have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (a \<inter> S \<inter> (b \<inter> S))"
	by (rule generate_topology.Int) (use Int in auto)
	then show ?case by (simp add: ac_simps)
	next
	case (UN K)
	then have "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) (\<Union>k\<in>K. k \<inter> S)"
	by (intro generate_topology.UN) auto
	then show ?case by simp
	next
	case (Basis s)
	then show ?case
	by (intro generate_topology.Basis) auto
	qed
	moreover
	have "\<exists>T. generate_topology BB T \<and> x = T \<inter> S"
	if "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x" "x \<noteq> UNIV"
	using that
	proof (induction)
	case UNIV
	then show ?case by simp
	next
	case (Int a b)
	then show ?case
	using generate_topology.Int
	by auto
	next
	case (UN K)
	from UN.IH have "\<forall>k\<in>K-{UNIV}. \<exists>T. generate_topology BB T \<and> k = T \<inter> S" by auto
	from this[THEN bchoice] obtain T where T: "\<And>k. k \<in> T ` (K - {UNIV}) \<Longrightarrow> generate_topology BB k" "\<And>k. k \<in> K - {UNIV} \<Longrightarrow> k = (T k) \<inter> S"
	by auto
	from generate_topology.UN[OF T(1)]
	have "generate_topology BB (\<Union>(T ` (K - {UNIV})))" by auto
	moreover have "\<Union>K = (\<Union>(T ` (K - {UNIV}))) \<inter> S" if "UNIV \<notin> K" using T(2) UN that by auto
	ultimately show ?case
	apply (cases "UNIV \<in> K") subgoal using UN by auto
	subgoal by auto
	done
	next
	case (Basis s)
	then show ?case
	using generate_topology.UNIV generate_topology.Basis by blast
	qed
	moreover
	have "\<exists>T. generate_topology BB T \<and> UNIV = T \<inter> S" if "generate_topology (insert S ((\<lambda>B. B \<inter> S) ` BB)) x"
	"x = UNIV"
	proof -
	have "S = UNIV"
	using that \<open>x \<subseteq> S\<close>
	by auto
	then show ?thesis by (simp add: generate_topology.UNIV)
	qed
	ultimately show ?thesis
	by (metis open_gen open_openin openin_open_Int' openin_subtopology)
	qed

	subsection \<open>Equal topologies\<close>

	lemma topology_eq_iff: "t = s \<longleftrightarrow> (topspace t = topspace s \<and>
	(\<forall>x\<subseteq>topspace t. openin t x = openin s x))"
	by (metis (full_types) openin_subset topology_eq)


	subsection \<open>Finer topologies\<close>

	definition finer_than (infix "(finer'_than)" 50)
	where "T1 finer_than T2 \<longleftrightarrow> continuous_map T1 T2 (\<lambda>x. x)"

	lemma finer_than_iff_nhds:
	"T1 finer_than T2 \<longleftrightarrow> (\<forall>X. openin T2 X \<longrightarrow> openin T1 (X \<inter> topspace T1)) \<and> (topspace T1 \<subseteq> topspace T2)"
	by (auto simp: finer_than_def continuous_map_alt)

	lemma continuous_on_finer_topo:
	"continuous_map s t f"
	if "continuous_map s' t f" "s finer_than s'"
	using that
	by (auto simp: finer_than_def o_def dest: continuous_map_compose)

	lemma continuous_on_finer_topo2:
	"continuous_map s t f"
	if "continuous_map s t' f" "t' finer_than t"
	using that
	by (auto simp: finer_than_def o_def dest: continuous_map_compose)

	lemma antisym_finer_than: "S = T" if "S finer_than T" "T finer_than S"
	using that
	apply (auto simp: finer_than_def topology_eq_iff continuous_map_alt)
	apply (metis inf.orderE)+
	done

	lemma subtopology_finer_than[simp]: "top_of_set X finer_than euclidean"
	by (auto simp: finer_than_iff_nhds openin_subtopology)

	subsection \<open>Support\<close>

	lemma support_on_nonneg_sum:
	"support_on X (\<lambda>x. \<Sum>i\<in>S. f i x) = (\<Union>i\<in>S. support_on X (f i))"
	if "finite S" "\<And>x i . x \<in> X \<Longrightarrow> i \<in> S \<Longrightarrow> f i x \<ge> 0"
	for f::"_\<Rightarrow>_\<Rightarrow>_::ordered_comm_monoid_add"
	using that by (auto simp: support_on_def sum_nonneg_eq_0_iff)

	lemma support_on_nonneg_sum_subset:
	"support_on X (\<lambda>x. \<Sum>i\<in>S. f i x) \<subseteq> (\<Union>i\<in>S. support_on X (f i))"
	for f::"_\<Rightarrow>_\<Rightarrow>_::ordered_comm_monoid_add"
	by (cases "finite S") (auto simp: support_on_def, meson sum.neutral)

	lemma support_on_nonneg_sum_subset':
	"support_on X (\<lambda>x. \<Sum>i\<in>S x. f i x) \<subseteq> (\<Union>x\<in>X. (\<Union>i\<in>S x. support_on X (f i)))"
	for f::"_\<Rightarrow>_\<Rightarrow>_::ordered_comm_monoid_add"
	by (auto simp: support_on_def, meson sum.neutral)

	subsection \<open>Final topology (Bourbaki, General Topology I, 4.)\<close>

	definition "final_topology X Y f =
	topology (\<lambda>U. U \<subseteq> X \<and>
	(\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i))))"

	lemma openin_final_topology:
	"openin (final_topology X Y f) =
	(\<lambda>U. U \<subseteq> X \<and> (\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i))))"
	unfolding final_topology_def
	apply (rule topology_inverse')
	unfolding istopology_def
	proof safe
	fix S T i
	assume "\<forall>i. openin (Y i) (f i -` S \<inter> topspace (Y i))"
	"\<forall>i. openin (Y i) (f i -` T \<inter> topspace (Y i))"
	then have "openin (Y i) (f i -` S \<inter> topspace (Y i) \<inter> (f i -` T \<inter> topspace (Y i)))"
	(is "openin _ ?I")
	by auto
	also have "?I = f i -` (S \<inter> T) \<inter> topspace (Y i)"
	(is "_ = ?R")
	by auto
	finally show "openin (Y i) ?R" .
	next
	fix K i
	assume "\<forall>U\<in>K. U \<subseteq> X \<and> (\<forall>i. openin (Y i) (f i -` U \<inter> topspace (Y i)))"
	then have "openin (Y i) (\<Union>X\<in>K. f i -` X \<inter> topspace (Y i))"
	by (intro openin_Union) auto
	then show "openin (Y i) (f i -` \<Union>K \<inter> topspace (Y i))"
	by (auto simp: vimage_Union)
	qed force+

	lemma topspace_final_topology:
	"topspace (final_topology X Y f) = X"
	if "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X"
	proof -
	have *: "f i -` X \<inter> topspace (Y i) = topspace (Y i)" for i
	using that
	by auto
	show ?thesis
	unfolding topspace_def
	unfolding openin_final_topology
	apply (rule antisym)
	apply force
	apply (rule subsetI)
	apply (rule UnionI[where X=X])
	using that
	by (auto simp: *)
	qed

	lemma continuous_on_final_topologyI2:
	"continuous_map (Y i) (final_topology X Y f) (f i)"
	if "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X"
	using that
	by (auto simp: openin_final_topology continuous_map_alt topspace_final_topology)

	lemma continuous_on_final_topologyI1:
	"continuous_map (final_topology X Y f) Z g"
	if hyp: "\<And>i. continuous_map (Y i) Z (g o f i)"
	and that: "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X" "g \<in> X \<rightarrow> topspace Z"
	unfolding continuous_map_alt
	proof safe
	fix V assume V: "openin Z V"
	have oV: "openin (Y i) (f i -` g -` V \<inter> topspace (Y i))"
	for i
	using hyp[rule_format, of i] V
	by (auto simp: continuous_map_alt vimage_comp dest!: spec[where x=V])
	have *: "f i -` g -` V \<inter> f i -` X \<inter> topspace (Y i) =
	f i -` g -` V \<inter> topspace (Y i)"
	(is "_ = ?rhs i")
	for i using that
	by auto
	show "openin (final_topology X Y f) (g -` V \<inter> topspace (final_topology X Y f))"
	by (auto simp: openin_final_topology oV topspace_final_topology that *)
	qed (use that in \<open>auto simp: topspace_final_topology\<close>)


	lemma continuous_on_final_topology_iff:
	"continuous_map (final_topology X Y f) Z g \<longleftrightarrow> (\<forall>i. continuous_map (Y i) Z (g o f i))"
	if "\<And>i. f i \<in> topspace (Y i) \<rightarrow> X" "g \<in> X \<rightarrow> topspace Z"
	using that
	by (auto intro!: continuous_on_final_topologyI1[OF _ that]
	intro: continuous_map_compose[OF continuous_on_final_topologyI2[OF that(1)]])


	subsection \<open>Quotient topology\<close>

	definition map_topology :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a topology \<Rightarrow> 'b topology" where
	"map_topology p X = final_topology (p ` topspace X) (\<lambda>_. X) (\<lambda>(_::unit). p)"

	lemma openin_map_topology:
	"openin (map_topology p X) = (\<lambda>U. U \<subseteq> p ` topspace X \<and> openin X (p -` U \<inter> topspace X))"
	by (auto simp: map_topology_def openin_final_topology)

	lemma topspace_map_topology[simp]: "topspace (map_topology f T) = f ` topspace T"
	unfolding map_topology_def
	by (subst topspace_final_topology) auto

	lemma continuous_on_map_topology:
	"continuous_map T (map_topology f T) f"
	unfolding continuous_map_alt openin_map_topology
	by auto

	lemma continuous_map_composeD:
	"continuous_map T X (g \<circ> f) \<Longrightarrow> g \<in> f ` topspace T \<rightarrow> topspace X"
	by (auto simp: continuous_map_def)

	lemma continuous_on_map_topology2:
	"continuous_map T X (g \<circ> f) \<longleftrightarrow> continuous_map (map_topology f T) X g"
	unfolding map_topology_def
	apply safe
	subgoal
	apply (rule continuous_on_final_topologyI1)
	subgoal by assumption
	subgoal by force
	subgoal by (rule continuous_map_composeD)
	done
	subgoal
	apply (erule continuous_map_compose[rotated])
	apply (rule continuous_on_final_topologyI2)
	by force
	done

	lemma map_sub_finer_than_commute:
	"map_topology f (subtopology T (f -` X)) finer_than subtopology (map_topology f T) X"
	by (auto simp: finer_than_def continuous_map_def openin_subtopology openin_map_topology
	topspace_subtopology)

	lemma sub_map_finer_than_commute:
	"subtopology (map_topology f T) X finer_than map_topology f (subtopology T (f -` X))"
	if "openin T (f -` X)"\<comment> \<open>this is more or less the condition from
	\<^url>\<open>https://math.stackexchange.com/questions/705840/quotient-topology-vs-subspace-topology\<close>\<close>
	unfolding finer_than_def continuous_map_alt
	proof (rule conjI, clarsimp)
	fix U
	assume "openin (map_topology f (subtopology T (f -` X))) U"
	then obtain W where W: "U \<subseteq> f ` (topspace T \<inter> f -` X)" "openin T W" "f -` U \<inter> (topspace T \<inter> f -` X) = W \<inter> f -` X"
	by (auto simp: topspace_subtopology openin_subtopology openin_map_topology)
	have "(f -` f ` W \<inter> f -` X) \<inter> topspace T = W \<inter> topspace T \<inter> f -` X"
	apply auto
	by (metis Int_iff W(3) vimage_eq)
	also have "openin T \<dots>"
	by (auto intro!: W that)
	finally show "openin (subtopology (map_topology f T) X) (U \<inter> (f ` topspace T \<inter> X))"
	using W
	unfolding topspace_subtopology topspace_map_topology openin_subtopology openin_map_topology
	by (intro exI[where x="(f ` W \<inter> X)"]) auto
	qed auto

	lemma subtopology_map_topology:
	"subtopology (map_topology f T) X = map_topology f (subtopology T (f -` X))"
	if "openin T (f -` X)"
	apply (rule antisym_finer_than)
	using sub_map_finer_than_commute[OF that] map_sub_finer_than_commute[of f T X]
	by auto

	lemma quotient_map_map_topology:
	"quotient_map X (map_topology f X) f"
	by (auto simp: quotient_map_def openin_map_topology ac_simps)
	(simp_all add: vimage_def Int_def)

	lemma topological_space_quotient: "class.topological_space (openin (map_topology f euclidean))"
	if "surj f"
	apply standard
	- apply (auto simp: )
	+ apply auto
	using that
	by (auto simp: openin_map_topology)

	lemma t2_space_quotient: "class.t2_space (open::'b set \<Rightarrow> bool)"
	if open_def: "open = (openin (map_topology (p::'a::t2_space\<Rightarrow>'b::topological_space) euclidean))"
	"surj p" and open_p: "\<And>X. open X \<Longrightarrow> open (p ` X)" and "closed {(x, y). p x = p y}" (is "closed ?R")
	apply (rule class.t2_space.intro)
	subgoal by (unfold open_def, rule topological_space_quotient; fact)
	proof standard
	fix a b::'b
	obtain x y where a_def: "a = p x" and b_def: "b = p y" using \<open>surj p\<close> by fastforce
	assume "a \<noteq> b"
	with \<open>closed ?R\<close> have "open (-?R)" "(x, y) \<in> -?R" by (auto simp add: a_def b_def)
	from open_prod_elim[OF this]
	obtain N\<^sub>x N\<^sub>y where "open N\<^sub>x" "open N\<^sub>y" "(x, y) \<in> N\<^sub>x \<times> N\<^sub>y" "N\<^sub>x \<times> N\<^sub>y \<subseteq> -?R" .
	then have "p ` N\<^sub>x \<inter> p ` N\<^sub>y = {}" by auto
	moreover
	from \<open>open N\<^sub>x\<close> \<open>open N\<^sub>y\<close> have "open (p ` N\<^sub>x)" "open (p ` N\<^sub>y)"
	using open_p by blast+
	moreover have "a \<in> p ` N\<^sub>x" "b \<in> p ` N\<^sub>y" using \<open>(x, y) \<in> _ \<times> _\<close> by (auto simp: a_def b_def)
	ultimately show "\<exists>U V. open U \<and> open V \<and> a \<in> U \<and> b \<in> V \<and> U \<inter> V = {}" by blast
	qed

	lemma second_countable_topology_quotient: "class.second_countable_topology (open::'b set \<Rightarrow> bool)"
	if open_def: "open = (openin (map_topology (p::'a::second_countable_topology\<Rightarrow>'b::topological_space) euclidean))"
	"surj p" and open_p: "\<And>X. open X \<Longrightarrow> open (p ` X)"
	apply (rule class.second_countable_topology.intro)
	subgoal by (unfold open_def, rule topological_space_quotient; fact)
	proof standard
	have euclidean_def: "euclidean = map_topology p euclidean"
	by (simp add: openin_inverse open_def)
	have continuous_on: "continuous_on UNIV p"
	using continuous_map_iff_continuous2 continuous_on_map_topology euclidean_def by fastforce
	from ex_countable_basis[where 'a='a] obtain A::"'a set set" where "countable A" "topological_basis A"
	by auto
	define B where "B = (\<lambda>X. p ` X) ` A"
	have "countable (B::'b set set)"
	by (auto simp: B_def intro!: \<open>countable A\<close>)
	moreover have "topological_basis B"
	proof (rule topological_basisI)
	fix B' assume "B' \<in> B" then show "open B'" using \<open>topological_basis A\<close>
	by (auto simp: B_def topological_basis_open intro!: open_p)
	next
	fix x::'b and O' assume "open O'" "x \<in> O'"
	have "open (p -` O')"
	using \<open>open O'\<close>
	by (rule open_vimage) (auto simp: continuous_on)
	obtain y where y: "y \<in> p -` {x}"
	using \<open>x \<in> O'\<close>
	by auto (metis UNIV_I open_def(2) rangeE)
	then have "y \<in> p -` O'" using \<open>x \<in> O'\<close> by auto
	from topological_basisE[OF \<open>topological_basis A\<close> \<open>open (p -` O')\<close> this]
	obtain C where "C \<in> A" "y \<in> C" "C \<subseteq> p -` O'" .
	let ?B' = "p ` C"
	have "?B' \<in> B"
	using \<open>C \<in> A\<close> by (auto simp: B_def)
	moreover
	have "x \<in> ?B'" using y \<open>y \<in> C\<close> \<open>x \<in> O'\<close>
	by auto
	moreover
	have "?B' \<subseteq> O'"
	using \<open>C \<subseteq> _\<close> by auto
	ultimately show "\<exists>B'\<in>B. x \<in> B' \<and> B' \<subseteq> O'" by metis
	qed
	ultimately show "\<exists>B::'b set set. countable B \<and> open = generate_topology B"
	by (auto simp: topological_basis_imp_subbasis)
	qed


	subsection \<open>Closure\<close>

	lemma closure_Union: "closure (\<Union>X) = (\<Union>x\<in>X. closure x)" if "finite X"
	using that
	by (induction X) auto

	subsection \<open>Compactness\<close>

	lemma compact_if_closed_subset_of_compact:
	"compact S" if "closed S" "compact T" "S \<subseteq> T"
	proof (rule compactI)
	fix UU assume UU: "\<forall>t\<in>UU. open t" "S \<subseteq> \<Union>UU"
	have "T \<subseteq> \<Union>(insert (- S) (UU))" "\<And>B. B \<in> insert (- S) UU \<Longrightarrow> open B"
	using UU \<open>S \<subseteq> T\<close>
	by (auto simp: open_Compl \<open>closed S\<close>)
	from compactE[OF \<open>compact T\<close> this]
	obtain \<T>' where \<T>: "\<T>' \<subseteq> insert (- S) UU" "finite \<T>'" "T \<subseteq> \<Union>\<T>'"
	by metis
	show "\<exists>C'\<subseteq>UU. finite C' \<and> S \<subseteq> \<Union>C'"
	apply (rule exI[where x="\<T>' - {-S}"])
	using \<T> UU
	apply auto
	proof -
	fix x assume "x \<in> S"
	with \<T> \<open>S \<subseteq> T\<close> obtain U where "x \<in> U" "U \<in> \<T>'" using \<T>
	by auto
	then show "\<exists>X\<in>\<T>' - {- S}. x \<in> X"
	using \<T> UU \<open>x \<in> S\<close>
	apply -
	apply (rule bexI[where x=U])
	by auto
	qed
	qed

	subsection \<open>Locally finite\<close>

	definition "locally_finite_on X I U \<longleftrightarrow> (\<forall>p\<in>X. \<exists>N. p\<in>N \<and> open N \<and> finite {i\<in>I. U i \<inter> N \<noteq> {}})"

	lemmas locally_finite_onI = locally_finite_on_def[THEN iffD2, rule_format]

	lemma locally_finite_onE:
	assumes "locally_finite_on X I U"
	assumes "p \<in> X"
	obtains N where "p \<in> N" "open N" "finite {i\<in>I. U i \<inter> N \<noteq> {}}"
	using assms
	by (auto simp: locally_finite_on_def)

	lemma locally_finite_onD:
	assumes "locally_finite_on X I U"
	assumes "p \<in> X"
	shows "finite {i\<in>I. p \<in> U i}"
	apply (rule locally_finite_onE[OF assms])
	apply (rule finite_subset)
	by auto

	lemma locally_finite_on_open_coverI: "locally_finite_on X I U"
	if fin: "\<And>j. j \<in> I \<Longrightarrow> finite {i\<in>I. U i \<inter> U j \<noteq> {}}"
	and open_cover: "X \<subseteq> (\<Union>i\<in>I. U i)" "\<And>i. i \<in> I \<Longrightarrow> open (U i)"
	proof (rule locally_finite_onI)
	fix p assume "p \<in> X"
	then obtain i where i: "i \<in> I" "p \<in> U i" "open (U i)"
	using open_cover
	by blast
	show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. U i \<inter> N \<noteq> {}}"
	by (intro exI[where x="U i"] conjI i fin)
	qed

	lemma locally_finite_compactD:
	"finite {i\<in>I. U i \<inter> V \<noteq> {}}"
	if lf: "locally_finite_on X I U"
	and compact: "compact V"
	and subset: "V \<subseteq> X"
	proof -
	have "\<exists>N. \<forall>p \<in> X. p \<in> N p \<and> open (N p) \<and> finite {i\<in>I. U i \<inter> N p \<noteq> {}}"
	by (rule bchoice) (auto elim!: locally_finite_onE[OF lf, rule_format])
	then obtain N where N: "\<And>p. p \<in> X \<Longrightarrow> p \<in> N p"
	"\<And>p. p \<in> X \<Longrightarrow> open (N p)"
	"\<And>p. p \<in> X \<Longrightarrow> finite {i\<in>I. U i \<inter> N p \<noteq> {}}"
	by blast
	have "V \<subseteq> (\<Union>p\<in>X. N p)" "\<And>B. B \<in> N ` X \<Longrightarrow> open B"
	using N subset by force+
	from compactE[OF compact this]
	obtain C where C: "C \<subseteq> X" "finite C" "V \<subseteq> \<Union>(N ` C)"
	by (metis finite_subset_image)
	then have "{i\<in>I. U i \<inter> V \<noteq> {}} \<subseteq> {i\<in>I. U i \<inter> \<Union>(N ` C) \<noteq> {}}"
	by force
	also have "\<dots> \<subseteq> (\<Union>c\<in>C. {i\<in>I. U i \<inter> N c \<noteq> {}})"
	by force
	also have "finite \<dots>"
	apply (rule finite_Union)
	using C by (auto intro!: C N)
	finally (finite_subset) show ?thesis .
	qed

	lemma closure_Int_open_eq_empty: "open S \<Longrightarrow> (closure T \<inter> S) = {} \<longleftrightarrow> T \<inter> S = {}"
	by (auto simp: open_Int_closure_eq_empty ac_simps)

	lemma locally_finite_on_subset:
	assumes "locally_finite_on X J U"
	assumes "\<And>i. i \<in> I \<Longrightarrow> V i \<subseteq> U i" "I \<subseteq> J"
	shows "locally_finite_on X I V"
	proof (rule locally_finite_onI)
	fix p assume "p \<in> X"
	from locally_finite_onE[OF assms(1) this]
	obtain N where "p \<in> N" "open N" "finite {i \<in> J. U i \<inter> N \<noteq> {}}" .
	then show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. V i \<inter> N \<noteq> {}}"
	apply (intro exI[where x=N])
	using assms
	by (auto elim!: finite_subset[rotated])
	qed

	lemma locally_finite_on_closure:
	"locally_finite_on X I (\<lambda>x. closure (U x))"
	if "locally_finite_on X I U"
	proof (rule locally_finite_onI)
	fix p assume "p \<in> X"
	from locally_finite_onE[OF that this] obtain N
	where "p \<in> N" "open N" "finite {i \<in> I. U i \<inter> N \<noteq> {}}" .
	then show "\<exists>N. p \<in> N \<and> open N \<and> finite {i \<in> I. closure (U i) \<inter> N \<noteq> {}}"
	by (auto intro!: exI[where x=N] simp: closure_Int_open_eq_empty)
	qed


	lemma locally_finite_on_closedin_Union_closure:
	"closedin (top_of_set X) (\<Union>i\<in>I. closure (U i))"
	if "locally_finite_on X I U" "\<And>i. i \<in> I \<Longrightarrow> closure (U i) \<subseteq> X"
	unfolding closedin_def
	apply safe
	subgoal using that(2) by auto
	subgoal
	apply (subst openin_subopen)
	proof clarsimp
	fix x
	assume x: "x \<in> X" "\<forall>i\<in>I. x \<notin> closure (U i)"
	from locally_finite_onE[OF that(1) \<open>x \<in> X\<close>]
	obtain N where N: "x \<in> N" "open N" "finite {i \<in> I. U i \<inter> N \<noteq> {}}" (is "finite ?I").
	define N' where "N' = N - (\<Union>i \<in> ?I. closure (U i))"
	have "open N'"
	by (auto simp: N'_def intro!: N)
	then have "openin (top_of_set X) (X \<inter> N')"
	by (rule openin_open_Int)
	moreover
	have "x \<in> X \<inter> N'" using x
	by (auto simp: N'_def N)
	moreover
	have "X \<inter> N' \<subseteq> X - (\<Union>i\<in>I. closure (U i))"
	using x that(2)
	apply (auto simp: N'_def)
	by (meson N(2) closure_iff_nhds_not_empty dual_order.refl)
	ultimately show "\<exists>T. openin (top_of_set X) T \<and> x \<in> T \<and> T \<subseteq> X - (\<Union>i\<in>I. closure (U i))"
	by auto
	qed
	done

	lemma closure_subtopology_minimal:
	"S \<subseteq> T \<Longrightarrow> closedin (top_of_set X) T \<Longrightarrow> closure S \<inter> X \<subseteq> T"
	apply (auto simp: closedin_closed)
	using closure_minimal by blast

	lemma locally_finite_on_closure_Union:
	"(\<Union>i\<in>I. closure (U i)) = closure (\<Union>i\<in>I. (U i)) \<inter> X"
	if "locally_finite_on X I U" "\<And>i. i \<in> I \<Longrightarrow> closure (U i) \<subseteq> X"
	proof (rule antisym)
	show "(\<Union>i\<in>I. closure (U i)) \<subseteq> closure (\<Union>i\<in>I. U i) \<inter> X"
	using that
	apply auto
	by (metis (no_types, lifting) SUP_le_iff closed_closure closure_minimal closure_subset subsetCE)
	show "closure (\<Union>i\<in>I. U i) \<inter> X \<subseteq> (\<Union>i\<in>I. closure (U i))"
	apply (rule closure_subtopology_minimal)
	apply auto
	using that
	by (auto intro!: locally_finite_on_closedin_Union_closure)
	qed


	subsection \<open>Refinement of cover\<close>

	definition refines :: "'a set set \<Rightarrow> 'a set set \<Rightarrow> bool" (infix "refines" 50)
	where "A refines B \<longleftrightarrow> (\<forall>s\<in>A. (\<exists>t. t \<in> B \<and> s \<subseteq> t))"

	lemma refines_subset: "x refines y" if "z refines y" "x \<subseteq> z"
	using that by (auto simp: refines_def)

	subsection \<open>Functions as vector space\<close>

	instantiation "fun" :: (type, scaleR) scaleR begin

	definition scaleR_fun :: "real \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
	"scaleR_fun r f = (\<lambda>x. r *\<^sub>R f x)"

	lemma scaleR_fun_beta[simp]: "(r \<^sub>R f) x = r \<^sub>R f x"
	by (simp add: scaleR_fun_def)

	instance ..

	end

	instance "fun" :: (type, real_vector) real_vector
	by standard (auto simp: scaleR_fun_def algebra_simps)


	subsection \<open>Additional lemmas\<close>

	lemmas [simp del] = vimage_Un vimage_Int

	lemma finite_Collect_imageI: "finite {U \<in> f ` X. P U}" if "finite {x\<in>X. P (f x)}"
	proof -
	have "{d \<in> f ` X. P d} \<subseteq> f ` {c \<in> X. P (f c)}"
	by blast
	then show ?thesis
	using finite_surj that by blast
	qed

	lemma plus_compose: "(x + y) \<circ> f = (x \<circ> f) + (y \<circ> f)"
	by auto

	lemma mult_compose: "(x * y) \<circ> f = (x \<circ> f) * (y \<circ> f)"
	by auto

	lemma scaleR_compose: "(c \<^sub>R x) \<circ> f = c \<^sub>R (x \<circ> f)"
	by (auto simp:)

	lemma image_scaleR_ball:
	fixes a :: "'a::real_normed_vector"
	shows "c \<noteq> 0 \<Longrightarrow> (\<^sub>R) c ` ball a r = ball (c \<^sub>R a) (abs c *\<^sub>R r)"
	proof (auto simp: mem_ball dist_norm, goal_cases)
	case (1 b)
	have "norm (c \<^sub>R a - c \<^sub>R b) = abs c * norm (a - b)"
	by (auto simp: norm_scaleR[symmetric] algebra_simps simp del: norm_scaleR)
	also have "\<dots> < abs c * r"
	apply (rule mult_strict_left_mono)
	using 1 by auto
	finally show ?case .
	next
	case (2 x)
	have "norm (a - x /\<^sub>R c) < r"
	proof -
	have "norm (a - x /\<^sub>R c) = abs c *\<^sub>R norm (a - x /\<^sub>R c) /\<^sub>R abs c"
	using 2 by auto
	also have "abs c \<^sub>R norm (a - x /\<^sub>R c) = norm (c \<^sub>R a - x)"
	using 2
	by (auto simp: norm_scaleR[symmetric] algebra_simps simp del: norm_scaleR)
	also have "\<dots> < \<bar>c\<bar> * r"
	by fact
	also have "\<bar>c\<bar> * r /\<^sub>R \<bar>c\<bar> = r" using 2 by auto
	finally show ?thesis using 2 by auto
	qed
	then have xdc: "x /\<^sub>R c \<in> ball a r"
	by (auto simp: mem_ball dist_norm)
	show ?case
	apply (rule image_eqI[OF _ xdc])
	using 2 by simp
	qed


	subsection \<open>Continuity\<close>

	lemma continuous_within_topologicalE:
	assumes "continuous (at x within s) f"
	"open B" "f x \<in> B"
	obtains A where "open A" "x \<in> A" "\<And>y. y \<in> s \<Longrightarrow> y \<in> A \<Longrightarrow> f y \<in> B"
	using assms continuous_within_topological by metis

	lemma continuous_within_topologicalE':
	assumes "continuous (at x) f"
	"open B" "f x \<in> B"
	obtains A where "open A" "x \<in> A" "f ` A \<subseteq> B"
	using assms continuous_within_topologicalE[OF assms]
	by (metis UNIV_I image_subsetI)

	lemma continuous_on_inverse: "continuous_on S f \<Longrightarrow> 0 \<notin> f ` S \<Longrightarrow> continuous_on S (\<lambda>x. inverse (f x))"
	for f::"_\<Rightarrow>_::real_normed_div_algebra"
	by (auto simp: continuous_on_def intro!: tendsto_inverse)


	subsection \<open>@{term "(has_derivative)"}\<close>

	lemma has_derivative_plus_fun[derivative_intros]:
	"(x + y has_derivative x' + y') (at a within A)"
	if [derivative_intros]:
	"(x has_derivative x') (at a within A)"
	"(y has_derivative y') (at a within A)"
	by (auto simp: plus_fun_def intro!: derivative_eq_intros)

	lemma has_derivative_scaleR_fun[derivative_intros]:
	"(x \<^sub>R y has_derivative x \<^sub>R y') (at a within A)"
	if [derivative_intros]:
	"(y has_derivative y') (at a within A)"
	by (auto simp: scaleR_fun_def intro!: derivative_eq_intros)

	lemma has_derivative_times_fun[derivative_intros]:
	"(x * y has_derivative (\<lambda>h. x a * y' h + x' h * y a)) (at a within A)"
	if [derivative_intros]:
	"(x has_derivative x') (at a within A)"
	"(y has_derivative y') (at a within A)"
	for x y::"_\<Rightarrow>'a::real_normed_algebra"
	by (auto simp: times_fun_def intro!: derivative_eq_intros)

	lemma real_sqrt_has_derivative_generic:
	"x \<noteq> 0 \<Longrightarrow> (sqrt has_derivative () ((if x > 0 then 1 else -1) inverse (sqrt x) / 2)) (at x within S)"
	apply (rule has_derivative_at_withinI)
	using DERIV_real_sqrt_generic[of x "(if x > 0 then 1 else -1) * inverse (sqrt x) / 2"] at_within_open[of x "UNIV - {0}"]
	by (auto simp: has_field_derivative_def open_delete ac_simps split: if_splits)

	lemma sqrt_has_derivative:
	"((\<lambda>x. sqrt (f x)) has_derivative (\<lambda>xa. (if 0 < f x then 1 else - 1) / (2 * sqrt (f x)) * f' xa)) (at x within S)"
	if "(f has_derivative f') (at x within S)" "f x \<noteq> 0"
	by (rule has_derivative_eq_rhs[OF has_derivative_compose[OF that(1) real_sqrt_has_derivative_generic, OF that(2)]])
	(auto simp: divide_simps)

	lemmas has_derivative_norm_compose[derivative_intros] = has_derivative_compose[OF _ has_derivative_norm]

	subsection \<open>Differentiable\<close>

	lemmas differentiable_on_empty[simp]

	lemma differentiable_transform_eventually: "f differentiable (at x within X)"
	if "g differentiable (at x within X)"
	"f x = g x"
	"\<forall>\<^sub>F x in (at x within X). f x = g x"
	using that
	apply (auto simp: differentiable_def)
	subgoal for D
	apply (rule exI[where x=D])
	apply (auto simp: has_derivative_within)
	by (simp add: eventually_mono Lim_transform_eventually)
	done

	lemma differentiable_within_eqI: "f differentiable at x within X"
	if "g differentiable at x within X" "\<And>x. x \<in> X \<Longrightarrow> f x = g x"
	"x \<in> X" "open X"
	apply (rule differentiable_transform_eventually)
	apply (rule that)
	apply (auto simp: that)
	proof -
	have "\<forall>\<^sub>F x in at x within X. x \<in> X"
	using \<open>open X\<close>
	using eventually_at_topological by blast
	then show " \<forall>\<^sub>F x in at x within X. f x = g x"
	by eventually_elim (auto simp: that)
	qed

	lemma differentiable_eqI: "f differentiable at x"
	if "g differentiable at x" "\<And>x. x \<in> X \<Longrightarrow> f x = g x" "x \<in> X" "open X"
	using that
	unfolding at_within_open[OF that(3,4), symmetric]
	by (rule differentiable_within_eqI)

	lemma differentiable_on_eqI:
	"f differentiable_on S"
	if "g differentiable_on S" "\<And>x. x \<in> S \<Longrightarrow> f x = g x" "open S"
	using that differentiable_eqI[of g _ S f]
	by (auto simp: differentiable_on_eq_differentiable_at)

	lemma differentiable_on_comp: "(f o g) differentiable_on S"
	if "g differentiable_on S" "f differentiable_on (g ` S)"
	using that
	by (auto simp: differentiable_on_def intro: differentiable_chain_within)

	lemma differentiable_on_comp2: "(f o g) differentiable_on S"
	if "f differentiable_on T" "g differentiable_on S" "g ` S \<subseteq> T"
	apply (rule differentiable_on_comp)
	apply (rule that)
	apply (rule differentiable_on_subset)
	apply (rule that)
	apply (rule that)
	done

	lemmas differentiable_on_compose2 = differentiable_on_comp2[unfolded o_def]

	lemma differentiable_on_openD: "f differentiable at x"
	if "f differentiable_on X" "open X" "x \<in> X"
	using differentiable_on_eq_differentiable_at that by blast

	lemma differentiable_on_add_fun[intro, simp]:
	"x differentiable_on UNIV \<Longrightarrow> y differentiable_on UNIV \<Longrightarrow> x + y differentiable_on UNIV"
	by (auto simp: plus_fun_def)

	lemma differentiable_on_mult_fun[intro, simp]:
	"x differentiable_on UNIV \<Longrightarrow> y differentiable_on UNIV \<Longrightarrow> x * y differentiable_on UNIV"
	for x y::"_\<Rightarrow>'a::real_normed_algebra"
	by (auto simp: times_fun_def)

	lemma differentiable_on_scaleR_fun[intro, simp]:
	"y differentiable_on UNIV \<Longrightarrow> x *\<^sub>R y differentiable_on UNIV"
	by (auto simp: scaleR_fun_def)

	lemma sqrt_differentiable:
	"(\<lambda>x. sqrt (f x)) differentiable (at x within S)"
	if "f differentiable (at x within S)" "f x \<noteq> 0"
	using that
	using sqrt_has_derivative[of f _ x S]
	by (auto simp: differentiable_def)

	lemma sqrt_differentiable_on: "(\<lambda>x. sqrt (f x)) differentiable_on S"
	if "f differentiable_on S" "0 \<notin> f ` S"
	using sqrt_differentiable[of f _ S] that
	by (force simp: differentiable_on_def)

	lemma differentiable_on_inverse: "f differentiable_on S \<Longrightarrow> 0 \<notin> f ` S \<Longrightarrow> (\<lambda>x. inverse (f x)) differentiable_on S"
	for f::"_\<Rightarrow>_::real_normed_field"
	by (auto simp: differentiable_on_def intro!: differentiable_inverse)

	lemma differentiable_on_openI:
	"f differentiable_on S"
	if "open S" "\<And>x. x \<in> S \<Longrightarrow> \<exists>f'. (f has_derivative f') (at x)"
	using that
	by (auto simp: differentiable_on_def at_within_open[where S=S] differentiable_def)

	lemmas differentiable_norm_compose_at = differentiable_compose[OF differentiable_norm_at]

	lemma differentiable_on_Pair:
	"f differentiable_on S \<Longrightarrow> g differentiable_on S \<Longrightarrow> (\<lambda>x. (f x, g x)) differentiable_on S"
	unfolding differentiable_on_def
	using differentiable_Pair[of f _ S g] by auto

	lemma differentiable_at_fst:
	"(\<lambda>x. fst (f x)) differentiable at x within X" if "f differentiable at x within X"
	using that
	by (auto simp: differentiable_def dest!: has_derivative_fst)

	lemma differentiable_at_snd:
	"(\<lambda>x. snd (f x)) differentiable at x within X" if "f differentiable at x within X"
	using that
	by (auto simp: differentiable_def dest!: has_derivative_snd)

	lemmas frechet_derivative_worksI = frechet_derivative_works[THEN iffD1]

	lemma sin_differentiable_at: "(\<lambda>x. sin (f x::real)) differentiable at x within X"
	if "f differentiable at x within X"
	using differentiable_def has_derivative_sin that by blast

	lemma cos_differentiable_at: "(\<lambda>x. cos (f x::real)) differentiable at x within X"
	if "f differentiable at x within X"
	using differentiable_def has_derivative_cos that by blast


	subsection \<open>Frechet derivative\<close>

	lemmas frechet_derivative_transform_within_open_ext =
	fun_cong[OF frechet_derivative_transform_within_open]

	lemmas frechet_derivative_at' = frechet_derivative_at[symmetric]

	lemma frechet_derivative_plus_fun:
	"x differentiable at a \<Longrightarrow> y differentiable at a \<Longrightarrow>
	frechet_derivative (x + y) (at a) =
	frechet_derivative x (at a) + frechet_derivative y (at a)"
	by (rule frechet_derivative_at')
	(auto intro!: derivative_eq_intros frechet_derivative_worksI)

	lemmas frechet_derivative_plus = frechet_derivative_plus_fun[unfolded plus_fun_def]

	lemma frechet_derivative_zero_fun: "frechet_derivative 0 (at a) = 0"
	by (auto simp: frechet_derivative_const zero_fun_def)

	lemma frechet_derivative_sin:
	"frechet_derivative (\<lambda>x. sin (f x)) (at x) = (\<lambda>xa. frechet_derivative f (at x) xa * cos (f x))"
	if "f differentiable (at x)"
	for f::"_\<Rightarrow>real"
	by (rule frechet_derivative_at'[OF has_derivative_sin[OF frechet_derivative_worksI[OF that]]])

	lemma frechet_derivative_cos:
	"frechet_derivative (\<lambda>x. cos (f x)) (at x) = (\<lambda>xa. frechet_derivative f (at x) xa * - sin (f x))"
	if "f differentiable (at x)"
	for f::"_\<Rightarrow>real"
	by (rule frechet_derivative_at'[OF has_derivative_cos[OF frechet_derivative_worksI[OF that]]])

	lemma differentiable_sum_fun:
	"(\<And>i. i \<in> I \<Longrightarrow> (f i differentiable at a)) \<Longrightarrow> sum f I differentiable at a"
	by (induction I rule: infinite_finite_induct) (auto simp: zero_fun_def plus_fun_def)

	lemma frechet_derivative_sum_fun:
	"(\<And>i. i \<in> I \<Longrightarrow> (f i differentiable at a)) \<Longrightarrow>
	frechet_derivative (\<Sum>i\<in>I. f i) (at a) = (\<Sum>i\<in>I. frechet_derivative (f i) (at a))"
	by (induction I rule: infinite_finite_induct)
	(auto simp: frechet_derivative_zero_fun frechet_derivative_plus_fun differentiable_sum_fun)

	lemma sum_fun_def: "(\<Sum>i\<in>I. f i) = (\<lambda>x. \<Sum>i\<in>I. f i x)"
	by (induction I rule: infinite_finite_induct) auto

	lemmas frechet_derivative_sum = frechet_derivative_sum_fun[unfolded sum_fun_def]


	lemma frechet_derivative_times_fun:
	"f differentiable at a \<Longrightarrow> g differentiable at a \<Longrightarrow>
	frechet_derivative (f * g) (at a) =
	(\<lambda>x. f a * frechet_derivative g (at a) x + frechet_derivative f (at a) x * g a)"
	for f g::"_\<Rightarrow>'a::real_normed_algebra"
	by (rule frechet_derivative_at') (auto intro!: derivative_eq_intros frechet_derivative_worksI)

	lemmas frechet_derivative_times = frechet_derivative_times_fun[unfolded times_fun_def]

	lemma frechet_derivative_scaleR_fun:
	"y differentiable at a \<Longrightarrow>
	frechet_derivative (x *\<^sub>R y) (at a) =
	x *\<^sub>R frechet_derivative y (at a)"
	by (rule frechet_derivative_at')
	(auto intro!: derivative_eq_intros frechet_derivative_worksI)

	lemmas frechet_derivative_scaleR = frechet_derivative_scaleR_fun[unfolded scaleR_fun_def]

	lemma frechet_derivative_compose:
	"frechet_derivative (f o g) (at x) = frechet_derivative (f) (at (g x)) o frechet_derivative g (at x)"
	if "g differentiable at x" "f differentiable at (g x)"
	by (meson diff_chain_at frechet_derivative_at' frechet_derivative_works that)

	lemma frechet_derivative_compose_eucl:
	"frechet_derivative (f o g) (at x) =
	(\<lambda>v. \<Sum>i\<in>Basis. ((frechet_derivative g (at x) v) \<bullet> i) *\<^sub>R frechet_derivative f (at (g x)) i)"
	(is "?l = ?r")
	if "g differentiable at x" "f differentiable at (g x)"
	proof (rule ext)
	fix v
	interpret g: linear "frechet_derivative g (at x)"
	using that(1)
	by (rule linear_frechet_derivative)
	interpret f: linear "frechet_derivative f (at (g x))"
	using that(2)
	by (rule linear_frechet_derivative)
	have "frechet_derivative (f o g) (at x) v =
	frechet_derivative f (at (g x)) (\<Sum>i\<in>Basis. (frechet_derivative g (at x) v \<bullet> i) *\<^sub>R i)"
	unfolding frechet_derivative_compose[OF that] o_apply
	by (simp add: euclidean_representation)
	also have "\<dots> = ?r v"
	by (auto simp: g.sum g.scaleR f.sum f.scaleR)
	finally show "?l v = ?r v" .
	qed


	lemma frechet_derivative_works_on_open:
	"f differentiable_on X \<Longrightarrow> open X \<Longrightarrow> x \<in> X \<Longrightarrow>
	(f has_derivative frechet_derivative f (at x)) (at x)"
	and frechet_derivative_works_on:
	"f differentiable_on X \<Longrightarrow> x \<in> X \<Longrightarrow>
	(f has_derivative frechet_derivative f (at x within X)) (at x within X)"
	by (auto simp: differentiable_onD differentiable_on_openD frechet_derivative_worksI)

	lemma frechet_derivative_inverse: "frechet_derivative (\<lambda>x. inverse (f x)) (at x) =
	(\<lambda>h. - 1 / (f x)\<^sup>2 * frechet_derivative f (at x) h)"
	if "f differentiable at x" "f x \<noteq> 0" for f::"_\<Rightarrow>_::real_normed_field"
	apply (rule frechet_derivative_at')
	using that
	by (auto intro!: derivative_eq_intros frechet_derivative_worksI
	simp: divide_simps algebra_simps power2_eq_square)

	lemma frechet_derivative_sqrt: "frechet_derivative (\<lambda>x. sqrt (f x)) (at x) =
	(\<lambda>v. (if f x > 0 then 1 else -1) / (2 * sqrt (f x)) * frechet_derivative f (at x) v)"
	if "f differentiable at x" "f x \<noteq> 0"
	apply (rule frechet_derivative_at')
	apply (rule sqrt_has_derivative[THEN has_derivative_eq_rhs])
	by (auto intro!: frechet_derivative_worksI that simp: divide_simps)

	lemma frechet_derivative_norm: "frechet_derivative (\<lambda>x. norm (f x)) (at x) =
	(\<lambda>v. frechet_derivative f (at x) v \<bullet> sgn (f x))"
	if "f differentiable at x" "f x \<noteq> 0"
	for f::"_\<Rightarrow>_::real_inner"
	apply (rule frechet_derivative_at')
	by (auto intro!: derivative_eq_intros frechet_derivative_worksI that simp: divide_simps)

	lemma (in bounded_linear) frechet_derivative:
	"frechet_derivative f (at x) = f"
	apply (rule frechet_derivative_at')
	apply (rule has_derivative_eq_rhs)
	apply (rule has_derivative)
	by (auto intro!: derivative_eq_intros)

	bundle no_matrix_mult begin
	no_notation matrix_matrix_mult (infixl "**" 70)
	end

	lemma (in bounded_bilinear) frechet_derivative:
	includes no_matrix_mult
	shows
	"x differentiable at a \<Longrightarrow> y differentiable at a \<Longrightarrow>
	frechet_derivative (\<lambda>a. x a ** y a) (at a) =
	(\<lambda>h. x a frechet_derivative y (at a) h + frechet_derivative x (at a) h y a)"
	by (rule frechet_derivative_at') (auto intro!: FDERIV frechet_derivative_worksI)

	lemma frechet_derivative_divide: "frechet_derivative (\<lambda>x. f x / g x) (at x) =
	(\<lambda>h. frechet_derivative f (at x) h / (g x) -frechet_derivative g (at x) h * f x / (g x)\<^sup>2)"
	if "f differentiable at x" "g differentiable at x" "g x \<noteq> 0" for f::"_\<Rightarrow>_::real_normed_field"
	using that
	by (auto simp: divide_inverse_commute bounded_bilinear.frechet_derivative[OF bounded_bilinear_mult]
	frechet_derivative_inverse)

	lemma frechet_derivative_pair:
	"frechet_derivative (\<lambda>x. (f x, g x)) (at x) = (\<lambda>v. (frechet_derivative f (at x) v, frechet_derivative g (at x) v))"
	if "f differentiable (at x)" "g differentiable (at x)"
	apply (rule frechet_derivative_at')
	apply (rule derivative_eq_intros)
	apply (rule frechet_derivative_worksI) apply fact
	apply (rule frechet_derivative_worksI) apply fact
	..

	lemma frechet_derivative_fst:
	"frechet_derivative (\<lambda>x. fst (f x)) (at x) = (\<lambda>xa. fst (frechet_derivative f (at x) xa))"
	if "(f differentiable at x)"
	for f::"_\<Rightarrow>(_::real_normed_vector \<times> _::real_normed_vector)"
	apply (rule frechet_derivative_at')
	using that
	by (auto intro!: derivative_eq_intros frechet_derivative_worksI)

	lemma frechet_derivative_snd:
	"frechet_derivative (\<lambda>x. snd (f x)) (at x) = (\<lambda>xa. snd (frechet_derivative f (at x) xa))"
	if "(f differentiable at x)"
	for f::"_\<Rightarrow>(_::real_normed_vector \<times> _::real_normed_vector)"
	apply (rule frechet_derivative_at')
	using that
	by (auto intro!: derivative_eq_intros frechet_derivative_worksI)

	lemma frechet_derivative_eq_vector_derivative_1:
	assumes "f differentiable at t"
	shows "frechet_derivative f (at t) 1 = vector_derivative f (at t)"
	apply (subst frechet_derivative_eq_vector_derivative)
	apply (rule assms) by auto


	subsection \<open>Linear algebra\<close>

	lemma (in vector_space) dim_pos_finite_dimensional_vector_spaceE:
	assumes "dim (UNIV::'b set) > 0"
	obtains basis where "finite_dimensional_vector_space scale basis"
	proof -
	from assms obtain b where b: "local.span b = local.span UNIV" "local.independent b"
	by (auto simp: dim_def split: if_splits)
	then have "dim UNIV = card b"
	by (rule dim_eq_card)
	with assms have "finite b" by (auto simp: card_ge_0_finite)
	then have "finite_dimensional_vector_space scale b"
	by unfold_locales (auto simp: b)
	then show ?thesis ..
	qed

	context vector_space_on begin

	context includes lifting_syntax assumes "\<exists>(Rep::'s \<Rightarrow> 'b) (Abs::'b \<Rightarrow> 's). type_definition Rep Abs S" begin

	interpretation local_typedef_vector_space_on S scale "TYPE('s)" by unfold_locales fact

	lemmas_with [var_simplified explicit_ab_group_add,
	unoverload_type 'd,
	OF type.ab_group_add_axioms type_vector_space_on_with,
	folded dim_S_def,
	untransferred,
	var_simplified implicit_ab_group_add]:
	lt_dim_pos_finite_dimensional_vector_spaceE = vector_space.dim_pos_finite_dimensional_vector_spaceE

	end

	lemmas_with [cancel_type_definition,
	OF S_ne,
	folded subset_iff',
	simplified pred_fun_def, folded finite_dimensional_vector_space_on_with,
	simplified\<comment>\<open>too much?\<close>]:
	dim_pos_finite_dimensional_vector_spaceE = lt_dim_pos_finite_dimensional_vector_spaceE

	end


	subsection \<open>Extensional function space\<close>

	text \<open>f is zero outside A. We use such functions to canonically represent
	functions whose domain is A\<close>
	definition extensional0 :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::zero) \<Rightarrow> bool"
	where "extensional0 A f = (\<forall>x. x \<notin> A \<longrightarrow> f x = 0)"

	lemma extensional0_0[intro, simp]: "extensional0 X 0"
	by (auto simp: extensional0_def)

	lemma extensional0_UNIV[intro, simp]: "extensional0 UNIV f"
	by (auto simp: extensional0_def)

	lemma ext_extensional0:
	"f = g" if "extensional0 S f" "extensional0 S g" "\<And>x. x \<in> S \<Longrightarrow> f x = g x"
	using that by (force simp: extensional0_def fun_eq_iff)

	lemma extensional0_add[intro, simp]:
	"extensional0 S f \<Longrightarrow> extensional0 S g \<Longrightarrow> extensional0 S (f + g::_\<Rightarrow>'a::comm_monoid_add)"
	by (auto simp: extensional0_def)

	lemma extensinoal0_mult[intro, simp]:
	"extensional0 S x \<Longrightarrow> extensional0 S y \<Longrightarrow> extensional0 S (x * y)"
	for x y::"_\<Rightarrow>'a::mult_zero"
	by (auto simp: extensional0_def)

	lemma extensional0_scaleR[intro, simp]: "extensional0 S f \<Longrightarrow> extensional0 S (c *\<^sub>R f::_\<Rightarrow>'a::real_vector)"
	by (auto simp: extensional0_def)

	lemma extensional0_outside: "x \<notin> S \<Longrightarrow> extensional0 S f \<Longrightarrow> f x = 0"
	by (auto simp: extensional0_def)

	lemma subspace_extensional0: "subspace (Collect (extensional0 X))"
	by (auto simp: subspace_def)

	text \<open>Send the function f to its canonical representative as a function with domain A\<close>
	definition restrict0 :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a \<Rightarrow> 'b"
	where "restrict0 A f x = (if x \<in> A then f x else 0)"

	lemma restrict0_UNIV[simp]: "restrict0 UNIV = (\<lambda>x. x)"
	by (intro ext) (auto simp: restrict0_def)

	lemma extensional0_restrict0[intro, simp]: "extensional0 A (restrict0 A f)"
	by (auto simp: extensional0_def restrict0_def)

	lemma restrict0_times: "restrict0 A (x * y) = restrict0 A x * restrict0 A y"
	for x::"'a\<Rightarrow>'b::mult_zero"
	by (auto simp: restrict0_def[abs_def])

	lemma restrict0_apply_in[simp]: "x \<in> A \<Longrightarrow> restrict0 A f x = f x"
	by (auto simp: restrict0_def)

	lemma restrict0_apply_out[simp]: "x \<notin> A \<Longrightarrow> restrict0 A f x = 0"
	by (auto simp: restrict0_def)

	lemma restrict0_scaleR: "restrict0 A (c \<^sub>R f::_\<Rightarrow>'a::real_vector) = c \<^sub>R restrict0 A f"
	by (auto simp: restrict0_def[abs_def])

	lemma restrict0_add: "restrict0 A (f + g::_\<Rightarrow>'a::real_vector) = restrict0 A f + restrict0 A g"
	by (auto simp: restrict0_def[abs_def])

	lemma restrict0_restrict0: "restrict0 X (restrict0 Y f) = restrict0 (X \<inter> Y) f"
	by (auto simp: restrict0_def)

	end
	diff --git a/thys/Smooth_Manifolds/Bump_Function.thy b/thys/Smooth_Manifolds/Bump_Function.thy
	--- a/thys/Smooth_Manifolds/Bump_Function.thy
	+++ b/thys/Smooth_Manifolds/Bump_Function.thy
	@@ -1,521 +1,521 @@
	section \<open>Bump Functions\<close>
	theory Bump_Function
	imports Smooth
	"HOL-Analysis.Weierstrass_Theorems"
	begin

	subsection \<open>Construction\<close>

	context begin

	qualified definition f :: "real \<Rightarrow> real" where
	"f t = (if t > 0 then exp(-inverse t) else 0)"

	lemma f_nonpos[simp]: "x \<le> 0 \<Longrightarrow> f x = 0"
	by (auto simp: f_def)

	lemma exp_inv_limit_0_right:
	"((\<lambda>(t::real). exp(-inverse t)) \<longlongrightarrow> 0) (at_right 0)"
	apply (rule filterlim_compose[where g = exp])
	apply (rule exp_at_bot)
	apply (rule filterlim_compose[where g = uminus])
	apply (rule filterlim_uminus_at_bot_at_top)
	by (rule filterlim_inverse_at_top_right)

	lemma "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. inverse (x ^ Suc k)) has_real_derivative
	- (inverse (t ^ Suc k) * ((1 + real k) * t ^ k) * inverse (t ^ Suc k))) (at t)"
	unfolding eventually_at_filter
	by (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI)

	lemma exp_inv_limit_0_right_gen':
	"((\<lambda>(t::real). inverse (t ^ k) / exp(inverse t)) \<longlongrightarrow> 0) (at_right 0)"
	proof (induct k)
	case 0
	then show ?case
	using exp_inv_limit_0_right
	by (auto simp: exp_minus inverse_eq_divide)
	next
	case (Suc k)
	have df: "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. inverse (x ^ Suc k)) has_real_derivative
	- (inverse (t ^ k) * ((1 + real k)) * (inverse t ^ 2))) (at t)"
	unfolding eventually_at_filter
	apply (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI)
	by (auto simp: power2_eq_square)
	have dg: "\<forall>\<^sub>F t in at_right 0. ((\<lambda>x. exp (inverse x)) has_real_derivative
	- (exp (inverse t) * (inverse t ^ 2))) (at t)"
	unfolding eventually_at_filter
	by (auto simp del: power_Suc intro!: derivative_eq_intros eventuallyI simp: power2_eq_square)
	show ?case
	apply (rule lhopital_right_0_at_top [OF _ _ df dg])
	apply (rule filterlim_compose[where g = exp])
	apply (rule exp_at_top)
	apply (rule filterlim_inverse_at_top_right)
	subgoal by (auto simp: eventually_at_filter)
	subgoal
	apply (rule Lim_transform_eventually[where f = "\<lambda>x. (1 + real k) * (inverse (x ^ k) / exp (inverse x))"])
	using Suc.hyps tendsto_mult_right_zero apply blast
	by (auto simp: eventually_at_filter)
	done
	qed

	lemma exp_inv_limit_0_right_gen:
	"((\<lambda>(t::real). exp(-inverse t) / t ^ k) \<longlongrightarrow> 0) (at_right 0)"
	using exp_inv_limit_0_right_gen'[of k]
	by (metis (no_types, lifting) Groups.mult_ac(2) Lim_cong_within divide_inverse exp_minus)

	lemma f_limit_0_right: "(f \<longlongrightarrow> 0) (at_right 0)"
	proof -
	have "\<forall>\<^sub>F t in at_right 0. (t::real) > 0"
	by (rule eventually_at_right_less)
	then have "\<forall>\<^sub>F t in at_right 0. exp(-inverse t) = f t"
	by (eventually_elim) (auto simp: f_def)
	moreover have "((\<lambda>(t::real). exp(-inverse t)) \<longlongrightarrow> 0) (at_right 0)"
	by (rule exp_inv_limit_0_right)
	ultimately show ?thesis
	by (blast intro: Lim_transform_eventually)
	qed

	lemma f_limit_0: "(f \<longlongrightarrow> 0) (at 0)"
	using _ f_limit_0_right
	proof (rule filterlim_split_at_real)
	have "\<forall>\<^sub>F t in at_left 0. 0 = f t"
	by (auto simp: f_def eventually_at_filter)
	then show "(f \<longlongrightarrow> 0) (at_left 0)"
	by (blast intro: Lim_transform_eventually)
	qed

	lemma f_tendsto: "(f \<longlongrightarrow> f x) (at x)"
	proof -
	consider "x = 0" \| "x < 0" \| "x > 0" by arith
	then show ?thesis
	proof cases
	case 1
	then show ?thesis by (auto simp: f_limit_0 f_def)
	next
	case 2
	have "\<forall>\<^sub>F t in at x. t < 0"
	apply (rule order_tendstoD)
	by (rule tendsto_intros) fact
	then have "\<forall>\<^sub>F t in at x. 0 = f t"
	by (eventually_elim) (auto simp: f_def)
	then show ?thesis
	using \<open>x < 0\<close> by (auto simp: f_def intro: Lim_transform_eventually)
	next
	case 3
	have "\<forall>\<^sub>F t in at x. t > 0"
	apply (rule order_tendstoD)
	by (rule tendsto_intros) fact
	then have "\<forall>\<^sub>F t in at x. exp(-inverse t) = f t"
	by (eventually_elim) (auto simp: f_def)
	moreover have "(\<lambda>t. exp (- inverse t)) \<midarrow>x\<rightarrow> f x"
	using \<open>x > 0\<close> by (auto simp: f_def tendsto_intros )
	ultimately show ?thesis
	by (blast intro: Lim_transform_eventually)
	qed
	qed

	lemma f_continuous: "continuous_on S f"
	using f_tendsto continuous_on continuous_on_subset subset_UNIV by metis

	lemma continuous_on_real_polynomial_function:
	"continuous_on S p" if "real_polynomial_function p"
	using that
	by induction (auto intro: continuous_intros linear_continuous_on)

	lemma f_nth_derivative_is_poly:
	"higher_differentiable_on {0<..} f k \<and>
	(\<exists>p. real_polynomial_function p \<and> (\<forall>t>0. nth_derivative k f t 1 = p t / (t ^ (2 * k)) * exp(-inverse t)))"
	proof (induction k)
	case 0
	then show ?case
	apply (auto simp: higher_differentiable_on.simps f_continuous)
	by (auto simp: f_def)
	next
	case (Suc k)
	obtain p where fk: "higher_differentiable_on {0<..} f k"
	and p1: "real_polynomial_function p"
	and p2: "\<forall>t>0. nth_derivative k f t 1 = p t / t ^ (2 * k) * exp (- inverse t)"
	using Suc by auto
	obtain p' where p'1: "real_polynomial_function p'"
	and p'2: "\<forall>t. (p has_real_derivative (p' t)) (at t)"
	using has_real_derivative_polynomial_function[of p] p1 by auto

	define rp where "rp t = (t\<^sup>2 * p' t - 2 * real k * t * p t + p t)" for t
	have rp: "real_polynomial_function rp"
	unfolding rp_def
	by (auto intro!: real_polynomial_function.intros(2-) real_polynomial_function_diff
	p1 p'1 simp: power2_eq_square)
	moreover
	have fk': "(\<lambda>x. nth_derivative k f x 1) differentiable at t" (is ?a)
	"frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1 =
	rp t * (exp (-inverse t) / t^(2*k+2))" (is ?b)
	if "0 < t" for t
	proof -
	from p'2 that have dp: "(p has_derivative ((*) (p' t))) (at t within {0<..})"
	by (auto simp: at_within_open[of _ "{0<..}"] has_field_derivative_def ac_simps)
	have "((\<lambda>t. p t / t ^ (2 * k) * exp (- inverse t)) has_derivative
	(\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t within {0<..})"
	using that
	apply (auto intro!: derivative_eq_intros dp ext)
	apply (simp add: divide_simps algebra_simps rp_def power2_eq_square)
	by (metis Suc_pred mult_is_0 neq0_conv power_Suc zero_neq_numeral)
	then have "((\<lambda>x. nth_derivative k f x 1) has_derivative
	(\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t within {0<..})"
	apply (rule has_derivative_transform_within[OF _ zero_less_one])
	- using that p2 by (auto simp: )
	+ using that p2 by auto
	then have "((\<lambda>x. nth_derivative k f x 1) has_derivative
	(\<lambda>v. v * rp t * (exp (-inverse t) / t^(2*k+2)))) (at t)"
	using that
	by (auto simp: at_within_open[of _ "{0<..}"])
	from frechet_derivative_at'[OF this] this
	show ?a ?b
	by (auto simp: differentiable_def)
	qed
	have hdS: "higher_differentiable_on {0<..} f (Suc k)"
	apply (subst higher_differentiable_on_real_Suc')
	apply (auto simp: fk fk' frechet_derivative_nth_derivative_commute[symmetric])
	apply (subst continuous_on_cong[OF refl])
	apply (rule fk')
	by (auto intro!: continuous_intros p'1 p1 rp
	intro: continuous_on_real_polynomial_function)
	moreover
	have "nth_derivative (Suc k) f t 1 = rp t / t ^ (2 * (Suc k)) * exp (- inverse t)"
	if "t > 0" for t
	proof -
	have "nth_derivative (Suc k) f t 1 = frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1"
	by (simp add: frechet_derivative_nth_derivative_commute)

	also have "\<dots> = rp t / t^(2k+2) (exp (-inverse t))"
	using fk'[OF \<open>t > 0\<close>] by simp
	finally show ?thesis by simp
	qed
	ultimately show ?case by blast
	qed

	lemma f_has_derivative_at_neg:
	" x < 0 \<Longrightarrow> (f has_derivative (\<lambda>x. 0)) (at x)"
	by (rule has_derivative_transform_within_open[where f="\<lambda>x. 0" and s="{..<0}"])
	(auto simp: f_def)

	lemma f_differentiable_at_neg:
	"x < 0 \<Longrightarrow> f differentiable at x"
	using f_has_derivative_at_neg
	by (auto simp: differentiable_def)

	lemma frechet_derivative_f_at_neg:
	"x \<in> {..<0} \<Longrightarrow> frechet_derivative f (at x) = (\<lambda>x. 0)"
	by (rule frechet_derivative_at') (rule f_has_derivative_at_neg, simp)

	lemma f_nth_derivative_lt_0:
	"higher_differentiable_on {..<0} f k \<and> (\<forall>t<0. nth_derivative k f t 1 = 0)"
	proof (induction k)
	case 0
	have rewr: "a \<in> {..<0} \<Longrightarrow> \<not>0 < a" for a::real by simp
	show ?case
	by (auto simp: higher_differentiable_on.simps f_def rewr
	simp del: lessThan_iff
	cong: continuous_on_cong)
	next
	case (Suc k)
	have "t < 0 \<Longrightarrow> (\<lambda>x. nth_derivative k f x 1) differentiable at t" for t
	by (rule differentiable_eqI[where g=0 and X="{..<0}"])
	(auto simp: zero_fun_def frechet_derivative_const Suc.IH)
	then have "frechet_derivative (\<lambda>x. nth_derivative k f x 1) (at t) 1 = 0" if "t < 0" for t
	using that Suc.IH
	by (subst frechet_derivative_transform_within_open[where X="{..<0}" and g =0])
	(auto simp: frechet_derivative_zero_fun)
	with Suc show ?case
	by (auto simp: higher_differentiable_on.simps f_differentiable_at_neg
	frechet_derivative_f_at_neg zero_fun_def
	simp flip: frechet_derivative_nth_derivative_commute
	simp del: lessThan_iff
	intro!: higher_differentiable_on_const
	cong: higher_differentiable_on_cong)
	qed

	lemma netlimit_at_left: "netlimit (at_left x) = x" for x::real
	by (rule Lim_ident_at) simp

	lemma netlimit_at_right: "netlimit (at_right x) = x" for x::real
	by (rule Lim_ident_at) simp


	lemma has_derivative_split_at:
	"(g has_derivative g') (at x)"
	if
	"(g has_derivative g') (at_left x)"
	"(g has_derivative g') (at_right x)"
	for x::real
	using that
	unfolding has_derivative_def netlimit_at netlimit_at_right netlimit_at_left
	by (auto intro: filterlim_split_at)

	lemma has_derivative_at_left_at_right':
	"(g has_derivative g') (at x)"
	if
	"(g has_derivative g') (at x within {..x})"
	"(g has_derivative g') (at x within {x..})"
	for x::real
	apply (rule has_derivative_split_at)
	subgoal by (rule has_derivative_subset) (fact, auto)
	subgoal by (rule has_derivative_subset) (fact, auto)
	done

	lemma real_polynomial_function_tendsto:
	"(p \<longlongrightarrow> p x) (at x within X)" if "real_polynomial_function p"
	using that
	by (induction p) (auto intro!: tendsto_eq_intros intro: bounded_linear.tendsto)

	lemma f_nth_derivative_cases:
	"higher_differentiable_on UNIV f k \<and>
	(\<forall>t\<le>0. nth_derivative k f t 1 = 0) \<and>
	(\<exists>p. real_polynomial_function p \<and>
	(\<forall>t>0. nth_derivative k f t 1 = p t / (t ^ (2 * k)) * exp(-inverse t)))"
	proof (induction k)
	case 0
	then show ?case
	apply (auto simp: higher_differentiable_on.simps f_continuous)
	by (auto simp: f_def)
	next
	case (Suc k)
	from Suc.IH obtain pk where IH:
	"higher_differentiable_on UNIV f k"
	"\<And>t. t \<le> 0 \<Longrightarrow> nth_derivative k f t 1 = 0"
	"real_polynomial_function pk"
	"\<And>t. t > 0 \<Longrightarrow> nth_derivative k f t 1 = pk t / t ^ (2 * k) * exp (- inverse t)"
	by auto
	from f_nth_derivative_lt_0[of "Suc k"]
	local.f_nth_derivative_is_poly[of "Suc k"]
	obtain p where neg: "higher_differentiable_on {..<0} f (Suc k)"
	and neg0: "(\<forall>t<0. nth_derivative (Suc k) f t 1 = 0)"
	and pos: "higher_differentiable_on {0<..} f (Suc k)"
	and p: "real_polynomial_function p"
	"\<And>t. t > 0 \<Longrightarrow> nth_derivative (Suc k) f t 1 = p t / t ^ (2 * Suc k) * exp (- inverse t)"
	by auto
	moreover
	have at_within_eq_at_right: "(at 0 within {0..}) = at_right (0::real)"
	apply (auto simp: filter_eq_iff eventually_at_filter )
	apply (simp add: eventually_mono)
	apply (simp add: eventually_mono)
	done
	have [simp]: "{0..} - {0} = {0::real<..}" by auto
	have [simp]: "(at (0::real) within {0..}) \<noteq> bot"
	by (auto simp: at_within_eq_bot_iff)
	have k_th_has_derivative_at_left:
	"((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0 within {..0})"
	apply (rule has_derivative_transform_within[OF _ zero_less_one])
	prefer 2
	apply force
	prefer 2
	apply (simp add: IH)
	by (rule derivative_intros)
	have k_th_has_derivative_at_right:
	"((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0 within {0..})"
	apply (rule has_derivative_transform_within[where
	f="\<lambda>x'. if x' = 0 then 0 else pk x' / x' ^ (2 * k) * exp (- inverse x')", OF _ zero_less_one])
	subgoal
	unfolding has_derivative_def
	apply (auto simp: Lim_ident_at)
	apply (rule Lim_transform_eventually[where f="\<lambda>x. (pk x * (exp (- inverse x) / x ^ (2 * k + 1)))"])
	apply (rule tendsto_eq_intros)
	apply (rule real_polynomial_function_tendsto[THEN tendsto_eq_rhs])
	apply fact
	apply (rule refl)
	apply (subst at_within_eq_at_right)
	apply (rule exp_inv_limit_0_right_gen)
	apply (auto simp add: eventually_at_filter divide_simps)
	done
	subgoal by force
	subgoal by (auto simp: IH(2) IH(4))
	done
	have k_th_has_derivative: "((\<lambda>x. nth_derivative k f x 1) has_derivative (\<lambda>x. 0)) (at 0)"
	apply (rule has_derivative_at_left_at_right')
	apply (rule k_th_has_derivative_at_left)
	apply (rule k_th_has_derivative_at_right)
	done
	have nth_Suc_zero: "nth_derivative (Suc k) f 0 1 = 0"
	apply (auto simp: frechet_derivative_nth_derivative_commute[symmetric])
	apply (subst frechet_derivative_at')
	apply (rule k_th_has_derivative)
	by simp
	moreover have "higher_differentiable_on UNIV f (Suc k)"
	proof -
	have "continuous_on UNIV (\<lambda>x. nth_derivative (Suc k) f x 1)"
	unfolding continuous_on_eq_continuous_within
	proof
	fix x::real
	consider "x < 0" \| "x > 0" \| "x = 0" by arith
	then show "isCont (\<lambda>x. nth_derivative (Suc k) f x 1) x"
	proof cases
	case 1
	then have at_eq: "at x = at x within {..<0}"
	using at_within_open[of x "{..<0}"] by auto
	show ?thesis
	unfolding at_eq
	apply (rule continuous_transform_within[OF _ zero_less_one])
	using neg0 1 by (auto simp: at_eq)
	next
	case 2
	then have at_eq: "at x = at x within {0<..}"
	using at_within_open[of x "{0<..}"] by auto
	show ?thesis
	unfolding at_eq
	apply (rule continuous_transform_within[OF _ zero_less_one])
	using p 2 by (auto intro!: continuous_intros
	intro: continuous_real_polymonial_function continuous_at_imp_continuous_within)
	next
	case 3
	have "((\<lambda>x. nth_derivative (Suc k) f x 1) \<longlongrightarrow> 0) (at_left 0)"
	proof -
	have "\<forall>\<^sub>F x in at_left 0. 0 = nth_derivative (Suc k) f x 1"
	using neg0
	by (auto simp: eventually_at_filter)
	then show ?thesis
	by (blast intro: Lim_transform_eventually)
	qed
	moreover have "((\<lambda>x. nth_derivative (Suc k) f x 1) \<longlongrightarrow> 0) (at_right 0)"
	proof -
	have "((\<lambda>x. p x * (exp (- inverse x) / x ^ (2 * Suc k))) \<longlongrightarrow> 0) (at_right 0)"
	apply (rule tendsto_eq_intros)
	apply (rule real_polynomial_function_tendsto)
	apply fact
	apply (rule exp_inv_limit_0_right_gen)
	by simp
	moreover
	have "\<forall>\<^sub>F x in at_right 0. p x * (exp (- inverse x) / x ^ (2 * Suc k)) =
	nth_derivative (Suc k) f x 1"
	using p
	by (auto simp: eventually_at_filter)
	ultimately show ?thesis
	by (rule Lim_transform_eventually)
	qed
	ultimately show ?thesis
	by (auto simp: continuous_def nth_Suc_zero 3 filterlim_split_at
	simp del: nth_derivative.simps)
	qed
	qed
	moreover have "(\<lambda>x. nth_derivative k f x 1) differentiable at x" for x
	proof -
	consider "x = 0" \| "x < 0" \| "x > 0"by arith
	then show ?thesis
	proof cases
	case 1
	then show ?thesis
	using k_th_has_derivative by (auto simp: differentiable_def)
	next
	case 2
	with neg show ?thesis
	- by (subst (asm) higher_differentiable_on_real_Suc') (auto simp: )
	+ by (subst (asm) higher_differentiable_on_real_Suc') auto
	next
	case 3
	with pos show ?thesis
	- by (subst (asm) higher_differentiable_on_real_Suc') (auto simp: )
	+ by (subst (asm) higher_differentiable_on_real_Suc') auto
	qed
	qed
	moreover have "higher_differentiable_on UNIV f k" by fact
	ultimately
	show ?thesis
	by (subst higher_differentiable_on_real_Suc'[OF open_UNIV]) auto
	qed
	ultimately
	show ?case
	by (auto simp: less_eq_real_def)
	qed

	lemma f_smooth_on: "k-smooth_on S f"
	and f_higher_differentiable_on: "higher_differentiable_on S f n"
	using f_nth_derivative_cases
	by (auto simp: smooth_on_def higher_differentiable_on_subset[OF _ subset_UNIV])

	lemma f_compose_smooth_on: "k-smooth_on S (\<lambda>x. f (g x))"
	if "k-smooth_on S g" "open S"
	using smooth_on_compose[OF f_smooth_on that open_UNIV subset_UNIV]
	by (auto simp: o_def)

	lemma f_nonneg: "f x \<ge> 0"
	by (auto simp: f_def)

	lemma f_pos_iff: "f x > 0 \<longleftrightarrow> x > 0"
	by (auto simp: f_def)

	lemma f_eq_zero_iff: "f x = 0 \<longleftrightarrow> x \<le> 0"
	by (auto simp: f_def)


	subsection \<open>Cutoff function\<close>

	definition "h t = f (2 - t) / (f (2 - t) + f (t - 1))"

	lemma denominator_pos: "f (2 - t) + f (t - 1) > 0"
	by (auto simp: f_def add_pos_pos)

	lemma denominator_nonzero: "f (2 - t) + f (t - 1) = 0 \<longleftrightarrow> False"
	using denominator_pos[of t] by auto

	lemma h_range: "0 \<le> h t" "h t \<le> 1"
	by (auto simp: h_def f_nonneg denominator_pos)

	lemma h_pos: "t < 2 \<Longrightarrow> 0 < h t"
	and h_less_one: "1 < t \<Longrightarrow> h t < 1"
	by (auto simp: h_def f_pos_iff denominator_pos)

	lemma h_eq_0: "h t = 0" if "t \<ge> 2"
	using that
	by (auto simp: h_def)

	lemma h_eq_1: "h t = 1" if "t \<le> 1"
	using that
	by (auto simp: h_def f_eq_zero_iff)

	lemma h_compose_smooth_on: "k-smooth_on S (\<lambda>x. h (g x))"
	if "k-smooth_on S g" "open S"
	by (auto simp: h_def[abs_def] denominator_nonzero
	intro!: smooth_on_divide f_compose_smooth_on smooth_on_minus smooth_on_add
	that)


	subsection \<open>Bump function\<close>

	definition H::"_::real_inner \<Rightarrow> real" where "H x = h (norm x)"

	lemma H_range: "0 \<le> H x" "H x \<le> 1"
	by (auto simp: H_def h_range)

	lemma H_eq_one: "H x = 1" if "x \<in> cball 0 1"
	using that
	by (auto simp: H_def h_eq_1)

	lemma H_pos: "H x > 0" if "x \<in> ball 0 2"
	using that
	by (auto simp: H_def h_pos)

	lemma H_eq_zero: "H x = 0" if "x \<notin> ball 0 2"
	using that
	by (auto simp: H_def h_eq_0)

	lemma H_neq_zeroD: "H x \<noteq> 0 \<Longrightarrow> x \<in> ball 0 2"
	using H_eq_zero by blast

	lemma H_smooth_on: "k-smooth_on UNIV H"
	proof -
	have 1: "k-smooth_on (ball 0 1) H"
	by (rule smooth_on_cong[where g="\<lambda>x. 1"]) (auto simp: H_eq_one)
	have 2: "k-smooth_on (UNIV - cball 0 (1/2)) H"
	by (auto simp: H_def[abs_def]
	intro!: h_compose_smooth_on smooth_on_norm)
	have O: "open (ball 0 1)" "open (UNIV - cball 0 (1 / 2))"
	by auto
	have *: "ball 0 1 \<union> (UNIV - cball 0 (1 / 2)) = UNIV" by (auto simp: mem_ball)
	from smooth_on_open_Un[OF 1 2 O, unfolded *]
	show ?thesis
	by (rule smooth_on_subset) auto
	qed

	lemma H_compose_smooth_on: "k-smooth_on S (\<lambda>x. H (g x))" if "k-smooth_on S g" "open S"
	for g :: "_ \<Rightarrow> _::euclidean_space"
	using smooth_on_compose[OF H_smooth_on that]
	by (auto simp: o_def)

	end

	end
	\ No newline at end of file
	diff --git a/thys/Smooth_Manifolds/Chart.thy b/thys/Smooth_Manifolds/Chart.thy
	--- a/thys/Smooth_Manifolds/Chart.thy
	+++ b/thys/Smooth_Manifolds/Chart.thy
	@@ -1,204 +1,204 @@
	section \<open>Charts\<close>
	theory Chart
	imports Analysis_More
	begin

	subsection \<open>Definition\<close>

	text \<open>A chart on \<open>M\<close> is a homeomorphism from an open subset of \<open>M\<close> to an open subset
	of some Euclidean space \<open>E\<close>. Here \<open>d\<close> and \<open>d'\<close> are open subsets of \<open>M\<close> and \<open>E\<close>, respectively,
	\<open>f: d \<rightarrow> d'\<close> is the mapping, and \<open>f': d' \<rightarrow> d\<close> is the inverse mapping.\<close>
	typedef (overloaded) ('a::topological_space, 'e::euclidean_space) chart =
	"{(d::'a set, d'::'e set, f, f').
	open d \<and> open d' \<and> homeomorphism d d' f f'}"
	by (rule exI[where x="({}, {}, (\<lambda>x. undefined), (\<lambda>x. undefined))"]) simp

	setup_lifting type_definition_chart

	lift_definition apply_chart::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'a \<Rightarrow> 'e"
	is "\<lambda>(d, d', f, f'). f" .

	declare [[coercion apply_chart]]

	lift_definition inv_chart::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'e \<Rightarrow> 'a"
	is "\<lambda>(d, d', f, f'). f'" .

	lift_definition domain::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'a set"
	is "\<lambda>(d, d', f, f'). d" .

	lift_definition codomain::"('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> 'e set"
	is "\<lambda>(d, d', f, f'). d'" .


	subsection \<open>Properties\<close>

	lemma open_domain[intro, simp]: "open (domain c)"
	and open_codomain[intro, simp]: "open (codomain c)"
	and chart_homeomorphism: "homeomorphism (domain c) (codomain c) c (inv_chart c)"
	by (transfer, auto)+

	lemma at_within_domain: "at x within domain c = at x" if "x \<in> domain c"
	by (rule at_within_open[OF that open_domain])

	lemma at_within_codomain: "at x within codomain c = at x" if "x \<in> codomain c"
	by (rule at_within_open[OF that open_codomain])

	lemma
	chart_in_codomain[intro, simp]: "x \<in> domain c \<Longrightarrow> c x \<in> codomain c"
	and inv_chart_inverse[simp]: "x \<in> domain c \<Longrightarrow> inv_chart c (c x) = x"
	and inv_chart_in_domain[intro, simp]:"y \<in> codomain c \<Longrightarrow> inv_chart c y \<in> domain c"
	and chart_inverse_inv_chart[simp]: "y \<in> codomain c \<Longrightarrow> c (inv_chart c y) = y"
	and image_domain_eq: "c ` (domain c) = codomain c"
	and inv_image_codomain_eq[simp]: "inv_chart c ` (codomain c) = domain c"
	and continuous_on_domain: "continuous_on (domain c) c"
	and continuous_on_codomain: "continuous_on (codomain c) (inv_chart c)"
	using chart_homeomorphism[of c]
	by (auto simp: homeomorphism_def)

	lemma chart_eqI: "c = d"
	if "domain c = domain d"
	"codomain c = codomain d"
	"\<And>x. c x = d x"
	"\<And>x. inv_chart c x = inv_chart d x"
	using that
	by transfer auto

	lemmas continuous_on_chart[continuous_intros] =
	continuous_on_compose2[OF continuous_on_domain]
	continuous_on_compose2[OF continuous_on_codomain]

	lemma continuous_apply_chart: "continuous (at x within X) c" if "x \<in> domain c"
	apply (rule continuous_at_imp_continuous_within)
	using continuous_on_domain[of c] that at_within_domain[OF that]
	by (auto simp: continuous_on_eq_continuous_within)

	lemma continuous_inv_chart: "continuous (at x within X) (inv_chart c)" if "x \<in> codomain c"
	apply (rule continuous_at_imp_continuous_within)
	using continuous_on_codomain[of c] that at_within_codomain[OF that]
	by (auto simp: continuous_on_eq_continuous_within)

	lemmas apply_chart_tendsto[tendsto_intros] = isCont_tendsto_compose[OF continuous_apply_chart, rotated]
	lemmas inv_chart_tendsto[tendsto_intros] = isCont_tendsto_compose[OF continuous_inv_chart, rotated]

	lemma continuous_within_compose2':
	"continuous (at (f x) within t) g \<Longrightarrow> f ` s \<subseteq> t \<Longrightarrow>
	continuous (at x within s) f \<Longrightarrow>
	continuous (at x within s) (\<lambda>x. g (f x))"
	by (simp add: continuous_within_compose2 continuous_within_subset)

	lemmas continuous_chart[continuous_intros] =
	continuous_within_compose2'[OF continuous_apply_chart]
	continuous_within_compose2'[OF continuous_inv_chart]

	lemma continuous_on_chart_inv:
	assumes "continuous_on s (apply_chart c o f)"
	"f ` s \<subseteq> domain c"
	shows "continuous_on s f"
	proof -
	have "continuous_on s (inv_chart c o apply_chart c o f)"
	using assms by (auto intro!: continuous_on_chart(2))
	moreover have "\<And>x. x \<in> s \<Longrightarrow> (inv_chart c o apply_chart c o f) x = f x"
	using assms by auto
	ultimately show ?thesis by auto
	qed

	lemma continuous_on_chart_inv':
	assumes "continuous_on (apply_chart c ` s) (f o inv_chart c)"
	"s \<subseteq> domain c"
	shows "continuous_on s f"
	proof -
	have "continuous_on s (apply_chart c)"
	using assms continuous_on_domain continuous_on_subset by blast
	then have "continuous_on s (f o inv_chart c o apply_chart c)"
	apply (rule continuous_on_compose) using assms by auto
	moreover have "(f o inv_chart c o apply_chart c) x = f x" if "x \<in> s" for x
	using assms that by auto
	ultimately show ?thesis by auto
	qed

	lemma inj_on_apply_chart: "inj_on (apply_chart f) (domain f)"
	by (auto simp: intro!: inj_on_inverseI[where g="inv_chart f"])

	lemma apply_chart_Int: "f ` (X \<inter> Y) = f ` X \<inter> f ` Y" if "X \<subseteq> domain f" "Y \<subseteq> domain f"
	using inj_on_apply_chart that
	by (rule inj_on_image_Int)

	lemma chart_image_eq_vimage: "c ` X = inv_chart c -` X \<inter> codomain c"
	if "X \<subseteq> domain c"
	using that
	by force

	lemma open_chart_image[simp, intro]: "open (c ` X)"
	if "open X" "X \<subseteq> domain c"
	proof -
	have "c ` X = inv_chart c -` X \<inter> codomain c"
	using that(2)
	by (rule chart_image_eq_vimage)
	also have "open \<dots>"
	using that
	by (metis continuous_on_codomain continuous_on_open_vimage open_codomain)
	finally show ?thesis .
	qed

	lemma open_inv_chart_image[simp, intro]: "open (inv_chart c ` X)"
	if "open X" "X \<subseteq> codomain c"
	proof -
	have "inv_chart c ` X = c -` X \<inter> domain c"
	using that(2)
	- apply (auto simp: )
	+ apply auto
	using image_iff by fastforce
	also have "open \<dots>"
	using that
	by (metis continuous_on_domain continuous_on_open_vimage open_domain)
	finally show ?thesis .
	qed

	lemma homeomorphism_UNIV_imp_open_map:
	"homeomorphism UNIV UNIV p p' \<Longrightarrow> open f' \<Longrightarrow> open (p ` f')"
	by (auto dest: homeomorphism_imp_open_map[where U=f'])


	subsection \<open>Restriction\<close>

	lemma homeomorphism_restrict:
	"homeomorphism (a \<inter> s) (b \<inter> f' -` s) f f'" if "homeomorphism a b f f'"
	using that
	by (fastforce simp: homeomorphism_def intro: continuous_on_subset intro!: imageI)

	lift_definition restrict_chart::"'a set \<Rightarrow> ('a::t2_space, 'e::euclidean_space) chart \<Rightarrow> ('a, 'e) chart"
	is "\<lambda>S. \<lambda>(d, d', f, f'). if open S then (d \<inter> S, d' \<inter> f' -` S, f, f') else ({}, {}, f, f')"
	by (auto simp: split: if_splits intro!: open_continuous_vimage' homeomorphism_restrict
	intro: homeomorphism_cont2 homeomorphism_cont1 )

	lemma restrict_chart_restrict_chart:
	"restrict_chart X (restrict_chart Y c) = restrict_chart (X \<inter> Y) c"
	if "open X" "open Y"
	using that
	by transfer auto

	lemma domain_restrict_chart[simp]: "open S \<Longrightarrow> domain (restrict_chart S c) = domain c \<inter> S"
	and domain_restrict_chart_if: "domain (restrict_chart S c) = (if open S then domain c \<inter> S else {})"
	and codomain_restrict_chart[simp]: "open S \<Longrightarrow> codomain (restrict_chart S c) = codomain c \<inter> inv_chart c -` S"
	and codomain_restrict_chart_if: "codomain (restrict_chart S c) = (if open S then codomain c \<inter> inv_chart c -` S else {})"
	and apply_chart_restrict_chart[simp]: "apply_chart (restrict_chart S c) = apply_chart c"
	and inv_chart_restrict_chart[simp]: "inv_chart (restrict_chart S c) = inv_chart c"
	by (transfer, auto)+


	subsection \<open>Composition\<close>

	lift_definition compose_chart::"('e\<Rightarrow>'e) \<Rightarrow> ('e\<Rightarrow>'e) \<Rightarrow>
	('a::topological_space, 'e::euclidean_space) chart \<Rightarrow> ('a, 'e) chart"
	is "\<lambda>p p'. \<lambda>(d, d', f, f'). if homeomorphism UNIV UNIV p p' then (d, p ` d', p o f, f' o p')
	else ({}, {}, f, f')"
	by (auto split: if_splits)
	(auto intro: homeomorphism_UNIV_imp_open_map homeomorphism_compose homeomorphism_of_subsets)

	lemma compose_chart_apply_chart[simp]: "apply_chart (compose_chart p p' c) = p o apply_chart c"
	and compose_chart_inv_chart[simp]: "inv_chart (compose_chart p p' c) = inv_chart c o p'"
	and domain_compose_chart[simp]: "domain (compose_chart p p' c) = domain c"
	and codomain_compose_chart[simp]: "codomain (compose_chart p p' c) = p ` codomain c"
	if "homeomorphism UNIV UNIV p p'"
	using that by (transfer, auto)+

	end
	diff --git a/thys/Smooth_Manifolds/Cotangent_Space.thy b/thys/Smooth_Manifolds/Cotangent_Space.thy
	--- a/thys/Smooth_Manifolds/Cotangent_Space.thy
	+++ b/thys/Smooth_Manifolds/Cotangent_Space.thy
	@@ -1,631 +1,631 @@
	section \<open>Cotangent Space\<close>
	theory Cotangent_Space
	imports Tangent_Space
	begin

	subsection \<open>Dual of a vector space\<close>

	abbreviation "linear_fun_on S \<equiv> linear_on S (UNIV::real set) scaleR scaleR"

	definition dual_space :: "'a::real_vector set \<Rightarrow> ('a \<Rightarrow> real) set" where
	"dual_space S = {E. linear_fun_on S E \<and> extensional0 S E}"

	lemma dual_space_eq:
	"dual_space S = {E. linear_fun_on S E} \<inter> {E. extensional0 S E}"
	by (auto simp: dual_space_def)

	lemma mem_dual_space:
	"E \<in> dual_space S \<longleftrightarrow> linear_fun_on S E \<and> extensional0 S E"
	by (auto simp: dual_space_def)

	lemma dual_spaceI:
	"E \<in> dual_space S"
	if "extensional0 S E" "linear_fun_on S E"
	using that
	by (auto simp: dual_space_def)

	lemma dual_spaceD:
	assumes "E \<in> dual_space S"
	shows dual_space_linear_on: "linear_fun_on S E"
	and dual_space_restrict[simp]: "extensional0 S E"
	using assms by (auto simp: dual_space_def)

	lemma linear_fun_on_zero:
	"linear_fun_on S 0"
	if "subspace S"
	by (unfold_locales, auto simp add: algebra_simps that[unfolded subspace_def])

	lemma "linear_fun_on S x \<Longrightarrow> a \<in> S \<Longrightarrow> b \<in> S \<Longrightarrow> x (a + b) = x a + x b"
	using linear_on.axioms module_hom_on.add by blast

	lemma linear_fun_on_add:
	"linear_fun_on S (x + y)"
	if x: "linear_fun_on S x" and y: "linear_fun_on S y" and S: "subspace S"
	using x that
	by (unfold_locales, auto dest!: linear_on.axioms
	simp add: algebra_simps module_hom_on.add module_hom_on.scale subspace_def)

	lemma linear_fun_on_scaleR:
	"linear_fun_on S (c *\<^sub>R x)"
	if x: "linear_fun_on S x" and S: "subspace S"
	using x that
	by (unfold_locales, auto dest!: linear_on.axioms
	simp add: module_hom_on.add module_hom_on.scale algebra_simps subspace_def)

	lemma subspace_linear_fun_on:
	"subspace {E. linear_fun_on S E}"
	if "subspace S"
	by (auto simp: subspace_def linear_fun_on_zero[OF that]
	linear_fun_on_add[OF _ _ that] linear_fun_on_scaleR[OF _ that])

	lemma subspace_dual_space:
	"subspace (dual_space S)"
	if "subspace S"
	unfolding dual_space_eq
	apply (rule subspace_inter)
	apply (rule subspace_linear_fun_on[OF that])
	apply (rule subspace_extensional0)
	done

	subsection \<open>Dimension of dual space\<close>

	text \<open>Mapping from S to the dual of S\<close>

	context fixes B S assumes B: "independent B" "span B = S"
	begin

	definition "inner_Basis a b = (\<Sum>i\<in>B. representation B a i * representation B b i)"
	\<comment> \<open>TODO: move to library\<close>

	definition std_dual :: "'a::real_vector \<Rightarrow> ('a \<Rightarrow> real)" where
	"std_dual a = restrict0 S (restrict0 S (\<lambda>b. inner_Basis a b))"

	lemma inner_Basis_add:
	"b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis (b1 + b2) v = inner_Basis b1 v + inner_Basis b2 v"
	by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
	B inner_Basis_def
	sum.distrib sum_distrib_left)

	lemma inner_Basis_add2:
	"b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis v (b1 + b2) = inner_Basis v b1 + inner_Basis v b2"
	by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
	B inner_Basis_def
	sum.distrib sum_distrib_left)

	lemma inner_Basis_scale:
	"b1 \<in> S \<Longrightarrow> inner_Basis (c \<^sub>R b1) v = c inner_Basis b1 v"
	by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
	B inner_Basis_def sum.distrib sum_distrib_left)

	lemma inner_Basis_scale2:
	"b1 \<in> S \<Longrightarrow> inner_Basis v (c \<^sub>R b1) = c inner_Basis v b1"
	by (auto simp: std_dual_def restrict0_def algebra_simps representation_add representation_scale
	B inner_Basis_def sum.distrib sum_distrib_left)

	lemma inner_Basis_minus:
	"b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis (b1 - b2) v = inner_Basis b1 v - inner_Basis b2 v"
	and inner_Basis_minus2:
	"b1 \<in> S \<Longrightarrow> b2 \<in> S \<Longrightarrow> inner_Basis v (b1 - b2) = inner_Basis v b1 - inner_Basis v b2"
	by (auto simp: std_dual_def restrict0_def algebra_simps representation_diff representation_scale
	B inner_Basis_def
	sum_subtractf sum_distrib_left)

	lemma sum_zero_representation:
	"v = 0"
	if "\<And>b. b \<in> B \<Longrightarrow> representation B v b = 0" and v: "v \<in> S"
	proof -
	have empty: "{b. representation B v b \<noteq> 0} = {}"
	using that(1) representation_ne_zero by auto
	have "v \<in> span B" using B v by simp
	from sum_nonzero_representation_eq[OF B(1) this]
	show ?thesis
	by (simp add: empty)
	qed

	lemma inner_Basis_0[simp]: "inner_Basis 0 a = 0" "inner_Basis a 0 = 0"
	by (auto simp: inner_Basis_def representation_zero)

	lemma inner_Basis_eq_zeroI: "a = 0" if "inner_Basis a a = 0"
	and "finite B" "a \<in> S"
	by (rule sum_zero_representation)
	(use that in \<open>auto simp: inner_Basis_def that sum_nonneg_eq_0_iff\<close>)

	lemma inner_Basis_zero: "inner_Basis a a = 0 \<longleftrightarrow> a = 0"
	if "finite B" "a \<in> S"
	by (auto simp: inner_Basis_eq_zeroI that)

	lemma subspace_S: "subspace S"
	using B by auto

	interpretation S: real_vector_space_on S
	using subspace_S
	by unfold_locales

	interpretation dual: real_vector_space_on "dual_space S"
	using subspace_dual_space[OF subspace_S]
	by unfold_locales

	lemma std_dual_linear:
	"linear_on S (dual_space S) scaleR scaleR std_dual"
	by unfold_locales
	(auto simp add: subspace_S[unfolded subspace_def] subspace_dual_space[unfolded subspace_def] algebra_simps
	std_dual_def inner_Basis_scale inner_Basis_add restrict0_def)

	lemma image_std_dual:
	"std_dual ` S \<subseteq> dual_space S"
	if "subspace S"
	proof safe
	fix y assume "y \<in> S"
	show "std_dual y \<in> dual_space S"
	proof (rule dual_spaceI)
	show "extensional0 S (std_dual y)"
	by (auto simp: std_dual_def)
	show "linear_fun_on S (std_dual y)"
	by (unfold_locales, auto simp: std_dual_def algebra_simps that[unfolded subspace_def]
	inner_Basis_add2 inner_Basis_scale2 B)
	qed
	qed

	lemma inj_std_dual:
	"inj_on std_dual S"
	if "subspace S" "finite B"
	proof (intro inj_onI)
	fix x y assume x: "x \<in> S" and y: "y \<in> S" and eq: "std_dual x = std_dual y"
	have 1: "inner_Basis x b = inner_Basis y b" if b: "b \<in> S" for b
	proof -
	have "std_dual x b = inner_Basis x b" "std_dual y b = inner_Basis y b"
	unfolding std_dual_def restrict0_def
	using b by auto
	then show ?thesis using eq by auto
	qed
	have 2: "x - y \<in> S" using that(1) x y by (rule subspace_diff)
	have "inner_Basis x (x - y) - inner_Basis y (x - y) = 0" using 1 2 by auto
	then have "inner_Basis (x - y) (x - y) = 0"
	by (auto simp: inner_Basis_minus inner_Basis_minus2 2 B x y algebra_simps)
	then show "x = y"
	by (auto simp: inner_Basis_zero B that 2)
	qed

	lemma inner_Basis_sum:
	"(\<And>i. i \<in> I \<Longrightarrow> x i \<in> S) \<Longrightarrow> inner_Basis (\<Sum>i\<in>I. x i) v = (\<Sum>i\<in>I. inner_Basis (x i) v)"
	apply (induction I rule: infinite_finite_induct)
	- apply (auto simp: )
	+ apply auto
	apply (subst inner_Basis_add)
	apply auto
	by (metis B(2) subspace_span subspace_sum)

	lemma inner_Basis_sum2:
	"(\<And>i. i \<in> I \<Longrightarrow> x i \<in> S) \<Longrightarrow> inner_Basis v (\<Sum>i\<in>I. x i) = (\<Sum>i\<in>I. inner_Basis v (x i))"
	apply (induction I rule: infinite_finite_induct)
	- apply (auto simp: )
	+ apply auto
	apply (subst inner_Basis_add2)
	apply auto
	by (metis B(2) subspace_span subspace_sum)

	lemma B_sub_S: "B \<subseteq> S"
	using B(2) span_eq by auto

	lemma inner_Basis_eq_representation:
	"inner_Basis i x = representation B x i"
	if "i \<in> B" "finite B"
	unfolding inner_Basis_def
	by (simp add: B that representation_basis if_distrib if_distribR cong: if_cong)

	lemma surj_std_dual:
	"std_dual ` S \<supseteq> dual_space S" if "subspace S" "finite B"
	proof safe
	fix y
	assume y: "y \<in> dual_space S"
	show "y \<in> std_dual ` S"
	proof -
	(* Basic idea: let v_i be a basis of S. Let x be the sum of (y v_i) * v_i.
	Then y should be equal to std_dual S ` x. *)
	let ?x = "\<Sum>i\<in>B. (y i) *\<^sub>R i"
	have x: "?x \<in> S"
	using that(1) apply (rule subspace_sum) using that(1) apply (rule subspace_scale)
	using B span_superset
	by auto
	from dual_space_linear_on[OF y]
	have linear_y: "linear_fun_on S y" .
	then interpret linear_on S UNIV scaleR scaleR y .
	interpret vector_space_pair_on S "UNIV::real set" scaleR scaleR by unfold_locales
	have "y = std_dual ?x"
	apply (rule ext_extensional0[of S])
	subgoal using y dual_space_def by auto
	subgoal by (auto simp: std_dual_def)
	unfolding std_dual_def restrict0_def apply auto
	apply (subst inner_Basis_sum) subgoal
	using B(2) span_base subspace_scale by blast
	subgoal for x
	proof goal_cases
	case 1
	have "(\<Sum>i\<in>B. inner_Basis (y i \<^sub>R i) x) = (\<Sum>i\<in>B. y (inner_Basis i x \<^sub>R i))"
	proof (rule sum.cong[OF refl])
	fix i assume i: "i \<in> B"
	then have "i : S" using B_sub_S by auto
	have "inner_Basis (y i \<^sub>R i) x = y i inner_Basis i x"
	apply (subst inner_Basis_scale)
	subgoal using B_sub_S i by auto
	apply (rule refl)
	done
	also have "\<dots> = y i *\<^sub>R inner_Basis i x" by simp
	also have "\<dots> = y (inner_Basis i x *\<^sub>R i)"
	by (auto simp: \<open>i \<in> S\<close> scale)
	finally show "inner_Basis (y i \<^sub>R i) x = y (inner_Basis i x \<^sub>R i)" .
	qed
	also have "\<dots> = y (\<Sum>i\<in>B. (inner_Basis i x *\<^sub>R i))" (is "_ = y ?sum")
	apply (subst linear_sum'[OF _ _ linear_y])
	apply (auto simp: inner_Basis_eq_representation)
	using B(2) S.mem_scale span_base by blast
	also have "?sum = x"
	apply (subst sum.cong[OF refl])
	apply (subst inner_Basis_eq_representation, assumption, rule that, rule refl)
	apply (subst sum_representation_eq)
	by (auto simp: that B \<open>x : S\<close>)
	finally show ?thesis by simp
	qed
	done
	then show ?thesis
	using x by auto
	qed
	qed

	lemma std_dual_bij_betw:
	"bij_betw (std_dual) S (dual_space S)"
	if "finite B"
	unfolding bij_betw_def
	using subspace_S inj_std_dual image_std_dual surj_std_dual that by blast

	lemma std_dual_eq_dual_space: "finite B \<Longrightarrow> std_dual ` S = dual_space S"
	using image_std_dual surj_std_dual subspace_S by auto

	lemma dim_dual_space:
	assumes "finite B"
	shows "dim (dual_space S) = dim S"
	proof -
	interpret finite_dimensional_real_vector_space_pair_1_on S "dual_space S" B
	using B assms span_superset
	by unfold_locales auto
	have *: "span S = S" using subspace_S by auto
	then have "dual.dim (std_dual ` S) = S.dim S"
	apply (intro dim_image_eq[OF _ order_refl std_dual_linear])
	using std_dual_bij_betw[OF assms]
	by (auto simp: bij_betw_def *)
	also have "S.dim S = dim S"
	unfolding S.dim_eq[OF order_refl] ..
	also have "dual.dim (std_dual ` S) = dim (std_dual ` S)"
	using image_std_dual[OF subspace_S]
	by (rule dual.dim_eq)
	also have "std_dual ` S = dual_space S"
	using assms
	by (rule std_dual_eq_dual_space)
	finally show ?thesis .
	qed

	end

	subsection \<open>Dual map\<close>

	context real_vector_space_pair_on begin

	definition dual_map :: "('a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> ('a \<Rightarrow> real)" where
	"dual_map f y = restrict0 S (\<lambda>x. y (f x))"

	lemma subspace_dual_S: "subspace (dual_space S)"
	apply (rule subspace_dual_space)
	apply (rule local.vs1.subspace)
	done

	lemma subspace_dual_T: "subspace (dual_space T)"
	apply (rule subspace_dual_space)
	apply (rule local.vs2.subspace)
	done

	lemma dual_map_linear:
	"linear_on (dual_space T) (dual_space S) scaleR scaleR (dual_map f)"
	apply unfold_locales
	by (auto simp add: dual_map_def restrict0_def subspace_dual_S[unfolded subspace_def]
	subspace_dual_T[unfolded subspace_def] algebra_simps)

	lemma image_dual_map:
	"dual_map f ` (dual_space T) \<subseteq> dual_space S"
	if f: "linear_on S T scaleR scaleR f" and
	defined: "f ` S \<subseteq> T"
	proof safe
	fix x assume x: "x \<in> dual_space T"
	show "dual_map f x \<in> dual_space S"
	proof (rule dual_spaceI)
	have 1: "linear_fun_on T x"
	using x by (rule dual_space_linear_on)
	show "extensional0 S (dual_map f x)" by (auto simp: dual_map_def)
	show "linear_fun_on S (dual_map f x)"
	apply (unfold_locales, auto simp: dual_map_def restrict0_def linear_on_def algebra_simps
	local.vs1.subspace[unfolded subspace_def])
	proof -
	show "x (f (b1 + b2)) = x (f b1) + x (f b2)" if "b1 \<in> S" "b2 \<in> S" for b1 b2
	proof -
	have "f b1 \<in> T" using \<open>b1 \<in> S\<close> defined by auto
	have "f b2 \<in> T" using \<open>b2 \<in> S\<close> defined by auto
	have "x (f (b1 + b2)) = x (f b1 + f b2)"
	by (auto simp: f[THEN linear_on.axioms, THEN module_hom_on.add] that)
	also have "x (f b1 + f b2) = x (f b1) + x (f b2)"
	by (auto simp: 1[THEN linear_on.axioms, THEN module_hom_on.add] \<open>f b1 \<in> T\<close> \<open>f b2 \<in> T\<close>)
	finally show ?thesis .
	qed
	show "x (f (r \<^sub>R b)) = r x (f b)" if "b \<in> S" for r b
	proof -
	have "f b \<in> T" using \<open>b \<in> S\<close> defined by auto
	have "x (f (r \<^sub>R b)) = x (r \<^sub>R f b)"
	by (auto simp: f[THEN linear_on.axioms, THEN module_hom_on.scale] that)
	also have "x (r \<^sub>R f b) = r x (f b)"
	by (auto simp: 1[THEN linear_on.axioms, THEN module_hom_on.scale] \<open>f b \<in> T\<close>)
	finally show ?thesis .
	qed
	qed
	qed
	qed

	end

	text \<open>Functoriality of dual map: identity\<close>

	context real_vector_space_on begin

	lemma dual_map_id:
	"real_vector_space_pair_on.dual_map S f y = y"
	if f: "\<And>x. x \<in> S \<Longrightarrow> f x = x" and y: "y \<in> dual_space S"
	proof (rule ext_extensional0[of S])
	have 1: "real_vector_space_pair_on S S" ..
	show "extensional0 S (real_vector_space_pair_on.dual_map S f y)"
	unfolding real_vector_space_pair_on.dual_map_def[OF 1] by auto
	show "extensional0 S y"
	using y by auto
	fix x assume x: "x \<in> S"
	show "real_vector_space_pair_on.dual_map S f y x = y x"
	proof -
	have "real_vector_space_pair_on.dual_map S f y x = y (f x)"
	by (auto simp: real_vector_space_pair_on.dual_map_def[OF 1] restrict0_def x)
	also have "y (f x) = y x"
	using f x by auto
	finally show ?thesis .
	qed
	qed

	end

	abbreviation "dual_map \<equiv> real_vector_space_pair_on.dual_map"
	lemmas dual_map_def = real_vector_space_pair_on.dual_map_def

	text \<open>Functoriality of dual map: composition\<close>

	lemma dual_map_compose:
	"dual_map S f (dual_map T g x) = dual_map S (g \<circ> f) x"
	if "x \<in> dual_space U" and "linear_on T U scaleR scaleR g"
	and f: "linear_on S T scaleR scaleR f"
	and defined: "f ` S \<subseteq> T"
	and ST: "real_vector_space_pair_on S T"
	and TU: "real_vector_space_pair_on T U"
	proof (rule ext)
	have SU: "real_vector_space_pair_on S U"
	using ST TU by (auto simp add: real_vector_space_pair_on_def)
	fix v show "dual_map S f (dual_map T g x) v = dual_map S (g \<circ> f) x v"
	unfolding dual_map_def[OF ST] dual_map_def[OF TU] dual_map_def[OF SU] restrict0_def
	using defined by auto
	qed

	subsection \<open>Definition of cotangent space\<close>

	context c_manifold begin

	definition cotangent_space :: "'a \<Rightarrow> ((('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real) set" where
	"cotangent_space p = dual_space (tangent_space p)"

	lemma subspace_cotangent_space:
	"subspace (cotangent_space p)"
	unfolding cotangent_space_def
	apply (rule subspace_dual_space)
	apply (rule subspace_tangent_space)
	done

	sublocale cotangent_space: real_vector_space_on "cotangent_space p"
	by unfold_locales (rule subspace_cotangent_space)

	(* Shouldn't there be a general theorem for this, instead of repeating the proof
	for tangent_space_dim_eq?
	*)
	lemma cotangent_space_dim_eq: "cotangent_space.dim p X = dim X"
	if "X \<subseteq> cotangent_space p"
	proof -
	have *: "b \<subseteq> cotangent_space p \<and> independent b \<and> span b = span X \<longleftrightarrow> independent b \<and> span b = span X"
	for b
	using that
	by auto (metis (no_types, lifting) c_manifold.subspace_cotangent_space c_manifold_axioms span_base span_eq_iff span_mono subsetCE)
	show ?thesis
	using that
	unfolding cotangent_space.dim_def dim_def *
	by auto
	qed

	lemma dim_cotangent_space:
	"dim (cotangent_space p) = DIM('b)" if "p \<in> carrier" and "k = \<infinity>"
	proof -
	from basis_exists[of "tangent_space p"]
	obtain B where B: "B \<subseteq> tangent_space p" "independent B" "tangent_space p \<subseteq> span B"
	"card B = dim (tangent_space p)"
	by auto
	have "finite B"
	apply (rule card_ge_0_finite)
	unfolding B
	apply (subst dim_tangent_space[OF that])
	by simp
	have "dim (cotangent_space p) = dim (tangent_space p)"
	unfolding cotangent_space_def
	apply (rule dim_dual_space[of B])
	apply fact
	using B span_minimal[OF B(1) subspace_tangent_space] \<open>finite B\<close>
	by auto
	also have "dim (tangent_space p) = DIM('b)"
	by (rule dim_tangent_space[OF that])
	finally show ?thesis .
	qed

	end

	subsection \<open>Pullback of cotangent space\<close>

	context diff begin

	definition pull_back :: "'a \<Rightarrow> ((('b \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> (('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real" where
	"pull_back p = dual_map (src.tangent_space p) push_forward"

	lemma
	linear_pullback: "linear_on (dest.cotangent_space (f p)) (src.cotangent_space p) scaleR scaleR (pull_back p)" and
	image_pullback: "pull_back p ` (dest.cotangent_space (f p)) \<subseteq> src.cotangent_space p"
	if "p \<in> src.carrier"
	proof -
	interpret a: real_vector_space_pair_on "src.tangent_space p" "dest.tangent_space (f p)" ..
	show "linear_on (dest.cotangent_space (f p)) (src.cotangent_space p) (\<^sub>R) (\<^sub>R) (pull_back p)"
	unfolding dest.cotangent_space_def src.cotangent_space_def pull_back_def
	by (rule a.dual_map_linear)
	show "pull_back p ` (dest.cotangent_space (f p)) \<subseteq> src.cotangent_space p"
	unfolding dest.cotangent_space_def src.cotangent_space_def pull_back_def
	apply (rule a.image_dual_map)
	apply (rule linear_imp_linear_on)
	apply (rule local.linear_push_forward)
	apply (rule local.src.subspace_tangent_space)
	apply (rule local.dest.subspace_tangent_space)
	apply (rule local.push_forward_in_tangent_space)
	by fact
	qed

	end

	subsection \<open>Cotangent field of a function\<close>

	context c_manifold begin

	text \<open>Given a function f, the cotangent vector of f at a point p is defined
	as follows: given a tangent vector X at p, considered as a functional, evaluate
	X on f.\<close>

	definition cotangent_field :: "('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> ((('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> real)" where
	"cotangent_field f p = restrict0 (tangent_space p) (\<lambda>X. X f)"

	lemma cotangent_field_is_cotangent:
	"cotangent_field f p \<in> cotangent_space p"
	unfolding cotangent_space_def
	proof (rule dual_spaceI)
	show "extensional0 (tangent_space p) (cotangent_field f p)"
	unfolding cotangent_field_def by auto
	show "linear_fun_on (tangent_space p) (cotangent_field f p)"
	apply unfold_locales unfolding cotangent_field_def apply auto
	proof -
	show "restrict0 (tangent_space p) (\<lambda>X. X f) (b1 + b2) = b1 f + b2 f"
	if b1: "b1 \<in> tangent_space p" and b2: "b2 \<in> tangent_space p" for b1 b2
	proof -
	have "b1 + b2 \<in> tangent_space p" using b1 b2 subspace_tangent_space subspace_add by auto
	then show ?thesis by auto
	qed
	show "restrict0 (tangent_space p) (\<lambda>X. X f) (r \<^sub>R b) = r b f"
	if b: "b \<in> tangent_space p" for r b
	proof -
	have "r *\<^sub>R b \<in> tangent_space p" using b subspace_tangent_space subspace_scale by auto
	then show ?thesis by auto
	qed
	qed
	qed

	subsection \<open>Tangent field of a path\<close>

	(* Note: an alternative definition is as follows: consider the path as
	a smooth map from the manifold with boundary [a,b], then take the
	push-forward of the trivial tangent field on [a,b]. In this case,
	showing this is a tangent vector would be trivial. *)

	text \<open>Given a path \<open>c\<close>, the tangent vector of \<open>c\<close> at real number \<open>x\<close> (or at point \<open>c(x)\<close>)
	is defined as follows: given a function f, take the derivative of the
	real-valued function \<open>f \<circ> c\<close>.\<close>

	definition tangent_field :: "(real \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> (('a \<Rightarrow> real) \<Rightarrow> real)" where
	"tangent_field c x = restrict0 diff_fun_space (\<lambda>f. frechet_derivative (f \<circ> c) (at x) 1)"

	lemma tangent_field_is_tangent:
	"tangent_field c x \<in> tangent_space (c x)"
	if c_smooth: "diff k charts_eucl charts c" and smooth: "k > 0"
	proof (rule tangent_spaceI)
	show "extensional0 diff_fun_space (tangent_field c x)"
	unfolding tangent_field_def by auto
	have diff_fun_c_diff: "(\<lambda>x. b (c x)) differentiable at x"
	if b: "b \<in> diff_fun_space"
	for b::"'a \<Rightarrow> real" and x
	proof -
	have diff_b: "diff_fun k charts_eucl (b o c)"
	unfolding diff_fun_def
	using c_smooth diff_fun_spaceD[OF b, THEN diff_fun.axioms]
	by (rule diff_compose)
	from diff_fun_charts_euclD[OF this] smooth
	have "(b o c) differentiable_on UNIV"
	by (rule smooth_on_imp_differentiable_on)
	then show ?thesis by (auto simp: differentiable_on_def o_def)
	qed
	show "linear_fun_on diff_fun_space (tangent_field c x)"
	apply unfold_locales unfolding cotangent_field_def apply auto
	proof -
	show "tangent_field c x (b1 + b2) = tangent_field c x b1 + tangent_field c x b2"
	if b1: "b1 \<in> diff_fun_space" and b2: "b2 \<in> diff_fun_space" for b1 b2
	unfolding tangent_field_def restrict0_def
	by (auto simp: diff_fun_space_add o_def diff_fun_c_diff b1 b2 frechet_derivative_plus)
	show "tangent_field c x (r \<^sub>R b) = r tangent_field c x b"
	if b: "b \<in> diff_fun_space" for r b
	unfolding tangent_field_def restrict0_def
	by (auto simp: diff_fun_space.m1.mem_scale o_def diff_fun_c_diff b frechet_derivative_times
	frechet_derivative_const)
	qed
	show "tangent_field c x (f * g) = f (c x) * tangent_field c x g + g (c x) * tangent_field c x f"
	if f: "f \<in> diff_fun_space" and g: "g \<in> diff_fun_space" for f g
	unfolding tangent_field_def restrict0_def
	by (auto simp: f g diff_fun_space_times diff_fun_space_add o_def diff_fun_c_diff
	frechet_derivative_plus frechet_derivative_times)
	qed

	subsection \<open>Integral along a path\<close>

	lemma fundamental_theorem_of_path_integral:
	"((\<lambda>x. (cotangent_field f (c x)) (tangent_field c x)) has_integral f (c b) - f (c a)) {a..b}"
	if ab: "a \<le> b" and f: "f \<in> diff_fun_space" and c: "diff k charts_eucl charts c" and k: "k \<noteq> 0"
	proof -
	from f have "diff k charts charts_eucl f"
	by (auto simp: diff_fun_space_def diff_fun_def)
	then have "(diff_fun k charts_eucl (f o c))"
	unfolding diff_fun_def
	apply (intro diff_compose)
	apply (rule c)
	apply assumption
	done
	then have "k-smooth_on UNIV (f o c)"
	by (rule diff_fun_charts_euclD)
	then have "(f o c) differentiable_on UNIV"
	by (rule smooth_on_imp_differentiable_on) (use k in simp)
	then have fc: "(\<lambda>a. f (c a)) differentiable at x" for x
	by (auto simp: differentiable_on_def o_def)
	then show ?thesis
	using ab
	unfolding cotangent_field_def
	apply (auto simp: tangent_field_is_tangent c k)
	unfolding tangent_field_def
	apply (auto simp: f)
	apply (rule fundamental_theorem_of_calculus)
	apply assumption
	apply (rule has_vector_derivative_at_within)
	unfolding o_def has_vector_derivative_def
	apply (subst frechet_derivative_at_real_eq_scaleR[symmetric])
	apply simp
	apply simp
	apply (rule frechet_derivative_worksI)
	apply simp
	done
	qed

	end

	end
	diff --git a/thys/Smooth_Manifolds/Projective_Space.thy b/thys/Smooth_Manifolds/Projective_Space.thy
	--- a/thys/Smooth_Manifolds/Projective_Space.thy
	+++ b/thys/Smooth_Manifolds/Projective_Space.thy
	@@ -1,704 +1,704 @@
	section \<open>Projective Space\<close>
	theory Projective_Space
	imports Differentiable_Manifold "HOL-Library.Quotient_Set"
	begin

	text \<open>Some of the main things to note here: double transfer (-> nonzero -> quotient)\<close>

	subsection \<open>Subtype of nonzero elements\<close>

	lemma open_ne_zero: "open {x::'a::t1_space. x \<noteq> c}"
	proof -
	have "{x::'a. x \<noteq> c} = UNIV - {c}" by auto
	also have "open \<dots>" by (rule open_delete; rule open_UNIV)
	finally show ?thesis .
	qed

	typedef (overloaded) 'a::euclidean_space nonzero = "UNIV - {0::'a::euclidean_space}" by auto

	setup_lifting type_definition_nonzero

	instantiation nonzero :: (euclidean_space) topological_space
	begin

	lift_definition open_nonzero::"'a nonzero set \<Rightarrow> bool" is "open::'a set \<Rightarrow> bool" .

	instance
	apply standard
	subgoal by transfer (auto simp: open_ne_zero)
	subgoal by transfer auto
	subgoal by transfer auto
	done

	end

	lemma open_nonzero_openin_transfer:
	"(rel_set (pcr_nonzero A) ===> (=)) (openin (top_of_set (Collect (Domainp (pcr_nonzero A))))) open"
	if "is_equality A"
	unfolding is_equality_def[THEN iffD1, OF that]
	proof
	fix X::"'a set" and Y::"'a nonzero set"
	assume t[transfer_rule]: "rel_set (pcr_nonzero (=)) X Y"
	show "openin (top_of_set (Collect (Domainp (pcr_nonzero (=))))) X = open Y"
	apply (auto simp: openin_subtopology)
	subgoal by transfer (auto simp: nonzero.domain_eq open_ne_zero)
	subgoal
	apply transfer
	apply (rule exI[where x=X])
	using t
	by (auto simp: rel_set_def)
	done
	qed

	instantiation nonzero :: (euclidean_space) scaleR
	begin
	lift_definition scaleR_nonzero::"real \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>c x. if c = 0 then One else c *\<^sub>R x"
	by auto
	instance ..

	end

	instantiation nonzero :: (euclidean_space) plus
	begin
	lift_definition plus_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>x y. if x + y = 0 then One else x + y"
	by auto
	instance ..
	end

	instantiation nonzero :: (euclidean_space) minus
	begin
	lift_definition minus_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> 'a nonzero" is "\<lambda>x y. if x = y then One else x - y"
	by auto
	instance ..
	end

	instantiation nonzero :: (euclidean_space) dist
	begin
	lift_definition dist_nonzero::"'a nonzero \<Rightarrow> 'a nonzero \<Rightarrow> real" is dist .
	instance ..
	end

	instantiation nonzero :: (euclidean_space) norm
	begin
	lift_definition norm_nonzero::"'a nonzero \<Rightarrow> real" is norm .
	instance ..
	end

	instance nonzero :: (euclidean_space) t2_space
	apply standard
	apply transfer
	subgoal for x y
	using hausdorff[of x y]
	apply clarsimp
	subgoal for U V
	apply (rule exI[where x="U - {0}"])
	apply clarsimp
	apply (rule conjI) defer
	apply (rule exI[where x="V - {0}"])
	by auto
	done
	done

	lemma scaleR_one_nonzero[simp]: "1 *\<^sub>R x = (x::_ nonzero)"
	by transfer auto

	lemma scaleR_scaleR_nonzero[simp]: "b \<noteq> 0 \<Longrightarrow> scaleR a (scaleR b x) = scaleR (a * b) (x::_ nonzero)"
	by transfer auto

	instance nonzero :: (euclidean_space) second_countable_topology
	proof standard
	from ex_countable_basis[where 'a='a] obtain A::"'a set set" where "countable A" "topological_basis A"
	by auto
	define B where "B = (\<lambda>X. Abs_nonzero ` (X - {0})) ` A"
	have [transfer_rule]: "rel_set (rel_set (pcr_nonzero (=))) ((\<lambda>X. X - {0})`A) B"
	by (clarsimp simp: B_def rel_set_def pcr_nonzero_def OO_def cr_nonzero_def)
	(metis Abs_nonzero_inverse Diff_iff UNIV_I singleton_iff)
	from \<open>topological_basis A\<close>
	have "topological_basis B"
	unfolding topological_basis_def
	apply transfer
	apply safe
	apply force
	subgoal for X
	apply (drule spec[where x=X])
	apply clarsimp
	subgoal for B'
	apply (rule exI[where x=B'])
	by auto
	done
	done
	then show "\<exists>B::'a nonzero set set. countable B \<and> open = generate_topology B"
	apply (intro exI[where x=B])
	by (auto simp add: B_def \<open>countable A\<close> topological_basis_imp_subbasis)
	qed


	subsection \<open>Quotient\<close>

	inductive proj_rel :: "'a::euclidean_space nonzero \<Rightarrow> 'a nonzero \<Rightarrow> bool" for x where
	"c \<noteq> 0 \<Longrightarrow> proj_rel x (c *\<^sub>R x)"

	lemma proj_rel_parametric: "(pcr_nonzero A ===> pcr_nonzero A ===> (=)) proj_rel proj_rel"
	if [transfer_rule]: " ((=) ===> pcr_nonzero A ===> pcr_nonzero A) (\<^sub>R) (\<^sub>R)"
	"bi_unique A"
	unfolding proj_rel.simps
	by transfer_prover

	quotient_type (overloaded) 'a proj_space = "('a::euclidean_space \<times> real) nonzero" / proj_rel
	morphisms rep_proj Proj
	parametric proj_rel_parametric
	proof (rule equivpI)
	show "reflp proj_rel"
	using proj_rel.intros[where c=1, simplified] by (auto simp: reflp_def)
	show "symp proj_rel"
	unfolding symp_def
	apply (auto elim!: proj_rel.cases)
	subgoal for x c
	by (rule proj_rel.intros[of "inverse c" "c *\<^sub>R x", simplified])
	done
	show "transp proj_rel"
	unfolding transp_def
	by (auto elim!: proj_rel.cases intro!: proj_rel.intros)
	qed

	lemma surj_Proj: "surj Proj"
	apply safe
	subgoal by force
	subgoal for x by (induct x) auto
	done

	definition proj_topology :: "'a::euclidean_space proj_space topology" where
	"proj_topology = map_topology Proj euclidean"

	instantiation proj_space :: (euclidean_space) topological_space
	begin

	definition open_proj_space :: "'a proj_space set \<Rightarrow> bool" where
	"open_proj_space = openin (map_topology Proj euclidean)"

	lemma topspace_map_Proj: "topspace (map_topology Proj euclidean) = UNIV"
	using surj_Proj by auto

	instance
	apply (rule class.Topological_Spaces.topological_space.of_class.intro)
	unfolding open_proj_space_def
	using surj_Proj
	by (rule topological_space_quotient)

	end

	lemma open_vimage_ProjI: "open T \<Longrightarrow> open (Proj -` T)"
	by (metis inf_top.right_neutral open_openin open_proj_space_def openin_map_topology topspace_euclidean)
	lemma open_vimage_ProjD: "open (Proj -` T) \<Longrightarrow> open T"
	by (metis inf_top.right_neutral open_openin open_proj_space_def openin_map_topology top.extremum topspace_euclidean topspace_map_Proj topspace_map_topology)
	lemma open_vimage_Proj_iff[simp]: "open (Proj -` T) = open T"
	by (auto simp: open_vimage_ProjI open_vimage_ProjD)

	lemma euclidean_proj_space_def: "euclidean = map_topology Proj euclidean"
	apply (auto simp: topology_eq_iff openin_map_topology)
	subgoal for x by (induction x) auto
	subgoal for _ x by (induction x) auto
	done

	lemma continuous_on_proj_spaceI: "continuous_on (S) f" if "continuous_on (Proj -` S) (f o Proj)" "open (S)"
	for f::"_ proj_space \<Rightarrow> _"
	by (metis (no_types, opaque_lifting) continuous_on_open_vimage open_vimage_Proj_iff that vimage_Int vimage_comp)

	lemma saturate_eq: "Proj -` Proj ` X = (\<Union>c\<in>UNIV-{0}. (*\<^sub>R) c ` X)"
	- apply (auto simp: )
	+ apply auto
	subgoal for x y
	proof -
	assume "Proj x = Proj y" "y \<in> X"
	then have "proj_rel x y" using proj_space.abs_eq_iff by auto
	then show ?thesis using \<open>y \<in> X\<close>
	by (force elim!: proj_rel.cases intro!: bexI[where x="inverse c" for c])
	qed
	subgoal for c x
	using proj_rel.intros[of c x]
	by (metis imageI proj_space.abs_eq_iff)
	done

	lemma open_scaling_nonzero: "c \<noteq> 0 \<Longrightarrow> open s \<Longrightarrow> open ((*\<^sub>R) c ` s::'a::euclidean_space nonzero set)"
	by transfer auto

	subsection \<open>Proof of Hausdorff property\<close>

	lemma Proj_open_map: "open (Proj ` X)" if "open X"
	proof -
	note saturate_eq[of X]
	also have "open ((\<Union>c\<in>UNIV - {0}. (*\<^sub>R) c ` X))"
	apply (rule open_Union)
	apply (rule)
	apply (erule imageE)
	apply simp
	apply (rule open_scaling_nonzero)
	apply (simp)
	apply (rule that)
	done
	finally show ?thesis by simp
	qed

	lemma proj_rel_transfer[transfer_rule]:
	"(pcr_nonzero A ===> pcr_nonzero A ===> (=)) (\<lambda>x a. \<exists>c. a = sr c x \<and> c \<noteq> 0) proj_rel"
	if [transfer_rule]: "((=) ===> pcr_nonzero A ===> pcr_nonzero A) sr (*\<^sub>R)"
	"bi_unique A"
	unfolding proj_rel.simps
	by (transfer_prover)

	lemma bool_aux: "a \<and> (a \<longrightarrow> b) \<longleftrightarrow> a \<and> b" by auto

	lemma closed_proj_rel: "closed {(x::'a::euclidean_space nonzero, y::'a nonzero). proj_rel x y}"
	proof -
	have closed_proj_rel_euclidean:
	"\<exists>A B. 0 \<notin> A \<and> 0 \<notin> B \<and> open A \<and> open B \<and> a \<in> A \<and> b \<in> B \<and>
	A \<times> B \<subseteq> - {(x, y). (x, y) \<noteq> 0 \<and> (\<exists>c. c \<noteq> 0 \<and> y = c *\<^sub>R x)}"
	if "\<And>c. c \<noteq> 0 \<Longrightarrow> b \<noteq> c *\<^sub>R a" "a \<noteq> 0" "b \<noteq> 0"
	for a b::'a
	proof -\<comment> \<open>explicitly constructing open ``cones'' that are disjoint\<close>
	define a1 where "a1 = a /\<^sub>R norm a"
	define b1 where "b1 = b /\<^sub>R norm b"
	have norm_a1[simp]: "norm a1 = 1" and norm_b1[simp]: "norm b1 = 1"
	using that
	by (auto simp: a1_def b1_def divide_simps)
	have a_alt_def: "a = norm a \<^sub>R a1" and b_alt_def: "b = norm b \<^sub>R b1"
	using that
	by (auto simp: a1_def b1_def)
	have a1_neq_b1: "a1 \<noteq> b1" "a1 \<noteq> -b1"
	using that(1)[of "norm b / norm a"] that(2-)
	apply (auto simp: a1_def b1_def divide_simps)
	apply (metis divideR_right divide_inverse inverse_eq_divide norm_eq_zero scaleR_scaleR)
	by (metis (no_types, lifting) add.inverse_inverse b1_def b_alt_def inverse_eq_divide
	scaleR_scaleR scale_eq_0_iff scale_minus_left that(1))
	define e where "e = (1/2) * (min 1 (min (dist a1 b1) (dist (-a1) b1)))"
	have e_less: "2 * e \<le> dist a1 b1" "2 * e \<le> dist (-a1) b1" "e < 1"
	and e_pos: "0 < e"
	using that a1_neq_b1
	by (auto simp: e_def min_def)
	define A1 where "A1 = ball a1 e \<inter> {x. norm x = 1}"
	define B1 where "B1 = ball b1 e \<inter> {x. norm x = 1}"
	have disjoint: "A1 \<inter> B1 = {}" "uminus ` A1 \<inter> B1 = {}"
	using e_less
	apply (auto simp: A1_def B1_def mem_ball)
	apply (smt dist_commute dist_triangle)
	by (smt add_uminus_conv_diff diff_self dist_0_norm dist_add_cancel dist_commute dist_norm dist_triangle)
	have norm_1: "x \<in> A1 \<Longrightarrow> norm x = 1"
	"x \<in> B1 \<Longrightarrow> norm x = 1"
	for x
	by (auto simp: A1_def B1_def)
	define scales where "scales X = {c *\<^sub>R x \|c x. c \<noteq> 0 \<and> x \<in> X}" for X::"'a set"
	have scales_mem: "c *\<^sub>R x \<in> (scales X) \<longleftrightarrow> x \<in> (scales X)" if "c \<noteq> 0" for c x X
	apply (auto simp: scales_def)
	apply (metis eq_vector_fraction_iff that)
	apply (metis divisors_zero that)
	done
	define A where "A = scales A1"
	define B where "B = scales B1"

	from disjoint have "A \<inter> B = {}"
	apply (auto simp: A_def B_def mem_ball scales_def, goal_cases)
	by (smt disjoint_iff_not_equal imageI mult_cancel_right norm_1(1) norm_1(2) norm_scaleR
	scaleR_left.minus scale_left_imp_eq scale_minus_right)
	have "0 \<notin> A" "0 \<notin> B" using e_less \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>
	by (auto simp: A_def B_def A1_def B1_def mem_ball a1_def b1_def scales_def)
	moreover
	let ?S = "top_of_set {x. norm x = 1}"
	have open_scales: "open (scales X)" if "openin ?S X" for X
	proof -
	have X1: "x \<in> X \<Longrightarrow> norm x = 1" for x using that by (auto simp: openin_subtopology)
	have "0 \<notin> X" using that by (auto simp: openin_subtopology)
	have "scales X = (\<lambda>x. x /\<^sub>R norm x) -` (X \<union> uminus ` X) \<inter> (topspace (top_of_set (UNIV - {0})))"
	apply (auto simp: scales_def)
	subgoal for c x using \<open>0 \<notin> X\<close>
	apply (cases "c > 0")
	by (auto simp: X1)
	subgoal by (metis X1 norm_zero zero_neq_one)
	subgoal for x
	apply (rule exI[where x="norm x"])
	apply (rule exI[where x="x /\<^sub>R norm x"])
	by auto
	subgoal for x y apply (rule exI[where x="- norm x"]) apply (rule exI[where x=y])
	apply auto
	by (metis divideR_right norm_eq_zero scale_minus_right)
	done
	also have "openin (top_of_set (UNIV - {0})) \<dots>"
	proof -
	have : " {y. inverse (norm y) norm y = 1} = UNIV - {0}"
	by auto
	from that have "openin ?S (uminus ` X)"
	apply (clarsimp simp: openin_subtopology)
	by (auto simp: open_negations intro!: exI[where x="uminus ` T" for T])
	then have "openin ?S (X \<union> uminus ` X)"
	using \<open>openin _ X\<close> by auto
	from _ this show ?thesis
	apply (rule continuous_map_open)
	apply (auto simp: continuous_map_def)
	apply (subst(asm) openin_subtopology)
	apply (auto simp: *)
	apply (subst openin_subtopology)
	apply clarsimp
	subgoal for T
	apply (rule exI[where x="(\<lambda>x. x /\<^sub>R norm x) -` T \<inter> UNIV - {0}"])
	apply (auto simp: Diff_eq)
	apply (rule open_continuous_vimage)
	by (auto intro!: continuous_intros)
	done
	qed
	finally show ?thesis
	apply (subst (asm) openin_subtopology)
	by clarsimp auto
	qed
	have "openin ?S A1" "openin ?S B1"
	by (auto simp: openin_subtopology A1_def B1_def)
	from open_scales[OF this(1)] open_scales[OF this(2)]
	have "open A" "open B" by (simp_all add: A_def B_def)
	moreover
	have "a \<in> A" "b \<in> B"
	by (force simp: A_def B_def A1_def B1_def that e_pos scales_def intro: a_alt_def b_alt_def)+
	moreover
	have False if "c *\<^sub>R p \<in> B" "p \<in> A" "c \<noteq> 0" for p c
	using that \<open>0 \<notin> A\<close> \<open>0 \<notin> B\<close> \<open>A \<inter> B = {}\<close>
	by (auto simp: A_def B_def scales_mem)
	then have "A \<times> B \<subseteq> - {(x, y). (x, y) \<noteq> 0 \<and> (\<exists>c. c \<noteq> 0 \<and> y = c *\<^sub>R x)}"
	by (auto simp: prod_eq_iff)
	ultimately show ?thesis by blast
	qed
	show ?thesis
	unfolding closed_def open_prod_def
	apply transfer
	apply (simp add: split_beta' bool_aux pred_prod.simps)
	apply (rule ballI)
	apply (clarsimp simp: pred_prod.simps[abs_def])
	subgoal for a b
	apply (subgoal_tac "(\<And>c. c \<noteq> 0 \<Longrightarrow> b \<noteq> c *\<^sub>R a)")
	using closed_proj_rel_euclidean[of b a]
	apply clarsimp
	subgoal for A B
	apply (rule exI[where x=A])
	apply (auto intro!: exI[where x=B])
	apply (auto simp: subset_iff prod_eq_iff)
	by blast
	subgoal by auto
	done
	done
	qed

	lemma closed_Proj_rel: "closed {(x, y). Proj x = Proj y}"
	using closed_proj_rel
	by (smt Collect_cong case_prodE case_prodI2 prod.inject proj_space.abs_eq_iff)

	instance proj_space :: (euclidean_space) t2_space
	apply (rule class.Topological_Spaces.t2_space.of_class.intro)
	using open_proj_space_def surj_Proj Proj_open_map closed_Proj_rel
	by (rule t2_space_quotient)

	instance proj_space :: (euclidean_space) second_countable_topology
	apply (rule class.Elementary_Topology.second_countable_topology.of_class.intro)
	using open_proj_space_def surj_Proj Proj_open_map
	by (rule second_countable_topology_quotient)


	subsection \<open>Charts\<close>


	subsubsection \<open>Chart for last coordinate\<close>

	lift_definition chart_last_nonzero :: "('a::euclidean_space \<times> real) nonzero \<Rightarrow> 'a" is "\<lambda>(x,c). x /\<^sub>R c" .

	lemma chart_last_nonzero_scaleR[simp]: "c \<noteq> 0 \<Longrightarrow> chart_last_nonzero (c *\<^sub>R n) = chart_last_nonzero n"
	by (transfer) auto

	lift_definition chart_last :: "'a::euclidean_space proj_space \<Rightarrow> 'a" is chart_last_nonzero
	by (erule proj_rel.cases) auto

	lift_definition chart_last_inv_nonzero :: "'a \<Rightarrow> ('a::euclidean_space\<times>real) nonzero" is
	"\<lambda>x. (x, 1)"
	by (auto simp: zero_prod_def)

	lift_definition chart_last_inv :: "'a \<Rightarrow> 'a::euclidean_space proj_space" is chart_last_inv_nonzero .

	lift_definition chart_last_domain_nonzeroP :: "('a::euclidean_space\<times>real) nonzero \<Rightarrow> bool" is
	"\<lambda>x. snd x \<noteq> 0" .

	lift_definition chart_last_domainP :: "'a::euclidean_space proj_space \<Rightarrow> bool" is chart_last_domain_nonzeroP
	unfolding rel_set_def
	by (safe elim!: proj_rel.cases; (transfer,simp))

	lemma open_chart_last_domain: "open (Collect chart_last_domainP)"
	unfolding open_proj_space_def
	unfolding openin_map_topology
	apply auto subgoal for x apply (induction x) by auto
	subgoal
	apply transfer
	apply transfer
	unfolding Collect_conj_eq
	apply (rule open_Int)
	by (auto intro!: open_Collect_neq continuous_on_snd)
	done

	lemma Proj_vimage_chart_last_domainP: "Proj -` Collect chart_last_domainP = Collect (chart_last_domain_nonzeroP)"
	apply safe
	subgoal by transfer'
	subgoal for x
	by auto transfer
	done

	lemma chart_last_continuous:
	notes [transfer_rule] = open_nonzero_openin_transfer
	shows "continuous_on (Collect chart_last_domainP) chart_last"
	apply (rule continuous_on_proj_spaceI)
	unfolding o_def chart_last.abs_eq Proj_vimage_chart_last_domainP
	apply transfer
	subgoal by (auto intro!: continuous_intros simp: split_beta)
	subgoal by (rule open_chart_last_domain)
	done

	lemma chart_last_inv_continuous:
	notes [transfer_rule] = open_nonzero_openin_transfer
	shows "continuous_on UNIV chart_last_inv"
	unfolding chart_last_inv_def map_fun_def comp_id
	apply (rule continuous_on_compose)
	subgoal by transfer (auto intro!: continuous_intros)
	subgoal
	by (metis continuous_on_open_vimage continuous_on_subset inf_top.right_neutral open_UNIV open_vimage_Proj_iff top_greatest)
	done

	lemma proj_rel_iff: "proj_rel a b \<longleftrightarrow> (\<exists>c\<noteq>0. b = c *\<^sub>R a)"
	by (auto elim!: proj_rel.cases intro!: proj_rel.intros)

	lemma chart_last_inverse: "chart_last_inv (chart_last x) = x" if "chart_last_domainP x"
	using that
	apply -
	apply transfer
	unfolding proj_rel_iff
	apply transfer
	apply (simp add: split_beta prod_eq_iff)
	subgoal for x
	by (rule exI[where x="snd x"]) auto
	done

	lemma chart_last_inv_inverse: "chart_last (chart_last_inv x) = x"
	apply transfer
	apply transfer
	by auto

	lemma chart_last_domainP_chart_last_inv: "chart_last_domainP (chart_last_inv x)"
	apply transfer apply transfer by auto

	lemma homeomorphism_chart_last:
	"homeomorphism (Collect chart_last_domainP) UNIV chart_last chart_last_inv"
	apply (auto simp: homeomorphism_def chart_last_inverse chart_last_inv_inverse
	chart_last_continuous chart_last_inv_continuous)
	subgoal
	apply transfer apply transfer apply (auto simp: split_beta')
	subgoal for x by (rule image_eqI[where x="(x, 1)"]) (auto simp: prod_eq_iff)
	done
	subgoal
	apply transfer apply transfer by (auto simp: split_beta')
	subgoal for x
	by (rule image_eqI[where x="chart_last x"]) (auto simp: chart_last_inverse)
	done

	lift_definition last_chart::"('a::euclidean_space proj_space, 'a) chart" is
	"(Collect chart_last_domainP, UNIV, chart_last, chart_last_inv)"
	using homeomorphism_chart_last open_chart_last_domain by auto


	subsubsection \<open>Charts for first \<open>DIM('a)\<close> coordinates\<close>

	lift_definition chart_basis_nonzero :: "'a \<Rightarrow> ('a::euclidean_space\<times>real)nonzero \<Rightarrow> 'a" is
	"\<lambda>b. \<lambda>(x,c). (x + (c - x \<bullet> b) *\<^sub>R b) /\<^sub>R (x \<bullet> b)" .

	lift_definition chart_basis :: "'a \<Rightarrow> 'a::euclidean_space proj_space \<Rightarrow> 'a" is
	chart_basis_nonzero
	apply (erule proj_rel.cases)
	apply transfer
	by (auto simp add: divide_simps algebra_simps)

	lift_definition chart_basis_domain_nonzeroP :: "'a \<Rightarrow> ('a::euclidean_space\<times>real) nonzero \<Rightarrow> bool" is
	"\<lambda>b (x, _). (x \<bullet> b) \<noteq> 0" .

	lift_definition chart_basis_domainP :: "'a \<Rightarrow> 'a::euclidean_space proj_space \<Rightarrow> bool" is chart_basis_domain_nonzeroP
	unfolding rel_set_def
	apply (safe elim!: proj_rel.cases)
	subgoal by transfer auto
	subgoal by transfer auto
	done

	lemma Proj_vimage_chart_basis_domainP:
	"Proj -` Collect (chart_basis_domainP b) = Collect (chart_basis_domain_nonzeroP b)"
	apply safe
	subgoal by transfer'
	subgoal for x
	by auto transfer
	done


	lemma open_chart_basis_domain: "open (Collect (chart_basis_domainP b))"
	unfolding open_proj_space_def
	unfolding openin_map_topology
	apply auto subgoal for x apply (induction x) by auto
	subgoal
	apply transfer
	apply transfer
	unfolding Collect_conj_eq
	apply (rule open_Int)
	apply (auto intro!: open_Collect_neq continuous_on_fst continuous_on_inner simp: split_beta)
	done
	done

	lemma chart_basis_continuous:
	notes [transfer_rule] = open_nonzero_openin_transfer
	shows "continuous_on (Collect (chart_basis_domainP b)) (chart_basis b)"
	apply (rule continuous_on_proj_spaceI)
	unfolding o_def chart_basis.abs_eq Proj_vimage_chart_basis_domainP
	apply transfer
	subgoal by (auto intro!: continuous_intros simp: split_beta)
	subgoal by (rule open_chart_basis_domain)
	done


	context
	fixes b::"'a::euclidean_space"
	assumes b: "b \<in> Basis"
	begin

	lemma b_neq0: "b \<noteq> 0" using b by auto

	lift_definition chart_basis_inv_nonzero :: "'a \<Rightarrow> ('a::euclidean_space \<times> real) nonzero" is
	"\<lambda>x. (x + (1 - x \<bullet> b) *\<^sub>R b, x \<bullet> b)"
	apply (auto simp: zero_prod_def)
	using b_neq0 using eq_neg_iff_add_eq_0 by force

	lift_definition chart_basis_inv :: "'a \<Rightarrow> 'a::euclidean_space proj_space" is
	chart_basis_inv_nonzero .

	lemma chart_basis_inv_continuous:
	notes [transfer_rule] = open_nonzero_openin_transfer
	shows "continuous_on UNIV chart_basis_inv"
	unfolding chart_basis_inv_def map_fun_def comp_id
	apply (rule continuous_on_compose)
	subgoal by transfer (auto intro!: continuous_intros)
	subgoal
	unfolding continuous_map_iff_continuous euclidean_proj_space_def
	using continuous_on_open_invariant open_vimage_Proj_iff by blast
	done

	lemma chart_basis_inv_inverse: "chart_basis b (chart_basis_inv x) = x"
	apply transfer
	apply transfer
	using b_neq0 b
	by (auto simp: algebra_simps divide_simps)

	lemma chart_basis_inverse: "chart_basis_inv (chart_basis b x) = x" if "chart_basis_domainP b x"
	using that
	apply transfer
	unfolding proj_rel_iff
	apply transfer
	apply (simp add: split_beta prod_eq_iff)
	subgoal for x
	apply (rule exI[where x="fst x \<bullet> b"])
	using b
	by (simp add: algebra_simps)
	done

	lemma chart_basis_domainP_chart_basis_inv: "chart_basis_domainP b (chart_basis_inv x)"
	apply transfer apply transfer by (use b in \<open>auto simp: algebra_simps\<close>)

	lemma homeomorphism_chart_basis:
	"homeomorphism (Collect (chart_basis_domainP b)) UNIV (chart_basis b) chart_basis_inv"
	apply (auto simp: homeomorphism_def chart_basis_inverse chart_basis_inv_inverse
	chart_basis_continuous chart_basis_inv_continuous)
	subgoal
	apply transfer apply transfer apply (auto simp: split_beta')
	subgoal for x
	apply (rule image_eqI[where x="(x + (1 - (x \<bullet> b)) *\<^sub>R b, x \<bullet> b)"])
	using b
	apply (auto simp add: algebra_simps divide_simps prod_eq_iff)
	by (metis add.right_neutral b_neq0 inner_commute inner_eq_zero_iff inner_right_distrib inner_zero_right)
	done
	subgoal
	apply transfer apply transfer using b by (auto simp: split_beta' algebra_simps)
	subgoal for x
	by (rule image_eqI[where x="chart_basis b x"]) (auto simp: chart_basis_inverse)
	done

	lift_definition basis_chart::"('a proj_space, 'a) chart"
	is "(Collect (chart_basis_domainP b), UNIV, chart_basis b, chart_basis_inv)"
	using homeomorphism_chart_basis by (auto simp: open_chart_basis_domain)

	end

	subsubsection \<open>Atlas\<close>

	definition "charts_proj_space = insert last_chart (basis_chart ` Basis)"

	lemma chart_last_basis_defined:
	"chart_last_domainP xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_last xa \<bullet> b \<noteq> 0"
	apply transfer apply transfer by (auto simp: prod_eq_iff)

	lemma chart_basis_last_defined:
	"b \<in> Basis \<Longrightarrow> chart_last_domainP xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_basis b xa \<bullet> b \<noteq> 0"
	apply transfer apply transfer
	by (auto simp: prod_eq_iff algebra_simps)

	lemma compat_last_chart: "\<infinity>-smooth_compat last_chart (basis_chart b)"
	if [transfer_rule]: "b \<in> Basis"
	unfolding smooth_compat_def
	proof (transfer; auto)
	have "smooth_on {x. x \<bullet> b \<noteq> 0} (chart_basis b \<circ> chart_last_inv)"
	apply transfer
	apply transfer
	by (auto simp: o_def intro!: smooth_on_inverse smooth_on_scaleR smooth_on_inner smooth_on_add
	smooth_on_minus open_Collect_neq continuous_intros)
	then show "smooth_on (chart_last ` (Collect chart_last_domainP \<inter> Collect (chart_basis_domainP b))) (chart_basis b \<circ> chart_last_inv)"
	by (rule smooth_on_subset) (auto simp: chart_last_basis_defined)
	next
	have "smooth_on {x. x \<bullet> b \<noteq> 0} (chart_last \<circ> chart_basis_inv b)"
	apply transfer
	apply transfer
	by (auto simp: o_def intro!: smooth_on_add smooth_on_scaleR smooth_on_minus smooth_on_inverse
	smooth_on_inner open_Collect_neq continuous_intros)
	then show "smooth_on (chart_basis b ` (Collect chart_last_domainP \<inter> Collect (chart_basis_domainP b))) (chart_last \<circ> chart_basis_inv b)"
	by (rule smooth_on_subset) (auto simp: chart_basis_last_defined that)
	qed

	lemma smooth_on_basis_comp_inv: "smooth_on {x. (x + (1 - x \<bullet> a) *\<^sub>R a) \<bullet> b \<noteq> 0} (chart_basis b \<circ> chart_basis_inv a)"
	if [transfer_rule]: "a \<in> Basis" "b \<in> Basis"
	apply transfer
	apply transfer
	by (auto intro!: smooth_on_add smooth_on_scaleR smooth_on_minus smooth_on_inner smooth_on_inverse
	smooth_on_mult open_Collect_neq continuous_intros simp: o_def algebra_simps inner_Basis)

	lemma chart_basis_basis_defined:
	"a \<noteq> b \<Longrightarrow> chart_basis_domainP a xa \<Longrightarrow> chart_basis_domainP b xa \<Longrightarrow> chart_basis a xa \<bullet> b \<noteq> 0"
	if "a \<in> Basis" "b \<in> Basis"
	using that
	apply transfer
	apply transfer
	by (auto simp: algebra_simps inner_Basis prod_eq_iff)

	lemma compat_basis_chart: "\<infinity>-smooth_compat (basis_chart a) (basis_chart b)"
	if [transfer_rule]: "a \<in> Basis" "b \<in> Basis"
	apply (cases "a = b")
	subgoal by (auto simp: smooth_compat_refl)
	subgoal
	unfolding smooth_compat_def
	apply (transfer; auto)
	subgoal
	using smooth_on_basis_comp_inv[OF that]
	apply (rule smooth_on_subset)
	by (auto simp: algebra_simps inner_Basis chart_basis_basis_defined that)
	subgoal
	using smooth_on_basis_comp_inv[OF that(2,1)]
	apply (rule smooth_on_subset)
	by (auto simp: algebra_simps inner_Basis chart_basis_basis_defined that)
	done
	done

	lemma c_manifold_proj_space: "c_manifold charts_proj_space \<infinity>"
	by standard
	(auto simp: charts_proj_space_def smooth_compat_refl smooth_compat_commute compat_last_chart
	compat_basis_chart)


	end
	diff --git a/thys/Smooth_Manifolds/Tangent_Space.thy b/thys/Smooth_Manifolds/Tangent_Space.thy
	--- a/thys/Smooth_Manifolds/Tangent_Space.thy
	+++ b/thys/Smooth_Manifolds/Tangent_Space.thy
	@@ -1,1421 +1,1421 @@
	section\<open>Tangent Space\<close>
	theory Tangent_Space
	imports Partition_Of_Unity
	begin

	lemma linear_imp_linear_on: "linear_on A B scaleR scaleR f" if "linear f"
	"subspace A" "subspace B"
	proof -
	interpret linear f by fact
	show ?thesis using that
	by unfold_locales (auto simp: add scaleR algebra_simps subspace_def)
	qed

	lemma (in vector_space_pair_on)
	linear_sum':
	"\<forall>x. x \<in> S1 \<longrightarrow> f x \<in> S2 \<Longrightarrow>
	\<forall>x. x \<in> S \<longrightarrow> g x \<in> S1 \<Longrightarrow>
	linear_on S1 S2 scale1 scale2 f \<Longrightarrow>
	f (sum g S) = (\<Sum>a\<in>S. f (g a))"
	using linear_sum[of f "\<lambda>x. if x \<in> S then g x else 0" S]
	by (auto simp: if_distrib if_distribR m1.mem_zero cong: if_cong)


	subsection \<open>Real vector (sub)spaces\<close>

	locale real_vector_space_on = fixes S assumes subspace: "subspace S"
	begin

	sublocale vector_space_on S scaleR
	rewrites span_eq_real: "local.span = real_vector.span"
	and dependent_eq_real: "local.dependent = real_vector.dependent"
	and subspace_eq_real: "local.subspace = real_vector.subspace"
	proof -
	show "vector_space_on S (*\<^sub>R)"
	by unfold_locales (use subspace[unfolded subspace_def] in \<open>auto simp: algebra_simps\<close>)
	then interpret subspace: vector_space_on S scaleR .
	show 1: "subspace.span = span"
	unfolding subspace.span_on_def span_explicit by auto
	show 2: "subspace.dependent = dependent"
	unfolding subspace.dependent_on_def dependent_explicit by auto
	show 3: "subspace.subspace = subspace"
	unfolding subspace.subspace_on_def subspace_def by auto
	qed

	lemma dim_eq: "local.dim X = real_vector.dim X" if "X \<subseteq> S"
	proof -
	have *: "b \<subseteq> S \<and> independent b \<and> span b = span X \<longleftrightarrow> independent b \<and> span b = span X"
	for b
	using that
	by auto (metis local.subspace_UNIV real_vector.span_base real_vector.span_eq_iff real_vector.span_mono subsetCE)
	show ?thesis
	using that
	unfolding local.dim_def real_vector.dim_def *
	by auto
	qed

	end

	locale real_vector_space_pair_on = vs1: real_vector_space_on S + vs2: real_vector_space_on T for S T
	begin

	sublocale vector_space_pair_on S T scaleR scaleR
	rewrites span_eq_real1: "module_on.span scaleR = vs1.span"
	and dependent_eq_real1: "module_on.dependent scaleR = vs1.dependent"
	and subspace_eq_real1: "module_on.subspace scaleR = vs1.subspace"
	and span_eq_real2: "module_on.span scaleR = vs2.span"
	and dependent_eq_real2: "module_on.dependent scaleR = vs2.dependent"
	and subspace_eq_real2: "module_on.subspace scaleR = vs2.subspace"
	by unfold_locales (simp_all add: vs1.span_eq_real vs1.dependent_eq_real vs1.subspace_eq_real
	vs2.span_eq_real vs2.dependent_eq_real vs2.subspace_eq_real)

	end

	locale finite_dimensional_real_vector_space_on = real_vector_space_on S for S +
	fixes basis :: "'a set"
	assumes finite_dimensional_basis: "finite basis" "\<not> dependent basis" "span basis = S" "basis \<subseteq> S"
	begin

	sublocale finite_dimensional_vector_space_on S scaleR basis
	rewrites span_eq_real: "local.span = real_vector.span"
	and dependent_eq_real: "local.dependent = real_vector.dependent"
	and subspace_eq_real: "local.subspace = real_vector.subspace"
	by unfold_locales (simp_all add: finite_dimensional_basis dependent_eq_real span_eq_real)

	end

	locale finite_dimensional_real_vector_space_pair_1_on =
	vs1: finite_dimensional_real_vector_space_on S1 basis +
	vs2: real_vector_space_on S2
	for S1 S2 basis
	begin

	sublocale finite_dimensional_vector_space_pair_1_on S1 S2 scaleR scaleR basis
	rewrites span_eq_real1: "module_on.span scaleR = vs1.span"
	and dependent_eq_real1: "module_on.dependent scaleR = vs1.dependent"
	and subspace_eq_real1: "module_on.subspace scaleR = vs1.subspace"
	and span_eq_real2: "module_on.span scaleR = vs2.span"
	and dependent_eq_real2: "module_on.dependent scaleR = vs2.dependent"
	and subspace_eq_real2: "module_on.subspace scaleR = vs2.subspace"
	apply unfold_locales
	subgoal using real_vector_space_on.span_eq_real vs1.real_vector_space_on_axioms by blast
	subgoal using real_vector_space_on.dependent_eq_real vs1.real_vector_space_on_axioms by blast
	subgoal using real_vector_space_on.subspace_eq_real vs1.real_vector_space_on_axioms by blast
	subgoal using real_vector_space_on.span_eq_real vs2.real_vector_space_on_axioms by blast
	subgoal using real_vector_space_on.dependent_eq_real vs2.real_vector_space_on_axioms by blast
	subgoal using real_vector_space_on.subspace_eq_real vs2.real_vector_space_on_axioms by blast
	done

	end

	locale finite_dimensional_real_vector_space_pair_on =
	vs1: finite_dimensional_real_vector_space_on S1 Basis1 +
	vs2: finite_dimensional_real_vector_space_on S2 Basis2
	for S1 S2 Basis1 Basis2
	begin

	sublocale finite_dimensional_real_vector_space_pair_1_on S1 S2 Basis1
	by unfold_locales

	sublocale finite_dimensional_vector_space_pair_on S1 S2 scaleR scaleR Basis1 Basis2
	rewrites "module_on.span scaleR = vs1.span"
	and "module_on.dependent scaleR = vs1.dependent"
	and "module_on.subspace scaleR = vs1.subspace"
	and "module_on.span scaleR = vs2.span"
	and "module_on.dependent scaleR = vs2.dependent"
	and "module_on.subspace scaleR = vs2.subspace"
	apply unfold_locales
	subgoal by (simp add: span_eq_real1)
	subgoal by (simp add: dependent_eq_real1)
	subgoal by (simp add: subspace_eq_real1)
	subgoal by (simp add: span_eq_real2)
	subgoal by (simp add: dependent_eq_real2)
	subgoal by (simp add: subspace_eq_real2)
	done

	end


	subsection \<open>Derivations\<close>

	context c_manifold begin

	text \<open>Set of \<open>C^k\<close> differentiable functions on carrier, where the smooth structure
	is given by charts. We assume \<open>f\<close> is zero outside carrier\<close>
	definition diff_fun_space :: "('a \<Rightarrow> real) set" where
	"diff_fun_space = {f. diff_fun k charts f \<and> extensional0 carrier f}"

	lemma diff_fun_spaceD: "diff_fun k charts f" if "f \<in> diff_fun_space"
	using that by (auto simp: diff_fun_space_def)

	lemma diff_fun_space_order_le: "diff_fun_space \<subseteq> c_manifold.diff_fun_space charts l" if "l \<le> k"
	proof -
	interpret l: c_manifold charts l
	by (rule c_manifold_order_le) fact
	show ?thesis
	unfolding diff_fun_space_def l.diff_fun_space_def
	using diff_fun.diff_fun_order_le[OF _ that]
	by auto
	qed

	lemma diff_fun_space_extensionalD:
	"g \<in> diff_fun_space \<Longrightarrow> extensional0 carrier g"
	by (auto simp: diff_fun_space_def)

	lemma diff_fun_space_eq: "diff_fun_space = {f. diff_fun k charts f} \<inter> {f. extensional0 carrier f}"
	by (auto simp: diff_fun_space_def)

	lemma subspace_diff_fun_space[intro, simp]:
	"subspace diff_fun_space"
	unfolding diff_fun_space_eq
	by (intro subspace_inter subspace_Collect_diff_fun subspace_extensional0)

	lemma diff_fun_space_times: "f * g \<in> diff_fun_space"
	if "f \<in> diff_fun_space" "g \<in> diff_fun_space"
	using that by (auto simp: diff_fun_space_def intro!: diff_fun_times)

	lemma diff_fun_space_add: "f + g \<in> diff_fun_space"
	if "f \<in> diff_fun_space" "g \<in> diff_fun_space"
	using that by (auto simp: diff_fun_space_def intro!: diff_fun_add)

	text \<open>Set of differentiable functions is a vector space\<close>
	sublocale diff_fun_space: vector_space_pair_on diff_fun_space "UNIV::real set" scaleR scaleR
	by unfold_locales
	(use subspace_diff_fun_space[unfolded subspace_def] in
	\<open>auto simp: diff_fun_space_add algebra_simps scaleR_fun_def\<close>)

	text \<open>Linear functional from differentiable functions to real numbers\<close>
	abbreviation "linear_diff_fun \<equiv> linear_on diff_fun_space (UNIV::real set) scaleR scaleR"

	text \<open>
	Definition of a derivation.

	A linear functional \<open>X\<close> is a derivation if it additionally satisfies the property
	\<open>X (f * g) = f p * X g + g p * X f\<close>. This is suppose to represent the product rule.
	\<close>
	definition is_derivation :: "(('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> bool" where
	"is_derivation X p \<longleftrightarrow> (linear_diff_fun X \<and>
	(\<forall>f g. f \<in> diff_fun_space \<longrightarrow> g \<in> diff_fun_space \<longrightarrow> X (f * g) = f p * X g + g p * X f))"

	lemma is_derivationI:
	"is_derivation X p"
	if "linear_diff_fun X"
	"\<And>f g. f \<in> diff_fun_space \<Longrightarrow> g \<in> diff_fun_space \<Longrightarrow> X (f * g) = f p * X g + g p * X f"
	using that
	unfolding is_derivation_def
	by blast

	lemma is_derivationD:
	assumes "is_derivation X p"
	shows is_derivation_linear_on: "linear_diff_fun X"
	and is_derivation_derivation: "\<And>f g. f \<in> diff_fun_space \<Longrightarrow> g \<in> diff_fun_space \<Longrightarrow> X (f * g) = f p * X g + g p * X f"
	using assms
	unfolding is_derivation_def
	by blast+

	text \<open>Differentiable functions on the Euclidean space\<close>
	lemma manifold_eucl_diff_fun_space_iff[simp]:
	"g \<in> manifold_eucl.diff_fun_space k \<longleftrightarrow> k-smooth_on UNIV g"
	by (auto simp: manifold_eucl.diff_fun_space_def differentiable_on_def
	diff_fun_charts_euclI diff_fun_charts_euclD)


	subsection \<open>Tangent space\<close>

	text \<open>
	Definition of the tangent space.

	The tangent space at a point p is defined to be the set of derivations. Note
	we need to restrict the domain of the functional to differentiable functions.
	\<close>
	definition tangent_space :: "'a \<Rightarrow> (('a \<Rightarrow> real) \<Rightarrow> real) set" where
	"tangent_space p = {X. is_derivation X p \<and> extensional0 diff_fun_space X}"

	lemma tangent_space_eq: "tangent_space p = {X. is_derivation X p} \<inter> {X. extensional0 diff_fun_space X}"
	by (auto simp: tangent_space_def)

	lemma mem_tangent_space: "X \<in> tangent_space p \<longleftrightarrow> is_derivation X p \<and> extensional0 diff_fun_space X"
	by (auto simp: tangent_space_def)

	lemma tangent_spaceI:
	"X \<in> tangent_space p"
	if
	"extensional0 diff_fun_space X"
	"linear_diff_fun X"
	"\<And>f g. f \<in> diff_fun_space \<Longrightarrow> g \<in> diff_fun_space \<Longrightarrow> X (f * g) = f p * X g + g p * X f"
	using that
	unfolding tangent_space_def is_derivation_def
	by blast

	lemma tangent_spaceD:
	assumes "X \<in> tangent_space p"
	shows tangent_space_linear_on: "linear_diff_fun X"
	and tangent_space_restrict: "extensional0 diff_fun_space X"
	and tangent_space_derivation: "\<And>f g. f \<in> diff_fun_space \<Longrightarrow> g \<in> diff_fun_space \<Longrightarrow> X (f * g) = f p * X g + g p * X f"
	using assms
	unfolding tangent_space_def is_derivation_def
	by blast+

	lemma is_derivation_0: "is_derivation 0 p"
	by (simp add: is_derivation_def diff_fun_space.linear_zero zero_fun_def)

	lemma is_derivation_add: "is_derivation (x + y) p"
	if x: "is_derivation x p" and y: "is_derivation y p"
	apply (rule is_derivationI)
	subgoal using x y by (auto dest!: is_derivation_linear_on simp: diff_fun_space.linear_compose_add plus_fun_def)
	subgoal by (simp add: is_derivation_derivation[OF x] is_derivation_derivation[OF y] algebra_simps)
	done

	lemma is_derivation_scaleR: "is_derivation (c *\<^sub>R x) p"
	if x: "is_derivation x p"
	apply (rule is_derivationI)
	subgoal using x diff_fun_space.linear_compose_scale_right[of x c]
	by (auto dest!: is_derivation_linear_on simp:scaleR_fun_def)
	subgoal by (simp add: is_derivation_derivation[OF x] algebra_simps)
	done

	lemma subspace_is_derivation: "subspace {X. is_derivation X p}"
	by (auto simp: subspace_def is_derivation_0 is_derivation_add is_derivation_scaleR)

	lemma subspace_tangent_space: "subspace (tangent_space p)"
	unfolding tangent_space_eq
	by (simp add: subspace_inter subspace_is_derivation subspace_extensional0)

	sublocale tangent_space: real_vector_space_on "tangent_space p"
	by unfold_locales (rule subspace_tangent_space)

	lemma tangent_space_dim_eq: "tangent_space.dim p X = dim X"
	if "X \<subseteq> tangent_space p"
	proof -
	have *: "b \<subseteq> tangent_space p \<and> independent b \<and> span b = span X \<longleftrightarrow> independent b \<and> span b = span X"
	for b
	using that
	by auto (metis (no_types, lifting) c_manifold.subspace_tangent_space c_manifold_axioms span_base span_eq_iff span_mono subsetCE)
	show ?thesis
	using that
	unfolding tangent_space.dim_def dim_def *
	by auto
	qed


	text \<open>properties of derivations\<close>

	lemma restrict0_in_fun_space: "restrict0 carrier f \<in> diff_fun_space"
	if "diff_fun k charts f"
	by (auto simp: diff_fun_space_def intro!: diff_fun.diff_fun_cong[OF that])

	lemma restrict0_const_diff_fun_space: "restrict0 carrier (\<lambda>x. c) \<in> diff_fun_space"
	by (rule restrict0_in_fun_space) (rule diff_fun_const)

	lemma derivation_one_eq_zero: "X (restrict0 carrier (\<lambda>x. 1)) = 0" (is "X ?f1 = _")
	if "X \<in> tangent_space p" "p \<in> carrier"
	proof -
	have "X ?f1 = X (?f1 * ?f1)" by (simp add: restrict0_times[symmetric]) (simp add: times_fun_def)
	also have "\<dots> = 1 * X (restrict0 carrier (\<lambda>x. 1)) + 1 * X (restrict0 carrier (\<lambda>x. 1))"
	apply (subst tangent_space_derivation[OF that(1)])
	apply (rule restrict0_const_diff_fun_space)
	using that
	by simp
	finally show ?thesis
	by auto
	qed

	lemma derivation_const_eq_zero: "X (restrict0 carrier (\<lambda>x. c)) = 0"
	if "X \<in> tangent_space p" "p \<in> carrier"
	proof -
	note scaleR = diff_fun_space.linear_scale[OF _ _ tangent_space_linear_on[OF that(1)]]
	have "X (c \<^sub>R (restrict0 carrier (\<lambda>x. 1))) = c \<^sub>R X (restrict0 carrier (\<lambda>x. 1))"
	by (rule scaleR) (auto intro!: restrict0_const_diff_fun_space)
	also note derivation_one_eq_zero[OF that]
	also note restrict0_scaleR[symmetric]
	finally show ?thesis
	by (auto simp: scaleR_fun_def)
	qed

	lemma derivation_times_eq_zeroI: "X (f * g) = 0" if X:"X \<in> tangent_space p"
	and d: "f \<in> diff_fun_space" "g \<in> diff_fun_space"
	and z: "f p = 0" "g p = 0"
	using tangent_space_derivation[OF X d]
	by (simp add: z)

	lemma derivation_zero_localI: "X f = 0"
	if "open W" "p \<in> W" "W \<subseteq> carrier"
	"X \<in> tangent_space p"
	"f \<in> diff_fun_space"
	"\<And>x. x \<in> W \<Longrightarrow> f x = 0"
	proof -
	define A where "A = carrier - W"
	have clA: "closedin (top_of_set carrier) A"
	using \<open>open W\<close>
	apply (auto simp: A_def)
	using closedin_def openin_open by fastforce
	have \<open>A \<subseteq> carrier\<close> by (auto simp: A_def)
	have d1: "diff_fun_on A (\<lambda>x. 1)"
	unfolding diff_fun_on_def
	using \<open>A \<subseteq> carrier\<close>
	by (auto intro!:exI[where x=carrier] exI[where x="\<lambda>x. 1"] diff_fun_const)

	define U where "U = carrier - {p}"
	have "open U"
	by (auto simp: U_def)

	have "A \<subseteq> U" using that by (auto simp: A_def U_def)
	have "U \<subseteq> carrier" by (auto simp: U_def)

	from extension_lemmaE[of A "\<lambda>x. 1" U, OF clA d1 \<open>A \<subseteq> U\<close> \<open>U \<subseteq> carrier\<close> \<open>open U\<close>]
	obtain u::"'a\<Rightarrow>real" where u: "diff_fun k charts u" "(\<And>x. x \<in> A \<Longrightarrow> u x = 1)" "csupport_on carrier u \<inter> carrier \<subseteq> U"
	by blast

	have u_in_df: "restrict0 carrier u \<in> diff_fun_space"
	by (rule restrict0_in_fun_space) fact

	have "f p = 0"
	using that by auto
	have "p \<notin> U" by (auto simp: U_def)
	then have "restrict0 carrier u p = 0"
	using u(3)
	by (auto simp: restrict0_def) (meson IntI not_in_csupportD subsetCE)
	have "X (f * restrict0 carrier u) = 0"
	using \<open>X \<in> tangent_space p\<close> \<open>f \<in> diff_fun_space\<close> u_in_df \<open>f p = 0\<close>
	by (rule derivation_times_eq_zeroI) fact
	also have "f * restrict0 carrier u = f"
	proof (rule ext, cases)
	fix x assume "x \<in> W"
	then show "(f * restrict0 carrier u) x = f x"
	by (auto simp: that)
	next
	fix x assume "x \<notin> W"
	show "(f * restrict0 carrier u) x = f x"
	proof cases
	assume "x \<in> carrier"
	with \<open>x \<notin> W\<close> have "x \<in> A" by (auto simp: A_def)
	then show ?thesis using \<open>x \<in> carrier\<close>
	by (auto simp: u)
	next
	assume "x \<notin> carrier"
	then show ?thesis
	using \<open>f \<in> diff_fun_space\<close>
	by (auto dest!: diff_fun_space_extensionalD simp: extensional0_outside)
	qed
	qed
	finally show ?thesis .
	qed

	lemma derivation_eq_localI: "X f = X g"
	if "open U" "p \<in> U" "U \<subseteq> carrier"
	"X \<in> tangent_space p"
	"f \<in> diff_fun_space"
	"g \<in> diff_fun_space"
	"\<And>x. x \<in> U \<Longrightarrow> f x = g x"
	proof -
	note minus = diff_fun_space.linear_diff[OF _ _ _ tangent_space_linear_on[OF that(4)]]
	have "f - g \<in> diff_fun_space"
	using subspace_diff_fun_space \<open>f \<in> _\<close> \<open>g \<in> _\<close>
	by (rule subspace_diff)
	have "X f - X g = X (f - g)"
	using that
	by (simp add: minus)
	also have "\<dots> = 0"
	using \<open>open U\<close> \<open>p \<in> U\<close> \<open>U \<subseteq> _\<close> \<open>X \<in> _\<close> \<open>f - g \<in> _\<close>
	by (rule derivation_zero_localI) (simp add: that)
	finally show ?thesis by simp
	qed

	end


	subsection \<open>Push-forward on the tangent space\<close>

	context diff begin

	text \<open>
	Push-forward on tangent spaces.

	Given an element of the tangent space at src, considered as a functional \<open>X\<close>,
	the push-forward of \<open>X\<close> is a functional at dest, mapping \<open>g\<close> to \<open>X (g \<circ> f)\<close>.
	\<close>
	definition push_forward :: "(('a \<Rightarrow> real) \<Rightarrow> real) \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> real" where
	"push_forward X = restrict0 dest.diff_fun_space (\<lambda>g. X (restrict0 src.carrier (g \<circ> f)))"

	lemma extensional_push_forward: "extensional0 dest.diff_fun_space (push_forward X)"
	by (auto simp: push_forward_def)

	lemma linear_push_forward: "linear push_forward"
	by (auto simp: push_forward_def[abs_def] o_def restrict0_def intro!: linearI)

	text \<open>Properties of push-forwards\<close>

	lemma restrict_compose_in_diff_fun_space:
	"x \<in> dest.diff_fun_space \<Longrightarrow> restrict0 src.carrier (x \<circ> f) \<in> src.diff_fun_space"
	apply (rule src.restrict0_in_fun_space)
	apply (rule diff_fun_compose)
	apply (rule diff_axioms)
	apply (rule dest.diff_fun_spaceD)
	by assumption

	text \<open>Push-forward of a linear functional is a linear\<close>
	lemma linear_on_diff_fun_push_forward:
	"dest.linear_diff_fun (push_forward X)"
	if "src.linear_diff_fun X"
	proof unfold_locales
	note add = src.diff_fun_space.linear_add[OF _ _ _ that]
	note scale = src.diff_fun_space.linear_scale[OF _ _ that]
	fix x y::"'b \<Rightarrow> real" and c::real
	assume dfx: "x \<in> dest.diff_fun_space"
	then have dx: "diff_fun k charts2 x" and ex: "extensional0 dest.carrier x"
	by (auto simp: dest.diff_fun_space_def)
	show "push_forward X (c \<^sub>R x) = c \<^sub>R push_forward X x"
	unfolding push_forward_def
	using defined dfx
	by (auto simp: subspace_mul scaleR_compose restrict0_scaleR
	restrict_compose_in_diff_fun_space scale)
	assume dfy: "y \<in> dest.diff_fun_space"
	then have dy: "diff_fun k charts2 y" and ey: "extensional0 dest.carrier y"
	by (auto simp: dest.diff_fun_space_def)
	show "push_forward X (x + y) = push_forward X x + push_forward X y"
	unfolding push_forward_def
	using defined dfy dfx
	by (auto simp: subspace_add plus_compose restrict0_add restrict_compose_in_diff_fun_space add)
	qed

	text \<open>Push-forward preserves the product rule\<close>
	lemma push_forward_is_derivation:
	"push_forward X (x * y) = x (f p) * push_forward X y + y (f p) * push_forward X x"
	(is "?l = ?r")
	if deriv: "\<And>x y. x \<in> src.diff_fun_space \<Longrightarrow> y \<in> src.diff_fun_space \<Longrightarrow> X (x * y) = x p * X y + y p * X x"
	and dx: "x \<in> dest.diff_fun_space"
	and dy: "y \<in> dest.diff_fun_space"
	and p: "p \<in> src.carrier"
	proof -
	have "x * y \<in> dest.diff_fun_space"
	using dx dy
	by (auto simp: dest.diff_fun_space_def dest.diff_fun_times)
	then have "?l = X (restrict0 src.carrier (x \<circ> f) * restrict0 src.carrier (y \<circ> f))"
	by (simp add: push_forward_def mult_compose restrict0_times)
	also have "\<dots> = restrict0 src.carrier (x \<circ> f) p * X (restrict0 src.carrier (y \<circ> f)) +
	restrict0 src.carrier (y \<circ> f) p * X (restrict0 src.carrier (x \<circ> f))"
	using dx dy
	by (simp add: deriv restrict_compose_in_diff_fun_space)
	also have "\<dots> = ?r"
	using dx dy
	by (simp add: push_forward_def p)
	finally show ?thesis .
	qed

	text \<open>Combining, we show that the push-forward of a derivation is a derivation\<close>
	lemma push_forward_in_tangent_space:
	"push_forward ` (src.tangent_space p) \<subseteq> dest.tangent_space (f p)"
	if "p \<in> src.carrier"
	unfolding src.is_derivation_def dest.is_derivation_def src.tangent_space_def dest.tangent_space_def
	apply safe
	subgoal
	by (rule linear_on_diff_fun_push_forward)
	subgoal by (blast intro: dest.diff_fun_spaceD that push_forward_is_derivation)
	subgoal by (simp add: push_forward_def)
	done

	end

	text \<open>Functoriality of push-forward: identity\<close>

	context c_manifold begin

	lemma push_forward_id:
	"diff.push_forward k charts charts f X = X"
	if "\<And>x. x \<in> carrier \<Longrightarrow> f x = x"
	"X \<in> tangent_space p" "p \<in> carrier"
	apply (subst diff.push_forward_def)
	apply (rule diff.diff_cong[where f="\<lambda>x. x"])
	apply (rule diff_id)
	apply (rule that(1)[symmetric], assumption)
	apply (rule ext_extensional0)
	apply (rule extensional0_restrict0)
	apply (rule tangent_space_restrict)
	apply (rule that)
	- apply (auto simp: )
	+ apply auto
	apply (rule arg_cong[where f=X])
	apply (rule ext_extensional0)
	apply (rule extensional0_restrict0)
	apply (rule diff_fun_space_extensionalD, assumption)
	apply (simp add: that)
	done

	end

	text \<open>Functoriality of push-forward: composition\<close>

	lemma push_forward_compose:
	"diff.push_forward k M2 M3 g (diff.push_forward k M1 M2 f X) = diff.push_forward k M1 M3 (g o f) X"
	if "X \<in> c_manifold.tangent_space M1 k p" "p \<in> manifold.carrier M1"
	and df: "diff k M1 M2 f" and dg: "diff k M2 M3 g"
	proof -
	interpret d12: diff k M1 M2 f by fact
	interpret d23: diff k M2 M3 g by fact
	interpret d13: diff k M1 M3 "g o f"
	by (rule diff_compose; fact)
	show ?thesis
	apply (rule ext_extensional0)
	apply (rule d23.extensional_push_forward)
	apply (rule d13.extensional_push_forward)
	proof -
	fix x
	assume x: "x \<in> d23.dest.diff_fun_space"
	show "d23.push_forward (d12.push_forward X) x = d13.push_forward X x"
	using x
	unfolding d12.push_forward_def d23.push_forward_def d13.push_forward_def
	apply (simp add: d23.restrict_compose_in_diff_fun_space)
	apply (rule arg_cong[where f=X])
	apply (rule ext_extensional0[OF extensional0_restrict0])
	apply (rule d12.src.diff_fun_space_extensionalD)
	apply (rule d13.restrict_compose_in_diff_fun_space, assumption)
	using d12.defined
	by auto
	qed
	qed

	context diffeomorphism begin

	text \<open>If f is a diffeomorphism, then the push-forward \<open>f*\<close> is a bijection\<close>

	lemma inv_push_forward_inverse: "push_forward (inv.push_forward X) = X"
	if "X \<in> dest.tangent_space p" "p \<in> dest.carrier"
	apply (subst push_forward_compose[OF that inv.diff_axioms diff_axioms])
	apply (rule dest.push_forward_id[OF _ that])
	by auto

	lemma push_forward_inverse: "inv.push_forward (push_forward X) = X"
	if "X \<in> src.tangent_space p" "p \<in> src.carrier"
	apply (subst push_forward_compose[OF that diff_axioms inv.diff_axioms])
	apply (rule src.push_forward_id[OF _ that])
	by auto

	lemma bij_betw_push_forward:
	"bij_betw push_forward (src.tangent_space p) (dest.tangent_space (f p))"
	if p: "p \<in> src.carrier"
	proof (rule bij_betwI[where g="inv.push_forward"])
	show "push_forward \<in> src.tangent_space p \<rightarrow> dest.tangent_space (f p)"
	using push_forward_in_tangent_space[OF p] by auto
	show "inv.push_forward \<in> dest.tangent_space (f p) \<rightarrow> src.tangent_space p"
	using inv.push_forward_in_tangent_space[of "f p"] that defined by auto
	show "inv.push_forward (push_forward x) = x" if "x \<in> src.tangent_space p" for x
	by (rule push_forward_inverse[OF that p])
	show "push_forward (inv.push_forward y) = y" if "y \<in> dest.tangent_space (f p)" for y
	apply (rule inv_push_forward_inverse[OF that])
	using defined p by auto
	qed

	lemma dim_tangent_space_src_dest_eq: "dim (src.tangent_space p) = dim (dest.tangent_space (f p))"
	if p: "p \<in> src.carrier" and "dim (dest.tangent_space (f p)) > 0"
	proof -
	from dest.tangent_space.dim_pos_finite_dimensional_vector_spaceE[
	unfolded dest.tangent_space_dim_eq[OF order_refl],
	OF that(2)]
	obtain basis where "basis \<subseteq> dest.tangent_space (f p)"
	"finite_dimensional_vector_space_on_with (dest.tangent_space (f p)) (+) (-) uminus 0 (*\<^sub>R) basis"
	by auto
	then interpret finite_dimensional_vector_space_on "(dest.tangent_space (f p))" scaleR basis
	unfolding finite_dimensional_vector_space_on_with_def
	by unfold_locales
	(auto simp: implicit_ab_group_add dest.tangent_space.dependent_eq_real dest.tangent_space.span_eq_real)
	interpret rev: finite_dimensional_vector_space_pair_1_on
	"dest.tangent_space (f p)" "src.tangent_space p" scaleR scaleR basis
	by unfold_locales
	from bij_betw_push_forward[OF p]
	have "inj_on push_forward (src.tangent_space p)"
	"dest.tangent_space (f p) = push_forward ` src.tangent_space p"
	unfolding bij_betw_def by auto
	have "dim (dest.tangent_space (f p)) = src.tangent_space.dim p (inv.push_forward ` dest.tangent_space (f p))"
	apply (rule rev.dim_image_eq[OF _ order_refl, of inv.push_forward, symmetric,
	unfolded dest.tangent_space_dim_eq[OF order_refl]])
	subgoal
	by (metis (no_types) contra_subsetD defined f_inv image_eqI inv.push_forward_in_tangent_space p)
	subgoal
	apply (rule linear_imp_linear_on)
	apply (rule inv.linear_push_forward)
	apply (rule dest.subspace_tangent_space)
	apply (rule src.subspace_tangent_space)
	done
	subgoal
	unfolding inj_on_def dest.tangent_space.span_eq_real
	apply auto
	proof -
	fix x :: "('c \<Rightarrow> real) \<Rightarrow> real" and y :: "('c \<Rightarrow> real) \<Rightarrow> real"
	assume a1: "y \<in> span (dest.tangent_space (f p))"
	assume a2: "x \<in> span (dest.tangent_space (f p))"
	assume a3: "inv.push_forward x = inv.push_forward y"
	have "f p \<in> dest.carrier"
	by (meson contra_subsetD defined image_eqI p)
	then show "x = y"
	using a3 a2 a1 by (metis (no_types) c_manifold.subspace_tangent_space c_manifolds_axioms c_manifolds_def inv_push_forward_inverse span_eq_iff)
	qed
	done
	also
	have "f p \<in> dest.carrier"
	using defined p by auto
	then have "inv.push_forward ` dest.tangent_space (f p) = src.tangent_space p"
	using inv.push_forward_in_tangent_space[of "f p"] that(1)
	apply auto
	subgoal for x
	apply (rule image_eqI[where x="push_forward x"])
	apply (auto simp: push_forward_inverse)
	using \<open>dest.tangent_space (f p) = push_forward ` src.tangent_space p\<close> by blast
	done
	also have "src.tangent_space.dim p \<dots> = dim \<dots>"
	by (rule src.tangent_space_dim_eq) simp
	finally show ?thesis ..
	qed

	lemma dim_tangent_space_src_dest_eq2: "dim (src.tangent_space p) = dim (dest.tangent_space (f p))"
	if p: "p \<in> src.carrier" and "dim (src.tangent_space p) > 0"
	proof -
	interpret rev: diffeomorphism k charts2 charts1 f' f
	- by unfold_locales (auto simp: )
	+ by unfold_locales auto
	from that rev.dim_tangent_space_src_dest_eq[of "f p"]
	show ?thesis
	by auto (metis contra_subsetD defined image_eqI)
	qed

	end

	subsection \<open>Smooth inclusion map\<close>

	context submanifold begin

	lemma diff_inclusion: "diff k (charts_submanifold S) charts (\<lambda>x. x)"
	using diff_id
	apply (rule diff.diff_submanifold)
	unfolding charts_submanifold_def using open_submanifold
	by auto

	sublocale inclusion: diff k "charts_submanifold S" charts "\<lambda>x. x"
	by (rule diff_inclusion)

	lemma linear_on_push_forward_inclusion:
	"linear_on (sub.tangent_space p) (tangent_space p) scaleR scaleR inclusion.push_forward"
	apply (rule linear_imp_linear_on)
	apply (rule inclusion.linear_push_forward)
	apply (rule sub.subspace_tangent_space)
	apply (rule subspace_tangent_space)
	done

	text \<open>Extension lemma: given a differentiable function on \<open>S\<close>, and a closed set \<open>B \<subseteq> S\<close>,
	there exists a function \<open>f'\<close> agreeing with \<open>f\<close> on \<open>B\<close>, such that the support
	of \<open>f'\<close> is contained in \<open>S.\<close>\<close>
	lemma extension_lemma_submanifoldE:
	fixes f::"'a\<Rightarrow>'e::euclidean_space"
	assumes f: "diff_fun k (charts_submanifold S) f"
	and B: "closed B" "B \<subseteq> sub.carrier"
	obtains f' where
	"diff_fun k charts f'"
	"(\<And>x. x \<in> B \<Longrightarrow> f' x = f x)"
	"csupport_on carrier f' \<inter> carrier \<subseteq> sub.carrier"
	proof -
	have 1: "closedin (top_of_set carrier) B"
	using B by (auto intro!: closed_subset)
	have 2: "diff_fun_on B f"
	proof (rule diff_fun_onI)
	show "B \<subseteq> sub.carrier" by fact
	show "sub.carrier \<subseteq> carrier" by auto
	show "open sub.carrier" using open_submanifold by auto
	have *: "charts_submanifold sub.carrier = charts_submanifold S"
	unfolding carrier_submanifold charts_submanifold_Int_carrier ..
	from f show "diff_fun k (charts_submanifold sub.carrier) f" unfolding * .
	qed simp
	from extension_lemmaE[OF 1 2 \<open>B \<subseteq> sub.carrier\<close>] open_submanifold
	obtain f' where f': "diff_fun k charts f'" "(\<And>x. x \<in> B \<Longrightarrow> f' x = f x)"
	"csupport_on carrier f' \<inter> carrier \<subseteq> sub.carrier"
	by auto
	then show ?thesis ..
	qed

	lemma inj_on_push_forward_inclusion: "inj_on inclusion.push_forward (sub.tangent_space p)"
	if p: "p \<in> sub.carrier"
	proof -
	interpret sub: vector_space_pair_on "sub.tangent_space p" "tangent_space p" scaleR scaleR
	by unfold_locales
	show ?thesis
	proof (subst sub.linear_inj_iff_eq_0[OF _ linear_on_push_forward_inclusion], safe)
	fix v assume v: "v \<in> sub.tangent_space p"
	then show "inclusion.push_forward v \<in> tangent_space p"
	using inclusion.push_forward_in_tangent_space[OF p]
	by auto
	assume dv: "inclusion.push_forward v = 0"
	have "extensional0 sub.diff_fun_space v" using v[THEN sub.tangent_space_restrict] .
	then show "v = 0"
	proof (rule ext_extensional0)
	show "extensional0 sub.diff_fun_space (0:: ('a \<Rightarrow> real) \<Rightarrow> real)"
	by auto
	fix f assume f: "f \<in> sub.diff_fun_space"
	from sub.precompact_neighborhoodE[OF p]
	obtain B where B: "p \<in> B" "open B" "compact (closure B)" "closure B \<subseteq> sub.carrier" .
	with extension_lemma_submanifoldE[of f "closure B", OF sub.diff_fun_spaceD[OF f]]
	obtain f' where f': "diff_fun k charts f'"
	"(\<And>x. x \<in> closure B \<Longrightarrow> f' x = f x)"
	"csupport_on carrier f' \<inter> carrier \<subseteq> sub.carrier" by blast
	have rf': "restrict0 sub.carrier f' \<in> sub.diff_fun_space"
	apply (rule sub.restrict0_in_fun_space)
	apply (rule diff_fun.diff_fun_submanifold)
	apply (rule f')
	apply (rule open_submanifold)
	done
	have supp_f': "support_on carrier f' \<inter> carrier \<subseteq> sub.carrier"
	using f'(3)
	by (auto simp: csupport_on_def)
	from f'(1)
	have df': "diff_fun k charts (restrict0 sub.carrier f')"
	apply (rule diff_fun.diff_fun_cong)
	using supp_f'
	by (auto simp: restrict0_def support_on_def)
	have rf'_diff_fun: "restrict0 sub.carrier f' \<in> diff_fun_space"
	using f' df'
	by (auto simp: diff_fun_space_def extensional0_def)
	have "v f = v (restrict0 sub.carrier f')"
	apply (rule sub.derivation_eq_localI[where X=v and U="B" and p=p])
	subgoal by (rule B)
	subgoal by (rule B)
	subgoal using B by auto
	subgoal by (rule v)
	subgoal by (rule f)
	subgoal by (rule rf')
	subgoal using f' B
	by (auto simp: restrict0_def)
	done
	also have "\<dots> = inclusion.push_forward v (restrict0 sub.carrier f')"
	using rf' rf'_diff_fun
	by (auto simp: inclusion.push_forward_def o_def restrict0_restrict0)
	also have "\<dots> = 0"
	by (simp add: dv)
	finally show "v f = 0 f" by auto
	qed
	qed
	qed

	lemma surj_on_push_forward_inclusion:
	"inclusion.push_forward ` sub.tangent_space p \<supseteq> tangent_space p"
	if p: "p \<in> sub.carrier"
	proof safe
	fix w
	assume w: "w \<in> tangent_space p"

	from sub.precompact_neighborhoodE[OF p]
	obtain B where B: "p \<in> B" "open B" "compact (closure B)" "closure B \<subseteq> sub.carrier" .
	have w_eqI: "w a = w b" if "a \<in> diff_fun_space" "b \<in> diff_fun_space" and "\<And>x. x \<in> B \<Longrightarrow> a x = b x" for a b
	apply (rule derivation_eq_localI[where X=w and U=B and p=p])
	using w B that by auto
	from tangent_space_linear_on[OF w]
	have linear_w: "linear_on diff_fun_space UNIV (\<^sub>R) (\<^sub>R) w" .
	note w_add = diff_fun_space.linear_add[OF _ _ _ linear_w]
	note w_scale = diff_fun_space.linear_scale[OF _ _ linear_w]
	note subspaceI = sub.subspace_diff_fun_space[THEN subspace_add]
	sub.subspace_diff_fun_space[THEN subspace_mul]
	subspace_diff_fun_space[THEN subspace_add]
	subspace_diff_fun_space[THEN subspace_mul]

	let ?P = "\<lambda>f f'. f' \<in> diff_fun_space \<and> (\<forall>x\<in>closure B. f x = f' x)"
	define extend where "extend f = (SOME f'. ?P f f')" for f
	have ex: "\<exists>f'. ?P f f'" if "f \<in> sub.diff_fun_space" for f
	proof -
	from that have "diff_fun k (charts_submanifold S) f"
	by (rule sub.diff_fun_spaceD)
	from extension_lemma_submanifoldE[OF this closed_closure \<open>closure B \<subseteq> sub.carrier\<close>]
	obtain f' where f': "diff_fun k charts f'" "(\<And>x. x \<in> closure B \<Longrightarrow> f' x = f x)" "csupport_on carrier f' \<inter> carrier \<subseteq> sub.carrier"
	by auto
	show ?thesis
	apply (rule exI[where x="restrict0 carrier f'"])
	using f' B
	by (auto intro!: restrict0_in_fun_space)
	qed
	have extend: "?P f (extend f)" if "f \<in> sub.diff_fun_space" for f
	using ex[OF that]
	unfolding extend_def
	by (rule someI_ex)
	note extend = extend[THEN conjunct1] extend[THEN conjunct2, rule_format]
	have extend2: "f \<in> sub.diff_fun_space \<Longrightarrow> x \<in> B \<Longrightarrow> extend f x = f x" for f x
	using extend by auto

	define v where "v f = w (extend f)" for f

	have ext_w: "extensional0 diff_fun_space w"
	using w by (rule tangent_space_restrict)

	have "w = inclusion.push_forward (restrict0 sub.diff_fun_space v)"
	unfolding inclusion.push_forward_def o_def
	using ext_w extensional0_restrict0
	proof (rule ext_extensional0)
	fix g
	assume g: "g \<in> diff_fun_space"
	then have "diff_fun k charts g"
	by (rule diff_fun_spaceD)
	then have "diff_fun k (charts_submanifold S) g"
	using open_submanifold
	by (rule diff_fun.diff_fun_submanifold)
	have rgsd: "restrict0 sub.carrier g \<in> sub.diff_fun_space"
	by (rule sub.restrict0_in_fun_space) fact
	have "w g = v (restrict0 sub.carrier g)"
	unfolding v_def
	apply (rule w_eqI)
	subgoal by fact
	subgoal by (rule extend) fact
	subgoal for x
	using extend(2)[of "restrict0 sub.carrier g" x] B(4) rgsd
	by (auto simp: restrict0_def split: if_splits)
	done
	with g rgsd show "w g = restrict0 diff_fun_space (\<lambda>g. restrict0 sub.diff_fun_space v (restrict0 sub.carrier g)) g"
	by auto
	qed
	moreover have "restrict0 sub.diff_fun_space v \<in> sub.tangent_space p"
	using extensional0_restrict0
	proof (rule sub.tangent_spaceI)
	have "v (x + y) = v x + v y" if "x \<in> sub.diff_fun_space" "y \<in> sub.diff_fun_space" for x y
	using that
	unfolding v_def
	by (subst w_add[symmetric]) (auto intro!: w_eqI simp: extend2 subspaceI extend(1))
	moreover have "v (c \<^sub>R x) = c \<^sub>R v x" if "x \<in> sub.diff_fun_space" for x c
	using that
	unfolding v_def
	by (subst w_scale[symmetric]) (auto intro!: w_eqI simp: extend2 subspaceI extend(1))
	ultimately show "linear_on sub.diff_fun_space UNIV (\<^sub>R) (\<^sub>R) (restrict0 sub.diff_fun_space v)"
	apply unfold_locales
	using sub.subspace_diff_fun_space[THEN subspace_add]
	sub.subspace_diff_fun_space[THEN subspace_mul]
	by auto
	fix f g assume f: "f \<in> sub.diff_fun_space" and g: "g \<in> sub.diff_fun_space"
	then have [simp]: "f * g \<in> sub.diff_fun_space" by (rule sub.diff_fun_space_times)
	have "restrict0 sub.diff_fun_space v (f * g) = w (extend (f * g))" by (simp add: v_def)
	also have "\<dots> = w (extend f * extend g)"
	apply (rule w_eqI)
	subgoal by (simp add: extend)
	subgoal by (simp add: diff_fun_space_times extend f g)
	subgoal using f g by (auto simp: extend2)
	done
	also have "\<dots> = extend f p * w (extend g) + extend g p * w (extend f)"
	apply (rule is_derivation_derivation)
	subgoal using w by (auto simp: tangent_space_def)
	by (auto intro!: extend f g)
	also have "\<dots> = f p * restrict0 sub.diff_fun_space v g + g p * restrict0 sub.diff_fun_space v f"
	by (simp add: f g v_def extend2 \<open>p \<in> B\<close>)
	finally show "restrict0 sub.diff_fun_space v (f * g) = f p * restrict0 sub.diff_fun_space v g + g p * restrict0 sub.diff_fun_space v f" .
	qed
	ultimately
	show "w \<in> inclusion.push_forward ` sub.tangent_space p" ..
	qed

	end

	subsection \<open>Tangent space of submanifold\<close>

	lemma span_idem: "span X = X" if "subspace X"
	using that by auto

	context submanifold begin

	lemma dim_tangent_space: "dim (tangent_space p) = dim (sub.tangent_space p)"
	if "p \<in> sub.carrier" "dim (sub.tangent_space p) > 0"
	proof -
	from that(2) obtain basis where basis: "independent basis" "span basis = span (sub.tangent_space p)"
	by (auto simp: dim_def split: if_splits)
	have basis_sub: "basis \<subseteq> sub.tangent_space p"
	using basis
	apply auto
	by (metis basis(2) span_base span_eq_iff sub.subspace_tangent_space)
	have "dim (sub.tangent_space p) = card basis"
	apply (rule dim_unique[OF _ _ _ refl])
	using basis span_base
	apply auto
	proof -
	fix x :: "('a \<Rightarrow> real) \<Rightarrow> real"
	assume a1: "x \<in> basis"
	have "sub.tangent_space p = span basis"
	by (metis basis(2) span_eq_iff sub.subspace_tangent_space)
	then show "x \<in> sub.tangent_space p"
	using a1 by (metis span_base)
	qed
	with that have "finite basis"
	using card_ge_0_finite by auto
	interpret sub: finite_dimensional_vector_space_on "sub.tangent_space p" scaleR basis
	apply unfold_locales
	unfolding tangent_space.dependent_eq_real tangent_space.span_eq_real
	subgoal by fact
	subgoal by fact
	subgoal using basis by (simp add: sub.subspace_tangent_space)
	subgoal by fact
	done
	interpret sub: finite_dimensional_vector_space_pair_1_on "sub.tangent_space p" "tangent_space p" scaleR scaleR basis
	by unfold_locales
	have "dim (tangent_space p) = tangent_space.dim p (tangent_space p)"
	using order_refl by (rule tangent_space_dim_eq[symmetric])
	also have "\<dots> = tangent_space.dim p (inclusion.push_forward ` sub.tangent_space p)"
	using surj_on_push_forward_inclusion[OF that(1)] inclusion.push_forward_in_tangent_space[OF that(1)]
	by auto
	also have "tangent_space.dim p (inclusion.push_forward ` sub.tangent_space p) =
	sub.tangent_space.dim p (sub.tangent_space p)"
	apply (rule sub.dim_image_eq[of inclusion.push_forward, OF _ order_refl linear_on_push_forward_inclusion])
	subgoal using inclusion.push_forward_in_tangent_space[of p] that by auto
	subgoal unfolding tangent_space.span_eq_real span_idem[OF sub.subspace_tangent_space]
	apply (rule inj_on_push_forward_inclusion)
	apply (rule that)
	done
	done
	also have "\<dots> = dim (sub.tangent_space p)"
	using order_refl
	by (rule sub.tangent_space_dim_eq)
	finally show ?thesis .
	qed

	lemma dim_tangent_space2: "dim (tangent_space p) = dim (sub.tangent_space p)"
	if "p \<in> sub.carrier" "dim (tangent_space p) > 0"
	proof -
	from that(2) obtain basis where basis: "independent basis" "span basis = span (tangent_space p)"
	by (auto simp: dim_def split: if_splits)
	have basis_sub: "basis \<subseteq> tangent_space p"
	using basis
	apply auto
	using c_manifold.subspace_tangent_space c_manifold_axioms span_base span_eq_iff by blast
	have "dim (tangent_space p) = card basis"
	apply (rule dim_unique[OF _ _ _ refl])
	using basis span_base
	apply auto
	proof -
	fix x :: "('a \<Rightarrow> real) \<Rightarrow> real"
	assume a1: "x \<in> basis"
	have "tangent_space p = span basis"
	by (metis basis(2) span_eq_iff subspace_tangent_space)
	then show "x \<in> tangent_space p"
	using a1 by (metis span_base)
	qed
	with that have "finite basis"
	using card_ge_0_finite by auto
	interpret sub: finite_dimensional_vector_space_on "tangent_space p" scaleR basis
	apply unfold_locales
	unfolding tangent_space.dependent_eq_real tangent_space.span_eq_real
	subgoal by fact
	subgoal by fact
	subgoal using basis by (simp add: subspace_tangent_space)
	subgoal by fact
	done
	interpret vector_space_pair_on "sub.tangent_space p" "tangent_space p" scaleR scaleR by unfold_locales
	interpret finite_dimensional_vector_space_pair_1_on "tangent_space p" "sub.tangent_space p" scaleR scaleR basis
	by unfold_locales
	from linear_injective_left_inverse[OF _ linear_on_push_forward_inclusion inj_on_push_forward_inclusion[OF \<open>p \<in> sub.carrier\<close>]]
	inclusion.push_forward_in_tangent_space[OF \<open>p \<in> sub.carrier\<close>]
	obtain g where g: "\<And>x. x \<in> tangent_space p \<Longrightarrow> g x \<in> sub.tangent_space p"
	"linear_on (tangent_space p) (sub.tangent_space p) (\<^sub>R) (\<^sub>R) g"
	"\<And>x. x \<in> sub.tangent_space p \<Longrightarrow> g (inclusion.push_forward x) = x"
	by (auto simp: subset_eq)
	have inj_on_g: "inj_on g (tangent_space p)"
	using inj_on_push_forward_inclusion[OF \<open>p \<in> sub.carrier\<close>] g
	apply (auto simp: inj_on_def)
	by (metis (no_types, lifting) \<open>inclusion.push_forward ` sub.tangent_space p \<subseteq> tangent_space p\<close>
	imageE subset_antisym surj_on_push_forward_inclusion that(1))
	have "dim (tangent_space p) = tangent_space.dim p (tangent_space p)"
	using order_refl by (rule tangent_space.dim_eq[symmetric])
	also have "\<dots> = sub.tangent_space.dim p (g ` tangent_space p)"
	apply (rule dim_image_eq[OF _ order_refl, symmetric])
	subgoal using g by auto
	subgoal using g by auto
	subgoal using inj_on_g by (auto simp: tangent_space.span_eq_real span_idem subspace_tangent_space)
	done
	also have "g ` tangent_space p = sub.tangent_space p"
	using g inj_on_g using inj_on_push_forward_inclusion[OF \<open>p \<in> sub.carrier\<close>] g
	apply (auto simp: inj_on_def)
	by (metis (no_types, lifting) \<open>inclusion.push_forward ` sub.tangent_space p \<subseteq> tangent_space p\<close>
	contra_subsetD image_eqI)
	also have "sub.tangent_space.dim p \<dots> = dim \<dots>"
	using order_refl by (rule sub.tangent_space_dim_eq)
	finally show ?thesis .
	qed

	end


	subsection \<open>Directional derivatives\<close>

	text \<open>When the manifold is the Euclidean space, The Frechet derivative
	at a in the direction of v is an element of the tangent space at a.\<close>
	definition directional_derivative::"enat \<Rightarrow> 'a \<Rightarrow> 'a::euclidean_space \<Rightarrow>
	('a \<Rightarrow> real) \<Rightarrow> real" where
	"directional_derivative k a v = restrict0 (manifold_eucl.diff_fun_space k) (\<lambda>f. frechet_derivative f (at a) v)"

	lemma extensional0_directional_derivative:
	"extensional0 (manifold_eucl.diff_fun_space k) (directional_derivative k a v)"
	unfolding directional_derivative_def
	by simp

	lemma extensional0_directional_derivative_le:
	"extensional0 (manifold_eucl.diff_fun_space k) (directional_derivative k' a v)"
	if "k \<le> k'"
	using that
	unfolding directional_derivative_def
	by (auto simp: extensional0_def restrict0_def manifold_eucl.diff_fun_space_def
	dest!: diff_fun.diff_fun_order_le[OF _ that])

	lemma directional_derivative_add[simp]: "directional_derivative k a (x + y) = directional_derivative k a x + directional_derivative k a y"
	and directional_derivative_scaleR[simp]: "directional_derivative k a (c \<^sub>R x) = c \<^sub>R directional_derivative k a x"
	if "k \<noteq> 0"
	using that
	by (auto simp: directional_derivative_def restrict0_def[abs_def] fun_eq_iff
	differentiable_on_def linear_iff that
	dest!: linear_frechet_derivative spec[where x=a] smooth_on_imp_differentiable_on)

	lemma linear_directional_derivative: "k \<noteq> 0 \<Longrightarrow> linear (directional_derivative k a)"
	by unfold_locales simp_all

	lemma frechet_derivative_inner[simp]:
	"frechet_derivative (\<lambda>x. x \<bullet> j) (at a) = (\<lambda>x. x \<bullet> j)"
	apply (rule sym)
	apply (rule frechet_derivative_at)
	by (auto intro!: derivative_eq_intros)

	lemma smooth_on_inner_const[simp]: "k-smooth_on UNIV (\<lambda>x. x \<bullet> j)"
	by (auto intro!: smooth_on_inner)

	lemma directional_derivative_inner[simp]: "directional_derivative k a x (\<lambda>x. x \<bullet> j) = x \<bullet> j"
	unfolding directional_derivative_def
	by (auto simp: restrict0_def differentiable_on_def)

	lemma sum_apply: "sum f X i = sum (\<lambda>x. f x i) X"
	by (induction rule: infinite_finite_induct) auto

	lemma inj_on_directional_derivative: "inj_on (directional_derivative k a) S" if "k \<noteq> 0"
	apply (rule inj_on_subset[OF _ subset_UNIV])
	unfolding linear_injective_0[OF linear_directional_derivative[OF that]]
	proof safe
	fix v
	assume 0: "directional_derivative k a v = 0"
	interpret linear "directional_derivative k a" using that by (rule linear_directional_derivative)
	show "v = 0"
	proof (rule euclidean_eqI)
	fix j::'a
	assume "j \<in> Basis"
	have "0 = directional_derivative k a v (\<lambda>x. x \<bullet> j)"
	using 0 by simp
	also have "\<dots> = directional_derivative k a (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R i) (\<lambda>x. x \<bullet> j)"
	by (simp add: euclidean_representation)
	also have "\<dots> = (\<Sum>i\<in>Basis. (v \<bullet> i) * frechet_derivative (\<lambda>x. x \<bullet> j) (at a) i)"
	unfolding sum
	by (auto simp: sum_apply intro!: sum.cong)
	also have "\<dots> = (v \<bullet> j)"
	using \<open>j \<in> Basis\<close>
	by (auto simp: inner_Basis if_distrib cong: if_cong)
	finally show "v \<bullet> j = 0 \<bullet> j" by simp
	qed
	qed

	lemma directional_derivative_eq_frechet_derivative:
	"directional_derivative k a v f = frechet_derivative f (at a) v"
	if "k-smooth_on UNIV f"
	using that
	by (auto simp: directional_derivative_def)

	lemma directional_derivative_linear_on_diff_fun_space:
	"k \<noteq> 0 \<Longrightarrow> manifold_eucl.linear_diff_fun k (directional_derivative k a x)"
	by unfold_locales
	(auto simp: directional_derivative_eq_frechet_derivative differentiable_onD
	smooth_on_add_fun smooth_on_scaleR_fun
	frechet_derivative_plus_fun frechet_derivative_scaleR_fun)

	lemma directional_derivative_is_derivation:
	"directional_derivative k a x (f * g) = f a * directional_derivative k a x g + g a * directional_derivative k a x f"
	if "f \<in> manifold_eucl.diff_fun_space k" "g \<in> manifold_eucl.diff_fun_space k" "k \<noteq> 0"
	using that
	by (auto simp: directional_derivative_eq_frechet_derivative smooth_on_times_fun
	frechet_derivative_times_fun differentiable_onD)

	lemma directional_derivative_in_tangent_space[intro, simp]:
	"k \<noteq> 0 \<Longrightarrow> directional_derivative k a x \<in> manifold_eucl.tangent_space k a" for x
	apply (rule manifold_eucl.tangent_spaceI)
	apply (rule extensional0_directional_derivative)
	apply (rule directional_derivative_linear_on_diff_fun_space)
	apply assumption
	by (rule directional_derivative_is_derivation)


	context c_manifold begin

	lemma is_derivation_order_le:
	"is_derivation X p"
	if "l \<le> k" "c_manifold.is_derivation charts l X p"
	proof -
	interpret l: c_manifold charts l
	by (rule c_manifold_order_le) fact
	show ?thesis
	using that(2) subspace_diff_fun_space
	using diff_fun_space_order_le[OF that(1)]
	by (auto simp: is_derivation_def l.is_derivation_def linear_on_def module_hom_on_def
	module_hom_on_axioms_def module_on_def subspace_def
	subset_iff)
	qed

	end

	lemma smooth_on_imp_differentiable_on: "f differentiable_on S"
	if "k-smooth_on S f" "k > 0"
	using that
	by auto

	text\<open>
	Key result: for the Euclidean space, the Frechet derivatives are the
	only elements of the tangent space.

	This result only holds for smooth manifolds, not for \<open>C^k\<close> differentiable
	manifolds. Smoothness is used at a key point in the proof.
	\<close>
	lemma surj_directional_derivative:
	"range (directional_derivative k a) = manifold_eucl.tangent_space k a"
	if "k = \<infinity>"
	proof -
	have "k \<noteq> 0" using that by auto
	have "X \<in> range (directional_derivative k a)" if "X \<in> manifold_eucl.tangent_space k a" for X
	proof -
	define v where "v i = X (\<lambda>x. (x - a) \<bullet> i)" for i
	have linear_X: "manifold_eucl.linear_diff_fun k X"
	by (rule manifold_eucl.tangent_space_linear_on) fact
	note X_sum = manifold_eucl.diff_fun_space.linear_sum'[OF _ _ linear_X]
	note X_add = manifold_eucl.diff_fun_space.linear_add[OF _ _ _ linear_X]
	note X_scale = manifold_eucl.diff_fun_space.linear_scale[OF _ _ linear_X]
	have "X = directional_derivative k a (\<Sum>i\<in>Basis. v i *\<^sub>R i)"
	apply (rule ext_extensional0)
	using that
	apply (rule manifold_eucl.tangent_space_restrict)
	apply (rule extensional0_directional_derivative)
	proof -
	fix f::"'a \<Rightarrow> real"
	assume f: "f \<in> manifold_eucl.diff_fun_space k"
	then have "smooth_on UNIV f" using \<open>k = \<infinity>\<close>
	by simp
	from smooth_on_Taylor2E[OF this, of a]
	obtain g where f_exp:
	"\<And>x. f x = f a + frechet_derivative f (at a) (x - a) +
	(\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. (x - a) \<bullet> j * ((x - a) \<bullet> i) * g i j x)"
	and g: "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> smooth_on UNIV (g i j)"
	by auto
	note [simp] = \<open>k = _\<close>
	have : "X (\<lambda>x. \<Sum>i\<in>Basis. \<Sum>j\<in>Basis. (x - a) \<bullet> j ((x - a) \<bullet> i) * g i j x) = 0"
	thm X_sum[unfolded sum_fun_def]
	apply (subst X_sum[unfolded sum_fun_def], safe)
	subgoal by auto
	subgoal for i
	by (auto intro!: smooth_on_sum smooth_on_mult smooth_on_inner smooth_on_minus simp: g)
	apply (intro sum.neutral ballI)
	apply (subst X_sum[unfolded sum_fun_def])
	subgoal by (auto intro!: smooth_on_mult smooth_on_inner smooth_on_minus g)
	subgoal by (auto intro!: smooth_on_mult smooth_on_inner smooth_on_minus g)
	proof (intro sum.neutral ballI)
	fix i j::'a
	assume ij: "i \<in> Basis" "j \<in> Basis"
	have "X (\<lambda>xb. (xb - a) \<bullet> j * ((xb - a) \<bullet> i) * g i j xb) =
	X ((\<lambda>xb. (xb - a) \<bullet> j) * (\<lambda>xb. ((xb - a) \<bullet> i) * g i j xb))"
	by (auto simp: times_fun_def ac_simps)
	also have "\<dots> = 0"
	apply (rule manifold_eucl.derivation_times_eq_zeroI)
	apply fact
	subgoal
	by (auto intro!: smooth_on_sum smooth_on_mult smooth_on_inner smooth_on_minus)
	subgoal
	by (auto intro!: smooth_on_mult smooth_on_inner smooth_on_minus g ij)
	apply auto
	done
	finally
	show "X (\<lambda>xb. (xb - a) \<bullet> j * ((xb - a) \<bullet> i) * g i j xb) = 0"
	by simp
	qed
	from f have "smooth_on UNIV f"
	by (auto )
	have "f differentiable at a"
	apply (rule differentiable_onD)
	apply (rule smooth_on_imp_differentiable_on)
	apply fact
	by auto
	interpret Df: linear "frechet_derivative f (at a)"
	apply (rule linear_frechet_derivative)
	by fact
	have X_mult_right: "k-smooth_on UNIV xx \<Longrightarrow> X (\<lambda>x. xx x * cc) = X xx * cc" for xx cc
	using X_scale[unfolded scaleR_fun_def, simplified, of xx cc]
	by (auto simp: ac_simps)
	have blf: "bounded_linear (frechet_derivative f (at a))"
	apply (rule has_derivative_bounded_linear)
	apply (rule frechet_derivative_worksI)
	apply fact
	done
	note smooth_on_frechet = smooth_on_compose[OF bounded_linear.smooth_on[OF blf], unfolded o_def, OF _ _ open_UNIV subset_UNIV]
	have *: "X (\<lambda>x. frechet_derivative f (at a) (x - a)) = frechet_derivative f (at a) (\<Sum>i\<in>Basis. v i \<^sub>R i)"
	unfolding v_def
	apply (subst frechet_derivative_componentwise)
	subgoal by fact
	apply (subst X_sum[unfolded sum_fun_def])
	subgoal by (auto intro!: smooth_on_sum smooth_on_mult smooth_on_inner smooth_on_minus)
	subgoal by (auto intro!: smooth_on_frechet smooth_on_minus smooth_on_mult smooth_on_inner)
	apply (subst X_mult_right)
	subgoal by (auto intro!: smooth_on_sum smooth_on_mult smooth_on_inner smooth_on_minus)
	apply (subst Df.sum)
	apply (rule sum.cong, rule refl)
	apply (subst Df.scaleR)
	apply auto
	done

	show "X f = directional_derivative k a (\<Sum>i\<in>Basis. v i *\<^sub>R i) f"
	apply (subst f_exp[abs_def])
	apply (subst X_add[unfolded plus_fun_def])
	subgoal by simp
	subgoal by (auto intro!: smooth_on_add smooth_on_frechet smooth_on_minus)
	subgoal
	by (auto intro!: smooth_on_add smooth_on_sum smooth_on_mult smooth_on_inner g smooth_on_minus)
	apply (subst X_add[unfolded plus_fun_def])
	subgoal by auto
	subgoal by (auto intro!: smooth_on_add smooth_on_frechet smooth_on_minus)
	subgoal by (auto intro!: smooth_on_frechet smooth_on_minus)
	apply (subst manifold_eucl.derivation_const_eq_zero[where c="f a" and X=X, simplified], fact)
	apply (subst *)
	apply simp
	using f
	by (simp add: directional_derivative_def **)
	qed
	then show ?thesis
	by (rule image_eqI) simp
	qed
	with directional_derivative_in_tangent_space[OF \<open>k \<noteq> 0\<close>] show ?thesis by auto
	qed

	lemma span_directional_derivative:
	"span (directional_derivative \<infinity> a ` Basis) = manifold_eucl.tangent_space \<infinity> a"
	by (subst span_linear_image)
	(simp_all add: linear_directional_derivative surj_directional_derivative)

	lemma directional_derivative_in_span:
	"directional_derivative \<infinity> a x \<in> span (directional_derivative \<infinity> a ` Basis)"
	unfolding span_directional_derivative
	using surj_directional_derivative
	by blast

	lemma linear_on_directional_derivative:
	"k \<noteq> 0 \<Longrightarrow> linear_on UNIV (manifold_eucl.tangent_space k a) (\<^sub>R) (\<^sub>R) (directional_derivative k a)"
	apply (rule linear_imp_linear_on)
	apply (rule linear_directional_derivative)
	by (auto simp: manifold_eucl.subspace_tangent_space)

	text \<open>The directional derivatives at Basis forms a basis of the tangent space at a\<close>
	interpretation manifold_eucl: finite_dimensional_real_vector_space_on
	"manifold_eucl.tangent_space \<infinity> a" "directional_derivative \<infinity> a ` Basis"
	apply unfold_locales
	subgoal by auto
	subgoal
	proof
	assume 4: "manifold_eucl.tangent_space.dependent (directional_derivative \<infinity> a ` Basis)"
	interpret rvo: real_vector_space_pair_on
	"UNIV::'a set"
	"manifold_eucl.tangent_space \<infinity> a"
	by unfold_locales simp
	have 1: "\<forall>x. x \<in> UNIV \<longrightarrow> directional_derivative \<infinity> a x \<in> manifold_eucl.tangent_space \<infinity> a"
	by auto
	have 2: "Basis \<subseteq> UNIV" by auto
	have 5: "inj_on (directional_derivative \<infinity> a) (span Basis)"
	by (rule inj_on_directional_derivative) simp_all
	from rvo.linear_dependent_inj_imageD[OF 1 2 linear_on_directional_derivative 4 5]
	show False using independent_Basis
	by auto
	qed
	subgoal by (simp add: span_directional_derivative)
	subgoal
	using surj_directional_derivative[of \<infinity> a]
	by auto
	done

	lemma independent_directional_derivative:
	"k \<noteq> 0 \<Longrightarrow> independent (directional_derivative k a ` Basis)"
	by (rule linear_independent_injective_image)
	(auto simp: independent_Basis linear_directional_derivative inj_on_directional_derivative)

	subsection \<open>Dimension\<close>

	text \<open>For the Euclidean space, the dimension of the tangent space
	equals the dimension of the original space.\<close>
	lemma dim_eucl_tangent_space:
	"dim (manifold_eucl.tangent_space \<infinity> a) = DIM('a)" for a::"'a::euclidean_space"
	proof -
	interpret finite_dimensional_real_vector_space_pair_on
	"UNIV::'a set"
	"manifold_eucl.tangent_space \<infinity> a"
	Basis "directional_derivative \<infinity> a ` Basis"
	by unfold_locales (auto simp: independent_Basis)
	have "manifold_eucl.tangent_space.dim \<infinity> a (manifold_eucl.tangent_space \<infinity> a) = manifold_eucl.tangent_space.dim \<infinity> a (range (directional_derivative \<infinity> a))"
	by (simp add: surj_directional_derivative)
	also have "\<dots> = vs1.dim (UNIV::'a set)"
	by (rule dim_image_eq)
	(auto simp: linear_on_directional_derivative inj_on_directional_derivative)
	also have "\<dots> = DIM('a)"
	by (simp add: vs1.dim_UNIV)
	finally have *: "DIM('a) = manifold_eucl.tangent_space.dim \<infinity> a (manifold_eucl.tangent_space \<infinity> a)" ..
	also have "\<dots> = dim (manifold_eucl.tangent_space \<infinity> a)"
	using manifold_eucl.basis_subset _ independent_directional_derivative
	proof (rule dim_unique[symmetric])
	show "manifold_eucl.tangent_space \<infinity> a \<subseteq> span (directional_derivative \<infinity> a ` Basis)"
	by (simp add: span_directional_derivative)
	have "card (directional_derivative \<infinity> a ` Basis) = DIM('a)"
	apply (rule card_image)
	by (rule inj_on_directional_derivative) simp
	also note *
	finally show "card (directional_derivative \<infinity> a ` Basis) =
	manifold_eucl.tangent_space.dim \<infinity> a (manifold_eucl.tangent_space \<infinity> a)" .
	qed simp
	finally show ?thesis ..
	qed


	context c_manifold begin

	text \<open>For a general manifold, the dimension of the tangent space at point p
	equals the dimension of the manifold.\<close>
	lemma dim_tangent_space: "dim (tangent_space p) = DIM('b)" if p: "p \<in> carrier" and smooth: "k = \<infinity>"
	proof -
	from carrierE[OF p] obtain c where "c \<in> charts" "p \<in> domain c" .
	interpret a: submanifold charts k "domain c"
	by unfold_locales simp
	let ?a = "charts_submanifold (domain c)"
	let ?b = "manifold_eucl.charts_submanifold (codomain c)"
	interpret a: diff k ?a ?b c
	apply (rule diff.diff_submanifold2)
	apply (rule diff_apply_chart)
	using \<open>c \<in> charts\<close>
	by auto
	interpret b: diff k ?b ?a "inv_chart c"
	apply (rule diff.diff_submanifold2)
	apply (rule diff_inv_chart)
	using \<open>c \<in> charts\<close>
	apply auto
	by (metis Int_iff a.dest.carrierE domain_restrict_chart image_empty image_insert
	inv_chart_in_domain manifold_eucl.dest.charts_submanifold_def open_codomain singletonD)
	interpret b: submanifold charts_eucl k "codomain c"
	by unfold_locales simp

	interpret diffeomorphism k "?a" "?b" "c" "inv_chart c"
	by unfold_locales auto

	have *: "DIM('b) = dim (a.dest.tangent_space (c p))"
	proof -
	have *: "DIM('b) = dim (manifold_eucl.tangent_space k (c p))"
	unfolding smooth dim_eucl_tangent_space ..
	also have "\<dots> = dim (a.dest.tangent_space (c p))"
	apply (rule b.dim_tangent_space2[of "c p"])
	subgoal
	using \<open>p \<in> domain c\<close> that
	- by (auto simp: )
	+ by auto
	subgoal unfolding *[symmetric] by simp
	done
	finally show ?thesis .
	qed
	also have **: "\<dots> = dim (a.sub.tangent_space p)"
	apply (rule dim_tangent_space_src_dest_eq[symmetric])
	unfolding *[symmetric]
	using \<open>p \<in> domain c\<close> that
	by auto
	also have "\<dots> = dim (tangent_space p)"
	apply (rule a.dim_tangent_space[symmetric])
	unfolding [symmetric] *[symmetric]
	using \<open>p \<in> domain c\<close> that
	by auto
	finally show ?thesis ..
	qed

	end

	end
	diff --git a/thys/Stirling_Formula/Gamma_Asymptotics.thy b/thys/Stirling_Formula/Gamma_Asymptotics.thy
	--- a/thys/Stirling_Formula/Gamma_Asymptotics.thy
	+++ b/thys/Stirling_Formula/Gamma_Asymptotics.thy
	@@ -1,1893 +1,1893 @@
	(*
	File: Gamma_Asymptotics.thy
	Author: Manuel Eberl

	The complete asymptotics of the real and complex logarithmic Gamma functions.
	Also of the real Polygamma functions (could be extended to the complex ones fairly easily
	if needed).
	*)
	section \<open>Complete asymptotics of the logarithmic Gamma function\<close>
	theory Gamma_Asymptotics
	imports
	"HOL-Complex_Analysis.Complex_Analysis"
	"HOL-Real_Asymp.Real_Asymp"
	Bernoulli.Bernoulli_FPS
	Bernoulli.Periodic_Bernpoly
	Stirling_Formula
	begin

	subsection \<open>Auxiliary Facts\<close>

	(* TODO: could be automated with Laurent series expansions in the future *)
	lemma stirling_limit_aux1:
	"((\<lambda>y. Ln (1 + z * of_real y) / of_real y) \<longlongrightarrow> z) (at_right 0)" for z :: complex
	proof (cases "z = 0")
	case True
	then show ?thesis by simp
	next
	case False
	have "((\<lambda>y. ln (1 + z * of_real y)) has_vector_derivative 1 * z) (at 0)"
	by (rule has_vector_derivative_real_field) (auto intro!: derivative_eq_intros)
	then have "(\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<midarrow>0\<rightarrow> 0"
	by (auto simp add: has_vector_derivative_def has_derivative_def netlimit_at
	scaleR_conv_of_real field_simps)
	then have "((\<lambda>y. (Ln (1 + z * of_real y) - of_real y * z) / of_real \<bar>y\<bar>) \<longlongrightarrow> 0) (at_right 0)"
	by (rule filterlim_mono[OF _ _ at_le]) simp_all
	also have "?this \<longleftrightarrow> ((\<lambda>y. Ln (1 + z * of_real y) / (of_real y) - z) \<longlongrightarrow> 0) (at_right 0)"
	using eventually_at_right_less[of "0::real"]
	by (intro filterlim_cong refl) (auto elim!: eventually_mono simp: field_simps)
	finally show ?thesis by (simp only: LIM_zero_iff)
	qed

	lemma stirling_limit_aux2:
	"((\<lambda>y. y * Ln (1 + z / of_real y)) \<longlongrightarrow> z) at_top" for z :: complex
	using stirling_limit_aux1[of z] by (subst filterlim_at_top_to_right) (simp add: field_simps)

	lemma Union_atLeastAtMost:
	assumes "N > 0"
	shows "(\<Union>n\<in>{0..<N}. {real n..real (n + 1)}) = {0..real N}"
	proof (intro equalityI subsetI)
	fix x assume x: "x \<in> {0..real N}"
	thus "x \<in> (\<Union>n\<in>{0..<N}. {real n..real (n + 1)})"
	proof (cases "x = real N")
	case True
	with assms show ?thesis by (auto intro!: bexI[of _ "N - 1"])
	next
	case False
	with x have x: "x \<ge> 0" "x < real N" by simp_all
	hence "x \<ge> real (nat \<lfloor>x\<rfloor>)" "x \<le> real (nat \<lfloor>x\<rfloor> + 1)" by linarith+
	moreover from x have "nat \<lfloor>x\<rfloor> < N" by linarith
	ultimately have "\<exists>n\<in>{0..<N}. x \<in> {real n..real (n + 1)}"
	by (intro bexI[of _ "nat \<lfloor>x\<rfloor>"]) simp_all
	thus ?thesis by blast
	qed
	qed auto


	subsection \<open>Cones in the complex plane\<close>

	definition complex_cone :: "real \<Rightarrow> real \<Rightarrow> complex set" where
	"complex_cone a b = {z. \<exists>y\<in>{a..b}. z = rcis (norm z) y}"

	abbreviation complex_cone' :: "real \<Rightarrow> complex set" where
	"complex_cone' a \<equiv> complex_cone (-a) a"

	lemma zero_in_complex_cone [simp, intro]: "a \<le> b \<Longrightarrow> 0 \<in> complex_cone a b"
	by (auto simp: complex_cone_def)

	lemma complex_coneE:
	assumes "z \<in> complex_cone a b"
	obtains r \<alpha> where "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
	proof -
	from assms obtain y where "y \<in> {a..b}" "z = rcis (norm z) y"
	unfolding complex_cone_def by auto
	thus ?thesis using that[of "norm z" y] by auto
	qed

	lemma arg_cis [simp]:
	assumes "x \<in> {-pi<..pi}"
	shows "Arg (cis x) = x"
	using assms by (intro cis_Arg_unique) auto

	lemma arg_mult_of_real_left [simp]:
	assumes "r > 0"
	shows "Arg (of_real r * z) = Arg z"
	proof (cases "z = 0")
	case False
	thus ?thesis
	using Arg_bounded[of z] assms
	by (intro cis_Arg_unique) (auto simp: sgn_mult sgn_of_real cis_Arg)
	qed auto

	lemma arg_mult_of_real_right [simp]:
	assumes "r > 0"
	shows "Arg (z * of_real r) = Arg z"
	by (subst mult.commute, subst arg_mult_of_real_left) (simp_all add: assms)

	lemma arg_rcis [simp]:
	assumes "x \<in> {-pi<..pi}" "r > 0"
	shows "Arg (rcis r x) = x"
	using assms by (simp add: rcis_def)

	lemma rcis_in_complex_cone [intro]:
	assumes "\<alpha> \<in> {a..b}" "r \<ge> 0"
	shows "rcis r \<alpha> \<in> complex_cone a b"
	using assms by (auto simp: complex_cone_def)

	lemma arg_imp_in_complex_cone:
	assumes "Arg z \<in> {a..b}"
	shows "z \<in> complex_cone a b"
	proof -
	have "z = rcis (norm z) (Arg z)"
	by (simp add: rcis_cmod_Arg)
	also have "\<dots> \<in> complex_cone a b"
	using assms by auto
	finally show ?thesis .
	qed

	lemma complex_cone_altdef:
	assumes "-pi < a" "a \<le> b" "b \<le> pi"
	shows "complex_cone a b = insert 0 {z. Arg z \<in> {a..b}}"
	proof (intro equalityI subsetI)
	fix z assume "z \<in> complex_cone a b"
	then obtain r \<alpha> where *: "r \<ge> 0" "\<alpha> \<in> {a..b}" "z = rcis r \<alpha>"
	by (auto elim: complex_coneE)
	have "Arg z \<in> {a..b}" if [simp]: "z \<noteq> 0"
	proof -
	have "r > 0" using that * by (subst (asm) *) auto
	hence "\<alpha> \<in> {a..b}"
	using (1,2) assms by (auto simp: (1))
	moreover from assms *(2) have "\<alpha> \<in> {-pi<..pi}"
	by auto
	ultimately show ?thesis using *(3) \<open>r > 0\<close>
	by (subst *) auto
	qed
	thus "z \<in> insert 0 {z. Arg z \<in> {a..b}}"
	by auto
	qed (use assms in \<open>auto intro: arg_imp_in_complex_cone\<close>)

	lemma nonneg_of_real_in_complex_cone [simp, intro]:
	assumes "x \<ge> 0" "a \<le> 0" "0 \<le> b"
	shows "of_real x \<in> complex_cone a b"
	proof -
	from assms have "rcis x 0 \<in> complex_cone a b"
	by (intro rcis_in_complex_cone) auto
	thus ?thesis by simp
	qed

	lemma one_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> 1 \<in> complex_cone a b"
	using nonneg_of_real_in_complex_cone[of 1] by (simp del: nonneg_of_real_in_complex_cone)

	lemma of_nat_in_complex_cone [simp, intro]: "a \<le> 0 \<Longrightarrow> 0 \<le> b \<Longrightarrow> of_nat n \<in> complex_cone a b"
	using nonneg_of_real_in_complex_cone[of "real n"] by (simp del: nonneg_of_real_in_complex_cone)


	subsection \<open>Another integral representation of the Beta function\<close>

	lemma complex_cone_inter_nonpos_Reals:
	assumes "-pi < a" "a \<le> b" "b < pi"
	shows "complex_cone a b \<inter> \<real>\<^sub>\<le>\<^sub>0 = {0}"
	proof (safe elim!: nonpos_Reals_cases)
	fix x :: real
	assume "complex_of_real x \<in> complex_cone a b" "x \<le> 0"
	hence "\<not>(x < 0)"
	using assms by (intro notI) (auto simp: complex_cone_altdef)
	with \<open>x \<le> 0\<close> show "complex_of_real x = 0" by auto
	qed (use assms in auto)

	theorem
	assumes a: "a > 0" and b: "b > (0 :: real)"
	shows has_integral_Beta_real':
	"((\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b)) has_integral Beta a b) {0<..}"
	and Beta_conv_nn_integral:
	"Beta a b = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
	proof -
	define I where
	"I = (\<integral>\<^sup>+u. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) \<partial>lborel)"
	have "Gamma (a + b) > 0" "Beta a b > 0"
	using assms by (simp_all add: add_pos_pos Beta_def)
	from a b have "ennreal (Gamma a * Gamma b) =
	(\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (a - 1) / exp t) \<partial>lborel) *
	(\<integral>\<^sup>+ t. ennreal (indicator {0..} t * t powr (b - 1) / exp t) \<partial>lborel)"
	by (subst ennreal_mult') (simp_all add: Gamma_conv_nn_integral_real)
	also have "\<dots> = (\<integral>\<^sup>+t. \<integral>\<^sup>+u. ennreal (indicator {0..} t * t powr (a - 1) / exp t) *
	ennreal (indicator {0..} u * u powr (b - 1) / exp u) \<partial>lborel \<partial>lborel)"
	by (simp add: nn_integral_cmult nn_integral_multc)
	also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
	/ exp (t + u) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"])
	(auto simp: indicator_def divide_ennreal ennreal_mult' [symmetric] exp_add mult_ac)
	also have "\<dots> = (\<integral>\<^sup>+t. indicator {0<..} t * (\<integral>\<^sup>+u. indicator {0..} u * t powr (a - 1) * u powr (b - 1)
	/ exp (t + u)
	\<partial>(density (distr lborel borel ((*) t)) (\<lambda>x. ennreal \<bar>t\<bar>))) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
	also have "\<dots> = (\<integral>\<^sup>+(t::real). indicator {0<..} t * (\<integral>\<^sup>+u.
	indicator {0..} (u * t) * t powr a *
	(u * t) powr (b - 1) / exp (t + t * u) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong)
	(auto simp: nn_integral_density nn_integral_distr algebra_simps powr_diff
	simp flip: ennreal_mult)
	also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr a * (u * t) powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
	(auto simp: indicator_def zero_le_mult_iff algebra_simps)
	also have "\<dots> = (\<integral>\<^sup>+(t::real). \<integral>\<^sup>+u. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (intro nn_integral_cong) (auto simp: powr_add powr_diff indicator_def powr_mult field_simps)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). \<integral>\<^sup>+t. indicator ({0<..}\<times>{0..}) (t, u) *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel \<partial>lborel)"
	by (rule lborel_pair.Fubini') auto
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong) (auto simp: indicator_def)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1)) \<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong_AE AE_I[of _ _ "{0}"]) (auto simp: indicator_def)
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u * (\<integral>\<^sup>+t. indicator {0<..} t *
	t powr (a + b - 1) * u powr (b - 1) / exp (t * (u + 1))
	\<partial>(density (distr lborel borel ((*) (1/(1+u)))) (\<lambda>x. ennreal \<bar>1/(1+u)\<bar>))) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong, subst lborel_distr_mult' [symmetric]) auto
	also have "\<dots> = (\<integral>\<^sup>+(u::real). indicator {0<..} u *
	(\<integral>\<^sup>+t. ennreal (1 / (u + 1)) * ennreal (indicator {0<..} (t / (u + 1)) *
	(t / (1+u)) powr (a + b - 1) * u powr (b - 1) / exp t)
	\<partial>lborel) \<partial>lborel)"
	by (intro nn_integral_cong mult_indicator_cong)
	(auto simp: nn_integral_distr nn_integral_density add_ac)
	also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. indicator ({0<..}\<times>{0<..}) (u, t) *
	1/(u+1) * (t / (u+1)) powr (a + b - 1) * u powr (b - 1) / exp t
	\<partial>lborel \<partial>lborel)"
	by (subst nn_integral_cmult [symmetric], simp, intro nn_integral_cong)
	(auto simp: indicator_def field_simps divide_ennreal simp flip: ennreal_mult ennreal_mult')
	also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+t. ennreal (indicator {0<..} u * u powr (b - 1) / (1 + u) powr (a + b)) *
	ennreal (indicator {0<..} t * t powr (a + b - 1) / exp t)
	\<partial>lborel \<partial>lborel)"
	by (intro nn_integral_cong)
	(auto simp: indicator_def powr_add powr_diff powr_divide powr_minus divide_simps add_ac
	simp flip: ennreal_mult)
	also have "\<dots> = I * (\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel)"
	by (simp add: nn_integral_cmult nn_integral_multc I_def)
	also have "(\<integral>\<^sup>+t. indicator {0<..} t * t powr (a + b - 1) / exp t \<partial>lborel) =
	ennreal (Gamma (a + b))"
	using assms
	by (subst Gamma_conv_nn_integral_real)
	(auto intro!: nn_integral_cong_AE[OF AE_I[of _ _ "{0}"]]
	simp: indicator_def split: if_splits split_of_bool_asm)
	finally have "ennreal (Gamma a * Gamma b) = I * ennreal (Gamma (a + b))" .
	hence "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
	I * ennreal (Gamma (a + b)) / ennreal (Gamma (a + b))" by simp
	also have "\<dots> = I"
	- using \<open>Gamma (a + b) > 0\<close> by (intro ennreal_mult_divide_eq) (auto simp: )
	+ using \<open>Gamma (a + b) > 0\<close> by (intro ennreal_mult_divide_eq) auto
	also have "ennreal (Gamma a * Gamma b) / ennreal (Gamma (a + b)) =
	ennreal (Gamma a * Gamma b / Gamma (a + b))"
	using assms by (intro divide_ennreal) auto
	also have "\<dots> = ennreal (Beta a b)"
	by (simp add: Beta_def)
	finally show *: "ennreal (Beta a b) = I" .

	define f where "f = (\<lambda>u. u powr (b - 1) / (1 + u) powr (a + b))"
	have "((\<lambda>u. indicator {0<..} u * f u) has_integral Beta a b) UNIV"
	using * \<open>Beta a b > 0\<close>
	by (subst has_integral_iff_nn_integral_lebesgue)
	(auto simp: f_def measurable_completion nn_integral_completion I_def mult_ac)
	also have "(\<lambda>u. indicator {0<..} u * f u) = (\<lambda>u. if u \<in> {0<..} then f u else 0)"
	by (auto simp: fun_eq_iff)
	also have "(\<dots> has_integral Beta a b) UNIV \<longleftrightarrow> (f has_integral Beta a b) {0<..}"
	by (rule has_integral_restrict_UNIV)
	finally show \<dots> by (simp add: f_def)
	qed

	lemma has_integral_Beta2:
	fixes a :: real
	assumes "a < -1/2"
	shows "((\<lambda>x. (1 + x ^ 2) powr a) has_integral Beta (- a - 1 / 2) (1 / 2) / 2) {0<..}"
	proof -
	define f where "f = (\<lambda>u. u powr (-1/2) / (1 + u) powr (-a))"
	define C where "C = Beta (-a-1/2) (1/2)"
	have I: "(f has_integral C) {0<..}"
	using has_integral_Beta_real'[of "-a-1/2" "1/2"] assms
	by (simp_all add: diff_divide_distrib f_def C_def)

	define g where "g = (\<lambda>x. x ^ 2 :: real)"
	have bij: "bij_betw g {0<..} {0<..}"
	by (intro bij_betwI[of _ _ _ sqrt]) (auto simp: g_def)

	have "(f absolutely_integrable_on g ` {0<..} \<and> integral (g ` {0<..}) f = C)"
	using I bij by (simp add: bij_betw_def has_integral_iff absolutely_integrable_on_def f_def)
	also have "?this \<longleftrightarrow> ((\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) absolutely_integrable_on {0<..} \<and>
	integral {0<..} (\<lambda>x. \<bar>2 * x\<bar> *\<^sub>R f (g x)) = C)"
	using bij by (intro has_absolute_integral_change_of_variables_1' [symmetric])
	(auto intro!: derivative_eq_intros simp: g_def bij_betw_def)
	finally have "((\<lambda>x. \<bar>2 * x\<bar> * f (g x)) has_integral C) {0<..}"
	by (simp add: absolutely_integrable_on_def f_def has_integral_iff)
	also have "?this \<longleftrightarrow> ((\<lambda>x::real. 2 * (1 + x\<^sup>2) powr a) has_integral C) {0<..}"
	by (intro has_integral_cong) (auto simp: f_def g_def powr_def exp_minus ln_realpow field_simps)
	finally have "((\<lambda>x::real. 1/2 * (2 * (1 + x\<^sup>2) powr a)) has_integral 1/2 * C) {0<..}"
	by (intro has_integral_mult_right)
	thus ?thesis by (simp add: C_def)
	qed

	lemma has_integral_Beta3:
	fixes a b :: real
	assumes "a < -1/2" and "b > 0"
	shows "((\<lambda>x. (b + x ^ 2) powr a) has_integral
	Beta (-a - 1/2) (1/2) / 2 * b powr (a + 1/2)) {0<..}"
	proof -
	define C where "C = Beta (- a - 1 / 2) (1 / 2) / 2"
	have int: "nn_integral lborel (\<lambda>x. indicator {0<..} x * (1 + x ^ 2) powr a) = C"
	using nn_integral_has_integral_lebesgue[OF _ has_integral_Beta2[OF assms(1)]]
	by (auto simp: C_def)
	have "nn_integral lborel (\<lambda>x. indicator {0<..} x * (b + x ^ 2) powr a) =
	(\<integral>\<^sup>+x. ennreal (indicat_real {0<..} (x * sqrt b) * (b + (x * sqrt b)\<^sup>2) powr a * sqrt b) \<partial>lborel)"
	using assms
	by (subst lborel_distr_mult'[of "sqrt b"])
	(auto simp: nn_integral_density nn_integral_distr mult_ac simp flip: ennreal_mult)
	also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (b * (1 + x ^ 2)) powr a * sqrt b) \<partial>lborel)"
	using assms
	by (intro nn_integral_cong) (auto simp: indicator_def field_simps zero_less_mult_iff)
	also have "\<dots> = (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * b powr (a + 1/2) * (1 + x ^ 2) powr a) \<partial>lborel)"
	using assms
	by (intro nn_integral_cong) (auto simp: indicator_def powr_add powr_half_sqrt powr_mult)
	also have "\<dots> = b powr (a + 1/2) * (\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel)"
	using assms by (subst nn_integral_cmult [symmetric]) (simp_all add: mult_ac flip: ennreal_mult)
	also have "(\<integral>\<^sup>+x. ennreal (indicat_real {0<..} x * (1 + x ^ 2) powr a) \<partial>lborel) = C"
	using int by simp
	also have "ennreal (b powr (a + 1/2)) * ennreal C = ennreal (C * b powr (a + 1/2))"
	using assms by (subst ennreal_mult) (auto simp: C_def mult_ac Beta_def)
	finally have : "(\<integral>\<^sup>+ x. ennreal (indicat_real {0<..} x (b + x\<^sup>2) powr a) \<partial>lborel) = \<dots>" .
	hence "((\<lambda>x. indicator {0<..} x * (b + x^2) powr a) has_integral C * b powr (a + 1/2)) UNIV"
	using assms
	by (subst has_integral_iff_nn_integral_lebesgue)
	(auto simp: C_def measurable_completion nn_integral_completion Beta_def)
	also have "(\<lambda>x. indicator {0<..} x * (b + x^2) powr a) =
	(\<lambda>x. if x \<in> {0<..} then (b + x^2) powr a else 0)"
	by (auto simp: fun_eq_iff)
	finally show ?thesis
	by (subst (asm) has_integral_restrict_UNIV) (auto simp: C_def)
	qed


	subsection \<open>Asymptotics of the real $\log\Gamma$ function and its derivatives\<close>

	text \<open>
	This is the error term that occurs in the expansion of @{term ln_Gamma}. It can be shown to
	be of order $O(s^{-n})$.
	\<close>
	definition stirling_integral :: "nat \<Rightarrow> 'a :: {real_normed_div_algebra, banach} \<Rightarrow> 'a" where
	"stirling_integral n s =
	lim (\<lambda>N. integral {0..N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))"

	context
	fixes s :: complex assumes s: "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	fixes approx :: "nat \<Rightarrow> complex"
	defines "approx \<equiv> (\<lambda>N.
	(\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) - (euler_mascheroni * s + ln s) - \<comment> \<open>\<open>\<longrightarrow> ln_Gamma s\<close>\<close>
	(ln_Gamma (of_nat N) - ln (2 * pi / of_nat N) / 2 - of_nat N * ln (of_nat N) + of_nat N) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	s * (harm (N - 1) - ln (of_nat (N - 1)) - euler_mascheroni) + \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	s * (ln (of_nat N + s) - ln (of_nat (N - 1))) - \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	(1/2) * (ln (of_nat N + s) - ln (of_nat N)) + \<comment> \<open>\<open>\<longrightarrow> 0\<close>\<close>
	of_nat N * (ln (of_nat N + s) - ln (of_nat N)) - \<comment> \<open>\<open>\<longrightarrow> s\<close>\<close>
	(s - 1/2) * ln s - ln (2 * pi) / 2)"
	begin

	qualified lemma
	assumes N: "N > 0"
	shows integrable_pbernpoly_1:
	"(\<lambda>x. of_real (-pbernpoly 1 x) / (of_real x + s)) integrable_on {0..real N}"
	and integral_pbernpoly_1_aux:
	"integral {0..real N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = approx N"
	and has_integral_pbernpoly_1:
	"((\<lambda>x. pbernpoly 1 x /(x + s)) has_integral
	(\<Sum>m<N. (of_nat m + 1 / 2 + s) * (ln (of_nat m + s) -
	ln (of_nat m + 1 + s)) + 1)) {0..real N}"
	proof -
	let ?A = "(\<lambda>n. {of_nat n..of_nat (n+1)}) ` {0..<N}"
	have has_integral:
	"((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral
	(of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1)
	{of_nat n..of_nat (n + 1)}" for n
	proof (rule has_integral_spike)
	have "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (of_real x + s)) - 1) has_integral
	(of_nat n + 1/2 + s) * (ln (of_real (real (n + 1)) + s) - ln (of_real (real n) + s)) - 1)
	{of_nat n..of_nat (n + 1)}"
	using s has_integral_const_real[of 1 "of_nat n" "of_nat (n + 1)"]
	by (intro has_integral_diff has_integral_mult_right fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros has_vector_derivative_real_field
	simp: has_field_derivative_iff_has_vector_derivative [symmetric] field_simps
	complex_nonpos_Reals_iff)
	thus "((\<lambda>x. (of_nat n + 1/2 + s) * (1 / (of_real x + s)) - 1) has_integral
	(of_nat n + 1/2 + s) * (ln (of_nat (n + 1) + s) - ln (of_nat n + s)) - 1)
	{of_nat n..of_nat (n + 1)}" by simp

	show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
	if "x \<in> {of_nat n..of_nat (n + 1)} - {of_nat (n + 1)}" for x
	proof -
	have x: "x \<ge> real n" "x < real (n + 1)" using that by simp_all
	hence "floor x = int n" by linarith
	moreover from s x have "complex_of_real x \<noteq> -s"
	by (auto simp add: complex_eq_iff complex_nonpos_Reals_iff simp del: of_nat_Suc)
	ultimately show "-pbernpoly 1 x / (x + s) = (of_nat n + 1/2 + s) * (1 / (x + s)) - 1"
	by (auto simp: pbernpoly_def bernpoly_def frac_def divide_simps add_eq_0_iff2)
	qed
	qed simp_all
	hence *: "\<And>I. I\<in>?A \<Longrightarrow> ((\<lambda>x. -pbernpoly 1 x / (x + s)) has_integral
	(Inf I + 1/2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1) I"
	by (auto simp: add_ac)
	have "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral
	(\<Sum>I\<in>?A. (Inf I + 1 / 2 + s) * (ln (Inf I + 1 + s) - ln (Inf I + s)) - 1))
	(\<Union>n\<in>{0..<N}. {real n..real (n + 1)})" (is "(_ has_integral ?i) _")
	apply (intro has_integral_Union * finite_imageI)
	apply (force intro!: negligible_atLeastAtMostI pairwiseI)+
	done
	hence has_integral: "((\<lambda>x. - pbernpoly 1 x / (x + s)) has_integral ?i) {0..real N}"
	by (subst has_integral_spike_set_eq)
	(use Union_atLeastAtMost assms in \<open>auto simp: intro!: empty_imp_negligible\<close>)
	hence "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}"
	and integral: "integral {0..real N} (\<lambda>x. - pbernpoly 1 x / (x + s)) = ?i"
	by (simp_all add: has_integral_iff)
	show "(\<lambda>x. - pbernpoly 1 x / (x + s)) integrable_on {0..real N}" by fact

	note has_integral_neg[OF has_integral]
	also have "-?i = (\<Sum>x<N. (of_nat x + 1 / 2 + s) * (ln (of_nat x + s) - ln (of_nat x + 1 + s)) + 1)"
	by (subst sum.reindex)
	(simp_all add: inj_on_def atLeast0LessThan algebra_simps sum_negf [symmetric])
	finally show has_integral:
	"((\<lambda>x. of_real (pbernpoly 1 x) / (of_real x + s)) has_integral \<dots>) {0..real N}" by simp

	note integral
	also have "?i = (\<Sum>n<N. (of_nat n + 1 / 2 + s) *
	(ln (of_nat n + 1 + s) - ln (of_nat n + s))) - N" (is "_ = ?S - _")
	by (subst sum.reindex) (simp_all add: inj_on_def sum_subtractf atLeast0LessThan)
	also have "?S = (\<Sum>n<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s))) +
	(s + 1 / 2) * (\<Sum>n<N. ln (of_nat (Suc n) + s) - ln (of_nat n + s))"
	(is "_ = ?S1 + _ * ?S2") by (simp add: algebra_simps sum.distrib sum_subtractf sum_distrib_left)
	also have "?S2 = ln (of_nat N + s) - ln s" by (subst sum_lessThan_telescope) simp
	also have "?S1 = (\<Sum>n=1..<N. of_nat n * (ln (of_nat n + 1 + s) - ln (of_nat n + s)))"
	by (intro sum.mono_neutral_right) auto
	also have "\<dots> = (\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) - (\<Sum>n=1..<N. of_nat n * ln (of_nat n + s))"
	by (simp add: algebra_simps sum_subtractf)
	also have "(\<Sum>n=1..<N. of_nat n * ln (of_nat n + 1 + s)) =
	(\<Sum>n=1..<N. (of_nat n - 1) * ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
	by (induction N) (simp_all add: add_ac of_nat_diff)
	also have "\<dots> - (\<Sum>n = 1..<N. of_nat n * ln (of_nat n + s)) =
	-(\<Sum>n=1..<N. ln (of_nat n + s)) + (N - 1) * ln (of_nat N + s)"
	by (induction N) (simp_all add: algebra_simps)
	also from s have neq: "s + of_nat x \<noteq> 0" for x
	by (auto simp: complex_nonpos_Reals_iff complex_eq_iff)
	hence "(\<Sum>n=1..<N. ln (of_nat n + s)) = (\<Sum>n=1..<N. ln (of_nat n) + ln (1 + s/n))"
	by (intro sum.cong refl, subst Ln_times_of_nat [symmetric]) (auto simp: divide_simps add_ac)
	also have "\<dots> = ln (fact (N - 1)) + (\<Sum>n=1..<N. ln (1 + s/n))"
	by (induction N) (simp_all add: Ln_times_of_nat fact_reduce add_ac)
	also have "(\<Sum>n=1..<N. ln (1 + s/n)) = -(\<Sum>n=1..<N. s / n - ln (1 + s/n)) + s * (\<Sum>n=1..<N. 1 / of_nat n)"
	by (simp add: sum_distrib_left sum_subtractf)
	also from N have "ln (fact (N - 1)) = ln_Gamma (of_nat N :: complex)"
	by (simp add: ln_Gamma_complex_conv_fact)
	also have "{1..<N} = {1..N - 1}" by auto
	hence "(\<Sum>n = 1..<N. 1 / of_nat n) = (harm (N - 1) :: complex)"
	by (simp add: harm_def divide_simps)
	also have "- (ln_Gamma (of_nat N) + (- (\<Sum>n = 1..<N. s / of_nat n - ln (1 + s / of_nat n)) +
	s * harm (N - 1))) + of_nat (N - 1) * ln (of_nat N + s) +
	(s + 1 / 2) * (ln (of_nat N + s) - ln s) - of_nat N = approx N"
	using N by (simp add: field_simps of_nat_diff ln_div approx_def Ln_of_nat
	ln_Gamma_complex_of_real [symmetric])
	finally show "integral {0..of_nat N} (\<lambda>x. -of_real (pbernpoly 1 x) / (of_real x + s)) = \<dots>"
	by simp
	qed

	lemma integrable_ln_Gamma_aux:
	shows "(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n) integrable_on {0..real N}"
	proof (cases "n = 1")
	case True
	with s show ?thesis using integrable_neg[OF integrable_pbernpoly_1[of N]]
	by (cases "N = 0") (simp_all add: integrable_negligible)
	next
	case False
	from s have "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using that
	by (auto simp: complex_eq_iff add_eq_0_iff2 complex_nonpos_Reals_iff)
	with False s show ?thesis
	by (auto intro!: integrable_continuous_real continuous_intros)
	qed

	text \<open>
	This following proof is based on ``Rudiments of the theory of the gamma function''
	by Bruce Berndt~\cite{berndt}.
	\<close>
	lemma tendsto_of_real_0_I:
	"(f \<longlongrightarrow> 0) G \<Longrightarrow> ((\<lambda>x. (of_real (f x))) \<longlongrightarrow> (0 ::'a::real_normed_div_algebra)) G"
	using tendsto_of_real_iff by force

	qualified lemma integral_pbernpoly_1:
	"(\<lambda>N. integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))
	\<longlonglongrightarrow> -ln_Gamma s - s + (s - 1 / 2) * ln s + ln (2 * pi) / 2"
	proof -
	have neq: "s + of_real x \<noteq> 0" if "x \<ge> 0" for x :: real
	using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	have "(approx \<longlongrightarrow> ln_Gamma s - 0 - 0 + 0 - 0 + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
	unfolding approx_def
	proof (intro tendsto_add tendsto_diff)
	from s have s': "s \<notin> \<int>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff elim!: nonpos_Ints_cases)
	have "(\<lambda>n. \<Sum>i=1..<n. s / of_nat i - ln (1 + s / of_nat i)) \<longlonglongrightarrow>
	ln_Gamma s + euler_mascheroni * s + ln s" (is "?f \<longlonglongrightarrow> _")
	using ln_Gamma_series'_aux[OF s'] unfolding sums_def
	by (subst filterlim_sequentially_Suc [symmetric], subst (asm) sum.atLeast1_atMost_eq [symmetric])
	(simp add: atLeastLessThanSuc_atLeastAtMost)
	thus "((\<lambda>n. ?f n - (euler_mascheroni * s + ln s)) \<longlongrightarrow> ln_Gamma s) at_top"
	by (auto intro: tendsto_eq_intros)
	next
	show "(\<lambda>x. complex_of_real (ln_Gamma (real x) - ln (2 * pi / real x) / 2 -
	real x * ln (real x) + real x)) \<longlonglongrightarrow> 0"
	proof (intro tendsto_of_real_0_I
	filterlim_compose[OF tendsto_sandwich filterlim_real_sequentially])
	show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<ge> 0) at_top"
	using eventually_ge_at_top[of "1::real"]
	by eventually_elim (insert ln_Gamma_bounds(1), simp add: algebra_simps)
	show "eventually (\<lambda>x::real. ln_Gamma x - ln (2 * pi / x) / 2 - x * ln x + x \<le>
	1 / 12 * inverse x) at_top"
	using eventually_ge_at_top[of "1::real"]
	by eventually_elim (insert ln_Gamma_bounds(2), simp add: field_simps)
	show "((\<lambda>x::real. 1 / 12 * inverse x) \<longlongrightarrow> 0) at_top"
	by (intro tendsto_mult_right_zero tendsto_inverse_0_at_top filterlim_ident)
	qed simp_all
	next
	have "(\<lambda>x. s * of_real (harm (x - 1) - ln (real (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow>
	s * of_real (euler_mascheroni - euler_mascheroni)"
	by (subst filterlim_sequentially_Suc [symmetric], intro tendsto_intros)
	(insert euler_mascheroni_LIMSEQ, simp_all)
	also have "?this \<longleftrightarrow> (\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0"
	by (intro filterlim_cong refl eventually_mono[OF eventually_gt_at_top[of "1::nat"]])
	(auto simp: Ln_of_nat of_real_harm)
	finally show "(\<lambda>x. s * (harm (x - 1) - ln (of_nat (x - 1)) - euler_mascheroni)) \<longlonglongrightarrow> 0" .
	next
	have "((\<lambda>x. ln (1 + (s + 1) / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
	by (intro tendsto_intros tendsto_divide_0[OF tendsto_const])
	(simp_all add: filterlim_ident filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
	also have "ln (of_real (x + 1) + s) - ln (complex_of_real x) = ln (1 + (s + 1) / of_real x)"
	if "x > 1" for x using that s
	using Ln_divide_of_real[of x "of_real (x + 1) + s", symmetric] neq[of "x+1"]
	by (simp add: field_simps Ln_of_real)
	hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real (x + 1) + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
	finally have "((\<lambda>n. ln (of_real (real n + 1) + s) - ln (of_real (real n))) \<longlongrightarrow> 0) at_top"
	by (rule filterlim_compose[OF _ filterlim_real_sequentially])
	hence "((\<lambda>n. ln (of_nat n + s) - ln (of_nat (n - 1))) \<longlongrightarrow> 0) at_top"
	by (subst filterlim_sequentially_Suc [symmetric]) (simp add: add_ac)
	thus "(\<lambda>x. s * (ln (of_nat x + s) - ln (of_nat (x - 1)))) \<longlonglongrightarrow> 0"
	by (rule tendsto_mult_right_zero)
	next
	have "((\<lambda>x. ln (1 + s / of_real x)) \<longlongrightarrow> ln (1 + 0)) at_top" (is ?P)
	by (intro tendsto_intros tendsto_divide_0[OF tendsto_const])
	(simp_all add: filterlim_ident filterlim_at_infinity_conv_norm_at_top filterlim_abs_real)
	also have "ln (of_real x + s) - ln (of_real x) = ln (1 + s / of_real x)" if "x > 0" for x
	using Ln_divide_of_real[of x "of_real x + s"] neq[of x] that
	by (auto simp: field_simps Ln_of_real)
	hence "?P \<longleftrightarrow> ((\<lambda>x. ln (of_real x + s) - ln (of_real x)) \<longlongrightarrow> 0) at_top"
	using s by (intro filterlim_cong refl)
	(auto intro: eventually_mono [OF eventually_gt_at_top[of "1::real"]])
	finally have "(\<lambda>x. (1/2) * (ln (of_real (real x) + s) - ln (of_real (real x)))) \<longlonglongrightarrow> 0"
	by (rule tendsto_mult_right_zero[OF filterlim_compose[OF _ filterlim_real_sequentially]])
	thus "(\<lambda>x. (1/2) * (ln (of_nat x + s) - ln (of_nat x))) \<longlonglongrightarrow> 0" by simp
	next
	have "((\<lambda>x. x * (ln (1 + s / of_real x))) \<longlongrightarrow> s) at_top" (is ?P)
	by (rule stirling_limit_aux2)
	also have "ln (1 + s / of_real x) = ln (of_real x + s) - ln (of_real x)" if "x > 1" for x
	using that s Ln_divide_of_real [of x "of_real x + s", symmetric] neq[of x]
	by (auto simp: Ln_of_real field_simps)
	hence "?P \<longleftrightarrow> ((\<lambda>x. of_real x * (ln (of_real x + s) - ln (of_real x))) \<longlongrightarrow> s) at_top"
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "1::real"]])
	finally have "(\<lambda>n. of_real (real n) * (ln (of_real (real n) + s) - ln (of_real (real n)))) \<longlonglongrightarrow> s"
	by (rule filterlim_compose[OF _ filterlim_real_sequentially])
	thus "(\<lambda>n. of_nat n * (ln (of_nat n + s) - ln (of_nat n))) \<longlonglongrightarrow> s" by simp
	qed simp_all
	also have "?this \<longleftrightarrow> ((\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) \<longlongrightarrow>
	ln_Gamma s + s - (s - 1/2) * ln s - ln (2 * pi) / 2) at_top"
	using integral_pbernpoly_1_aux
	by (intro filterlim_cong refl)
	(auto intro: eventually_mono[OF eventually_gt_at_top[of "0::nat"]])
	also have "(\<lambda>N. integral {0..real N} (\<lambda>x. -pbernpoly 1 x / (x + s))) =
	(\<lambda>N. -integral {0..real N} (\<lambda>x. pbernpoly 1 x / (x + s)))"
	by (simp add: fun_eq_iff)
	finally show ?thesis by (simp add: tendsto_minus_cancel_left [symmetric] algebra_simps)
	qed


	qualified lemma pbernpoly_integral_conv_pbernpoly_integral_Suc:
	assumes "n \<ge> 1"
	shows "integral {0..real N} (\<lambda>x. pbernpoly n x / (x + s) ^ n) =
	of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) + of_nat n / of_nat (Suc n) *
	integral {0..real N} (\<lambda>x. of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)"
	proof -
	note [derivative_intros] = has_field_derivative_pbernpoly_Suc'
	define I where "I = -of_real (pbernpoly (Suc n) (of_nat N)) / (of_nat (Suc n) * (of_nat N + s) ^ n) +
	of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n +
	integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)"
	have "((\<lambda>x. (-of_nat n * inverse (of_real x + s) ^ Suc n) *
	(of_real (pbernpoly (Suc n) x) / (of_nat (Suc n))))
	has_integral -I) {0..real N}"
	proof (rule integration_by_parts_interior_strong[OF bounded_bilinear_mult])
	fix x :: real assume x: "x \<in> {0<..<real N} - real ` {0..N}"
	have "x \<notin> \<int>"
	proof
	assume "x \<in> \<int>"
	then obtain n where "x = of_int n" by (auto elim!: Ints_cases)
	with x have x': "x = of_nat (nat n)" by simp
	from x show False by (auto simp: x')
	qed
	hence "((\<lambda>x. of_real (pbernpoly (Suc n) x / of_nat (Suc n))) has_vector_derivative
	complex_of_real (pbernpoly n x)) (at x)"
	by (intro has_vector_derivative_of_real) (auto intro!: derivative_eq_intros)
	thus "((\<lambda>x. of_real (pbernpoly (Suc n) x) / of_nat (Suc n)) has_vector_derivative
	complex_of_real (pbernpoly n x)) (at x)" by simp
	from x s have "complex_of_real x + s \<noteq> 0"
	by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	thus "((\<lambda>x. inverse (of_real x + s) ^ n) has_vector_derivative
	- of_nat n * inverse (of_real x + s) ^ Suc n) (at x)" using x s assms
	by (auto intro!: derivative_eq_intros has_vector_derivative_real_field simp: divide_simps power_add [symmetric]
	simp del: power_Suc)
	next
	have "complex_of_real x + s \<noteq> 0" if "x \<ge> 0" for x
	using that s by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	thus "continuous_on {0..real N} (\<lambda>x. inverse (of_real x + s) ^ n)"
	"continuous_on {0..real N} (\<lambda>x. complex_of_real (pbernpoly (Suc n) x) / of_nat (Suc n))"
	using assms s by (auto intro!: continuous_intros simp del: of_nat_Suc)
	next
	have "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
	pbernpoly (Suc n) (of_nat N) / (of_nat (Suc n) * (of_nat N + s) ^ n) -
	of_real (bernoulli (Suc n) / real (Suc n)) / s ^ n - -I) {0..real N}"
	using integrable_ln_Gamma_aux[of n N] assms
	by (auto simp: I_def has_integral_integral divide_simps)
	thus "((\<lambda>x. inverse (of_real x + s) ^ n * of_real (pbernpoly n x)) has_integral
	inverse (of_real (real N) + s) ^ n * (of_real (pbernpoly (Suc n) (real N)) /
	of_nat (Suc n)) -
	inverse (of_real 0 + s) ^ n * (of_real (pbernpoly (Suc n) 0) / of_nat (Suc n)) - - I)
	{0..real N}" by (simp_all add: field_simps)
	qed simp_all
	also have "(\<lambda>x. - of_nat n * inverse (of_real x + s) ^ Suc n * (of_real (pbernpoly (Suc n) x) /
	of_nat (Suc n))) =
	(\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) /
	(of_real x + s) ^ Suc n))"
	by (simp add: divide_simps fun_eq_iff)
	finally have "((\<lambda>x. - (of_nat n / of_nat (Suc n) * of_real (pbernpoly (Suc n) x) /
	(of_real x + s) ^ Suc n)) has_integral - I) {0..real N}" .
	from has_integral_neg[OF this] show ?thesis
	by (auto simp add: I_def has_integral_iff algebra_simps integral_mult_right [symmetric]
	simp del: power_Suc of_nat_Suc )
	qed

	lemma pbernpoly_over_power_tendsto_0:
	assumes "n > 0"
	shows "(\<lambda>x. of_real (pbernpoly (Suc n) (real x)) / (of_nat (Suc n) * (s + of_nat x) ^ n)) \<longlonglongrightarrow> 0"
	proof -
	from s have neq: "s + of_nat n \<noteq> 0" for n
	by (auto simp: complex_eq_iff complex_nonpos_Reals_iff)
	obtain c where c: "\<And>x. norm (pbernpoly (Suc n) x) \<le> c"
	using bounded_pbernpoly by auto
	have "eventually (\<lambda>x. real x + Re s > 0) at_top"
	by real_asymp
	hence "eventually (\<lambda>x. norm (of_real (pbernpoly (Suc n) (real x)) /
	(of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
	(c / real (Suc n)) / (real x + Re s) ^ n) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim x)
	have "norm (of_real (pbernpoly (Suc n) (real x)) /
	(of_nat (Suc n) * (s + of_nat x) ^ n)) \<le>
	(c / real (Suc n)) / norm (s + of_nat x) ^ n" (is "_ \<le> ?rhs") using c[of x]
	by (auto simp: norm_divide norm_mult norm_power neq field_simps simp del: of_nat_Suc)
	also have "(real x + Re s) \<le> cmod (s + of_nat x)"
	using complex_Re_le_cmod[of "s + of_nat x"] s by (auto simp add: complex_nonpos_Reals_iff)
	hence "?rhs \<le> (c / real (Suc n)) / (real x + Re s) ^ n" using s elim c[of 0] neq[of x]
	by (intro divide_left_mono power_mono mult_pos_pos divide_nonneg_pos zero_less_power) auto
	finally show ?case .
	qed
	moreover have "(\<lambda>x. (c / real (Suc n)) / (real x + Re s) ^ n) \<longlonglongrightarrow> 0"
	using \<open>n > 0\<close> by real_asymp
	ultimately show ?thesis by (rule Lim_null_comparison)
	qed

	lemma convergent_stirling_integral:
	assumes "n > 0"
	shows "convergent (\<lambda>N. integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))" (is "convergent (?f n)")
	proof -
	have "convergent (?f (Suc n))" for n
	proof (induction n)
	case 0
	thus ?case using integral_pbernpoly_1 by (auto intro!: convergentI)
	next
	case (Suc n)
	have "convergent (\<lambda>N. ?f (Suc n) N -
	of_real (pbernpoly (Suc (Suc n)) (real N)) /
	(of_nat (Suc (Suc n)) * (s + of_nat N) ^ Suc n) +
	of_real (bernoulli (Suc (Suc n)) / (real (Suc (Suc n)))) / s ^ Suc n)"
	(is "convergent ?g")
	by (intro convergent_add convergent_diff Suc
	convergent_const convergentI[OF pbernpoly_over_power_tendsto_0]) simp_all
	also have "?g = (\<lambda>N. of_nat (Suc n) / of_nat (Suc (Suc n)) * ?f (Suc (Suc n)) N)" using s
	by (subst pbernpoly_integral_conv_pbernpoly_integral_Suc)
	(auto simp: fun_eq_iff field_simps simp del: of_nat_Suc power_Suc)
	also have "convergent \<dots> \<longleftrightarrow> convergent (?f (Suc (Suc n)))"
	by (intro convergent_mult_const_iff) (simp_all del: of_nat_Suc)
	finally show ?case .
	qed
	from this[of "n - 1"] assms show ?thesis by simp
	qed

	lemma stirling_integral_conv_stirling_integral_Suc:
	assumes "n > 0"
	shows "stirling_integral n s =
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	proof -
	have "(\<lambda>N. of_real (pbernpoly (Suc n) (real N)) / (of_nat (Suc n) * (s + of_nat N) ^ n) -
	of_real (bernoulli (Suc n)) / (real (Suc n) * s ^ n) +
	integral {0..real N} (\<lambda>x. of_nat n / of_nat (Suc n) *
	(of_real (pbernpoly (Suc n) x) / (of_real x + s) ^ Suc n)))
	\<longlonglongrightarrow> 0 - of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n) +
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s" (is "?f \<longlonglongrightarrow> _")
	unfolding stirling_integral_def integral_mult_right
	using convergent_stirling_integral[of "Suc n"] assms s
	by (intro tendsto_intros pbernpoly_over_power_tendsto_0)
	(auto simp: convergent_LIMSEQ_iff simp del: of_nat_Suc)
	also have "?this \<longleftrightarrow> (\<lambda>N. integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<longlonglongrightarrow>
	of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	using eventually_gt_at_top[of "0::nat"] pbernpoly_integral_conv_pbernpoly_integral_Suc[of n]
	assms unfolding integral_mult_right
	by (intro filterlim_cong refl) (auto elim!: eventually_mono simp del: power_Suc)
	finally show ?thesis unfolding stirling_integral_def[of n] by (rule limI)
	qed

	lemma stirling_integral_1_unfold:
	assumes "m > 0"
	shows "stirling_integral 1 s = stirling_integral m s / of_nat m -
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	proof -
	have "stirling_integral 1 s = stirling_integral (Suc m) s / of_nat (Suc m) -
	(\<Sum>k=1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))" for m
	proof (induction m)
	case (Suc m)
	let ?C = "(\<Sum>k = 1..<Suc m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	note Suc.IH
	also have "stirling_integral (Suc m) s / of_nat (Suc m) =
	stirling_integral (Suc (Suc m)) s / of_nat (Suc (Suc m)) -
	of_real (bernoulli (Suc (Suc m))) /
	(of_nat (Suc m) * of_nat (Suc (Suc m)) * s ^ Suc m)"
	(is "_ = ?A - ?B") by (subst stirling_integral_conv_stirling_integral_Suc)
	(simp_all del: of_nat_Suc power_Suc add: divide_simps)
	also have "?A - ?B - ?C = ?A - (?B + ?C)" by (rule diff_diff_eq)
	also have "?B + ?C = (\<Sum>k = 1..<Suc (Suc m). of_real (bernoulli (Suc k)) /
	(of_nat k * of_nat (Suc k) * s ^ k))"
	using s by (simp add: divide_simps)
	finally show ?case .
	qed simp_all
	note this[of "m - 1"]
	also from assms have "Suc (m - 1) = m" by simp
	finally show ?thesis .
	qed

	lemma ln_Gamma_stirling_complex:
	assumes "m > 0"
	shows "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) -
	stirling_integral m s / of_nat m"
	proof -
	have "ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 - stirling_integral 1 s"
	using limI[OF integral_pbernpoly_1] by (simp add: stirling_integral_def algebra_simps)
	also have "stirling_integral 1 s = stirling_integral m s / of_nat m -
	(\<Sum>k = 1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k))"
	using assms by (rule stirling_integral_1_unfold)
	finally show ?thesis by simp
	qed

	lemma LIMSEQ_stirling_integral:
	"n > 0 \<Longrightarrow> (\<lambda>x. integral {0..real x} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n))
	\<longlonglongrightarrow> stirling_integral n s" unfolding stirling_integral_def
	using convergent_stirling_integral[of n] by (simp only: convergent_LIMSEQ_iff)

	end

	lemmas has_integral_of_real = has_integral_linear[OF _ bounded_linear_of_real, unfolded o_def]
	lemmas integral_of_real = integral_linear[OF _ bounded_linear_of_real, unfolded o_def]

	lemma integrable_ln_Gamma_aux_real:
	assumes "0 < s"
	shows "(\<lambda>x. pbernpoly n x / (x + s) ^ n) integrable_on {0..real N}"
	proof -
	have "(\<lambda>x. complex_of_real (pbernpoly n x / (x + s) ^ n)) integrable_on {0..real N}"
	using integrable_ln_Gamma_aux[of "of_real s" n N] assms by simp
	from integrable_linear[OF this bounded_linear_Re] show ?thesis
	by (simp only: o_def Re_complex_of_real)
	qed

	lemma
	assumes "x > 0" "n > 0"
	shows stirling_integral_complex_of_real:
	"stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)"
	and LIMSEQ_stirling_integral_real:
	"(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> stirling_integral n x"
	and stirling_integral_real_convergent:
	"convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
	proof -
	have "(\<lambda>N. integral {0..real N} (\<lambda>t. of_real (pbernpoly n t / (t + x) ^ n)))
	\<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
	using LIMSEQ_stirling_integral[of "complex_of_real x" n] assms by simp
	hence "(\<lambda>N. of_real (integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n)))
	\<longlonglongrightarrow> stirling_integral n (complex_of_real x)"
	using integrable_ln_Gamma_aux_real[OF assms(1), of n]
	by (subst (asm) integral_of_real) simp
	from tendsto_Re[OF this]
	have "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> Re (stirling_integral n (complex_of_real x))" by simp
	thus "convergent (\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))"
	by (rule convergentI)
	thus "(\<lambda>N. integral {0..real N} (\<lambda>t. pbernpoly n t / (t + x) ^ n))
	\<longlonglongrightarrow> stirling_integral n x" unfolding stirling_integral_def
	by (simp add: convergent_LIMSEQ_iff)
	from tendsto_of_real[OF this, where 'a = complex]
	integrable_ln_Gamma_aux_real[OF assms(1), of n]
	have "(\<lambda>xa. integral {0..real xa}
	(\<lambda>xa. complex_of_real (pbernpoly n xa) / (complex_of_real xa + x) ^ n))
	\<longlonglongrightarrow> complex_of_real (stirling_integral n x)"
	by (subst (asm) integral_of_real [symmetric]) simp_all
	from LIMSEQ_unique[OF this LIMSEQ_stirling_integral[of "complex_of_real x" n]] assms
	show "stirling_integral n (complex_of_real x) = of_real (stirling_integral n x)" by simp
	qed

	lemma ln_Gamma_stirling_real:
	assumes "x > (0 :: real)" "m > (0::nat)"
	shows "ln_Gamma x = (x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
	stirling_integral m x / of_nat m"
	proof -
	from assms have "complex_of_real (ln_Gamma x) = ln_Gamma (complex_of_real x)"
	by (simp add: ln_Gamma_complex_of_real)
	also have "ln_Gamma (complex_of_real x) = complex_of_real (
	(x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (of_nat k * of_nat (Suc k) * x ^ k)) -
	stirling_integral m x / of_nat m)" using assms
	by (subst ln_Gamma_stirling_complex[of _ m])
	(simp_all add: Ln_of_real stirling_integral_complex_of_real)
	finally show ?thesis by (subst (asm) of_real_eq_iff)
	qed


	lemma stirling_integral_bound_aux:
	assumes n: "n > (1::nat)"
	obtains c where "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le> c / Re s ^ (n - 1)"
	proof -
	obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
	have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
	from c[of 0] have c_nonneg: "c \<ge> 0" by simp
	have "norm (stirling_integral n s) \<le> c / (real n - 1) / Re s ^ (n - 1)" if s: "Re s > 0" for s
	proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
	have pos: "x + norm s > 0" if "x \<ge> 0" for x using s that by (intro add_nonneg_pos) auto
	have nz: "of_real x + s \<noteq> 0" if "x \<ge> 0" for x using s that by (auto simp: complex_eq_iff)
	let ?bound = "\<lambda>N. c / (Re s ^ (n - 1) * (real n - 1)) -
	c / ((real N + Re s) ^ (n - 1) * (real n - 1))"
	show "eventually (\<lambda>N. norm (integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	c / (real n - 1) / Re s ^ (n - 1)) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim N)
	let ?F = "\<lambda>x. -c / ((x + Re s) ^ (n - 1) * (real n - 1))"
	from n s have "((\<lambda>x. c / (x + Re s) ^ n) has_integral (?F (real N) - ?F 0)) {0..real N}"
	by (intro fundamental_theorem_of_calculus)
	(auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
	has_field_derivative_iff_has_vector_derivative [symmetric])
	also have "?F (real N) - ?F 0 = ?bound N" by simp
	finally have *: "((\<lambda>x. c / (x + Re s) ^ n) has_integral ?bound N) {0..real N}" .
	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c / (x + Re s) ^ n)"
	proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
	fix x assume x: "x \<in> {0..real N}"
	have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
	unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / (x + Re s) ^ n"
	using x c c_nonneg s nz[of x] complex_Re_le_cmod[of "of_real x + s"]
	by (intro divide_left_mono power_mono mult_pos_pos zero_less_power add_nonneg_pos) auto
	finally show "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> \<dots>" .
	qed (insert n s * pos nz c, auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> = ?bound N" using * by (simp add: has_integral_iff)
	also have "\<dots> \<le> c / (Re s ^ (n - 1) * (real n - 1))" using c_nonneg elim s n by simp
	also have "\<dots> = c / (real n - 1) / (Re s ^ (n - 1))" by simp
	finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) /
	(of_real x + s) ^ n)) \<le> c / (real n - 1) / Re s ^ (n - 1)" .
	qed
	qed (insert s n, simp_all add: complex_nonpos_Reals_iff)
	thus ?thesis by (rule that)
	qed

	lemma stirling_integral_bound_aux_integral1:
	fixes a b c :: real and n :: nat
	assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1" "l < a - b" "r > a + b"
	shows "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral
	2c(n / (n - 1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))) {l..r}"
	proof -
	define x1 x2 where "x1 = a - b" and "x2 = a + b"
	define F1 where "F1 = (\<lambda>x::real. c / (a - x) ^ (n - 1) / (n - 1))"
	define F3 where "F3 = (\<lambda>x::real. -c / (x - a) ^ (n - 1) / (n - 1))"
	have deriv: "(F1 has_vector_derivative (c / (a - x) ^ n)) (at x within A)"
	"(F3 has_vector_derivative (c / (x - a) ^ n)) (at x within A)"
	if "x \<noteq> a" for x :: real and A
	unfolding F1_def F3_def using assms that
	by (auto intro!: derivative_eq_intros simp: divide_simps power_diff add_eq_0_iff2
	simp flip: has_field_derivative_iff_has_vector_derivative)

	from assms have "((\<lambda>x. c / (a - x) ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
	by (intro fundamental_theorem_of_calculus deriv) (auto simp: x1_def max_def split: if_splits)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}"
	using assms
	by (intro has_integral_spike_finite_eq[of "{l}"]) (auto simp: x1_def max_def split: if_splits)
	finally have I1: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l)) {l..x1}" .

	have "((\<lambda>x. c / b ^ n) has_integral (x2 - x1) * c / b ^ n) {x1..x2}"
	using has_integral_const_real[of "c / b ^ n" x1 x2] assms by (simp add: x1_def x2_def)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}"
	by (intro has_integral_spike_finite_eq[of "{x1, x2}"])
	(auto simp: x1_def x2_def split: if_splits)
	finally have I2: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral ((x2 - x1) * c / b ^ n)) {x1..x2}" .

	from assms have I3: "((\<lambda>x. c / (x - a) ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
	by (intro fundamental_theorem_of_calculus deriv) (auto simp: x2_def min_def split: if_splits)
	also have "?this \<longleftrightarrow> ((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}"
	using assms
	by (intro has_integral_spike_finite_eq[of "{r}"]) (auto simp: x2_def min_def split: if_splits)
	finally have I3: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F3 r - F3 x2)) {x2..r}" .

	have "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2)) {l..r}"
	using assms
	by (intro has_integral_combine[OF _ _ has_integral_combine[OF _ _ I1 I2] I3])
	(auto simp: x1_def x2_def)
	also have "(F1 x1 - F1 l) + ((x2 - x1) * c / b ^ n) + (F3 r - F3 x2) =
	F1 x1 - F1 l + F3 r - F3 x2 + (x2 - x1) * c / b ^ n"
	by (simp add: algebra_simps)
	also have "x2 - x1 = 2 * b"
	using assms by (simp add: x2_def x1_def min_def max_def)
	also have "2 * b * c / b ^ n = 2 * c / b ^ (n - 1)"
	using assms by (simp add: power_diff field_simps)
	also have "F1 x1 - F1 l + F3 r - F3 x2 =
	c/(n-1) * (2/b^(n-1) - 1/(a-l)^(n-1) - 1/(r-a)^(n-1))"
	using assms by (simp add: x1_def x2_def F1_def F3_def field_simps)
	also have "\<dots> + 2 * c / b ^ (n - 1) =
	2c(1 + 1/(n-1))/b^(n-1) - c/(n-1) * (1/(a-l)^(n-1) + 1/(r-a)^(n-1))"
	using assms by (simp add: field_simps)
	also have "1 + 1 / (n - 1) = n / (n - 1)"
	using assms by (simp add: field_simps)
	finally show ?thesis .
	qed

	lemma stirling_integral_bound_aux_integral2:
	fixes a b c :: real and n :: nat
	assumes "a \<ge> 0" "b > 0" "c \<ge> 0" "n > 1"
	obtains I where "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
	"I \<le> 2 * c * (n / (n - 1)) / b ^ (n-1)"
	proof -
	define l' where "l' = min l (a - b - 1)"
	define r' where "r' = max r (a + b + 1)"

	define A where "A = 2 * c * (n / (n - 1)) / b ^ (n - 1)"
	define B where "B = c / real (n - 1) * (1 / (a - l') ^ (n - 1) + 1 / (r' - a) ^ (n - 1))"

	have has_int: "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral (A - B)) {l'..r'}"
	using assms unfolding A_def B_def
	by (intro stirling_integral_bound_aux_integral1) (auto simp: l'_def r'_def)
	have "(\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) integrable_on {l..r}"
	by (rule integrable_on_subinterval[OF has_integral_integrable[OF has_int]])
	(auto simp: l'_def r'_def)
	then obtain I where has_int': "((\<lambda>x. c / max b \<bar>x - a\<bar> ^ n) has_integral I) {l..r}"
	by (auto simp: integrable_on_def)

	from assms have "I \<le> A - B"
	by (intro has_integral_subset_le[OF _ has_int' has_int]) (auto simp: l'_def r'_def)
	also have "\<dots> \<le> A"
	using assms by (simp add: B_def l'_def r'_def)
	finally show ?thesis using that[of I] has_int' unfolding A_def by blast
	qed

	lemma stirling_integral_bound_aux':
	assumes n: "n > (1::nat)" and \<alpha>: "\<alpha> \<in> {0<..<pi}"
	obtains c where "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
	norm (stirling_integral n s) \<le> c / norm s ^ (n - 1)"
	proof -
	obtain c where c: "norm (pbernpoly n x) \<le> c" for x by (rule bounded_pbernpoly[of n]) blast
	have c': "pbernpoly n x \<le> c" for x using c[of x] by (simp add: abs_real_def split: if_splits)
	from c[of 0] have c_nonneg: "c \<ge> 0" by simp

	define D where "D = c * Beta (- (real_of_int (- int n) / 2) - 1 / 2) (1 / 2) / 2"
	define C where "C = max D (2c(n/(n-1))/sin \<alpha>^(n-1))"

	have *: "norm (stirling_integral n s) \<le> C / norm s ^ (n - 1)"
	if s: "s \<in> complex_cone' \<alpha> - {0}" for s :: complex
	proof (rule Lim_norm_ubound[OF _ LIMSEQ_stirling_integral])
	from s \<alpha> have Arg: "\<bar>Arg s\<bar> \<le> \<alpha>" by (auto simp: complex_cone_altdef)
	have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> s by auto
	from s have [simp]: "s \<noteq> 0" by auto

	show "eventually (\<lambda>N. norm (integral {0..real N}
	(\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	C / norm s ^ (n - 1)) at_top"
	using eventually_gt_at_top[of "0::nat"]
	proof eventually_elim
	case (elim N)
	show ?case
	proof (cases "Re s > 0")
	case True
	have int: "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
	D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0<..}"
	using has_integral_mult_left[OF has_integral_Beta3[of "-n/2" "norm s ^ 2"], of c] assms True
	unfolding D_def by (simp add: algebra_simps)
	hence int': "((\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) has_integral
	D * (norm s ^ 2) powr (-n / 2 + 1 / 2)) {0..}"
	by (subst has_integral_interior [symmetric]) simp_all
	hence integrable: "(\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2)) integrable_on {0..}"
	by (simp add: has_integral_iff)

	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
	proof (intro integral_norm_bound_integral s ballI integrable_ln_Gamma_aux)
	have [simp]: "{0<..} - {0::real..} = {}" "{0..} - {0<..} = {0::real}"
	by auto
	have "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0<..}"
	using int by (simp add: has_integral_iff)
	also have "?this \<longleftrightarrow> (\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on {0..}"
	by (intro integrable_spike_set_eq) auto
	finally show "(\<lambda>x. c * (x\<^sup>2 + (cmod s)\<^sup>2) powr (real_of_int (- int n) / 2)) integrable_on
	{0..real N}" by (rule integrable_on_subinterval) auto
	next
	fix x assume x: "x \<in> {0..real N}"
	have nz: "complex_of_real x + s \<noteq> 0"
	using True x by (auto simp: complex_eq_iff)
	have "norm (of_real (pbernpoly n x) / (of_real x + s) ^ n) \<le> c / norm (of_real x + s) ^ n"
	unfolding norm_divide norm_power using c by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / sqrt (x ^ 2 + norm s ^ 2) ^ n"
	proof (intro divide_left_mono mult_pos_pos zero_less_power power_mono)
	show "sqrt (x\<^sup>2 + (cmod s)\<^sup>2) \<le> cmod (complex_of_real x + s)"
	using x True by (simp add: cmod_def algebra_simps power2_eq_square)
	qed (use x True c_nonneg assms nz in \<open>auto simp: add_nonneg_pos\<close>)
	also have "sqrt (x ^ 2 + norm s ^ 2) ^ n = (x ^ 2 + norm s ^ 2) powr (1/2 * n)"
	by (subst powr_powr [symmetric], subst powr_realpow)
	(auto simp: powr_half_sqrt add_nonneg_pos)
	also have "c / \<dots> = c * (x^2 + norm s^2) powr (-n / 2)"
	by (simp add: powr_minus field_simps)
	finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
	qed fact+
	also have "\<dots> \<le> integral {0..} (\<lambda>x. c * (x^2 + norm s^2) powr (-n / 2))"
	using c_nonneg
	by (intro integral_subset_le integrable integrable_on_subinterval[OF integrable]) auto
	also have "\<dots> = D * (norm s ^ 2) powr (-n / 2 + 1 / 2)"
	using int' by (simp add: has_integral_iff)
	also have "(norm s ^ 2) powr (-n / 2 + 1 / 2) = norm s powr (2 * (-n / 2 + 1 / 2))"
	by (subst powr_powr [symmetric]) auto
	also have "\<dots> = norm s powr (-real (n - 1))"
	using assms by (simp add: of_nat_diff)
	also have "D * \<dots> = D / norm s ^ (n - 1)"
	by (auto simp: powr_minus powr_realpow field_simps)
	also have "\<dots> \<le> C / norm s ^ (n - 1)"
	by (intro divide_right_mono) (auto simp: C_def)
	finally show "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le> \<dots>" .

	next

	case False
	have "cos \<bar>Arg s\<bar> = cos (Arg s)"
	by (simp add: abs_if)
	also have "cos (Arg s) = Re (rcis (norm s) (Arg s)) / norm s"
	by (subst Re_rcis) auto
	also have "\<dots> = Re s / norm s"
	by (subst rcis_cmod_Arg) auto
	also have "\<dots> \<le> cos (pi / 2)"
	using False by (auto simp: field_simps)
	finally have "\<bar>Arg s\<bar> \<ge> pi / 2"
	using Arg \<alpha> by (subst (asm) cos_mono_le_eq) auto

	have "sin \<alpha> * norm s = sin (pi - \<alpha>) * norm s"
	by simp
	also have "\<dots> \<le> sin (pi - \<bar>Arg s\<bar>) * norm s"
	using \<alpha> Arg \<open>\<bar>Arg s\<bar> \<ge> pi / 2\<close>
	by (intro mult_right_mono sin_monotone_2pi_le) auto
	also have "sin \<bar>Arg s\<bar> \<ge> 0"
	using Arg_bounded[of s] by (intro sin_ge_zero) auto
	hence "sin (pi - \<bar>Arg s\<bar>) = \<bar>sin \<bar>Arg s\<bar>\<bar>"
	by simp
	also have "\<dots> = \<bar>sin (Arg s)\<bar>"
	by (simp add: abs_if)
	also have "\<dots> * norm s = \<bar>Im (rcis (norm s) (Arg s))\<bar>"
	by (simp add: abs_mult)
	also have "\<dots> = \<bar>Im s\<bar>"
	by (subst rcis_cmod_Arg) auto
	finally have abs_Im_ge: "\<bar>Im s\<bar> \<ge> sin \<alpha> * norm s" .

	have [simp]: "Im s \<noteq> 0" "s \<noteq> 0"
	using s \<open>s \<notin> \<real>\<^sub>\<le>\<^sub>0\<close> False
	by (auto simp: cmod_def zero_le_mult_iff complex_nonpos_Reals_iff)
	have "sin \<alpha> > 0"
	using assms by (intro sin_gt_zero) auto

	obtain I where I: "((\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) has_integral I) {0..real N}"
	"I \<le> 2c(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
	using s c_nonneg assms False
	stirling_integral_bound_aux_integral2[of "-Re s" "\<bar>Im s\<bar>" c n 0 "real N"] by auto

	have "norm (integral {0..real N} (\<lambda>x. of_real (pbernpoly n x) / (of_real x + s) ^ n)) \<le>
	integral {0..real N} (\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n)"
	proof (intro integral_norm_bound_integral integrable_ln_Gamma_aux s ballI)
	show "(\<lambda>x. c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n) integrable_on {0..real N}"
	using I(1) by (simp add: has_integral_iff)
	next
	fix x assume x: "x \<in> {0..real N}"
	have nz: "complex_of_real x + s \<noteq> 0"
	by (auto simp: complex_eq_iff)
	have "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le>
	c / norm (complex_of_real x + s) ^ n"
	unfolding norm_divide norm_power using c[of x] by (intro divide_right_mono) simp_all
	also have "\<dots> \<le> c / max \<bar>Im s\<bar> \<bar>x + Re s\<bar> ^ n"
	using c_nonneg nz abs_Re_le_cmod[of "of_real x + s"] abs_Im_le_cmod[of "of_real x + s"]
	by (intro divide_left_mono power_mono mult_pos_pos zero_less_power)
	(auto simp: less_max_iff_disj)
	finally show "norm (complex_of_real (pbernpoly n x) / (complex_of_real x + s) ^ n) \<le> \<dots>" .
	qed (auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> \<le> 2c(n/(n-1)) / \<bar>Im s\<bar> ^ (n - 1)"
	using I by (simp add: has_integral_iff)
	also have "\<dots> \<le> 2c(n/(n-1)) / (sin \<alpha> * norm s) ^ (n - 1)"
	using \<open>sin \<alpha> > 0\<close> s c_nonneg abs_Im_ge
	by (intro divide_left_mono mult_pos_pos zero_less_power power_mono mult_nonneg_nonneg) auto
	also have "\<dots> = 2c(n/(n-1))/sin \<alpha>^(n-1) / norm s ^ (n - 1)"
	by (simp add: field_simps)
	also have "\<dots> \<le> C / norm s ^ (n - 1)"
	by (intro divide_right_mono) (auto simp: C_def)
	finally show ?thesis .
	qed
	qed
	qed (use that assms complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> in auto)
	thus ?thesis by (rule that)
	qed

	lemma stirling_integral_bound:
	assumes "n > 0"
	obtains c where
	"\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral n s) \<le> c / Re s ^ n"
	proof -
	let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	from stirling_integral_bound_aux[of "Suc n"] assms obtain c where
	c: "\<And>s. Re s > 0 \<Longrightarrow> norm (stirling_integral (Suc n) s) \<le> c / Re s ^ n" by auto
	define c1 where "c1 = real n / real (Suc n) * c"
	define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
	have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
	show ?thesis
	proof (rule that)
	fix s :: complex assume s: "Re s > 0"
	hence s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0" by (auto simp: complex_nonpos_Reals_iff)
	have "stirling_integral n s = ?f s" using s' assms
	by (rule stirling_integral_conv_stirling_integral_Suc)
	also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
	norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
	by (rule norm_triangle_ineq4)
	also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
	c2 / norm s ^ n" (is "_ = ?A + ?B")
	by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
	also have "?A \<le> real n / real (Suc n) * (c / Re s ^ n)"
	by (intro mult_left_mono c s) simp_all
	also have "\<dots> = c1 / Re s ^ n" by (simp add: c1_def)
	also have "c2 / norm s ^ n \<le> c2 / Re s ^ n" using s c2_nonneg
	by (intro divide_left_mono power_mono complex_Re_le_cmod mult_pos_pos zero_less_power) auto
	also have "c1 / Re s ^ n + c2 / Re s ^ n = (c1 + c2) / Re s ^ n"
	using s by (simp add: field_simps)
	finally show "norm (stirling_integral n s) \<le> (c1 + c2) / Re s ^ n" by - simp_all
	qed
	qed

	lemma stirling_integral_bound':
	assumes "n > 0" and "\<alpha> \<in> {0<..<pi}"
	obtains c where
	"\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral n s) \<le> c / norm s ^ n"
	proof -
	let ?f = "\<lambda>s. of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s -
	of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n)"
	from stirling_integral_bound_aux'[of "Suc n"] assms obtain c where
	c: "\<And>s::complex. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow>
	norm (stirling_integral (Suc n) s) \<le> c / norm s ^ n" by auto
	define c1 where "c1 = real n / real (Suc n) * c"
	define c2 where "c2 = \<bar>bernoulli (Suc n)\<bar> / real (Suc n)"
	have c2_nonneg: "c2 \<ge> 0" by (simp add: c2_def)
	show ?thesis
	proof (rule that)
	fix s :: complex assume s: "s \<in> complex_cone' \<alpha> - {0}"
	have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] assms s by auto

	have "stirling_integral n s = ?f s" using s' assms
	by (intro stirling_integral_conv_stirling_integral_Suc) auto
	also have "norm \<dots> \<le> norm (of_nat n / of_nat (Suc n) * stirling_integral (Suc n) s) +
	norm (of_real (bernoulli (Suc n)) / (of_nat (Suc n) * s ^ n))"
	by (rule norm_triangle_ineq4)
	also have "\<dots> = real n / real (Suc n) * norm (stirling_integral (Suc n) s) +
	c2 / norm s ^ n" (is "_ = ?A + ?B")
	by (simp add: norm_divide norm_mult norm_power c2_def field_simps del: of_nat_Suc)
	also have "?A \<le> real n / real (Suc n) * (c / norm s ^ n)"
	by (intro mult_left_mono c s) simp_all
	also have "\<dots> = c1 / norm s ^ n" by (simp add: c1_def)
	also have "c1 / norm s ^ n + c2 / norm s ^ n = (c1 + c2) / norm s ^ n"
	using s by (simp add: divide_simps)
	finally show "norm (stirling_integral n s) \<le> (c1 + c2) / norm s ^ n" by - simp_all
	qed
	qed


	lemma stirling_integral_holomorphic [holomorphic_intros]:
	assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
	shows "stirling_integral m holomorphic_on A"
	proof -
	from assms have [simp]: "z \<notin> \<real>\<^sub>\<le>\<^sub>0" if "z \<in> A" for z
	using that by auto
	let ?f = "\<lambda>s::complex. of_nat m * ((s - 1 / 2) * Ln s - s + of_real (ln (2 * pi) / 2) +
	(\<Sum>k=1..<m. of_real (bernoulli (Suc k)) / (of_nat k * of_nat (Suc k) * s ^ k)) -
	ln_Gamma s)"
	have "?f holomorphic_on A" using assms
	by (auto intro!: holomorphic_intros simp del: of_nat_Suc elim!: nonpos_Reals_cases)
	also have "?this \<longleftrightarrow> stirling_integral m holomorphic_on A"
	using assms by (intro holomorphic_cong refl)
	(simp_all add: field_simps ln_Gamma_stirling_complex)
	finally show "stirling_integral m holomorphic_on A" .
	qed

	lemma stirling_integral_continuous_on_complex [continuous_intros]:
	assumes m: "m > 0" and "A \<inter> \<real>\<^sub>\<le>\<^sub>0 = {}"
	shows "continuous_on A (stirling_integral m :: _ \<Rightarrow> complex)"
	by (intro holomorphic_on_imp_continuous_on stirling_integral_holomorphic assms)

	lemma has_field_derivative_stirling_integral_complex:
	fixes x :: complex
	assumes "x \<notin> \<real>\<^sub>\<le>\<^sub>0" "n > 0"
	shows "(stirling_integral n has_field_derivative deriv (stirling_integral n) x) (at x)"
	using assms
	by (intro holomorphic_derivI[OF stirling_integral_holomorphic, of n "-\<real>\<^sub>\<le>\<^sub>0"]) auto



	lemma
	assumes n: "n > 0" and "x > 0"
	shows deriv_stirling_integral_complex_of_real:
	"(deriv ^^ j) (stirling_integral n) (complex_of_real x) =
	complex_of_real ((deriv ^^ j) (stirling_integral n) x)" (is "?lhs x = ?rhs x")
	and differentiable_stirling_integral_real:
	"(deriv ^^ j) (stirling_integral n) field_differentiable at x" (is ?thesis2)
	proof -
	let ?A = "{s. Re s > 0}"
	let ?f = "\<lambda>j x. (deriv ^^ j) (stirling_integral n) (complex_of_real x)"
	let ?f' = "\<lambda>j x. complex_of_real ((deriv ^^ j) (stirling_integral n) x)"

	have [simp]: "open ?A" by (simp add: open_halfspace_Re_gt)

	have "?lhs x = ?rhs x \<and> (deriv ^^ j) (stirling_integral n) field_differentiable at x"
	if "x > 0" for x using that
	proof (induction j arbitrary: x)
	case 0
	have "((\<lambda>x. Re (stirling_integral n (of_real x))) has_field_derivative
	Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)" using 0 n
	by (auto intro!: derivative_intros has_vector_derivative_real_field
	field_differentiable_derivI holomorphic_on_imp_differentiable_at[of _ ?A]
	stirling_integral_holomorphic simp: complex_nonpos_Reals_iff)
	also have "?this \<longleftrightarrow> (stirling_integral n has_field_derivative
	Re (deriv (\<lambda>x. stirling_integral n x) (of_real x))) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] 0 n
	by (intro has_field_derivative_cong_ev refl)
	(auto elim!: eventually_mono simp: stirling_integral_complex_of_real)
	finally have "stirling_integral n field_differentiable at x"
	by (auto simp: field_differentiable_def)
	with 0 n show ?case by (auto simp: stirling_integral_complex_of_real)
	next
	case (Suc j x)
	note IH = conjunct1[OF Suc.IH] conjunct2[OF Suc.IH]
	have *: "(deriv ^^ Suc j) (stirling_integral n) (complex_of_real x) =
	of_real ((deriv ^^ Suc j) (stirling_integral n) x)" if x: "x > 0" for x
	proof -
	have "deriv ((deriv ^^ j) (stirling_integral n)) (complex_of_real x) =
	vector_derivative (\<lambda>x. (deriv ^^ j) (stirling_integral n) (of_real x)) (at x)"
	using n x
	by (intro vector_derivative_of_real_right [symmetric]
	holomorphic_on_imp_differentiable_at[of _ ?A] holomorphic_higher_deriv
	stirling_integral_holomorphic) (auto simp: complex_nonpos_Reals_iff)
	also have "\<dots> = vector_derivative (\<lambda>x. of_real ((deriv ^^ j) (stirling_integral n) x)) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] x
	by (intro vector_derivative_cong_eq) (auto elim!: eventually_mono simp: IH(1))
	also have "\<dots> = of_real (deriv ((deriv ^^ j) (stirling_integral n)) x)"
	by (intro vector_derivative_of_real_left holomorphic_on_imp_differentiable_at[of _ ?A]
	field_differentiable_imp_differentiable IH(2) x)
	finally show ?thesis by simp
	qed
	have "((\<lambda>x. Re ((deriv ^^ Suc j) (stirling_integral n) (of_real x))) has_field_derivative
	Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"
	using Suc.prems n
	by (intro derivative_intros has_vector_derivative_real_field field_differentiable_derivI
	holomorphic_on_imp_differentiable_at[of _ ?A] stirling_integral_holomorphic
	holomorphic_higher_deriv) (auto simp: complex_nonpos_Reals_iff)
	also have "?this \<longleftrightarrow> ((deriv ^^ Suc j) (stirling_integral n) has_field_derivative
	Re (deriv ((deriv ^^ Suc j) (stirling_integral n)) (of_real x))) (at x)"
	using eventually_nhds_in_open[of "{0<..}" x] Suc.prems *
	by (intro has_field_derivative_cong_ev refl) (auto elim!: eventually_mono)
	finally have "(deriv ^^ Suc j) (stirling_integral n) field_differentiable at x"
	by (auto simp: field_differentiable_def)
	with *[OF Suc.prems] show ?case by blast
	qed
	from this[OF assms(2)] show "?lhs x = ?rhs x" ?thesis2 by blast+
	qed

	text \<open>
	Unfortunately, asymptotic power series cannot, in general, be differentiated. However, since
	@{term ln_Gamma} is holomorphic on the entire positive real half-space, we can differentiate
	its asymptotic expansion after all.

	To do this, we use an ad-hoc version of the more general approach outlined in Erdelyi's
	``Asymptotic Expansions'' for holomorphic functions: We bound the value of the $j$-th derivative
	of the remainder term at some value $x$ by applying Cauchy's integral formula along a circle
	centred at $x$ with radius $\frac{1}{2} x$.
	\<close>
	lemma deriv_stirling_integral_real_bound:
	assumes m: "m > 0"
	shows "(deriv ^^ j) (stirling_integral m) \<in> O(\<lambda>x::real. 1 / x ^ (m + j))"
	proof -
	obtain c where c: "\<And>s. 0 < Re s \<Longrightarrow> cmod (stirling_integral m s) \<le> c / Re s ^ m"
	using stirling_integral_bound[OF m] by auto
	have "0 \<le> cmod (stirling_integral m 1)" by simp
	also have "\<dots> \<le> c" using c[of 1] by simp
	finally have c_nonneg: "c \<ge> 0" .
	define B where "B = c * 2 ^ (m + Suc j)"
	define B' where "B' = B * fact j / 2"

	have "eventually (\<lambda>x::real. norm ((deriv ^^ j) (stirling_integral m) x) \<le>
	B' * norm (1 / x ^ (m+ j))) at_top"
	using eventually_gt_at_top[of "0::real"]
	proof eventually_elim
	case (elim x)
	have "s \<notin> \<real>\<^sub>\<le>\<^sub>0" if "s \<in> cball (of_real x) (x/2)" for s :: complex
	proof -
	have "x - Re s \<le> norm (of_real x - s)" using complex_Re_le_cmod[of "of_real x - s"] by simp
	also from that have "\<dots> \<le> x/2" by (simp add: dist_complex_def)
	finally show ?thesis using elim by (auto simp: complex_nonpos_Reals_iff)
	qed
	hence "((\<lambda>u. stirling_integral m u / (u - of_real x) ^ Suc j) has_contour_integral
	complex_of_real (2 * pi) * \<i> / fact j *
	(deriv ^^ j) (stirling_integral m) (of_real x)) (circlepath (of_real x) (x/2))"
	using m elim
	by (intro Cauchy_has_contour_integral_higher_derivative_circlepath
	stirling_integral_continuous_on_complex stirling_integral_holomorphic) auto
	hence "norm (of_real (2 * pi) * \<i> / fact j * (deriv ^^ j) (stirling_integral m) (of_real x)) \<le>
	B / x ^ (m + Suc j) * (2 * pi * (x / 2))"
	proof (rule has_contour_integral_bound_circlepath)
	fix u :: complex assume dist: "norm (u - of_real x) = x / 2"
	have "Re (of_real x - u) \<le> norm (of_real x - u)" by (rule complex_Re_le_cmod)
	also have "\<dots> = x / 2" using dist by (simp add: norm_minus_commute)
	finally have Re_u: "Re u \<ge> x/2" using elim by simp
	have "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le>
	c / Re u ^ m / (x / 2) ^ Suc j" using Re_u elim
	unfolding norm_divide norm_power dist
	by (intro divide_right_mono zero_le_power c) simp_all
	also have "\<dots> \<le> c / (x/2) ^ m / (x / 2) ^ Suc j" using c_nonneg elim Re_u
	by (intro divide_right_mono divide_left_mono power_mono) simp_all
	also have "\<dots> = B / x ^ (m + Suc j)" using elim by (simp add: B_def field_simps power_add)
	finally show "norm (stirling_integral m u / (u - of_real x) ^ Suc j) \<le> B / x ^ (m + Suc j)" .
	qed (insert elim c_nonneg, auto simp: B_def simp del: power_Suc)
	hence "cmod ((deriv ^^ j) (stirling_integral m) (of_real x)) \<le> B' / x ^ (j + m)"
	using elim by (simp add: field_simps norm_divide norm_mult norm_power B'_def)
	with elim m show ?case by (simp_all add: add_ac deriv_stirling_integral_complex_of_real)
	qed
	thus ?thesis by (rule bigoI)
	qed

	definition stirling_sum where
	"stirling_sum j m x =
	(-1) ^ j * (\<Sum>k = 1..<m. (of_real (bernoulli (Suc k)) * pochhammer (of_nat k) j / (of_nat k *
	of_nat (Suc k))) * inverse x ^ (k + j))"

	definition stirling_sum' where
	"stirling_sum' j m x =
	(-1) ^ (Suc j) * (\<Sum>k\<le>m. (of_real (bernoulli' k) *
	pochhammer (of_nat (Suc k)) (j - 1) * inverse x ^ (k + j)))"

	lemma stirling_sum_complex_of_real:
	"stirling_sum j m (complex_of_real x) = complex_of_real (stirling_sum j m x)"
	by (simp add: stirling_sum_def pochhammer_of_real [symmetric] del: of_nat_Suc)

	lemma stirling_sum'_complex_of_real:
	"stirling_sum' j m (complex_of_real x) = complex_of_real (stirling_sum' j m x)"
	by (simp add: stirling_sum'_def pochhammer_of_real [symmetric] del: of_nat_Suc)

	lemma has_field_derivative_stirling_sum_complex [derivative_intros]:
	"Re x > 0 \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
	unfolding stirling_sum_def [abs_def] sum_distrib_left
	by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc
	simp: pochhammer_Suc power_diff)

	lemma has_field_derivative_stirling_sum_real [derivative_intros]:
	"x > (0::real) \<Longrightarrow> (stirling_sum j m has_field_derivative stirling_sum (Suc j) m x) (at x)"
	unfolding stirling_sum_def [abs_def] sum_distrib_left
	by (rule DERIV_sum) (auto intro!: derivative_eq_intros simp del: of_nat_Suc
	simp: pochhammer_Suc power_diff)

	lemma has_field_derivative_stirling_sum'_complex [derivative_intros]:
	assumes "j > 0" "Re x > 0"
	shows "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
	proof (cases j)
	case (Suc j')
	from assms have [simp]: "x \<noteq> 0" by auto
	define c where "c = (\<lambda>n. (-1) ^ Suc j * complex_of_real (bernoulli' n) *
	pochhammer (of_nat (Suc n)) j')"
	define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
	define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
	have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
	by (intro DERIV_sum)
	(auto simp: T_def T'_def intro!: derivative_eq_intros
	simp: field_simps power_add [symmetric] simp del: of_nat_Suc power_Suc of_nat_add)
	also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
	by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
	also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
	by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left
	sum_distrib_right algebra_simps pochhammer_Suc)
	finally show ?thesis .
	qed (insert assms, simp_all)

	lemma has_field_derivative_stirling_sum'_real [derivative_intros]:
	assumes "j > 0" "x > (0::real)"
	shows "(stirling_sum' j m has_field_derivative stirling_sum' (Suc j) m x) (at x)"
	proof (cases j)
	case (Suc j')
	from assms have [simp]: "x \<noteq> 0" by auto
	define c where "c = (\<lambda>n. (-1) ^ Suc j * (bernoulli' n) * pochhammer (of_nat (Suc n)) j')"
	define T where "T = (\<lambda>n x. c n * inverse x ^ (j + n))"
	define T' where "T' = (\<lambda>n x. - (of_nat (j + n)) * c n * inverse x ^ (Suc (j + n)))"
	have "((\<lambda>x. \<Sum>k\<le>m. T k x) has_field_derivative (\<Sum>k\<le>m. T' k x)) (at x)" using assms Suc
	by (intro DERIV_sum)
	(auto simp: T_def T'_def intro!: derivative_eq_intros
	simp: field_simps power_add [symmetric] simp del: of_nat_Suc power_Suc of_nat_add)
	also have "(\<lambda>x. (\<Sum>k\<le>m. T k x)) = stirling_sum' j m"
	by (simp add: Suc T_def c_def stirling_sum'_def fun_eq_iff add_ac mult.assoc sum_distrib_left)
	also have "(\<Sum>k\<le>m. T' k x) = stirling_sum' (Suc j) m x"
	by (simp add: T'_def c_def Suc stirling_sum'_def sum_distrib_left
	sum_distrib_right algebra_simps pochhammer_Suc)
	finally show ?thesis .
	qed (insert assms, simp_all)

	lemma higher_deriv_stirling_sum_complex:
	"Re x > 0 \<Longrightarrow> (deriv ^^ i) (stirling_sum j m) x = stirling_sum (i + j) m x"
	proof (induction i arbitrary: x)
	case (Suc i)
	have "deriv ((deriv ^^ i) (stirling_sum j m)) x = deriv (stirling_sum (i + j) m) x"
	using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: open_halfspace_Re_gt Suc.IH)
	also from Suc.prems have "\<dots> = stirling_sum (Suc (i + j)) m x"
	by (intro DERIV_imp_deriv has_field_derivative_stirling_sum_complex)
	finally show ?case by simp
	qed simp_all


	definition Polygamma_approx :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a :: {real_normed_field, ln}" where
	"Polygamma_approx j m =
	(deriv ^^ j) (\<lambda>x. (x - 1 / 2) * ln x - x + of_real (ln (2 * pi)) / 2 + stirling_sum 0 m x)"

	lemma Polygamma_approx_Suc: "Polygamma_approx (Suc j) m = deriv (Polygamma_approx j m)"
	by (simp add: Polygamma_approx_def)

	lemma Polygamma_approx_0:
	"Polygamma_approx 0 m x = (x - 1/2) * ln x - x + of_real (ln (2*pi)) / 2 + stirling_sum 0 m x"
	by (simp add: Polygamma_approx_def)

	lemma Polygamma_approx_1_complex:
	"Re x > 0 \<Longrightarrow>
	Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
	unfolding Polygamma_approx_Suc Polygamma_approx_0
	by (intro DERIV_imp_deriv)
	(auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)

	lemma Polygamma_approx_1_real:
	"x > (0 :: real) \<Longrightarrow>
	Polygamma_approx (Suc 0) m x = ln x - 1 / (2*x) + stirling_sum (Suc 0) m x"
	unfolding Polygamma_approx_Suc Polygamma_approx_0
	by (intro DERIV_imp_deriv)
	(auto intro!: derivative_eq_intros elim!: nonpos_Reals_cases simp: field_simps)

	lemma stirling_sum_2_conv_stirling_sum'_1:
	fixes x :: "'a :: {real_div_algebra, field_char_0}"
	assumes "m > 0" "x \<noteq> 0"
	shows "stirling_sum' 1 m x = 1 / x + 1 / (2 * x^2) + stirling_sum 2 m x"
	proof -
	have pochhammer_2: "pochhammer (of_nat k) 2 = of_nat k * of_nat (Suc k)" for k
	by (simp add: pochhammer_Suc eval_nat_numeral add_ac)
	have "stirling_sum 2 m x =
	(\<Sum>k = Suc 0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))"
	unfolding stirling_sum_def pochhammer_2 power2_minus power_one mult_1_left
	by (intro sum.cong refl)
	(simp_all add: stirling_sum_def pochhammer_2 power2_eq_square divide_simps bernoulli'_def
	del: of_nat_Suc power_Suc)
	also have "1 / (2 * x^2) + \<dots> =
	(\<Sum>k=0..<m. of_real (bernoulli' (Suc k)) * inverse x ^ Suc (Suc k))" using assms
	by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: power2_eq_square field_simps)
	also have "1 / x + \<dots> = (\<Sum>k=0..<Suc m. of_real (bernoulli' k) * inverse x ^ Suc k)"
	by (subst sum.atLeast0_lessThan_Suc_shift) (simp_all add: bernoulli'_def divide_simps)
	also have "\<dots> = (\<Sum>k\<le>m. of_real (bernoulli' k) * inverse x ^ Suc k)"
	by (intro sum.cong) auto
	also have "\<dots> = stirling_sum' 1 m x" by (simp add: stirling_sum'_def)
	finally show ?thesis by (simp add: add_ac)
	qed

	lemma Polygamma_approx_2_real:
	assumes "x > (0::real)" "m > 0"
	shows "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
	proof -
	have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
	using eventually_nhds_in_open[of "{0<..}" x] assms
	by (intro deriv_cong_ev) (auto elim!: eventually_mono simp: Polygamma_approx_1_real)
	also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
	by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros
	elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
	also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
	by (simp add: eval_nat_numeral)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_2_complex:
	assumes "Re x > 0" "m > 0"
	shows "Polygamma_approx (Suc (Suc 0)) m x = stirling_sum' 1 m x"
	proof -
	have "Polygamma_approx (Suc (Suc 0)) m x = deriv (Polygamma_approx (Suc 0) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (\<lambda>x. ln x - 1 / (2*x) + stirling_sum (Suc 0) m x) x"
	using eventually_nhds_in_open[of "{s. Re s > 0}" x] assms
	by (intro deriv_cong_ev)
	(auto simp: open_halfspace_Re_gt elim!: eventually_mono simp: Polygamma_approx_1_complex)
	also have "\<dots> = 1 / x + 1 / (2*x^2) + stirling_sum (Suc (Suc 0)) m x" using assms
	by (intro DERIV_imp_deriv) (auto intro!: derivative_eq_intros
	elim!: nonpos_Reals_cases simp: field_simps power2_eq_square)
	also have "\<dots> = stirling_sum' 1 m x" using stirling_sum_2_conv_stirling_sum'_1[of m x] assms
	by (subst stirling_sum_2_conv_stirling_sum'_1) (auto simp: eval_nat_numeral)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_ge_2_real:
	assumes "x > (0::real)" "m > 0"
	shows "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
	using assms(1)
	proof (induction j arbitrary: x)
	case (0 x)
	with assms show ?case by (simp add: Polygamma_approx_2_real)
	next
	case (Suc j x)
	have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
	using eventually_nhds_in_open[of "{0<..}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH)
	also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
	by (intro DERIV_imp_deriv derivative_intros) simp_all
	finally show ?case .
	qed

	lemma Polygamma_approx_ge_2_complex:
	assumes "Re x > 0" "m > 0"
	shows "Polygamma_approx (Suc (Suc j)) m x = stirling_sum' (Suc j) m x"
	using assms(1)
	proof (induction j arbitrary: x)
	case (0 x)
	with assms show ?case by (simp add: Polygamma_approx_2_complex)
	next
	case (Suc j x)
	have "Polygamma_approx (Suc (Suc (Suc j))) m x = deriv (Polygamma_approx (Suc (Suc j)) m) x"
	by (simp add: Polygamma_approx_Suc)
	also have "\<dots> = deriv (stirling_sum' (Suc j) m) x"
	using eventually_nhds_in_open[of "{x. Re x > 0}" x] Suc.prems
	by (intro deriv_cong_ev refl) (auto elim!: eventually_mono simp: Suc.IH open_halfspace_Re_gt)
	also have "\<dots> = stirling_sum' (Suc (Suc j)) m x" using Suc.prems
	by (intro DERIV_imp_deriv derivative_intros) simp_all
	finally show ?case .
	qed

	lemma Polygamma_approx_complex_of_real:
	assumes "x > 0" "m > 0"
	shows "Polygamma_approx j m (complex_of_real x) = of_real (Polygamma_approx j m x)"
	proof (cases j)
	case 0
	with assms show ?thesis by (simp add: Polygamma_approx_0 Ln_of_real stirling_sum_complex_of_real)
	next
	case [simp]: (Suc j')
	thus ?thesis
	proof (cases j')
	case 0
	with assms show ?thesis
	by (simp add: Polygamma_approx_1_complex
	Polygamma_approx_1_real stirling_sum_complex_of_real Ln_of_real)
	next
	case (Suc j'')
	with assms show ?thesis
	by (simp add: Polygamma_approx_ge_2_complex Polygamma_approx_ge_2_real
	stirling_sum'_complex_of_real)
	qed
	qed

	lemma higher_deriv_Polygamma_approx [simp]:
	"(deriv ^^ j) (Polygamma_approx i m) = Polygamma_approx (j + i) m"
	by (simp add: Polygamma_approx_def funpow_add)

	lemma stirling_sum_holomorphic [holomorphic_intros]:
	"0 \<notin> A \<Longrightarrow> stirling_sum j m holomorphic_on A"
	unfolding stirling_sum_def by (intro holomorphic_intros) auto

	lemma Polygamma_approx_holomorphic [holomorphic_intros]:
	"Polygamma_approx j m holomorphic_on {s. Re s > 0}"
	unfolding Polygamma_approx_def
	by (intro holomorphic_intros) (auto simp: open_halfspace_Re_gt elim!: nonpos_Reals_cases)

	lemma higher_deriv_lnGamma_stirling:
	assumes m: "m > 0"
	shows "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
	proof -
	have "eventually (\<lambda>x. \<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar> =
	inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>) at_top"
	using eventually_gt_at_top[of "0::real"]
	proof eventually_elim
	case (elim x)
	note x = this
	have "\<forall>\<^sub>F y in nhds (complex_of_real x). y \<in> - \<real>\<^sub>\<le>\<^sub>0"
	using elim by (intro eventually_nhds_in_open) auto
	hence "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) =
	(deriv ^^ j) (\<lambda>x. (-inverse (of_nat m)) * stirling_integral m x) (complex_of_real x)"
	using x m
	by (intro higher_deriv_cong_ev refl)
	(auto elim!: eventually_mono simp: ln_Gamma_stirling_complex Polygamma_approx_def
	field_simps open_halfspace_Re_gt stirling_sum_def)
	also have "\<dots> = - inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (of_real x)" using x m
	by (intro higher_deriv_cmult[of _ "-\<real>\<^sub>\<le>\<^sub>0"] stirling_integral_holomorphic)
	(auto simp: open_halfspace_Re_gt)
	also have "(deriv ^^ j) (\<lambda>x. ln_Gamma x - Polygamma_approx 0 m x) (complex_of_real x) =
	(deriv ^^ j) ln_Gamma (of_real x) - (deriv ^^ j) (Polygamma_approx 0 m) (of_real x)"
	using x
	by (intro higher_deriv_diff[of _ "{s. Re s > 0}"])
	(auto intro!: holomorphic_intros elim!: nonpos_Reals_cases simp: open_halfspace_Re_gt)
	also have "(deriv ^^ j) (Polygamma_approx 0 m) (complex_of_real x) =
	of_real (Polygamma_approx j m x)" using x m
	by (simp add: Polygamma_approx_complex_of_real)
	also have "norm (- inverse (of_nat m) * (deriv ^^ j) (stirling_integral m) (complex_of_real x)) =
	inverse (real m) * \<bar>(deriv ^^ j) (stirling_integral m) x\<bar>"
	using x m by (simp add: norm_mult norm_inverse deriv_stirling_integral_complex_of_real)
	also have "(deriv ^^ j) ln_Gamma (complex_of_real x) = of_real ((deriv ^^ j) ln_Gamma x)" using x
	by (simp add: higher_deriv_ln_Gamma_complex_of_real)
	also have "norm (\<dots> - of_real (Polygamma_approx j m x)) =
	\<bar>(deriv ^^ j) ln_Gamma x - Polygamma_approx j m x\<bar>"
	by (simp only: of_real_diff [symmetric] norm_of_real)
	finally show ?case .
	qed
	from bigthetaI_cong[OF this] m
	have "(\<lambda>x::real. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x) \<in>
	\<Theta>(\<lambda>x. (deriv ^^ j) (stirling_integral m) x)" by simp
	also have "(\<lambda>x::real. (deriv ^^ j) (stirling_integral m) x) \<in> O(\<lambda>x. 1 / x ^ (m + j))" using m
	by (rule deriv_stirling_integral_real_bound)
	finally show ?thesis .
	qed

	lemma Polygamma_approx_1_real':
	assumes x: "(x::real) > 0" and m: "m > 0"
	shows "Polygamma_approx 1 m x = ln x - (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)"
	proof -
	have "Polygamma_approx 1 m x = ln x - (1 / (2 * x) +
	(\<Sum>k=Suc 0..<m. bernoulli (Suc k) * inverse x ^ Suc k / real (Suc k)))"
	(is "_ = _ - (_ + ?S)") using x by (simp add: Polygamma_approx_1_real stirling_sum_def)
	also have "?S = (\<Sum>k=Suc 0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))"
	by (intro sum.cong refl) (simp_all add: bernoulli'_def)
	also have "1 / (2 * x) + \<dots> =
	(\<Sum>k=0..<m. bernoulli' (Suc k) * inverse x ^ Suc k / real (Suc k))" using m
	by (subst (2) sum.atLeast_Suc_lessThan) (simp_all add: field_simps)
	also have "\<dots> = (\<Sum>k = Suc 0..m. bernoulli' k * inverse x ^ k / real k)" using assms
	by (subst sum.shift_bounds_Suc_ivl [symmetric]) (simp add: atLeastLessThanSuc_atLeastAtMost)
	finally show ?thesis .
	qed

	theorem
	assumes m: "m > 0"
	shows ln_Gamma_real_asymptotics:
	"(\<lambda>x. ln_Gamma x - ((x - 1 / 2) * ln x - x + ln (2 * pi) / 2 +
	(\<Sum>k = 1..<m. bernoulli (Suc k) / (real k * real (Suc k)) / x^k)))
	\<in> O(\<lambda>x. 1 / x ^ m)" (is ?th1)
	and Digamma_real_asymptotics:
	"(\<lambda>x. Digamma x - (ln x - (\<Sum>k=1..m. bernoulli' k / real k / x ^ k)))
	\<in> O(\<lambda>x. 1 / (x ^ Suc m))" (is ?th2)
	and Polygamma_real_asymptotics: "j > 0 \<Longrightarrow>
	(\<lambda>x. Polygamma j x - (- 1) ^ Suc j * (\<Sum>k\<le>m. bernoulli' k *
	pochhammer (real (Suc k)) (j - 1) / x ^ (k + j)))
	\<in> O(\<lambda>x. 1 / x ^ (m+j+1))" (is "_ \<Longrightarrow> ?th3")
	proof -
	define G :: "nat \<Rightarrow> real \<Rightarrow> real" where
	"G = (\<lambda>m. if m = 0 then ln_Gamma else Polygamma (m - 1))"
	have *: "(\<lambda>x. G j x - h x) \<in> O(\<lambda>x. 1 / x ^ (m + j))"
	if "\<And>x::real. x > 0 \<Longrightarrow> Polygamma_approx j m x = h x" for j h
	proof -
	have "(\<lambda>x. G j x - h x) \<in>
	\<Theta>(\<lambda>x. (deriv ^^ j) ln_Gamma x - Polygamma_approx j m x)" (is "_ \<in> \<Theta>(?f)")
	using that
	by (intro bigthetaI_cong) (auto intro: eventually_mono[OF eventually_gt_at_top[of "0::real"]]
	simp del: funpow.simps simp: higher_deriv_ln_Gamma_real G_def)
	also have "?f \<in> O(\<lambda>x::real. 1 / x ^ (m + j))" using m
	by (rule higher_deriv_lnGamma_stirling)
	finally show ?thesis .
	qed

	note [[simproc del: simplify_landau_sum]]
	from *[OF Polygamma_approx_0] assms show ?th1
	by (simp add: G_def Polygamma_approx_0 stirling_sum_def field_simps)
	from *[OF Polygamma_approx_1_real'] assms show ?th2 by (simp add: G_def field_simps)

	assume j: "j > 0"
	from *[OF Polygamma_approx_ge_2_real, of "j - 1"] assms j show ?th3
	by (simp add: G_def stirling_sum'_def power_add power_diff field_simps)
	qed




	subsection \<open>Asymptotics of the complex Gamma function\<close>

	text \<open>
	The \<open>m\<close>-th order remainder of Stirling's formula for $\log\Gamma$ is $O(s^{-m})$ uniformly over
	any complex cone $\text{Arg}(z) \leq \alpha$, $z\neq 0$ for any angle
	$\alpha\in(0, \pi)$. This means that there is bounded by $c z^{-m}$ for some constant $c$ for
	all $z$ in this cone.
	\<close>
	context
	fixes F and \<alpha>
	assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
	defines "F \<equiv> principal (complex_cone' \<alpha> - {0})"
	begin

	lemma stirling_integral_bigo:
	fixes m :: nat
	assumes m: "m > 0"
	shows "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
	proof -
	obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
	using stirling_integral_bound'[OF \<open>m > 0\<close> \<alpha>] by blast
	have "0 \<le> norm (stirling_integral m 1 :: complex)"
	by simp
	also have "\<dots> \<le> c"
	using c[of 1] \<alpha> by simp
	finally have "c \<ge> 0" .

	have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha> - {0}) F"
	unfolding F_def by (auto simp: eventually_principal)
	hence "eventually (\<lambda>s. norm (stirling_integral m s) \<le>
	c * norm (1 / s ^ m)) F"
	by eventually_elim (use c in \<open>simp add: norm_divide norm_power\<close>)
	thus "stirling_integral m \<in> O[F](\<lambda>s. 1 / s ^ m)"
	by (intro bigoI[of _ c]) auto
	qed

	end

	text \<open>
	The following is a more explicit statement of this:
	\<close>
	theorem ln_Gamma_complex_asymptotics_explicit:
	fixes m :: nat and \<alpha> :: real
	assumes "m > 0" and "\<alpha> \<in> {0<..<pi}"
	obtains C :: real and R :: "complex \<Rightarrow> complex"
	where "\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
	ln_Gamma s = (s - 1/2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
	and "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> norm (R s) \<le> C / norm s ^ m"
	proof -
	obtain c where c: "\<And>s. s \<in> complex_cone' \<alpha> - {0} \<Longrightarrow> norm (stirling_integral m s) \<le> c / norm s ^ m"
	using stirling_integral_bound'[OF assms] by blast
	have "0 \<le> norm (stirling_integral m 1 :: complex)"
	by simp
	also have "\<dots> \<le> c"
	using c[of 1] assms by simp
	finally have "c \<ge> 0" .
	define R where "R = (\<lambda>s::complex. stirling_integral m s / of_nat m)"
	show ?thesis
	proof (rule that)
	from ln_Gamma_stirling_complex[of _ m] assms show
	"\<forall>s::complex. s \<notin> \<real>\<^sub>\<le>\<^sub>0 \<longrightarrow>
	ln_Gamma s = (s - 1 / 2) * ln s - s + ln (2 * pi) / 2 +
	(\<Sum>k=1..<m. bernoulli (k+1) / (k * (k+1) * s ^ k)) - R s"
	by (auto simp add: R_def algebra_simps)
	show "\<forall>s. s \<noteq> 0 \<and> \<bar>Arg s\<bar> \<le> \<alpha> \<longrightarrow> cmod (R s) \<le> c / real m / cmod s ^ m"
	proof (safe, goal_cases)
	case (1 s)
	show ?case
	using 1 c[of s] assms
	by (auto simp: complex_cone_altdef abs_le_iff R_def norm_divide field_simps)
	qed
	qed
	qed


	text \<open>
	Lastly, we can also derive the asymptotics of $\Gamma$ itself:
	\[\Gamma(z) \sim \sqrt{2\pi / z} \left(\frac{z}{e}\right)^z\]
	uniformly for $\|z\|\to\infty$ within the cone $\text{Arg}(z) \leq \alpha$ for $\alpha\in(0,\pi)$:
	\<close>

	context
	fixes F and \<alpha>
	assumes \<alpha>: "\<alpha> \<in> {0<..<pi}"
	defines "F \<equiv> inf at_infinity (principal (complex_cone' \<alpha>))"
	begin

	lemma Gamma_complex_asymp_equiv:
	"Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2))"
	proof -
	define I :: "complex \<Rightarrow> complex" where "I = stirling_integral 1"
	have "eventually (\<lambda>s. s \<in> complex_cone' \<alpha>) F"
	by (auto simp: eventually_inf_principal F_def)
	moreover have "eventually (\<lambda>s. s \<noteq> 0) F"
	unfolding F_def eventually_inf_principal
	using eventually_not_equal_at_infinity by eventually_elim auto
	ultimately have "eventually (\<lambda>s. Gamma s =
	sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)) F"
	proof eventually_elim
	case (elim s)
	from elim have s': "s \<notin> \<real>\<^sub>\<le>\<^sub>0"
	using complex_cone_inter_nonpos_Reals[of "-\<alpha>" \<alpha>] \<alpha> by auto
	from elim have [simp]: "s \<noteq> 0" by auto
	from s' have "Gamma s = exp (ln_Gamma s)"
	unfolding Gamma_complex_altdef using nonpos_Ints_subset_nonpos_Reals by auto
	also from s' have "ln_Gamma s = (s-1/2) * Ln s - s + complex_of_real (ln (2 * pi) / 2) - I s"
	by (subst ln_Gamma_stirling_complex[of _ 1]) (simp_all add: exp_add exp_diff I_def)
	also have "exp \<dots> = exp ((s - 1 / 2) * Ln s) / exp s *
	exp (complex_of_real (ln (2 * pi) / 2)) / exp (I s)"
	unfolding exp_diff exp_add by (simp add: exp_diff exp_add)
	also have "exp ((s - 1 / 2) * Ln s) = s powr (s - 1 / 2)"
	by (simp add: powr_def)
	also have "exp (complex_of_real (ln (2 * pi) / 2)) = sqrt (2 * pi)"
	by (subst exp_of_real) (auto simp: powr_def simp flip: powr_half_sqrt)
	also have "exp s = exp 1 powr s"
	by (simp add: powr_def)
	also have "s powr (s - 1 / 2) / exp 1 powr s = (s powr s / exp 1 powr s) / s powr (1/2)"
	by (subst powr_diff) auto
	also have *: "Ln (s / exp 1) = Ln s - 1"
	using Ln_divide_of_real[of "exp 1" s] by (simp flip: exp_of_real)
	hence "s powr s / exp 1 powr s = (s / exp 1) powr s"
	unfolding powr_def by (subst *) (auto simp: exp_diff field_simps)
	finally show "Gamma s = sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s)"
	by (simp add: algebra_simps)
	qed
	hence "Gamma \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / exp (I s))"
	by (rule asymp_equiv_refl_ev)
	also have "\<dots> \<sim>[F] (\<lambda>s. sqrt (2 * pi) * (s / exp 1) powr s / s powr (1 / 2) / 1)"
	proof (intro asymp_equiv_intros)
	have "F \<le> principal (complex_cone' \<alpha> - {0})"
	unfolding le_principal F_def eventually_inf_principal
	using eventually_not_equal_at_infinity by eventually_elim auto
	moreover have "I \<in> O[principal (complex_cone' \<alpha> - {0})](\<lambda>s. 1 / s)"
	using stirling_integral_bigo[of \<alpha> 1] \<alpha> unfolding F_def by (simp add: I_def)
	ultimately have "I \<in> O[F](\<lambda>s. 1 / s)"
	by (rule landau_o.big.filter_mono)
	also have "(\<lambda>s. 1 / s) \<in> o[F](\<lambda>s. 1)"
	proof (rule landau_o.smallI)
	fix c :: real
	assume c: "c > 0"
	hence "eventually (\<lambda>z::complex. norm z \<ge> 1 / c) at_infinity"
	by (auto simp: eventually_at_infinity)
	moreover have "eventually (\<lambda>z::complex. z \<noteq> 0) at_infinity"
	by (rule eventually_not_equal_at_infinity)
	ultimately show "eventually (\<lambda>z::complex. norm (1 / z) \<le> c * norm (1 :: complex)) F"
	unfolding F_def eventually_inf_principal
	by eventually_elim (use \<open>c > 0\<close> in \<open>auto simp: norm_divide field_simps\<close>)
	qed
	finally have "I \<in> o[F](\<lambda>s. 1)" .
	from smalloD_tendsto[OF this] have [tendsto_intros]: "(I \<longlongrightarrow> 0) F"
	by simp
	show "(\<lambda>x. exp (I x)) \<sim>[F] (\<lambda>x. 1)"
	by (rule asymp_equivI' tendsto_eq_intros refl \| simp)+
	qed
	finally show ?thesis by simp
	qed

	end

	end
	diff --git a/thys/Sturm_Sequences/Sturm_Method.thy b/thys/Sturm_Sequences/Sturm_Method.thy
	--- a/thys/Sturm_Sequences/Sturm_Method.thy
	+++ b/thys/Sturm_Sequences/Sturm_Method.thy
	@@ -1,583 +1,583 @@
	section \<open>The ``sturm'' proof method\<close>

	(* Author: Manuel Eberl <manuel@pruvisto.org> *)
	theory Sturm_Method
	imports Sturm_Theorem
	begin

	subsection \<open>Preliminary lemmas\<close>

	text \<open>
	In this subsection, we prove lemmas that reduce root counting and
	related statements to simple, computable expressions using the
	@{term "count_roots"} function family.
	\<close>

	lemma poly_card_roots_less_leq:
	"card {x. a < x \<and> x \<le> b \<and> poly p x = 0} = count_roots_between p a b"
	by (simp add: count_roots_between_correct)

	lemma poly_card_roots_leq_leq:
	"card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
	( count_roots_between p a b +
	(if (a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0) then 1 else 0))"
	proof (cases "(a \<le> b \<and> poly p a = 0 \<and> p \<noteq> 0) \<or> (a = b \<and> p = 0)")
	case False
	note False' = this
	thus ?thesis
	proof (cases "p = 0")
	case False
	with False' have "poly p a \<noteq> 0 \<or> a > b" by auto
	hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
	{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
	by (auto simp: less_eq_real_def)
	thus ?thesis using poly_card_roots_less_leq False'
	by (auto split: if_split_asm)
	next
	case True
	have "{x. a \<le> x \<and> x \<le> b} = {a..b}"
	"{x. a < x \<and> x \<le> b} = {a<..b}" by auto
	with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x \<le> b} = 0"
	by (auto simp add: card_eq_0_iff infinite_Ioc infinite_Icc)
	with True False show ?thesis
	- using count_roots_between_correct by (simp add: )
	+ using count_roots_between_correct by simp
	qed
	next
	case True
	note True' = this
	have fin: "finite {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0}"
	proof (cases "p = 0")
	case True
	with True' have "a = b" by simp
	hence "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} = {b}" using True by auto
	thus ?thesis by simp
	next
	case False
	from poly_roots_finite[OF this] show ?thesis by fast
	qed
	with True have "{x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
	insert a {x. a < x \<and> x \<le> b \<and> poly p x = 0}" by auto
	hence "card {x. a \<le> x \<and> x \<le> b \<and> poly p x = 0} =
	Suc (card {x. a < x \<and> x \<le> b \<and> poly p x = 0})" using fin by force
	thus ?thesis using True count_roots_between_correct by simp
	qed

	lemma poly_card_roots_less_less:
	"card {x. a < x \<and> x < b \<and> poly p x = 0} =
	( count_roots_between p a b -
	(if poly p b = 0 \<and> a < b \<and> p \<noteq> 0 then 1 else 0))"
	proof (cases "poly p b = 0 \<and> a < b \<and> p \<noteq> 0")
	case False
	note False' = this
	show ?thesis
	proof (cases "p = 0")
	case True
	have [simp]: "{x. a < x \<and> x < b} = {a<..<b}"
	"{x. a < x \<and> x \<le> b} = {a<..b}" by auto
	with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a < x \<and> x < b} = 0"
	by (auto simp add: card_eq_0_iff infinite_Ioo infinite_Ioc)
	with True False' show ?thesis
	by (auto simp: count_roots_between_correct)
	next
	case False
	with False' have "{x. a < x \<and> x < b \<and> poly p x = 0} =
	{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
	by (auto simp: less_eq_real_def)
	thus ?thesis using poly_card_roots_less_leq False by auto
	qed
	next
	case True
	with poly_roots_finite
	have fin: "finite {x. a < x \<and> x < b \<and> poly p x = 0}" by fast
	from True have "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
	insert b {x. a < x \<and> x < b \<and> poly p x = 0}" by auto
	hence "Suc (card {x. a < x \<and> x < b \<and> poly p x = 0}) =
	card {x. a < x \<and> x \<le> b \<and> poly p x = 0}" using fin by force
	also note count_roots_between_correct[symmetric]
	finally show ?thesis using True by simp
	qed

	lemma poly_card_roots_leq_less:
	"card {x::real. a \<le> x \<and> x < b \<and> poly p x = 0} =
	( count_roots_between p a b +
	(if p \<noteq> 0 \<and> a < b \<and> poly p a = 0 then 1 else 0) -
	(if p \<noteq> 0 \<and> a < b \<and> poly p b = 0 then 1 else 0))"
	proof (cases "p = 0 \<or> a \<ge> b")
	case True
	note True' = this
	show ?thesis
	proof (cases "a \<ge> b")
	case False
	hence "{x. a < x \<and> x \<le> b} = {a<..b}"
	"{x. a \<le> x \<and> x < b} = {a..<b}" by auto
	with True False have "card {x. a < x \<and> x \<le> b} = 0" "card {x. a \<le> x \<and> x < b} = 0"
	by (auto simp add: card_eq_0_iff infinite_Ico infinite_Ioc)
	with False True' show ?thesis
	by (simp add: count_roots_between_correct)
	next
	case True
	with True' have "{x. a \<le> x \<and> x < b \<and> poly p x = 0} =
	{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
	by (auto simp: less_eq_real_def)
	thus ?thesis using poly_card_roots_less_leq True by simp
	qed
	next
	case False
	let ?A = "{x. a \<le> x \<and> x < b \<and> poly p x = 0}"
	let ?B = "{x. a < x \<and> x \<le> b \<and> poly p x = 0}"
	let ?C = "{x. x = b \<and> poly p x = 0}"
	let ?D = "{x. x = a \<and> poly p a = 0}"
	have CD_if: "?C = (if poly p b = 0 then {b} else {})"
	"?D = (if poly p a = 0 then {a} else {})" by auto
	from False poly_roots_finite
	have [simp]: "finite ?A" "finite ?B" "finite ?C" "finite ?D"
	by (fast, fast, simp_all)

	from False have "?A = (?B \<union> ?D) - ?C" by (auto simp: less_eq_real_def)
	with False have "card ?A = card ?B + (if poly p a = 0 then 1 else 0) -
	(if poly p b = 0 then 1 else 0)" by (auto simp: CD_if)
	also note count_roots_between_correct[symmetric]
	finally show ?thesis using False by simp
	qed

	lemma poly_card_roots:
	"card {x::real. poly p x = 0} = count_roots p"
	using count_roots_correct by simp

	lemma poly_no_roots:
	"(\<forall>x. poly p x \<noteq> 0) \<longleftrightarrow> ( p \<noteq> 0 \<and> count_roots p = 0)"
	by (auto simp: count_roots_correct dest: poly_roots_finite)

	lemma poly_pos:
	"(\<forall>x. poly p x > 0) \<longleftrightarrow> (
	p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots p = 0)"
	by (simp only: Let_def poly_pos poly_no_roots, blast)


	lemma poly_card_roots_greater:
	"card {x::real. x > a \<and> poly p x = 0} = count_roots_above p a"
	using count_roots_above_correct by simp

	lemma poly_card_roots_leq:
	"card {x::real. x \<le> a \<and> poly p x = 0} = count_roots_below p a"
	using count_roots_below_correct by simp

	lemma poly_card_roots_geq:
	"card {x::real. x \<ge> a \<and> poly p x = 0} = (
	count_roots_above p a + (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
	proof (cases "poly p a = 0 \<and> p \<noteq> 0")
	case False
	hence "card {x. x \<ge> a \<and> poly p x = 0} = card {x. x > a \<and> poly p x = 0}"
	proof (cases rule: disjE)
	assume "p = 0"
	have "\<not>finite {a<..<a+1}"
	by (metis infinite_Ioo less_add_one)
	moreover have "{a<..<a+1} \<subseteq> {x. x \<ge> a \<and> poly p x = 0}"
	"{a<..<a+1} \<subseteq> {x. x > a \<and> poly p x = 0}"
	using \<open>p = 0\<close> by auto
	ultimately have "\<not>finite {x. x \<ge> a \<and> poly p x = 0}"
	"\<not>finite {x. x > a \<and> poly p x = 0}"
	by (auto dest!: finite_subset[of "{a<..<a+1}"] simp: infinite_Ioo)
	thus ?thesis by simp
	next
	assume "poly p a \<noteq> 0"
	hence "{x. x \<ge> a \<and> poly p x = 0} = {x. x > a \<and> poly p x = 0}"
	by (auto simp: less_eq_real_def)
	thus ?thesis by simp
	qed auto
	thus ?thesis using False
	by (auto intro: poly_card_roots_greater)
	next
	case True
	hence "finite {x. x > a \<and> poly p x = 0}" using poly_roots_finite by force
	moreover have "{x. x \<ge> a \<and> poly p x = 0} =
	insert a {x. x > a \<and> poly p x = 0}" using True by auto
	ultimately have "card {x. x \<ge> a \<and> poly p x = 0} =
	Suc (card {x. x > a \<and> poly p x = 0})"
	using card_insert_disjoint by auto
	thus ?thesis using True by (auto intro: poly_card_roots_greater)
	qed

	lemma poly_card_roots_less:
	"card {x::real. x < a \<and> poly p x = 0} =
	(count_roots_below p a - (if poly p a = 0 \<and> p \<noteq> 0 then 1 else 0))"
	proof (cases "poly p a = 0 \<and> p \<noteq> 0")
	case False
	hence "card {x. x < a \<and> poly p x = 0} = card {x. x \<le> a \<and> poly p x = 0}"
	proof (cases rule: disjE)
	assume "p = 0"
	have "\<not>finite {a - 1<..<a}"
	by (metis infinite_Ioo diff_add_cancel less_add_one)
	moreover have "{a - 1<..<a} \<subseteq> {x. x \<le> a \<and> poly p x = 0}"
	"{a - 1<..<a} \<subseteq> {x. x < a \<and> poly p x = 0}"
	using \<open>p = 0\<close> by auto
	ultimately have "\<not>finite {x. x \<le> a \<and> poly p x = 0}"
	"\<not>finite {x. x < a \<and> poly p x = 0}"
	by (auto dest: finite_subset[of "{a - 1<..<a}"] simp: infinite_Ioo)
	thus ?thesis by simp
	next
	assume "poly p a \<noteq> 0"
	hence "{x. x < a \<and> poly p x = 0} = {x. x \<le> a \<and> poly p x = 0}"
	by (auto simp: less_eq_real_def)
	thus ?thesis by simp
	qed auto
	thus ?thesis using False
	by (auto intro: poly_card_roots_leq)
	next
	case True
	hence "finite {x. x < a \<and> poly p x = 0}" using poly_roots_finite by force
	moreover have "{x. x \<le> a \<and> poly p x = 0} =
	insert a {x. x < a \<and> poly p x = 0}" using True by auto
	ultimately have "Suc (card {x. x < a \<and> poly p x = 0}) =
	(card {x. x \<le> a \<and> poly p x = 0})"
	using card_insert_disjoint by auto
	also note count_roots_below_correct[symmetric]
	finally show ?thesis using True by simp
	qed


	lemma poly_no_roots_less_leq:
	"(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((a \<ge> b \<or> (p \<noteq> 0 \<and> count_roots_between p a b = 0)))"
	by (auto simp: count_roots_between_correct card_eq_0_iff not_le
	dest: poly_roots_finite)

	lemma poly_pos_between_less_leq:
	"(\<forall>x. a < x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p b > 0 \<and> count_roots_between p a b = 0)))"
	by (simp only: poly_pos_between_less_leq Let_def
	poly_no_roots_less_leq, blast)


	lemma poly_no_roots_leq_leq:
	"(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((a > b \<or> (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b = 0)))"
	apply (intro iffI)
	apply (force simp add: count_roots_between_correct card_eq_0_iff)
	apply (elim conjE disjE, simp, intro allI)
	apply (rename_tac x, case_tac "x = a")
	apply (auto simp add: count_roots_between_correct card_eq_0_iff
	dest: poly_roots_finite)
	done

	lemma poly_pos_between_leq_leq:
	"(\<forall>x. a \<le> x \<and> x \<le> b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	((a > b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and>
	count_roots_between p a b = 0)))"
	by (simp only: poly_pos_between_leq_leq Let_def poly_no_roots_leq_leq, force)



	lemma poly_no_roots_less_less:
	"(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((a \<ge> b \<or> p \<noteq> 0 \<and> count_roots_between p a b =
	(if poly p b = 0 then 1 else 0)))"
	proof (standard, goal_cases)
	case A: 1
	show ?case
	proof (cases "a \<ge> b")
	case True
	with A show ?thesis by simp
	next
	case False
	with A have [simp]: "p \<noteq> 0" using dense[of a b] by auto
	have B: "{x. a < x \<and> x \<le> b \<and> poly p x = 0} =
	{x. a < x \<and> x < b \<and> poly p x = 0} \<union>
	(if poly p b = 0 then {b} else {})" using A False by auto
	have "count_roots_between p a b =
	card {x. a < x \<and> x < b \<and> poly p x = 0} +
	(if poly p b = 0 then 1 else 0)"
	by (subst count_roots_between_correct, subst B, subst card_Un_disjoint,
	rule finite_subset[OF _ poly_roots_finite], blast, simp_all)
	also from A have "{x. a < x \<and> x < b \<and> poly p x = 0} = {}" by simp
	finally show ?thesis by auto
	qed
	next
	case prems: 2
	hence "card {x. a < x \<and> x < b \<and> poly p x = 0} = 0"
	by (subst poly_card_roots_less_less, auto simp: count_roots_between_def)
	thus ?case using prems
	by (cases "p = 0", simp, subst (asm) card_eq_0_iff,
	auto dest: poly_roots_finite)
	qed

	lemma poly_pos_between_less_less:
	"(\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p ((a+b)/2) > 0 \<and>
	count_roots_between p a b = (if poly p b = 0 then 1 else 0))))"
	by (simp only: poly_pos_between_less_less Let_def
	poly_no_roots_less_less, blast)

	lemma poly_no_roots_leq_less:
	"(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((a \<ge> b \<or> p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_between p a b =
	(if a < b \<and> poly p b = 0 then 1 else 0)))"
	proof (standard, goal_cases)
	case prems: 1
	hence "\<forall>x. a < x \<and> x < b \<longrightarrow> poly p x \<noteq> 0" by simp
	thus ?case using prems by (subst (asm) poly_no_roots_less_less, auto)
	next
	case prems: 2
	hence "(b \<le> a \<or> p \<noteq> 0 \<and> count_roots_between p a b =
	(if poly p b = 0 then 1 else 0))" by auto
	thus ?case using prems unfolding Let_def
	by (subst (asm) poly_no_roots_less_less[symmetric, unfolded Let_def],
	auto split: if_split_asm simp: less_eq_real_def)
	qed

	lemma poly_pos_between_leq_less:
	"(\<forall>x. a \<le> x \<and> x < b \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	((a \<ge> b \<or> (p \<noteq> 0 \<and> poly p a > 0 \<and> count_roots_between p a b =
	(if a < b \<and> poly p b = 0 then 1 else 0))))"
	by (simp only: poly_pos_between_leq_less Let_def
	poly_no_roots_leq_less, force)


	lemma poly_no_roots_greater:
	"(\<forall>x. x > a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((p \<noteq> 0 \<and> count_roots_above p a = 0))"
	proof-
	have "\<forall>x. \<not> a < x \<Longrightarrow> False" by (metis gt_ex)
	thus ?thesis by (auto simp: count_roots_above_correct card_eq_0_iff
	intro: poly_roots_finite )
	qed

	lemma poly_pos_greater:
	"(\<forall>x. x > a \<longrightarrow> poly p x > 0) \<longleftrightarrow> (
	p \<noteq> 0 \<and> poly_inf p = 1 \<and> count_roots_above p a = 0)"
	unfolding Let_def
	by (subst poly_pos_greater, subst poly_no_roots_greater, force)

	lemma poly_no_roots_leq:
	"(\<forall>x. x \<le> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	( (p \<noteq> 0 \<and> count_roots_below p a = 0))"
	by (auto simp: Let_def count_roots_below_correct card_eq_0_iff
	intro: poly_roots_finite)

	lemma poly_pos_leq:
	"(\<forall>x. x \<le> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	( p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a = 0)"
	by (simp only: poly_pos_leq Let_def poly_no_roots_leq, blast)



	lemma poly_no_roots_geq:
	"(\<forall>x. x \<ge> a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	( (p \<noteq> 0 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0))"
	proof (standard, goal_cases)
	case prems: 1
	hence "\<forall>x>a. poly p x \<noteq> 0" by simp
	thus ?case using prems by (subst (asm) poly_no_roots_greater, auto)
	next
	case prems: 2
	hence "(p \<noteq> 0 \<and> count_roots_above p a = 0)" by simp
	thus ?case using prems
	by (subst (asm) poly_no_roots_greater[symmetric, unfolded Let_def],
	auto simp: less_eq_real_def)
	qed

	lemma poly_pos_geq:
	"(\<forall>x. x \<ge> a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	(p \<noteq> 0 \<and> poly_inf p = 1 \<and> poly p a \<noteq> 0 \<and> count_roots_above p a = 0)"
	by (simp only: poly_pos_geq Let_def poly_no_roots_geq, blast)

	lemma poly_no_roots_less:
	"(\<forall>x. x < a \<longrightarrow> poly p x \<noteq> 0) \<longleftrightarrow>
	((p \<noteq> 0 \<and> count_roots_below p a = (if poly p a = 0 then 1 else 0)))"
	proof (standard, goal_cases)
	case prems: 1
	hence "{x. x \<le> a \<and> poly p x = 0} = (if poly p a = 0 then {a} else {})"
	by (auto simp: less_eq_real_def)
	moreover have "\<forall>x. \<not> x < a \<Longrightarrow> False" by (metis lt_ex)
	ultimately show ?case using prems by (auto simp: count_roots_below_correct)
	next
	case prems: 2
	have A: "{x. x \<le> a \<and> poly p x = 0} = {x. x < a \<and> poly p x = 0} \<union>
	(if poly p a = 0 then {a} else {})" by (auto simp: less_eq_real_def)
	have "count_roots_below p a = card {x. x < a \<and> poly p x = 0} +
	(if poly p a = 0 then 1 else 0)" using prems
	by (subst count_roots_below_correct, subst A, subst card_Un_disjoint,
	auto intro: poly_roots_finite)
	with prems have "card {x. x < a \<and> poly p x = 0} = 0" by simp
	thus ?case using prems
	by (subst (asm) card_eq_0_iff, auto intro: poly_roots_finite)
	qed

	lemma poly_pos_less:
	"(\<forall>x. x < a \<longrightarrow> poly p x > 0) \<longleftrightarrow>
	(p \<noteq> 0 \<and> poly_neg_inf p = 1 \<and> count_roots_below p a =
	(if poly p a = 0 then 1 else 0))"
	by (simp only: poly_pos_less Let_def poly_no_roots_less, blast)


	lemmas sturm_card_substs = poly_card_roots poly_card_roots_less_leq
	poly_card_roots_leq_less poly_card_roots_less_less poly_card_roots_leq_leq
	poly_card_roots_less poly_card_roots_leq poly_card_roots_greater
	poly_card_roots_geq

	lemmas sturm_prop_substs = poly_no_roots poly_no_roots_less_leq
	poly_no_roots_leq_leq poly_no_roots_less_less poly_no_roots_leq_less
	poly_no_roots_leq poly_no_roots_less poly_no_roots_geq
	poly_no_roots_greater
	poly_pos poly_pos_greater poly_pos_geq poly_pos_less poly_pos_leq
	poly_pos_between_leq_less poly_pos_between_less_leq
	poly_pos_between_leq_leq poly_pos_between_less_less


	subsection \<open>Reification\<close>

	text \<open>
	This subsection defines a number of equations to automatically convert
	statements about roots of polynomials into a canonical form so that they
	can be proven using the above substitutions.
	\<close>

	definition "PR_TAG x \<equiv> x"

	lemma sturm_id_PR_prio0:
	"{x::real. P x} = {x::real. (PR_TAG P) x}"
	"(\<forall>x::real. f x < g x) = (\<forall>x::real. PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real. P x) = (\<forall>x::real. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	by (simp_all add: PR_TAG_def)

	lemma sturm_id_PR_prio1:
	"{x::real. x < a \<and> P x} = {x::real. x < a \<and> (PR_TAG P) x}"
	"{x::real. x \<le> a \<and> P x} = {x::real. x \<le> a \<and> (PR_TAG P) x}"
	"{x::real. x \<ge> b \<and> P x} = {x::real. x \<ge> b \<and> (PR_TAG P) x}"
	"{x::real. x > b \<and> P x} = {x::real. x > b \<and> (PR_TAG P) x}"
	"(\<forall>x::real < a. f x < g x) = (\<forall>x::real < a. PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real \<le> a. f x < g x) = (\<forall>x::real \<le> a. PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real > a. f x < g x) = (\<forall>x::real > a. PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real \<ge> a. f x < g x) = (\<forall>x::real \<ge> a. PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real < a. P x) = (\<forall>x::real < a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real > a. P x) = (\<forall>x::real > a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real \<le> a. P x) = (\<forall>x::real \<le> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real \<ge> a. P x) = (\<forall>x::real \<ge> a. \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	by (simp_all add: PR_TAG_def)

	lemma sturm_id_PR_prio2:
	"{x::real. x > a \<and> x \<le> b \<and> P x} =
	{x::real. x > a \<and> x \<le> b \<and> PR_TAG P x}"
	"{x::real. x \<ge> a \<and> x \<le> b \<and> P x} =
	{x::real. x \<ge> a \<and> x \<le> b \<and> PR_TAG P x}"
	"{x::real. x \<ge> a \<and> x < b \<and> P x} =
	{x::real. x \<ge> a \<and> x < b \<and> PR_TAG P x}"
	"{x::real. x > a \<and> x < b \<and> P x} =
	{x::real. x > a \<and> x < b \<and> PR_TAG P x}"
	"(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> f x < g x) =
	(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> f x < g x) =
	(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real. a < x \<and> x < b \<longrightarrow> f x < g x) =
	(\<forall>x::real. a < x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> f x < g x) =
	(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> PR_TAG (\<lambda>x. f x < g x) x)"
	"(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> P x) =
	(\<forall>x::real. a < x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> P x) =
	(\<forall>x::real. a \<le> x \<and> x \<le> b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> P x) =
	(\<forall>x::real. a \<le> x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	"(\<forall>x::real. a < x \<and> x < b \<longrightarrow> P x) =
	(\<forall>x::real. a < x \<and> x < b \<longrightarrow> \<not>(PR_TAG (\<lambda>x. \<not>P x)) x)"
	by (simp_all add: PR_TAG_def)



	lemma PR_TAG_intro_prio0:
	fixes P :: "real \<Rightarrow> bool" and f :: "real \<Rightarrow> real"
	shows
	"PR_TAG P = P' \<Longrightarrow> PR_TAG (\<lambda>x. \<not>(\<not>P x)) = P'"
	"\<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. P x \<and> Q x) = (\<lambda>x. poly (gcd p q) x = 0)" and
	" \<lbrakk>PR_TAG P = (\<lambda>x. poly p x = 0); PR_TAG Q = (\<lambda>x. poly q x = 0)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. P x \<or> Q x) = (\<lambda>x. poly (p*q) x = 0)" and

	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x = g x) = (\<lambda>x. poly (p-q) x = 0)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> g x) = (\<lambda>x. poly (p-q) x \<noteq> 0)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x < g x) = (\<lambda>x. poly (q-p) x > 0)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> g x) = (\<lambda>x. poly (q-p) x \<ge> 0)"

	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. -f x) = (\<lambda>x. poly (-p) x)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x + g x) = (\<lambda>x. poly (p+q) x)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x - g x) = (\<lambda>x. poly (p-q) x)"
	"\<lbrakk>PR_TAG f = (\<lambda>x. poly p x); PR_TAG g = (\<lambda>x. poly q x)\<rbrakk>
	\<Longrightarrow> PR_TAG (\<lambda>x. f x * g x) = (\<lambda>x. poly (p*q) x)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n) = (\<lambda>x. poly (p^n) x)"
	"PR_TAG (\<lambda>x. poly p x :: real) = (\<lambda>x. poly p x)"
	"PR_TAG (\<lambda>x. x::real) = (\<lambda>x. poly [:0,1:] x)"
	"PR_TAG (\<lambda>x. a::real) = (\<lambda>x. poly [:a:] x)"
	by (simp_all add: PR_TAG_def poly_eq_0_iff_dvd field_simps)


	lemma PR_TAG_intro_prio1:
	fixes f :: "real \<Rightarrow> real"
	shows
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x = 0) = (\<lambda>x. poly p x = 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<noteq> 0) = (\<lambda>x. poly p x \<noteq> 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 = f x) = (\<lambda>x. poly p x = 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. 0 \<noteq> f x) = (\<lambda>x. poly p x \<noteq> 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<ge> 0) = (\<lambda>x. poly p x \<ge> 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x > 0) = (\<lambda>x. poly p x > 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x \<le> 0) = (\<lambda>x. poly (-p) x \<ge> 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow> PR_TAG (\<lambda>x. f x < 0) = (\<lambda>x. poly (-p) x > 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
	PR_TAG (\<lambda>x. 0 \<le> f x) = (\<lambda>x. poly (-p) x \<le> 0)"
	"PR_TAG f = (\<lambda>x. poly p x) \<Longrightarrow>
	PR_TAG (\<lambda>x. 0 < f x) = (\<lambda>x. poly (-p) x < 0)"
	"PR_TAG f = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. a * f x) = (\<lambda>x. poly (smult a p) x)"
	"PR_TAG f = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. f x * a) = (\<lambda>x. poly (smult a p) x)"
	"PR_TAG f = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. f x / a) = (\<lambda>x. poly (smult (inverse a) p) x)"
	"PR_TAG (\<lambda>x. x^n :: real) = (\<lambda>x. poly (monom 1 n) x)"
	by (simp_all add: PR_TAG_def field_simps poly_monom)

	lemma PR_TAG_intro_prio2:
	"PR_TAG (\<lambda>x. 1 / b) = (\<lambda>x. inverse b)"
	"PR_TAG (\<lambda>x. a / b) = (\<lambda>x. a / b)"
	"PR_TAG (\<lambda>x. a / b * x^n :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
	"PR_TAG (\<lambda>x. x^n * a / b :: real) = (\<lambda>x. poly (monom (a/b) n) x)"
	"PR_TAG (\<lambda>x. a * x^n :: real) = (\<lambda>x. poly (monom a n) x)"
	"PR_TAG (\<lambda>x. x^n * a :: real) = (\<lambda>x. poly (monom a n) x)"
	"PR_TAG (\<lambda>x. x^n / a :: real) = (\<lambda>x. poly (monom (inverse a) n) x)"
	(* TODO: can this be done more efficiently? I should think so. *)
	"PR_TAG (\<lambda>x. f x^(Suc (Suc 0)) :: real) = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. f x * f x :: real) = (\<lambda>x. poly p x)"
	"PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. (f x)^n * f x :: real) = (\<lambda>x. poly p x)"
	"PR_TAG (\<lambda>x. (f x)^Suc n :: real) = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. f x * (f x)^n :: real) = (\<lambda>x. poly p x)"
	"PR_TAG (\<lambda>x. (f x)^(m+n) :: real) = (\<lambda>x. poly p x)
	\<Longrightarrow> PR_TAG (\<lambda>x. (f x)^m * (f x)^n :: real) = (\<lambda>x. poly p x)"
	by (simp_all add: PR_TAG_def field_simps poly_monom power_add)

	lemma sturm_meta_spec: "(\<And>x::real. P x) \<Longrightarrow> P x" by simp
	lemma sturm_imp_conv:
	"(a < x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
	"(a \<le> x \<longrightarrow> x < b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
	"(a < x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
	"(a \<le> x \<longrightarrow> x \<le> b \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
	"(x < b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x < b \<longrightarrow> c)"
	"(x < b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x < b \<longrightarrow> c)"
	"(x \<le> b \<longrightarrow> a < x \<longrightarrow> c) \<longleftrightarrow> (a < x \<and> x \<le> b \<longrightarrow> c)"
	"(x \<le> b \<longrightarrow> a \<le> x \<longrightarrow> c) \<longleftrightarrow> (a \<le> x \<and> x \<le> b \<longrightarrow> c)"
	by auto


	subsection \<open>Setup for the ``sturm'' method\<close>

	ML_file \<open>sturm.ML\<close>

	method_setup sturm = \<open>
	Scan.succeed (fn ctxt => SIMPLE_METHOD' (Sturm.sturm_tac ctxt true))
	\<close>

	end
	diff --git a/thys/Taylor_Models/Taylor_Models.thy b/thys/Taylor_Models/Taylor_Models.thy
	--- a/thys/Taylor_Models/Taylor_Models.thy
	+++ b/thys/Taylor_Models/Taylor_Models.thy
	@@ -1,2086 +1,2086 @@
	theory Taylor_Models
	imports
	"Horner_Eval"
	"Polynomial_Expression_Additional"
	"Taylor_Models_Misc"
	"HOL-Decision_Procs.Approximation"
	"HOL-Library.Function_Algebras"
	"HOL-Library.Set_Algebras"
	"Affine_Arithmetic.Straight_Line_Program"
	"Affine_Arithmetic.Affine_Approximation"
	begin

	text \<open>TODO: get rid of float poly/float inteval and use real poly/real interval
	and data refinement?\<close>

	section \<open>Multivariate Taylor Models\<close>

	subsection \<open>Computing interval bounds on arithmetic expressions\<close>

	text \<open>This is a wrapper around the "approx" function.
	It computes range bounds on floatarith expressions.\<close>
	fun compute_bound_fa :: "nat \<Rightarrow> floatarith \<Rightarrow> float interval list \<Rightarrow> float interval option"
	where "compute_bound_fa prec f I = approx prec f (map Some I)"

	lemma compute_bound_fa_correct:
	"interpret_floatarith f i \<in>\<^sub>r ivl"
	if "compute_bound_fa prec f I = Some ivl"
	"i all_in I"
	for i::"real list"
	proof-
	have bounded: "bounded_by i (map Some I)"
	using that(2)
	unfolding bounded_by_def
	by (auto simp: bounds_of_interval_eq_lower_upper set_of_eq)
	from that have Some: "approx prec f (map Some I) = Some ivl"
	by (auto simp: lower_Interval upper_Interval min_def split: option.splits if_splits)
	from approx[OF bounded Some]
	show ?thesis by (auto simp: set_of_eq)
	qed


	subsection \<open>Definition of Taylor models and notion of rangeity\<close>

	text \<open>Taylor models are a pair of a polynomial and an absolute error bound.\<close>
	datatype taylor_model = TaylorModel (tm_poly: "float poly") (tm_bound: "float interval")

	text \<open>Taylor model for a real valuation of variables\<close>

	primrec insertion :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a poly \<Rightarrow> 'a::{plus,zero,minus,uminus,times,one,power}"
	where
	"insertion bs (C c) = c"
	\| "insertion bs (poly.Bound n) = bs n"
	\| "insertion bs (Neg a) = - insertion bs a"
	\| "insertion bs (poly.Add a b) = insertion bs a + insertion bs b"
	\| "insertion bs (Sub a b) = insertion bs a - insertion bs b"
	\| "insertion bs (Mul a b) = insertion bs a * insertion bs b"
	\| "insertion bs (Pw t n) = insertion bs t ^ n"
	\| "insertion bs (CN c n p) = insertion bs c + (bs n) * insertion bs p"

	definition range_tm :: "(nat \<Rightarrow> real) \<Rightarrow> taylor_model \<Rightarrow> real interval" where
	"range_tm e tm = interval_of (insertion e (tm_poly tm)) + real_interval (tm_bound tm)"

	lemma Ipoly_num_params_cong: "Ipoly xs p = Ipoly ys p"
	if "\<And>i. i < num_params p \<Longrightarrow> xs ! i = ys ! i"
	using that
	by (induction p; auto)

	lemma insertion_num_params_cong: "insertion e p = insertion f p"
	if "\<And>i. i < num_params p \<Longrightarrow> e i = f i"
	using that
	by (induction p; auto)

	lemma insertion_eq_IpolyI: "insertion xs p = Ipoly ys p"
	if "\<And>i. i < num_params p \<Longrightarrow> xs i = ys ! i"
	using that
	by (induction p; auto)

	lemma Ipoly_eq_insertionI: "Ipoly ys p = insertion xs p"
	if "\<And>i. i < num_params p \<Longrightarrow> xs i = ys ! i"
	using that
	by (induction p; auto)

	lemma range_tmI:
	"x \<in>\<^sub>i range_tm e tm"
	if x: "x \<in>\<^sub>i interval_of (insertion e ((tm_poly tm))) + real_interval (tm_bound tm)"
	for e::"nat\<Rightarrow>real"
	by (auto simp: range_tm_def x)

	lemma range_tmD:
	"x \<in>\<^sub>i interval_of (insertion e (tm_poly tm)) + real_interval (tm_bound tm)"
	if "x \<in>\<^sub>i range_tm e tm"
	for e::"nat\<Rightarrow>real"
	using that
	by (auto simp: range_tm_def)


	subsection \<open>Interval bounds for Taylor models\<close>

	text \<open>Bound a polynomial by simply approximating it with interval arguments.\<close>
	fun compute_bound_poly :: "nat \<Rightarrow> float interval poly \<Rightarrow> (float interval list) \<Rightarrow> (float interval list) \<Rightarrow> float interval" where
	"compute_bound_poly prec (poly.C f) I a = f"
	\| "compute_bound_poly prec (poly.Bound n) I a = round_interval prec (I ! n - (a ! n))"
	\| "compute_bound_poly prec (poly.Add p q) I a =
	round_interval prec (compute_bound_poly prec p I a + compute_bound_poly prec q I a)"
	\| "compute_bound_poly prec (poly.Sub p q) I a =
	round_interval prec (compute_bound_poly prec p I a - compute_bound_poly prec q I a)"
	\| "compute_bound_poly prec (poly.Mul p q) I a =
	mult_float_interval prec (compute_bound_poly prec p I a) (compute_bound_poly prec q I a)"
	\| "compute_bound_poly prec (poly.Neg p) I a = -compute_bound_poly prec p I a"
	\| "compute_bound_poly prec (poly.Pw p n) I a = power_float_interval prec n (compute_bound_poly prec p I a)"
	\| "compute_bound_poly prec (poly.CN p n q) I a =
	round_interval prec (compute_bound_poly prec p I a +
	mult_float_interval prec (round_interval prec (I ! n - (a ! n))) (compute_bound_poly prec q I a))"

	text \<open>Bounds on Taylor models are simply a bound on its polynomial, widened by the approximation error.\<close>
	fun compute_bound_tm :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> float interval"
	where "compute_bound_tm prec I a (TaylorModel p e) = compute_bound_poly prec p I a + e"

	lemma compute_bound_tm_def:
	"compute_bound_tm prec I a tm = compute_bound_poly prec (tm_poly tm) I a + (tm_bound tm)"
	by (cases tm) auto

	lemma real_of_float_in_real_interval_of[intro, simp]: "real_of_float x \<in>\<^sub>r X" if "x \<in>\<^sub>i X"
	using that
	by (auto simp: set_of_eq)

	lemma in_set_of_round_interval[intro, simp]:
	"x \<in>\<^sub>r round_interval prec X" if "x \<in>\<^sub>r X"
	using round_ivl_correct[of X prec] that
	by (auto simp: set_of_eq)

	lemma in_set_real_minus_interval[intro, simp]:
	"x - y \<in>\<^sub>r X - Y" if "x \<in>\<^sub>r X" "y \<in>\<^sub>r Y"
	using that
	by (auto simp: set_of_eq)

	lemma real_interval_plus: "real_interval (a + b) = real_interval a + real_interval b"
	by (simp add: interval_eqI)

	lemma real_interval_uminus: "real_interval (- b) = - real_interval b"
	by (simp add: interval_eqI)

	lemma real_interval_of: "real_interval (interval_of b) = interval_of b"
	by (simp add: interval_eqI)

	lemma real_interval_minus: "real_interval (a - b) = real_interval a - real_interval b"
	using real_interval_plus[of a "-b"] real_interval_uminus[of b]
	by (auto simp: interval_eq_iff)

	lemma in_set_real_plus_interval[intro, simp]:
	"x + y \<in>\<^sub>r X + Y" if "x \<in>\<^sub>r X" "y \<in>\<^sub>r Y"
	using that
	by (auto simp: set_of_eq)

	lemma in_set_neg_plus_interval[intro, simp]:
	"- y \<in>\<^sub>r - Y" if "y \<in>\<^sub>r Y"
	using that
	by (auto simp: set_of_eq)

	lemma in_set_real_times_interval[intro, simp]:
	"x * y \<in>\<^sub>r X * Y" if "x \<in>\<^sub>r X" "y \<in>\<^sub>r Y"
	using that
	by (auto simp: real_interval_times intro!: times_in_intervalI)

	lemma real_interval_one: "real_interval 1 = 1"
	by (simp add: interval_eqI)

	lemma real_interval_zero: "real_interval 0 = 0"
	by (simp add: interval_eqI)

	lemma real_interval_power: "real_interval (a ^ b) = real_interval a ^ b"
	by (induction b arbitrary: a)
	(auto simp: real_interval_times real_interval_one)

	lemma in_set_real_power_interval[intro, simp]:
	"x ^ n \<in>\<^sub>r X ^ n" if "x \<in>\<^sub>r X"
	using that
	by (auto simp: real_interval_power intro!: set_of_power_mono)

	lemma power_float_interval_real_interval[intro, simp]:
	"x ^ n \<in>\<^sub>r power_float_interval prec n X" if "x \<in>\<^sub>r X"
	by (auto simp: real_interval_power that intro!: power_float_intervalI)

	lemma in_set_mult_float_interval[intro, simp]:
	"x * y \<in>\<^sub>r mult_float_interval prec X Y" if "x \<in>\<^sub>r X" "y \<in>\<^sub>r Y"
	using mult_float_interval[of X Y] in_set_real_times_interval[OF that] that(1) that(2)
	by blast

	lemma in_set_real_minus_swapI: "e i \<in>\<^sub>r I ! i - a ! i"
	if "x - e i \<in>\<^sub>r a ! i" "x \<in>\<^sub>r I ! i"
	using that
	by (auto simp: set_of_eq)

	definition develops_at_within::"(nat \<Rightarrow> real) \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> bool"
	where "develops_at_within e a I \<longleftrightarrow> (a all_subset I) \<and> (\<forall>i < length I. e i \<in>\<^sub>r I ! i - a ! i)"

	lemma develops_at_withinI:
	assumes all_in: "a all_subset I"
	assumes e: "\<And>i. i < length I \<Longrightarrow> e i \<in>\<^sub>r I ! i - a ! i"
	shows "develops_at_within e a I"
	using assms by (auto simp: develops_at_within_def)

	lemma develops_at_withinD:
	assumes "develops_at_within e a I"
	shows "a all_subset I"
	"\<And>i. i < length I \<Longrightarrow> e i \<in>\<^sub>r I ! i - a ! i"
	using assms by (auto simp: develops_at_within_def)

	lemma compute_bound_poly_correct:
	fixes p::"float poly"
	assumes "num_params p \<le> length I"
	assumes dev: "develops_at_within e a I"
	shows "insertion e (p::real poly) \<in>\<^sub>r compute_bound_poly prec (map_poly interval_of p) I a"
	using assms(1)
	proof (induction p)
	case (C x)
	then show ?case by auto
	next
	case (Bound i)
	then show ?case
	using dev
	by (auto simp: develops_at_within_def)
	next
	case (Add p1 p2)
	then show ?case by force
	next
	case (Sub p1 p2)
	then show ?case by force
	next
	case (Mul p1 p2)
	then show ?case by force
	next
	case (Neg p)
	then show ?case by force
	next
	case (Pw p x2a)
	then show ?case by force
	next
	case (CN p1 i p2)
	then show ?case
	using dev
	by (auto simp: develops_at_within_def)
	qed

	lemma compute_bound_tm_correct:
	fixes I :: "float interval list" and f :: "real list \<Rightarrow> real"
	assumes n: "num_params (tm_poly t) \<le> length I"
	assumes dev: "develops_at_within e a I"
	assumes x0: "x0 \<in>\<^sub>i range_tm e t"
	shows "x0 \<in>\<^sub>r compute_bound_tm prec I a t"
	proof -
	let ?I = "insertion e (tm_poly t)"
	have "x0 = ?I + (x0 - ?I)" by simp
	also have "\<dots> \<in>\<^sub>r compute_bound_tm prec I a t"
	unfolding compute_bound_tm_def
	apply (rule in_set_real_plus_interval)
	apply (rule compute_bound_poly_correct)
	apply (rule assms)
	apply (rule dev)
	using range_tmD[OF x0]
	by (auto simp: set_of_eq)
	finally show "x0 \<in>\<^sub>r compute_bound_tm prec I a t" .
	qed

	lemma compute_bound_tm_correct_subset:
	fixes I :: "float interval list" and f :: "real list \<Rightarrow> real"
	assumes n: "num_params (tm_poly t) \<le> length I"
	assumes dev: "develops_at_within e a I"
	shows "set_of (range_tm e t) \<subseteq> set_of (real_interval (compute_bound_tm prec I a t))"
	using assms
	by (auto intro!: compute_bound_tm_correct)

	lemma compute_bound_poly_mono:
	assumes "num_params p \<le> length I"
	assumes mem: "I all_subset J" "a all_subset I"
	shows "set_of (compute_bound_poly prec p I a) \<subseteq> set_of (compute_bound_poly prec p J a)"
	using assms(1)
	proof (induction p arbitrary: a)
	case (C x)
	then show ?case by auto
	next
	case (Bound x)
	then show ?case using mem
	by (simp add: round_interval_mono set_of_sub_inc)
	next
	case (Add p1 p2)
	then show ?case using mem
	by (simp add: round_interval_mono set_of_add_inc)
	next
	case (Sub p1 p2)
	then show ?case using mem
	by (simp add: round_interval_mono set_of_sub_inc)
	next
	case (Mul p1 p2)
	then show ?case using mem
	by (simp add: round_interval_mono mult_float_interval_mono')
	next
	case (Neg p)
	then show ?case using mem
	by (simp add: round_interval_mono set_of_neg_inc)
	next
	case (Pw p x2a)
	then show ?case using mem
	by (simp add: power_float_interval_mono)
	next
	case (CN p1 x2a p2)
	then show ?case using mem
	by (simp add: round_interval_mono mult_float_interval_mono'
	set_of_add_inc set_of_sub_inc)
	qed

	lemma compute_bound_tm_mono:
	fixes I :: "float interval list" and f :: "real list \<Rightarrow> real"
	assumes "num_params (tm_poly t) \<le> length I"
	assumes "I all_subset J"
	assumes "a all_subset I"
	shows "set_of (compute_bound_tm prec I a t) \<subseteq> set_of (compute_bound_tm prec J a t)"
	apply (simp add: compute_bound_tm_def)
	apply (rule set_of_add_inc_left)
	apply (rule compute_bound_poly_mono)
	using assms
	by (auto simp: set_of_eq)


	subsection \<open>Computing taylor models for basic, univariate functions\<close>

	definition tm_const :: "float \<Rightarrow> taylor_model"
	where "tm_const c = TaylorModel (poly.C c) 0"

	context includes floatarith_notation begin

	definition tm_pi :: "nat \<Rightarrow> taylor_model"
	where "tm_pi prec = (
	let pi_ivl = the (compute_bound_fa prec Pi [])
	in TaylorModel (poly.C (mid pi_ivl)) (centered pi_ivl)
	)"

	lemma zero_real_interval[intro,simp]: "0 \<in>\<^sub>r 0"
	by (auto simp: set_of_eq)

	lemma range_TM_tm_const[simp]: "range_tm e (tm_const c) = interval_of c"
	by (auto simp: range_tm_def real_interval_zero tm_const_def)

	lemma num_params_tm_const[simp]: "num_params (tm_poly (tm_const c)) = 0"
	by (auto simp: tm_const_def)

	lemma num_params_tm_pi[simp]: "num_params (tm_poly (tm_pi prec)) = 0"
	by (auto simp: tm_pi_def Let_def)

	lemma range_tm_tm_pi: "pi \<in>\<^sub>i range_tm e (tm_pi prec)"
	proof-
	have "\<And>prec. real_of_float (lb_pi prec) \<le> real_of_float (ub_pi prec)"
	using iffD1[OF atLeastAtMost_iff, OF pi_boundaries]
	using order_trans by auto
	then obtain ivl_pi where ivl_pi_def: "compute_bound_fa prec Pi [] = Some ivl_pi"
	by (simp add: approx.simps)
	show ?thesis
	unfolding range_tm_def Let_def
	using compute_bound_fa_correct[OF ivl_pi_def, of "[]"]
	by (auto simp: set_of_eq Let_def centered_def ivl_pi_def tm_pi_def
	simp del: compute_bound_fa.simps)
	qed


	subsubsection \<open>Derivations of floatarith expressions\<close>

	text \<open>Compute the nth derivative of a floatarith expression\<close>
	fun deriv :: "nat \<Rightarrow> floatarith \<Rightarrow> nat \<Rightarrow> floatarith"
	where "deriv v f 0 = f"
	\| "deriv v f (Suc n) = DERIV_floatarith v (deriv v f n)"

	lemma isDERIV_DERIV_floatarith:
	assumes "isDERIV v f vs"
	shows "isDERIV v (DERIV_floatarith v f) vs"
	using assms
	proof(induction f)
	case (Power f m)
	then show ?case
	by (cases m) (auto simp: isDERIV_Power)
	qed (simp_all add: numeral_eq_Suc add_nonneg_eq_0_iff )

	lemma isDERIV_is_analytic:
	"isDERIV i (Taylor_Models.deriv i f n) xs"
	if "isDERIV i f xs"
	using isDERIV_DERIV_floatarith that
	by(induction n) auto

	lemma deriv_correct:
	assumes "isDERIV i f (xs[i:=t])" "i < length xs"
	shows "((\<lambda>x. interpret_floatarith (deriv i f n) (xs[i:=x])) has_real_derivative interpret_floatarith (deriv i f (Suc n)) (xs[i:=t]))
	(at t within S)"
	apply(simp)
	apply (rule has_field_derivative_at_within)
	apply(rule DERIV_floatarith)
	apply fact
	apply (rule isDERIV_is_analytic)
	apply fact
	done

	text \<open>Faster derivation for univariate functions, producing smaller terms and thus less over-approximation.\<close>
	text \<open>TODO: Extend to Arctan, Log!\<close>
	fun deriv_rec :: "floatarith \<Rightarrow> nat \<Rightarrow> floatarith"
	where "deriv_rec (Exp (Var 0)) _ = Exp (Var 0)"
	\| "deriv_rec (Cos (Var 0)) n = (case n mod 4
	of 0 \<Rightarrow> Cos (Var 0)
	\| Suc 0 \<Rightarrow> Minus (Sin (Var 0))
	\| Suc (Suc 0) \<Rightarrow> Minus (Cos (Var 0))
	\| Suc (Suc (Suc 0)) \<Rightarrow> Sin (Var 0))"
	\| "deriv_rec (Inverse (Var 0)) n = (if n = 0 then Inverse (Var 0) else Mult (Num (fact n * (if n mod 2 = 0 then 1 else -1))) (Inverse (Power (Var 0) (Suc n))))"
	\| "deriv_rec f n = deriv 0 f n"

	lemma deriv_rec_correct:
	assumes "isDERIV 0 f (xs[0:=t])" "0 < length xs"
	shows "((\<lambda>x. interpret_floatarith (deriv_rec f n) (xs[0:=x])) has_real_derivative interpret_floatarith (deriv_rec f (Suc n)) (xs[0:=t])) (at t within S)"
	apply(cases "(f, n)" rule: deriv_rec.cases)
	apply(safe)
	using assms deriv_correct[OF assms]
	proof-
	assume "f = Cos (Var 0)"

	have n_mod_4_cases: "n mod 4 = 0 \| n mod 4 = 1 \| n mod 4 = 2 \| n mod 4 = 3"
	by auto
	have Sin_sin: "(\<lambda>xs. interpret_floatarith (Sin (Var 0)) xs) = (\<lambda>xs. sin (xs!0))"
	- by (simp add: )
	+ by simp
	show "((\<lambda>x. interpret_floatarith (deriv_rec (Cos (Var 0)) n) (xs[0:=x])) has_real_derivative
	interpret_floatarith (deriv_rec (Cos (Var 0)) (Suc n)) (xs[0:=t]))
	(at t within S)"
	using n_mod_4_cases assms
	by (auto simp add: mod_Suc Sin_sin field_differentiable_minus
	intro!: derivative_eq_intros)
	next
	assume f_def: "f = Inverse (Var 0)" and "isDERIV 0 f (xs[0:=t])"
	hence "t \<noteq> 0" using assms
	by simp
	{
	fix n::nat and x::real
	assume "x \<noteq> 0"
	moreover have "(n mod 2 = 0 \<and> Suc n mod 2 = 1) \<or> (n mod 2 = 1 \<and> Suc n mod 2 = 0)"
	by (cases n rule: parity_cases) auto
	ultimately have "interpret_floatarith (deriv_rec f n) (xs[0:=x]) = fact n * (-1::real)^n / (x^Suc n)"
	using assms by (auto simp add: f_def field_simps fact_real_float_equiv)
	}
	note closed_formula = this

	have "((\<lambda>x. inverse (x ^ Suc n)) has_real_derivative -real (Suc n) * inverse (t ^ Suc (Suc n))) (at t)"
	using DERIV_inverse_fun[OF DERIV_pow[where n="Suc n"], where s=UNIV]
	apply(rule iffD1[OF DERIV_cong_ev[OF refl], rotated 2])
	using \<open>t \<noteq> 0\<close>
	by (simp_all add: divide_simps)
	hence "((\<lambda>x. fact n * (-1::real)^n * inverse (x ^ Suc n)) has_real_derivative fact (Suc n) * (- 1) ^ Suc n / t ^ Suc (Suc n)) (at t)"
	apply(rule iffD1[OF DERIV_cong_ev, OF refl _ _ DERIV_cmult[where c="fact n * (-1::real)^n"], rotated 2])
	using \<open>t \<noteq> 0\<close>
	by (simp_all add: field_simps distrib_left)
	then show "((\<lambda>x. interpret_floatarith (deriv_rec (Inverse (Var 0)) n) (xs[0:=x])) has_real_derivative
	interpret_floatarith (deriv_rec (Inverse (Var 0)) (Suc n)) (xs[0:=t]))
	(at t within S)"
	apply -
	apply (rule has_field_derivative_at_within)
	apply(rule iffD1[OF DERIV_cong_ev[OF refl _ closed_formula[OF \<open>t \<noteq> 0\<close>, symmetric]], unfolded f_def, rotated 1])
	apply simp
	using assms
	by (simp, safe, simp_all add: fact_real_float_equiv inverse_eq_divide even_iff_mod_2_eq_zero)
	qed (use assms in \<open>simp_all add: has_field_derivative_subset[OF DERIV_exp subset_UNIV]\<close>)

	lemma deriv_rec_0_idem[simp]:
	shows "deriv_rec f 0 = f"
	by (cases "(f, 0::nat)" rule: deriv_rec.cases, simp_all)


	subsubsection \<open>Computing Taylor models for arbitrary univariate expressions\<close>

	fun tmf_c :: "nat \<Rightarrow> float interval list \<Rightarrow> floatarith \<Rightarrow> nat \<Rightarrow> float interval option"
	where "tmf_c prec I f i = compute_bound_fa prec (Mult (deriv_rec f i) (Inverse (Num (fact i)))) I"
	\<comment> \<open>The interval coefficients of the Taylor polynomial,
	i.e. the real coefficients approximated by a float interval.\<close>

	fun tmf_ivl_cs :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float list \<Rightarrow> floatarith \<Rightarrow> float interval list option"
	where "tmf_ivl_cs prec ord I a f = those (map (tmf_c prec a f) [0..<ord] @ [tmf_c prec I f ord])"
	\<comment> \<open>Make a list of bounds on the n+1 coefficients, with the n+1-th coefficient bounding
	the remainder term of the Taylor-Lagrange formula.\<close>

	fun tmf_polys :: "float interval list \<Rightarrow> float poly \<times> float interval poly"
	where "tmf_polys [] = (poly.C 0, poly.C 0)"
	\| "tmf_polys (c # cs) = (
	let (pf, pi) = tmf_polys cs
	in (poly.CN (poly.C (mid c)) 0 pf, poly.CN (poly.C (centered c)) 0 pi)
	)"

	fun tm_floatarith :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float list \<Rightarrow> floatarith \<Rightarrow> taylor_model option"
	where "tm_floatarith prec ord I a f = (
	map_option (\<lambda>cs.
	let (pf, pi) = tmf_polys cs;
	_ = compute_bound_tm prec (List.map2 (-) I a);
	e = round_interval prec (Ipoly (List.map2 (-) I a) pi) \<comment> \<open>TODO: use \<open>compute_bound_tm\<close> here?!\<close>
	in TaylorModel pf e
	) (tmf_ivl_cs prec ord I a f)
	)" \<comment> \<open>Compute a Taylor model from an arbitrary, univariate floatarith expression, if possible.
	This is used to compute Taylor models for elemental functions like sin, cos, exp, etc.\<close>

	term compute_bound_poly
	lemma tmf_c_correct:
	fixes A::"float interval list" and I::"float interval" and f::floatarith and a::"real list"
	assumes "a all_in A"
	assumes "tmf_c prec A f i = Some I"
	shows "interpret_floatarith (deriv_rec f i) a / fact i \<in>\<^sub>r I"
	using compute_bound_fa_correct[OF assms(2)[unfolded tmf_c.simps], where i="a"] assms(1)
	by (simp add: divide_real_def fact_real_float_equiv)

	lemma tmf_ivl_cs_length:
	assumes "tmf_ivl_cs prec n A a f = Some cs"
	shows "length cs = n + 1"
	by (simp add: Some_those_length[OF assms[unfolded tmf_ivl_cs.simps]])

	lemma tmf_ivl_cs_correct:
	fixes A::"float interval list" and f::floatarith
	assumes "a all_in I"
	assumes "tmf_ivl_cs prec ord I a f = Some cs"
	shows "\<And>i. i < ord \<Longrightarrow> tmf_c prec (map interval_of a) f i = Some (cs!i)"
	and "tmf_c prec I f ord = Some (cs!ord)"
	and "length cs = Suc ord"
	proof-
	from tmf_ivl_cs_length[OF assms(2)]
	show "tmf_c prec I f ord = Some (cs!ord)"
	by (metis Some_those_nth assms(2) diff_zero length_map length_upt less_add_one
	nth_append_length tmf_ivl_cs.simps)
	next
	fix i assume "i < ord"
	have "Some (cs!i) = (map (tmf_c prec a f) [0..<ord] @ [tmf_c prec I f ord]) ! i"
	apply(rule Some_those_nth)
	using assms(2) tmf_ivl_cs_length \<open>i < ord\<close>
	by simp_all
	then show "tmf_c prec a f i = Some (cs!i)"
	using \<open>i < ord\<close>
	by (simp add: nth_append)
	next
	show "length cs = Suc ord"
	using assms
	by (auto simp: split_beta' those_eq_Some_iff list_eq_iff_nth_eq)
	qed

	lemma Ipoly_fst_tmf_polys:
	"Ipoly xs (fst (tmf_polys z)) = (\<Sum>i<length z. xs ! 0 ^ i * (mid (z ! i)))"
	for xs::"real list"
	proof (induction z)
	case (Cons z zs)
	show ?case
	unfolding list.size add_Suc_right sum.lessThan_Suc_shift
	by (auto simp: split_beta' Let_def nth_Cons Cons sum_distrib_left ac_simps)
	qed simp

	lemma insertion_fst_tmf_polys:
	"insertion e (fst (tmf_polys z)) = (\<Sum>i<length z. e 0 ^ i * (mid (z ! i)))"
	for e::"nat \<Rightarrow> real"
	proof (induction z)
	case (Cons z zs)
	show ?case
	unfolding list.size add_Suc_right sum.lessThan_Suc_shift
	by (auto simp: split_beta' Let_def nth_Cons Cons sum_distrib_left ac_simps)
	qed simp

	lemma Ipoly_snd_tmf_polys:
	"set_of (horner_eval (real_interval o centered o nth z) x (length z)) \<subseteq> set_of (Ipoly [x] (map_poly real_interval (snd (tmf_polys z))))"
	proof (induction z)
	case (Cons z zs)
	show ?case
	using Cons[THEN set_of_mul_inc_right]
	unfolding list.size add_Suc_right sum.lessThan_Suc_shift
	by (auto simp: split_beta' Let_def nth_Cons sum_distrib_left ac_simps
	elim!: plus_in_intervalE intro!: plus_in_intervalI)
	qed (auto simp: real_interval_zero)

	lemma zero_interval[intro,simp]: "0 \<in>\<^sub>i 0"
	by (simp add: set_of_eq)

	lemma sum_in_intervalI: "sum f X \<in>\<^sub>i sum g X" if "\<And>x. x \<in> X \<Longrightarrow> f x \<in>\<^sub>i g x"
	for f :: "_ \<Rightarrow> 'a :: ordered_comm_monoid_add"
	using that
	proof (induction X rule: infinite_finite_induct)
	case (insert x F)
	then show ?case
	by (auto intro!: plus_in_intervalI)
	qed simp_all

	lemma set_of_sum_subset: "set_of (sum f X) \<subseteq> set_of (sum g X)"
	if "\<And>x. x \<in> X \<Longrightarrow> set_of (f x) \<subseteq> set_of (g x)"
	for f :: "_\<Rightarrow>'a::linordered_ab_group_add interval"
	using that
	by (induction X rule: infinite_finite_induct) (simp_all add: set_of_add_inc)

	lemma interval_of_plus: "interval_of (a + b) = interval_of a + interval_of b"
	by (simp add: interval_eqI)

	lemma interval_of_uminus: "interval_of (- a) = - interval_of a"
	by (simp add: interval_eqI)

	lemma interval_of_zero: "interval_of 0 = 0"
	by (simp add: interval_eqI)

	lemma interval_of_sum: "interval_of (sum f X) = sum (\<lambda>x. interval_of (f x)) X"
	by (induction X rule: infinite_finite_induct) (auto simp: interval_of_plus interval_of_zero)

	lemma interval_of_prod: "interval_of (a * b) = interval_of a * interval_of b"
	by (simp add: lower_times upper_times interval_eqI)

	lemma in_set_of_interval_of[simp]: "x \<in>\<^sub>i (interval_of y) \<longleftrightarrow> x = y" for x y::"'a::order"
	by (auto simp: set_of_eq)

	lemma real_interval_Ipoly: "real_interval (Ipoly xs p) = Ipoly (map real_interval xs) (map_poly real_interval p)"
	if "num_params p \<le> length xs"
	using that
	by (induction p)
	(auto simp: real_interval_plus real_interval_minus real_interval_times
	real_interval_uminus real_interval_power)

	lemma num_params_tmf_polys1: "num_params (fst (tmf_polys z)) \<le> Suc 0"
	by (induction z) (auto simp: split_beta' Let_def)

	lemma num_params_tmf_polys2: "num_params (snd (tmf_polys z)) \<le> Suc 0"
	by (induction z) (auto simp: split_beta' Let_def)

	lemma set_of_real_interval_subset: "set_of (real_interval x) \<subseteq> set_of (real_interval y)"
	if "set_of x \<subseteq> set_of y"
	using that
	by (auto simp: set_of_eq)

	theorem tm_floatarith:
	assumes t: "tm_floatarith prec ord I xs f = Some t"
	assumes a: "xs all_in I" and x: "x \<in>\<^sub>r I ! 0"
	assumes xs_ne: "xs \<noteq> []"
	assumes deriv: "\<And>x. x \<in>\<^sub>r I ! 0 \<Longrightarrow> isDERIV 0 f (xs[0 := x])"
	assumes "\<And>i. 0 < i \<Longrightarrow> i < length xs \<Longrightarrow> e i = real_of_float (xs ! i)"
	assumes diff_e: "(x - real_of_float (xs ! 0)) = e 0"
	shows "interpret_floatarith f (xs[0:=x]) \<in>\<^sub>i range_tm e t"
	proof -
	from xs_ne a have I_ne[simp]: "I \<noteq> []" by auto
	have xs'_in: "xs[0 := x] all_in I"
	using a
	by (auto simp: nth_list_update x)
	from t obtain z where z: "tmf_ivl_cs prec ord I xs f = Some z"
	and tz: "tm_poly t = fst (tmf_polys z)"
	and tb: "tm_bound t = round_interval prec (Ipoly (List.map2 (-) I xs) (snd (tmf_polys z)))"
	using assms(1)
	by (cases t) (auto simp: those_eq_Some_iff split_beta' Let_def simp del: tmf_ivl_cs.simps)
	from tmf_ivl_cs_correct[OF a z(1)]
	have z_less: "i < ord \<Longrightarrow> tmf_c prec (map interval_of xs) f i = Some (z ! i)"
	and lz: "length z = Suc ord" "length z - 1 = ord"
	and z_ord: "tmf_c prec I f ord = Some (z ! ord)" for i
	by auto
	have rewr: "{..ord} = insert ord {..<ord}" by auto
	let ?diff = "\<lambda>(i::nat) (x::real). interpret_floatarith (deriv_rec f i) (xs[0:=x])"
	let ?c = "real_of_float (xs ! 0)"
	let ?n = "ord"
	let ?a = "real_of_float (lower (I!0))"
	let ?b = "real_of_float (upper (I!0))"
	let ?x = "x::real"
	let ?f = "\<lambda>x::real. interpret_floatarith f (xs[0 := x])"
	have 2: "?diff 0 = ?f" using \<open>xs \<noteq> []\<close>
	by (simp add: map_update)
	have 3: "\<forall>m t. m < ?n \<and> ?a \<le> t \<and> t \<le> ?b \<longrightarrow> (?diff m has_real_derivative ?diff (Suc m) t) (at t)"
	by (auto intro!: derivative_eq_intros deriv_rec_correct deriv simp: set_of_eq xs_ne)
	have 4: "?a \<le> ?c" "?c \<le> ?b" "?a \<le> ?x" "?x \<le> ?b"
	using a xs_ne x
	by (force simp: set_of_eq)+

	define cr where "cr \<equiv> \<lambda>s m. if m < ord then ?diff m ?c / fact m - mid (z ! m)
	else ?diff m s / fact ord - mid (z ! ord)"
	define ci where "ci \<equiv> \<lambda>i. real_interval (z ! i) - interval_of (real_of_float (mid (z ! i)))"

	have cr_ord: "cr x ord \<in>\<^sub>i ci ord"
	using tmf_c_correct[OF xs'_in z_ord]
	by (auto simp: ci_def set_of_eq cr_def)

	have enclosure: "(\<Sum>m<ord. cr s m * (x - (xs ! 0)) ^ m) + cr s ord * (x - (xs ! 0)) ^ ord
	\<in>\<^sub>r round_interval prec (Ipoly (List.map2 (-) I (map interval_of xs)) (snd (tmf_polys z)))"
	if cr_ord: "cr s ord \<in>\<^sub>i ci ord" for s
	proof -
	have "(\<Sum>m<ord. cr s m * (x - xs!0) ^ m) + cr s ord * (x - xs!0) ^ ord =
	horner_eval (cr s) (x - xs!0) (Suc ord)"
	by (simp add: horner_eval_eq_setsum)
	also have "\<dots> \<in>\<^sub>i horner_eval ci (real_interval (I ! 0 - xs ! 0)) (Suc ord)"
	proof (rule horner_eval_interval)
	fix i assume "i < Suc ord"
	then consider "i < ord" \| "i = ord" by arith
	then show "cr s i \<in>\<^sub>i ci i"
	proof cases
	case 1
	then show ?thesis
	by (auto simp: cr_def ci_def not_less less_Suc_eq_le
	intro!: minus_in_intervalI tmf_c_correct[OF _ z_less])
	(metis in_set_of_interval_of list_update_id map_update nth_map real_interval_of)
	qed (simp add: cr_ord)
	qed (auto intro!: minus_in_intervalI simp: real_interval_minus x)
	also have "\<dots> = set_of (horner_eval (real_interval o centered \<circ> (!) z)
	(real_interval (I ! 0 - xs ! 0)) (length z))"
	by (auto simp: ci_def centered_def real_interval_minus real_interval_of lz)
	also have "\<dots> \<subseteq> set_of (Ipoly [real_interval (I ! 0 - xs ! 0)]
	(map_poly real_interval (snd (tmf_polys z))))"
	(is "_ \<subseteq> set_of ?x")
	by (rule Ipoly_snd_tmf_polys)
	also have "\<dots> = set_of (real_interval (Ipoly [(I ! 0 - xs ! 0)] (snd (tmf_polys z))))"
	by (auto simp: real_interval_Ipoly num_params_tmf_polys2)
	also have "\<dots> \<subseteq> set_of (real_interval (round_interval prec (Ipoly [(I ! 0 - xs ! 0)] (snd (tmf_polys z)))))"
	by (rule set_of_real_interval_subset) (rule round_ivl_correct)
	also
	have "Ipoly [I ! 0 - interval_of (xs ! 0)] (snd (tmf_polys z)) = Ipoly (List.map2 (-) I (map interval_of xs)) (snd (tmf_polys z))"
	using a
	apply (auto intro!: Ipoly_num_params_cong nth_equalityI
	simp: nth_Cons simp del:length_greater_0_conv split: nat.splits dest!: less_le_trans[OF _ num_params_tmf_polys2[of z]])
	apply (subst map2_nth)
	by simp_all
	finally show ?thesis .
	qed
	consider "0 < ord" "x \<noteq> xs ! 0" \| "0 < ord" "x = xs ! 0" \| "ord = 0" by arith
	then show ?thesis
	proof cases
	case hyps: 1
	then have 1: "0 < ord" and 5: "x \<noteq> xs ! 0" by simp_all
	from Taylor[OF 1 2 3 4 5] obtain s where s: "(if ?x < ?c then ?x < s \<and> s < ?c else ?c < s \<and> s < ?x)"
	and tse: "?f ?x = (\<Sum>m<?n. ?diff m ?c / fact m * (?x - ?c) ^ m) + ?diff ?n s / fact ?n * (?x - ?c) ^ ?n"
	by blast

	have "interpret_floatarith f ((map real_of_float xs)[0 := x]) -
	Ipoly (List.map2 (-) [x] [xs!0]) (fst (tmf_polys z)) =
	(\<Sum>m<?n. ?diff m ?c / fact m * (?x - ?c) ^ m) + ?diff ?n s / fact ?n * (?x - ?c) ^ ?n -
	(\<Sum>m\<le>?n. (x - xs!0) ^ m * mid (z ! m))"
	unfolding tse
	by (simp add: Ipoly_fst_tmf_polys rewr lz)
	also have "\<dots> = (\<Sum>m<ord. cr s m * (x - xs!0) ^ m) + cr s ord * (x - xs!0) ^ ord"
	unfolding rewr
	by (simp add: algebra_simps cr_def sum.distrib sum_subtractf)
	also have "cr s ord \<in>\<^sub>i ci ord"
	using a
	apply (auto simp: cr_def ci_def intro!: minus_in_intervalI
	tmf_c_correct[OF _ z_ord])
	by (smt "4"(1) "4"(2) "4"(3) "4"(4) a all_in_def in_real_intervalI length_greater_0_conv nth_list_update s xs_ne)
	note enclosure[OF this]
	also have "Ipoly (List.map2 (-) [x] (map real_of_float [xs ! 0])) (map_poly real_of_float (fst (tmf_polys z))) =
	insertion e (map_poly real_of_float (fst (tmf_polys z)))"
	using diff_e
	by (auto intro!: Ipoly_eq_insertionI simp: nth_Cons split: nat.splits dest: less_le_trans[OF _ num_params_tmf_polys1[of z]])
	finally
	show ?thesis
	by (simp add: tz tb range_tm_def set_of_eq)
	next
	case 3
	with 3 have "length z = Suc 0" by (simp add: lz)
	then have "fst (tmf_polys z) = fst (tmf_polys [z ! 0])"
	by (cases z) auto
	also have "\<dots> = CN (mid (z ! 0))\<^sub>p 0 0\<^sub>p"
	by simp
	finally have "fst (tmf_polys z) = CN (mid (z ! 0))\<^sub>p 0 0\<^sub>p" .
	with enclosure[OF cr_ord]
	show ?thesis
	by (simp add: cr_def 3 range_tm_def tz tb set_of_eq)
	next
	case 2
	have rewr: "{..<length z} = insert 0 {1..<length z}"
	by (auto simp: lz)
	from 2 enclosure[OF cr_ord]
	show ?thesis
	by (auto simp: zero_power 2 cr_def range_tm_def tz tb insertion_fst_tmf_polys
	diff_e[symmetric] rewr set_of_eq)
	qed
	qed


	subsection \<open>Operations on Taylor models\<close>

	fun tm_norm_poly :: "taylor_model \<Rightarrow> taylor_model"
	where "tm_norm_poly (TaylorModel p e) = TaylorModel (polynate p) e"
	\<comment> \<open>Normalizes the Taylor model by transforming its polynomial into horner form.\<close>

	fun tm_lower_order tm_lower_order_of_normed :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_lower_order prec ord I a t = tm_lower_order_of_normed prec ord I a (tm_norm_poly t)"
	\| "tm_lower_order_of_normed prec ord I a (TaylorModel p e) = (
	let (l, r) = split_by_degree ord p
	in TaylorModel l (round_interval prec (e + compute_bound_poly prec r I a))
	)"
	\<comment> \<open>Reduces the degree of a Taylor model's polynomial to n and keeps it range by increasing the error bound.\<close>

	fun tm_round_floats tm_round_floats_of_normed :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_round_floats prec I a t = tm_round_floats_of_normed prec I a (tm_norm_poly t)"
	\| "tm_round_floats_of_normed prec I a (TaylorModel p e) = (
	let (l, r) = split_by_prec prec p
	in TaylorModel l (round_interval prec (e + compute_bound_poly prec r I a))
	)"
	\<comment> \<open>Rounding of Taylor models. Rounds both the coefficients of the polynomial and the floats in the error bound.\<close>

	fun tm_norm tm_norm' :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_norm prec ord I a t = tm_norm' prec ord I a (tm_norm_poly t)"
	\| "tm_norm' prec ord I a t = tm_round_floats_of_normed prec I a (tm_lower_order_of_normed prec ord I a t)"
	\<comment> \<open>Normalization of taylor models. Performs order lowering and rounding on tayor models,
	also converts the polynomial into horner form.\<close>

	fun tm_neg :: "taylor_model \<Rightarrow> taylor_model"
	where "tm_neg (TaylorModel p e) = TaylorModel (~\<^sub>p p) (-e)"

	fun tm_add :: "taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_add (TaylorModel p1 e1) (TaylorModel p2 e2) = TaylorModel (p1 +\<^sub>p p2) (e1 + e2)"

	fun tm_sub :: "taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_sub t1 t2 = tm_add t1 (tm_neg t2)"

	fun tm_mul :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_mul prec ord I a (TaylorModel p1 e1) (TaylorModel p2 e2) = (
	let d1 = compute_bound_poly prec p1 I a;
	d2 = compute_bound_poly prec p2 I a;
	p = p1 *\<^sub>p p2;
	e = e1d2 + d1e2 + e1*e2
	in tm_norm' prec ord I a (TaylorModel p e)
	)"
	lemmas [simp del] = tm_norm'.simps

	fun tm_pow :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> nat \<Rightarrow> taylor_model"
	where "tm_pow prec ord I a t 0 = tm_const 1"
	\| "tm_pow prec ord I a t (Suc n) = (
	if odd (Suc n)
	then tm_mul prec ord I a t (tm_pow prec ord I a t n)
	else let t' = tm_pow prec ord I a t ((Suc n) div 2)
	in tm_mul prec ord I a t' t'
	)"

	text \<open>Evaluates a float polynomial, using a Taylor model as the parameter. This is used to compose Taylor models.\<close>
	fun eval_poly_at_tm :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> float poly \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "eval_poly_at_tm prec ord I a (poly.C c) t = tm_const c"
	\| "eval_poly_at_tm prec ord I a (poly.Bound n) t = t"
	\| "eval_poly_at_tm prec ord I a (poly.Add p1 p2) t
	= tm_add (eval_poly_at_tm prec ord I a p1 t)
	(eval_poly_at_tm prec ord I a p2 t)"
	\| "eval_poly_at_tm prec ord I a (poly.Sub p1 p2) t
	= tm_sub (eval_poly_at_tm prec ord I a p1 t)
	(eval_poly_at_tm prec ord I a p2 t)"
	\| "eval_poly_at_tm prec ord I a (poly.Mul p1 p2) t
	= tm_mul prec ord I a (eval_poly_at_tm prec ord I a p1 t)
	(eval_poly_at_tm prec ord I a p2 t)"
	\| "eval_poly_at_tm prec ord I a (poly.Neg p) t
	= tm_neg (eval_poly_at_tm prec ord I a p t)"
	\| "eval_poly_at_tm prec ord I a (poly.Pw p n) t
	= tm_pow prec ord I a (eval_poly_at_tm prec ord I a p t) n"
	\| "eval_poly_at_tm prec ord I a (poly.CN c n p) t = (
	let pt = eval_poly_at_tm prec ord I a p t;
	t_mul_pt = tm_mul prec ord I a t pt
	in tm_add (eval_poly_at_tm prec ord I a c t) t_mul_pt
	)"

	fun tm_inc_err :: "float interval \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_inc_err i (TaylorModel p e) = TaylorModel p (e + i)"

	fun tm_comp :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> float \<Rightarrow> taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_comp prec ord I a ta (TaylorModel p e) t = (
	let t_sub_ta = tm_sub t (tm_const ta);
	pt = eval_poly_at_tm prec ord I a p t_sub_ta
	in tm_inc_err e pt
	)"

	text \<open>\<open>tm_max\<close>, \<open>tm_min\<close> and \<open>tm_abs\<close> are implemented extremely naively, because I don't expect them to be very useful.
	But the implementation is fairly modular, i.e. \<open>tm_{abs,min,max}\<close> all can easily be swapped out,
	as long as the corresponding correctness lemmas \<open>tm_{abs,min,max}_range\<close> are updated as well.\<close>
	fun tm_abs :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_abs prec I a t = (
	let bound = compute_bound_tm prec I a t; abs_bound=Ivl (0::float) (max (abs (lower bound)) (abs (upper bound)))
	in TaylorModel (poly.C (mid abs_bound)) (centered abs_bound))"

	fun tm_union :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_union prec I a t1 t2 = (
	let b1 = compute_bound_tm prec I a t1; b2 = compute_bound_tm prec I a t2;
	b_combined = sup b1 b2
	in TaylorModel (poly.C (mid b_combined)) (centered b_combined))"

	fun tm_min :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_min prec I a t1 t2 = tm_union prec I a t1 t2"

	fun tm_max :: "nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> taylor_model \<Rightarrow> taylor_model \<Rightarrow> taylor_model"
	where "tm_max prec I a t1 t2 = tm_union prec I a t1 t2"

	text \<open>Rangeity of is preserved by our operations on Taylor models.\<close>

	lemma insertion_polyadd[simp]: "insertion e (a +\<^sub>p b) = insertion e a + insertion e b"
	for a b::"'a::ring_1 poly"
	apply (induction a b rule: polyadd.induct)
	apply (auto simp: algebra_simps Let_def)
	by (metis (no_types) mult_zero_right ring_class.ring_distribs(1))


	lemma insertion_polyneg[simp]: "insertion e (~\<^sub>p b) = - insertion e b"
	for b::"'a::ring_1 poly"
	by (induction b rule: polyneg.induct) (auto simp: algebra_simps Let_def)

	lemma insertion_polysub[simp]: "insertion e (a -\<^sub>p b) = insertion e a - insertion e b"
	for a b::"'a::ring_1 poly"
	by (simp add: polysub_def)

	lemma insertion_polymul[simp]: "insertion e (a \<^sub>p b) = insertion e a insertion e b"
	for a b::"'a::comm_ring_1 poly"
	by (induction a b rule: polymul.induct)
	(auto simp: algebra_simps Let_def)

	lemma insertion_polypow[simp]: "insertion e (a ^\<^sub>p b) = insertion e a ^ b"
	for a::"'a::comm_ring_1 poly"
	proof (induction b rule: nat_less_induct)
	case (1 n)
	then show ?case
	proof (cases n)
	case (Suc nat)
	then show ?thesis
	- apply (auto simp: )
	+ apply auto
	apply (auto simp: Let_def div2_less_self 1 simp del: polypow.simps)
	apply (metis even_Suc even_two_times_div_two odd_Suc_div_two semiring_normalization_rules(27) semiring_normalization_rules(36))
	apply (metis even_two_times_div_two semiring_normalization_rules(36))
	done
	qed simp
	qed

	lemma insertion_polynate [simp]:
	"insertion bs (polynate p) = (insertion bs p :: 'a::comm_ring_1)"
	- by (induct p rule: polynate.induct) (auto simp: )
	+ by (induct p rule: polynate.induct) auto

	lemma tm_norm_poly_range:
	assumes "x \<in>\<^sub>i range_tm e t"
	shows "x \<in>\<^sub>i range_tm e (tm_norm_poly t)"
	using assms
	by (cases t) (simp add: range_tm_def)

	lemma split_by_degree_correct_insertion:
	fixes x :: "nat \<Rightarrow> real" and p :: "float poly"
	assumes "split_by_degree ord p = (l, r)"
	shows "maxdegree l \<le> ord" (is ?P1)
	and "insertion x p = insertion x l + insertion x r" (is ?P2)
	and "num_params l \<le> num_params p" (is ?P3)
	and "num_params r \<le> num_params p" (is ?P4)
	proof -
	define xs where "xs = map x [0..<num_params p]"
	have xs: "i < num_params p \<Longrightarrow> x i = xs ! i" for i
	by (auto simp: xs_def)
	have "insertion x p = Ipoly xs p"
	by (auto intro!: insertion_eq_IpolyI xs)
	also
	from split_by_degree_correct[OF assms(1)[symmetric]]
	have "maxdegree l \<le> ord"
	and p: "Ipoly xs (map_poly real_of_float p) =
	Ipoly xs (map_poly real_of_float l) + Ipoly xs (map_poly real_of_float r)"
	and l: "num_params l \<le> num_params p"
	and r: "num_params r \<le> num_params p"
	by auto
	show ?P1 ?P3 ?P4 by fact+
	note p
	also have "Ipoly xs (map_poly real_of_float l) = insertion x l"
	using l
	by (auto intro!: xs Ipoly_eq_insertionI)
	also have "Ipoly xs (map_poly real_of_float r) = insertion x r"
	using r
	by (auto intro!: xs Ipoly_eq_insertionI)
	finally show ?P2 .
	qed

	lemma split_by_prec_correct_insertion:
	fixes x :: "nat \<Rightarrow> real" and p :: "float poly"
	assumes "split_by_prec ord p = (l, r)"
	shows "insertion x p = insertion x l + insertion x r" (is ?P1)
	and "num_params l \<le> num_params p" (is ?P2)
	and "num_params r \<le> num_params p" (is ?P3)
	proof -
	define xs where "xs = map x [0..<num_params p]"
	have xs: "i < num_params p \<Longrightarrow> x i = xs ! i" for i
	by (auto simp: xs_def)
	have "insertion x p = Ipoly xs p"
	by (auto intro!: insertion_eq_IpolyI xs)
	also
	from split_by_prec_correct[OF assms(1)[symmetric]]
	have p: "Ipoly xs (map_poly real_of_float p) =
	Ipoly xs (map_poly real_of_float l) + Ipoly xs (map_poly real_of_float r)"
	and l: "num_params l \<le> num_params p"
	and r: "num_params r \<le> num_params p"
	by auto
	show ?P2 ?P3 by fact+
	note p
	also have "Ipoly xs (map_poly real_of_float l) = insertion x l"
	using l
	by (auto intro!: xs Ipoly_eq_insertionI)
	also have "Ipoly xs (map_poly real_of_float r) = insertion x r"
	using r
	by (auto intro!: xs Ipoly_eq_insertionI)
	finally show ?P1 .
	qed

	lemma tm_lower_order_of_normed_range:
	assumes "x \<in>\<^sub>i range_tm e t"
	assumes dev: "develops_at_within e a I"
	assumes "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_lower_order_of_normed prec ord I a t)"
	proof-
	obtain p err where t_decomp: "t = TaylorModel p err"
	by (cases t) simp
	obtain pl pr where p_split: "split_by_degree ord p = (pl, pr)"
	by (cases "split_by_degree ord p", simp)

	from split_by_degree_correct_insertion[OF p_split]
	have params: "maxdegree pl \<le> ord" "num_params pl \<le> num_params p" "num_params pr \<le> num_params p"
	and ins: "insertion e (map_poly real_of_float p) =
	insertion e (map_poly real_of_float pl) + insertion e (map_poly real_of_float pr)"
	by auto
	from assms params have params_pr: "num_params pr \<le> length I" by (auto simp: t_decomp)

	have "range_tm e t =
	interval_of (insertion e (map_poly real_of_float pl)) +
	(interval_of (insertion e (map_poly real_of_float pr)) + real_interval err)"
	by (auto simp: t_decomp range_tm_def ins ac_simps interval_of_plus) term round_interval
	also have "set_of \<dots> \<subseteq> set_of (interval_of (insertion e pl)) +
	set_of (real_interval (round_interval prec (err + compute_bound_poly prec pr I a)))"
	unfolding set_of_plus real_interval_plus add.commute[of err]
	apply (rule set_plus_mono2[OF order_refl])
	apply (rule order_trans) prefer 2
	apply (rule set_of_real_interval_subset)
	apply (rule round_ivl_correct)
	unfolding set_of_plus real_interval_plus
	apply (rule set_plus_mono2[OF _ order_refl])
	apply (rule subsetI)
	apply simp
	apply (rule compute_bound_poly_correct)
	apply (rule params_pr)
	by (rule assms)
	also have "\<dots> = set_of (range_tm e (tm_lower_order_of_normed prec ord I a t))"
	by (simp add: t_decomp split_beta' Let_def p_split range_tm_def set_of_plus)
	finally show ?thesis using assms by auto
	qed

	lemma num_params_tm_norm_poly_le: "num_params (tm_poly (tm_norm_poly t)) \<le> X"
	if "num_params (tm_poly t) \<le> X"
	using that
	by (cases t) (auto simp: intro!: num_params_polynate[THEN order_trans])

	lemma tm_lower_order_range:
	assumes "x \<in>\<^sub>i range_tm e t"
	assumes dev: "develops_at_within e a I"
	assumes "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_lower_order prec ord I a t)"
	by (auto simp add: intro!: tm_lower_order_of_normed_range tm_norm_poly_range assms
	num_params_tm_norm_poly_le)

	lemma tm_round_floats_of_normed_range:
	assumes "x \<in>\<^sub>i range_tm e t"
	assumes dev: "develops_at_within e a I"
	assumes "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_round_floats_of_normed prec I a t)"
	\<comment> \<open>TODO: this is a clone of @{thm tm_lower_order_of_normed_range} -> general sweeping method!\<close>
	proof-
	obtain p err where t_decomp: "t = TaylorModel p err"
	by (cases t) simp
	obtain pl pr where p_prec: "split_by_prec prec p = (pl, pr)"
	by (cases "split_by_prec prec p", simp)

	from split_by_prec_correct_insertion[OF p_prec]
	have params: "num_params pl \<le> num_params p" "num_params pr \<le> num_params p"
	and ins: "insertion e (map_poly real_of_float p) =
	insertion e (map_poly real_of_float pl) + insertion e (map_poly real_of_float pr)"
	by auto
	from assms params have params_pr: "num_params pr \<le> length I"
	by (auto simp: t_decomp)

	have "range_tm e t =
	interval_of (insertion e (map_poly real_of_float pl)) +
	(interval_of (insertion e (map_poly real_of_float pr)) + real_interval err)"
	by (auto simp: t_decomp range_tm_def ins ac_simps interval_of_plus)
	also have "set_of \<dots> \<subseteq> set_of (interval_of (insertion e pl)) +
	set_of (real_interval (round_interval prec (err + compute_bound_poly prec pr I a)))"
	unfolding set_of_plus real_interval_plus add.commute[of err]
	apply (rule set_plus_mono2[OF order_refl])
	apply (rule order_trans) prefer 2
	apply (rule set_of_real_interval_subset)
	apply (rule round_ivl_correct)
	unfolding set_of_plus real_interval_plus
	apply (rule set_plus_mono2[OF _ order_refl])
	apply (rule subsetI)
	apply simp
	apply (rule compute_bound_poly_correct)
	apply (rule params_pr)
	by (rule assms)
	also have "\<dots> = set_of (range_tm e (tm_round_floats_of_normed prec I a t))"
	by (simp add: t_decomp split_beta' Let_def p_prec range_tm_def set_of_plus)
	finally show ?thesis using assms by auto
	qed

	lemma num_params_split_by_degree_le: "num_params (fst (split_by_degree ord x)) \<le> K"
	"num_params (snd (split_by_degree ord x)) \<le> K"
	if "num_params x \<le> K" for x::"float poly"
	using split_by_degree_correct_insertion(3,4)[of ord x, OF surjective_pairing] that
	by auto

	lemma num_params_split_by_prec_le: "num_params (fst (split_by_prec ord x)) \<le> K"
	"num_params (snd (split_by_prec ord x)) \<le> K"
	if "num_params x \<le> K" for x::"float poly"
	using split_by_prec_correct_insertion(2,3)[of ord x, OF surjective_pairing] that
	by auto

	lemma num_params_tm_norm'_le:
	"num_params (tm_poly (tm_round_floats_of_normed prec I a t)) \<le> X"
	if "num_params (tm_poly t) \<le> X"
	using that
	by (cases t) (auto simp: tm_norm'.simps split_beta' Let_def intro!: num_params_split_by_prec_le)

	lemma tm_round_floats_range:
	assumes "x \<in>\<^sub>i range_tm e t" "develops_at_within e a I" "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_round_floats prec I a t)"
	by (auto intro!: tm_round_floats_of_normed_range assms tm_norm_poly_range num_params_tm_norm_poly_le)

	lemma num_params_tm_lower_order_of_normed_le: "num_params (tm_poly (tm_lower_order_of_normed prec ord I a t)) \<le> X"
	if "num_params (tm_poly t) \<le> X"
	using that
	apply (cases t)
	apply (auto simp: split_beta' Let_def intro!: num_params_polynate[THEN order_trans])
	apply (rule order_trans[OF split_by_degree_correct(3)])
	by (auto simp: prod_eq_iff)


	lemma tm_norm'_range:
	assumes "x \<in>\<^sub>i range_tm e t" "develops_at_within e a I" "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_norm' prec ord I a t)"
	by (auto intro!: tm_round_floats_of_normed_range tm_lower_order_of_normed_range assms
	num_params_tm_norm_poly_le num_params_tm_lower_order_of_normed_le
	simp: tm_norm'.simps)

	lemma num_params_tm_norm':
	"num_params (tm_poly (tm_norm' prec ord I a t)) \<le> X"
	if "num_params (tm_poly t) \<le> X"
	using that
	by (cases t) (auto simp: tm_norm'.simps split_beta' Let_def
	intro!: num_params_tm_norm'_le num_params_split_by_prec_le num_params_split_by_degree_le)

	lemma tm_norm_range:
	assumes "x \<in>\<^sub>i range_tm e t" "develops_at_within e a I" "num_params (tm_poly t) \<le> length I"
	shows "x \<in>\<^sub>i range_tm e (tm_norm prec ord I a t)"
	by (auto intro!: assms tm_norm'_range tm_norm_poly_range num_params_tm_norm_poly_le)
	lemmas [simp del] = tm_norm.simps

	lemma tm_neg_range:
	assumes "x \<in>\<^sub>i range_tm e t"
	shows "- x \<in>\<^sub>i range_tm e (tm_neg t)"
	using assms
	by (cases t)
	(auto simp: set_of_eq range_tm_def interval_of_plus interval_of_uminus map_poly_homo_polyneg)
	lemmas [simp del] = tm_neg.simps


	lemma tm_bound_tm_add[simp]: "tm_bound (tm_add t1 t2) = tm_bound t1 + tm_bound t2"
	- by (cases t1; cases t2) (auto simp: )
	+ by (cases t1; cases t2) auto

	lemma interval_of_add: "interval_of (a + b) = interval_of a + interval_of b"
	by (auto intro!: interval_eqI)

	lemma tm_add_range:
	"x + y \<in>\<^sub>i range_tm e (tm_add t1 t2)"
	if "x \<in>\<^sub>i range_tm e t1"
	"y \<in>\<^sub>i range_tm e t2"
	proof -
	from range_tmD[OF that(1)] range_tmD[OF that(2)]
	show ?thesis
	apply (cases t1; cases t2)
	apply (rule range_tmI)
	by (auto simp: map_poly_homo_polyadd real_interval_plus ac_simps interval_of_add
	num_params_polyadd insertion_polyadd set_of_eq
	dest: less_le_trans[OF _ num_params_polyadd])
	qed
	lemmas [simp del] = tm_add.simps

	lemma tm_sub_range:
	assumes "x \<in>\<^sub>i range_tm e t1"
	assumes "y \<in>\<^sub>i range_tm e t2"
	shows "x - y \<in>\<^sub>i range_tm e (tm_sub t1 t2)"
	using tm_add_range[OF assms(1) tm_neg_range[OF assms(2)]]
	by simp
	lemmas [simp del] = tm_sub.simps

	lemma set_of_intervalI: "set_of (interval_of y) \<subseteq> set_of Y" if "y \<in>\<^sub>i Y" for y::"'a::order"
	using that by (auto simp: set_of_eq)

	lemma set_of_real_intervalI: "set_of (interval_of y) \<subseteq> set_of (real_interval Y)" if "y \<in>\<^sub>r Y"
	using that by (auto simp: set_of_eq)

	lemma tm_mul_range:
	assumes "x \<in>\<^sub>i range_tm e t1"
	assumes "y \<in>\<^sub>i range_tm e t2"
	assumes dev: "develops_at_within e a I"
	assumes params: "num_params (tm_poly t1) \<le> length I" "num_params (tm_poly t2) \<le> length I"
	shows "x * y \<in>\<^sub>i range_tm e (tm_mul prec ord I a t1 t2)"
	proof -
	define p1 where "p1 = tm_poly t1"
	define p2 where "p2 = tm_poly t2"
	define e1 where "e1 = tm_bound t1"
	define e2 where "e2 = tm_bound t2"
	have t1_def: "t1 = TaylorModel p1 e1" and t2_def: "t2 = TaylorModel p2 e2"
	by (auto simp: p1_def e1_def p2_def e2_def)
	from params have params: "num_params p1 \<le> length I" "num_params p2 \<le> length I"
	by (auto simp: p1_def p2_def)
	from range_tmD[OF assms(1)]
	obtain xe where x: "x = insertion e p1 + xe"
	(is "_ = ?x' + _")
	and xe: "xe \<in>\<^sub>r e1"
	by (auto simp: p1_def e1_def elim!: plus_in_intervalE)
	from range_tmD[OF assms(2)]
	obtain ye where y: "y = insertion e p2 + ye"
	(is "_ = ?y' + _")
	and ye: "ye \<in>\<^sub>r e2"
	by (auto simp: p2_def e2_def elim!: plus_in_intervalE)
	have "x * y = insertion e (p1 \<^sub>p p2) + (xe ?y' + ?x' * ye + xe * ye)"
	by (simp add: algebra_simps x y map_poly_homo_polymul)
	also have "\<dots> \<in>\<^sub>i range_tm e (tm_mul prec ord I a t1 t2)"
	by (auto intro!: tm_round_floats_of_normed_range assms tm_norm'_range
	simp: split_beta' Let_def t1_def t2_def)
	(auto simp: range_tm_def real_interval_plus real_interval_times intro!: plus_in_intervalI
	times_in_intervalI xe ye params compute_bound_poly_correct dev
	num_params_polymul[THEN order_trans])
	finally show ?thesis .
	qed

	lemma num_params_tm_mul_le:
	"num_params (tm_poly (tm_mul prec ord I a t1 t2)) \<le> X"
	if "num_params (tm_poly t1) \<le> X"
	"num_params (tm_poly t2) \<le> X"
	using that
	by (cases t1; cases t2)
	(auto simp: intro!: num_params_tm_norm' num_params_polymul[THEN order_trans])

	lemmas [simp del] = tm_pow.simps\<comment> \<open>TODO: make a systematic decision\<close>

	lemma
	shows tm_pow_range: "num_params (tm_poly t) \<le> length I \<Longrightarrow>
	develops_at_within e a I \<Longrightarrow>
	x \<in>\<^sub>i range_tm e t \<Longrightarrow>
	x ^ n \<in>\<^sub>i range_tm e (tm_pow prec ord I a t n)"
	and num_params_tm_pow_le[THEN order_trans]:
	"num_params (tm_poly (tm_pow prec ord I a t n)) \<le> num_params (tm_poly t)"
	unfolding atomize_conj atomize_imp
	proof(induction n arbitrary: x t rule: nat_less_induct)
	case (1 n)
	note IH1 = 1(1)[rule_format, THEN conjunct1, rule_format]
	note IH2 = 1(1)[rule_format, THEN conjunct2, THEN order_trans]
	show ?case
	proof (cases n)
	case 0
	then show ?thesis by (auto simp: tm_const_def range_tm_def set_of_eq tm_pow.simps)
	next
	case (Suc nat)
	have eq: "odd nat \<Longrightarrow> x * x ^ nat = x ^ ((Suc nat) div 2) * x ^ ((Suc nat) div 2)"
	apply (subst power_add[symmetric])
	unfolding div2_plus_div2
	by simp
	show ?thesis
	unfolding tm_pow.simps Suc
	using Suc
	apply (auto )
	subgoal
	apply (rule tm_mul_range) apply (assumption)
	apply (rule IH1) apply force
	apply assumption+
	apply (rule IH2) apply force
	apply assumption
	done
	subgoal
	apply (rule num_params_tm_mul_le) apply force
	apply (rule IH2) apply force
	apply force
	done
	subgoal
	apply (auto simp: Let_def)
	unfolding eq odd_Suc_div_two
	apply (rule tm_mul_range)
	subgoal by (rule IH1) (auto intro!: tm_mul_range num_params_tm_mul_le IH1 IH2 1
	simp: Let_def div2_less_self)
	subgoal by (rule IH1) (auto intro!: tm_mul_range num_params_tm_mul_le IH1 IH2 1
	simp: Let_def div2_less_self)
	subgoal by assumption
	subgoal by (rule IH2) (auto simp: div2_less_self 1)
	subgoal by (rule IH2) (auto simp: div2_less_self 1)
	done
	subgoal
	by (auto simp: Let_def div2_less_self 1 intro!: IH2 num_params_tm_mul_le)
	done
	qed
	qed

	lemma num_params_tm_add_le:
	"num_params (tm_poly (tm_add t1 t2)) \<le> X"
	if "num_params (tm_poly t1) \<le> X"
	"num_params (tm_poly t2) \<le> X"
	using that
	by (cases t1; cases t2)
	(auto simp: tm_add.simps
	intro!: num_params_tm_norm' num_params_polymul[THEN order_trans]
	num_params_polyadd[THEN order_trans])

	lemma num_params_tm_neg_eq[simp]:
	"num_params (tm_poly (tm_neg t1)) = num_params (tm_poly t1)"
	by (cases t1) (auto simp: tm_neg.simps num_params_polyneg)

	lemma num_params_tm_sub_le:
	"num_params (tm_poly (tm_sub t1 t2)) \<le> X"
	if "num_params (tm_poly t1) \<le> X"
	"num_params (tm_poly t2) \<le> X"
	using that
	by (cases t1; cases t2) (auto simp: tm_sub.simps intro!: num_params_tm_add_le)

	lemma num_params_eval_poly_le: "num_params (tm_poly (eval_poly_at_tm prec ord I a p t)) \<le> x"
	if "num_params (tm_poly t) \<le> x" "num_params p \<le> max 1 x"
	using that
	by (induction prec ord I a p t rule: eval_poly_at_tm.induct)
	(auto intro!: num_params_tm_add_le num_params_tm_sub_le num_params_tm_mul_le
	num_params_tm_pow_le)

	lemma eval_poly_at_tm_range:
	assumes "num_params p \<le> 1"
	assumes tg_def: "e' 0 \<in>\<^sub>i range_tm e tg"
	assumes dev: "develops_at_within e a I" and params: "num_params (tm_poly tg) \<le> length I"
	shows "insertion e' p \<in>\<^sub>i range_tm e (eval_poly_at_tm prec ord I a p tg)"
	using assms(1) params
	proof(induction p)
	case (C c) thus ?case
	using tg_def
	by (cases tg) (auto simp: tm_const_def range_tm_def real_interval_zero)
	next
	case (Bound n) thus ?case
	using tg_def
	by simp
	next
	case (Add p1l p1r) thus ?case
	using tm_add_range by (simp add: func_plus)
	next
	case (Sub p1l p1r) thus ?case
	using tm_sub_range by (simp add: fun_diff_def)
	next
	case (Mul p1l p1r) thus ?case
	by (auto intro!: tm_mul_range Mul dev num_params_eval_poly_le)
	next
	case (Neg p1') thus ?case
	using tm_neg_range by (simp add: fun_Compl_def)
	next
	case (Pw p1' n) thus ?case
	by (auto intro!: tm_pow_range Pw dev num_params_eval_poly_le)
	next
	case (CN p1l n p1r) thus ?case
	by (auto intro!: tm_mul_range tm_pow_range CN dev num_params_eval_poly_le tm_add_range tg_def)
	qed

	lemma tm_inc_err_range: "x \<in>\<^sub>i range_tm e (tm_inc_err i t)"
	if "x \<in>\<^sub>i range_tm e t + real_interval i"
	using that
	by (cases t) (auto simp: range_tm_def real_interval_plus ac_simps)

	lemma num_params_tm_inc_err: "num_params (tm_poly (tm_inc_err i t)) \<le> X"
	if "num_params (tm_poly t) \<le> X"
	using that
	by (cases t) auto

	lemma num_params_tm_comp_le: "num_params (tm_poly (tm_comp prec ord I a ga tf tg)) \<le> X"
	if "num_params (tm_poly tf) \<le> max 1 X" "num_params (tm_poly tg) \<le> X"
	using that
	by (cases tf) (auto intro!: num_params_tm_inc_err num_params_eval_poly_le num_params_tm_sub_le)

	lemma tm_comp_range:
	assumes tf_def: "x \<in>\<^sub>i range_tm e' tf"
	assumes tg_def: "e' 0 \<in>\<^sub>i range_tm e (tm_sub tg (tm_const ga))"
	assumes params: "num_params (tm_poly tf) \<le> 1" "num_params (tm_poly tg) \<le> length I"
	assumes dev: "develops_at_within e a I"
	shows "x \<in>\<^sub>i range_tm e (tm_comp prec ord I a ga tf tg)"
	proof-
	obtain pf ef where tf_decomp: "tf = TaylorModel pf ef" using taylor_model.exhaust by auto
	obtain pg eg where tg_decomp: "tg = TaylorModel pg eg" using taylor_model.exhaust by auto

	from params have params: "num_params pf \<le> Suc 0" "num_params pg \<le> length I"
	by (auto simp: tf_decomp tg_decomp)
	from tf_def obtain xe where x_def: "x = insertion e' pf + xe" "xe \<in>\<^sub>r ef"
	by (auto simp: tf_decomp range_tm_def elim!: plus_in_intervalE)
	show ?thesis
	using tg_def
	by (auto simp: tf_decomp tg_decomp x_def params dev
	intro!: tm_inc_err_range eval_poly_at_tm_range plus_in_intervalI num_params_tm_sub_le)
	qed

	lemma mid_centered_collapse:
	"interval_of (real_of_float (mid abs_bound)) + real_interval (centered abs_bound) =
	real_interval abs_bound"
	by (auto simp: centered_def interval_eq_iff)

	lemmas [simp del] = tm_abs.simps
	lemma tm_abs_range:
	assumes x: "x \<in>\<^sub>i range_tm e t"
	assumes n: "num_params (tm_poly t) \<le> length I" and d: "develops_at_within e a I"
	shows "abs x \<in>\<^sub>i range_tm e (tm_abs prec I a t)"
	proof-
	obtain p e where t_def[simp]: "t = TaylorModel p e" using taylor_model.exhaust by auto
	define bound where "bound = compute_bound_tm prec I a t"
	have bound: "x \<in>\<^sub>r bound"
	unfolding bound_def
	using n d x
	by (rule compute_bound_tm_correct)
	define abs_bound where "abs_bound \<equiv> Ivl 0 (max \<bar>lower bound\<bar> \<bar>upper bound\<bar>)"
	have abs_bound: "\<bar>x\<bar> \<in>\<^sub>r abs_bound" using bound
	by (auto simp: abs_bound_def set_of_eq abs_real_def max_def min_def)
	have tm_abs_decomp: "tm_abs prec I a t = TaylorModel (poly.C (mid abs_bound)) (centered abs_bound)"
	by (simp add: bound_def abs_bound_def Let_def tm_abs.simps)
	show ?thesis
	unfolding tm_abs_decomp
	by (rule range_tmI) (auto simp: mid_centered_collapse abs_bound)
	qed

	lemma num_params_tm_abs_le: "num_params (tm_poly (tm_abs prec I a t)) \<le> X" if "num_params (tm_poly t) \<le> X"
	using that
	by (auto simp: tm_abs.simps Let_def)

	lemma real_interval_sup: "real_interval (sup a b) = sup (real_interval a) (real_interval b)"
	by (auto simp: interval_eq_iff inf_real_def inf_float_def sup_float_def sup_real_def min_def max_def)

	lemma in_interval_supI1: "x \<in>\<^sub>i a \<Longrightarrow> x \<in>\<^sub>i sup a b"
	and in_interval_supI2: "x \<in>\<^sub>i b \<Longrightarrow> x \<in>\<^sub>i sup a b"
	for x::"'a::lattice"
	by (auto simp: set_of_eq le_infI1 le_infI2 le_supI1 le_supI2)

	lemma tm_union_range_left:
	assumes "x \<in>\<^sub>i range_tm e t1"
	"num_params (tm_poly t1) \<le> length I" "develops_at_within e a I"
	shows "x \<in>\<^sub>i range_tm e (tm_union prec I a t1 t2)"
	proof-
	define b1 where "b1 \<equiv> compute_bound_tm prec I a t1"
	define b2 where "b2 \<equiv> compute_bound_tm prec I a t2"
	define b_combined where "b_combined \<equiv> sup b1 b2"

	obtain p e where tm_union_decomp: "tm_union prec I a t1 t2 = TaylorModel p e"
	using taylor_model.exhaust by auto
	then have p_def: "p = (mid b_combined)\<^sub>p"
	and e_def: "e = centered b_combined"
	by (auto simp: Let_def b1_def b2_def b_combined_def interval_eq_iff)
	have "x \<in>\<^sub>r b1"
	by (auto simp : b1_def intro!: compute_bound_tm_correct assms)
	then have "x \<in>\<^sub>r b_combined"
	by (auto simp: b_combined_def real_interval_sup in_interval_supI1)
	then show ?thesis
	unfolding tm_union_decomp
	by (auto simp: range_tm_def p_def e_def mid_centered_collapse)
	qed

	lemma tm_union_range_right:
	assumes "x \<in>\<^sub>i range_tm e t2"
	"num_params (tm_poly t2) \<le> length I" "develops_at_within e a I"
	shows "x \<in>\<^sub>i range_tm e (tm_union prec I a t1 t2)"
	using tm_union_range_left[OF assms]
	by (simp add: interval_union_commute)

	lemma num_params_tm_union_le:
	"num_params (tm_poly (tm_union prec I a t1 t2)) \<le> X"
	if "num_params (tm_poly t1) \<le> X" "num_params (tm_poly t2) \<le> X"
	using that
	by (auto simp: Let_def)

	lemmas [simp del] = tm_union.simps tm_min.simps tm_max.simps

	lemma tm_min_range:
	assumes "x \<in>\<^sub>i range_tm e t1"
	assumes "y \<in>\<^sub>i range_tm e t2"
	"num_params (tm_poly t1) \<le> length I"
	"num_params (tm_poly t2) \<le> length I"
	"develops_at_within e a I"
	shows "min x y \<in>\<^sub>i range_tm e (tm_min prec I a t1 t2)"
	using assms
	by (auto simp: Let_def tm_min.simps min_def intro: tm_union_range_left tm_union_range_right)

	lemma tm_max_range:
	assumes "x \<in>\<^sub>i range_tm e t1"
	assumes "y \<in>\<^sub>i range_tm e t2"
	"num_params (tm_poly t1) \<le> length I"
	"num_params (tm_poly t2) \<le> length I"
	"develops_at_within e a I"
	shows "max x y \<in>\<^sub>i range_tm e (tm_max prec I a t1 t2)"
	using assms
	by (auto simp: Let_def tm_max.simps max_def intro: tm_union_range_left tm_union_range_right)


	subsection \<open>Computing Taylor models for multivariate expressions\<close>

	text \<open>Compute Taylor models for expressions of the form "f (g x)", where f is an elementary function like exp or cos,
	by composing Taylor models for f and g. For our correctness proof, we need to make it explicit that the range
	of g on I is inside the domain of f, by introducing the \<open>f_exists_on\<close> predicate.\<close>
	fun compute_tm_by_comp :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> floatarith \<Rightarrow> taylor_model option \<Rightarrow> (float interval \<Rightarrow> bool) \<Rightarrow> taylor_model option"
	where "compute_tm_by_comp prec ord I a f g f_exists_on = (
	case g
	of Some tg \<Rightarrow> (
	let gI = compute_bound_tm prec I a tg;
	ga = mid (compute_bound_tm prec a a tg)
	in if f_exists_on gI
	then map_option (\<lambda>tf. tm_comp prec ord I a ga tf tg ) (tm_floatarith prec ord [gI] [ga] f)
	else None)
	\| _ \<Rightarrow> None
	)"

	text \<open>Compute Taylor models with numerical precision \<open>prec\<close> of degree \<open>ord\<close>,
	with Taylor models in the environment \<open>env\<close> whose variables are jointly interpreted with domain
	\<open>I\<close> and expanded around point \<open>a\<close>.
	from floatarith expressions on a rectangular domain.\<close>
	fun approx_tm :: "nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> floatarith \<Rightarrow> taylor_model list \<Rightarrow>
	taylor_model option"
	where "approx_tm _ _ I _ (Num c) env = Some (tm_const c)"
	\| "approx_tm _ _ I a (Var n) env = (if n < length env then Some (env ! n) else None)"
	\| "approx_tm prec ord I a (Add l r) env = (
	case (approx_tm prec ord I a l env, approx_tm prec ord I a r env)
	of (Some t1, Some t2) \<Rightarrow> Some (tm_add t1 t2)
	\| _ \<Rightarrow> None)"
	\| "approx_tm prec ord I a (Minus f) env
	= map_option tm_neg (approx_tm prec ord I a f env)"
	\| "approx_tm prec ord I a (Mult l r) env = (
	case (approx_tm prec ord I a l env, approx_tm prec ord I a r env)
	of (Some t1, Some t2) \<Rightarrow> Some (tm_mul prec ord I a t1 t2)
	\| _ \<Rightarrow> None)"
	\| "approx_tm prec ord I a (Power f k) env
	= map_option (\<lambda>t. tm_pow prec ord I a t k)
	(approx_tm prec ord I a f env)"
	\| "approx_tm prec ord I a (Inverse f) env
	= compute_tm_by_comp prec ord I a (Inverse (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. 0 < lower x \<or> upper x < 0)"
	\| "approx_tm prec ord I a (Cos f) env
	= compute_tm_by_comp prec ord I a (Cos (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. True)"
	\| "approx_tm prec ord I a (Arctan f) env
	= compute_tm_by_comp prec ord I a (Arctan (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. True)"
	\| "approx_tm prec ord I a (Exp f) env
	= compute_tm_by_comp prec ord I a (Exp (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. True)"
	\| "approx_tm prec ord I a (Ln f) env
	= compute_tm_by_comp prec ord I a (Ln (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. 0 < lower x)"
	\| "approx_tm prec ord I a (Sqrt f) env
	= compute_tm_by_comp prec ord I a (Sqrt (Var 0)) (approx_tm prec ord I a f env) (\<lambda>x. 0 < lower x)"
	\| "approx_tm prec ord I a Pi env = Some (tm_pi prec)"
	\| "approx_tm prec ord I a (Abs f) env
	= map_option (tm_abs prec I a) (approx_tm prec ord I a f env)"
	\| "approx_tm prec ord I a (Min l r) env = (
	case (approx_tm prec ord I a l env, approx_tm prec ord I a r env)
	of (Some t1, Some t2) \<Rightarrow> Some (tm_min prec I a t1 t2)
	\| _ \<Rightarrow> None)"
	\| "approx_tm prec ord I a (Max l r) env = (
	case (approx_tm prec ord I a l env, approx_tm prec ord I a r env)
	of (Some t1, Some t2) \<Rightarrow> Some (tm_max prec I a t1 t2)
	\| _ \<Rightarrow> None)"
	\| "approx_tm prec ord I a (Powr l r) env = None" \<comment> \<open>TODO\<close>
	\| "approx_tm prec ord I a (Floor l) env = None" \<comment> \<open>TODO\<close>

	lemma mid_in_real_interval: "mid i \<in>\<^sub>r i"
	using lower_le_upper[of i]
	by (auto simp: mid_def set_of_eq powr_minus)

	lemma set_of_real_interval_mono:"set_of (real_interval x) \<subseteq> set_of (real_interval y)"
	if "set_of x \<subseteq> set_of y"
	using that by (auto simp: set_of_eq)

	lemmas [simp del] = compute_bound_poly.simps tm_floatarith.simps

	(*
	assumes tx_valid: "valid_tm I a (interpret_floatarith g) tg"
	assumes t_def: "compute_tm_on_ivl_by_comp prec ord I a f (Some tg) c = Some t"
	assumes f_deriv: "\<And>x. x \<in>\<^sub>r (compute_bound_tm prec I a tg) \<Longrightarrow> c (compute_bound_tm prec I a tg) \<Longrightarrow> isDERIV 0 f [x]"
	shows "valid_tm I a ((\<lambda>x. interpret_floatarith f [x]) o interpret_floatarith g) t"
	*)

	lemmas [simp del] = tmf_ivl_cs.simps compute_bound_tm.simps tmf_polys.simps

	lemma tm_floatarith_eq_Some_num_params:
	"tm_floatarith prec ord a b f = Some tf \<Longrightarrow> num_params (tm_poly tf) \<le> 1"
	by (auto simp: tm_floatarith.simps split_beta' Let_def those_eq_Some_iff num_params_tmf_polys1)

	lemma compute_tm_by_comp_range:
	assumes "max_Var_floatarith f \<le> 1"
	assumes a: "a all_subset I"
	assumes tx_range: "x \<in>\<^sub>i range_tm e tg"
	assumes t_def: "compute_tm_by_comp prec ord I a f (Some tg) c = Some t"
	assumes f_deriv:
	"\<And>x. x \<in>\<^sub>r compute_bound_tm prec I a tg \<Longrightarrow> c (compute_bound_tm prec I a tg) \<Longrightarrow> isDERIV 0 f [x]"
	assumes params: "num_params (tm_poly tg) \<le> length I"
	and dev: "develops_at_within e a I"
	shows "interpret_floatarith f [x] \<in>\<^sub>i range_tm e t"
	proof-
	from t_def[simplified, simplified Let_def]
	obtain tf
	where t1_def: "tm_floatarith prec ord [compute_bound_tm prec I (a) tg]
	[mid (compute_bound_tm prec a a tg)] f =
	Some tf"
	and t_decomp: "t = tm_comp prec ord I a (mid (compute_bound_tm prec a a tg)) tf tg "
	and c_true: "c (compute_bound_tm prec I a tg)"
	by (auto simp: split_beta' Let_def split: if_splits)
	have a1: "mid (compute_bound_tm prec a a tg) \<in>\<^sub>r (compute_bound_tm prec I a tg)"
	apply(rule rev_subsetD[OF mid_in_real_interval])
	apply (rule set_of_real_interval_mono)
	apply (rule compute_bound_tm_mono)
	using params a
	by (auto simp add: set_of_eq elim!: range_tmD)
	from \<open>max_Var_floatarith f \<le> 1\<close>
	have [simp]: "\<And>x. 0 \<le> length x \<Longrightarrow> (\<lambda>x. interpret_floatarith f [x ! 0]) x = interpret_floatarith f x"
	by (induction f, simp_all)

	let ?mid = "real_of_float (mid (compute_bound_tm prec a a tg))"
	have 1: "interpret_floatarith f [x] \<in>\<^sub>i range_tm (\<lambda>_. x - ?mid) tf"
	apply (rule tm_floatarith[OF t1_def, simplified])
	subgoal
	apply (rule rev_subsetD)
	apply (rule mid_in_real_interval)
	apply (rule set_of_real_interval_mono)
	apply (rule compute_bound_tm_mono)
	using assms
	by (auto)
	subgoal
	by (rule compute_bound_tm_correct assms)+
	subgoal by (auto intro!: assms c_true)
	- subgoal by (auto simp: )
	+ subgoal by auto
	done
	show ?thesis
	unfolding t_decomp
	apply (rule tm_comp_range)
	apply (rule 1)
	using tm_floatarith_eq_Some_num_params[OF t1_def]
	by (auto simp: intro!: tm_sub_range assms )
	qed

	lemmas [simp del] = compute_tm_by_comp.simps

	lemma compute_tm_by_comp_num_params_le:
	assumes "compute_tm_by_comp prec ord I a f (Some t0) i = Some t"
	assumes "1 \<le> X" "num_params (tm_poly t0) \<le> X"
	shows "num_params (tm_poly t) \<le> X"
	using assms
	by (auto simp: compute_tm_by_comp.simps Let_def intro!: num_params_tm_comp_le
	dest!: tm_floatarith_eq_Some_num_params
	split: option.splits if_splits)

	lemma compute_tm_by_comp_eq_Some_iff: "compute_tm_by_comp prec ord I a f t0 i = Some t \<longleftrightarrow>
	(\<exists>z x2. t0 = Some x2 \<and>
	tm_floatarith prec ord [compute_bound_tm prec I a x2]
	[mid (compute_bound_tm prec a a x2)] f =
	Some z
	\<and> tm_comp prec ord I a
	(mid (compute_bound_tm prec a a x2)) z x2 = t
	\<and> i (compute_bound_tm prec I a x2))"
	by (auto simp: compute_tm_by_comp.simps Let_def split: option.splits)

	lemma num_params_approx_tm:
	assumes "approx_tm prec ord I a f env = Some t"
	assumes "\<And>tm. tm \<in> set env \<Longrightarrow> num_params (tm_poly tm) \<le> length I"
	shows "num_params (tm_poly t) \<le> length I"
	using assms
	proof (induction f arbitrary: t)
	case (Add f1 f2)
	then show ?case by (auto split: option.splits intro!: num_params_tm_add_le)
	next
	case (Minus f)
	then show ?case by (auto split: option.splits)
	next
	case (Mult f1 f2)
	then show ?case by (auto split: option.splits intro!: num_params_tm_mul_le)
	next
	case (Inverse f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Cos f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Arctan f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Abs f)
	then show ?case
	by (auto simp: tm_abs.simps Let_def intro!: num_params_tm_union_le)
	next
	case (Max f1 f2)
	then show ?case
	by (auto simp: tm_max.simps Let_def intro!: num_params_tm_union_le split: option.splits)
	next
	case (Min f1 f2)
	then show ?case
	by (auto simp: tm_min.simps Let_def intro!: num_params_tm_union_le split: option.splits)
	next
	case Pi
	then show ?case
	by (auto )
	next
	case (Sqrt f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Exp f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Powr f1 f2)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Ln f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Power f x2a)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_pow_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Floor f)
	then show ?case
	by (auto split: option.splits simp: Let_def compute_tm_by_comp_eq_Some_iff
	intro!: num_params_tm_comp_le dest!: tm_floatarith_eq_Some_num_params)
	next
	case (Var x)
	then show ?case by (auto split: if_splits)
	next
	case (Num x)
	then show ?case by auto
	qed

	lemma in_interval_realI: "a \<in>\<^sub>i I" if "a \<in>\<^sub>r I" using that by (auto simp: set_of_eq)

	lemma all_subset_all_inI: "map interval_of a all_subset I" if "a all_in I"
	using that by (auto simp: in_interval_realI)

	lemma compute_tm_by_comp_None: "compute_tm_by_comp p ord I a x None k = None"
	by (rule ccontr) (auto simp: compute_tm_by_comp_eq_Some_iff)

	lemma approx_tm_num_Vars_None:
	assumes "max_Var_floatarith f > length env"
	shows "approx_tm p ord I a f env = None"
	using assms
	by (induction f) (auto split: option.splits if_splits simp: max_def compute_tm_by_comp_None)

	lemma approx_tm_num_Vars:
	assumes "approx_tm prec ord I a f env = Some t"
	shows "max_Var_floatarith f \<le> length env"
	apply (rule ccontr)
	using approx_tm_num_Vars_None[of env f prec ord I a] assms
	by auto

	definition "range_tms e xs = map (range_tm e) xs"

	lemma approx_tm_range:
	assumes a: "a all_subset I"
	assumes t_def: "approx_tm prec ord I a f env = Some t"
	assumes allin: "xs all_in\<^sub>i range_tms e env"
	assumes devs: "develops_at_within e a I"
	assumes env: "\<And>tm. tm \<in> set env \<Longrightarrow> num_params (tm_poly tm) \<le> length I"
	shows "interpret_floatarith f xs \<in>\<^sub>i range_tm e t"
	using t_def
	proof(induct f arbitrary: t)
	case (Var n)
	thus ?case
	using assms(2) allin approx_tm_num_Vars[of prec ord I a "Var n" env t]
	by (auto simp: all_in_i_def range_tms_def)
	next
	case (Num c)
	thus ?case
	using assms(2) by (auto simp add: assms(3))
	next
	case (Add l r t)
	obtain t1 where t1_def: "approx_tm prec ord I a l env = Some t1"
	by (metis (no_types, lifting) Add(3) approx_tm.simps(3) option.case_eq_if option.collapse prod.case)
	obtain t2 where t2_def: "approx_tm prec ord I a r env = Some t2"
	by (smt Add(3) approx_tm.simps(3) option.case_eq_if option.collapse prod.case)
	have t_def: "t = tm_add t1 t2"
	using Add(3) t1_def t2_def
	by (metis approx_tm.simps(3) option.case(2) option.inject prod.case)

	have [simp]: "interpret_floatarith (floatarith.Add l r) = interpret_floatarith l + interpret_floatarith r"
	by auto
	show ?case
	using Add
	by (auto simp: t_def intro!: tm_add_range Add t1_def t2_def)
	next
	case (Minus f t)
	have [simp]: "interpret_floatarith (Minus f) = -interpret_floatarith f"
	by auto

	obtain t1 where t1_def: "approx_tm prec ord I a f env = Some t1"
	by (metis Minus.prems(1) approx_tm.simps(4) map_option_eq_Some)
	have t_def: "t = tm_neg t1"
	by (metis Minus.prems(1) approx_tm.simps(4) option.inject option.simps(9) t1_def)

	show ?case
	by (auto simp: t_def intro!: tm_neg_range t1_def Minus)
	next
	case (Mult l r t)
	obtain t1 where t1_def: "approx_tm prec ord I a l env = Some t1"
	by (metis (no_types, lifting) Mult(3) approx_tm.simps(5) option.case_eq_if option.collapse prod.case)
	obtain t2 where t2_def: "approx_tm prec ord I a r env = Some t2"
	by (smt Mult(3) approx_tm.simps(5) option.case_eq_if option.collapse prod.case)
	have t_def: "t = tm_mul prec ord I a t1 t2"
	using Mult(3) t1_def t2_def
	by (metis approx_tm.simps(5) option.case(2) option.inject prod.case)

	have [simp]: "interpret_floatarith (floatarith.Mult l r) = interpret_floatarith l * interpret_floatarith r"
	by auto
	show ?case
	using env Mult
	by (auto simp add: t_def intro!: tm_mul_range Mult t1_def t2_def devs
	num_params_approx_tm[OF t1_def] num_params_approx_tm[OF t2_def])
	next
	case (Power f k t)
	from Power(2)
	obtain tm_f where tm_f_def: "approx_tm prec ord I a f env = Some tm_f"
	apply(simp) by metis
	have t_decomp: "t = tm_pow prec ord I a tm_f k"
	using Power(2) by (simp add: tm_f_def)
	show ?case
	using env Power
	by (auto simp add: t_def tm_f_def intro!: tm_pow_range Power devs
	num_params_approx_tm[OF tm_f_def])
	next
	case (Inverse f t)
	from Inverse obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have safe: "\<And>x. x \<in>\<^sub>r (compute_bound_tm prec I a tf) \<Longrightarrow>
	0 < lower (compute_bound_tm prec I a tf) \<or> upper (compute_bound_tm prec I a tf) < 0 \<Longrightarrow>
	isDERIV 0 (Inverse (Var 0)) [x]"
	by (simp add: set_of_eq , safe, simp_all)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	Inverse(1)[OF tf_def]
	Inverse(2)[unfolded approx_tm.simps tf_def]
	safe np devs]
	show ?case by simp
	next
	case hyps: (Cos f t)
	from hyps obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	hyps(1)[OF tf_def]
	hyps(2)[unfolded approx_tm.simps tf_def]
	_ np devs]
	show ?case by simp
	next
	case hyps: (Arctan f t)
	from hyps obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	hyps(1)[OF tf_def]
	hyps(2)[unfolded approx_tm.simps tf_def]
	_ np devs]
	show ?case by simp
	next
	case hyps: (Exp f t)
	from hyps obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	hyps(1)[OF tf_def]
	hyps(2)[unfolded approx_tm.simps tf_def]
	_ np devs]
	show ?case by simp
	next
	case hyps: (Ln f t)
	from hyps obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have safe: "\<And>x. x \<in>\<^sub>r compute_bound_tm prec I a tf \<Longrightarrow>
	0 < lower (compute_bound_tm prec I a tf) \<Longrightarrow> isDERIV 0 (Ln (Var 0)) [x]"
	by (auto simp: set_of_eq)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	hyps(1)[OF tf_def]
	hyps(2)[unfolded approx_tm.simps tf_def]
	safe np devs]
	show ?case by simp
	next
	case hyps: (Sqrt f t)
	from hyps obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	by (auto simp: compute_tm_by_comp_eq_Some_iff)
	have safe: "\<And>x. x \<in>\<^sub>r compute_bound_tm prec I a tf \<Longrightarrow>
	0 < lower (compute_bound_tm prec I a tf) \<Longrightarrow> isDERIV 0 (Sqrt (Var 0)) [x]"
	by (auto simp: set_of_eq)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from compute_tm_by_comp_range[OF _ a
	hyps(1)[OF tf_def]
	hyps(2)[unfolded approx_tm.simps tf_def]
	safe np devs]
	show ?case by simp
	next
	case (Pi t)
	hence "t = tm_pi prec" by simp
	then show ?case
	by (auto intro!: range_tm_tm_pi)
	next
	case (Abs f t)
	from Abs(2) obtain tf where tf_def: "approx_tm prec ord I a f env = Some tf"
	and t_def: "t = tm_abs prec I a tf"
	by (metis (no_types, lifting) approx_tm.simps(14) map_option_eq_Some)
	have np: "num_params (tm_poly tf) \<le> length I"
	using tf_def
	apply (rule num_params_approx_tm)
	using assms by auto
	from tm_abs_range[OF Abs(1)[OF tf_def] np devs]
	show ?case
	unfolding t_def interpret_floatarith.simps(9) comp_def
	by assumption
	next
	case hyps: (Min l r t)
	from hyps(3)
	obtain t1 t2 where t_decomp: "t = tm_min prec I a t1 t2"
	and t1_def: "Some t1 = approx_tm prec ord I a l env"
	and t2_def: "approx_tm prec ord I a r env = Some t2"
	by (smt approx_tm.simps(15) option.case_eq_if option.collapse option.distinct(2) option.inject split_conv)
	from this(2,3) hyps(1-3)
	have t1_range: "(interpret_floatarith l xs) \<in>\<^sub>i range_tm e t1"
	and t2_range: "(interpret_floatarith r xs) \<in>\<^sub>i range_tm e t2"
	by auto

	have [simp]: "interpret_floatarith (floatarith.Min l r) = (\<lambda>vs. min (interpret_floatarith l vs) (interpret_floatarith r vs))"
	by auto
	have np1: "num_params (tm_poly t1) \<le> length I"
	using t1_def[symmetric]
	apply (rule num_params_approx_tm)
	using assms by auto
	have np2: "num_params (tm_poly t2) \<le> length I"
	using t2_def
	apply (rule num_params_approx_tm)
	using assms by auto
	show ?case
	unfolding t_decomp(1)
	apply(simp del: tm_min.simps)
	using t1_range t2_range np1 np2
	by (auto intro!: tm_min_range devs)
	next
	case hyps: (Max l r t)
	from hyps(3)
	obtain t1 t2 where t_decomp: "t = tm_max prec I a t1 t2"
	and t1_def: "Some t1 = approx_tm prec ord I a l env"
	and t2_def: "approx_tm prec ord I a r env = Some t2"
	by (smt approx_tm.simps(16) option.case_eq_if option.collapse option.distinct(2) option.inject split_conv)
	from this(2,3) hyps(1-3)
	have t1_range: "(interpret_floatarith l xs) \<in>\<^sub>i range_tm e t1"
	and t2_range: "(interpret_floatarith r xs) \<in>\<^sub>i range_tm e t2"
	by auto

	have [simp]: "interpret_floatarith (floatarith.Min l r) = (\<lambda>vs. min (interpret_floatarith l vs) (interpret_floatarith r vs))"
	by auto
	have np1: "num_params (tm_poly t1) \<le> length I"
	using t1_def[symmetric]
	apply (rule num_params_approx_tm)
	using assms by auto
	have np2: "num_params (tm_poly t2) \<le> length I"
	using t2_def
	apply (rule num_params_approx_tm)
	using assms by auto
	show ?case
	unfolding t_decomp(1)
	apply(simp del: tm_min.simps)
	using t1_range t2_range np1 np2
	by (auto intro!: tm_max_range devs)
	qed simp_all


	text \<open>Evaluate expression with Taylor models in environment.\<close>

	subsection \<open>Computing bounds for floatarith expressions\<close>

	text \<open>TODO: compare parametrization of input vs. uncertainty for input...\<close>

	definition "tm_of_ivl_par n ivl = TaylorModel (CN (C ((upper ivl + lower ivl)*Float 1 (-1))) n
	(C ((upper ivl - lower ivl)*Float 1 (-1)))) 0"
	\<comment> \<open>track uncertainty in parameter \<open>n\<close>, which is to be interpreted over standardized domain \<open>[-1, 1]\<close>.\<close>

	value "tm_of_ivl_par 3 (Ivl (-1) 1)"

	definition "tms_of_ivls ivls = map (\<lambda>(i, ivl). tm_of_ivl_par i ivl) (zip [0..<length ivls] ivls)"

	value "tms_of_ivls [Ivl 1 2, Ivl 4 5]"

	primrec approx_slp'::"nat \<Rightarrow> nat \<Rightarrow> float interval list \<Rightarrow> float interval list \<Rightarrow> slp \<Rightarrow>
	taylor_model list \<Rightarrow> taylor_model list option"
	where
	"approx_slp' p ord I a [] xs = Some xs"
	\| "approx_slp' p ord I a (ea # eas) xs =
	do {
	r \<leftarrow> approx_tm p ord I a ea xs;
	approx_slp' p ord I a eas (r#xs)
	}"

	lemma mem_range_tms_Cons_iff[simp]: "x#xs all_in\<^sub>i range_tms e (X#XS) \<longleftrightarrow> x \<in>\<^sub>i range_tm e X \<and> xs all_in\<^sub>i range_tms e XS"
	by (auto simp: range_tms_def all_in_i_def nth_Cons split: nat.splits)

	lemma approx_slp'_range:
	assumes i: "i all_subset I"
	assumes dev: "develops_at_within e i I"
	assumes vs: "vs all_in\<^sub>i range_tms e VS" "(\<And>tm. tm \<in> set VS \<Longrightarrow> num_params (tm_poly tm) \<le> length I)"
	assumes appr: "approx_slp' p ord I i ra VS = Some X"
	shows "interpret_slp ra vs all_in\<^sub>i range_tms e X"
	using appr vs
	proof (induction ra arbitrary: X vs VS)
	case (Cons ra ras)
	from Cons.prems
	obtain a where a: "approx_tm p ord I i ra VS = Some a"
	and r: "approx_slp' p ord I i ras (a # VS) = Some X"
	by (auto simp: bind_eq_Some_conv)
	from approx_tm_range[OF i a Cons.prems(2) dev Cons.prems(3)]
	have "interpret_floatarith ra vs \<in>\<^sub>i range_tm e a"
	by auto
	then have 1: "interpret_floatarith ra vs#vs all_in\<^sub>i range_tms e (a#VS)"
	using Cons.prems(2)
	by auto
	show ?case
	apply auto
	apply (rule Cons.IH)
	apply (rule r)
	apply (rule 1)
	apply auto
	apply (rule num_params_approx_tm)
	apply (rule a)
	by (auto intro!: Cons.prems)
	qed auto

	definition approx_slp::"nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> slp \<Rightarrow> taylor_model list \<Rightarrow> taylor_model list option"
	where
	"approx_slp p ord d slp tms =
	map_option (take d)
	(approx_slp' p ord (replicate (length tms) (Ivl (-1) 1)) (replicate (length tms) 0) slp tms)"

	lemma length_range_tms[simp]: "length (range_tms e VS) = length VS"
	by (auto simp: range_tms_def)

	lemma set_of_Ivl: "set_of (Ivl a b) = {a .. b}" if "a \<le> b"
	by (auto simp: set_of_eq that min_def)

	lemma set_of_zero[simp]: "set_of 0 = {0::'a::ordered_comm_monoid_add}"
	by (auto simp: set_of_eq)

	theorem approx_slp_range_tms:
	assumes "approx_slp p ord d slp VS = Some X"
	assumes slp_def: "slp = slp_of_fas fas"
	assumes d_def: "d = length fas"
	assumes e: "e \<in> UNIV \<rightarrow> {-1 .. 1}"
	assumes vs: "vs all_in\<^sub>i range_tms e VS"
	assumes lens: "\<And>tm. tm \<in> set VS \<Longrightarrow> num_params (tm_poly tm) \<le> length vs"
	shows "interpret_floatariths fas vs all_in\<^sub>i range_tms e X"
	proof -
	have "interpret_floatariths fas vs = take d (interpret_slp slp vs)"
	by (simp add: slp_of_fas slp_def d_def)
	also
	have lvs: "length vs = length VS"
	using assms by (auto simp: all_in_i_def)
	define i where "i = replicate (length vs) (0::float interval)"
	define I where "I = replicate (length vs) (Ivl (-1) 1::float interval)"
	from assms obtain XS where
	XS: "approx_slp' p ord I i slp VS = Some XS"
	and X: "take d XS = X"
	by (auto simp: approx_slp_def lvs i_def I_def)
	have iI: "i all_subset I"
	by (auto simp: i_def I_def set_of_Ivl)
	have dev: "develops_at_within e i I"
	using e
	by (auto simp: develops_at_within_def i_def I_def set_of_Ivl real_interval_Ivl
	real_interval_minus real_interval_zero set_of_eq Pi_iff min_def)
	from approx_slp'_range[OF iI dev vs _ XS] lens
	have "interpret_slp slp vs all_in\<^sub>i range_tms e XS" by (auto simp: I_def)
	then have "take d (interpret_slp slp vs) all_in\<^sub>i range_tms e (take d XS)"
	by (auto simp: all_in_i_def range_tms_def)
	also note \<open>take d XS = X\<close>
	finally show ?thesis .
	qed

	end

	end
	\ No newline at end of file
	diff --git a/thys/VerifyThis2019/Challenge3.thy b/thys/VerifyThis2019/Challenge3.thy
	--- a/thys/VerifyThis2019/Challenge3.thy
	+++ b/thys/VerifyThis2019/Challenge3.thy
	@@ -1,128 +1,128 @@
	section \<open>Challenge 3\<close>
	theory Challenge3
	imports Parallel_Multiset_Fold Refine_Imperative_HOL.IICF
	begin

	text \<open>Problem definition:
	\<^url>\<open>https://ethz.ch/content/dam/ethz/special-interest/infk/chair-program-method/pm/documents/Verify%20This/Challenges%202019/sparse_matrix_multiplication.pdf\<close>\<close>

	subsection \<open>Single-Threaded Implementation\<close>
	text \<open>We define type synonyms for values (which we fix to integers here) and
	triplets, which are a pair of coordinates and a value.
	\<close>
	type_synonym val = int
	type_synonym triplet = "(nat \<times> nat) \<times> val"

	text \<open>We fix a size \<open>n\<close> for the vector.\<close>
	context
	fixes n :: nat
	begin

	text \<open>An algorithm finishing triples in any order.
	\<close>
	definition
	"alg (ts :: triplet list) x = fold_mset (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) (\<lambda>_. 0 :: int) (mset ts)"

	text \<open>
	We show that the folding function is commutative, i.e., the order of the folding does not matter.
	We will use this below to show that the computation can be parallelized.
	\<close>
	interpretation comp_fun_commute "(\<lambda>((r, c), v) y. y(c := (y c :: val) + x r * v))"
	apply unfold_locales
	apply (auto intro!: ext)
	done

	subsection \<open>Specification\<close>
	text \<open>Abstraction function, mapping a sparse matrix to a function from coordinates to values.\<close>
	definition \<alpha> :: "triplet list \<Rightarrow> (nat \<times> nat) \<Rightarrow> val" where
	"\<alpha> = the_default 0 oo map_of"

	text \<open>Abstract product.\<close>
	definition "pr m x i \<equiv> \<Sum>k=0..<n. x k * m (k, i)"

	subsection \<open>Correctness\<close>

	lemma aux:
	"
	distinct (map fst (ts1@ts2)) \<Longrightarrow>
	the_default (0::val) (case map_of ts1 (k, i) of None \<Rightarrow> map_of ts2 (k, i) \| Some x \<Rightarrow> Some x)

	= the_default 0 (map_of ts1 (k, i)) + the_default 0 (map_of ts2 (k, i))
	"
	apply (auto split: option.splits)
	by (metis disjoint_iff_not_equal img_fst map_of_eq_None_iff the_default.simps(2))

	lemma 1[simp]: "distinct (map fst (ts1@ts2)) \<Longrightarrow>
	pr (\<alpha> (ts1@ts2)) x i = pr (\<alpha> ts1) x i + pr (\<alpha> ts2) x i"
	apply (auto simp: pr_def \<alpha>_def map_add_def aux split: option.splits)
	apply (auto simp: algebra_simps)
	by (simp add: sum.distrib)

	lemmas 2 = 1[of "[((r,c),v)]" "ts", simplified] for r c v ts

	lemma [simp]: "\<alpha> [] = (\<lambda>_. 0)" by (auto simp: \<alpha>_def)

	lemma [simp]: "pr (\<lambda>_. 0::val) x = (\<lambda>_. 0)"
	by (auto simp: pr_def[abs_def])

	lemma aux3: "the_default 0 (if b then Some x else None) = (if b then x else 0)"
	by auto

	lemma correct_aux: "\<lbrakk>distinct (map fst ts); \<forall>((r,c),_)\<in>set ts. r<n\<rbrakk>
	\<Longrightarrow> \<forall>i. fold (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) ts m i = m i + pr (\<alpha> ts) x i"
	apply (induction ts arbitrary: m)
	- apply (auto simp: )
	+ apply auto
	subgoal
	apply (subst 2)
	apply auto
	unfolding pr_def \<alpha>_def
	apply (auto split: if_splits cong: sum.cong simp: aux3)
	apply (auto simp: if_distrib[where f="\<lambda>x. _*x"] cong: sum.cong if_cong)
	done

	subgoal
	apply (subst 2)
	apply auto
	unfolding pr_def \<alpha>_def
	apply (auto split: if_splits cong: sum.cong simp: aux3)
	done
	done


	lemma correct_fold:
	assumes "distinct (map fst ts)"
	assumes "\<forall>((r,c),_)\<in>set ts. r<n"
	shows "fold (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) ts (\<lambda>_. 0) = pr (\<alpha> ts) x"
	apply (rule ext)
	using correct_aux[OF assms, rule_format, where m = "\<lambda>_. 0", simplified]
	by simp

	lemma alg_by_fold: "alg ts x = fold (\<lambda>((r,c),v) y. y(c:=y c + x r * v)) ts (\<lambda>_. 0)"
	unfolding alg_def by (simp add: fold_mset_rewr)

	theorem correct:
	assumes "distinct (map fst ts)"
	assumes "\<forall>((r,c),_)\<in>set ts. r<n"
	shows "alg ts x = pr (\<alpha> ts) x"
	using alg_by_fold correct_fold[OF assms] by simp

	subsection \<open>Multi-Threaded Implementation\<close>
	text \<open>Correctness of the parallel implementation:\<close>
	theorem parallel_correct:
	assumes "distinct (map fst ts)" "\<forall>((r,c),_)\<in>set ts. r<n"
	and "0 < n" \<comment> \<open>At least on thread\<close>
	\<comment>\<open>We have reached a final state.\<close>
	and "reachable x n ts (\<lambda>_. 0) (ts', ms, r)" "final n (ts', ms, r)"
	shows "r = pr (\<alpha> ts) x"
	unfolding final_state_correct[OF assms(3-)] correct[OF assms(1,2)] alg_by_fold[symmetric] ..

	text \<open>We also know that the computation will always terminate.\<close>
	theorem parallel_termination:
	assumes "0 < n"
	and "reachable x n ts (\<lambda>_. 0) s"
	shows "\<exists>s'. final n s' \<and> (step x n)\<^sup>\<^sup> s s'"
	using assms by (rule "termination")

	end \<comment> \<open>Context for fixed \<open>n\<close>.\<close>

	end
	\ No newline at end of file
	diff --git a/thys/Virtual_Substitution/Debruijn.thy b/thys/Virtual_Substitution/Debruijn.thy
	--- a/thys/Virtual_Substitution/Debruijn.thy
	+++ b/thys/Virtual_Substitution/Debruijn.thy
	@@ -1,897 +1,897 @@
	section "Debruijn Indicies Formulation"
	theory Debruijn
	imports PolyAtoms
	begin
	subsection "Lift and Lower Functions"

	text "these functions are required for debruijn notation
	the (liftPoly n a p) functions increment each variable greater n in polynomial p by a
	the (lowerPoly n a p) functions lower each variable greater than n by a so variables n through n+a-1 shouldn't exist
	"
	context includes poly_mapping.lifting begin

	definition "inc_above b i x = (if x < b then x else x + i::nat)"
	definition "dec_above b i x = (if x \<le> b then x else x - i::nat)"

	lemma inc_above_dec_above: "x < b \<or> b + i \<le> x \<Longrightarrow> inc_above b i (dec_above b i x) = x"
	by (auto simp: inc_above_def dec_above_def)
	lemma dec_above_inc_above: "dec_above b i (inc_above b i x) = x"
	by (auto simp: inc_above_def dec_above_def)

	lemma inc_above_dec_above_iff: "inc_above b i (dec_above b i x) = x \<longleftrightarrow> x < b \<or> b + i \<le> x"
	by (auto simp: inc_above_def dec_above_def)

	lemma inj_on_dec_above: "inj_on (dec_above b i) {x. x < b \<or> b + i \<le> x}"
	by (rule inj_on_inverseI[where g = "inc_above b i"]) (auto simp: inc_above_dec_above)

	lemma finite_inc_above_ne: "finite {x. f x \<noteq> c} \<Longrightarrow> finite {x. f (inc_above b i x) \<noteq> c}"
	proof -
	fix b and f::"nat\<Rightarrow>'a"
	assume f: "finite {x. f x \<noteq> c}"
	moreover
	have "finite {x. f (x + i) \<noteq> c}"
	proof -
	have "{x. f (x + i) \<noteq> c} = (+) i -` {x. f x \<noteq> c}"
	by (auto simp: ac_simps)
	also have "finite \<dots>"
	by (rule finite_vimageI) (use f in auto)
	finally show ?thesis .
	qed
	ultimately have "finite ({x. f x \<noteq> c} \<union> {x. f (x + i) \<noteq> c})"
	by auto
	from _ this show "finite {x. f (inc_above b i x) \<noteq> c}"
	by (rule finite_subset) (auto simp: inc_above_def)
	qed

	lemma finite_dec_above_ne: "finite {x. f x \<noteq> c} \<Longrightarrow> finite {x. f (dec_above b i x) \<noteq> c}"
	proof -
	fix b and f::"nat\<Rightarrow>'a"
	assume f: "finite {x. f x \<noteq> c}"
	moreover
	have "finite {x. f (x - i) \<noteq> c}"
	proof -
	have "{x. f (x - i) \<noteq> c} \<subseteq> {0..i} \<union> ((\<lambda>x. x - i) -` {x. f x \<noteq> c} \<inter> {i<..})"
	by auto
	also have "finite \<dots>"
	apply (rule finite_UnI[OF finite_atLeastAtMost])
	by (rule finite_vimage_IntI) (use f in \<open>auto simp: inj_on_def\<close>)
	finally (finite_subset) show ?thesis .
	qed
	ultimately have "finite ({x. f x \<noteq> c} \<union> {x. f (x - i) \<noteq> c} \<union> {b})"
	by auto
	from _ this show "finite {x. f (dec_above b i x) \<noteq> c}"
	by (rule finite_subset) (auto simp: dec_above_def)
	qed

	lift_definition lowerPowers::"nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
	is "\<lambda>b i p x. if x \<in> {b..<b+i} then 0 else p (dec_above b i x)::'a"
	proof -
	fix b i::nat and p::"nat \<Rightarrow> 'a"
	assume "finite {x. p x \<noteq> 0}"
	then have "finite {x. p (dec_above b i x) \<noteq> 0}"
	by (rule finite_dec_above_ne)
	from _ this show "finite {x. (if x \<in> {b..<b+i} then 0 else p (dec_above b i x)) \<noteq> 0}"
	by (rule finite_subset) auto
	qed

	lift_definition higherPowers::"nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a) \<Rightarrow> (nat \<Rightarrow>\<^sub>0 'a::zero)"
	is "\<lambda>b i p x. p (inc_above b i x)::'a"
	by (simp_all add: finite_inc_above_ne)

	lemma higherPowers_lowerPowers: "higherPowers n i (lowerPowers n i x) = x"
	by transfer (force simp: dec_above_def inc_above_def antisym_conv2)

	lemma inj_lowerPowers: "inj (lowerPowers b i)"
	using higherPowers_lowerPowers
	by (rule inj_on_inverseI)

	lemma lowerPowers_higherPowers:
	"(\<And>j. n \<le> j \<Longrightarrow> j < n + i \<Longrightarrow> lookup x j = 0) \<Longrightarrow> lowerPowers n i (higherPowers n i x) = x"
	by (transfer fixing: n i) (force simp: inc_above_dec_above)

	lemma inj_on_higherPowers: "inj_on (higherPowers n i) {x. \<forall>j. n \<le> j \<and> j < n + i \<longrightarrow> lookup x j = 0}"
	using lowerPowers_higherPowers
	by (rule inj_on_inverseI) auto

	lemma higherPowers_eq: "lookup (higherPowers b i p) x = lookup p (inc_above b i x)"
	by (simp_all add: higherPowers.rep_eq)

	lemma lowerPowers_eq: "lookup (lowerPowers b i p) x = (if b \<le> x \<and> x < b + i then 0 else lookup p (dec_above b i x))"
	by (auto simp add: lowerPowers.rep_eq)

	lemma keys_higherPowers: "keys (higherPowers b i m) = dec_above b i ` (keys m \<inter> {x. x \<notin> {b..<b+i}})"
	apply safe
	subgoal for x
	apply (rule image_eqI[where x="inc_above b i x"])
	apply (auto simp: dec_above_inc_above in_keys_iff higherPowers.rep_eq)
	by (metis add_less_cancel_right inc_above_def leD)
	subgoal for x
	by (auto simp: inc_above_dec_above in_keys_iff higherPowers.rep_eq)
	done

	context includes fmap.lifting begin

	lift_definition lowerPowers\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> (nat, 'a) fmap \<Rightarrow> (nat, 'a::zero) fmap"
	is "\<lambda>b i p x. if x \<in> {b..<b+i} then None else p (dec_above b i x)"
	proof -
	fix b i::nat and p::"nat \<Rightarrow> 'a option"
	assume "finite (dom p)"
	then have "finite {x. p x \<noteq> None}" by (simp add: dom_def)

	have "dom (\<lambda>x. p (dec_above b i x)) = {x. p (dec_above b i x) \<noteq> None}"
	by auto
	also have "finite \<dots>"
	by (rule finite_dec_above_ne) fact
	finally
	have "finite (dom (\<lambda>x. p (dec_above b i x)))" .
	from _ this
	show "finite (dom (\<lambda>x. if x \<in> {b..<b+i} then None else p (dec_above b i x)))"
	by (rule finite_subset) (auto split: if_splits)
	qed

	lift_definition higherPowers\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> (nat, 'a) fmap \<Rightarrow> (nat, 'a) fmap"
	is "\<lambda>b i f x. f (inc_above b i x)"
	proof -
	fix b i::nat and f::"nat \<Rightarrow> 'a option"
	assume "finite (dom f)"
	then have "finite {i. f i \<noteq> None}" by (simp add: dom_def)

	have "dom (\<lambda>x. f (inc_above b i x)) = {x. f (inc_above b i x) \<noteq> None}"
	by auto
	also have "finite \<dots>"
	by (rule finite_inc_above_ne) fact
	finally show "finite (dom (\<lambda>x. f (inc_above b i x)))"
	.
	qed

	lemma map_of_map_key_inverse_fun_eq:
	"map_of (map (\<lambda>(k, y). (f k, y)) xs) x = map_of xs (g x)"
	if "\<And>x. x \<in> set xs \<Longrightarrow> g (f (fst x)) = fst x" "f (g x) = x"
	for f::"'a \<Rightarrow> 'b"
	using that
	proof (induction xs)
	case Nil
	then show ?case by simp
	next
	case (Cons a xs)
	from Cons
	have IH: "map_of (map (\<lambda>a. (f (fst a), snd a)) xs) x = map_of xs (g x)"
	by (auto simp: split_beta')
	have inv_into: "g (f (fst a)) = fst a"
	by (rule Cons) simp
	show ?case
	using Cons
	by (auto simp add: split_beta' inv_into IH)
	qed

	lemma map_of_filter_key_in: "P x \<Longrightarrow> map_of (filter (\<lambda>(k, v). P k) xs) x = map_of xs x"
	- by (induction xs) (auto simp: )
	+ by (induction xs) auto

	lemma map_of_eq_NoneI: "x\<notin>fst`set xs \<Longrightarrow> map_of xs x = None"
	- by (induction xs) (auto simp: )
	+ by (induction xs) auto

	lemma compute_higherPowers\<^sub>f[code]: "higherPowers\<^sub>f b i (fmap_of_list xs) =
	fmap_of_list (map (\<lambda>(k, v). (if k < b then k else k - i, v)) (filter (\<lambda>(k, v). k \<notin> {b..<b+i}) xs))"
	proof -
	have *: "map_of (map (\<lambda>(k, y). (if k < b then k else k - i, y)) (filter (\<lambda>(k, v). b \<le> k \<longrightarrow> \<not> k < b + i) xs)) x =
	map_of (filter (\<lambda>(k, v). b \<le> k \<longrightarrow> \<not> k < b + i) xs) (if x < b then x else x + i)"
	for x
	by (rule map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k + i"
	and f = "\<lambda>k. if k < b then k else k - i"]) auto
	show ?thesis
	by (auto
	simp add: * higherPowers\<^sub>f.rep_eq lowerPowers\<^sub>f.rep_eq fmlookup_of_list fmlookup_default_def
	inc_above_def
	map_of_filter_key_in
	split: option.splits
	intro!: fmap_ext)
	qed

	lemma compute_lowerPowers\<^sub>f[code]: "lowerPowers\<^sub>f b i (fmap_of_list xs) =
	fmap_of_list (map (\<lambda>(k, v). (if k < b then k else k + i, v)) xs)"
	apply (auto
	simp add: lowerPowers\<^sub>f.rep_eq fmlookup_of_list fmlookup_default_def
	dec_above_def
	map_of_filter_key_in
	split: option.splits
	intro!: fmap_ext)
	subgoal by (rule map_of_eq_NoneI[symmetric]) (auto split: if_splits)
	subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
	subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
	subgoal by (rule map_of_eq_NoneI[symmetric]) (auto split: if_splits)
	subgoal by (subst map_of_map_key_inverse_fun_eq[where g="\<lambda>k. if k < b then k else k - i"]) auto
	done

	lemma compute_higherPowers[code]: "higherPowers n i (Pm_fmap xs) = Pm_fmap (higherPowers\<^sub>f n i xs)"
	by (rule poly_mapping_eqI)
	(auto simp: higherPowers\<^sub>f.rep_eq higherPowers.rep_eq fmlookup_default_def dec_above_def
	split: option.splits)

	lemma compute_lowerPowers[code]: "lowerPowers n i (Pm_fmap xs) = Pm_fmap (lowerPowers\<^sub>f n i xs)"
	by (rule poly_mapping_eqI)
	(auto simp: lowerPowers\<^sub>f.rep_eq lowerPowers.rep_eq fmlookup_default_def dec_above_def
	split: option.splits)

	lemma finite_nonzero_coeff: "finite {x. MPoly_Type.coeff mpoly x \<noteq> 0}"
	by transfer auto

	lift_definition lowerPoly\<^sub>0::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0'a::zero) \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0 'a)" is
	"\<lambda>b i (mp::(nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>'a) mon. mp (lowerPowers b i mon)"
	proof -
	fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
	assume "finite {x. mp x \<noteq> 0}"
	have "{x. mp (lowerPowers b i x) \<noteq> 0} = (lowerPowers b i -` {x. mp x \<noteq> 0})"
	(is "?set = ?vimage")
	by auto
	also
	from finite_vimageI[OF \<open>finite _\<close> inj_lowerPowers]
	have "finite ?vimage" .
	finally show "finite ?set" .
	qed

	lemma higherPowers_zero[simp]: "higherPowers b i 0 = 0"
	by transfer auto

	lemma keys_lowerPoly\<^sub>0: "keys (lowerPoly\<^sub>0 b i mp) = higherPowers b i ` (keys mp \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
	apply (auto )
	subgoal for x
	apply (rule image_eqI[where x="lowerPowers b i x"])
	apply (auto simp: higherPowers_lowerPowers in_keys_iff lowerPoly\<^sub>0.rep_eq lowerPowers.rep_eq)
	done
	subgoal for x
	apply (auto simp: in_keys_iff lowerPoly\<^sub>0.rep_eq)
	apply (subst (asm) lowerPowers_higherPowers)
	apply auto
	done
	done


	lift_definition higherPoly\<^sub>0::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0'a::zero) \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>\<^sub>0 'a)" is
	"\<lambda>b i (mp::(nat\<Rightarrow>\<^sub>0nat)\<Rightarrow>'a) mon.
	if (\<exists>j\<in>{b..<b+i}. lookup mon j > 0)
	then 0
	else mp (higherPowers b i mon)"
	proof -
	fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a"
	assume "finite {x. mp x \<noteq> 0}"
	have "{x. (if \<exists>j\<in>{b..<b + i}. 0 < lookup x j then 0 else mp (higherPowers b i x)) \<noteq> 0} \<subseteq>
	insert 0 (higherPowers b i -` {x. mp x \<noteq> 0} \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
	(is "?set \<subseteq> ?vimage")
	by auto
	also
	from finite_vimage_IntI[OF \<open>finite _\<close> inj_on_higherPowers, of b i]
	have "finite ?vimage" by (auto simp: Ball_def)
	finally (finite_subset) show "finite ?set" .
	qed


	context includes fmap.lifting begin

	lift_definition lowerPoly\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a::zero)fmap \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a)fmap" is
	"\<lambda>b i (mp::((nat\<Rightarrow>\<^sub>0nat)\<rightharpoonup>'a)) mon::(nat\<Rightarrow>\<^sub>0nat). mp (lowerPowers b i mon)"
	proof -\<comment> \<open>TODO: this is exactly the same proof as the one for \<open>lowerPoly\<^sub>0\<close>\<close>
	fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<Rightarrow> 'a option"
	assume "finite (dom mp)"
	also have "dom mp = {x. mp x \<noteq> None}" by auto
	finally have "finite {x. mp x \<noteq> None}" .
	have "(dom (\<lambda>mon. mp (lowerPowers b i mon))) = {mon. mp (lowerPowers b i mon) \<noteq> None}"
	(is "?set = _")
	by (auto split: if_splits)
	also have "\<dots> = lowerPowers b i -` {x. mp x \<noteq> None}" (is "_ = ?vimage")
	by auto
	also
	from finite_vimageI[OF \<open>finite {x. mp x \<noteq> None}\<close> inj_lowerPowers]
	have "finite ?vimage" .
	finally show "finite ?set" .
	qed

	lift_definition higherPoly\<^sub>f::"nat \<Rightarrow> nat \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a::zero)fmap \<Rightarrow> ((nat\<Rightarrow>\<^sub>0nat), 'a)fmap" is
	"\<lambda>b i (mp::((nat\<Rightarrow>\<^sub>0nat)\<rightharpoonup>'a)) mon::(nat\<Rightarrow>\<^sub>0nat).
	if (\<exists>j\<in>{b..<b+i}. lookup mon j > 0)
	then None
	else mp (higherPowers b i mon)"
	proof -
	fix b i and mp::"(nat \<Rightarrow>\<^sub>0 nat) \<rightharpoonup> 'a"
	assume "finite (dom mp)"
	have "dom (\<lambda>x. (if \<exists>j\<in>{b..<b + i}. 0 < lookup x j then None else mp (higherPowers b i x))) \<subseteq>
	insert 0 (higherPowers b i -` (dom mp) \<inter> {x. \<forall>j\<in>{b..<b+i}. lookup x j = 0})"
	(is "?set \<subseteq> ?vimage")
	by (auto split: if_splits)
	also
	from finite_vimage_IntI[OF \<open>finite _\<close> inj_on_higherPowers, of b i]
	have "finite ?vimage" by (auto simp: Ball_def)
	finally (finite_subset) show "finite ?set" .
	qed


	lemma keys_lowerPowers: "keys (lowerPowers b i m) = inc_above b i ` (keys m)"
	apply safe
	subgoal for x
	apply (rule image_eqI[where x="dec_above b i x"])
	apply (auto simp: inc_above_dec_above in_keys_iff lowerPowers.rep_eq)
	apply (metis inc_above_dec_above not_less)
	by meson
	by (metis higherPowers.rep_eq higherPowers_lowerPowers in_keys_iff)


	lemma keys_higherPoly\<^sub>0: "keys (higherPoly\<^sub>0 b i mp) = lowerPowers b i ` (keys mp)"
	apply (auto )
	subgoal for x
	apply (rule image_eqI[where x="higherPowers b i x"])
	apply (auto simp: lowerPowers_higherPowers in_keys_iff higherPoly\<^sub>0.rep_eq higherPowers.rep_eq)
	apply (metis atLeastLessThan_iff lowerPowers_higherPowers neq0_conv)
	by meson
	subgoal for x
	apply (auto simp: in_keys_iff higherPoly\<^sub>0.rep_eq)
	apply (simp add: lowerPowers_eq)
	by (simp add: higherPowers_lowerPowers)
	done

	end

	lemma inc_above_id[simp]: "n < m \<Longrightarrow> inc_above m i n = n" by (auto simp: inc_above_def)
	lemma inc_above_Suc[simp]: "n \<ge> m \<Longrightarrow> inc_above m i n = n + i" by (auto simp: inc_above_def)

	lemma compute_lowerPoly\<^sub>0[code]: "lowerPoly\<^sub>0 n i (Pm_fmap m) = Pm_fmap (lowerPoly\<^sub>f n i m)"
	by (auto simp: lowerPoly\<^sub>0.rep_eq fmlookup_default_def lowerPoly\<^sub>f.rep_eq
	split: option.splits
	intro!: poly_mapping_eqI)

	lemma compute_higherPoly\<^sub>0[code]: "higherPoly\<^sub>0 n i (Pm_fmap m) = Pm_fmap (higherPoly\<^sub>f n i m)"
	by (auto simp: higherPoly\<^sub>0.rep_eq fmlookup_default_def higherPoly\<^sub>f.rep_eq
	split: option.splits
	intro!: poly_mapping_eqI)

	lemma compute_lowerPoly\<^sub>f[code]: "lowerPoly\<^sub>f n i (fmap_of_list xs) =
	(fmap_of_list (map (\<lambda>(mon, c). (higherPowers n i mon, c))
	(filter (\<lambda>(mon, v). \<forall>j\<in>{n..<n+i}. lookup mon j = 0) xs)))"
	apply (rule sym)
	apply (rule fmap_ext)
	unfolding lowerPoly\<^sub>f.rep_eq fmlookup_of_list
	apply (subst map_of_map_key_inverse_fun_eq[where g="lowerPowers n i"])
	subgoal
	by (auto simp add: lowerPowers_higherPowers)
	subgoal by (auto simp add: higherPowers_lowerPowers)
	apply (auto simp: fmlookup_of_list lowerPoly\<^sub>f.rep_eq map_of_eq_None_iff map_of_filter_key_in
	fmdom'_fmap_of_list higherPowers.rep_eq lowerPowers.rep_eq dec_above_def
	intro!: fmap_ext)
	done

	lemma compute_higherPoly\<^sub>f[code]: "higherPoly\<^sub>f n i (fmap_of_list xs) =
	fmap_of_list (filter (\<lambda>(mon, v). \<forall>j\<in>{n..<n+i}. lookup mon j = 0)
	(map (\<lambda>(mon, c). (lowerPowers n i mon, c)) xs))"
	apply (rule sym)
	apply (rule fmap_ext)
	unfolding higherPoly\<^sub>f.rep_eq fmlookup_of_list
	apply auto
	subgoal
	by (rule map_of_eq_NoneI) auto
	subgoal
	apply (subst map_of_filter_key_in)
	apply auto
	apply (subst map_of_map_key_inverse_fun_eq[where g="higherPowers n i"])
	subgoal
	by (auto simp add: higherPowers_lowerPowers)
	subgoal by (auto simp add: lowerPowers_higherPowers)
	apply (auto simp: fmlookup_of_list lowerPoly\<^sub>f.rep_eq map_of_eq_None_iff map_of_filter_key_in
	fmdom'_fmap_of_list higherPowers.rep_eq lowerPowers.rep_eq dec_above_def
	intro!: fmap_ext)
	done
	done

	end

	lift_definition lowerPoly::"nat \<Rightarrow> nat \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" is lowerPoly\<^sub>0 .
	lift_definition liftPoly::"nat \<Rightarrow> nat \<Rightarrow> 'a::zero mpoly \<Rightarrow> 'a mpoly" is higherPoly\<^sub>0 .

	lemma coeff_lowerPoly: "MPoly_Type.coeff (lowerPoly b i mp) x = MPoly_Type.coeff mp (lowerPowers b i x)"
	by (transfer') (simp add: lowerPoly\<^sub>0.rep_eq lowerPowers.rep_eq)

	lemma coeff_liftPoly: "MPoly_Type.coeff (liftPoly b i mp) x = (if (\<exists>j\<in>{b..<b+i}. lookup x j > 0)
	then 0
	else MPoly_Type.coeff mp (higherPowers b i x))"
	by (transfer') (simp add: higherPowers.rep_eq higherPoly\<^sub>0.rep_eq )

	lemma monomials_lowerPoly: "monomials (lowerPoly b i mp) = higherPowers b i ` (monomials mp \<inter> {x. \<forall>j\<in>{b..<b + i}. lookup x j = 0}) "
	by transfer' (simp add: keys_lowerPoly\<^sub>0)


	lemma monomials_liftPoly: "monomials (liftPoly b i mp) = lowerPowers b i ` (monomials mp) "
	using keys_higherPoly\<^sub>0
	by (simp add: keys_higherPoly\<^sub>0 liftPoly.rep_eq monomials.rep_eq)


	value [code] "lowerPoly 1 1 (1 * Var 0 + 2 * Var 2 ^ 2 + 3 * Var 3 ^ 4::int mpoly) = (Var 0 + 2 * Var 1^2 + 3 * Var 2^4::int mpoly)"
	value [code] "lowerPoly 1 3 (1 * Var 0 + 2 * Var 4 ^ 2 + 3 * Var 5 ^ 4::int mpoly) = (Var 0 + 2 * Var 1^2 + 3 * Var 2^4::int mpoly)"

	value [code] "liftPoly 1 3 (1 * Var 0 + 2 * Var 4 ^ 2 + 3 * Var 5 ^ 4::int mpoly) = (Var 0 + 2 * Var 7^2 + 3 * Var 8^4::int mpoly)"

	fun lowerAtom :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
	"lowerAtom d amount (Eq p) = Eq(lowerPoly d amount p)"\|
	"lowerAtom d amount (Less p) = Less(lowerPoly d amount p)"\|
	"lowerAtom d amount (Leq p) = Leq(lowerPoly d amount p)"\|
	"lowerAtom d amount (Neq p) = Neq(lowerPoly d amount p)"

	lemma lookup_not_in_vars_eq_zero: "x \<in> monomials p \<Longrightarrow> i \<notin> vars p \<Longrightarrow> lookup x i = 0"
	by (meson degree_eq_iff varNotIn_degree)

	lemma nth_dec_above:
	assumes "length xs = i" "length ys = j" "k \<notin> {i..<i+j}"
	shows "nth_default 0 (xs @ zs) (dec_above i j k) = (nth_default 0 (xs @ ys @ zs)) k"
	using assms dec_above_def nth_append add.commute
	by (smt add_diff_cancel_left add_le_cancel_left add_strict_increasing append_Nil2 atLeastLessThan_iff le_add_diff_inverse length_append length_greater_0_conv less_imp_le_nat not_less nth_default_append)

	lemma insertion_lowerPoly:
	assumes i_notin: "vars p \<inter> {i..<i+j} = {}"
	and lprfx: "length prfx = i"
	and lxs: "length xs = j"
	shows "insertion (nth_default 0 (prfx@L)) (lowerPoly i j p) = insertion (nth_default 0 (prfx@xs@L)) p" (is "?lhs = ?rhs")
	proof -
	have *: "monomials p \<inter> {x. \<forall>j\<in>{i..<i + j}. lookup x j = 0} = monomials p"
	using assms(1) by (auto intro: lookup_not_in_vars_eq_zero)
	then have "monomials p \<subseteq> {x. \<forall>k. i \<le> k \<and> k < i + j \<longrightarrow> lookup x k = 0}"
	by force
	have "?lhs = (\<Sum>m\<in>monomials (lowerPoly i j p). MPoly_Type.coeff (lowerPoly i j p) m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ L)) k ^ lookup m k))"
	unfolding insertion_code ..
	also have "\<dots> = (\<Sum>m\<in>monomials p.
	MPoly_Type.coeff p m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L) k) ^ lookup m k))"
	proof (rule sum.reindex_cong)
	note inj_on_higherPowers[of i j]
	moreover note \<open>monomials p \<subseteq> _\<close>
	ultimately show "inj_on (higherPowers i j) (monomials p)"
	by (rule inj_on_subset)
	next
	show "monomials (lowerPoly i j p) = higherPowers i j ` monomials p"
	unfolding monomials_lowerPoly * ..
	next
	fix m
	assume m: "m \<in> monomials p"
	from m \<open>monomials p \<subseteq> _\<close> have "keys m \<subseteq> {x. x \<notin> {i..<i + j}}"
	by auto
	then have "lookup m k = 0" if "i \<le> k" "k < i + j" for k
	using that by (auto simp: in_keys_iff)
	then have "lowerPowers i j (higherPowers i j m) = m"
	by (rule lowerPowers_higherPowers)
	then have "MPoly_Type.coeff (lowerPoly i j p) (higherPowers i j m) = MPoly_Type.coeff p m"
	unfolding coeff_lowerPoly by simp
	moreover
	have "(\<Prod>k\<in>keys (higherPowers i j m). (nth_default 0 (prfx @ L)) k ^ lookup (higherPowers i j m) k) =
	(\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L)) k ^ lookup m k)"
	proof (rule prod.reindex_cong)
	show "keys (higherPowers i j m) = dec_above i j ` keys m"
	unfolding keys_higherPowers using \<open>keys m \<subseteq> _\<close> by auto
	next
	from inj_on_dec_above[of i j]
	show "inj_on (dec_above i j) (keys m)"
	by (rule inj_on_subset) (use \<open>keys m \<subseteq> _\<close> in auto)
	next
	fix k assume k: "k \<in> keys m"
	from k \<open>keys m \<subseteq> _\<close> have "k \<notin> {i..<i+j}" by auto
	from k \<open>keys m \<subseteq> _\<close>
	have "inc_above i j (dec_above i j k) = k"
	by (subst inc_above_dec_above) auto
	then have "lookup (higherPowers i j m) (dec_above i j k) = lookup m k"
	unfolding higherPowers.rep_eq by simp
	moreover have "nth_default 0 (prfx @ L) (dec_above i j k) = (nth_default 0 (prfx @ xs @ L)) k"
	apply (rule nth_dec_above)
	using assms \<open>k \<notin> _\<close>
	by auto
	ultimately
	show "((nth_default 0 (prfx @ L)) (dec_above i j k)) ^ lookup (higherPowers i j m) (dec_above i j k) = ((nth_default 0 (prfx @ xs @ L)) k) ^ lookup m k"
	by simp
	qed
	ultimately
	show "MPoly_Type.coeff (lowerPoly i j p) (higherPowers i j m) * (\<Prod>k\<in>keys (higherPowers i j m). (nth_default 0(prfx @ L)) k ^ lookup (higherPowers i j m) k) =
	MPoly_Type.coeff p m * (\<Prod>k\<in>keys m. (nth_default 0 (prfx @ xs @ L)) k ^ lookup m k)"
	by simp
	qed
	finally show ?thesis
	unfolding insertion_code .
	qed

	lemma insertion_lowerPoly1:
	assumes i_notin: "i \<notin> vars p"
	and lprfx: "length prfx = i"
	shows "insertion (nth_default 0 (prfx@x#L)) p = insertion (nth_default 0 (prfx@L)) (lowerPoly i 1 p)"
	using assms nth_default_def apply simp
	by (subst insertion_lowerPoly[where xs="[x]"]) auto

	lemma insertion_lowerPoly01:
	assumes i_notin: "0 \<notin> vars p"
	shows "insertion (nth_default 0 (x#L)) p = insertion (nth_default 0 L) (lowerPoly 0 1 p)"
	using insertion_lowerPoly1[OF assms, of Nil x L]
	by simp

	lemma aEval_lowerAtom : "(freeIn 0 (Atom A)) \<Longrightarrow> (aEval A (x#L) = aEval (lowerAtom 0 1 A) L)"
	by (cases A) (simp_all add:insertion_lowerPoly01)


	fun map_fm_binders :: "(atom \<Rightarrow> nat \<Rightarrow> atom) \<Rightarrow> atom fm \<Rightarrow> nat \<Rightarrow> atom fm" where
	"map_fm_binders f TrueF n = TrueF"\|
	"map_fm_binders f FalseF n = FalseF"\|
	"map_fm_binders f (Atom \<phi>) n = Atom (f \<phi> n)"\|
	"map_fm_binders f (And \<phi> \<psi>) n = And (map_fm_binders f \<phi> n) (map_fm_binders f \<psi> n)"\|
	"map_fm_binders f (Or \<phi> \<psi>) n = Or (map_fm_binders f \<phi> n) (map_fm_binders f \<psi> n)"\|
	"map_fm_binders f (ExQ \<phi>) n = ExQ(map_fm_binders f \<phi> (n+1))"\|
	"map_fm_binders f (AllQ \<phi>) n = AllQ(map_fm_binders f \<phi> (n+1))"\|
	"map_fm_binders f (AllN i \<phi>) n = AllN i (map_fm_binders f \<phi> (n+i))"\|
	"map_fm_binders f (ExN i \<phi>) n = ExN i (map_fm_binders f \<phi> (n+i))"\|
	"map_fm_binders f (Neg \<phi>) n = Neg(map_fm_binders f \<phi> n)"



	fun lowerFm :: "nat \<Rightarrow> nat \<Rightarrow> atom fm \<Rightarrow> atom fm" where
	"lowerFm d amount f = map_fm_binders (\<lambda>a. \<lambda>x. lowerAtom (d+x) amount a) f 0"

	fun delete_nth :: "nat \<Rightarrow> real list \<Rightarrow> real list" where
	"delete_nth n xs = take n xs @ drop n xs"

	lemma eval_lowerFm_helper :
	assumes "freeIn i F"
	assumes "length init = i"
	shows "eval (lowerFm i 1 F) (init @xs) = eval F (init@[x]@xs)"
	using assms
	proof(induction F arbitrary : i init)
	case TrueF
	then show ?case by simp
	next
	case FalseF
	then show ?case by simp
	next
	case (Atom A)
	then show ?case apply(cases A) by (simp_all add: insertion_lowerPoly1)
	next
	case (And F1 F2)
	then show ?case by auto
	next
	case (Or F1 F2)
	then show ?case by auto
	next
	case (Neg F)
	then show ?case by simp
	next
	case (ExQ F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + 1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + 1 + x) 1 a) F y)"
	apply(induction F) by(simp_all)
	show ?case apply simp apply(rule ex_cong1)
	subgoal for xa
	using map[of 0] ExQ(1)[of "Suc i" "xa#init"] ExQ(2) ExQ(3)
	by simp
	done
	next
	case (AllQ F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + 1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + 1 + x) 1 a) F y)"
	apply(induction F) by(simp_all)
	show ?case apply simp apply(rule all_cong1)
	subgoal for xa
	using map[of 0] AllQ(1)[of "Suc i" "xa#init"] AllQ(2) AllQ(3)
	by simp
	done
	next
	case (ExN x1 F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + x1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + x1 + x) 1 a) F y)"
	apply(induction F) apply(simp_all add:add.commute add.left_commute)
	apply (metis add_Suc)
	apply (metis add_Suc)
	apply (metis add.assoc)
	by (metis add.assoc)
	show ?case apply simp apply(rule ex_cong1)
	subgoal for l
	using map[of 0] ExN(1)[of "i+x1" "l@init"] ExN(2) ExN(3)
	by auto
	done
	next
	case (AllN x1 F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. lowerAtom (i + x) 1 a) F (y + x1)) = (map_fm_binders (\<lambda>a x. lowerAtom (i + x1 + x) 1 a) F y)"
	apply(induction F) apply(simp_all add:add.commute add.left_commute)
	apply (metis add_Suc)
	apply (metis add_Suc)
	apply (metis add.assoc)
	by (metis add.assoc)
	show ?case apply simp apply(rule all_cong1)
	subgoal for l
	using map[of 0] AllN(1)[of "i+x1" "l@init"] AllN(2) AllN(3)
	by auto
	done
	qed

	lemma eval_lowerFm :
	assumes h : "freeIn 0 F"
	shows " \<forall>xs. (eval (lowerFm 0 1 F) xs = eval (ExQ F) xs)"
	using eval_lowerFm_helper[OF h] by simp

	fun liftAtom :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom" where
	"liftAtom d amount (Eq p) = Eq(liftPoly d amount p)"\|
	"liftAtom d amount (Less p) = Less(liftPoly d amount p)"\|
	"liftAtom d amount (Leq p) = Leq(liftPoly d amount p)"\|
	"liftAtom d amount (Neq p) = Neq(liftPoly d amount p)"


	fun liftFm :: "nat \<Rightarrow> nat \<Rightarrow> atom fm \<Rightarrow> atom fm" where
	"liftFm d amount f = map_fm_binders (\<lambda>a. \<lambda>x. liftAtom (d+x) amount a) f 0"

	fun insert_into :: "real list \<Rightarrow> nat \<Rightarrow> real list \<Rightarrow> real list" where
	"insert_into xs n l = take n xs @ l @ drop n xs"


	lemma higherPoly\<^sub>0_add : "higherPoly\<^sub>0 x y (p + q) = higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"
	using poly_mapping_eq_iff[where a = "higherPoly\<^sub>0 x y (p + q)", where b = "higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"]
	plus_poly_mapping.rep_eq[where x = "higherPoly\<^sub>0 x y (p + q)", where xa = "higherPoly\<^sub>0 x y p + higherPoly\<^sub>0 x y q"]
	apply (auto)
	by (simp add: higherPoly\<^sub>0.rep_eq lookup_add poly_mapping_eqI)

	lemma liftPoly_add: "liftPoly w z (a + b) = (liftPoly w z a) + (liftPoly w z b)"
	unfolding liftPoly_def apply (auto)
	proof -
	have h1: "mapping_of (a + b) = mapping_of a + mapping_of b"
	by (simp add: plus_mpoly.rep_eq)
	have h2: "MPoly (higherPoly\<^sub>0 w z (mapping_of a + mapping_of b)) =
	MPoly (higherPoly\<^sub>0 w z (mapping_of a)) + MPoly (higherPoly\<^sub>0 w z (mapping_of b))"
	proof -
	have h0a: "higherPoly\<^sub>0 w z (mapping_of a + mapping_of b) = (higherPoly\<^sub>0 w z (mapping_of a)) + (higherPoly\<^sub>0 w z (mapping_of b))"
	using higherPoly\<^sub>0_add[of w z _ _ ] by auto
	then show ?thesis
	by (simp add: plus_mpoly.abs_eq)
	qed
	show "MPoly (higherPoly\<^sub>0 w z (mapping_of (a + b))) =
	MPoly (higherPoly\<^sub>0 w z (mapping_of a)) +
	MPoly (higherPoly\<^sub>0 w z (mapping_of b))" using h1 h2 by auto
	qed


	lemma vars_lift_add : "vars(liftPoly a b (p+q)) \<subseteq> vars(liftPoly a b (p))\<union> vars(liftPoly a b (q))"
	using liftPoly_add[of a b p q]
	using vars_add[of "liftPoly a b p" "liftPoly a b q"]
	by auto

	lemma mapping_of_lift_add : "mapping_of (liftPoly x y (a + b)) = mapping_of (liftPoly x y a) + mapping_of (liftPoly x y b)"
	unfolding liftPoly.rep_eq plus_mpoly.rep_eq
	using higherPoly\<^sub>0_add .

	lemma coeff_lift_add : "MPoly_Type.coeff (liftPoly x y (a + b)) m = MPoly_Type.coeff (liftPoly x y a) m + MPoly_Type.coeff (liftPoly x y b) m"
	proof-
	have "MPoly_Type.coeff (liftPoly x y (a + b)) m = MPoly_Type.coeff (liftPoly x y a + liftPoly x y b) m"
	apply( simp add : mapping_of_lift_add coeff_def ) using lookup_add
	by (simp add: plus_mpoly.rep_eq)
	also have "... = MPoly_Type.coeff (liftPoly x y a) m + MPoly_Type.coeff (liftPoly x y b) m"
	using MPolyExtension.coeff_add[of "liftPoly x y a" "liftPoly x y b" m] .
	finally show ?thesis
	by auto
	qed

	lemma lift_add : "insertion (f::nat\<Rightarrow>real) (liftPoly 0 z (a + b)) = insertion f (liftPoly 0 z a + liftPoly 0 z b)"
	using liftPoly_add[of 0 z a b]
	by simp

	lemma lower_power_zero : "lowerPowers a b 0 = 0"
	unfolding lowerPowers_def dec_above_def id_def apply auto
	unfolding Poly_Mapping.lookup_zero by auto

	lemma lift_vars_monom : "vars (liftPoly i j ((MPoly_Type.monom m a)::real mpoly)) = (\<lambda>x. if x\<ge>i then x+j else x) ` vars(MPoly_Type.monom m a)"
	proof(cases "a=0")
	case True
	then show ?thesis
	by (smt MPolyExtension.monom_zero add.left_neutral add_diff_cancel_right' image_empty liftPoly_add vars_monom_single_cases)
	next
	case False
	have h1: "vars (liftPoly i j (MPoly_Type.monom m a)) = keys (lowerPowers i j m)"
	unfolding liftPoly_def
	unfolding keys_lowerPowers keys_higherPoly\<^sub>0 vars_def apply auto
	apply (smt imageE keys_higherPoly\<^sub>0 keys_lowerPowers lookup_eq_zero_in_keys_contradict lookup_single_not_eq mapping_of_inverse monomials.abs_eq)
	by (metis False higherPowers.rep_eq higherPowers_lowerPowers image_eqI in_keys_iff keys_higherPoly\<^sub>0 lookup_single_eq mapping_of_inverse monomials.abs_eq)
	show ?thesis
	unfolding h1 vars_monom_keys[OF False]
	keys_lowerPowers inc_above_def by auto
	qed

	lemma lift_clear_vars : "vars (liftPoly i j (p::real mpoly)) \<inter> {i..<i + j} = {}"
	proof(induction p rule: mpoly_induct)
	case (monom m a)
	then show ?case
	unfolding lift_vars_monom by auto
	next
	case (sum p1 p2 m a)
	then show ?case
	using vars_lift_add[of i j p1 p2]
	by blast
	qed

	lemma lift0: "(liftPoly i j 0) = 0"
	by (simp add: coeff_liftPoly mpoly_eq_iff)

	lemma lower0: "(lowerPoly i j 0) = 0"
	by (simp add: coeff_all_0 coeff_lowerPoly)

	lemma lower_lift_monom : "insertion f (MPoly_Type.monom m a :: real mpoly) = insertion f (lowerPoly i j (liftPoly i j (MPoly_Type.monom m a)))"
	proof (cases "a=0")
	case True
	show ?thesis unfolding True lift0 monom_zero lower0 ..
	next
	case False
	have h1 : "higherPowers i j ` ({lowerPowers i j m} \<inter> {x. \<forall>j\<in>{i..<i + j}. lookup x j = 0}) = {m}"
	apply (simp add: lowerPowers.rep_eq higherPowers.rep_eq)
	using higherPowers_lowerPowers .
	have higher_lower : "higherPowers i j (lowerPowers i j m) = m"
	using higherPowers_lowerPowers by blast
	show ?thesis using False
	unfolding insertion_code monomials_monom apply auto
	unfolding monomials_lowerPoly monomials_liftPoly apply auto
	unfolding More_MPoly_Type.coeff_monom h1 apply auto
	unfolding coeff_lowerPoly coeff_liftPoly higherPowers_lowerPowers coeff_monom
	apply(cases "\<exists>ja\<in>{i..<i + j}. 0 < lookup (lowerPowers i j m) ja")
	apply auto
	by (simp add: lowerPowers_eq)
	qed


	lemma lower_lift : "insertion f (p::real mpoly) = insertion f (lowerPoly i j (liftPoly i j p))"
	unfolding insertion_code proof(induction p rule: mpoly_induct)
	case (monom m a)
	then show ?case using lower_lift_monom unfolding insertion_code monomials_lowerPoly monomials_liftPoly coeff_lowerPoly coeff_liftPoly by auto
	next
	case (sum p1 p2 m a)
	have h1 : "monomials p1 \<inter> monomials p2 = {}" using sum
	by (metis Int_insert_right_if0 inf_bot_right monomials_monom)
	have h4 : "monomials (lowerPoly i j (liftPoly i j (p1 + p2))) = monomials (lowerPoly i j (liftPoly i j (p1))) \<union> monomials (lowerPoly i j (liftPoly i j (p2)))"
	using monomials_lowerPoly monomials_liftPoly monomials_add_disjoint[OF h1]
	by (simp add: monomials_liftPoly monomials_lowerPoly Int_Un_distrib2 image_Un)
	have h5 : "MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p1 + p2))) = MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p1))) + MPoly_Type.coeff (lowerPoly i j (liftPoly i j (p2)))"
	unfolding coeff_lowerPoly coeff_liftPoly MPolyExtension.coeff_add by auto
	show ?case
	unfolding MPolyExtension.coeff_add
	unfolding h4 h5
	unfolding monomials_add_disjoint[OF h1]
	by (smt IntE coeff_eq_zero_iff disjoint_iff_not_equal finite_monomials h1 higherPowers_lowerPowers imageE monomials_liftPoly monomials_lowerPoly plus_fun_apply sum.IH(1) sum.IH(2) sum.cong sum.union_disjoint
	)
	qed
	lemma lift_insertion : " \<forall>init.
	length init = (i::nat) \<longrightarrow>
	(\<forall>I xs.
	(insertion (nth_default 0 (init @ xs)) (p::real mpoly)) = (insertion ((nth_default 0) (init @ I @ xs)) (liftPoly i (length I) p)))"
	proof safe
	fix init I xs
	assume "i = length (init::real list)"
	then have i_len : "length init = i" by auto
	have h: "higherPoly\<^sub>0 i (length (I::real list)) (mapping_of p) \<in> UNIV"
	by simp
	have h2 : "vars (liftPoly i (length I) p) \<inter> {i..<i + length I} = {}"
	using lift_clear_vars by auto
	show "insertion ((nth_default 0) (init @ xs)) p = insertion ((nth_default 0) (init @ I @ xs)) (liftPoly (length init) (length I) p) "
	using lower_lift insertion_lowerPoly[OF h2 i_len refl, of xs] i_len by auto
	qed

	lemma eval_liftFm_helper :
	assumes "length init = i"
	assumes "length I = amount"
	shows "eval F (init @xs) = eval (liftFm i amount F) (init@I@xs)"
	using assms(1)
	proof(induction F arbitrary: i init)
	case (Atom x)
	then show ?case
	apply(cases x) apply simp_all using lift_insertion assms Atom.prems by force+
	next
	case (ExQ F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + Suc 0)) = (map_fm_binders (\<lambda>a x. liftAtom (i + 1 + x) amount a) F y)"
	apply(induction F) by(simp_all)
	show ?case apply simp apply(rule ex_cong1)
	subgoal for x
	using map[of 0] using ExQ(1)[of "x#init" "i+1"] ExQ(2)
	by simp
	done
	next
	case (AllQ F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + Suc 0)) = (map_fm_binders (\<lambda>a x. liftAtom (i + 1 + x) amount a) F y)"
	apply(induction F) by(simp_all)
	show ?case apply simp apply(rule all_cong1)
	subgoal for x
	using map[of 0] using AllQ(1)[of "x#init" "i+1"] AllQ(2)
	by simp
	done
	next
	case (ExN x1 F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + x1)) = (map_fm_binders (\<lambda>a x. liftAtom (i + x1 + x) amount a) F y)"
	apply(induction F) apply(simp_all add: add.commute add.left_commute)
	apply (metis add_Suc)
	apply (metis add_Suc)
	apply (metis add.assoc)
	by (metis add.assoc)
	show ?case apply simp apply(rule ex_cong1)
	subgoal for l
	using map[of 0] ExN(1)[of "l@init" "i+x1"] ExN(2)
	by auto
	done
	next
	case (AllN x1 F)
	have map: "\<And>y. (map_fm_binders (\<lambda>a x. liftAtom (i + x) (amount) a) F (y + x1)) = (map_fm_binders (\<lambda>a x. liftAtom (i + x1 + x) amount a) F y)"
	apply(induction F) apply(simp_all add: add.commute add.left_commute)
	apply (metis add_Suc)
	apply (metis add_Suc)
	apply (metis add.assoc)
	by (metis add.assoc)
	show ?case apply simp apply(rule all_cong1)
	subgoal for l
	using map[of 0] AllN(1)[of "l@init" "i+x1"] AllN(2)
	by auto
	done
	qed auto

	lemma eval_liftFm :
	assumes "length I = amount"
	assumes "length L \<ge> d"
	shows "eval F L = eval (liftFm d amount F) (insert_into L d I)"
	proof -
	define init where "init = take d L"
	then have "length init = d" using assms by simp
	then have "(eval F (init @ (drop d L)) = eval (liftFm d amount F) (init @ I @ (drop d L)))"
	using eval_liftFm_helper[of init d I amount F "(drop d L)"] assms by auto
	then show ?thesis
	unfolding insert_into.simps assms init_def by auto
	qed


	lemma not_in_lift : "var\<notin>vars(p::real mpoly) \<Longrightarrow> var+z\<notin>vars(liftPoly 0 z p)"
	proof(induction p rule: mpoly_induct)
	case (monom m a)
	then show ?case
	using lift_vars_monom[of 0 z m a] by auto
	next
	case (sum p1 p2 m a)
	show ?case
	using sum using vars_lift_add[of 0 z p1 p2]
	vars_add[of p1 p2]
	by (metis (no_types, lifting) Set.basic_monos(7) Un_iff monomials.rep_eq vars_add_monom)
	qed

	lemma lift_const : "insertion f (liftPoly 0 z (Const (C::real))) = insertion f (Const C :: real mpoly)"
	apply(cases "C=0")
	unfolding insertion_code monomials_Const coeff_Const monomials_liftPoly apply auto
	unfolding lower_power_zero[of 0 z] lookup_zero power.power_0 comm_monoid_mult_class.prod.neutral_const coeff_liftPoly coeff_Const
	unfolding higherPowers_def by auto

	lemma liftPoly_sub: "liftPoly 0 z (a - b) = (liftPoly 0 z a) - (liftPoly 0 z b)"
	unfolding liftPoly_def apply (auto)
	proof -
	have h1: "mapping_of (a - b) = mapping_of a - mapping_of b"
	by (simp add: minus_mpoly.rep_eq)
	have h2: "MPoly (higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)) =
	MPoly (higherPoly\<^sub>0 0 z (mapping_of a)) - MPoly (higherPoly\<^sub>0 0 z (mapping_of b))"
	proof -
	have h0a: "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b) = (higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"
	using poly_mapping_eq_iff[where a = "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)", where b = "(higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"]
	minus_poly_mapping.rep_eq[where x = "higherPoly\<^sub>0 0 z (mapping_of a - mapping_of b)", where xa = "(higherPoly\<^sub>0 0 z (mapping_of a)) - (higherPoly\<^sub>0 0 z (mapping_of b))"]
	apply (auto)
	by (simp add: higherPoly\<^sub>0.rep_eq poly_mapping_eqI minus_poly_mapping.rep_eq)
	then show ?thesis
	by (simp add: minus_mpoly.abs_eq)
	qed
	show "MPoly (higherPoly\<^sub>0 0 z (mapping_of (a - b))) =
	MPoly (higherPoly\<^sub>0 0 z (mapping_of a)) -
	MPoly (higherPoly\<^sub>0 0 z (mapping_of b))" using h1 h2 by auto
	qed

	lemma lift_sub : "insertion (f::nat\<Rightarrow>real) (liftPoly 0 z (a - b)) = insertion f (liftPoly 0 z a - liftPoly 0 z b)"
	using liftPoly_sub[of "z" "a" "b"] by auto

	lemma lift_minus :
	assumes "insertion (f::nat \<Rightarrow> real) (liftPoly 0 z (c - Const (C::real))) = 0"
	shows "insertion f (liftPoly 0 z c) = C"
	proof-
	have "insertion f (liftPoly 0 z (c - Const C)) = insertion f ((liftPoly 0 z c) - (liftPoly 0 z (Const C)))"
	by (simp add: lift_sub)
	have "... = insertion f (liftPoly 0 z c) - (insertion f (liftPoly 0 z (Const C)))"
	using insertion_sub by auto
	also have "... = insertion f (liftPoly 0 z c) - C"
	using lift_const[of f z C] insertion_const by auto
	then show ?thesis
	using \<open>insertion f (liftPoly 0 z (c - Const C)) = insertion f (liftPoly 0 z c - liftPoly 0 z (Const C))\<close> assms calculation by auto
	qed

	end

	lemma lift00 : "liftPoly 0 0 (a::real mpoly) = a"
	unfolding liftPoly_def apply auto
	unfolding higherPoly\<^sub>0_def apply auto
	unfolding higherPowers_def apply auto
	by (simp add: mapping_of_inverse)

	end
	diff --git a/thys/Virtual_Substitution/EliminateVariable.thy b/thys/Virtual_Substitution/EliminateVariable.thy
	--- a/thys/Virtual_Substitution/EliminateVariable.thy
	+++ b/thys/Virtual_Substitution/EliminateVariable.thy
	@@ -1,683 +1,683 @@
	subsection "Lemmas of the elimVar function"

	theory EliminateVariable
	imports LinearCase QuadraticCase "HOL-Library.Quadratic_Discriminant"
	begin




	lemma elimVar_eq :
	assumes hlength : "length xs = var"
	assumes in_list : "Eq p \<in> set(L)"
	assumes low_pow : "MPoly_Type.degree p var = 1 \<or> MPoly_Type.degree p var = 2"
	shows "((\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) =
	((\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>)))\<or> (\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)))"
	proof-

	{ fix x
	define A where "A = (isolate_variable_sparse p var 2)"
	define B where "B = (isolate_variable_sparse p var 1)"
	define C where "C = (isolate_variable_sparse p var 0)"
	have freeA : "var \<notin> vars A"
	unfolding A_def
	by (simp add: not_in_isovarspar)
	have freeB : "var \<notin> vars B"
	unfolding B_def
	by (simp add: not_in_isovarspar)
	have freeC : "var \<notin> vars C"
	unfolding C_def
	by (simp add: not_in_isovarspar)
	assume "eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)"
	then have h : "(\<forall>a\<in>set L. aEval a (xs @ x # \<Gamma>)) \<and> (\<forall>f\<in>set F. eval f (xs @ x # \<Gamma>))"
	apply(simp add:eval_list_conj)
	by (meson Un_iff eval.simps(1) image_eqI)
	define X where "X=xs@x#\<Gamma>"
	have Xlength : "length X > var"
	using X_def hlength by auto
	define Aval where "Aval = insertion (nth_default 0 (list_update X var x)) A"
	define Bval where "Bval = insertion (nth_default 0 (list_update X var x)) B"
	define Cval where "Cval = insertion (nth_default 0 (list_update X var x)) C"
	have hinsert : "(xs @ x # \<Gamma>)[var := x] = (xs @ x #\<Gamma>)"
	using hlength by auto
	have allAval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) A = Aval"
	using Aval_def
	using not_contains_insertion[where var="var", where p = "A", OF freeA, where L = "xs @ x #\<Gamma>", where x="x", where val="Aval"]
	unfolding X_def hinsert using hlength by auto
	have allBval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) B = Bval"
	using Bval_def
	using not_contains_insertion[where var="var", where p = "B", OF freeB, where L = "xs @ x #\<Gamma>", where x="x", where val="Bval"]
	unfolding X_def hinsert using hlength by auto
	have allCval : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) C = Cval"
	using Cval_def
	using not_contains_insertion[where var="var", where p = "C", OF freeC, where L = "xs @ x #\<Gamma>", where x="x", where val="Cval"]
	unfolding X_def hinsert using hlength by auto
	have insertion_p : "insertion (nth_default 0 X) p = 0"
	using in_list h aEval.simps(1) X_def by fastforce
	have express_p : "p = A * Var var ^ 2 + B * Var var + C"
	using express_poly[OF low_pow] unfolding A_def B_def C_def
	by fastforce
	have insertion_p' : "Aval x^2+Bval x+Cval = 0"
	using express_p insertion_p unfolding Aval_def Bval_def Cval_def X_def hinsert
	apply(simp add: insertion_add insertion_mult insertion_pow)
	using insertion_var by (metis X_def Xlength hinsert)
	have biglemma : "
	((Aval = 0 \<and>
	Bval \<noteq> 0 \<and>
	(\<forall>f\<in>set L. aEval (linear_substitution var (-C) B f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
	Aval \<noteq> 0 \<and>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
	Aval *
	Cval
	\<le> (Bval)\<^sup>2 \<and>
	((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
	(\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))) \<or>
	Aval = 0 \<and>
	Bval = 0 \<and>
	Cval = 0))"
	proof(cases "Aval=0")
	case True
	then have aval0 : "Aval=0" by simp
	show ?thesis proof(cases "Bval=0")
	case True
	then have bval0 : "Bval=0" by simp
	have h : "eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)"
	using hlength h unfolding X_def
	using \<open>eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)\<close> by blast
	show ?thesis proof(cases "Cval=0")
	case True
	show ?thesis
	by(simp add:aval0 True bval0)
	next
	case False
	show ?thesis
	using insertion_p' aval0 bval0 False by(simp)
	qed
	next
	case False
	have bh : "insertion (nth_default 0 (X[var := - Cval / Bval])) B = Bval"
	using allBval unfolding X_def
	using Bval_def X_def freeB not_contains_insertion by blast
	have ch : "insertion (nth_default 0 (X[var := - Cval / Bval])) C = Cval"
	using allCval unfolding X_def
	using Cval_def X_def freeC not_contains_insertion by blast
	have xh : "x=-Cval/Bval"
	proof-
	have "Bval*x+Cval = 0"
	using insertion_p' aval0
	by simp
	then show ?thesis using False
	by (smt nonzero_mult_div_cancel_left)
	qed
	have freecneg : "var \<notin> vars (-C)" using freeC not_in_neg by auto
	have h1: "(\<forall>a\<in>set L. aEval (linear_substitution var (-C) (B) a) (X[var := x]))"
	using h xh Bval_def Cval_def False LinearCase.linear[OF Xlength False freecneg freeB, of "-Cval"] freeB freeC freecneg
	by (metis X_def hinsert insertion_neg)
	have h2 : "\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (X[var := x])"
	using h xh Bval_def Cval_def False LinearCase.linear_fm[OF Xlength False freecneg freeB, of "-Cval"] freeB freeC
	by (metis X_def hinsert insertion_neg)
	show ?thesis using h1 h2 apply(simp add:aval0 False)
	using X_def hlength
	using hinsert by auto
	qed
	next
	case False
	then have aval0 : "Aval \<noteq>0" by simp
	have h4 : "insertion (nth_default 0 (X[var := x])) 4 = 4"
	using insertion_const[where f = "(nth_default 0 (X[var := x]))", where c="4"]
	by (metis MPoly_Type.insertion_one insertion_add numeral_Bit0 one_add_one)
	show ?thesis proof(cases "4 * Aval * Cval \<le> Bval\<^sup>2")
	case True
	have h1a : "var\<notin>vars(-B)"
	by(simp add: freeB not_in_neg)
	have h1b : "var\<notin>vars(1::real mpoly)"
	using isolate_var_one not_in_isovarspar by blast
	have h1c : "var\<notin>vars(-1::real mpoly)"
	by(simp add: h1b not_in_neg)
	have h1d : "var\<notin>vars(4::real mpoly)"
	by (metis h1b not_in_add numeral_Bit0 one_add_one)
	have h1e : "var\<notin>vars(B^2-4AC)"
	by(simp add: freeB h1d freeA freeC not_in_mult not_in_pow not_in_sub)
	have h1f : "var\<notin>vars(2::real mpoly)"
	using h1b not_in_add by fastforce
	have h1g : "var\<notin>vars(2*A)"
	by(simp add: freeA h1f not_in_mult)
	have h1h : "freeIn var (quadratic_sub var (-B) (1) (B^2-4AC) (2*A) a)"
	using free_in_quad h1a h1b h1e h1g by blast
	have h1i : "freeIn var (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a)"
	using free_in_quad h1a h1c h1e h1g by blast
	have h2 : "2*Aval \<noteq> 0" using aval0 by auto
	have h3 : "0 \<le> (Bval^2-4AvalCval)" using True by auto
	have h4a : "var \<notin> vars 4"
	by (metis monom_numeral notInKeys_notInVars not_in_add not_in_isovarspar not_in_pow one_add_one power.simps(1) rel_simps(76) vars_monom_keys)
	have h4 : "var \<notin> vars (B^2-4AC)" by(simp add: h4a freeA freeB freeC not_in_pow not_in_mult not_in_sub)
	have h5 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-B) = -Bval "
	using allBval apply(simp add: insertion_neg)
	by (simp add: B_def Bval_def insertion_isovarspars_free)
	have h6 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 1 = 1" by simp
	have h6a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-1) = (-1)" using h6 by (simp add: insertion_neg)
	have h7a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 4 = 4" by (metis h6 insertion_add numeral_Bit0 one_add_one)
	have h7b : "var \<notin> vars(4AC)" using freeA freeC by (simp add: h4a not_in_mult)
	have h7c : "var \<notin> vars(B^2)" using freeB not_in_pow by auto
	have h7 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (B^2-4AC) = (Bval^2-4AvalCval)"
	using h7a allAval allBval allCval unfolding X_def using hlength
	apply (simp add: insertion_mult insertion_sub power2_eq_square)
	by (metis A_def Aval_def Bval_def C_def Cval_def X_def freeB insertion_isovarspars_free not_contains_insertion)
	have h8a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 2 = 2" by (metis h6 insertion_add one_add_one)
	have h8 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (2A) = (2Aval)"
	apply(simp add: allAval h8a insertion_mult)
	by (simp add: A_def Aval_def insertion_isovarspars_free)

	have h1 : "- Bval\<^sup>2 + 4 * Aval * Cval \<le> 0"
	using True by simp
	have xh : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)\<or>x=(- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
	using insertion_p' aval0 h1
	discriminant_iff unfolding discrim_def by blast
	have p1 : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval) \<Longrightarrow>
	((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x])))"
	proof-
	assume x_def : "x = (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
	then have h : "(\<forall>a\<in>set L. aEval a (X[var := (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval + sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
	using h
	using X_def hinsert by auto
	{ fix a
	assume in_list : "a\<in> set L"
	have "eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
	using free_in_quad[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
	using quadratic_sub[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
	h in_list
	using var_not_in_eval by fastforce

	}
	then have left : "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
	by simp


	{ fix a
	assume in_list : "a\<in> set F"
	have "eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
	using free_in_quad_fm[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
	using quadratic_sub_fm[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
	h in_list
	using var_not_in_eval by fastforce

	}
	then have right : "(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
	by simp
	show ?thesis
	using right left by simp
	qed

	have p2 : "x = (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval) \<Longrightarrow>
	((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x])))"
	proof -
	assume x_def : "x = (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)"
	then have h : "(\<forall>a\<in>set L. aEval a (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
	using h
	using X_def hinsert by auto
	then have "(\<forall>a\<in>set L. aEval a (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)])) \<and> (\<forall>f\<in>set F. eval f (X[var := (- Bval - sqrt (Bval\<^sup>2 - 4 * Aval * Cval)) / (2 * Aval)]))"
	using h by simp
	{ fix a
	assume in_list : "a\<in> set L"
	have "eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
	using free_in_quad[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
	using quadratic_sub[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]
	h in_list
	using var_not_in_eval by fastforce

	}
	then have left : "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
	by simp


	{ fix a
	assume in_list : "a\<in> set F"
	have "eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x])"
	using free_in_quad_fm[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
	using quadratic_sub_fm[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]
	h in_list
	using var_not_in_eval by fastforce

	}
	then have right : "(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (X[var := x]))"
	by simp
	show ?thesis
	using right left by simp
	qed
	have subst4 : "insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 = 4" using h7a hlength X_def by auto
	have disj: "(\<forall>a\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<and>
	(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<or>
	(\<forall>a\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>)) \<and>
	(\<forall>a\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) a) (xs @ x # \<Gamma>))"
	using xh p1 p2
	unfolding X_def hinsert by blast
	show ?thesis apply(simp add: aval0 True h7a subst4) using disj
	unfolding X_def hinsert by auto
	next
	case False
	then have det : "0 < - Bval\<^sup>2 + 4 * Aval * Cval"
	by simp
	show ?thesis apply(simp add: aval0 False h4) using discriminant_negative unfolding discrim_def
	using insertion_p'
	using aval0 det by auto
	qed
	qed
	have "(\<exists>x.
	(insertion (nth_default 0 (xs @ x # \<Gamma>)) A = 0 \<and>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) B \<noteq> 0 \<and>
	(\<forall>f\<in>set L. aEval (linear_substitution var (-C) (B) f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) A \<noteq> 0 \<and>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
	insertion (nth_default 0 (xs @ x # \<Gamma>)) A *
	insertion (nth_default 0 (xs @ x # \<Gamma>)) C
	\<le> (insertion (nth_default 0 (xs @ x # \<Gamma>)) B)\<^sup>2 \<and>
	((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
	(\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)))) \<or>
	(Aval = 0 \<and>
	Bval = 0 \<and>
	Cval = 0))"
	apply(rule exI[where x=x])
	using biglemma
	using allAval allBval allCval unfolding A_def B_def C_def Aval_def Bval_def Cval_def X_def hinsert
	by auto
	then obtain x where x : "(insertion (nth_default 0 (xs @ x # \<Gamma>)) A = 0 \<and>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) B \<noteq> 0 \<and>
	(\<forall>f\<in>set L. aEval (linear_substitution var (-C) (B) f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (linear_substitution_fm var (-C) B f) (xs @ x # \<Gamma>)) \<or>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) A \<noteq> 0 \<and>
	insertion (nth_default 0 (xs @ x # \<Gamma>)) 4 *
	insertion (nth_default 0 (xs @ x # \<Gamma>)) A *
	insertion (nth_default 0 (xs @ x # \<Gamma>)) C
	\<le> (insertion (nth_default 0 (xs @ x # \<Gamma>)) B)\<^sup>2 \<and>
	((\<forall>f\<in>set L. eval (quadratic_sub var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>))\<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) 1 (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<or>
	(\<forall>f\<in>set L. eval (quadratic_sub var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)) \<and>
	(\<forall>f\<in>set F. eval (quadratic_sub_fm var (- B) (-1) (B\<^sup>2 - 4 * A * C) (2 * A) f) (xs @ x # \<Gamma>)))) \<or>
	(Aval = 0 \<and>
	Bval = 0 \<and>
	Cval = 0)" by auto
	have h : "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)"
	proof(cases "(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)")
	case True
	then show ?thesis by simp
	next
	case False
	have "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))"
	apply(rule exI[where x=x])
	apply(simp add: eval_list_conj insertion_mult insertion_sub insertion_pow insertion_add
	del: quadratic_sub.simps linear_substitution.simps quadratic_sub_fm.simps linear_substitution_fm.simps)
	unfolding A_def[symmetric] B_def[symmetric] C_def[symmetric] One_nat_def[symmetric] X_def[symmetric]
	using hlength x
	by (auto simp add:False)
	then show ?thesis by auto
	qed
	have "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs@ x# \<Gamma>))"
	proof(cases "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))")
	case True
	then show ?thesis by auto
	next
	case False
	then have "(Aval = 0 \<and> Bval = 0 \<and> Cval = 0)"
	using h by auto
	then have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>))"
	unfolding express_p
	apply(simp add:insertion_add insertion_mult insertion_pow)
	using allAval allBval allCval by auto
	then show ?thesis by auto
	qed
	}
	then have left : "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) \<Longrightarrow>
	((\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs@ x# \<Gamma>)))"
	by blast


	{
	assume hlength : "length (xs::real list) = var"
	define A where "A = (isolate_variable_sparse p var 2)"
	define B where "B = (isolate_variable_sparse p var 1)"
	define C where "C = (isolate_variable_sparse p var 0)"
	have freeA : "var \<notin> vars A"
	unfolding A_def
	by (simp add: not_in_isovarspar)
	have freeB : "var \<notin> vars B"
	unfolding B_def
	by (simp add: not_in_isovarspar)
	have freeC : "var \<notin> vars C"
	unfolding C_def
	by (simp add: not_in_isovarspar)
	have express_p : "p = A(Var var)^2+B(Var var)+C"
	using express_poly[OF low_pow] unfolding A_def B_def C_def
	by fastforce
	assume h : "(\<exists>x. (eval (elimVar var L F (Eq p)) (list_update (xs@x#\<Gamma>) var x)))"
	fix x
	define X where "X=xs@x#\<Gamma>"
	have Xlength : "length X > var"
	using X_def hlength by auto
	define Aval where "Aval = insertion (nth_default 0 (list_update X var x)) A"
	define Bval where "Bval = insertion (nth_default 0 (list_update X var x)) B"
	define Cval where "Cval = insertion (nth_default 0 (list_update X var x)) C"
	have allAval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) A = Aval"
	using freeA Aval_def
	using not_contains_insertion by blast
	have allBval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) B = Bval"
	using freeB Bval_def
	using not_contains_insertion by blast
	have allCval : "\<forall>x. insertion (nth_default 0 (list_update X var x)) C = Cval"
	using freeC Cval_def
	using not_contains_insertion by blast
	assume "(eval (elimVar var L F (Eq p)) (list_update (xs@x#\<Gamma>) var x))"
	then have h : "(eval (elimVar var L F (Eq p)) (list_update X var x))"
	unfolding X_def .

	have "(Aval = 0 \<and> Bval \<noteq> 0 \<and>
	(\<forall>f\<in>(\<lambda>a. Atom(linear_substitution var (-C) B a)) ` set L \<union>
	linear_substitution_fm var (-C) B `
	set F.
	eval f (X[var := x])) \<or>
	Aval \<noteq> 0 \<and>
	insertion (nth_default 0 (X[var := x])) 4 * Aval * Cval \<le> Bval\<^sup>2 \<and>
	((\<forall>f\<in>(quadratic_sub var (-B) 1 (B^2-4AC) (2*A)) `
	set L \<union>
	(quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A)) `
	set F.
	eval f (X[var := x]))
	\<or>(\<forall>f\<in>(quadratic_sub var (-B) (-1) (B^2-4AC) (2*A)) `
	set L \<union>
	(quadratic_sub_fm var (-B) (-1) (B^2-4AC) (2*A)) `
	set F.
	eval f (X[var := x]))
	))"
	unfolding Aval_def Bval_def Cval_def A_def B_def C_def
	using h by(simp add: eval_list_conj insertion_mult insertion_sub insertion_pow insertion_add insertion_var Xlength)
	then have h : "(Aval = 0 \<and> Bval \<noteq> 0 \<and>
	((\<forall>a\<in> set L. aEval (linear_substitution var (-C) B a) (X[var := x])) \<and>
	(\<forall>a\<in> set F. eval (linear_substitution_fm var (-C) B a) (X[var := x]))) \<or>
	Aval \<noteq> 0 \<and> insertion (nth_default 0 (X[var := x])) 4 * Aval * Cval \<le> Bval\<^sup>2 \<and>
	(((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x])))
	\<or>((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x])))))
	"
	apply(cases "Aval = 0 ")
	apply auto
	by (meson Un_iff eval.simps(1) imageI)
	have h : "(\<exists>x. ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))\<or>(Aval=0\<and>Bval=0\<and>Cval=0)"
	proof(cases "Aval=0")
	case True
	then have aval0 : "Aval=0"
	by simp
	show ?thesis proof(cases "Bval = 0")
	case True
	then have bval0 : "Bval = 0" by simp
	show ?thesis proof(cases "Cval=0")
	case True
	then show ?thesis using aval0 bval0 True by auto
	next
	case False
	then show ?thesis using h by(simp add:aval0 bval0 False)
	qed
	next
	case False
	have hb : "insertion (nth_default 0 (X[var := - Cval / Bval])) B = Bval"
	using allBval by simp
	have hc : "insertion (nth_default 0 (X[var := - Cval / Bval])) (-C) = -Cval"
	using allCval
	by (simp add: insertion_neg)
	have freecneg : "var\<notin>vars(-C)" using freeC not_in_neg by auto
	have p1 : "(\<forall>a\<in>set L. aEval a ((xs @ x # \<Gamma>)[var := - Cval / Bval]))"
	using h apply(simp add: False aval0)
	using linear[OF Xlength False freecneg freeB hc hb]
	list_update_length var_not_in_linear[OF freecneg freeB]
	unfolding X_def using hlength
	by (metis divide_minus_left)

	have p2 : "(\<forall>a\<in>set F. eval a ((xs @ x # \<Gamma>)[var := - Cval / Bval]))"
	using h apply(simp add: False aval0)
	using linear_fm[OF Xlength False freecneg freeB hc hb]
	list_update_length var_not_in_linear_fm[OF freecneg freeB]
	unfolding X_def using hlength var_not_in_eval
	by (metis divide_minus_left linear_substitution_fm.elims linear_substitution_fm_helper.elims)
	show ?thesis
	using p1 p2 hlength by fastforce
	qed
	next
	case False
	then have aval0 : "Aval \<noteq> 0"
	by simp
	have h4 : "insertion (nth_default 0 (X[var := x])) 4 = 4"
	using insertion_const[where f = "(nth_default 0 (X[var := x]))", where c="4"]
	by (metis MPoly_Type.insertion_one insertion_add numeral_Bit0 one_add_one)
	show ?thesis proof(cases "4 * Aval * Cval \<le> Bval\<^sup>2")
	case True
	then have h1 : "- Bval\<^sup>2 + 4 * Aval * Cval \<le> 0"
	by simp
	have h : "(((\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x])))
	\<or>((\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))
	\<and>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))))"
	using h by(simp add: h1 aval0)
	have h1a : "var\<notin>vars(-B)"
	by(simp add: freeB not_in_neg)
	have h1b : "var\<notin>vars(1::real mpoly)"
	using isolate_var_one not_in_isovarspar by blast
	have h1c : "var\<notin>vars(-1::real mpoly)"
	by(simp add: h1b not_in_neg)
	have h1d : "var\<notin>vars(4::real mpoly)"
	by (metis h1b not_in_add numeral_Bit0 one_add_one)
	have h1e : "var\<notin>vars(B^2-4AC)"
	by(simp add: freeB h1d freeA freeC not_in_mult not_in_pow not_in_sub)
	have h1f : "var\<notin>vars(2::real mpoly)"
	using h1b not_in_add by fastforce
	have h1g : "var\<notin>vars(2*A)"
	by(simp add: freeA h1f not_in_mult)
	have h1h : "freeIn var (quadratic_sub var (-B) (1) (B^2-4AC) (2*A) a)"
	using free_in_quad h1a h1b h1e h1g by blast
	have h1i : "freeIn var (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a)"
	using free_in_quad h1a h1c h1e h1g by blast
	have h2 : "2*Aval \<noteq> 0" using aval0 by auto
	have h3 : "0 \<le> (Bval^2-4AvalCval)" using True by auto
	have h4a : "var \<notin> vars 4"
	by (metis monom_numeral notInKeys_notInVars not_in_add not_in_isovarspar not_in_pow one_add_one power.simps(1) rel_simps(76) vars_monom_keys)
	have h4 : "var \<notin> vars (B^2-4AC)" by(simp add: h4a freeA freeB freeC not_in_pow not_in_mult not_in_sub)
	have h5 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-B) = -Bval " using allBval by(simp add: insertion_neg)
	have h6 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 1 = 1" by simp
	have h6a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (-1) = (-1)" using h6 by (simp add: insertion_neg)
	have h7a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 4 = 4" by (metis h6 insertion_add numeral_Bit0 one_add_one)
	have h7b : "var \<notin> vars(4AC)" using freeA freeC by (simp add: h4a not_in_mult)
	have h7c : "var \<notin> vars(B^2)" using freeB not_in_pow by auto
	have h7 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (B^2-4AC) = (Bval^2-4AvalCval)"
	by (simp add: h7a allAval allBval allCval insertion_mult insertion_sub power2_eq_square)
	have h8a : "\<forall>x. insertion (nth_default 0 (list_update X var x)) 2 = 2" by (metis h6 insertion_add one_add_one)
	have h8 : "\<forall>x. insertion (nth_default 0 (list_update X var x)) (2A) = (2Aval)" by(simp add: allAval h8a insertion_mult)

	have p1 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))
	\<Longrightarrow>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))
	\<Longrightarrow> \<exists>x. length xs = var \<and> ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x])))"
	proof-
	assume p1 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))"
	assume p2 : "(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) 1 (B^2-4AC) (2*A) a) (X[var := x]))"
	show ?thesis
	using free_in_quad[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
	using quadratic_sub[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
	using free_in_quad_fm[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1b h1e h1g]
	using quadratic_sub_fm[where a="-B",where b="1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="1", OF h6 h7 h8]
	p1 p2
	using var_not_in_eval
	by (metis X_def hlength list_update_length)
	qed
	have p2 : "(\<forall>a\<in> set L. eval (quadratic_sub var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))
	\<Longrightarrow>(\<forall>a\<in> set F. eval (quadratic_sub_fm var (-B) (-1) (B^2-4AC) (2*A) a) (X[var := x]))
	\<Longrightarrow>\<exists>x. length xs = var \<and> ((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x])))"
	using free_in_quad[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
	using quadratic_sub[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]

	using free_in_quad_fm[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var",OF h1a h1c h1e h1g]
	using quadratic_sub_fm[where a="-B",where b="-1", where c="(B^2-4AC)", where d="2*A",where var="var", where L="X", OF Xlength,
	where Dv="2Aval", OF h2, where Cv="(Bval^2-4Aval*Cval)", OF h3, where Av="-Bval", OF h4 h5, where Bv="-1", OF h6a h7 h8]

	using var_not_in_eval by (metis X_def hlength list_update_length)
	then show ?thesis
	using h p1 p2 by blast
	next
	case False
	then show ?thesis using h by(simp add: aval0 False h4)
	qed
	qed
	have "(\<exists>x.((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))\<or>(\<forall>x. aEval (Eq p) (xs @ x#\<Gamma>))"
	proof(cases "(\<exists>x.((\<forall>a\<in>set L . aEval a ((xs@x#\<Gamma>)[var := x])) \<and> (\<forall>f\<in>set F. eval f ((xs@x#\<Gamma>)[var := x]))))")
	case True
	then show ?thesis by auto
	next
	case False
	then have "Aval=0\<and>Bval=0\<and>Cval=0" using h by auto
	then have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>))"
	unfolding express_p apply(simp add:insertion_add insertion_mult insertion_pow)
	using allAval allBval allCval hlength unfolding X_def by auto
	then show ?thesis by auto
	qed
	}


	then have right : "(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>)) \<Longrightarrow>
	((\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>))\<or>(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)))"
	by (smt UnE eval.simps(1) eval_list_conj hlength imageE list_update_length set_append set_map)


	show ?thesis using right left by blast
	qed

	text "simply states that the variable is free in the equality case of the elimVar function"
	lemma freeIn_elimVar_eq : "freeIn var (elimVar var L F (Eq p))"
	proof-
	have h4 : "var \<notin> vars(4:: real mpoly)" using var_not_in_Const
	by (metis (full_types) isolate_var_one monom_numeral not_in_isovarspar numeral_One vars_monom_keys zero_neq_numeral)
	have hlinear: "\<forall>f\<in>set(map (\<lambda>a. Atom(linear_substitution var (-isolate_variable_sparse p var 0) (isolate_variable_sparse p var (Suc 0)) a)) L @
	map (linear_substitution_fm var (-isolate_variable_sparse p var 0) (isolate_variable_sparse p var (Suc 0)))
	F). freeIn var f"
	using
	var_not_in_linear[where c="(isolate_variable_sparse p var (Suc 0))", where b="(- isolate_variable_sparse p var 0)", where var="var"]
	var_not_in_linear_fm[where c="(isolate_variable_sparse p var (Suc 0))", where b="(-isolate_variable_sparse p var 0)", where var="var"]
	not_in_isovarspar not_in_neg by auto
	have freeA : "var \<notin> vars (- isolate_variable_sparse p var (Suc 0))"
	using not_in_isovarspar not_in_neg by auto
	have freeB1 : "var \<notin> vars (1::real mpoly)"
	by (metis h4 monom_numeral monom_one notInKeys_notInVars vars_monom_keys zero_neq_numeral)
	have freeC : "var \<notin> vars (((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
	4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0))"
	using not_in_isovarspar not_in_pow not_in_sub not_in_mult h4 by auto
	have freeD : "var \<notin> vars ((2 * isolate_variable_sparse p var 2))"
	using not_in_isovarspar not_in_mult
	by (metis mult_2 not_in_add)
	have freeB2 : "var\<notin>vars (-1::real mpoly)"
	using freeB1 not_in_neg by auto
	have quadratic1 : "\<forall>f\<in>set(map (quadratic_sub var (- isolate_variable_sparse p var (Suc 0)) 1
	((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
	4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
	(2 * isolate_variable_sparse p var 2))
	L @
	map (quadratic_sub_fm var (- isolate_variable_sparse p var (Suc 0)) 1
	((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
	4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
	(2 * isolate_variable_sparse p var 2))
	F). freeIn var f"
	using free_in_quad[OF freeA freeB1 freeC freeD]
	free_in_quad_fm[OF freeA freeB1 freeC freeD] by auto
	have quadratic2 : "\<forall>f\<in>set(map (quadratic_sub var (- isolate_variable_sparse p var (Suc 0)) (-1)
	((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
	4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
	(2 * isolate_variable_sparse p var 2))
	L @
	map (quadratic_sub_fm var (- isolate_variable_sparse p var (Suc 0)) (-1)
	((isolate_variable_sparse p var (Suc 0))\<^sup>2 -
	4 * isolate_variable_sparse p var 2 * isolate_variable_sparse p var 0)
	(2 * isolate_variable_sparse p var 2))
	F). freeIn var f"
	using free_in_quad[OF freeA freeB2 freeC freeD]
	free_in_quad_fm[OF freeA freeB2 freeC freeD] by auto
	show ?thesis
	using not_in_mult not_in_add h4 not_in_pow not_in_sub freeIn_list_conj not_in_isovarspar hlinear quadratic1 quadratic2
	- by(simp add: )
	+ bysimp
	qed


	text "Theorem 20.2 in the textbook"
	lemma elimVar_eq_2 :
	assumes hlength : "length xs = var"
	assumes in_list : "Eq p \<in> set(L)"
	assumes low_pow : "MPoly_Type.degree p var = 1 \<or> MPoly_Type.degree p var = 2"
	assumes nonzero : "\<forall>x.
	insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 2) \<noteq> 0
	\<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 1) \<noteq> 0
	\<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 0) \<noteq> 0" (is ?non0)
	shows "(\<exists>x. eval (list_conj (map fm.Atom L @ F)) (xs @ x # \<Gamma>)) =
	(\<exists>x. eval (elimVar var L F (Eq p)) (xs @ x # \<Gamma>))"
	proof-
	define A where "A = (isolate_variable_sparse p var 2)"
	define B where "B = (isolate_variable_sparse p var 1)"
	define C where "C = (isolate_variable_sparse p var 0)"
	have freeA : "var \<notin> vars A"
	unfolding A_def
	by (simp add: not_in_isovarspar)
	have freeB : "var \<notin> vars B"
	unfolding B_def
	by (simp add: not_in_isovarspar)
	have freeC : "var \<notin> vars C"
	unfolding C_def
	by (simp add: not_in_isovarspar)
	have express_p : "p = A(Var var)^2+B(Var var)+C"
	using express_poly[OF low_pow] unfolding A_def B_def C_def
	by fastforce
	have af : "isolate_variable_sparse p var 2 = A"
	using A_def by auto
	have bf : "isolate_variable_sparse p var (Suc 0) = B"
	using B_def by auto
	have cf : "isolate_variable_sparse p var 0 = C"
	using C_def by auto
	have xlength : "\<forall>x. (insertion (nth_default 0 (xs @ x # \<Gamma>)) (Var var))= x"
	using hlength insertion_var
	by (metis add.commute add_strict_increasing length_append length_greater_0_conv list.distinct(1) list_update_id nth_append_length order_refl)
	fix x
	define c where "c i = (insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var i))" for i
	have c2 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) A = c 2"
	using freeA apply(simp add: A_def c_def)
	by (simp add: hlength insertion_lowerPoly1)
	have c1 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) B = c 1"
	using freeB apply(simp add: B_def c_def)
	by (simp add: hlength insertion_lowerPoly1)
	have c0 : "\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) C = c 0"
	using freeC apply(simp add: C_def c_def)
	by (simp add: hlength insertion_lowerPoly1)
	have sum : "\<forall>x. c 2 * x\<^sup>2 + c (Suc 0) * x + c 0 = (\<Sum>i\<le>2. c i * x ^ i)"
	by (simp add: numerals(2))
	have "(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)) = (\<not>?non0)"
	apply(simp add : af bf cf)
	unfolding express_p apply(simp add:insertion_add insertion_mult insertion_pow xlength)
	apply(simp add:c2 c1 c0)
	apply(simp add: sum)
	using polyfun_eq_0[where c="c", where n="2"]
	using sum by auto
	then have "\<not>(\<forall>x. aEval (Eq p) (xs @ x \<Gamma>))"
	using nonzero by auto
	then show ?thesis
	using disjE[OF elimVar_eq[OF hlength in_list, where F="F", where \<Gamma>="\<Gamma>"], where R="?thesis"]
	using \<open>(\<forall>x. aEval (Eq p) (xs @ x # \<Gamma>)) = (\<not> (\<forall>x. insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 2) \<noteq> 0 \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 1) \<noteq> 0 \<or> insertion (nth_default 0 (xs @ x # \<Gamma>)) (isolate_variable_sparse p var 0) \<noteq> 0))\<close> low_pow nonzero by blast
	qed



	end
	\ No newline at end of file
	diff --git a/thys/Virtual_Substitution/ExecutiblePolyProps.thy b/thys/Virtual_Substitution/ExecutiblePolyProps.thy
	--- a/thys/Virtual_Substitution/ExecutiblePolyProps.thy
	+++ b/thys/Virtual_Substitution/ExecutiblePolyProps.thy
	@@ -1,1081 +1,1081 @@
	text "Executable Polynomial Properties"
	theory ExecutiblePolyProps
	imports
	Polynomials.MPoly_Type_Univariate
	MPolyExtension
	begin

	text \<open>(Univariate) Polynomial hiding\<close>

	lifting_update poly.lifting
	lifting_forget poly.lifting

	text \<open>\<close>

	subsection "Lemmas with Monomial and Monomials"

	lemma of_nat_monomial: "of_nat p = monomial p 0"
	by (auto simp: poly_mapping_eq_iff lookup_of_nat fun_eq_iff lookup_single)

	lemma of_nat_times_monomial: "of_nat p * monomial c i = monomial (p*c) i"
	by (auto simp: poly_mapping_eq_iff prod_fun_def fun_eq_iff of_nat_monomial
	lookup_single mult_single)

	lemma monomial_adds_nat_iff: "monomial p i adds c \<longleftrightarrow> lookup c i \<ge> p" for p::"nat"
	apply (auto simp: adds_def lookup_add)
	by (metis add.left_commute nat_le_iff_add remove_key_sum single_add)

	lemma update_minus_monomial: "Poly_Mapping.update k i (m - monomial i k) = Poly_Mapping.update k i m"
	by (auto simp: poly_mapping_eq_iff lookup_update update.rep_eq fun_eq_iff lookup_minus
	lookup_single)

	lemma monomials_Var: "monomials (Var x::'a::zero_neq_one mpoly) = {Poly_Mapping.single x 1}"
	by transfer (auto simp: Var\<^sub>0_def)

	lemma monomials_Const: "monomials (Const x) = (if x = 0 then {} else {0})"
	by transfer' (auto simp: Const\<^sub>0_def)

	lemma coeff_eq_zero_iff: "MPoly_Type.coeff c p = 0 \<longleftrightarrow> p \<notin> monomials c"
	by transfer (simp add: not_in_keys_iff_lookup_eq_zero)

	lemma monomials_1[simp]: "monomials 1 = {0}"
	by transfer auto

	lemma monomials_and_monoms:
	shows "(k \<in> monomials m) = (\<exists> (a::nat). a \<noteq> 0 \<and> (monomials (MPoly_Type.monom k a)) \<subseteq> monomials m)"
	proof -
	show ?thesis using monomials_monom by auto
	qed

	lemma mult_monomials_dir_one:
	shows "monomials (p*q) \<subseteq> {a+b \| a b . a \<in> monomials p \<and> b \<in> monomials q}"
	using monomials_and_monoms mult_monom
	by (simp add: keys_mult monomials.rep_eq times_mpoly.rep_eq)

	lemma monom_eq_zero_iff[simp]: "MPoly_Type.monom a b = 0 \<longleftrightarrow> b = 0"
	by (metis MPolyExtension.coeff_monom MPolyExtension.monom_zero)

	lemma update_eq_plus_monomial:
	"v \<ge> lookup m k \<Longrightarrow> Poly_Mapping.update k v m = m + monomial (v - lookup m k) k"
	for v n::nat
	by transfer auto

	lemma coeff_monom_mult':
	"MPoly_Type.coeff ((MPoly_Type.monom m' a) * q) (m'm) = a * MPoly_Type.coeff q (m'm - m')"
	if *: "m'm = m' + (m'm - m')"
	by (subst *) (rule More_MPoly_Type.coeff_monom_mult)

	lemma monomials_zero[simp]: "monomials 0 = {}"
	by transfer auto

	lemma in_monomials_iff: "x \<in> monomials m \<longleftrightarrow> MPoly_Type.coeff m x \<noteq> 0"
	using coeff_eq_zero_iff[of m x] by auto

	lemma monomials_monom_mult: "monomials (MPoly_Type.monom mon a * q) = (if a = 0 then {} else (+) mon ` monomials q)"
	for q::"'a::semiring_no_zero_divisors mpoly"
	apply auto
	subgoal by transfer' (auto elim!: in_keys_timesE)
	subgoal by (simp add: in_monomials_iff More_MPoly_Type.coeff_monom_mult)
	done

	subsection "Simplification Lemmas for Const 0 and Const 1"
	lemma add_zero : "P + Const 0 = P"
	proof -
	have h:"P + 0 = P" using add_0_right by auto
	show ?thesis unfolding Const_def using h by (simp add: Const\<^sub>0_zero zero_mpoly.abs_eq)
	qed

	(* example *)
	lemma add_zero_example : "((Var 0)^2 - (Const 1)) + Const 0 = ((Var 0)^2 - (Const 1))"
	proof -
	show ?thesis by (simp add : add_zero)
	qed

	lemma mult_zero_left : "Const 0 * P = Const 0"
	proof -
	have h:"0*P = 0" by simp
	show ?thesis unfolding Const_def using h by (simp add: Const\<^sub>0_zero zero_mpoly_def)
	qed

	lemma mult_zero_right : "P * Const 0 = Const 0"
	by (metis mult_zero_left mult_zero_right)

	lemma mult_one_left : "Const 1 * (P :: real mpoly) = P"
	by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly_def)

	lemma mult_one_right : "(P::real mpoly) * Const 1 = P"
	by (simp add: Const.abs_eq Const\<^sub>0_one one_mpoly_def)


	subsection "Coefficient Lemmas"
	lemma coeff_zero[simp]: "MPoly_Type.coeff 0 x = 0"
	by transfer auto

	lemma coeff_sum: "MPoly_Type.coeff (sum f S) x = sum (\<lambda>i. MPoly_Type.coeff (f i) x) S"
	apply (induction S rule: infinite_finite_induct)
	apply (auto)
	by (metis More_MPoly_Type.coeff_add)

	lemma coeff_mult_Var: "MPoly_Type.coeff (x * Var i ^ p) c = (MPoly_Type.coeff x (c - monomial p i) when lookup c i \<ge> p)"
	by transfer'
	(auto simp: Var\<^sub>0_def pprod.monomial_power lookup_times_monomial_right
	of_nat_times_monomial monomial_adds_nat_iff)

	lemma lookup_update_self[simp]: "Poly_Mapping.update i (lookup m i) m = m"
	by (auto simp: lookup_update intro!: poly_mapping_eqI)

	lemma coeff_Const: "MPoly_Type.coeff (Const p) m = (p when m = 0)"
	by transfer' (auto simp: Const\<^sub>0_def lookup_single)

	lemma coeff_Var: "MPoly_Type.coeff (Var p) m = (1 when m = monomial 1 p)"
	by transfer' (auto simp: Var\<^sub>0_def lookup_single when_def)

	subsection "Miscellaneous"
	lemma update_0_0[simp]: "Poly_Mapping.update x 0 0 = 0"
	by (metis lookup_update_self lookup_zero)

	lemma mpoly_eq_iff: "p = q \<longleftrightarrow> (\<forall>m. MPoly_Type.coeff p m = MPoly_Type.coeff q m)"
	by transfer (auto simp: poly_mapping_eqI)

	lemma power_both_sides :
	assumes Ah : "(A::real) \<ge>0"
	assumes Bh : "(B::real) \<ge>0"
	shows "(A\<le>B) = (A^2\<le>B^2)"
	using Ah Bh by (meson power2_le_imp_le power_mono)

	lemma in_list_induct_helper:
	assumes "set(xs)\<subseteq>X"
	assumes "P []"
	assumes "(\<And>x. x\<in>X \<Longrightarrow> ( \<And>xs. P xs \<Longrightarrow> P (x # xs)))"
	shows "P xs" using assms(1)
	proof(induction xs)
	case Nil
	then show ?case using assms by auto
	next
	case (Cons a xs)
	then show ?case using assms(3) by auto
	qed

	theorem in_list_induct [case_names Nil Cons]:
	assumes "P []"
	assumes "(\<And>x. x\<in>set(xs) \<Longrightarrow> ( \<And>xs. P xs \<Longrightarrow> P (x # xs)))"
	shows "P xs"
	using in_list_induct_helper[of xs "set(xs)" P] using assms by auto

	subsubsection "Keys and vars"

	lemma inKeys_inVars : "a\<noteq>0 \<Longrightarrow> x \<in> keys m \<Longrightarrow> x \<in> vars(MPoly_Type.monom m a)"
	by(simp add: vars_def)

	lemma notInKeys_notInVars : "x \<notin> keys m \<Longrightarrow> x \<notin> vars(MPoly_Type.monom m a)"
	by(simp add: vars_def)

	lemma lookupNotIn : "x \<notin> keys m \<Longrightarrow> lookup m x = 0"
	by (simp add: in_keys_iff)

	subsection "Degree Lemmas"

	lemma degree_le_iff: "MPoly_Type.degree p x \<le> k \<longleftrightarrow> (\<forall>m\<in>monomials p. lookup m x \<le> k)"
	by transfer simp

	lemma degree_less_iff: "MPoly_Type.degree p x < k \<longleftrightarrow> (k>0 \<and> (\<forall>m\<in>monomials p. lookup m x < k))"
	by (transfer fixing: k) (cases "k = 0"; simp)

	lemma degree_ge_iff: "k > 0 \<Longrightarrow> MPoly_Type.degree p x \<ge> k \<longleftrightarrow> (\<exists>m\<in>monomials p. lookup m x \<ge> k)"
	using Max_ge_iff by (meson degree_less_iff not_less)

	lemma degree_greater_iff: "MPoly_Type.degree p x > k \<longleftrightarrow> (\<exists>m\<in>monomials p. lookup m x > k)"
	by transfer' (auto simp: Max_gr_iff)

	lemma degree_eq_iff:
	"MPoly_Type.degree p x = k \<longleftrightarrow> (if k = 0
	then (\<forall>m\<in>monomials p. lookup m x = 0)
	else (\<exists>m\<in>monomials p. lookup m x = k) \<and> (\<forall>m\<in>monomials p. lookup m x \<le> k))"
	by (subst eq_iff) (force simp: degree_le_iff degree_ge_iff intro!: antisym)

	declare poly_mapping.lookup_inject[simp del]

	lemma lookup_eq_and_update_lemma: "lookup m var = deg \<and> Poly_Mapping.update var 0 m = x \<longleftrightarrow>
	m = Poly_Mapping.update var deg x \<and> lookup x var = 0"
	unfolding poly_mapping_eq_iff
	by (force simp: update.rep_eq fun_eq_iff)


	lemma degree_const : "MPoly_Type.degree (Const (z::real)) (x::nat) = 0"
	by (simp add: degree_eq_iff monomials_Const)

	lemma degree_one : "MPoly_Type.degree (Var x :: real mpoly) x = 1"
	by(simp add: degree_eq_iff monomials_Var)

	subsection "Lemmas on treating a multivariate polynomial as univariate "
	lemma coeff_isolate_variable_sparse:
	"MPoly_Type.coeff (isolate_variable_sparse p var deg) x =
	(if lookup x var = 0
	then MPoly_Type.coeff p (Poly_Mapping.update var deg x)
	else 0)"
	apply (transfer fixing: x var deg p)
	unfolding lookup_sum
	unfolding lookup_single
	apply (auto simp: when_def)
	apply (subst sum.inter_filter[symmetric])
	subgoal by simp
	subgoal by (simp add: lookup_eq_and_update_lemma Collect_conv_if)
	by (auto intro!: sum.neutral simp add: lookup_update)

	lemma isovarspar_sum:
	"isolate_variable_sparse (p+q) var deg =
	isolate_variable_sparse (p) var deg
	+ isolate_variable_sparse (q) var deg"
	apply (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse )
	apply (metis More_MPoly_Type.coeff_add coeff_isolate_variable_sparse)
	by (metis More_MPoly_Type.coeff_add add.comm_neutral coeff_isolate_variable_sparse less_numeral_extra(3))

	lemma isolate_zero[simp]: "isolate_variable_sparse 0 var n = 0"
	by transfer' (auto simp: mpoly_eq_iff)

	lemma coeff_isolate_variable_sparse_minus_monomial:
	"MPoly_Type.coeff (isolate_variable_sparse mp var i) (m - monomial i var) =
	(if lookup m var \<le> i then MPoly_Type.coeff mp (Poly_Mapping.update var i m) else 0)"
	by (simp add: coeff_isolate_variable_sparse lookup_minus update_minus_monomial)

	lemma sum_over_zero: "(mp::real mpoly) = (\<Sum>i::nat \<le>MPoly_Type.degree mp x. isolate_variable_sparse mp x i * Var x^i)"
	by (auto simp add: mpoly_eq_iff coeff_sum coeff_mult_Var if_if_eq_conj not_le
	coeff_isolate_variable_sparse_minus_monomial when_def lookup_update degree_less_iff
	simp flip: eq_iff
	intro!: coeff_not_in_monomials)

	lemma const_lookup_zero : "isolate_variable_sparse (Const p ::real mpoly) (x::nat) (0::nat) = Const p"
	by (auto simp: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Const when_def)
	(metis lookup_update_self)

	lemma const_lookup_suc : "isolate_variable_sparse (Const p :: real mpoly) x (Suc i) = 0"
	apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Const when_def)
	by (metis lookup_update lookup_zero nat.distinct(1))

	lemma isovar_greater_degree : "\<forall>i > MPoly_Type.degree p var. isolate_variable_sparse p var i = 0"
	apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse degree_less_iff)
	by (metis coeff_not_in_monomials less_irrefl_nat lookup_update)

	lemma isolate_var_0 : "isolate_variable_sparse (Var x::real mpoly) x 0 = 0"
	apply(auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Var when_def)
	by (metis gr0I lookup_single_eq lookup_update_self n_not_Suc_n)

	lemma isolate_var_one : "isolate_variable_sparse (Var x :: real mpoly) x 1 = 1"
	by (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_Var coeff_eq_zero_iff)
	(smt More_MPoly_Type.coeff_monom One_nat_def add_diff_cancel_left' lookup_eq_and_update_lemma
	lookup_single_eq lookup_update_self monom_one plus_1_eq_Suc single_diff single_zero update_minus_monomial)

	lemma isovarspase_monom :
	assumes notInKeys : "x \<notin> keys m"
	assumes notZero : "a \<noteq> 0"
	shows "isolate_variable_sparse (MPoly_Type.monom m a) x 0 = (MPoly_Type.monom m a :: real mpoly)"
	using assms
	by (auto simp add: mpoly_eq_iff coeff_isolate_variable_sparse coeff_eq_zero_iff in_keys_iff)
	(metis lookup_update_self)

	lemma isolate_variable_spase_zero : "lookup m x = 0 \<Longrightarrow>
	insertion (nth L) ((MPoly_Type.monom m a)::real mpoly) = 0 \<Longrightarrow>
	a \<noteq> 0 \<Longrightarrow> insertion (nth L) (isolate_variable_sparse (MPoly_Type.monom m a) x 0) = 0"
	by (simp add: isovarspase_monom lookup_eq_zero_in_keys_contradict notInKeys_notInVars)

	lemma isovarsparNotIn : "x \<notin> vars (p::real mpoly) \<Longrightarrow> isolate_variable_sparse p x 0 = p"
	proof(induction p rule: mpoly_induct)
	case (monom m a)
	then show ?case
	apply(cases "a=0")
	by (simp_all add: isovarspase_monom vars_monom_keys)
	next
	case (sum p1 p2 m a)
	then show ?case
	by (simp add: monomials.rep_eq vars_add_monom isovarspar_sum)
	qed


	lemma degree0isovarspar :
	assumes deg0 : "MPoly_Type.degree (p::real mpoly) x = 0"
	shows "isolate_variable_sparse p x 0 = p"
	proof -
	have h1 : "p = (\<Sum>i::nat \<le>MPoly_Type.degree p x. isolate_variable_sparse p x i * Var x ^ i)"
	using sum_over_zero by auto
	have h2a : "\<forall>f. (\<Sum>i::nat \<le>0. f i) = f 0"
	apply(simp add: sum_def)
	by (metis add.right_neutral comm_monoid_add_class.sum_def finite.emptyI insert_absorb insert_not_empty sum.empty sum.insert)
	have h2 : "p = isolate_variable_sparse p x 0 * Var x ^ 0"
	using deg0 h1 h2a by auto
	show ?thesis using h2
	by auto
	qed


	subsection "Summation Lemmas"

	lemma summation_normalized :
	assumes nonzero : "(B ::real) \<noteq>0"
	shows "(\<Sum>i = 0..<((n::nat)+1). (f i :: real) * B ^ (n - i)) = (\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n)"
	proof -
	have h1a : "\<forall>x::real. ((\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * x = (\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * x))"
	apply(induction n )
	apply(auto)
	by (simp add: distrib_right)
	have h1 : "(\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n) = (\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * (B^n))"
	using h1a by auto
	have h2 : "(\<Sum>i = 0..<(n+1). ((f i) / (B ^ i)) * (B^n)) = (\<Sum>i = 0..<(n+1). (f i) * ((B^n) / (B ^ i)))"
	by auto
	have h3 : "(\<Sum>i = 0..<(n+1). (f i) * ((B^n) / (B ^ i))) = (\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i))"
	using add.right_neutral nonzero power_diff by fastforce
	show ?thesis using h1 h2 h3 by auto
	qed

	lemma normalize_summation :
	assumes nonzero : "(B::real)\<noteq>0"
	shows "(\<Sum>i = 0..<n+1. f i * B ^ (n - i))= 0
	\<longleftrightarrow>
	(\<Sum>i = 0..<(n::nat)+1. (f i::real) / (B ^ i)) = 0"
	proof -
	have pow_zero : "\<forall>i. B^(i :: nat)\<noteq>0" using nonzero by(auto)
	have single_division_zero : "\<forall>X. B*(X::real)=0 \<longleftrightarrow> X=0" using nonzero by(auto)
	have h1: "(\<Sum>i = 0..<n+1. (f i) / (B ^ i)) = 0 \<longleftrightarrow> ((\<Sum>i = 0..<n+1. (f i) / (B ^ i)))*B^n = 0"
	using nonzero single_division_zero by(auto)
	have h2: "((\<Sum>i = 0..<n+1. (f i) / (B ^ i))(B^n)) = ((\<Sum>i = 0..<n+1. (f i) (B ^ (n- i))))"
	using summation_normalized nonzero by auto
	show ?thesis using h1 h2 by auto
	qed


	lemma normalize_summation_less :
	assumes nonzero : "(B::real)\<noteq>0"
	shows "(\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i)) * B ^ (n mod 2) < 0
	\<longleftrightarrow>
	(\<Sum>i = 0..<((n::nat)+1). (f i::real) / (B ^ i)) < 0"
	proof -
	have h1 : "(\<Sum>i = 0..<(n+1). (f i) * B ^ (n - i)) * B ^ (n mod 2) < 0
	\<longleftrightarrow> (\<Sum>i = 0..<(n+1). (f i) / (B ^ i)) * (B^n) * B ^ (n mod 2) < 0"
	using summation_normalized nonzero by auto
	have h2a : "n mod 2 = 0 \<or> n mod 2 = 1" by auto
	have h2b : "n mod 2 = 1 \<Longrightarrow> odd n" by auto
	have h2c : "(B^n) * B ^ (n mod 2) > 0"
	using h2a h2b apply auto
	using nonzero apply presburger
	by (metis even_Suc mult.commute nonzero power_Suc zero_less_power_eq)
	have h2 : "\<forall>x. ((x * (B^n) * B ^ (n mod 2) < 0) = (x<0))"
	using h2c using mult.assoc by (metis mult_less_0_iff not_square_less_zero)
	show ?thesis using h1 h2 by auto
	qed

	subsection "Additional Lemmas with Vars"

	lemma not_in_isovarspar : "isolate_variable_sparse (p::real mpoly) var x = (q::real mpoly) \<Longrightarrow> var\<notin>(vars q)"
	apply(simp add: isolate_variable_sparse_def vars_def)
	proof -
	assume a1: "MPoly (\<Sum>m \| m \<in> monomials p \<and> lookup m var = x. monomial (MPoly_Type.coeff p m) (Poly_Mapping.update var 0 m)) = q"
	{ fix pp :: "nat \<Rightarrow>\<^sub>0 nat"
	have "isolate_variable_sparse p var x = q"
	using a1 isolate_variable_sparse.abs_eq by blast
	then have "var \<notin> keys pp \<or> pp \<notin> keys (mapping_of q)"
	by (metis (no_types) coeff_def coeff_isolate_variable_sparse in_keys_iff) }
	then show "\<forall>p\<in>keys (mapping_of q). var \<notin> keys p"
	by meson
	qed

	lemma not_in_add : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p+q))"
	by (meson UnE in_mono vars_add)

	lemma not_in_mult : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p*q))"
	by (meson UnE in_mono vars_mult)

	lemma not_in_neg : "var\<notin>(vars(p::real mpoly)) \<longleftrightarrow> var\<notin>(vars(-p))"
	proof -
	have h: "var \<notin> (vars (-1::real mpoly))" by (metis add_diff_cancel_right' add_neg_numeral_special(8) isolate_var_one isolate_zero isovarsparNotIn isovarspar_sum not_in_isovarspar)
	show ?thesis using not_in_mult using h by fastforce
	qed

	lemma not_in_sub : "var\<notin>(vars (p::real mpoly)) \<Longrightarrow> var\<notin>(vars (q::real mpoly)) \<Longrightarrow> var\<notin>(vars (p-q))"
	using not_in_add not_in_neg by fastforce


	lemma not_in_pow : "var\<notin>(vars(p::real mpoly)) \<Longrightarrow> var\<notin>(vars(p^i))"
	proof (induction i)
	case 0
	then show ?case using isolate_var_one not_in_isovarspar
	by (metis power_0)
	next
	case (Suc i)
	then show ?case using not_in_mult by simp
	qed

	lemma not_in_sum_var: "(\<forall>i. var\<notin>(vars(f(i)::real mpoly))) \<Longrightarrow> var\<notin>(vars(\<Sum>i\<in>{0..<(n::nat)}.f(i)))"
	proof (induction n)
	case 0
	then show ?case using isolate_zero not_in_isovarspar by fastforce
	next
	case (Suc n)
	have h1: "(sum f {0..<Suc n}) = (sum f {0..< n}) + (f n)" using sum.atLeast0_lessThan_Suc by blast
	have h2: "var \<notin> vars (f n)" by (simp add: Suc.prems)
	then show ?case using h1 vars_add by (simp add: Suc.IH Suc.prems not_in_add)
	qed

	lemma not_in_sum : "(\<forall>i. var\<notin>(vars(f(i)::real mpoly))) \<Longrightarrow> \<forall>(n::nat). var\<notin>(vars(\<Sum>i\<in>{0..<n}.f(i)))"
	using not_in_sum_var by blast

	lemma not_contains_insertion_helper :
	"\<forall>x\<in>keys (mapping_of p). var \<notin> keys x \<Longrightarrow>
	(\<And>k f. (k \<notin> keys f) = (lookup f k = 0)) \<Longrightarrow>
	lookup (mapping_of p) a = 0 \<or>
	(\<Prod>aa. (if aa < length L then L[var := y] ! aa else 0) ^ lookup a aa) =
	(\<Prod>aa. (if aa < length L then L[var := x] ! aa else 0) ^ lookup a aa)"
	apply(cases "lookup (mapping_of p) a = 0")
	apply auto
	apply(rule Prod_any.cong)
	apply auto
	using lookupNotIn nth_list_update_neq power_0 by smt

	lemma not_contains_insertion :
	assumes notIn : "var \<notin> vars (p:: real mpoly)"
	assumes exists : "insertion (nth_default 0 (list_update L var x)) p = val"
	shows "insertion (nth_default 0 (list_update L var y)) p = val"
	using notIn exists
	apply(simp add: insertion_def insertion_aux_def insertion_fun_def)
	unfolding vars_def nth_default_def
	using not_in_keys_iff_lookup_eq_zero
	apply auto
	apply(rule Sum_any.cong)
	apply simp
	using not_contains_insertion_helper[of p var _ L y x]
	proof -
	fix a :: "nat \<Rightarrow>\<^sub>0 nat"
	assume a1: "\<forall>x\<in>keys (mapping_of p). var \<notin> keys x"
	assume "\<And>k f. ((k::'a) \<notin> keys f) = (lookup f k = 0)"
	then show "lookup (mapping_of p) a = 0 \<or> (\<Prod>n. (if n < length L then L[var := y] ! n else 0) ^ lookup a n) = (\<Prod>n. (if n < length L then L[var := x] ! n else 0) ^ lookup a n)"
	using a1 \<open>\<And>a. \<lbrakk>\<forall>x\<in>keys (mapping_of p). var \<notin> keys x; \<And>k f. (k \<notin> keys f) = (lookup f k = 0)\<rbrakk> \<Longrightarrow> lookup (mapping_of p) a = 0 \<or> (\<Prod>aa. (if aa < length L then L[var := y] ! aa else 0) ^ lookup a aa) = (\<Prod>aa. (if aa < length L then L[var := x] ! aa else 0) ^ lookup a aa)\<close> by blast
	qed


	subsection "Insertion Lemmas"
	lemma insertion_sum_var : "((insertion f (\<Sum>i\<in>{0..<(n::nat)}.g(i))) = (\<Sum>i\<in>{0..<n}. insertion f (g i)))"
	proof (induction n)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then show ?case by (simp add: insertion_add)
	qed

	(* changed to explicitly typecast n as a nat *)
	lemma insertion_sum : "\<forall>(n::nat). ((insertion f (\<Sum>i\<in>{0..<n}.g(i))) = (\<Sum>i\<in>{0..<n}. insertion f (g i)))"
	using insertion_sum_var by blast


	lemma insertion_sum' : "\<And>(n::nat). ((insertion f (\<Sum>i\<le>n. g(i))) = (\<Sum>i\<le>n. insertion f (g i)))"
	by (metis (no_types, lifting) fun_sum_commute insertion_add insertion_zero sum.cong)

	lemma insertion_pow : "insertion f (p^i) = (insertion f p)^i"
	proof (induction i)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then show ?case by (simp add: insertion_mult)
	qed

	lemma insertion_neg : "insertion f (-p) = -insertion f p"
	by (metis add.inverse_inverse insertionNegative)

	lemma insertion_var :
	"length L > var \<Longrightarrow> insertion (nth_default 0 (list_update L var x)) (Var var) = x"
	by (auto simp: monomials_Var coeff_Var insertion_code nth_default_def)

	lemma insertion_var_zero : "insertion (nth_default 0 (x#xs)) (Var 0) = x" using insertion_var
	by fastforce

	lemma notIn_insertion_sub : "x\<notin>vars(p::real mpoly) \<Longrightarrow> x\<notin>vars(q::real mpoly)
	\<Longrightarrow> insertion f (p-q) = insertion f p - insertion f q"
	by (metis ab_group_add_class.ab_diff_conv_add_uminus insertion_add insertion_neg)

	lemma insertion_sub : "insertion f (A-B :: real mpoly) = insertion f A - insertion f B"
	using insertion_neg insertion_add
	by (metis uminus_add_conv_diff)

	lemma insertion_four : "insertion ((nth_default 0) xs) 4 = 4"
	by (metis (no_types, lifting) insertion_add insertion_one numeral_plus_numeral one_add_one semiring_norm(2) semiring_norm(6))

	lemma insertion_add_ind_basecase:
	"insertion (nth (list_update L var x)) ((\<Sum>i::nat \<le> 0. isolate_variable_sparse p var i * (Var var)^i))
	= (\<Sum>i = 0..<(0+1). insertion (nth (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
	proof -
	have h1: "((\<Sum>i::nat \<le> 0. isolate_variable_sparse p var i * (Var var)^i))
	= (isolate_variable_sparse p var 0 * (Var var)^0)"
	by auto
	show ?thesis using h1
	by auto
	qed

	lemma insertion_add_ind:
	"insertion (nth_default 0 (list_update L var x)) ((\<Sum>i::nat \<le> d. isolate_variable_sparse p var i * (Var var)^i))
	= (\<Sum>i = 0..<(d+1). insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
	proof (induction d)
	case 0
	then show ?case using insertion_add_ind_basecase nth_default_def
	by auto
	next
	case (Suc n)
	then show ?case using insertion_add apply auto
	by (simp add: insertion_add)
	qed

	lemma sum_over_degree_insertion :
	assumes lLength : "length L > var"
	assumes deg : "MPoly_Type.degree (p::real mpoly) var = d"
	shows "(\<Sum>i = 0..<(d+1). insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i) * (x^i))
	= insertion (nth_default 0 (list_update L var x)) p"
	proof -
	have h1: "(p::real mpoly) = (\<Sum>i::nat \<le>(MPoly_Type.degree p var). isolate_variable_sparse p var i * (Var var)^i)" using sum_over_zero by auto
	have h2: "insertion (nth_default 0 (list_update L var x)) p =
	insertion (nth_default 0 (list_update L var x)) ((\<Sum>i::nat \<le> d. isolate_variable_sparse p var i * (Var var)^i))" using h1 deg by auto
	have h3: "insertion (nth_default 0 (list_update L var x)) p = (\<Sum>i = 0..<(d+1). insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse p var i * (Var var)^i))"
	using h2 insertion_add_ind nth_default_def
	- by (simp add: )
	+ by simp
	show ?thesis using h3 insertion_var insertion_pow
	by (metis (no_types, lifting) insertion_mult lLength sum.cong)
	qed



	lemma insertion_isovarspars_free :
	"insertion (nth_default 0 (list_update L var x)) (isolate_variable_sparse (p::real mpoly) var (i::nat))
	=insertion (nth_default 0 (list_update L var y)) (isolate_variable_sparse (p::real mpoly) var (i::nat))"
	proof -
	have h : "var \<notin> vars(isolate_variable_sparse (p::real mpoly) var (i::nat))"
	by (simp add: not_in_isovarspar)
	then show ?thesis using not_contains_insertion
	by blast
	qed
	lemma insertion_zero : "insertion f (Const 0 ::real mpoly) = 0"
	by (metis add_cancel_right_right add_zero insertion_zero)

	lemma insertion_one : "insertion f (Const 1 ::real mpoly) = 1"
	by (metis insertion_one mult.right_neutral mult_one_left)

	lemma insertion_const : "insertion f (Const c::real mpoly) = (c::real)"
	by (auto simp: monomials_Const coeff_Const insertion_code)


	subsection "Putting Things Together"
	subsubsection "More Degree Lemmas"
	lemma degree_add_leq :
	assumes h1 : "MPoly_Type.degree a var \<le> x"
	assumes h2 : "MPoly_Type.degree b var \<le> x"
	shows "MPoly_Type.degree (a+b) var \<le> x"
	using degree_eq_iff coeff_add coeff_not_in_monomials
	by (smt (z3) More_MPoly_Type.coeff_add add.left_neutral coeff_eq_zero_iff degree_le_iff h1 h2)

	lemma degree_add_less :
	assumes h1 : "MPoly_Type.degree a var < x"
	assumes h2 : "MPoly_Type.degree b var < x"
	shows "MPoly_Type.degree (a+b) var < x"
	proof -
	obtain pp :: "nat \<Rightarrow> nat \<Rightarrow> 'a mpoly \<Rightarrow> nat \<Rightarrow>\<^sub>0 nat" where
	"\<forall>x0 x1 x2. (\<exists>v3. v3 \<in> monomials x2 \<and> \<not> lookup v3 x1 < x0) = (pp x0 x1 x2 \<in> monomials x2 \<and> \<not> lookup (pp x0 x1 x2) x1 < x0)"
	by moura
	then have f1: "\<forall>m n na. (\<not> MPoly_Type.degree m n < na \<or> 0 < na \<and> (\<forall>p. p \<notin> monomials m \<or> lookup p n < na)) \<and> (MPoly_Type.degree m n < na \<or> \<not> 0 < na \<or> pp na n m \<in> monomials m \<and> \<not> lookup (pp na n m) n < na)"
	by (metis (no_types) degree_less_iff)
	then have "0 < x \<and> (\<forall>p. p \<notin> monomials a \<or> lookup p var < x)"
	using assms(1) by presburger
	then show ?thesis
	using f1 by (metis MPolyExtension.coeff_add add.left_neutral assms(2) coeff_eq_zero_iff)
	qed

	lemma degree_sum : "(\<forall>i\<in>{0..n::nat}. MPoly_Type.degree (f i :: real mpoly) var \<le> x) \<Longrightarrow> (MPoly_Type.degree (\<Sum>x\<in>{0..n}. f x) var) \<le> x"
	proof(induction n)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then show ?case by(simp add: degree_add_leq)
	qed

	lemma degree_sum_less : "(\<forall>i\<in>{0..n::nat}. MPoly_Type.degree (f i :: real mpoly) var < x) \<Longrightarrow> (MPoly_Type.degree (\<Sum>x\<in>{0..n}. f x) var) < x"
	proof(induction n)
	case 0
	then show ?case by auto
	next
	case (Suc n)
	then show ?case by(simp add: degree_add_less)
	qed


	lemma varNotIn_degree :
	assumes "var \<notin> vars p"
	shows "MPoly_Type.degree p var = 0"
	proof-
	have "\<forall>m\<in>monomials p. lookup m var = 0"
	using assms unfolding vars_def keys_def
	using monomials.rep_eq by fastforce
	then show ?thesis
	using degree_less_iff by blast
	qed

	lemma degree_mult_leq :
	assumes pnonzero: "(p::real mpoly)\<noteq>0"
	assumes qnonzero: "(q::real mpoly)\<noteq>0"
	shows "MPoly_Type.degree ((p::real mpoly) * (q::real mpoly)) var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var)"
	proof(cases "MPoly_Type.degree (p*q) var =0")
	case True
	then show ?thesis by simp
	next
	case False
	have hp: "\<forall>m\<in>monomials p. lookup m var \<le> MPoly_Type.degree p var" using degree_eq_iff
	by (metis zero_le)
	have hq: "\<forall>m\<in>monomials q. lookup m var \<le> MPoly_Type.degree q var" using degree_eq_iff
	by (metis zero_le)
	have hpq: "\<forall>m\<in>{a+b \| a b . a \<in> monomials p \<and> b \<in> monomials q}.
	lookup m var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var)"
	by (smt add_le_mono hp hq mem_Collect_eq plus_poly_mapping.rep_eq)
	have h1: "(\<forall>m\<in>monomials (p*q). lookup m var \<le> (MPoly_Type.degree p var) + (MPoly_Type.degree q var))"
	using mult_monomials_dir_one hpq
	by blast
	then show ?thesis using h1 degree_eq_iff False
	by (simp add: degree_le_iff)
	qed

	lemma degree_exists_monom:
	assumes "p\<noteq>0"
	shows "\<exists>m\<in>monomials p. lookup m var = MPoly_Type.degree p var"
	proof(cases "MPoly_Type.degree p var =0")
	case True
	have h1: "\<exists>m\<in>monomials p. lookup m var = 0" unfolding monomials_def
	by (metis True assms(1) aux degree_eq_iff in_keys_iff mapping_of_inject monomials.rep_eq monomials_def zero_mpoly.rep_eq)
	then show ?thesis using h1
	using True by simp
	next
	case False
	then show ?thesis using degree_eq_iff assms(1) apply(auto)
	by (metis degree_eq_iff dual_order.strict_iff_order)
	qed

	lemma degree_not_exists_monom:
	assumes "p\<noteq>0"
	shows "\<not> (\<exists> m\<in>monomials p. lookup m var > MPoly_Type.degree p var)"
	proof -
	show ?thesis using degree_less_iff by blast
	qed

	lemma degree_monom: "MPoly_Type.degree (MPoly_Type.monom x y) v = (if y = 0 then 0 else lookup x v)"
	by (auto simp: degree_eq_iff)

	lemma degree_plus_disjoint:
	"MPoly_Type.degree (p + MPoly_Type.monom m c) v = max (MPoly_Type.degree p v) (MPoly_Type.degree (MPoly_Type.monom m c) v)"
	if "m \<notin> monomials p"
	for p::"real mpoly"
	using that
	apply (subst degree_eq_iff)
	apply (auto simp: monomials_add_disjoint)
	apply (auto simp: degree_eq_iff degree_monom)
	apply (metis MPoly_Type.degree_zero degree_exists_monom less_numeral_extra(3))
	using degree_le_iff apply blast
	using degree_eq_iff
	apply (metis max_def neq0_conv)
	apply (metis degree_eq_iff max.coboundedI1 neq0_conv)
	apply (metis MPoly_Type.degree_zero degree_exists_monom max_def zero_le)
	using degree_le_iff max.cobounded1 by blast

	subsubsection "More isolate\\_variable\\_sparse lemmas"

	lemma isolate_variable_sparse_ne_zeroD:
	"isolate_variable_sparse mp v x \<noteq> 0 \<Longrightarrow> x \<le> MPoly_Type.degree mp v"
	using isovar_greater_degree leI by blast

	context includes poly.lifting begin
	lift_definition mpoly_to_nested_poly::"'a::comm_monoid_add mpoly \<Rightarrow> nat \<Rightarrow> 'a mpoly Polynomial.poly" is
	"\<lambda>(mp::'a mpoly) (v::nat) (p::nat). isolate_variable_sparse mp v p"
	\<comment> \<open>note \<^const>\<open>extract_var\<close> nests the other way around\<close>
	unfolding MOST_iff_cofinite
	proof -
	fix mp::"'a mpoly" and v::nat
	have "{p. isolate_variable_sparse mp v p \<noteq> 0} \<subseteq> {0..MPoly_Type.degree mp v}"
	(is "?s \<subseteq> _")
	by (auto dest!: isolate_variable_sparse_ne_zeroD)
	also have "finite \<dots>" by simp
	finally (finite_subset) show "finite ?s" .
	qed

	lemma degree_eq_0_mpoly_to_nested_polyI:
	"mpoly_to_nested_poly mp v = 0 \<Longrightarrow> MPoly_Type.degree mp v = 0"
	apply transfer'
	apply (simp add: degree_eq_iff)
	apply transfer'
	apply (auto simp: fun_eq_iff)
	proof -
	fix mpa :: "'a mpoly" and va :: nat and m :: "nat \<Rightarrow>\<^sub>0 nat"
	assume a1: "\<forall>x. (\<Sum>m \| m \<in> monomials mpa \<and> lookup m va = x. monomial (MPoly_Type.coeff mpa m) (Poly_Mapping.update va 0 m)) = 0"
	assume a2: "m \<in> monomials mpa"
	have f3: "\<forall>m p. lookup (mapping_of m) p \<noteq> (0::'a) \<or> p \<notin> monomials m"
	by (metis (full_types) coeff_def coeff_eq_zero_iff)
	have f4: "\<forall>n. mapping_of (isolate_variable_sparse mpa va n) = 0"
	using a1 by (simp add: isolate_variable_sparse.rep_eq)
	have "\<forall>p n. lookup 0 (p::nat \<Rightarrow>\<^sub>0 nat) = (0::'a) \<or> (0::nat) = n"
	by simp
	then show "lookup m va = 0"
	using f4 f3 a2 by (metis coeff_def coeff_isolate_variable_sparse lookup_eq_and_update_lemma)
	qed

	lemma coeff_eq_zero_mpoly_to_nested_polyD: "mpoly_to_nested_poly mp v = 0 \<Longrightarrow> MPoly_Type.coeff mp 0 = 0"
	apply transfer'
	apply transfer'
	by (metis (no_types) coeff_def coeff_isolate_variable_sparse isolate_variable_sparse.rep_eq lookup_zero update_0_0)

	lemma mpoly_to_nested_poly_eq_zero_iff[simp]:
	"mpoly_to_nested_poly mp v = 0 \<longleftrightarrow> mp = 0"
	apply (auto simp: coeff_eq_zero_mpoly_to_nested_polyD degree_eq_0_mpoly_to_nested_polyI)
	proof -
	show "mpoly_to_nested_poly mp v = 0 \<Longrightarrow> mp = 0"
	apply (frule degree_eq_0_mpoly_to_nested_polyI)
	apply (frule coeff_eq_zero_mpoly_to_nested_polyD)
	apply (transfer' fixing: mp v)
	apply (transfer' fixing: mp v)
	apply (auto simp: fun_eq_iff mpoly_eq_iff intro!: sum.neutral)
	proof -
	fix m :: "nat \<Rightarrow>\<^sub>0 nat"
	assume a1: "\<forall>x. (\<Sum>m \| m \<in> monomials mp \<and> lookup m v = x. monomial (MPoly_Type.coeff mp m) (Poly_Mapping.update v 0 m)) = 0"
	assume a2: "MPoly_Type.degree mp v = 0"
	have "\<forall>n. isolate_variable_sparse mp v n = 0"
	using a1 by (simp add: isolate_variable_sparse.abs_eq zero_mpoly.abs_eq)
	then have f3: "\<forall>p. MPoly_Type.coeff mp p = MPoly_Type.coeff 0 p \<or> lookup p v \<noteq> 0"
	by (metis (no_types) coeff_isolate_variable_sparse lookup_update_self)
	then show "MPoly_Type.coeff mp m = 0"
	using a2 coeff_zero
	by (metis coeff_not_in_monomials degree_eq_iff)
	qed
	show "mp = 0 \<Longrightarrow> mpoly_to_nested_poly 0 v = 0"
	subgoal
	apply transfer'
	apply transfer'
	by (auto simp: fun_eq_iff intro!: sum.neutral)
	done
	qed

	lemma isolate_variable_sparse_degree_eq_zero_iff: "isolate_variable_sparse p v (MPoly_Type.degree p v) = 0 \<longleftrightarrow> p = 0"
	apply (transfer')
	apply auto
	proof -
	fix pa :: "'a mpoly" and va :: nat
	assume "(\<Sum>m \| m \<in> monomials pa \<and> lookup m va = MPoly_Type.degree pa va. monomial (MPoly_Type.coeff pa m) (Poly_Mapping.update va 0 m)) = 0"
	then have "mapping_of (isolate_variable_sparse pa va (MPoly_Type.degree pa va)) = 0"
	by (simp add: isolate_variable_sparse.rep_eq)
	then show "pa = 0"
	by (metis (no_types) coeff_def coeff_eq_zero_iff coeff_isolate_variable_sparse degree_exists_monom lookup_eq_and_update_lemma lookup_zero)
	qed

	lemma degree_eq_univariate_degree: "MPoly_Type.degree p v =
	(if p = 0 then 0 else Polynomial.degree (mpoly_to_nested_poly p v))"
	apply auto
	apply (rule antisym)
	subgoal
	apply (rule Polynomial.le_degree)
	- apply (auto simp: )
	+ apply auto
	apply transfer'
	by (simp add: isolate_variable_sparse_degree_eq_zero_iff)
	subgoal apply (rule Polynomial.degree_le)
	apply (auto simp: elim!: degree_eq_zeroE)
	apply transfer'
	by (simp add: isovar_greater_degree)
	done

	lemma compute_mpoly_to_nested_poly[code]:
	"coeffs (mpoly_to_nested_poly mp v) =
	(if mp = 0 then []
	else map (isolate_variable_sparse mp v) [0..<Suc(MPoly_Type.degree mp v)])"
	unfolding coeffs_def unfolding mpoly_to_nested_poly_eq_zero_iff degree_eq_univariate_degree apply auto
	subgoal by transfer' (rule refl)
	by transfer' (rule refl)

	end

	lemma isolate_variable_sparse_monom: "isolate_variable_sparse (MPoly_Type.monom m a) v i =
	(if a = 0 \<or> lookup m v \<noteq> i then 0 else MPoly_Type.monom (Poly_Mapping.update v 0 m) a)"
	proof -
	have *: "{x. x = m \<and> lookup x v = i} = (if lookup m v = i then {m} else {})"
	by auto
	show ?thesis
	by (transfer' fixing: m a v i) (simp add:*)
	qed



	lemma isolate_variable_sparse_monom_mult:
	"isolate_variable_sparse (MPoly_Type.monom m a * q) v n =
	(if n \<ge> lookup m v
	then MPoly_Type.monom (Poly_Mapping.update v 0 m) a * isolate_variable_sparse q v (n - lookup m v)
	else 0)"
	for q::"'a::semiring_no_zero_divisors mpoly"
	apply (auto simp: MPoly_Type.mult_monom)
	subgoal
	apply transfer'
	subgoal for mon v i a q
	apply (auto simp add: monomials_monom_mult sum_distrib_left)
	apply (rule sum.reindex_bij_witness_not_neutral[where
	j="\<lambda>a. a - mon"
	and i="\<lambda>a. mon + a"
	and S'="{}"
	and T'="{}"
	])
	apply (auto simp: lookup_add)
	apply (auto simp: poly_mapping_eq_iff fun_eq_iff single.rep_eq Poly_Mapping.mult_single)
	apply (auto simp: when_def More_MPoly_Type.coeff_monom_mult)
	by (auto simp: lookup_update lookup_add split: if_splits)
	done
	subgoal
	apply transfer'
	apply (auto intro!: sum.neutral simp: monomials_monom_mult )
	apply (rule poly_mapping_eqI)
	apply (auto simp: lookup_single when_def)
	by (simp add: lookup_add)
	done

	lemma isolate_variable_sparse_mult:
	"isolate_variable_sparse (p * q) v n = (\<Sum>i\<le>n. isolate_variable_sparse p v i * isolate_variable_sparse q v (n - i))"
	for p q::"'a::semiring_no_zero_divisors mpoly"
	proof (induction p rule: mpoly_induct)
	case (monom m a)
	then show ?case
	by (cases "a = 0")
	(auto simp add: mpoly_eq_iff coeff_sum coeff_mult if_conn if_distrib if_distribR
	isolate_variable_sparse_monom isolate_variable_sparse_monom_mult
	cong: if_cong)
	next
	case (sum p1 p2 m a)
	then show ?case
	by (simp add: distrib_right isovarspar_sum sum.distrib)
	qed

	subsubsection "More Miscellaneous"
	lemma var_not_in_Const : "var\<notin>vars (Const x :: real mpoly)"
	unfolding vars_def keys_def
	by (smt UN_iff coeff_def coeff_isolate_variable_sparse const_lookup_zero keys_def lookup_eq_zero_in_keys_contradict)

	lemma mpoly_to_nested_poly_mult:
	"mpoly_to_nested_poly (p * q) v = mpoly_to_nested_poly p v * mpoly_to_nested_poly q v"
	for p q::"'a::{comm_semiring_0, semiring_no_zero_divisors} mpoly"
	by (auto simp: poly_eq_iff coeff_mult mpoly_to_nested_poly.rep_eq isolate_variable_sparse_mult)

	lemma get_if_const_insertion :
	assumes "get_if_const (p::real mpoly) = Some r"
	shows "insertion f p = r"
	proof-
	have "Set.is_empty (vars p)"
	apply(cases "Set.is_empty (vars p)")
	apply(simp) using assms by(simp)
	then have "(MPoly_Type.coeff p 0) = r"
	using assms by simp
	then show ?thesis
	by (metis Set.is_empty_def \<open>Set.is_empty (vars p)\<close> empty_iff insertion_irrelevant_vars insertion_trivial)
	qed

	subsubsection "Yet more Degree Lemmas"
	lemma degree_mult:
	fixes p q::"'a::{comm_semiring_0, ring_1_no_zero_divisors} mpoly"
	assumes "p \<noteq> 0"
	assumes "q \<noteq> 0"
	shows "MPoly_Type.degree (p * q) v = MPoly_Type.degree p v + MPoly_Type.degree q v"
	using assms
	by (auto simp add: degree_eq_univariate_degree mpoly_to_nested_poly_mult Polynomial.degree_mult_eq)

	lemma degree_eq:
	assumes "(p::real mpoly) = (q:: real mpoly)"
	shows "MPoly_Type.degree p x = MPoly_Type.degree q x"
	by (simp add: assms)

	lemma degree_var_i : "MPoly_Type.degree (((Var x)^i:: real mpoly)) x = i"
	proof (induct i)
	case 0
	then show ?case using degree_const
	by simp
	next
	case (Suc i)
	have multh: "(Var x)^(Suc i) = ((Var x)^i::real mpoly) * (Var x:: real mpoly)"
	using power_Suc2 by blast
	have deg0h: "MPoly_Type.degree 0 x = 0"
	by simp
	have deg1h: "MPoly_Type.degree (Var x::real mpoly) x = 1"
	using degree_one
	by blast
	have nonzeroh1: "(Var x:: real mpoly) \<noteq> 0"
	using degree_eq deg0h deg1h by auto
	have nonzeroh2: "((Var x)^i:: real mpoly) \<noteq> 0"
	using degree_eq deg0h Suc.hyps
	by (metis one_neq_zero power_0)
	have sumh: "(MPoly_Type.degree (((Var x)^i:: real mpoly) * (Var x:: real mpoly)) x) = (MPoly_Type.degree ((Var x)^i::real mpoly) x) + (MPoly_Type.degree (Var x::real mpoly) x)"
	using degree_mult[where p = "(Var x)^i::real mpoly", where q = "Var x::real mpoly"] nonzeroh1 nonzeroh2
	by blast
	then show ?case using sumh deg1h
	by (metis Suc.hyps Suc_eq_plus1 multh)
	qed


	lemma degree_less_sum:
	assumes "MPoly_Type.degree (p::real mpoly) var = n"
	assumes "MPoly_Type.degree (q::real mpoly) var = m"
	assumes "m < n"
	shows "MPoly_Type.degree (p + q) var = n"
	proof -
	have h1: "n > 0"
	using assms(3) neq0_conv by blast
	have h2: "(\<exists>m\<in>monomials p. lookup m var = n) \<and> (\<forall>m\<in>monomials p. lookup m var \<le> n)"
	using degree_eq_iff assms(1)
	by (metis degree_ge_iff h1 order_refl)
	have h3: "(\<exists>m\<in>monomials (p + q). lookup m var = n)"
	using h2
	by (metis MPolyExtension.coeff_add add.right_neutral assms(2) assms(3) coeff_eq_zero_iff degree_not_exists_monom)
	have h4: "(\<forall>m\<in>monomials (p + q). lookup m var \<le> n)"
	using h2 assms(3) assms(2)
	using degree_add_leq degree_le_iff dual_order.strict_iff_order by blast
	show ?thesis using degree_eq_iff h3 h4
	by (metis assms(3) gr_implies_not0)
	qed

	lemma degree_less_sum':
	assumes "MPoly_Type.degree (p::real mpoly) var = n"
	assumes "MPoly_Type.degree (q::real mpoly) var = m"
	assumes "n < m"
	shows "MPoly_Type.degree (p + q) var = m" using degree_less_sum[OF assms(2) assms(1) assms(3)]
	by (simp add: add.commute)

	(* Result on the degree of the derivative *)

	lemma nonzero_const_is_nonzero:
	assumes "(k::real) \<noteq> 0"
	shows "((Const k)::real mpoly) \<noteq> 0"
	by (metis MPoly_Type.insertion_zero assms insertion_const)

	lemma degree_derivative :
	assumes "MPoly_Type.degree p x > 0"
	shows "MPoly_Type.degree p x = MPoly_Type.degree (derivative x p) x + 1"
	proof -
	define f where "f i = (isolate_variable_sparse p x (i+1) * (Var x)^(i) * (Const (i+1)))" for i
	define n where "n = MPoly_Type.degree p x-1"
	have d : "\<exists>m\<in>monomials p. lookup m x = n+1"
	using n_def degree_eq_iff assms
	by (metis add.commute less_not_refl2 less_one linordered_semidom_class.add_diff_inverse)
	have h1a : "\<forall>i. MPoly_Type.degree (isolate_variable_sparse p x i) x = 0"
	by (simp add: not_in_isovarspar varNotIn_degree)
	have h1b : "\<forall>i::nat. MPoly_Type.degree ((Var x)^i:: real mpoly) x = i"
	using degree_var_i by auto
	have h1c1 : "\<forall>i. (Var(x)^(i)::real mpoly)\<noteq>0"
	by (metis MPoly_Type.degree_zero h1b power_0 zero_neq_one)
	fix i
	have h1c1var: "((Var x)^i:: real mpoly) \<noteq> 0" using h1c1 by blast
	have h1c2 : "((Const ((i::nat) + 1))::real mpoly)\<noteq>0"
	using nonzero_const_is_nonzero
	by auto
	have h1c3: "(isolate_variable_sparse p x (n + 1)) \<noteq> 0" using d
	by (metis One_nat_def Suc_pred add.commute assms isolate_variable_sparse_degree_eq_zero_iff n_def not_gr_zero not_in_isovarspar plus_1_eq_Suc varNotIn_degree)
	have h3: "(isolate_variable_sparse p x (i+1) = 0) \<longrightarrow> (MPoly_Type.degree (f i) x) = 0"
	by (simp add: f_def)
	have degh1: "(MPoly_Type.degree (((Const ((i::nat)+1))::real mpoly)*(Var x)^i) x) =
	((MPoly_Type.degree ((Const (i+1))::real mpoly) x) + (MPoly_Type.degree ((Var x)^i:: real mpoly) x))"
	using h1c2 h1c1var degree_mult[where p="((Const ((i::nat)+1))::real mpoly)", where q="((Var x)^i:: real mpoly)"]
	by blast
	then have degh2: "(MPoly_Type.degree (((Const ((i::nat)+1))::real mpoly)*(Var x)^i) x) = i"
	using degree_var_i degree_const
	by simp
	have nonzerohyp: "(((Const ((i::nat)+1))::real mpoly)*(Var x)^i) \<noteq> 0"
	proof (induct i)
	case 0
	then show ?case
	by (simp add: nonzero_const_is_nonzero)
	next
	case (Suc i)
	then show ?case using degree_eq degh2
	by (metis Suc_eq_plus1 h1c1 mult_eq_0_iff nat.simps(3) nonzero_const_is_nonzero of_nat_eq_0_iff)
	qed
	have h4a1: "(isolate_variable_sparse p x (i+1) \<noteq> 0) \<longrightarrow> (MPoly_Type.degree (isolate_variable_sparse p x (i+1) * ((Var x)^(i) * (Const (i+1)))::real mpoly) x =
	(MPoly_Type.degree (isolate_variable_sparse p x (i+1):: real mpoly) x) + (MPoly_Type.degree (((Const (i+1)) * (Var x)^(i))::real mpoly) x))"
	using nonzerohyp degree_mult[where p = "(isolate_variable_sparse p x (i+1))::real mpoly", where q = "((Const (i+1)) * (Var x)^(i)):: real mpoly", where v = "x"]
	by (simp add: mult.commute)
	have h4: "(isolate_variable_sparse p x (i+1) \<noteq> 0) \<longrightarrow> (MPoly_Type.degree (f i) x) = i"
	using h4a1 f_def degh2 h1a
	by (metis (no_types, lifting) degh1 degree_const h1b mult.commute mult.left_commute of_nat_1 of_nat_add)
	have h5: "(MPoly_Type.degree (f i) x) \<le> i" using h3 h4 by auto
	have h6: "(MPoly_Type.degree (f n) x) = n" using h1c3 h4
	by (smt One_nat_def add.right_neutral add_Suc_right degree_const degree_mult divisors_zero f_def h1a h1b h1c1 mult.commute nonzero_const_is_nonzero of_nat_1 of_nat_add of_nat_neq_0)
	have h7a: "derivative x p = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. isolate_variable_sparse p x (i+1) * (Var x)^i * (Const (i+1)))" using derivative_def by auto
	have h7b: "(\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. isolate_variable_sparse p x (i+1) * (Var x)^i * (Const (i+1))) = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. (f i))" using f_def
	by (metis Suc_eq_plus1 add.commute semiring_1_class.of_nat_simps(2))
	have h7c: "derivative x p = (\<Sum>i\<in>{0..MPoly_Type.degree p x-1}. (f i))" using h7a h7b by auto
	have h7: "derivative x p = (\<Sum>i\<in>{0..n}. (f i))" using n_def h7c
	by blast
	have h8: "n > 0 \<longrightarrow> ((MPoly_Type.degree (\<Sum>i\<in>{0..(n-1)}. (f i)) x) < n)"
	proof (induct n)
	case 0
	then show ?case
	by blast
	next
	case (Suc n)
	then show ?case using h5 degree_less_sum
	by (smt add_cancel_right_right atLeastAtMost_iff degree_const degree_mult degree_sum_less degree_var_i diff_Suc_1 f_def h1a le_imp_less_Suc mult.commute mult_eq_0_iff)
	qed
	have h9a: "n = 0 \<longrightarrow> MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n" using h6
	by auto
	have h9b: "n > 0 \<longrightarrow> MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n"
	proof -
	have h9bhyp: "n > 0 \<longrightarrow> (MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = MPoly_Type.degree ((\<Sum>i\<in>{0..(n-1)}. (f i)) + (f n)) x)"
	by (metis Suc_diff_1 sum.atLeast0_atMost_Suc)
	have h9bhyp2: "n > 0 \<longrightarrow> ((MPoly_Type.degree ((\<Sum>i\<in>{0..(n-1)}. (f i)) + (f n)) x) = n)"
	using h6 h8 degree_less_sum
	by (simp add: add.commute)
	then show ?thesis using h9bhyp2 h9bhyp
	by linarith
	qed
	have h9: "MPoly_Type.degree (\<Sum>i\<in>{0..n}. (f i)) x = n" using h9a h9b
	by blast
	have h10: "MPoly_Type.degree (derivative x p) x = n" using h9 h7
	by simp
	show ?thesis using h10 n_def
	using assms by linarith
	qed


	lemma express_poly :
	assumes h : "MPoly_Type.degree (p::real mpoly) var = 1 \<or> MPoly_Type.degree p var = 2"
	shows "p =
	(isolate_variable_sparse p var 2)*(Var var)^2
	+(isolate_variable_sparse p var 1)*(Var var)
	+(isolate_variable_sparse p var 0)"
	proof-
	have h1a: "MPoly_Type.degree p var = 1 \<longrightarrow> p =
	isolate_variable_sparse p var 0 +
	isolate_variable_sparse p var 1 * Var var"
	using sum_over_zero[where mp="p",where x="var"]
	by auto
	have h1b: "MPoly_Type.degree p var = 1 \<longrightarrow> isolate_variable_sparse p var 2 = 0"
	using isovar_greater_degree
	by (simp add: isovar_greater_degree)
	have h1: "MPoly_Type.degree p var = 1 \<longrightarrow> p =
	isolate_variable_sparse p var 0 +
	isolate_variable_sparse p var 1 * Var var
	+ isolate_variable_sparse p var 2 * (Var var)^2" using h1a h1b by auto
	have h2a: "MPoly_Type.degree p var = 2 \<longrightarrow> p = (\<Sum>i::nat \<le> 2. isolate_variable_sparse p var i * Var var^i)"
	using sum_over_zero[where mp="p", where x="var"] by auto
	have h2b: "(\<Sum>i::nat \<le> 2. isolate_variable_sparse p var i * Var var^i) =
	(\<Sum>i::nat \<le> 1. isolate_variable_sparse p var i * Var var^i) +
	isolate_variable_sparse p var 2 * (Var var)^2" apply auto
	by (simp add: numerals(2))
	have h2: "MPoly_Type.degree p var = 2 \<longrightarrow> p =
	isolate_variable_sparse p var 0 +
	isolate_variable_sparse p var 1 * Var var +
	isolate_variable_sparse p var 2 * (Var var)^2"
	using h2a h2b by auto
	have h3: "isolate_variable_sparse p var 0 +
	isolate_variable_sparse p var 1 * Var var +
	isolate_variable_sparse p var 2 * (Var var)^2 =
	isolate_variable_sparse p var 2 * (Var var)^2 +
	isolate_variable_sparse p var 1 * Var var +
	isolate_variable_sparse p var 0" by (simp add: add.commute)

	show ?thesis using h h1 h2 h3 by presburger
	qed

	lemma degree_isovarspar : "MPoly_Type.degree (isolate_variable_sparse (p::real mpoly) x i) x = 0"
	using not_in_isovarspar varNotIn_degree by blast


	end

File Metadata

Mime Type: application/octet-stream
Expires: Tue, May 21, 11:16 PM (1 d, 23 h)
Storage Engine: chunks
Storage Format: Chunks
Storage Handle: N3uXRaPMd7qE
Default Alt Text: (5 MB)

Offset	End	Complete
0	4194304	Yes
4194304	5842830	Yes

No OneTemporaryActions

View Options

File Metadata

Event Timeline

No OneTemporary
Actions